freepascal
/
utils
1
0
フォーク 0
コード 課題 0 プルリクエスト 0 リリース 0 Wiki アクティビティ
ソースを参照

* refactored uutlHandleManager 

* removed uutlStored
* small improvements and bug fixing
master
Bergmann89 9年前
親
851bd40eb5
コミット
ff4dc341c9
16個のファイルの変更、1147行の追加、925行の削除
分割表示
差分オプション
統計情報を表示 Patchファイルをダウンロード Diffファイルをダウンロード
  1. +8
    -12
      bitSpaceUtils.lpk
  2. +1
    -2
      bitSpaceUtils.pas
  3. +5
    -1
      tests/tests.lpi
  4. +1
    -1
      tests/tests.lpr
  5. +299
    -281
      tests/tests.lps
  6. +181
    -0
      tests/uutlHandleManagerTests.pas
  7. +2
    -2
      tests/uutlObservableHashSetTests.pas
  8. +2
    -2
      tests/uutlObservableListTests.pas
  9. +9
    -3
      tests/uutlObservableMapTests.pas
  10. +35
    -4
      uutlCommon.pas
  11. +33
    -16
      uutlEvent.pas
  12. +49
    -10
      uutlEventManager.pas
  13. +509
    -81
      uutlGenerics.pas
  14. +12
    -12
      uutlObservable.pas
  15. +0
    -496
      uutlStored.pas
  16. +1
    -2
      uutlSyncObjs.pas

+ 8
- 12
bitSpaceUtils.lpk ファイルの表示

@@ -11,7 +11,7 @@
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Files Count="31">
<Files Count="30">
<Item1>
<Filename Value="uutlAlgorithm.pas"/>
<UnitName Value="uutlAlgorithm"/>
@@ -117,25 +117,21 @@
<UnitName Value="uutlXmlHelper"/>
</Item26>
<Item27>
<Filename Value="uutlStored.pas"/>
<UnitName Value="uutlStored"/>
</Item27>
<Item28>
<Filename Value="uutlVariantObject.pas"/>
<UnitName Value="uutlVariantObject"/>
</Item28>
<Item29>
</Item27>
<Item28>
<Filename Value="uutlVariantProperty.pas"/>
<UnitName Value="uutlVariantProperty"/>
</Item29>
<Item30>
</Item28>
<Item29>
<Filename Value="uutlVariantEnum.pas"/>
<UnitName Value="uutlVariantEnum"/>
</Item30>
<Item31>
</Item29>
<Item30>
<Filename Value="uutlVariantSet.pas"/>
<UnitName Value="uutlVariantSet"/>
</Item31>
</Item30>
</Files>
<RequiredPkgs Count="2">
<Item1>


+ 1
- 2
bitSpaceUtils.pas ファイルの表示

@@ -11,8 +11,7 @@ uses
uutlAlgorithm, uutlArrayContainer, uutlCommon, uutlComparer, uutlCompression, uutlEmbeddedProfiler, uutlEnumerator,
uutlEvent, uutlEventManager, uutlFilter, uutlGenerics, uutlInterfaces, uutlKeyCodes, uutlLinq, uutlListBase,
uutlLogger, uutlMCF, uutlObservable, uutlSScanf, uutlStreamHelper, uutlSyncObjs, uutlThreads, uutlTypes,
uutlXmlHelper, uutlStored, uutlVariantObject, uutlVariantProperty, uutlVariantEnum, uutlVariantSet,
LazarusPackageIntf;
uutlXmlHelper, uutlVariantObject, uutlVariantProperty, uutlVariantEnum, uutlVariantSet, LazarusPackageIntf;

implementation



+ 5
- 1
tests/tests.lpi ファイルの表示

@@ -33,7 +33,7 @@
<PackageName Value="FCL"/>
</Item3>
</RequiredPackages>
<Units Count="40">
<Units Count="41">
<Unit0>
<Filename Value="tests.lpr"/>
<IsPartOfProject Value="True"/>
@@ -194,6 +194,10 @@
<Filename Value="uutlVariantSetTest.pas"/>
<IsPartOfProject Value="True"/>
</Unit39>
<Unit40>
<Filename Value="uutlHandleManagerTests.pas"/>
<IsPartOfProject Value="True"/>
</Unit40>
</Units>
</ProjectOptions>
<CompilerOptions>


+ 1
- 1
tests/tests.lpr ファイルの表示

@@ -17,7 +17,7 @@ uses
// units unter test
uutlAlgorithm, uutlArrayContainer, uutlCommon, uutlComparer, uutlEnumerator, uutlFilter, uutlGenerics, uutlInterfaces,
uutlLinq, uutlListBase, uutlLogger, uutlStreamHelper, uutlSyncObjs, uutlTypes, uutlXmlHelper, uutlObservable,
uutlSetHelperTests, uutlVariantEnumTest, uutlVariantSetTest;
uutlSetHelperTests, uutlVariantEnumTest, uutlVariantSetTest, uutlHandleManagerTests;

{$R *.res}



+ 299
- 281
tests/tests.lps
ファイル差分が大きすぎるため省略します
ファイルの表示


+ 181
- 0
tests/uutlHandleManagerTests.pas ファイルの表示

@@ -0,0 +1,181 @@
unit uutlHandleManagerTests;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, TestFramework,
uutlGenerics;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TStringHandleManager = specialize TutlHandleManager<String>;
TutlHandleManagerTests = class(TTestCase)
private
fManager: TStringHandleManager;

public
procedure SetUp; override;
procedure TearDown; override;

published
procedure Add;
procedure GetValue;
procedure SetValue;
procedure ComplexAddAndRemove;
procedure Enumerate;
end;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlHandleManagerTests////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManagerTests.SetUp;
begin
inherited SetUp;
fManager := TStringHandleManager.Create(true);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManagerTests.TearDown;
begin
FreeAndNil(fManager);
inherited TearDown;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManagerTests.Add;
var
h: TutlHandle;
begin
h := fManager.Add(0, 0, 'test');
AssertEquals($0000000100000000, h);

h := fManager.Add(1, 0, 'test');
AssertEquals($0001000100000001, h);

h := fManager.Add(2, 0, 'test');
AssertEquals($0002000100000002, h);

h := fManager.Add(0, 1, 'test');
AssertEquals($0100000100000000, h);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManagerTests.GetValue;
var
h: TutlHandle;
s: String;
b: Boolean;
begin
h := fManager.Add(0, 0, 'test');
b := fManager.TryGetValue(h, s);
AssertTrue (b);
AssertEquals('test', s);

b := fManager.TryGetValue(123, s);
AssertFalse(b);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManagerTests.SetValue;
var
b: Boolean;
s: String;
begin
b := fManager.TrySetValue($0000000100000010, 'test');
AssertTrue(b);

b := fManager.TryGetValue($0000000100000010, s);
AssertTrue (b);
AssertEquals('test', s);

b := fManager.TrySetValue($0000000100000010, 'hello');
AssertTrue(b);

b := fManager.TryGetValue($0000000100000010, s);
AssertTrue (b);
AssertEquals('hello', s);

b := fManager.TrySetValue($0000000200000010, 'blubb');
AssertFalse(b);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManagerTests.ComplexAddAndRemove;
var
h1, h2, h3, h4, h5: TutlHandle;
b: Boolean;
begin
h1 := fManager.Add(0, 0, '1');
AssertEquals($0000000100000000, h1);

h2 := fManager.Add(0, 0, '2');
AssertEquals($0000000100000001, h2);

h3 := fManager.Add(0, 0, '3');
AssertEquals($0000000100000002, h3);

h4 := fManager.Add(0, 0, '4');
AssertEquals($0000000100000003, h4);

h5 := fManager.Add(0, 0, '5');
AssertEquals($0000000100000004, h5);

b := fManager.Remove(h2);
AssertTrue(b);

h2 := fManager.Add(0, 0, '12');
AssertEquals($0000000200000001, h2);

b := fManager.Remove(h4);
AssertTrue(b);

b := fManager.Remove(h3);
AssertTrue(b);

h3 := fManager.Add(0, 0, '13');
AssertEquals($0000000200000002, h3);

h4 := fManager.Add(0, 0, '14');
AssertEquals($0000000200000003, h4);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManagerTests.Enumerate;
var
h, h1, h2, h3: TutlHandle;
b: Boolean;
e: TStringHandleManager.IEnumerator;
begin
e := fManager.GetEnumerator;

h1 := fManager.Add(0, 0, '1');
h2 := fManager.Add(0, 0, '2');
h3 := fManager.Add(0, 0, '3');

b := e.MoveNext;
AssertTrue(b);
h := e.Current;
AssertTrue(h1 = h);

b := e.MoveNext;
AssertTrue(b);
h := e.Current;
AssertTrue(h2 = h);

b := e.MoveNext;
AssertTrue(b);
h := e.Current;
AssertTrue(h3 = h);

b := e.MoveNext;
AssertFalse(b);
end;

initialization
RegisterTest(TutlHandleManagerTests.Suite);
end.


+ 2
- 2
tests/uutlObservableHashSetTests.pas ファイルの表示

@@ -19,7 +19,7 @@ type
fEventArgs: TEventArgList;
fEventListener: IutlEventListener;

procedure EventHandler(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure EventHandler(aSender: TObject; aEventArgs: IutlEventArgs);

public
procedure SetUp; override;
@@ -37,7 +37,7 @@ implementation
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlObservableHashSetTests////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableHashSetTests.EventHandler(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlObservableHashSetTests.EventHandler(aSender: TObject; aEventArgs: IutlEventArgs);
begin
if fCaptureEvents then
fEventArgs.Add(aEventArgs);


+ 2
- 2
tests/uutlObservableListTests.pas ファイルの表示

@@ -19,7 +19,7 @@ type
fEventArgs: TEventArgList;
fEventListener: IutlEventListener;

procedure EventHandler(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure EventHandler(aSender: TObject; aEventArgs: IutlEventArgs);

public
procedure SetUp; override;
@@ -37,7 +37,7 @@ implementation
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlObservableListTests///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableListTests.EventHandler(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlObservableListTests.EventHandler(aSender: TObject; aEventArgs: IutlEventArgs);
begin
if fCaptureEvents then
fEventArgs.Add(aEventArgs);


+ 9
- 3
tests/uutlObservableMapTests.pas ファイルの表示

@@ -19,7 +19,7 @@ type
fEventArgs: TEventArgList;
fEventListener: IutlEventListener;

procedure EventHandler(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure EventHandler(aSender: TObject; aEventArgs: IutlEventArgs);

public
procedure SetUp; override;
@@ -37,7 +37,7 @@ implementation
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlObservableMapTests////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableMapTests.EventHandler(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlObservableMapTests.EventHandler(aSender: TObject; aEventArgs: IutlEventArgs);
begin
if fCaptureEvents then
fEventArgs.Add(aEventArgs);
@@ -154,9 +154,15 @@ begin

fMap.Clear;

AssertEquals(1, fEventArgs.Count);
AssertEquals(4, fEventArgs.Count);
AssertTrue (Supports(fEventArgs[0], TutlObservableEventArgs, ea));
AssertTrue (oetClear = ea.EventType);
AssertTrue (Supports(fEventArgs[1], TutlObservableEventArgs, ea));
AssertTrue (oetRemove = ea.EventType);
AssertTrue (Supports(fEventArgs[2], TutlObservableEventArgs, ea));
AssertTrue (oetRemove = ea.EventType);
AssertTrue (Supports(fEventArgs[3], TutlObservableEventArgs, ea));
AssertTrue (oetRemove = ea.EventType);
end;

initialization


+ 35
- 4
uutlCommon.pas ファイルの表示

@@ -24,7 +24,12 @@ type
property AutoFree: Boolean read fAutoFree write fAutoFree;
property RefCount: LongInt read fRefCount;

procedure AfterConstruction; override;

constructor Create;

public
class function NewInstance: TObject; override;
end;
TutlInterfaceNoRefCount = TutlInterfacedObject;

@@ -61,6 +66,7 @@ type
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
EInternal = class(Exception);
EOutOfRangeException = class(Exception)
private
fMin: Integer;
@@ -92,6 +98,7 @@ function GetPlatformIdentitfier(): String;
function utlRateLimited (const Reference: QWord; const Interval: QWord): boolean;
function utlFinalizeObject (var obj; const aTypeInfo: PTypeInfo; const aFreeObject: Boolean): Boolean;
function utlFilterBuilder (): IutlFilterBuilder;
function utlBitCount (const aValue: DWord): Integer;

implementation

@@ -303,6 +310,16 @@ begin
result := TFilterBuilderImpl.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function utlBitCount(const aValue: DWord): Integer;
var
t: DWord;
begin
t := aValue - ((aValue shr 1) and &33333333333)
- ((aValue shr 2) and &11111111111);
result := ((t + (t shr 3)) and &30707070707) mod 63;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlInterfacedObject///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
@@ -317,23 +334,37 @@ end;
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfacedObject._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result := InterLockedIncrement(fRefCount);
_AddRef := interlockedincrement(fRefCount);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfacedObject._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result := InterLockedDecrement(fRefCount);
if (result = 0) and fAutoFree then
_Release := InterLockedDecrement(fRefCount);
if (_Release = 0) and fAutoFree then
Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlInterfacedObject.AfterConstruction;
begin
inherited AfterConstruction;
InterLockedDecrement(fRefCount);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlInterfacedObject.Create;
begin
inherited Create;
fAutoFree := false;
fRefCount := 0;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlInterfacedObject.NewInstance: TObject;
begin
result := inherited NewInstance;
if Assigned(result) then
TutlInterfacedObject(result).fRefCount := 1;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


+ 33
- 16
uutlEvent.pas ファイルの表示

@@ -17,11 +17,11 @@ type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlEventListener = interface(IUnknown)
['{BC45E26B-96F7-4151-87F1-C330C8C668E5}']
procedure DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlEventHandler = procedure (constref aSender: TObject; constref aEventArgs: IutlEventArgs) of object;
TutlEventHandler = procedure (aSender: TObject; aEventArgs: IutlEventArgs) of object;
TutlEventArgs = class(TutlInterfacedObject, IutlEventArgs)
public
constructor Create;
@@ -30,8 +30,8 @@ type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlObservable = interface(IUnknown)
['{C54BD844-8273-4ACF-90C5-05DACF4359AF}']
procedure RegisterEventListener (constref aListener: IutlEventListener);
procedure UnregisterEventListener(constref aListener: IutlEventListener);
procedure RegisterEventListener (aListener: IutlEventListener);
procedure UnregisterEventListener(aListener: IutlEventListener);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
@@ -49,12 +49,12 @@ type
TutlNotifyEventList = specialize TutlEventList<TNotifyEvent>;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlEventHandlerList = class(
TutlEventListenerList = class(
specialize TutlEventList<TutlEventHandler>
, IutlEventListener)

public { IutlEventListener }
procedure DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);

public
constructor Create;
@@ -63,7 +63,8 @@ type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlEventListenerSet = class(
specialize TutlCustomHashSet<IutlEventListener>
, IutlEventListener)
, IutlEventListener
, IutlObservable)

private type
TComparer = class(TInterfacedObject, IComparer)
@@ -73,7 +74,11 @@ type
end;

public { IutlEventListener }
procedure DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);

public { IutlObservable }
procedure RegisterEventListener (aListener: IutlEventListener);
procedure UnregisterEventListener(aListener: IutlEventListener);

public
constructor Create; reintroduce;
@@ -88,7 +93,7 @@ type
fHandler: TutlEventHandler;

public { IEventListener }
procedure DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);

public
constructor Create(const aHandler: TutlEventHandler);
@@ -114,7 +119,7 @@ type
function PopEventPair(out aPair: TEventPair): Boolean;

public { IEventListener }
procedure DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);

public
procedure DispatchEvents;
@@ -169,9 +174,9 @@ begin
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventHandlerList///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventListenerList//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventHandlerList.DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlEventListenerList.DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);
var
e: TutlEventHandler;
begin
@@ -180,7 +185,7 @@ begin
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventHandlerList.Create;
constructor TutlEventListenerList.Create;
begin
inherited Create;
AutoFree := true;
@@ -208,7 +213,7 @@ end;
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventListenerSet///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventListenerSet.DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlEventListenerSet.DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);
var
e: IutlEventListener;
begin
@@ -216,6 +221,18 @@ begin
e.DispatchEvent(aSender, aEventArgs);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventListenerSet.RegisterEventListener(aListener: IutlEventListener);
begin
Add(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventListenerSet.UnregisterEventListener(aListener: IutlEventListener);
begin
Remove(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventListenerSet.Create;
begin
@@ -225,7 +242,7 @@ end;
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventListenerCallback//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventListenerCallback.DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlEventListenerCallback.DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);
begin
fHandler(aSender, aEventArgs);
end;
@@ -266,7 +283,7 @@ begin
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlEventListenerAsync.DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlEventListenerAsync.DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);
var
p: TEventPair;
begin


+ 49
- 10
uutlEventManager.pas ファイルの表示

@@ -10,7 +10,7 @@ interface

uses
Classes, SysUtils, Controls,
uutlEvent;
uutlEvent, uutlCommon;

type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
@@ -110,7 +110,10 @@ type
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlWinControlEventManager = class(TutlEventListenerSet)
TutlWinControlEventManager = class(
TutlInterfacedObject
, IutlObservable)

public const
EVENT_MOUSE_DOWN = 0;
EVENT_MOUSE_UP = 1;
@@ -186,6 +189,7 @@ type
fKeyboard: TKeyboardState;
fMouse: TMouseState;
fWindow: TWindowState;
fEventListener: TutlEventListenerSet;

procedure HandlerMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure HandlerMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
@@ -204,7 +208,8 @@ type
procedure HandlerDeactivate (Sender: TObject);

protected
procedure RecordEvent(constref aEventArgs: IutlEventArgs); virtual;
procedure RecordEvent(aEventArgs: IutlEventArgs); virtual;
procedure DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);

function CreateMouseEventArgs(
aControl: TControl;
@@ -226,20 +231,26 @@ type
aControl: TControl;
aType: TutlEventType): IutlEventArgs; virtual;

public { IutlObservable }
procedure RegisterEventListener (aListener: IutlEventListener);
procedure UnregisterEventListener(aListener: IutlEventListener);

public
property Keyboard: TKeyboardState read fKeyboard;
property Mouse: TMouseState read fMouse;
property Window: TWindowState read fWindow;

procedure DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure AttachEvents (const aControl: TWinControl; const aTypes: TutlEventTypes);
procedure AttachEvents(const aControl: TWinControl; const aTypes: TutlEventTypes);

constructor Create;
destructor Destroy; override;
end;

implementation

uses
LCLIntf, Forms,
uutlKeyCodes, uutlCommon;
uutlKeyCodes;

type
TWinControlVisibilityClass = class(TWinControl)
@@ -416,7 +427,7 @@ begin
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.RecordEvent(constref aEventArgs: IutlEventArgs);
procedure TutlWinControlEventManager.RecordEvent(aEventArgs: IutlEventArgs);
var
mea: TutlMouseEventArgs;
kea: TutlKeyEventArgs;
@@ -491,6 +502,13 @@ begin
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.DispatchEvent(aSender: TObject; aEventArgs: IutlEventArgs);
begin
RecordEvent(aEventArgs);
fEventListener.DispatchEvent(aSender, aEventArgs);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlWinControlEventManager.CreateMouseEventArgs(
aControl: TControl;
@@ -552,10 +570,17 @@ begin
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.DispatchEvent(constref aSender: TObject; constref aEventArgs: IutlEventArgs);
procedure TutlWinControlEventManager.RegisterEventListener(aListener: IutlEventListener);
begin
RecordEvent(aEventArgs);
inherited DispatchEvent(aSender, aEventArgs);
if Assigned(fEventListener) then
fEventListener.Add(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlWinControlEventManager.UnregisterEventListener(aListener: IutlEventListener);
begin
if Assigned(fEventListener) then
fEventListener.Remove(aListener);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
@@ -595,5 +620,19 @@ begin
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlWinControlEventManager.Create;
begin
inherited Create;
fEventListener := TutlEventListenerSet.Create;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlWinControlEventManager.Destroy;
begin
FreeAndNil(fEventListener);
inherited Destroy;
end;

end.


+ 509
- 81
uutlGenerics.pas ファイルの表示

@@ -1,6 +1,7 @@
unit uutlGenerics;

{$mode objfpc}{$H+}
{$modeswitch advancedrecords}

interface

@@ -198,7 +199,7 @@ type
function Extract (const aItem: T; const aDefault: T): T; overload;
function Remove (const aItem: T): Integer;

constructor Create (const aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
constructor Create (aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
destructor Destroy; override;
end;

@@ -241,7 +242,7 @@ type
function Remove (constref aItem: T): Boolean;
procedure Delete (const aIndex: Integer);

constructor Create (const aComparer: IComparer; const aOwnsItems: Boolean);
constructor Create (aComparer: IComparer; const aOwnsItems: Boolean);
destructor Destroy; override;
end;

@@ -287,7 +288,7 @@ type
procedure Release(var aItem: TKeyValuePair; const aFreeItem: Boolean); override;

public
constructor Create(const aOwner: TutlCustomMap; const aComparer: IComparer);
constructor Create(const aOwner: TutlCustomMap; aComparer: IComparer);
end;

////////////////////////////////////////////////////////////////////////////////////////////////
@@ -479,7 +480,10 @@ type

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlHandle = QWord;
generic TutlHandleManager<T> = class(TObject)
generic TutlHandleManager<T> = class(
TutlInterfacedObject
, specialize IutlEnumerable<TutlHandle>)

private type
THandleData = packed record
case Integer of
@@ -488,47 +492,124 @@ type
);

1: (
Index: Cardinal; // 0..31
Counter: Word; // 32..47
Identifier: Word // 48..63
Index: Cardinal; // 0..31 index in data array (unique for each priority)
Counter: Word; // 32..47 reusage counter
TypeID: Byte; // 48..55 Stored Data Type
Priority: Byte; // 56..63 Priority to share handles between multiple systems
);
end;

THandleEntry = bitpacked record
Data: T;
NextFreeIndex: Cardinal; // 0..31
Counter: Word; // 32..47
IsActive: Boolean; // 48
__reserved: 0..((1 shl 15)-1); // 49..63
TIndex = Cardinal;
TEntryStatus = byte;
PHandleEntry = ^THandleEntry;
THandleEntry = packed record
Next: TIndex; // 0..31 next used/free item
Prev: TIndex; // 32..63 prev used/free item
Counter: Word; // 64..79 current counter value
Status: TEntryStatus; // 80..87 item status
TypeID: Byte; // 88..95 type id
Data: T; // actual data
end;

THandleEntries = array of THandleEntry;
PPriorityItem = ^TPriorityItem;
TPriorityItem = packed record
FirstFree: TIndex;
LastFree: TIndex;
FirstUsed: TIndex;
LastUsed: TIndex;
Handles: THandleEntries;

function GetHandleEntry(const aIndex: TIndex): PHandleEntry;
procedure Grow(const aSize: Integer = 0);

procedure PushFront(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);
procedure PushBack (const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);
procedure Remove (const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);

function PopFront(var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;
function PopBack (var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;

procedure PushFrontFreeIndex(const aIndex: TIndex); inline;
procedure PushBackFreeIndex (const aIndex: TIndex); inline;
procedure PushFrontUsedIndex(const aIndex: TIndex); inline;
procedure PushBackUsedIndex (const aIndex: TIndex); inline;
procedure RemoveFreeIndex (const aIndex: TIndex); inline;
procedure RemoveUsedIndex (const aIndex: TIndex); inline;

function PopFrontFreeIndex: TIndex;
function PopBackFreeIndex: TIndex;
function PopFrontUsedIndex: TIndex;
function PopBackUsedIndex: TIndex;
end;

TPriorityItems = array of TPriorityItem;

TEnumerator = class(specialize TutlEnumerator<TutlHandle>)
private
fOwner: TutlHandleManager;
fPriority: Integer;
fIndex: TIndex;
fHandle: THandleEntry;

protected
function InternalMoveNext: Boolean; override;
procedure InternalReset; override;

public
function GetCurrent: TutlHandle; override;

constructor Create(const aOwner: TutlHandleManager);
end;

private const
UNKNOWN_INDEX: TIndex = high(TIndex);
GROW_SIZE = 100;

ENTRY_STATUS_UNKNOWN: byte = 0;
ENTRY_STATUS_FREE: byte = 1;
ENTRY_STATUS_USED: byte = 2;

private
class function HighIndex(constref aEntries: THandleEntries): TIndex; inline;

public type
IEnumerator = specialize IEnumerator<TutlHandle>;
IutlEnumerator = specialize IutlEnumerator<TutlHandle>;

private
fCount: Integer;
fGrowSize: Integer;
fEntries: array of THandleEntry;
fFirstFreeIndex: Cardinal;
fItems: TPriorityItems;
fOwnsValues: Boolean;

procedure Grow;
function GetPriorityItem(const aPriority: Byte): PPriorityItem;

public
function Get (const aHandle: TutlHandle): T;
function TryGet (const aHandle: TutlHandle; out aData: T): Boolean;
function Add (constref aData: T; const aIdentifier: Word): TutlHandle;
function IsValid(const aHandle: TutlHandle): Boolean; inline;
procedure Update (const aHandle: TutlHandle; aData: T);
procedure Remove (const aHandle: TutlHandle);
function GetValue (const aHandle: TutlHandle): T;
function TryGetValue (const aHandle: TutlHandle; out aData: T): Boolean;
procedure SetValue (const aHandle: TutlHandle; aData: T);
function TrySetValue (const aHandle: TutlHandle; aData: T): Boolean;
function Add (const aTypeID: Byte; const aPriority: Byte; constref aData: T): TutlHandle;
function IsValid (const aHandle: TutlHandle): Boolean; inline;
procedure Update (const aHandle: TutlHandle; aData: T);
function Remove (const aHandle: TutlHandle): Boolean;
procedure Delete (const aHandle: TutlHandle);
procedure Clear;

public { IutlEnumerable }
function GetEnumerator: IEnumerator;
function GetUtlEnumerator: IutlEnumerator;

public
property Items[const aHandle: TutlHandle]: T read Get write Update;
property Items[const aHandle: TutlHandle]: T read GetValue write SetValue; default;
property Count: Integer read fCount;

constructor Create(const aOwnsValues: Boolean);
destructor Destroy; override;

public
class function GetIdentifier(const aHandle: TutlHandle): Word; inline;
class function GetTypeID (const aHandle: TutlHandle): Byte; inline;
class function GetPriority(const aHandle: TutlHandle): Byte; inline;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
@@ -1180,7 +1261,7 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlCustomList.Create(const aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
constructor TutlCustomList.Create(aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
begin
if not Assigned(aEqualityComparer) then
raise EArgumentNilException.Create('aEqualityComparer');
@@ -1261,7 +1342,7 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlCustomHashSet.Create(const aComparer: IComparer; const aOwnsItems: Boolean);
constructor TutlCustomHashSet.Create(aComparer: IComparer; const aOwnsItems: Boolean);
begin
inherited Create(aOwnsItems);
fComparer := aComparer;
@@ -1295,7 +1376,7 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlCustomMap.THashSet.Create(const aOwner: TutlCustomMap; const aComparer: IComparer);
constructor TutlCustomMap.THashSet.Create(const aOwner: TutlCustomMap; aComparer: IComparer);
begin
inherited Create(aComparer, true);
fOwner := aOwner;
@@ -1681,69 +1762,388 @@ begin
FreeAndNil(fHashSetImpl);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlHandleManager.TPriorityItem////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TPriorityItem.GetHandleEntry(const aIndex: TIndex): PHandleEntry;
begin
if (aIndex > HighIndex(Handles)) then
Grow;
result := @Handles[aIndex];
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.Grow(const aSize: Integer);
var
oldIdx, newIdx, i: TIndex;
begin
oldIdx := Length(Handles);
if (aSize = 0) then
SetLength(Handles, Length(Handles) + GROW_SIZE)
else if (Length(Handles) >= aSize) then
exit
else
SetLength(Handles, aSize);
newIdx := High(Handles);
for i := oldIdx to newIdx do begin
FillByte(Handles[i].Data, SizeOf(T), 0);
Handles[i].Counter := 0;
Handles[i].Status := ENTRY_STATUS_UNKNOWN;
Handles[i].Next := High(TIndex);
Handles[i].Prev := High(TIndex);
PushBackFreeIndex(i);
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.PushFront(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex;
const aStatus: TEntryStatus);
begin
Assert(aIndex <= HighIndex(Handles));
Assert(Handles[aIndex].Status = ENTRY_STATUS_UNKNOWN);
if (FirstIndex <> UNKNOWN_INDEX)
and (FirstIndex <= HighIndex(Handles))
and (Handles[FirstIndex].Status = aStatus)
then
Handles[FirstIndex].Prev := aIndex;
with Handles[aIndex] do begin
Prev := UNKNOWN_INDEX;
Next := FirstIndex;
Status := aStatus;
end;
FirstIndex := aIndex;
if (LastIndex = UNKNOWN_INDEX) then
LastIndex := aIndex;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.PushBack(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex;
const aStatus: TEntryStatus);
begin
Assert(aIndex <= HighIndex(Handles));
Assert(Handles[aIndex].Status = ENTRY_STATUS_UNKNOWN);
if (LastIndex <> UNKNOWN_INDEX)
and (LastIndex <= HighIndex(Handles))
and (Handles[LastIndex].Status = aStatus)
then
Handles[LastIndex].Next := aIndex;
with Handles[aIndex] do begin
Prev := LastIndex;
Next := UNKNOWN_INDEX;
Status := aStatus;
end;
LastIndex := aIndex;
if (FirstIndex = UNKNOWN_INDEX) then
FirstIndex := aIndex;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.Remove(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);
begin
Assert(aIndex <> UNKNOWN_INDEX);
Assert(aIndex <= HighIndex(Handles));
Assert(Handles[aIndex].Status = aStatus);
with Handles[aIndex] do begin
if (Prev <> UNKNOWN_INDEX) then begin
Assert(Prev <= HighIndex(Handles));
Handles[Prev].Next := Next;
end;
if (Next <> UNKNOWN_INDEX) then begin
Assert(Next <= HighIndex(Handles));
Handles[Next].Prev := Prev;
end;
if (aIndex = FirstIndex) then
FirstIndex := Next;
if (aIndex = LastIndex) then
LastIndex := Prev;
Prev := UNKNOWN_INDEX;
Next := UNKNOWN_INDEX;
Status := ENTRY_STATUS_UNKNOWN;
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TPriorityItem.PopFront(var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;
begin
if aCanGrow
and ( (FirstIndex = UNKNOWN_INDEX)
or (FirstIndex > HighIndex(Handles)))
then
Grow;
Assert(FirstIndex <> UNKNOWN_INDEX);
Assert(FirstIndex <= HighIndex(Handles));
Assert(Handles[FirstIndex].Status = aStatus);
result := FirstIndex;
with Handles[result] do begin
if (LastIndex = FirstIndex) then
LastIndex := Next;
FirstIndex := Next;
Prev := UNKNOWN_INDEX;
Next := UNKNOWN_INDEX;
Status := ENTRY_STATUS_UNKNOWN;
end;
if (FirstIndex <> UNKNOWN_INDEX)
and (FirstIndex <= HighIndex(Handles))
and (Handles[FirstIndex].Status = aStatus)
then
Handles[FirstIndex].Prev := UNKNOWN_INDEX;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TPriorityItem.PopBack(var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;
begin
if aCanGrow
and ( (LastIndex <> UNKNOWN_INDEX)
or (LastIndex <= HighIndex(Handles)))
then
Grow;
Assert(LastIndex <> UNKNOWN_INDEX);
Assert(LastIndex <= HighIndex(Handles));
Assert(Handles[LastIndex].Status = aStatus);
result := LastIndex;
with Handles[result] do begin
if (FirstIndex = LastIndex) then
FirstIndex := Next;
LastIndex := Prev;
Prev := UNKNOWN_INDEX;
Next := UNKNOWN_INDEX;
Status := ENTRY_STATUS_UNKNOWN;
end;
if (LastIndex <> UNKNOWN_INDEX)
and (LastIndex <= HighIndex(Handles))
and (Handles[LastIndex].Status = aStatus)
then
Handles[LastIndex].Next := UNKNOWN_INDEX;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.PushFrontFreeIndex(const aIndex: TIndex);
begin
PushFront(aIndex, FirstFree, LastFree, ENTRY_STATUS_FREE);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.PushBackFreeIndex(const aIndex: TIndex);
begin
PushBack(aIndex, FirstFree, LastFree, ENTRY_STATUS_FREE);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.PushFrontUsedIndex(const aIndex: TIndex);
begin
PushFront(aIndex, FirstUsed, LastUsed, ENTRY_STATUS_USED);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.PushBackUsedIndex(const aIndex: TIndex);
begin
PushBack(aIndex, FirstUsed, LastUsed, ENTRY_STATUS_USED);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.RemoveFreeIndex(const aIndex: TIndex);
begin
Remove(aIndex, FirstFree, LastFree, ENTRY_STATUS_FREE);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TPriorityItem.RemoveUsedIndex(const aIndex: TIndex);
begin
Remove(aIndex, FirstUsed, LastUsed, ENTRY_STATUS_USED);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TPriorityItem.PopFrontFreeIndex: TIndex;
begin
result := PopFront(FirstFree, LastFree, ENTRY_STATUS_FREE, true);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TPriorityItem.PopBackFreeIndex: TIndex;
begin
result := PopBack(FirstFree, LastFree, ENTRY_STATUS_FREE, false);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TPriorityItem.PopFrontUsedIndex: TIndex;
begin
result := PopFront(FirstUsed, LastUsed, ENTRY_STATUS_USED, false);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TPriorityItem.PopBackUsedIndex: TIndex;
begin
result := PopBack(FirstUsed, LastUsed, ENTRY_STATUS_USED, false);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlHandleManager.TEnumerator//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TEnumerator.InternalMoveNext: Boolean;
var
p: PPriorityItem;
begin
repeat
if (fIndex = UNKNOWN_INDEX) then begin
inc(fPriority);
if (fPriority > High(fOwner.fItems)) then
break;
p := fOwner.GetPriorityItem(fPriority);
fIndex := p^.FirstUsed;
end else begin
p := fOwner.GetPriorityItem(fPriority);
fIndex := p^.Handles[fIndex].Next;
if (fIndex > HighIndex(p^.Handles)) then
fIndex := UNKNOWN_INDEX;
end;
until (fPriority > High(fOwner.fItems)) or (fIndex <> UNKNOWN_INDEX);
result := (fPriority <= High(fOwner.fItems));
if result then begin
p := fOwner.GetPriorityItem(fPriority);
fHandle := p^.Handles[fIndex];
end else
FillByte(fHandle, SizeOf(fHandle), 0);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.TEnumerator.InternalReset;
begin
fPriority := -1;
fIndex := UNKNOWN_INDEX;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TEnumerator.GetCurrent: TutlHandle;
begin
if (fHandle.Status <> ENTRY_STATUS_USED) then
raise EInvalidOperation.Create('enumerator not initialized or collection changed');
with THandleData(result) do begin
Index := fIndex;
Counter := fHandle.Counter;
TypeID := fHandle.TypeID;
Priority := fPriority;
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlHandleManager.TEnumerator.Create(const aOwner: TutlHandleManager);
begin
if not Assigned(aOwner) then
raise EArgumentNilException.Create('aOwner');
inherited Create;
fOwner := aOwner;
FillByte(fHandle, SizeOf(fHandle), 0);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlHandleManager Class Methods////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlHandleManager.HighIndex(constref aEntries: THandleEntries): TIndex;
begin
result := TIndex(High(aEntries));
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlHandleManager//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.Grow;
function TutlHandleManager.GetPriorityItem(const aPriority: Byte): PPriorityItem;
var
oldIdx, newIdx, i: Integer;
begin
oldIdx := High(fEntries);
SetLength(fEntries, Length(fEntries) + fGrowSize);
newIdx := High(fEntries);
for i := oldIdx to newIdx do
fEntries[i].NextFreeIndex := i + 1;
if (aPriority > High(fItems)) then begin
oldIdx := Length(fItems);
SetLength(fItems, aPriority + 1);
newIdx := High(fItems);
for i := oldIdx to newIdx do with fItems[i] do begin
FirstFree := UNKNOWN_INDEX;
LastFree := UNKNOWN_INDEX;
FirstUsed := UNKNOWN_INDEX;
LastUsed := UNKNOWN_INDEX;
SetLength(Handles, 0);
end;
end;
result := @fItems[aPriority];
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.Get(const aHandle: TutlHandle): T;
function TutlHandleManager.GetValue(const aHandle: TutlHandle): T;
begin
if not TryGet(aHandle, result) then
if not TryGetValue(aHandle, result) then
raise EArgumentException.Create('unknown or invalid handle');
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TryGet(const aHandle: TutlHandle; out aData: T): Boolean;
function TutlHandleManager.TryGetValue(const aHandle: TutlHandle; out aData: T): Boolean;
begin
result := IsValid(aHandle);
with THandleData(aHandle) do begin
result := IsValid(aHandle);
if result
then aData := fEntries[Index].Data
then aData := fItems[Priority].Handles[Index].Data
else FillByte(aData, SizeOf(T), 0);
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.Add(constref aData: T; const aIdentifier: Word): TutlHandle;
procedure TutlHandleManager.SetValue(const aHandle: TutlHandle; aData: T);
begin
if not TrySetValue(aHandle, aData) then
raise EArgumentException.Create('unknown or invalid handle');
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.TrySetValue(const aHandle: TutlHandle; aData: T): Boolean;
var
p: PPriorityItem;
h: PHandleEntry;
begin
if not IsValid(aHandle) then with THandleData(aHandle) do begin
p := GetPriorityItem(Priority);
p^.Grow(Index + 1);
h := p^.GetHandleEntry(Index);
result := (h^.Status = ENTRY_STATUS_FREE);
if result then begin
p^.RemoveFreeIndex (Index);
p^.PushBackUsedIndex(Index);
h^.Counter := Counter;
h^.Data := aData;
end;
end else
Update(aHandle, aData);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.Add(const aTypeID: Byte; const aPriority: Byte; constref aData: T): TutlHandle;
var
p: PPriorityItem;
h: PHandleEntry;
i: Integer;
begin
i := fFirstFreeIndex;
if (High(fEntries) < i) then
Grow;
Assert(not fEntries[i].IsActive);
fFirstFreeIndex := fEntries[i].NextFreeIndex;
fEntries[i].NextFreeIndex := 0;
fEntries[i].Counter := fEntries[i].Counter + 1;
if (fEntries[i].Counter = 0) then
fEntries[i].Counter := 1;
fEntries[i].IsActive := true;
fEntries[i].Data := aData;
inc(fCount);
p := GetPriorityItem(aPriority);
i := p^.PopFrontFreeIndex;
p^.PushBackUsedIndex(i);
h := p^.GetHandleEntry(i);
h^.TypeID := aTypeID;
h^.Counter := h^.Counter + 1;
if (h^.Counter = 0) then
h^.Counter := 1;
h^.Data := aData;
with THandleData(result) do begin
Index := i;
Counter := fEntries[i].Counter;
Identifier := aIdentifier;
Index := i;
Counter := h^.Counter;
TypeID := aTypeID;
Priority := aPriority;
end;
inc(fCount);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.IsValid(const aHandle: TutlHandle): Boolean;
begin
with THandleData(aHandle) do begin
result := (fEntries[Index].Counter = Counter)
and (fEntries[Index].IsActive)
and (h.Index <= High(fEntries));
result := (Priority <= High(fItems))
and (Index <= HighIndex(fItems[Priority].Handles))
and (fItems[Priority].Handles[Index].Counter = Counter)
and (fItems[Priority].Handles[Index].Status = ENTRY_STATUS_USED);
end;
end;

@@ -1753,60 +2153,88 @@ begin
if not IsValid(aHandle) then
raise EArgumentException.Create('unknown or invalid handle');
with THandleData(aHandle) do begin
if not utlFinalizeObject(fEntries[Index].Data, TypeInfo(T), fOwnsValues) then
Finalize(fEntries[Index].Data);
fEntries[Index].Data := aData;
if not utlFinalizeObject(fItems[Priority].Handles[Index].Data, TypeInfo(T), fOwnsValues) then
Finalize(fItems[Priority].Handles[Index].Data);
fItems[Priority].Handles[Index].Data := aData;
end;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.Remove(const aHandle: TutlHandle);
function TutlHandleManager.Remove(const aHandle: TutlHandle): Boolean;
var
p: PPriorityItem;
begin
if not IsValid(aHandle) then
raise EArgumentException.Create('unknown or invalid handle');
result := IsValid(aHandle);
if not result then
exit;
with THandleData(aHandle) do begin
fEntries[Index].NextFreeIndex := fFirstFreeIndex;
fEntries[Index].IsActive := false;
fFirstFreeIndex := Index;
if not utlFinalizeObject(fEntries[Index].Data, TypeInfo(T), fOwnsValues) then
Finalize(fEntries[Index].Data);
p := GetPriorityItem(Priority);
p^.RemoveUsedIndex(Index);
p^.PushFrontFreeIndex(Index);
end;
dec(fCount);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.Delete(const aHandle: TutlHandle);
begin
if not Remove(aHandle) then
raise EArgumentException.Create('unknown or invalid handle');
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlHandleManager.Clear;
var
i: Integer;
i, j: Integer;
begin
for i := low(fEntries) to high(fEntries) do begin
if fEntries[i].IsActive and not utlFinalizeObject(fEntries[i].Data, TypeInfo(T), fOwnsValues) then
Finalize(fEntries[i].Data);
for j := low(fItems) to high(fItems) do begin
for i := low(fItems[j].Handles) to high(fItems[j].Handles) do begin
if (fItems[j].Handles[i].Status = ENTRY_STATUS_USED) and not utlFinalizeObject(fItems[j].Handles[i].Data, TypeInfo(T), fOwnsValues) then
Finalize(fItems[j].Handles[i].Data);
FillByte(fItems[j].Handles[i].Data, SizeOf(T), 0);
end;
SetLength(fItems[j].Handles, 0);
end;
SetLength(fEntries, 0);
SetLength(fItems, 0);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.GetEnumerator: IEnumerator;
begin
result := TEnumerator.Create(self);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlHandleManager.GetUtlEnumerator: IutlEnumerator;
begin
result := TEnumerator.Create(self);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlHandleManager.Create(const aOwnsValues: Boolean);
begin
inherited Create;
fGrowSize := 50;
fCount := 0;
fFirstFreeIndex := 0;
fOwnsValues := aOwnsValues;
fCount := 0;
fOwnsValues := aOwnsValues;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlHandleManager.Destroy;
begin
Clear;
// Clear;
inherited Destroy;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlHandleManager.GetIdentifier(const aHandle: TutlHandle): Word;
class function TutlHandleManager.GetTypeID(const aHandle: TutlHandle): Byte;
begin
result := THandleData(aHandle).TypeID;
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlHandleManager.GetPriority(const aHandle: TutlHandle): Byte;
begin
result := THandleData(aHandle).Identifier;
result := THandleData(aHandle).Priority;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


+ 12
- 12
uutlObservable.pas ファイルの表示

@@ -86,8 +86,8 @@ type
procedure DoClear (); virtual;

public { IutlObservable }
procedure RegisterEventListener (constref aListener: IutlEventListener);
procedure UnregisterEventListener(constref aListener: IutlEventListener);
procedure RegisterEventListener (aListener: IutlEventListener);
procedure UnregisterEventListener(aListener: IutlEventListener);

protected
procedure SetItem(const aIndex: Integer; aValue: T); override;
@@ -146,8 +146,8 @@ type
procedure DoClear (); virtual;

public { IutlObservable }
procedure RegisterEventListener (constref aListener: IutlEventListener);
procedure UnregisterEventListener(constref aListener: IutlEventListener);
procedure RegisterEventListener (aListener: IutlEventListener);
procedure UnregisterEventListener(aListener: IutlEventListener);

public
procedure Clear; override;
@@ -213,8 +213,8 @@ type
procedure DoClear (); virtual;

public { IutlObservable }
procedure RegisterEventListener (constref aListener: IutlEventListener);
procedure UnregisterEventListener(constref aListener: IutlEventListener);
procedure RegisterEventListener (aListener: IutlEventListener);
procedure UnregisterEventListener(aListener: IutlEventListener);

public
constructor Create(const aHashSet: TObservableHashSet; const aOwnsKeys: Boolean; const aOwnsValues: Boolean); reintroduce;
@@ -350,13 +350,13 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableCustomList.RegisterEventListener(constref aListener: IutlEventListener);
procedure TutlObservableCustomList.RegisterEventListener(aListener: IutlEventListener);
begin
fEventListener.Add(aListener);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableCustomList.UnregisterEventListener(constref aListener: IutlEventListener);
procedure TutlObservableCustomList.UnregisterEventListener(aListener: IutlEventListener);
begin
fEventListener.Remove(aListener);
end;
@@ -490,13 +490,13 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableCustomHashSet.RegisterEventListener(constref aListener: IutlEventListener);
procedure TutlObservableCustomHashSet.RegisterEventListener(aListener: IutlEventListener);
begin
fEventListener.Add(aListener);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableCustomHashSet.UnregisterEventListener(constref aListener: IutlEventListener);
procedure TutlObservableCustomHashSet.UnregisterEventListener(aListener: IutlEventListener);
begin
fEventListener.Remove(aListener);
end;
@@ -659,13 +659,13 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableCustomMap.RegisterEventListener(constref aListener: IutlEventListener);
procedure TutlObservableCustomMap.RegisterEventListener(aListener: IutlEventListener);
begin
fEventListener.Add(aListener);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlObservableCustomMap.UnregisterEventListener(constref aListener: IutlEventListener);
procedure TutlObservableCustomMap.UnregisterEventListener(aListener: IutlEventListener);
begin
fEventListener.Remove(aListener);
end;


+ 0
- 496
uutlStored.pas ファイルの表示

@@ -1,496 +0,0 @@
unit uutlStored;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils,
DOM,
uutlMCF;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlStored = interface(IUnknown)
['{1AAA369A-B938-4430-AFAA-E4B5FD9D5A8D}']
function GetStoredCount(): Integer; // returns the number of stored values
function GetStoredName (const aIndex: Integer): String; // returns the name of the stored value
function GetStoredValue(const aIndex: Integer): Variant; // returns the stored value as string
procedure SetStoredValue(const aIndex: Integer; const aValue: Variant); // set the stored value
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlStoredWriter = interface(IUnknown)
['{AE592B18-DDC2-408A-BB26-DAA24E2A7C34}']
procedure Write(constref aObj: IutlStored; const aStream: TStream);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlStoredReader = interface(IUnknown)
['{B596DCD9-5F34-45F9-82C7-790F5407E1E8}']
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredWriter = class(
TInterfacedObject
, IutlStoredWriter)

public { IutlStoredWriter }
procedure Write(constref aObj: IutlStored; const aStream: TStream); virtual;
constructor Create; virtual;

public
class function CreateWriter: IutlStoredWriter;
end;
TutlStoredWriterClass = class of TutlStoredWriter;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredReader = class(
TInterfacedObject
, IutlStoredReader)

public { IutlStoredReader }
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean; virtual;
constructor Create; virtual;

public
class function CreateReader: IutlStoredReader;
end;
TutlStoredReaderClass = class of TutlStoredReader;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredXmlWriter = class(TutlStoredWriter)
private
fRootName: String;

protected
property RootName: String read fRootName write fRootName;

procedure Write(constref aObj: IutlStored; const aElement: TDOMElement); virtual;

public
procedure Write(constref aObj: IutlStored; const aStream: TStream); override;
constructor Create; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredXmlReader = class(TutlStoredReader)
protected
function CreateObject(constref aOwner: IutlStored; const aElement: TDOMElement): IutlStored; virtual;
procedure Read (constref aObj: IutlStored; const aElement: TDOMElement); virtual;

public
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredMcfWriter = class(TutlStoredWriter)
protected
procedure Write(constref aObj: IutlStored; const aName: String; const aParent: TutlMCFSection); virtual;
procedure Write(constref aObj: IutlStored; const aSection: TutlMCFSection); virtual;

public
procedure Write(constref aObj: IutlStored; const aStream: TStream); override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredMcfReader = class(TutlStoredReader)
private
function TryFindStoredName(const aObj: IutlStored; const aName: String; out aIndex: Integer): Boolean;

protected
function CreateObject(constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): IutlStored; virtual;
function ReadValue (constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): Variant; virtual;
procedure ReadSection (constref aObj: IutlStored; const aSection: TutlMCFSection); virtual;

public
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean; override;
end;

implementation

uses
XMLWrite, XMLRead, variants,
uutlXmlHelper, uutlSyncObjs;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredWriter//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredWriter.Write(constref aObj: IutlStored; const aStream: TStream);
begin
// DUMMY
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlStoredWriter.Create;
begin
inherited Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlStoredWriter.CreateWriter: IutlStoredWriter;
begin
result := TutlStoredWriterClass(ClassType).Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredReader//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredReader.Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
begin
result := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlStoredReader.Create;
begin
inherited Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlStoredReader.CreateReader: IutlStoredReader;
begin
result := TutlStoredReaderClass(ClassType).Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredXmlWriter///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredXmlWriter.Write(constref aObj: IutlStored; const aElement: TDOMElement);
var
i, c: Integer;
s: DOMString;
v: Variant;
vt: TVarType;
intf: IUnknown;
lock: IutlLockable;
stored: IutlStored;
begin
if not Supports(aObj, IutlLockable, lock) then
lock := nil;
if Assigned(lock) then
lock.Lock;
try
with TutlXmlHelper.Create(aElement) do begin
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
s := DOMString(aObj.GetStoredName(i));
v := aObj.GetStoredValue(i);
vt := VarType(v);
case vt of
varunknown: begin
intf := IUnknown(v);
if Supports(intf, IutlStored, stored) then
Write(stored, AppendNode(s));
end;
else
SetAttribString(s, String(v));
end;
end;
end;
finally
if Assigned(lock) then
lock.Unlock;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredXmlWriter.Write(constref aObj: IutlStored; const aStream: TStream);
var
doc: TXMLDocument;
root: TDOMElement;
begin
doc := TXMLDocument.Create;
try
root := doc.CreateElement(DOMString(fRootName));
doc.AppendChild(root);
Write(aObj, root);
WriteXMLFile(doc, aStream);
finally
FreeAndNil(doc);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlStoredXmlWriter.Create;
begin
inherited Create;
fRootName := 'root';
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredXmlReader///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredXmlReader.CreateObject(constref aOwner: IutlStored; const aElement: TDOMElement): IutlStored;
begin
result := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredXmlReader.Read(constref aObj: IutlStored; const aElement: TDOMElement);
var
i, j: Integer;
s: DOMString;
v: Variant;
vt: TVarType;
intf: IUnknown;
stored: IutlStored;
attribs: TDOMNamedNodeMap;
attrib: TDOMNode;
el: TDOMElement;

function TryFindStoredName(const aName: String; out aIndex: Integer): Boolean;
var
c, i: Integer;
begin
result := true;
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
aIndex := i;
if (aObj.GetStoredName(aIndex) = aName) then
exit;
end;
aIndex := -1;
result := false;
end;

begin
with TutlXmlHelper.Create(aElement) do begin
attribs := aElement.Attributes;
for i := 0 to attribs.Length-1 do begin
attrib := attribs.Item[i];
s := attrib.NodeName;
v := attrib.TextContent;
if not TryFindStoredName(String(s), j) then
continue;
aObj.SetStoredValue(j, v);
end;

for el in Nodes('') do begin
s := el.NodeName;
v := Unassigned;
stored := nil;
if TryFindStoredName(String(s), j) then begin
v := aObj.GetStoredValue(j);
vt := VarType(v);
case vt of
varunknown: begin
intf := v;
if not Supports(intf, IutlStored, stored) then
stored := nil;
end;
else
raise EInvalidOperation.Create('expected ' + String(s) + ' to be an stored object');
end;
end else
j := -1;
if not Assigned(stored) then
stored := CreateObject(aObj, el);
if not Assigned(stored) then
continue;
Read(stored, el);
aObj.SetStoredValue(j, stored);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredXmlReader.Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
var
doc: TXMLDocument;
p: Int64;
begin
p := aStream.Position;
doc := TXMLDocument.Create;
try try
result := true;
ReadXMLFile(doc, aStream);
Read(aObj, (doc.FirstChild as TDOMElement));
except
result := false;
aStream.Position := p;
end;
finally
FreeAndNil(doc);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredMcfWriter///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfWriter.Write(constref aObj: IutlStored; const aName: String; const aParent: TutlMCFSection);
begin
Write(aObj, aParent.Section(aName));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfWriter.Write(constref aObj: IutlStored; const aSection: TutlMCFSection);
var
lock: IutlLockable;
i, c: Integer;
s: String;
v: Variant;
vt: TVarType;
intf: IUnknown;
stored: IutlStored;
begin
if not Supports(aObj, IutlLockable, lock) then
lock := nil;
if Assigned(lock) then
lock.Lock;
try
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
s := aObj.GetStoredName (i);
v := aObj.GetStoredValue(i);
vt := VarType(v);
case vt of
varunknown: begin
intf := IUnknown(v);
if Supports(intf, IutlStored, stored) then
Write(stored, s, aSection);
end;

varboolean:
aSection.SetBool(s, v);

{$IFNDEF FPUNONE}
varsingle,
vardouble:
aSection.SetFloat(s, v);
{$ENDIF}

vardecimal,
varshortint,
varbyte,
varword,
varlongword,
varint64,
varqword,
varsmallint,
varinteger:
aSection.SetInt(s, v);
else
aSection.SetString(s, String(v));
end;
end;
finally
if Assigned(lock) then
lock.Unlock;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfWriter.Write(constref aObj: IutlStored; const aStream: TStream);
var
mcf: TutlMCFFile;
begin
mcf := TutlMCFFile.Create(nil);
try
Write(aObj, mcf);
mcf.SaveToStream(aStream);
finally
FreeAndNil(mcf);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredMcfReader///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.TryFindStoredName(const aObj: IutlStored; const aName: String; out aIndex: Integer): Boolean;
var
c, i: Integer;
begin
result := true;
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
aIndex := i;
if (aObj.GetStoredName(aIndex) = aName) then
exit;
end;
aIndex := -1;
result := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.CreateObject(constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): IutlStored;
begin
result := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.ReadValue(constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): Variant;
begin
result := aParent.GetString(aName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfReader.ReadSection(constref aObj: IutlStored; const aSection: TutlMCFSection);
var
i, j, c: Integer;
s: String;
v: Variant;
vt: TVarType;
intf: IUnknown;
stored: IutlStored;
begin
c := aSection.ValueCount;
for i := 0 to c-1 do begin
s := aSection.ValueNameAt[i];
v := ReadValue(aObj, s, aSection);
if (VarType(v) <> varempty) and TryFindStoredName(aObj, s, j) then
aObj.SetStoredValue(j, v);
end;

c := aSection.SectionCount;
for i := 0 to c-1 do begin
s := aSection.SectionNameAt[i];
v := Unassigned;
stored := nil;
if TryFindStoredName(aObj, s, j) then begin
v := aObj.GetStoredValue(j);
vt := VarType(v);
case vt of
varunknown: begin
intf := v;
if not Supports(intf, IutlStored, stored) then
stored := nil;
end;
else
raise EInvalidOperation.Create('expected ' + s + ' to be an stored object');
end;
end else
j := -1;
if not Assigned(stored) then
stored := CreateObject(aObj, s, aSection);
if not Assigned(stored) then
continue;
ReadSection(stored, aSection.Section(s));
aObj.SetStoredValue(j, stored);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
var
p: Int64;
mcf: TutlMCFFile;
begin
p := aStream.Position;
mcf := TutlMCFFile.Create(nil);
try try
result := true;
mcf.LoadFromStream(aStream);
ReadSection(aObj, mcf);
except
result := false;
aStream.Position := p;
end;
finally
FreeAndNil(mcf);
end;
end;

end.


+ 1
- 2
uutlSyncObjs.pas ファイルの表示

@@ -115,11 +115,10 @@ type
public type
ILock = specialize IutlLock<T>;

private
protected
fLock: IutlLockable;
fObject: T;


public
function LockedObject: T; inline;



書き込み プレビュー
読み込み中…
キャンセル
保存