diff --git a/Tests/UtilsTests.ico b/Tests/UtilsTests.ico
deleted file mode 100644
index 0341321..0000000
Binary files a/Tests/UtilsTests.ico and /dev/null differ
diff --git a/Tests/UtilsTests.lpi b/Tests/UtilsTests.lpi
deleted file mode 100644
index 92f2f27..0000000
--- a/Tests/UtilsTests.lpi
+++ /dev/null
@@ -1,90 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/Tests/UtilsTests.lpr b/Tests/UtilsTests.lpr
deleted file mode 100644
index a51e236..0000000
--- a/Tests/UtilsTests.lpr
+++ /dev/null
@@ -1,23 +0,0 @@
-program UtilsTests;
-
-{$mode objfpc}{$H+}
-
-uses
- sysutils, Interfaces, Forms, GuiTestRunner, uGenericsTests;
-
-{$R *.res}
-
-var
- heaptrcFile: String;
-
-begin
- heaptrcFile := ChangeFileExt(Application.ExeName, '.heaptrc');
- if (FileExists(heaptrcFile)) then
- DeleteFile(heaptrcFile);
- SetHeapTraceOutput(heaptrcFile);
-
- Application.Initialize;
- Application.CreateForm(TGuiTestRunner, TestRunner);
- Application.Run;
-end.
-
diff --git a/Tests/UtilsTests.lps b/Tests/UtilsTests.lps
deleted file mode 100644
index a732cdf..0000000
--- a/Tests/UtilsTests.lps
+++ /dev/null
@@ -1,110 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/Tests/UtilsTests.res b/Tests/UtilsTests.res
deleted file mode 100644
index 7c6cf3e..0000000
Binary files a/Tests/UtilsTests.res and /dev/null differ
diff --git a/Tests/uGenericsTests.pas b/Tests/uGenericsTests.pas
deleted file mode 100644
index 8fb2a21..0000000
--- a/Tests/uGenericsTests.pas
+++ /dev/null
@@ -1,1252 +0,0 @@
-unit uGenericsTests;
-
-{$mode objfpc}{$H+}
-{$modeswitch nestedprocvars}
-
-interface
-
-uses
- Classes, SysUtils, fpcunit, testregistry,
- uutlGenerics;
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TTestObject = class
- private
- fData: Integer;
- fOnDestroy: TNotifyEvent;
- public
- property Data: Integer read fData;
- constructor Create(const aData: Integer; const aOnDestroy: TNotifyEvent);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlListTest = class(TTestCase)
- private type
- TTestList = specialize TutlList;
- private
- fList: TTestList;
- fTestObjs: array[0..9] of TTestObject;
- procedure TestObjectDestroy(aSender: TObject);
- protected
- procedure SetUp; override;
- procedure TearDown; override;
- published
- procedure GetItem;
- procedure SetItem;
-
- procedure Add;
- procedure Insert;
- procedure IndexOf;
-
- procedure Exchange;
- procedure Move;
-
- procedure Delete;
- procedure Extract;
- procedure Remove;
- procedure Clear;
-
- procedure First;
- procedure PushFirst;
- procedure PopFirst;
-
- procedure Last;
- procedure PushLast;
- procedure PopLast;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlHashSetTest = class(TTestCase)
- private type
- TTestObjComparer = specialize TutlEventComparer;
- TTestHashSet = specialize TutlCustomHashSet;
- private
- fHashSet: TTestHashSet;
- fTestObjs: array[0..9] of TTestObject;
- procedure TestObjectDestroy(aSender: TObject);
- protected
- procedure SetUp; override;
- procedure TearDown; override;
- public
- function CompareTestObjects(const i1, i2: TTestObject): Integer;
- published
- procedure Add;
- procedure Contains;
- procedure IndexOf;
- procedure Remove;
- procedure Delete;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlMapTest = class(TTestCase)
- private type
- TTestMap = specialize TutlMap;
- private
- fMap: TTestMap;
- fTestObjs: array[0..9] of TTestObject;
- fLastRemovedIndex: Integer;
- procedure TestObjectDestroy(aSender: TObject);
- function Key(const aIndex: Integer): Integer;
- function CreateObj: TTestObject;
- protected
- procedure SetUp; override;
- procedure TearDown; override;
-
- procedure AddExistingKey;
- published
- procedure GetValue;
- procedure SetValue;
- procedure GetValueAt;
- procedure SetValueAt;
- procedure GetKey;
- procedure Add;
- procedure IndexOf;
- procedure Delete;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlPagedDataFiFoTest = class(TTestCase)
- private type
- TTestFiFo = specialize TutlPagedDataFiFo;
- private
- fFiFo: TTestFiFo;
- protected
- procedure SetUp; override;
- procedure TearDown; override;
- published
- procedure WriteReadSinglePage;
- procedure WriteReadMultiPage;
- procedure WritePeekReadSinglePage;
- procedure WritePeekReadMultiPage;
- procedure WriteDiscardReadSinglePage;
- procedure WriteDiscardReadMultiPage;
- procedure NestedProvider;
- procedure NestedConsumer;
- procedure StreamProvider;
- procedure StreamConsumer;
- procedure RandomSizeTest;
- procedure BigDataBlocks;
- procedure WriteSmallBlocks;
- procedure ReadSmallBlocks;
- procedure WriteHalfPageReadAll;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlEnumHelperTest = class(TTestCase)
- private type
- TBasicEnum = (test1,test2,test3);
- TBasicEnumH = specialize TutlEnumHelper;
- TOffsetEnum = (
- rtNone = -1,
- rtJanaru = 0,
- rtTambinor = 1,
- rtBendalir = 2,
- rtCogadh = 3);
- TOffsetEnumH = specialize TutlEnumHelper;
- TSparseEnum = (
- pmFoo = $00f0,
- pmPoint = $1b01,
- pmLine = $1b02,
- pmFill = $1b03);
- TSparseEnumH = specialize TutlEnumHelper;
- TDisorder = (teNone = -1, teOne = 200, teTwo = 10);
- TDisorderH = specialize TutlEnumHelper;
- {$push}{$ScopedEnums on}
- TScoped = (tefoo, uGenericsTests);
- TScopedH = specialize TutlEnumHelper;
- {$pop}
- published
- procedure BasicConvert;
- procedure OffsetEnum;
- procedure SparseEnum;
- procedure DisorderedEnum;
- procedure ScopedEnum;
- end;
-
-
-
-implementation
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TTestObject///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TTestObject.Create(const aData: Integer; const aOnDestroy: TNotifyEvent);
-begin
- inherited Create;
- fData := aData;
- fOnDestroy := aOnDestroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TTestObject.Destroy;
-begin
- if Assigned(fOnDestroy) then
- fOnDestroy(self);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlListTest//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.TestObjectDestroy(aSender: TObject);
-var
- i: Integer;
-begin
- for i := Low(fTestObjs) to High(fTestObjs) do
- if (fTestObjs[i] = aSender) then
- fTestObjs[i] := nil;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.SetUp;
-var
- i: Integer;
-begin
- inherited SetUp;
- fList := TTestList.Create(true);
- for i := Low(fTestObjs) to High(fTestObjs) do begin
- fTestObjs[i] := TTestObject.Create(i, @TestObjectDestroy);
- fList.Add(fTestObjs[i]);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.TearDown;
-begin
- FreeAndNil(fList);
- inherited TearDown;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.GetItem;
-var
- i: Integer;
-begin
- for i := Low(fTestObjs) to High(fTestObjs) do
- AssertTrue(fTestObjs[i] = fList[i - Low(fTestObjs)]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.SetItem;
-var
- o1, o2: TTestObject;
-begin
- o1 := fList[3];
- o2 := fList[6];
- fList[3] := o2;
- fList[6] := o1;
- AssertTrue(fList[6] = o1);
- AssertTrue(fList[3] = o2);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Add;
-var
- t: TTestObject;
- c: Integer;
-begin
- t := TTestObject.Create(123456, @TestObjectDestroy);
- c := fList.Count;
- fList.Add(t);
- AssertEquals(c+1, fList.Count);
- AssertTrue(fList[c] = t);
- AssertTrue(fList.Last = t);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Insert;
-var
- t: TTestObject;
- c: Integer;
-begin
- t := TTestObject.Create(123456, @TestObjectDestroy);
- c := fList.Count;
- fList.Insert(3, t);
- AssertEquals(c+1, fList.Count);
- AssertTrue(fList[3] = t);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.IndexOf;
-var
- i: Integer;
-begin
- for i := Low(fTestObjs) to High(fTestObjs) do
- AssertEquals(i - Low(fTestObjs), fList.IndexOf(fTestObjs[i]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Exchange;
-var
- o1, o2: TTestObject;
-begin
- o1 := fList[3];
- o2 := fList[7];
- fList.Exchange(3, 7);
- AssertTrue(fList[3] = o2);
- AssertTrue(fList[7] = o1);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Move;
-begin
- fList.Move(3, 6);
- AssertTrue(fList[3] = fTestObjs[4]);
- AssertTrue(fList[4] = fTestObjs[5]);
- AssertTrue(fList[5] = fTestObjs[6]);
- AssertTrue(fList[6] = fTestObjs[3]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Delete;
-begin
- fList.Delete(3);
- AssertTrue(fTestObjs[3] = nil);
- AssertEquals(Length(fTestObjs)-1, fList.Count);
-
- fList.OwnsObjects := false;
- fList.Delete(4);
- AssertTrue(fTestObjs[5] <> nil);
- AssertEquals(Length(fTestObjs)-2, fList.Count);
- AssertTrue(fList[4] = fTestObjs[6]);
- FreeAndNil(fTestObjs[5]);
- fList.OwnsObjects := true;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Extract;
-var
- o1, o2, o3: TTestObject;
-begin
- o1 := fList[1];
- o2 := TTestObject.Create(1234, @TestObjectDestroy);
- o3 := fList.Extract(o1, o2);
- try
- AssertTrue(o1 = o3);
- AssertEquals(Length(fTestObjs)-1, fList.Count);
- AssertTrue(fTestObjs[1] <> nil);
- finally
- FreeAndNil(o1);
- FreeAndNil(o2);
- end;
-
- o1 := fList[1];
- o2 := TTestObject.Create(1234, @TestObjectDestroy);
- o3 := fList.Extract(o2, o1);
- try
- AssertTrue(o1 = o3);
- AssertEquals(Length(fTestObjs)-1, fList.Count);
- finally
- FreeAndNil(o2);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Remove;
-var
- o1: TTestObject;
- i: Integer;
-begin
- o1 := fList[3];
- i := fList.Remove(o1);
- AssertEquals(3, i);
- AssertEquals(Length(fTestObjs)-1, fList.Count);
- AssertTrue(fTestObjs[3] = nil);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Clear;
-var
- o: TTestObject;
-begin
- fList.Clear;
- AssertEquals(0, fList.Count);
- for o in fTestObjs do
- AssertTrue(o = nil);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.First;
-begin
- AssertTrue(fTestObjs[Low(fTestObjs)] = fList.First);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.PushFirst;
-var
- o1: TTestObject;
-begin
- o1 := TTestObject.Create(1234, @TestObjectDestroy);
- fList.PushFirst(o1);
- AssertEquals(Length(fTestObjs)+1, fList.Count);
- AssertTrue(fList.First = o1);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.PopFirst;
-var
- o1: TTestObject;
-begin
- o1 := fList.PopFirst;
- AssertEquals(Length(fTestObjs)-1, fList.Count);
- AssertTrue(o1 = fTestObjs[0]);
- FreeAndNil(o1);
-
- o1 := fList.PopFirst(true);
- AssertEquals(Length(fTestObjs)-2, fList.Count);
- AssertTrue(o1 = nil);
- AssertTrue(fTestObjs[1] = nil);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.Last;
-begin
- AssertTrue(fTestObjs[High(fTestObjs)] = fList.Last);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.PushLast;
-var
- o1: TTestObject;
-begin
- o1 := TTestObject.Create(1234, @TestObjectDestroy);
- fList.PushLast(o1);
- AssertEquals(Length(fTestObjs)+1, fList.Count);
- AssertTrue(fList.Last = o1);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlListTest.PopLast;
-var
- o1: TTestObject;
-begin
- o1 := fList.PopLast;
- AssertEquals(Length(fTestObjs)-1, fList.Count);
- AssertTrue(o1 = fTestObjs[High(fTestObjs)]);
- FreeAndNil(o1);
-
- o1 := fList.PopLast(true);
- AssertEquals(Length(fTestObjs)-2, fList.Count);
- AssertTrue(o1 = nil);
- AssertTrue(fTestObjs[High(fTestObjs)-1] = nil);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlHashSetTest///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.TestObjectDestroy(aSender: TObject);
-var
- i: Integer;
-begin
- for i := Low(fTestObjs) to High(fTestObjs) do
- if (fTestObjs[i] = aSender) then
- fTestObjs[i] := nil;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.SetUp;
-var
- i: Integer;
-begin
- inherited SetUp;
- fHashSet := TTestHashSet.Create(TTestObjComparer.Create(@CompareTestObjects), true);
- for i := Low(fTestObjs) to High(fTestObjs) do begin
- fTestObjs[i] := TTestObject.Create(i, @TestObjectDestroy);
- fHashSet.Add(fTestObjs[i]);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.TearDown;
-begin
- FreeAndNil(fHashSet);
- inherited TearDown;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlHashSetTest.CompareTestObjects(const i1, i2: TTestObject): Integer;
-begin
- if (i1.Data < i2.Data) then
- result := -1
- else if (i1.Data > i2.Data) then
- result := 1
- else
- result := 0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.Add;
-var
- o1: TTestObject;
- b: Boolean;
-begin
- o1 := TTestObject.Create(1234, @TestObjectDestroy);
- b := fHashSet.Add(o1);
- AssertTrue(b);
- AssertEquals(Length(fTestObjs)+1, fHashSet.Count);
-
- b := fHashSet.Add(o1);
- AssertFalse(b);
- AssertEquals(Length(fTestObjs)+1, fHashSet.Count);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.Contains;
-var
- o1: TTestObject;
- b: Boolean;
-begin
- o1 := TTestObject.Create(1234, @TestObjectDestroy);
- try
- b := fHashSet.Contains(fTestObjs[0]);
- AssertTrue(b);
-
- b := fHashSet.Contains(o1);
- AssertFalse(b);
- finally
- FreeAndNil(o1);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.IndexOf;
-var
- o1: TTestObject;
- i: Integer;
-begin
- o1 := TTestObject.Create(1234, @TestObjectDestroy);
- try
- i := fHashSet.IndexOf(fTestObjs[4]);
- AssertEquals(4, i);
-
- i := fHashSet.IndexOf(o1);
- AssertEquals(-1, i);
- finally
- FreeAndNil(o1);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.Remove;
-var
- b: Boolean;
-begin
- b := fHashSet.Remove(fTestObjs[5]);
- AssertTrue(fTestObjs[5] = nil);
- AssertTrue(b);
- AssertEquals(Length(fTestObjs)-1, fHashSet.Count);
-
- fHashSet.OwnsObjects := false;
- try
- b := fHashSet.Remove(fTestObjs[0]);
- AssertTrue(fTestObjs[0] <> nil);
- AssertEquals(Length(fTestObjs)-2, fHashSet.Count);
- AssertTrue(b);
-
- b := fHashSet.Remove(fTestObjs[0]);
- AssertFalse(b);
- AssertEquals(Length(fTestObjs)-2, fHashSet.Count);
- finally
- FreeAndNil(fTestObjs[0]);
- fHashSet.OwnsObjects := true;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlHashSetTest.Delete;
-begin
- fHashSet.Delete(0);
- AssertEquals(Length(fTestObjs)-1, fHashSet.Count);
- AssertTrue(fTestObjs[0] = nil);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMapTest///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.TestObjectDestroy(aSender: TObject);
-var
- i: Integer;
-begin
- for i := Low(fTestObjs) to High(fTestObjs) do
- if (fTestObjs[i] = aSender) then begin
- fLastRemovedIndex := i;
- fTestObjs[i] := nil;
- exit;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMapTest.Key(const aIndex: Integer): Integer;
-begin
- result := fTestObjs[aIndex].Data;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMapTest.CreateObj: TTestObject;
-var
- k: Integer;
-begin
- repeat
- k := random(10000);
- until not fMap.Contains(k);
- result := TTestObject.Create(k, @TestObjectDestroy);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.SetUp;
-var
- i: Integer;
- o: TTestObject;
-begin
- inherited SetUp;
- fMap := TTestMap.Create(true);
- Randomize;
- for i := Low(fTestObjs) to High(fTestObjs) do begin
- o := CreateObj;
- fTestObjs[i] := o;
- fMap.Add(o.Data, o);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.TearDown;
-begin
- FreeAndNil(fMap);
- inherited TearDown;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.AddExistingKey;
-var
- o1: TTestObject;
-begin
- o1 := TTestObject.Create(fTestObjs[0].Data, @TestObjectDestroy);
- try
- fMap.Add(o1.Data, o1);
- finally
- FreeAndNil(o1);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.GetValue;
-var
- i: Integer;
-begin
- for i := Low(fTestObjs) to High(fTestObjs) do
- AssertTrue(fMap[Key(i)] = fTestObjs[i]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.SetValue;
-var
- o1, o2: TTestObject;
-begin
- o1 := fMap[Key(2)];
- o2 := CreateObj;
- fMap[Key(2)] := o2;
- try
- AssertTrue(fMap[Key(2)] = o2);
- finally
- FreeAndNil(o1);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.GetValueAt;
-type
- TIntList = specialize TutlList;
- TIntComparer = specialize TutlComparer;
-var
- o: TTestObject;
- l: TIntList;
- i: Integer;
-begin
- l := TIntList.Create;
- try
- for o in fTestObjs do
- l.Add(o.Data);
- l.Sort(TIntComparer.Create);
-
- for i := 0 to l.Count-1 do
- AssertEquals(l[i], fMap.ValueAt[i].Data);
- finally
- FreeAndNil(l);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.SetValueAt;
-var
- o1, o2: TTestObject;
-begin
- o1 := fMap.ValueAt[4];
- o2 := TTestObject.Create(o1.Data, @TestObjectDestroy);
- fMap.ValueAt[4] := o2;
- try
- AssertTrue(fMap.ValueAt[4] = o2);
- finally
- FreeAndNil(o1);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.GetKey;
-type
- TIntList = specialize TutlList;
- TIntComparer = specialize TutlComparer;
-var
- o: TTestObject;
- l: TIntList;
- i: Integer;
-begin
- l := TIntList.Create;
- try
- for o in fTestObjs do
- l.Add(o.Data);
- l.Sort(TIntComparer.Create);
-
- for i := 0 to l.Count-1 do
- AssertEquals(l[i], fMap.Keys[i]);
- finally
- FreeAndNil(l);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.Add;
-var
- o1: TTestObject;
-begin
- o1 := CreateObj;
- fMap.Add(o1.Data, o1);
- AssertEquals(Length(fTestObjs)+1, fMap.Count);
-
- AssertException(EutlMapKeyAlreadyExists, @AddExistingKey);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.IndexOf;
-type
- TIntList = specialize TutlList;
- TIntComparer = specialize TutlComparer;
-var
- o: TTestObject;
- l: TIntList;
-begin
- l := TIntList.Create;
- try
- for o in fTestObjs do
- l.Add(o.Data);
- l.Sort(TIntComparer.Create);
-
- for o in fTestObjs do
- AssertEquals(l.IndexOf(o.Data), fMap.IndexOf(o.Data));
- finally
- FreeAndNil(l);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMapTest.Delete;
-var
- i: Integer;
-begin
- for i := Low(fTestObjs) to High(fTestObjs) do begin
- fMap.Delete(Key(i));
- AssertNull(fTestObjs[i]);
- AssertEquals('Count', Length(fTestObjs)-i-1, fMap.Count);
- AssertEquals('Index', fLastRemovedIndex, i);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlPagedDataFiFoTest/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.SetUp;
-begin
- inherited SetUp;
- fFiFo := TTestFiFo.Create;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.TearDown;
-begin
- FreeAndNil(fFiFo);
- inherited TearDown;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WriteReadSinglePage;
-var
- buf1, buf2: String;
- l: Integer;
-begin
- buf1 := 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis a';
- l := Length(buf1);
- AssertEquals(l, fFiFo.Write(PByte(@buf1[1]), l));
- AssertEquals(l, fFiFo.Size);
-
- SetLength(buf2, l);
- AssertEquals(l, fFiFo.Read(PByte(@buf2[1]), l));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(buf1, buf2));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WriteReadMultiPage;
-var
- buf1, buf2: String;
- l: Integer;
-begin
- buf1 := 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam liber tempor cum soluta nobis eleifend option congue nihil imperdiet doming id quod mazim placerat facer possim assum. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, At accusam aliquyam diam diam dolore dolores duo eirmod eos erat, et nonumy sed tempor et et invidunt justo labore Stet clita ea et gubergren, kasd magna no rebum. sanctus sea sed takimata ut vero voluptua. est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat. Consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptu';
- l := Length(buf1);
- AssertEquals(l, fFiFo.Write(PByte(@buf1[1]), l));
- AssertEquals(l, fFiFo.Size);
-
- SetLength(buf2, l);
- AssertEquals(l, fFiFo.Read(PByte(@buf2[1]), l));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(buf1, buf2));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WritePeekReadSinglePage;
-var
- buf1, buf2, buf3: String;
- l: Integer;
-begin
- buf1 := 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis a';
- l := Length(buf1);
- AssertEquals(l, fFiFo.Write(PByte(@buf1[1]), l));
- AssertEquals(l, fFiFo.Size);
-
- SetLength(buf2, l);
- AssertEquals(l, fFiFo.Peek(PByte(@buf2[1]), l));
- AssertEquals(l, fFiFo.Size);
- Assert(buf1 = buf2);
-
- SetLength(buf3, l);
- AssertEquals(l, fFiFo.Read(PByte(@buf3[1]), l));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(buf1, buf3));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WritePeekReadMultiPage;
-var
- buf1, buf2, buf3: String;
- l: Integer;
-begin
- buf1 := 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam liber tempor cum soluta nobis eleifend option congue nihil imperdiet doming id quod mazim placerat facer possim assum. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, At accusam aliquyam diam diam dolore dolores duo eirmod eos erat, et nonumy sed tempor et et invidunt justo labore Stet clita ea et gubergren, kasd magna no rebum. sanctus sea sed takimata ut vero voluptua. est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat. Consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptu';
- l := Length(buf1);
- AssertEquals(l, fFiFo.Write(PByte(@buf1[1]), l));
- AssertEquals(l, fFiFo.Size);
-
- SetLength(buf2, l);
- AssertEquals(l, fFiFo.Peek(PByte(@buf2[1]), l));
- AssertEquals(l, fFiFo.Size);
- Assert(buf1 = buf2);
-
- SetLength(buf3, l);
- AssertEquals(l, fFiFo.Read(PByte(@buf3[1]), l));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(buf1, buf3));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WriteDiscardReadSinglePage;
-var
- buf1, buf2: String;
- l: Integer;
-begin
- buf1 := 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam liber tempor cum soluta nobis eleifend option congue nihil imperdiet doming id quod mazim placerat facer possim assum. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, At accusam aliquyam diam diam dolore dolores duo eirmod eos erat, et nonumy sed tempor et et invidunt justo labore Stet clita ea et gubergren, kasd magna no rebum. sanctus sea sed takimata ut vero voluptua. est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat. Consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptu';
- l := Length(buf1);
- AssertEquals(l, fFiFo.Write(PByte(@buf1[1]), l));
- AssertEquals(l, fFiFo.Size);
-
- AssertEquals(512, fFiFo.Discard(512));
- AssertEquals(l - 512, fFiFo.Size);
-
- buf1 := 't clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam liber tempor cum soluta nobis eleifend option congue nihil imperdiet doming id quod mazim placerat facer possim assum. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, At accusam aliquyam diam diam dolore dolores duo eirmod eos erat, et nonumy sed tempor et et invidunt justo labore Stet clita ea et gubergren, kasd magna no rebum. sanctus sea sed takimata ut vero voluptua. est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat. Consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptu';
- l := Length(buf1);
- SetLength(buf2, l);
- AssertEquals(l, fFiFo.Read(PByte(@buf2[1]), l));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(buf1, buf2));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WriteDiscardReadMultiPage;
-var
- buf1, buf2: String;
- l: Integer;
-begin
- buf1 := 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Nam liber tempor cum soluta nobis eleifend option congue nihil imperdiet doming id quod mazim placerat facer possim assum. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, At accusam aliquyam diam diam dolore dolores duo eirmod eos erat, et nonumy sed tempor et et invidunt justo labore Stet clita ea et gubergren, kasd magna no rebum. sanctus sea sed takimata ut vero voluptua. est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat. Consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptu';
- l := Length(buf1);
- AssertEquals(l, fFiFo.Write(PByte(@buf1[1]), l));
- AssertEquals(l, fFiFo.Size);
-
- AssertEquals(3000, fFiFo.Discard(3000));
- AssertEquals(l - 3000, fFiFo.Size);
-
- buf1 := 'tur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat. Consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptu';
- l := Length(buf1);
- SetLength(buf2, l);
- AssertEquals(l, fFiFo.Read(PByte(@buf2[1]), l));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(buf1, buf2));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.NestedProvider;
-var
- pos: Integer;
- len: Integer;
- data: String;
- tmp: String;
-
- function GiveData(const aBuffer: PByte; aCount: Integer): Integer;
- begin
- result := aCount;
- if (result > len - pos) then
- result := len - pos;
- move(data[pos+1], aBuffer^, result);
- inc(pos, result);
- end;
-
-var
- provider: TTestFiFo.IDataProvider;
-begin
- data := 'abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzab';
- len := Length(data);
- pos := 0;
-
- provider := TTestFiFo.TNestedDataProvider.Create(@GiveData);
- AssertEquals(len, fFiFo.Write(provider, len));
- provider := nil;
-
- SetLength(tmp, len);
- AssertEquals(len, fFiFo.Read(PByte(@tmp[1]), len));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(data, tmp));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.NestedConsumer;
-var
- pos: Integer;
- len: Integer;
- data: String;
- tmp: String;
-
- function TakeData(const aBuffer: PByte; aCount: Integer): Integer;
- begin
- result := aCount;
- if (result > len - pos) then
- result := len - pos;
- move(aBuffer^, data[pos+1], result);
- inc(pos, result);
- end;
-
-var
- consumer: TTestFiFo.IDataConsumer;
-begin
- tmp := 'abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzab';
- len := Length(tmp);
- pos := 0;
- AssertEquals(len, fFiFo.Write(@tmp[1], len));
-
- SetLength(data, len);
- consumer := TTestFiFo.TNestedDataConsumer.Create(@TakeData);
- AssertEquals(len, fFiFo.Read(consumer, len));
- consumer := nil;
-
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(data, tmp));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.StreamProvider;
-var
- s: TMemoryStream;
- len: Integer;
- buf1, buf2: String;
- provider: TTestFiFo.IDataProvider;
-begin
- buf1 := 'abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzab';
- len := Length(buf1);
-
- s := TMemoryStream.Create;
- try
- s.Write(buf1[1], len);
- s.Position := 0;
- provider := TTestFiFo.TStreamDataProvider.Create(s);
- AssertEquals(len, fFiFo.Write(provider, len));
- provider := nil;
-
- SetLength(buf2, len);
- AssertEquals(len, fFiFo.Read(@buf2[1], len));
- AssertEquals('Data', 0, CompareStr(buf1, buf2));
- finally
- FreeAndNil(s);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.StreamConsumer;
-var
- s: TMemoryStream;
- len: Integer;
- buf1, buf2: String;
- consumer: TTestFiFo.IDataConsumer;
-begin
- buf1 := 'abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzab';
- len := Length(buf1);
-
- AssertEquals(len, fFiFo.Write(@buf1[1], len));
-
- s := TMemoryStream.Create;
- try
- consumer := TTestFiFo.TStreamDataConsumer.Create(s);
- AssertEquals(len, fFiFo.Read(consumer, len));
- consumer := nil;
-
- SetLength(buf2, len);
- s.Position := 0;
- s.Read(buf2[1], len);
- AssertEquals('Data', 0, CompareStr(buf1, buf2));
- finally
- FreeAndNil(s);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.RandomSizeTest;
-const
- MAX_LEN = 128;
- MAX_REPEAT = 1024;
-
-var
- rBuf, wBuf: Word;
- buf, tmp: array[0..MAX_LEN-1] of Word;
- len, i, j: Integer;
-begin
- rBuf := 0;
- wBuf := 0;
- len := 1;
- for i := 0 to MAX_REPEAT-1 do begin
- for j := 0 to len-1 do begin
- buf[j] := wBuf;
- inc(wBuf);
- end;
- AssertEquals(SizeOf(Word) * len, fFiFo.Write(@buf[0], SizeOf(Word) * len));
-
- AssertEquals(SizeOf(Word) * len, fFiFo.Peek(@tmp[0], SizeOf(Word) * len));
- for j := 0 to len-1 do begin
- AssertEquals(rBuf, tmp[j]);
- inc(rBuf);
- end;
- AssertEquals(SizeOf(Word) * len, fFiFo.Discard(SizeOf(Word) * len));
- AssertEquals(0, fFiFo.Size);
-
- inc(len);
- if (len >= MAX_LEN) then
- len := 1;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.BigDataBlocks;
-const
- BUFFER_LEN = 1000;
- REPEAT_COUNT = 50;
-var
- buf1, buf2: array[0..BUFFER_LEN-1] of Integer;
- i, j, sz: Integer;
-begin
- for i := 0 to BUFFER_LEN-1 do
- buf1[i] := i;
-
- sz := 0;
- for i := 0 to REPEAT_COUNT + 4 do begin
- if (i < REPEAT_COUNT) then begin
- AssertEquals(SizeOf(Integer) * BUFFER_LEN, fFiFo.Write(@buf1[0], SizeOf(Integer) * BUFFER_LEN));
- inc(sz, SizeOf(Integer) * BUFFER_LEN);
- AssertEquals(sz, fFiFo.Size);
- end;
-
- if (i >= 5) then begin
- AssertEquals(SizeOf(Integer) * BUFFER_LEN, fFiFo.Read(@buf2[0], SizeOf(Integer) * BUFFER_LEN));
- dec(sz, SizeOf(Integer) * BUFFER_LEN);
- AssertEquals(sz, fFiFo.Size);
- for j := 0 to BUFFER_LEN-1 do
- AssertEquals(j, buf2[j]);
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WriteSmallBlocks;
-var
- pos: Integer;
- len: Integer;
- data: String;
- tmp: String;
-
- function GiveData(const aBuffer: PByte; aCount: Integer): Integer;
- begin
- result := aCount;
- if (result > len - pos) then
- result := len - pos;
- if (result > 10) then
- result := 10;
- move(data[pos+1], aBuffer^, result);
- inc(pos, result);
- end;
-
-var
- provider: TTestFiFo.IDataProvider;
-begin
- data := 'abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzab';
- len := Length(data);
- pos := 0;
-
- provider := TTestFiFo.TNestedDataProvider.Create(@GiveData);
- AssertEquals(len, fFiFo.Write(provider, len));
- provider := nil;
-
- SetLength(tmp, len);
- AssertEquals(len, fFiFo.Read(PByte(@tmp[1]), len));
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(data, tmp));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.ReadSmallBlocks;
-var
- pos: Integer;
- len: Integer;
- data: String;
- tmp: String;
-
- function TakeData(const aBuffer: PByte; aCount: Integer): Integer;
- begin
- result := aCount;
- if (result > len - pos) then
- result := len - pos;
- if (result > 10) then
- result := 10;
- move(aBuffer^, data[pos+1], result);
- inc(pos, result);
- end;
-
-var
- consumer: TTestFiFo.IDataConsumer;
-begin
- tmp := 'abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzab';
- len := Length(tmp);
- pos := 0;
- AssertEquals(len, fFiFo.Write(@tmp[1], len));
-
- SetLength(data, len);
- consumer := TTestFiFo.TNestedDataConsumer.Create(@TakeData);
- AssertEquals(len, fFiFo.Read(consumer, len));
- consumer := nil;
-
- AssertEquals(0, fFiFo.Size);
- AssertEquals('Data', 0, CompareStr(data, tmp));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlPagedDataFiFoTest.WriteHalfPageReadAll;
-const
- REPEAT_COUNT = 10;
-var
- buf1: String;
- i, sz: Integer;
- p: Pointer;
-begin
- buf1 := 'abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzab';
- for i := 1 to REPEAT_COUNT do begin
- AssertEquals('Write' + IntToStr(i), fFiFo.PageSize div 2, fFiFo.Write(@buf1[1], fFiFo.PageSize div 2));
- sz := fFiFo.Size;
- AssertEquals('Size' + IntToStr(i), fFiFo.PageSize div 2, sz);
- p := GetMem(fFiFo.PageSize);
- try
- AssertEquals('Read' + IntToStr(i), sz, fFiFo.Read(p, fFiFo.PageSize));
- Assert(CompareMem(p, @buf1[1], sz), 'Data' + IntToStr(i));
- finally
- Freemem(p);
- end;
- end;
-end;
-
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlEnumHelperTest////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlEnumHelperTest.BasicConvert;
-var
- en: TBasicEnum;
-begin
- AssertEquals('test1', TBasicEnumH.ToString(test1));
- AssertEquals(Ord(test2), Ord(TBasicEnumH.ToEnum('test2')));
- en:= test1;
- AssertEquals(false, TBasicEnumH.TryToEnum('NotInList',en));
- AssertEquals(ord(test1), ord(en));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlEnumHelperTest.OffsetEnum;
-begin
- AssertEquals('rtJanaru', TOffsetEnumH.ToString(rtJanaru));
- AssertEquals(Ord(rtJanaru), Ord(TOffsetEnumH.ToEnum('rtJanaru')));
- AssertEquals(5, Length(TOffsetEnumH.Values));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlEnumHelperTest.SparseEnum;
-begin
- AssertEquals('pmPoint', TSparseEnumH.ToString(pmPoint));
- AssertEquals(Ord(pmPoint), Ord(TSparseEnumH.ToEnum('pmPoint')));
- AssertEquals(4, Length(TSparseEnumH.Values));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlEnumHelperTest.DisorderedEnum;
-var
- s: string;
- en: TDisorder;
-begin
- AssertEquals(3, Length(TDisorderH.Values));
- s:= '';
- for en in TDisorderH.Values do
- s += TDisorderH.ToString(en) + '|';
- AssertEquals('teNone|teOne|teTwo|', s);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlEnumHelperTest.ScopedEnum;
-var
- s: string;
- en: TScoped;
-begin
- AssertEquals(2, Length(TScopedH.Values));
- s:= '';
- for en in TScopedH.Values do
- s += TScopedH.ToString(en) + '|';
- AssertEquals('tefoo|uGenericsTests|', s);
-end;
-
-initialization
- RegisterTest(TutlListTest);
- RegisterTest(TutlHashSetTest);
- RegisterTest(TutlMapTest);
- RegisterTest(TutlPagedDataFiFoTest);
- RegisterTest(TutlEnumHelperTest);
-
-end.
-
diff --git a/uutlConsoleHelper.pas b/uutlConsoleHelper.pas
deleted file mode 100644
index c90fa06..0000000
--- a/uutlConsoleHelper.pas
+++ /dev/null
@@ -1,2128 +0,0 @@
-unit uutlConsoleHelper;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit implementiert Helper Klassen für Consolen Ein- und Ausgaben,
- sowie Menüführung und Autovervollständigung }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils, fgl, uutlMCF, uutlCommon, uutlGenerics, syncobjs;
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlParameterStringFlag = (psfBrackets);
- TutlParameterStringFlags = set of TutlParameterStringFlag;
- TutlMenuItem = class;
- TutlMenuParameter = class
- private
- fParent: TutlMenuItem;
- fOptional: Boolean;
- fName, fDescription, fValue: String;
- public
- property Parent: TutlMenuItem read fParent;
- property Optional: Boolean read fOptional;
- property Value: String read fValue;
- property Name: String read fName;
- property Description: String read fDescription;
-
- procedure WriteConfig(const aMCF: TutlMCFSection); virtual;
- procedure ReadConfig(const aMCF: TutlMCFSection); virtual;
-
- procedure GetAutoCompleteStrings(const aStrings: TStrings); virtual; abstract;
- function SetValue(const aValue: String): Boolean; virtual;
- function GetString(const aOptions: TutlParameterStringFlags = [psfBrackets]): String; virtual;
-
- constructor Create(const aOptional: Boolean; const aName, aDescription: String);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlMenuParameterListBase = specialize TFPGObjectList;
- TutlMenuParameterList = class(TutlMenuParameterListBase)
- public
- function HasParameter(const aName: String): Boolean;
- function FindParameter(const aName: String): TutlMenuParameter;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlMenuParameterStack = class(TutlMenuParameterList)
- public
- procedure Push(const aValue: TutlMenuParameter);
- function Seek: TutlMenuParameter;
- function Pop: TutlMenuParameter;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlParameterType = (ptString = 0, ptInteger, ptBoolean, ptHex, ptPreset);
- TutlParameterTypeH = specialize TutlEnumHelper;
- TutlMenuParameterSingle = class(TutlMenuParameter)
- private
- fType: TutlParameterType;
- public
- property ParamType: TutlParameterType read fType;
-
- procedure WriteConfig(const aMCF: TutlMCFSection); override;
- procedure ReadConfig(const aMCF: TutlMCFSection); override;
-
- procedure GetAutoCompleteStrings(const aStrings: TStrings); override;
- function SetValue(const aValue: String): Boolean; override;
- function GetString(const aOptions: TutlParameterStringFlags = [psfBrackets]): String; override;
-
- constructor Create(const aOptional: Boolean; const aName, aDescription: String; const aType: TutlParameterType);
- destructor Destroy; override;
- end;
- TutlMenuParameterSingleList = specialize TFPGObjectList;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlMenuParameterGroup = class(TutlMenuParameter)
- private
- fParameters: TutlMenuParameterSingleList;
- function GetCount: Integer;
- function GetParameter(const aIndex: Integer): TutlMenuParameterSingle;
- public
- property Count: Integer read GetCount;
- property Parameter[const aIndex: Integer]: TutlMenuParameterSingle read GetParameter; default;
-
- procedure WriteConfig(const aMCF: TutlMCFSection); override;
- procedure ReadConfig(const aMCF: TutlMCFSection); override;
-
- procedure GetAutoCompleteStrings(const aStrings: TStrings); override;
- function SetValue(const aValue: String): Boolean; override;
- function GetString(const aOptions: TutlParameterStringFlags = [psfBrackets]): String; override;
-
- function AddParameter(const aName, aDescription: String;
- const aType: TutlParameterType): TutlMenuParameterSingle; overload;
- function AddParameter(const aParameter: TutlMenuParameterSingle): TutlMenuParameterSingle; overload;
- procedure DelParameter(const aIndex: Integer);
-
- constructor Create(const aOptional: Boolean; const aName, aDescription: String);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlCallback = procedure(aSender: TObject) of object;
- TutlMenuItemList = specialize TFPGObjectList;
- TutlMenuItem = class(TObject)
- private
- fCommand: String;
- fDescription: String;
- fCallback: TutlCallback;
- fExecutable: Boolean;
- fParent: TutlMenuItem;
- fHelpItem: TutlMenuItem;
-
- function GetCount: Integer;
- function GetItems(const aIndex: Integer): TutlMenuItem;
- function GetMenuPath: String;
- function GetParamCount: Integer;
- function GetParameters(const aIndex: Integer): TutlMenuParameter;
- function GetParameterString: String;
- procedure SetCallback(aValue: TutlCallback);
- protected
- fItems: TutlMenuItemList;
- fParameters: TutlMenuParameterList;
-
- procedure WriteConfig(const aMCF: TutlMCFSection); virtual;
- procedure ReadConfig(const aMCF: TutlMCFSection); virtual;
- public
- property Command: String read fCommand write fCommand;
- property Description: String read fDescription write fDescription;
- property Callback: TutlCallback read fCallback write SetCallback;
- property Executable: Boolean read fExecutable;
- property MenuPath: String read GetMenuPath;
- property ParameterString: String read GetParameterString;
- property ParamCount: Integer read GetParamCount;
- property Count: Integer read GetCount;
- property Parent: TutlMenuItem read fParent;
- property Items[const aIndex: Integer]: TutlMenuItem read GetItems; default;
- property Parameters[const aIndex: Integer]: TutlMenuParameter read GetParameters;
-
- procedure GetAutoCompleteStrings(const aList: TStrings; const aParameter: TutlMenuParameterList); virtual;
- function GetString: String;
- function AddItem(const aCmd, aDesc: String; const aCallback: TutlCallback): TutlMenuItem; overload;
- function AddItem(const aItem: TutlMenuItem): TutlMenuItem; overload;
- procedure DelItem(const aIndex: Integer);
- function AddParameter(const aParameter: TutlMenuParameter): TutlMenuParameter;
- procedure DelParameter(const aIndex: Integer);
-
- procedure LoadFromStream(const aStream: TStream);
- procedure SaveToStream(const aStream: TStream);
-
- constructor Create(const aParent: TutlMenuItem; const aCmd, aDesc: String; const aCallback: TutlCallback);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlParseResult = (prUnknownCommand, prInvalidParam, prInvalidParamCount, prSuccess, prIncompleteCmd);
- TutlHelpOption = (hoNone, hoAll, hoDetail);
- TutlCommandMenu = class(TutlMenuItem)
- private
- fInvalidParam: String;
- fUnknownCmd: String;
- fLastCmd: String;
- fCurrentParamCount: Integer;
- function GetCmdParameter: TutlMenuParameterList;
- protected
- fCmdParameter: TutlMenuParameterStack;
- fCmdStack: TutlStringStack;
- fCurrentMenu: TutlMenuItem;
- procedure SplitCmdString(const aText: String; const aChar: Char);
- function ParseCommand: TutlParseResult;
- public
- property CmdParameter: TutlMenuParameterList read GetCmdParameter;
- property LastCmd: String read fLastCmd;
-
- procedure ExecuteCommand(const aCmd: String); virtual;
-
- procedure DisplayHelp(const aRefMenu: TutlMenuItem = nil; const aOption: TutlHelpOption = hoNone);
- procedure DisplayIncompleteCommand;
- procedure DisplayUnknownCommand(const aCmd: String = '');
- procedure DisplayInvalidParamCount(const aParamCount: Integer = -1);
- procedure DisplayInvalidParam(const aParam: String = '');
-
- constructor Create(const aHelp: String);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlInputEvent = procedure(aSender: TObject; const aInput: String) of Object;
- TutlAutoCompleteEvent = function(aSender: TObject; const aInput: String; const aDisplayPossibilities: Boolean): String of Object;
- TutlCommandPrompt = class(TObject)
- private
- fCurrent: String;
- fInput: String;
- fPrefix: String;
- fHistoryBackup: String;
- fCurID: Integer;
- fStartIndex: Integer;
- fHistoryID: Integer;
- fHistoryEnabled: Boolean;
- fRunning: Boolean;
- fHiddenChar: Char;
- fConsoleCS: TCriticalSection;
- fHistory: TStringList;
-
- fOnInput: TutlInputEvent;
- fOnAutoComplete: TutlAutoCompleteEvent;
-
- function GetCurrent: String;
- procedure SetCurrent(aValue: String);
- procedure SetHiddenChar(aValue: Char);
- procedure SetPrefix(aValue: String);
-
- procedure CursorToStart;
- procedure CursorToEnd;
- procedure DelInput(const aAll: Boolean = false);
- procedure RestoreInput;
- procedure CursorRight;
- procedure CursorLeft;
- procedure DelChar(const aBeforeCursor: Boolean = false);
- procedure WriteChar(const c: Char);
-
- function ReadLnEx: String;
- function AutoComplete(const aInput: String; const aDisplayPossibilities: Boolean): String;
- procedure AddHistory(const aInput: String);
-
- procedure DoInput;
- public
- property Prefix: String read fPrefix write SetPrefix;
- property Current: String read GetCurrent write SetCurrent;
- property HistoryEnabled: Boolean read fHistoryEnabled write fHistoryEnabled;
- property HiddenChar: Char read fHiddenChar write SetHiddenChar;
- property OnInput: TutlInputEvent read fOnInput write fOnInput;
- property OnAutoComplete: TutlAutoCompleteEvent read fOnAutoComplete write fOnAutoComplete;
-
- procedure Start;
- procedure Stop;
- procedure Reset;
- procedure Clear; //löscht nur die Ausgabe und hält die Eingabe intern
- procedure Restore; //stellt die Ausgabe wieder her
-
- constructor Create(const aConsoleCS: TCriticalSection);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlConsoleMenu = class(TutlCommandMenu)
- private
- fExitMenu: TutlMenuItem;
- fCommandPrompt: TutlCommandPrompt;
- fIsAsking: Boolean;
- fInputBackup: String;
-
- fOnAnswer: TutlInputEvent;
-
- procedure CommandInput(aSender: TObject; const aCmd: String);
- function AutoComplete(aSender: TObject; const aCmd: String;
- const aDisplayPossibilities: Boolean): String;
-
- procedure DoAnswer(const aInput: String);
- public
- property CommandPrompt: TutlCommandPrompt read fCommandPrompt;
- property OnAnswer: TutlInputEvent read fOnAnswer;
-
- procedure ExecuteCommand(const aCmd: String); override;
- procedure StartMenu;
- procedure ExitMenu;
- procedure Ask(const aQuestion: String; const aHidden: Boolean = false; const aOnAnswer: TutlInputEvent = nil);
-
- constructor Create(const aHelp: String; const aConsoleCS: TCriticalSection);
- destructor Destroy; override;
- end;
-
-implementation
-
-uses
- strutils,
- uutlLogger,
- uutlKeyCodes,
- {$IFDEF WINDOWS}
- windows
- {$ELSE}
- crt
- {$ENDIF};
-
-const
- COMMAND_PROMPT_PREFIX = '> ';
-
-{$IFDEF WINDOWS}
-var
- ScanCode : char;
- SpecialKey : boolean;
- DoingNumChars: Boolean;
- DoingNumCode: Byte;
-
-Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte; keycode:longint): byte;
- { Several remappings of scancodes are necessary to comply with what
- we get with MSDOS. Special Windows keys, as Alt-Tab, Ctrl-Esc etc.
- are excluded }
-var
- AltKey, CtrlKey, ShiftKey: boolean;
-const
- {
- Keypad key scancodes:
-
- Ctrl Norm
-
- $77 $47 - Home
- $8D $48 - Up arrow
- $84 $49 - PgUp
- $8E $4A - -
- $73 $4B - Left Arrow
- $8F $4C - 5
- $74 $4D - Right arrow
- $4E $4E - +
- $75 $4F - End
- $91 $50 - Down arrow
- $76 $51 - PgDn
- $92 $52 - Ins
- $93 $53 - Del
- }
- CtrlKeypadKeys: array[$47..$53] of byte =
- ($77, $8D, $84, $8E, $73, $8F, $74, $4E, $75, $91, $76, $92, $93);
-
-begin
- AltKey := ((CtrlKeyState AND
- (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
- CtrlKey := ((CtrlKeyState AND
- (RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0);
- ShiftKey := ((CtrlKeyState AND SHIFT_PRESSED) > 0);
-
- if AltKey then
- begin
- case ScanCode of
- // Digits, -, =
- $02..$0D: inc(ScanCode, $76);
- // Function keys
- $3B..$44: inc(Scancode, $2D);
- $57..$58: inc(Scancode, $34);
- // Extended cursor block keys
- $47..$49, $4B, $4D, $4F..$53:
- inc(Scancode, $50);
- // Other keys
- $1C: Scancode := $A6; // Enter
- $35: Scancode := $A4; // / (keypad and normal!)
- end
- end
- else if CtrlKey then
- case Scancode of
- // Tab key
- $0F: Scancode := $94;
- // Function keys
- $3B..$44: inc(Scancode, $23);
- $57..$58: inc(Scancode, $32);
- // Keypad keys
- $35: Scancode := $95; // \
- $37: Scancode := $96; // *
- $47..$53: Scancode := CtrlKeypadKeys[Scancode];
- //Enter on Numpad
- $1C:
- begin
- Scancode := $0A;
- SpecialKey := False;
- end;
- end
- else if ShiftKey then
- case Scancode of
- // Function keys
- $3B..$44: inc(Scancode, $19);
- $57..$58: inc(Scancode, $30);
- //Enter on Numpad
- $1C:
- begin
- Scancode := $0D;
- SpecialKey := False;
- end;
- end
- else
- case Scancode of
- // Function keys
- $57..$58: inc(Scancode, $2E); // F11 and F12
- //Enter on NumPad
- $1C:
- begin
- Scancode := $0D;
- SpecialKey := False;
- end;
- end;
- RemapScanCode := ScanCode;
-end;
-
-
-function KeyPressed : boolean;
-var
- nevents,nread : dword;
- buf : TINPUTRECORD;
- AltKey: Boolean;
- c : longint;
-begin
- KeyPressed := FALSE;
- if ScanCode <> #0 then
- KeyPressed := TRUE
- else
- begin
- GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents{%H-});
- while nevents>0 do
- begin
- ReadConsoleInputA(TextRec(input).Handle,buf{%H-},1,nread{%H-});
- if buf.EventType = KEY_EVENT then
- if buf.Event.KeyEvent.bKeyDown then
- begin
- { Alt key is VK_MENU }
- { Capslock key is VK_CAPITAL }
-
- AltKey := ((Buf.Event.KeyEvent.dwControlKeyState AND
- (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
- if not(Buf.Event.KeyEvent.wVirtualKeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL,
- VK_CAPITAL, VK_NUMLOCK,
- VK_SCROLL]) then
- begin
- keypressed:=true;
-
- if (ord(buf.Event.KeyEvent.AsciiChar) = 0) or
- (buf.Event.KeyEvent.dwControlKeyState and (LEFT_ALT_PRESSED or ENHANCED_KEY) > 0) then
- begin
- SpecialKey := TRUE;
- ScanCode := Chr(RemapScanCode(Buf.Event.KeyEvent.wVirtualScanCode, Buf.Event.KeyEvent.dwControlKeyState,
- Buf.Event.KeyEvent.wVirtualKeyCode));
- end
- else
- begin
- { Map shift-tab }
- if (buf.Event.KeyEvent.AsciiChar=#9) and
- (buf.Event.KeyEvent.dwControlKeyState and SHIFT_PRESSED > 0) then
- begin
- SpecialKey := TRUE;
- ScanCode := #15;
- end
- else
- begin
- SpecialKey := FALSE;
- ScanCode := Chr(Ord(buf.Event.KeyEvent.AsciiChar));
- end;
- end;
-
- if AltKey then
- begin
- case Buf.Event.KeyEvent.wVirtualScanCode of
- 71 : c:=7;
- 72 : c:=8;
- 73 : c:=9;
- 75 : c:=4;
- 76 : c:=5;
- 77 : c:=6;
- 79 : c:=1;
- 80 : c:=2;
- 81 : c:=3;
- 82 : c:=0;
- else
- break;
- end;
- DoingNumChars := true;
- DoingNumCode := Byte((DoingNumCode * 10) + c);
- Keypressed := false;
- Specialkey := false;
- ScanCode := #0;
- end
- else
- break;
- end;
- end
- else
- begin
- if (Buf.Event.KeyEvent.wVirtualKeyCode in [VK_MENU]) then
- if DoingNumChars then
- if DoingNumCode > 0 then
- begin
- ScanCode := Chr(DoingNumCode);
- Keypressed := true;
-
- DoingNumChars := false;
- DoingNumCode := 0;
- break
- end; { if }
- end;
- { if we got a key then we can exit }
- if keypressed then
- exit;
- GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
- end;
- end;
-end;
-
-function ReadKey: char;
-begin
- while (not KeyPressed) do
- Sleep(1);
- if SpecialKey then begin
- ReadKey := #0;
- SpecialKey := FALSE;
- end else begin
- ReadKey := ScanCode;
- ScanCode := #0;
- end;
-end;
-{$ENDIF}
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuParameter////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameter.WriteConfig(const aMCF: TutlMCFSection);
-begin
- with aMCF do begin
- SetString('classname', self.ClassName);
- SetBool ('optional', fOptional);
- SetString('name', fName);
- SetString('description', fDescription);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameter.ReadConfig(const aMCF: TutlMCFSection);
-begin
- with aMCF do begin
- fOptional := GetBool ('optional', true);
- fName := GetString('name', fName);
- fDescription := GetString('description', fDescription);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameter.SetValue(const aValue: String): Boolean;
-begin
- fValue := aValue;
- result := true;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuParameter////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameter.GetString(const aOptions: TutlParameterStringFlags
- ): String;
-begin
- if fOptional then
- result := '(' + fName + ')'
- else
- result := '[' + fName + ']'
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMenuParameter.Create(const aOptional: Boolean; const aName, aDescription: String);
-begin
- inherited Create;
- fOptional := aOptional;
- fName := aName;
- fDescription := aDescription;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMenuParameter.Destroy;
-begin
- inherited Destroy;
-end;
-
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuParameterList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterList.HasParameter(const aName: String): Boolean;
-begin
- result := Assigned(FindParameter(aName));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterList.FindParameter(const aName: String): TutlMenuParameter;
-var
- i: Integer;
-begin
- for i := 0 to Count-1 do begin
- result := Items[i];
- if (result.Name = aName) then
- exit;
- end;
- result := nil
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuParameterStack///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterStack.Push(const aValue: TutlMenuParameter);
-begin
- Add(aValue);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterStack.Seek: TutlMenuParameter;
-begin
- if (Count > 0) then
- result := Items[Count-1]
- else
- result := nil;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterStack.Pop: TutlMenuParameter;
-begin
- if (Count > 0) then begin
- result := Items[Count-1];
- Delete(Count-1);
- end else
- result := nil;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterSingle.WriteConfig(const aMCF: TutlMCFSection);
-begin
- inherited WriteConfig(aMCF);
- aMCF.SetString('type', TutlParameterTypeH.ToString(fType));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterSingle.ReadConfig(const aMCF: TutlMCFSection);
-begin
- inherited ReadConfig(aMCF);
- fType := TutlParameterTypeH.ToEnum(aMCF.GetString('type', TutlParameterTypeH.ToString(ptPreset)));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuParameterSingle//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterSingle.GetAutoCompleteStrings(const aStrings: TStrings);
-begin
- case fType of
- ptBoolean: begin
- aStrings.Add('true');
- aStrings.Add('false');
- end;
- ptInteger: begin
- aStrings.Add('[integer]');
- end;
- ptHex: begin
- aStrings.Add('[hex]');
- end;
- ptString: begin
- aStrings.Add('[string]');
- end;
- ptPreset: begin
- aStrings.Add(fName);
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterSingle.SetValue(const aValue: String): Boolean;
-const
- BOOL_ARR: array[0..7] of String = ('y', 'n', 't', 'f', 'yes', 'no', 'true', 'false');
-
- function IsInArr: Boolean;
- var
- i: Integer;
- s: String;
- begin
- s := LowerCase(aValue);
- result := true;
- for i := 0 to high(BOOL_ARR) do
- if (BOOL_ARR[i] = s) then
- exit;
- result := false;
- end;
-
-var
- i: Integer;
- c: QWord;
-begin
- result := false;
- case fType of
- ptBoolean:
- if IsInArr then
- result := true;
- ptInteger:
- result := TryStrToInt(aValue, i);
- ptHex:
- result := AnsiStartsStr('0x', aValue) and TryStrToQWord('$' + AnsiRightStr(aValue, Length(aValue)-2), c);
- ptPreset:
- result := (aValue = fName);
- ptString:
- result := true;
- end;
- if result then
- result := inherited SetValue(aValue);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuParameterSingle//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterSingle.GetString(const aOptions: TutlParameterStringFlags): String;
-begin
- result := fName;
- case fType of
- ptBoolean:
- result := result+':b';
- ptHex:
- result := result+':h';
- ptInteger:
- result := result+':i';
- ptString:
- result := result+':s';
- ptPreset:
- result := '''' + result + '''';
- end;
- if (psfBrackets in aOptions) then begin
- if fOptional then
- result := '(' + result + ')'
- else
- result := '[' + result + ']';
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMenuParameterSingle.Create(const aOptional: Boolean;
- const aName, aDescription: String; const aType: TutlParameterType);
-begin
- inherited Create(aOptional, aName, aDescription);
- fType := aType;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMenuParameterSingle.Destroy;
-begin
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuParameterGroup///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterGroup.GetCount: Integer;
-begin
- result := fParameters.Count;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterGroup.GetParameter(const aIndex: Integer): TutlMenuParameterSingle;
-begin
- if (aIndex >= 0) and (aIndex < fParameters.Count) then
- result := fParameters[aIndex]
- else
- raise Exception.Create(format('TMenuParameterGroup.GetParameter - index out of bounds (%d)', [aIndex]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterGroup.WriteConfig(const aMCF: TutlMCFSection);
-var
- i: Integer;
-begin
- inherited WriteConfig(aMCF);
- with aMCF.Sections['parameters'] do begin
- SetInt('count', fParameters.Count);
- for i := 0 to fParameters.Count-1 do
- fParameters[i].WriteConfig(Sections[IntToStr(i)]);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterGroup.ReadConfig(const aMCF: TutlMCFSection);
-var
- c, i: Integer;
-begin
- inherited ReadConfig(aMCF);
- with aMCF.Sections['parameters'] do begin
- c := GetInt('count', 0);
- for i := 0 to c-1 do
- AddParameter('', '', ptPreset).ReadConfig(Sections[IntToStr(i)]);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterGroup.GetAutoCompleteStrings(const aStrings: TStrings);
-var
- i: Integer;
-begin
- for i := 0 to fParameters.Count-1 do
- fParameters[i].GetAutoCompleteStrings(aStrings);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterGroup.SetValue(const aValue: String): Boolean;
-var
- i: Integer;
-begin
- for i := 0 to fParameters.Count-1 do
- if fParameters[i].SetValue(aValue) then begin
- result := inherited SetValue(aValue);
- break;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterGroup.GetString(const aOptions: TutlParameterStringFlags): String;
-var
- i: Integer;
- s: String;
-begin
- result := '';
- for i := 0 to fParameters.Count-1 do begin
- if result <> '' then
- result := result + '|';
- s := fParameters[i].GetString;
- s := copy(s, 2, Length(s)-2);
- result := result + s;
- end;
- result := fName + ':' + result;
- if (psfBrackets in aOptions) then begin
- if (fOptional) then
- result := '(' + result + ')'
- else
- result := '[' + result + ']';
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterGroup.AddParameter(const aName, aDescription: String; const aType: TutlParameterType): TutlMenuParameterSingle;
-begin
- result := TutlMenuParameterSingle.Create(false, aName, aDescription, aType);
- fParameters.Add(result);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuParameterGroup.AddParameter(const aParameter: TutlMenuParameterSingle): TutlMenuParameterSingle;
-begin
- result := aParameter;
- fParameters.Add(result);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuParameterGroup.DelParameter(const aIndex: Integer);
-begin
- if (aIndex >= 0) and (aIndex < fParameters.Count) then
- fParameters.Delete(aIndex)
- else
- raise Exception.Create(format('TMenuParameterGroup.DelParameter - index out of bounds (%d)', [aIndex]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMenuParameterGroup.Create(const aOptional: Boolean; const aName, aDescription: String);
-begin
- inherited Create(aOptional, aName, aDescription);
- fParameters := TutlMenuParameterSingleList.Create(true);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMenuParameterGroup.Destroy;
-begin
- FreeAndNil(fParameters);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMenuItem/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.GetCount: Integer;
-begin
- result := fItems.Count;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.GetItems(const aIndex: Integer): TutlMenuItem;
-begin
- if (aIndex >= 0) and (aIndex < fItems.Count) then
- result := fItems[aIndex]
- else
- raise Exception.Create(format('TMenuItem.GetItems - index out of bounds (%d)', [aIndex]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.GetMenuPath: String;
-var
- m: TutlMenuItem;
-begin
- result := '';
- m := self;
- while Assigned(m) do begin
- if Length(result) > 0 then
- result := ' ' + result;
- result := m.GetString + result; //m.Command + result;
- if (m <> m.Parent) then
- m := m.Parent
- else
- m := nil;
- end;
- result := Trim(result);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.GetParamCount: Integer;
-begin
- result := fParameters.Count;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.GetParameters(const aIndex: Integer): TutlMenuParameter;
-begin
- if (aIndex >= 0) and (aIndex < fParameters.Count) then
- result := fParameters[aIndex]
- else
- raise Exception.Create(format('TMenuItem.GetParameters - index out of bounds', [aIndex]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.GetParameterString: String;
-var
- i: Integer;
-begin
- result := '';
- for i := 0 to fParameters.Count-1 do begin
- if result <> '' then
- result := result + ' ';
- result := result + fParameters[i].GetString;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.SetCallback(aValue: TutlCallback);
-begin
- if fCallback = aValue then
- exit;
- fCallback := aValue;
- fExecutable := Assigned(fCallback);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.WriteConfig(const aMCF: TutlMCFSection);
-var
- i: Integer;
-begin
- with aMCF do begin
- SetString('command', fCommand);
- SetString('description', fDescription);
- SetBool ('executable', fExecutable);
- with Sections['parameters'] do begin
- SetInt('count', fParameters.Count);
- for i := 0 to fParameters.Count-1 do
- fParameters[i].WriteConfig(Sections[IntToStr(i)]);
- end;
- with Sections['menus'] do begin
- SetInt('count', fItems.Count);
- for i := 0 to fItems.Count-1 do
- fItems[i].WriteConfig(Sections[IntToStr(i)]);
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.ReadConfig(const aMCF: TutlMCFSection);
-var
- c, i: Integer;
- s: String;
- p: TutlMenuParameter;
-begin
- fItems.Clear;
- fParameters.Clear;
- with aMCF do begin
- fCommand := GetString('command', '');
- fDescription := GetString('description', '');
- fExecutable := GetBool ('executable', false);
- with Sections['parameters'] do begin
- c := GetInt('count', 0);
- for i := 0 to c-1 do begin
- s := Sections[IntToStr(i)].GetString('classname', '');
- p := nil;
- if (s = TutlMenuParameterSingle.ClassName) then
- p := TutlMenuParameterSingle.Create(true, '', '', ptPreset)
- else if (s = TutlMenuParameterGroup.ClassName) then
- p := TutlMenuParameterGroup.Create(true, '', '');
- if Assigned(p) then begin
- fParameters.Add(p);
- p.ReadConfig(Sections[IntToStr(i)]);
- end;
- end;
- end;
- with Sections['menus'] do begin
- c := GetInt('count', 0);
- for i := 0 to c-1 do
- AddItem('', '', nil).ReadConfig(Sections[IntToStr(i)]);
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.GetAutoCompleteStrings(const aList: TStrings; const aParameter: TutlMenuParameterList);
-var
- hasAllParam: Boolean;
- i: Integer;
- p: TutlMenuParameter;
-begin
- hasAllParam := true;
- for i := 0 to fParameters.Count-1 do begin
- p := fParameters[i];
- if not p.Optional then begin
- if not aParameter.HasParameter(p.Name) then begin
- p.GetAutoCompleteStrings(aList);
- hasAllParam := false;
- break;
- end;
- end else begin
- if not aParameter.HasParameter(p.Name) then
- p.GetAutoCompleteStrings(aList);
- end;
- end;
- if hasAllParam then begin
- for i := 0 to fItems.Count-1 do
- aList.Add(fItems[i].Command);
- if Command <> 'help' then
- aList.Add('help');
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.GetString: String;
-var
- s: String;
-begin
- result := Command;
- s := ParameterString;
- if (Command <> '') and (s <> '') then
- result := result + ' ';
- result := result + s;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.AddItem(const aCmd, aDesc: String; const aCallback: TutlCallback): TutlMenuItem;
-begin
- result := TutlMenuItem.Create(self, aCmd, aDesc, aCallback);
- fItems.Add(result);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.AddItem(const aItem: TutlMenuItem): TutlMenuItem;
-begin
- result := aItem;
- fItems.Add(result);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.DelItem(const aIndex: Integer);
-begin
- if (aIndex >= 0) and (aIndex < fItems.Count) then
- fItems.Delete(aIndex)
- else
- raise Exception.Create(format('TMenuItem.DelItem - index out of bounds (%d)', [aIndex]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMenuItem.AddParameter(const aParameter: TutlMenuParameter): TutlMenuParameter;
-begin
- result := aParameter;
- result.fParent := self;
- fParameters.Add(result);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.DelParameter(const aIndex: Integer);
-begin
- if (aIndex >= 0) and (aIndex < fParameters.Count) then
- fParameters.Delete(aIndex)
- else
- raise Exception.Create(format('TMenuItem.DelParameter - index out of bounds (%d)', [aIndex]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMenuItem.Create(const aParent: TutlMenuItem; const aCmd, aDesc: String; const aCallback: TutlCallback);
-begin
- inherited Create;
- fParent := aParent;
- fCommand := aCmd;
- fDescription := aDesc;
- fCallback := aCallback;
- fExecutable := Assigned(fCallback);
- fItems := TutlMenuItemList.Create(true);
- fParameters := TutlMenuParameterList.Create(true);
-
- if aCmd <> 'help' then begin
- fHelpItem := TutlMenuItem.Create(self, 'help', 'shows the help. use ''all'' to display the menu tree. use ''detail'' to display command details', nil);
- with fHelpItem.AddParameter(TutlMenuParameterGroup.Create(true, 'mode', 'specify how to display the help menu')) as TutlMenuParameterGroup do begin
- AddParameter('all', 'displays the complete menu tree', ptPreset);
- AddParameter('detail', 'displays detailed information', ptPreset);
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMenuItem.Destroy;
-begin
- FreeAndNil(fItems);
- FreeAndNil(fParameters);
- FreeAndNil(fHelpItem);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlCommandMenu//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlCommandMenu.GetCmdParameter: TutlMenuParameterList;
-begin
- result := fCmdParameter;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandMenu.SplitCmdString(const aText: String; const aChar: Char);
-var
- i: Integer;
- Buffer: String;
- Quote: Boolean;
-begin
- fCmdStack.Clear;
- Buffer := '';
- Quote := false;
- for i := 1 to Length(aText) do begin
- if (aText[i] = aChar) and not Quote then begin
- Buffer := Trim(Buffer);
- fCmdStack.Add(Buffer);
- Buffer := '';
- end else if (aText[i] = '"') then
- Quote := not Quote
- else
- Buffer := Buffer + aText[i];
- end;
- if Buffer <> '' then begin
- Buffer := Trim(Buffer);
- fCmdStack.Add(Buffer);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlCommandMenu.ParseCommand: TutlParseResult;
-
- procedure RestoreParameterStack(const aMenu: TutlMenuItem);
- var
- p: TutlMenuParameter;
- begin
- p := fCmdParameter.Seek;
- while Assigned(p) and (p.Parent = aMenu) do begin
- fCmdStack.Push(p.Value);
- fCmdParameter.Pop;
- p := fCmdParameter.Seek;
- end;
- end;
-
- function BackTrack(const aMenu: TutlMenuItem): TutlParseResult;
- var
- s, cmd: String;
- OptionalParamCount: Integer;
- i, c: Integer;
- m: TutlMenuItem;
- p: TutlMenuParameter;
- begin
- //Stack is empty
- if (fCmdStack.Count = 0) then begin
- if Assigned(aMenu.Callback) or (aMenu = fHelpItem) then
- result := prSuccess
- else
- result := prIncompleteCmd;
- fCurrentMenu := aMenu;
- exit;
- end;
- s := fCmdStack.Pop;
- cmd := LowerCase(s);
-
- //find command
- m := nil;
- for i := 0 to aMenu.Count-1 do
- if (LowerCase(aMenu[i].Command) = cmd) then begin
- m := aMenu[i];
- break;
- end;
- if not Assigned(m) and (cmd = 'help') then begin
- m := fHelpItem;
- m.fParent := aMenu;
- end;
-
- if Assigned(m) then begin
- //count optional parameters
- c := 0;
- for i := 0 to m.ParamCount-1 do
- if (m.Parameters[i].Optional) then
- inc(c);
- OptionalParamCount := (1 shl c) - 1;
-
- //backtrack optional parameters
- while (OptionalParamCount >= 0) do begin
- result := prSuccess;
- fCurrentParamCount := 0;
- c := 0;
- for i := 0 to m.ParamCount-1 do begin
- p := m.Parameters[i];
- if not p.Optional or (((OptionalParamCount shr c) and 1) = 1) then begin
- if (fCmdStack.Count <= 0) then begin
- result := prInvalidParamCount;
- RestoreParameterStack(m);
- fCurrentMenu := m;
- break;
- end else if (LowerCase(fCmdStack.Seek) = 'help') then begin
- break;
- end else if not (p.SetValue(fCmdStack.Seek)) then begin
- result := prInvalidParam;
- RestoreParameterStack(m);
- fCurrentMenu := m;
- break;
- end else begin
- inc(fCurrentParamCount);
- fCmdParameter.Push(p);
- fCmdStack.Pop;
- end;
- if p.Optional then
- inc(c);
- end;
- end;
-
- if (result = prSuccess) then begin
- result := BackTrack(m);
- if result = prUnknownCommand then
- fCurrentMenu := aMenu;
- end;
- if result <> prSuccess then
- dec(OptionalParamCount)
- else
- OptionalParamCount := -1;
- end;
- end else begin
- fCmdStack.Push(s);
- fUnknownCmd := s;
- result := prUnknownCommand;
- end;
- end;
-
-begin
- fCmdParameter.Clear;
- fCurrentParamCount := 0;
- fInvalidParam := '';
- fUnknownCmd := '';
- fCurrentMenu := nil;
- result := BackTrack(self);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandMenu.ExecuteCommand(const aCmd: String);
-var
- r: TutlParseResult;
- p: TutlMenuParameter;
-begin
- fLastCmd := aCmd;
- SplitCmdString(aCmd, ' ');
- r := ParseCommand;
- case r of
- prSuccess:
- if (fCurrentMenu = fHelpItem) then begin
- p := nil;
- if (fCmdParameter.Count > 0) and (fCmdParameter[fCmdParameter.Count-1].Parent = fHelpItem) then
- p := fCmdParameter[fCmdParameter.Count-1];
- if not Assigned(p) then
- DisplayHelp(fHelpItem.Parent)
- else if (p.Value = 'all') then
- DisplayHelp(fHelpItem.Parent, hoAll)
- else if (p.Value = 'detail') then
- DisplayHelp(fHelpItem.Parent, hoDetail)
- else
- DisplayHelp(fHelpItem.Parent);
- end else
- fCurrentMenu.Callback(self);
- prInvalidParam:
- DisplayInvalidParam(fInvalidParam);
- prInvalidParamCount:
- DisplayInvalidParamCount(fCurrentParamCount);
- prIncompleteCmd:
- DisplayIncompleteCommand;
- prUnknownCommand:
- DisplayUnknownCommand(fUnknownCmd);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandMenu.DisplayHelp(const aRefMenu: TutlMenuItem; const aOption: TutlHelpOption);
-var
- maxLength: Integer;
-
- function AddStr(const aOld, aNew, aPostfix: String): String;
- begin
- result := aOld;
- if (aOld <> '') and (aNew <> '') then
- result := result + aPostfix;
- result := result + aNew;
- end;
-
- function GetMaxLength(const aItem: TutlMenuItem): Integer;
- var
- i, l: Integer;
- m: TutlMenuItem;
- begin
- result := 0;
- for i := 0 to aItem.Count-1 do begin
- m := aItem[i];
- l := Length(m.GetString);
- if l > result then
- result := l;
- if (aOption = hoAll) then begin
- l := GetMaxLength(m) + 2;
- if l > result then
- result := l;
- end;
- end;
- end;
-
- function FillStr(const aStr: String; const aChar: Char; const aLength: Integer): String;
- begin
- result := aStr + StringOfChar(aChar, aLength-Length(aStr));
- end;
-
- procedure AddHelpText(var aMsg: String; const aPrefix: String; const aItem: TutlMenuItem);
- begin
- if (aMsg <> '') then
- aMsg := aMsg + sLineBreak;
- aMsg := aMsg + FillStr(aPrefix + aItem.GetString, ' ', maxLength) + ' ' + aItem.Description;
- end;
-
- procedure AddHelpItems(var aMsg: String; const aPrefix: String; const aItem: TutlMenuItem; const aDisplayHelpItem: Boolean = false);
- var
- i: Integer;
- m: TutlMenuItem;
- begin
- for i := 0 to aItem.Count-1 do begin
- m := aItem[i];
- AddHelpText(aMsg, aPrefix, m);
- if (aOption = hoAll) then
- AddHelpItems(aMsg, aPrefix+' ', m);
- end;
- if aDisplayHelpItem then
- AddHelpText(aMsg, aPrefix, fHelpItem);
- end;
-
- procedure DisplayGroupParameters(var aMsg: String; const aParamGroup: TutlMenuParameterGroup);
- var
- i, maxLen, l: Integer;
- p: TutlMenuParameter;
- begin
- maxLen := 0;
- for i := 0 to aParamGroup.Count-1 do begin
- l := Length(aParamGroup[i].GetString([]));
- if l > maxLen then
- maxLen := l;
- end;
- inc(maxLen, 3);
-
- for i := 0 to aParamGroup.Count-1 do begin
- p := aParamGroup[i];
- aMsg := aMsg + sLineBreak + ' ' +
- FillStr(p.GetString([]), ' ', maxLen) +
- p.Description;
- end;
- end;
-
- procedure DisplayParameters(var aMsg: String);
- var
- i, maxLen, l: Integer;
- p: TutlMenuParameter;
- begin
- maxLen := 0;
- for i := 0 to aRefMenu.ParamCount-1 do begin
- l := Length(aRefMenu.Parameters[i].GetString);
- if (l > maxLen) then
- maxLen := l;
- end;
- inc(maxLen, 3);
-
- aMsg := aMsg + sLineBreak + 'Parameters:';
- if (aRefMenu.ParamCount > 0) then begin
- for i := 0 to aRefMenu.ParamCount-1 do begin
- p := aRefMenu.Parameters[i];
- aMsg := aMsg + sLineBreak + ' ' + FillStr(p.GetString, ' ', maxLen);
- if p.Optional then
- aMsg := aMsg + '(optional) '
- else
- aMsg := aMsg + ' ';
- aMsg := aMsg + p.Description;
- if (p is TutlMenuParameterGroup) then
- DisplayGroupParameters(aMsg, p as TutlMenuParameterGroup);
- end;
- end else
- aMsg := aMsg + sLineBreak + ' [no Parameters]';
- end;
-
-var
- menu: TutlMenuItem;
- msg: String;
-begin
- if Assigned(aRefMenu) then
- menu := aRefMenu
- else
- menu := self;
-
- msg := AddStr(menu.MenuPath, menu.ParameterString, ' ');
- msg := AddStr(msg, menu.Description, ' - ');
- fHelpItem.fParent := nil;
- if (aOption = hoDetail) then
- msg := msg + sLineBreak + 'Submenus / Commands:';
- maxLength := max(GetMaxLength(menu), Length(fHelpItem.GetString)) + 2;
- if (msg = '') then
- msg := sLineBreak;
- AddHelpItems(msg, ' ', menu, true);
- if (aRefMenu is TutlConsoleMenu) then
- AddHelpText(msg, ' ', (self as TutlConsoleMenu).fExitMenu);
- if (aOption = hoDetail) then
- DisplayParameters(msg);
- utlLogger.Log(Self, msg, []);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandMenu.DisplayIncompleteCommand;
-
- function GetMenuPath: String;
- var
- s: String;
- begin
- s := '';
- if Assigned(fCurrentMenu) then
- s := fCurrentMenu.MenuPath;
- if (s <> '') then
- result := s+' '
- else
- result := '';
- end;
-
-begin
- utlLogger.Error(Self, 'incomplete command! type "%shelp" to get further information.', [GetMenuPath]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandMenu.DisplayUnknownCommand(const aCmd: String);
-
- function GetMenuPath: String;
- var
- s: String;
- begin
- s := '';
- if Assigned(fCurrentMenu) then
- s := fCurrentMenu.MenuPath;
- if (s <> '') then
- result := s+' '
- else
- result := '';
- end;
-
- function GetCommand: String;
- begin
- if (aCmd <> '') then
- result := ' "'+aCmd+'"'
- else
- result := '';
- end;
-
-begin
- utlLogger.Error(Self, 'unknown command%s! type "%shelp" to get further information.', [GetCommand, GetMenuPath]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandMenu.DisplayInvalidParamCount(const aParamCount: Integer);
-
- function GetMenuPath: String;
- var
- s: String;
- begin
- s := '';
- if Assigned(fCurrentMenu) then
- s := fCurrentMenu.MenuPath;
- if (s <> '') then
- result := s+' '
- else
- result := '';
- end;
-
- function GetParamCount: String;
- var
- i, c: Integer;
- begin
- result := ' (';
- if (aParamCount >= 0) then begin
- result := result + IntToStr(aParamCount);
- end;
- if Assigned(fCurrentMenu) then begin
- c := 0;
- for i := 0 to fCurrentMenu.ParamCount-1 do
- if not fCurrentMenu.Parameters[i].Optional then
- inc(c);
- result := result + ', expected '+IntToStr(c);
- end;
- result := result + ')';
- if (result = ' ()') then
- result := '';
- end;
-
-begin
- utlLogger.Log(Self, 'invalid parameter count%s! type "%shelp" to get further information.', [GetParamCount, GetMenuPath]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandMenu.DisplayInvalidParam(const aParam: String);
-
- function GetMenuPath: String;
- var
- s: String;
- begin
- s := '';
- if Assigned(fCurrentMenu) then
- s := fCurrentMenu.MenuPath;
- if (s <> '') then
- result := s+' '
- else
- result := '';
- end;
-
- function GetParam: String;
- begin
- if (aParam <> '') then
- result := ' "'+aParam+'"'
- else
- result := '';
- end;
-
-begin
- utlLogger.Log(Self, 'invalid parameter%s! type "%shelp" to get further information.', [GetParam, GetMenuPath]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.LoadFromStream(const aStream: TStream);
-var
- mcf: TutlMCFFile;
-begin
- mcf := TutlMCFFile.Create(nil);
- try
- mcf.LoadFromStream(aStream);
- ReadConfig(mcf);
- finally
- mcf.Free;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMenuItem.SaveToStream(const aStream: TStream);
-var
- mcf: TutlMCFFile;
-begin
- mcf := TutlMCFFile.Create(nil);
- try
- WriteConfig(mcf);
- mcf.SaveToStream(aStream);
- finally
- mcf.Free;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlCommandMenu.Create(const aHelp: String);
-begin
- inherited Create(nil, '', aHelp, nil);
- fCmdStack := TutlStringStack.Create;
- fCmdParameter := TutlMenuParameterStack.Create(False);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlCommandMenu.Destroy;
-begin
- FreeAndNil(fCmdStack);
- FreeAndNil(fCmdParameter);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlCommandPrompt/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.SetPrefix(aValue: String);
-begin
- if fPrefix = aValue then
- exit;
- DelInput(true);
- delete(fCurrent, 1, Length(fPrefix));
- if fHistoryID >= 0 then
- delete(fHistoryBackup, 1, Length(fPrefix));
- fPrefix := aValue;
- fStartIndex := Length(fPrefix)+1;
- fCurrent := fPrefix + fCurrent;
- if fHistoryID >= 0 then
- fHistoryBackup := fPrefix + fHistoryBackup;
- RestoreInput;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlCommandPrompt.GetCurrent: String;
-begin
- if fHistoryID = -1 then
- result := copy(fCurrent, fStartIndex, MaxInt)
- else
- result := copy(fHistoryBackup, fStartIndex, MaxInt);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.SetCurrent(aValue: String);
-begin
- DelInput;
- fCurrent := fPrefix + aValue;
- fHistoryID := -1;
- RestoreInput;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.SetHiddenChar(aValue: Char);
-begin
- if fHiddenChar = aValue then
- exit;
- DelInput(true);
- fHiddenChar := aValue;
- RestoreInput;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.CursorToStart;
-begin
- Write(StringOfChar(#8, fCurID-fStartIndex));
- fCurID := fStartIndex;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.CursorToEnd;
-begin
- Write(Copy(fCurrent, fCurID, MaxInt));
- fCurID := Length(fCurrent)+1;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.DelInput(const aAll: Boolean);
-var
- l: Integer;
-begin
- if not aAll then
- l := fCurID - fStartIndex
- else
- l := fCurID - 1;
- Write(StringOfChar(#08, l));
- Write(StringOfChar(' ', l));
- Write(StringOfChar(#08, l));
- dec(fCurID, l);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.RestoreInput;
-begin
- if (fHiddenChar <> #0) then begin
- while fCurID < fStartIndex do begin
- Write(fCurrent[fCurID]);
- inc(fCurID);
- end;
- Write(StringOfChar(fHiddenChar, Length(fCurrent) - fCurID + 1))
- end else
- Write(Copy(fCurrent, fCurID, MaxInt));
- fCurID := Length(fCurrent)+1;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.CursorRight;
-begin
- if fCurID <= Length(fCurrent) then begin
- if (fHiddenChar <> #0) then
- Write(fHiddenChar)
- else
- Write(fCurrent[fCurID]);
- inc(fCurID);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.CursorLeft;
-begin
- if fCurID > fStartIndex then begin
- Write(#8);
- dec(fCurID, 1);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.DelChar(const aBeforeCursor: Boolean);
-begin
- if not aBeforeCursor and (fCurID <= Length(fCurrent)) then begin
- Delete(fCurrent, fCurID, 1);
- Write(copy(fCurrent, fCurID, MaxInt), ' ');
- Write(StringOfChar(#8, Length(fCurrent)-fCurID+2));
- end else if aBeforeCursor and (fCurID > fStartIndex) then begin
- Delete(fCurrent, fCurID-1, 1);
- Write(#8, copy(fCurrent, fCurID-1, MaxInt), ' ');
- Write(StringOfChar(#8, Length(fCurrent)-fCurID+3));
- dec(fCurID);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.WriteChar(const c: Char);
-begin
- if (fCurID <= Length(fCurrent)) then begin
- Write('#', copy(fCurrent, fCurID, MaxInt));
- Write(StringOfChar(#8, Length(fCurrent)-fCurID+2));
- end;
- Insert(c, fCurrent, fCurID);
- inc(fCurID, 1);
- if (fHiddenChar <> #0) then
- Write(fHiddenChar)
- else
- Write(c);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlCommandPrompt.ReadLnEx: String;
-var
- c: Byte;
- key: Char;
- CtrlKey: Boolean;
- s: String;
- tabPressed: Boolean;
-begin
- fHistoryID := -1;
- CtrlKey := false;
- tabPressed := false;
-
- fConsoleCS.Enter;
- try
- DelInput(true);
- RestoreInput;
- finally
- fConsoleCS.Leave;
- end;
-
- while fRunning do begin
- key := ReadKey;
- c := Ord(key) and $FF;
- fConsoleCS.Enter;
- try
- if (CtrlKey) then begin
- CtrlKey := false;
- case c of
- 72: begin //KEY_UP
- if (fHistoryID+1 < fHistory.Count) then begin
- if (fHistoryID = -1) then
- fHistoryBackup := fCurrent;
- CursorToEnd;
- DelInput;
- inc(fHistoryID);
- fCurrent := fPrefix + fHistory[fHistoryID];
- RestoreInput;
- end;
- end;
- 80: begin //KEY_DOWN
- if (fHistoryID >= 0) then begin
- CursorToEnd;
- DelInput;
- dec(fHistoryID);
- if (fHistoryID >= 0) then
- fCurrent := fPrefix + fHistory[fHistoryID]
- else
- fCurrent := fHistoryBackup;
- RestoreInput;
- end;
- end;
- 75: begin //KEY_LEFT
- CursorLeft;
- end;
- 77: begin //KEY_RIGHT
- CursorRight;
- end;
- 82: begin //KEY_INSERT
- end;
- 83: begin //KEY_DELETE
- DelChar(false);
- end;
- 71: begin //KEY_HOME
- CursorToStart;
- end;
- 79: begin //KEY_END
- CursorToEnd;
- end;
- 73: begin //KEY_PGUP
- end;
- 81: begin //KEY_PGDOWN
- end;
- end;
- end else begin
- if (tabPressed) then
- tabPressed := (c = VK_TAB);
- case c of
- VK_UNKNOWN: begin
- CtrlKey := true;
- end;
- VK_BACK: begin
- DelChar(true);
- end;
- VK_TAB: begin
- CursorToEnd;
- DelInput;
- s := fCurrent;
- fCurrent := fPrefix +
- AutoComplete(copy(fCurrent, fStartIndex, MaxInt), tabPressed);
- RestoreInput;
- if s <> fCurrent then
- tabPressed := false
- else
- tabPressed := not tabPressed;
- end;
- VK_RETURN: begin //RETURN
- break;
- end;
- VK_ESCAPE: begin
- Reset;
- end;
- else
- WriteChar(Chr(c));
- end;
- end;
- finally
- fConsoleCS.Leave;
- end;
- end;
-
- fConsoleCS.Enter;
- try
- WriteLn;
- finally
- fConsoleCS.Leave;
- end;
- result := copy(fCurrent, Length(fPrefix)+1, MaxInt);
- Reset;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlCommandPrompt.AutoComplete(const aInput: String; const aDisplayPossibilities: Boolean): String;
-begin
- result := aInput;
- if Assigned(fOnAutoComplete) then
- result := fOnAutoComplete(self, aInput, aDisplayPossibilities);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.AddHistory(const aInput: String);
-begin
- if fHistoryEnabled and (fHiddenChar = #0) and
- ((fHistory.Count <= 0) or (fHistory[0] <> aInput)) then
- fHistory.Insert(0, aInput);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.DoInput;
-begin
- if Assigned(fOnInput) then
- fOnInput(self, fInput);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.Start;
-begin
- Reset;
- fRunning := true;
- while fRunning do begin
- fInput := ReadLnEx;
- AddHistory(fInput);
- DoInput;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.Stop;
-begin
- fRunning := false;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.Reset;
-begin
- CursorToEnd;
- DelInput(true);
- fCurrent := fPrefix;
- fCurID := 1;
- Restore;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.Clear;
-begin
- fConsoleCS.Enter;
- try
- DelInput(true);
- finally
- fConsoleCS.Leave;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCommandPrompt.Restore;
-begin
- fConsoleCS.Enter;
- try
- RestoreInput;
- finally
- fConsoleCS.Leave;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlCommandPrompt.Create(const aConsoleCS: syncobjs.TCriticalSection);
-begin
- inherited Create;
- fConsoleCS := aConsoleCS;
- fPrefix := COMMAND_PROMPT_PREFIX;
- fHistory := TStringList.Create;
- fHistoryEnabled := true;
- fStartIndex := Length(fPrefix)+1;
-end;
-
-destructor TutlCommandPrompt.Destroy;
-begin
- FreeAndNil(fHistory);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlConsoleMenu//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlConsoleMenu.CommandInput(aSender: TObject; const aCmd: String);
-begin
- if fIsAsking then begin
- fIsAsking := false;
- fCommandPrompt.Current := fInputBackup;
- fCommandPrompt.Prefix := COMMAND_PROMPT_PREFIX;
- fCommandPrompt.OnAutoComplete := @AutoComplete;
- fCommandPrompt.HiddenChar := #0;
- fCommandPrompt.HistoryEnabled := true;
- DoAnswer(aCmd);
- end else begin
- utlLogger.Debug(Self, 'CMD: ' + aCmd, []);
- ExecuteCommand(aCmd);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlConsoleMenu.AutoComplete(aSender: TObject; const aCmd: String;
- const aDisplayPossibilities: Boolean): String;
-var
- r: TutlParseResult;
- s, cmd: String;
- c: Char;
- cmdList: TStringList;
- i, CharIndex, MaxLength: Integer;
-
- function TestParam(const aParam: String): Boolean;
- var
- i: Integer;
- c: QWord;
- begin
- if aParam = '[integer]' then
- result := TryStrToInt(s, i)
- else if aParam = '[hex]' then
- result := AnsiStartsStr('0x', s) and TryStrToQWord('$' + copy(s, 3, MaxInt), c)
- else
- result := true;
- end;
-
- function NextChar: Char;
- var
- i: Integer;
- c: String;
- begin
- result := #0;
- try
- for i := 0 to cmdList.Count-1 do begin
- c := cmdList[i];
- if (Length(c) > 0) and (c[1] <> '[') then begin
- if (Length(c) >= CharIndex) then begin
- if (result = #0) then
- result := c[CharIndex]
- else if (result <> c[CharIndex]) then begin
- result := #0;
- exit;
- end;
- end;
- end;
- end;
- finally
- inc(CharIndex);
- end;
- end;
-
- function GetMaxLength: Integer;
- var
- i, l: Integer;
- begin
- result := 0;
- for i := 0 to cmdList.Count-1 do begin
- l := Length(cmdList[i]);
- if l > result then
- result := l;
- end;
- end;
-
-begin
- SplitCmdString(aCmd, ' ');
- s := '';
- if (Length(aCmd) > 0) and (aCmd[Length(aCmd)] <> ' ') then begin
- s := fCmdStack[fCmdStack.Count-1];
- fCmdStack.Delete(fCmdStack.Count-1);
- end;
- r := ParseCommand;
- result := aCmd;
- if (r in [prSuccess, prIncompleteCmd, prInvalidParamCount]) and Assigned(fCurrentMenu) then begin
- cmdList := TStringList.Create;
- try
- fCurrentMenu.GetAutoCompleteStrings(cmdList, fCmdParameter);
- if (s <> '') then begin
- for i := cmdList.Count-1 downto 0 do begin
- cmd := cmdList[i];
- if (Length(cmd) > 0) and (cmd[1] = '[') then begin
- if not TestParam(cmd) then
- cmdList.Delete(i);
- end else if not AnsiStartsStr(s, cmd) then
- cmdList.Delete(i);
- end;
- end;
-
- CharIndex := Length(s)+1;
- c := NextChar;
- while c <> #0 do begin
- result := result + c;
- c := NextChar;
- end;
- if (cmdList.Count = 1) then
- result := result + ' ';
-
- if aDisplayPossibilities then begin
- WriteLn('');
- s := '';
- MaxLength := GetMaxLength+5;
- for i := 0 to cmdList.Count-1 do begin
- cmd := cmdList[i];
- s := s + cmd + StringOfChar(' ', MaxLength-Length(cmd));
- if ((i+1) mod 5) = 0 then begin
- writeln(s);
- s := '';
- end;
- end;
- if (s <> '') then
- WriteLn(s);
- if (cmdList.Count = 0) then
- WriteLn('[no possible commands]');
- end;
- finally
- cmdList.Free;
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlConsoleMenu.DoAnswer(const aInput: String);
-begin
- if Assigned(fOnAnswer) then
- fOnAnswer(self, aInput);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlConsoleMenu.ExecuteCommand(const aCmd: String);
-begin
- if (LowerCase(AnsiLeftStr(trim(aCmd), 4)) = 'exit') then
- ExitMenu
- else
- inherited ExecuteCommand(aCmd);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlConsoleMenu.StartMenu;
-begin
- fCommandPrompt.Start;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlConsoleMenu.ExitMenu;
-begin
- fCommandPrompt.Stop;
-end;
-
-procedure TutlConsoleMenu.Ask(const aQuestion: String; const aHidden: Boolean; const aOnAnswer: TutlInputEvent);
-begin
- if Assigned(aOnAnswer) then
- fOnAnswer := aOnAnswer;
- fIsAsking := true;
- fInputBackup := fCommandPrompt.Current;
- if aHidden then
- fCommandPrompt.HiddenChar := '*'
- else
- fCommandPrompt.HiddenChar := #0;
- fCommandPrompt.HistoryEnabled := false;
- fCommandPrompt.OnAutoComplete := nil;
- fCommandPrompt.Prefix := aQuestion;
- fCommandPrompt.Current := '';
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlConsoleMenu.Create(const aHelp: String; const aConsoleCS: syncobjs.TCriticalSection);
-begin
- inherited Create(aHelp);
- fExitMenu := TutlMenuItem.Create(self, 'exit', 'exit programm', nil);
- fCommandPrompt := TutlCommandPrompt.Create(aConsoleCS);
- fCommandPrompt.OnAutoComplete := @AutoComplete;
- fCommandPrompt.OnInput := @CommandInput;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlConsoleMenu.Destroy;
-begin
- FreeAndNil(fCommandPrompt);
- FreeAndNil(fExitMenu);
- inherited Destroy;
-end;
-
-end.
-
diff --git a/uutlConversion.pas b/uutlConversion.pas
deleted file mode 100644
index b30c8b5..0000000
--- a/uutlConversion.pas
+++ /dev/null
@@ -1,66 +0,0 @@
-unit uutlConversion;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit stellt Methoden für Konvertierung verschiedener Datentypen zur Verfügung }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils;
-
-function Supports(const aInstance: TObject; const aClass: TClass; out aObj): Boolean; overload;
-function HexToBinary(HexValue: PChar; BinValue: PByte; BinBufSize: Integer): Integer;
-
-implementation
-
-function Supports(const aInstance: TObject; const aClass: TClass; out aObj): Boolean;
-begin
- result := Assigned(aInstance) and aInstance.InheritsFrom(aClass);
- if result then
- TObject(aObj) := aInstance
- else
- TObject(aObj) := nil;
-end;
-
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//wandelt einen Hex-String in einen Blob um
-//@hexvalue: Hex-String
-//@binvalue: Zeiger auf einen Speicherbereich
-//@binbufsize: maximale größe die geschrieben werden darf
-//@result: gelesene bytes
-function HexToBinary(HexValue: PChar; BinValue: PByte; BinBufSize: Integer): Integer;
-var i,j,h,l : integer;
-
-begin
- i:=binbufsize;
- while (i>0) do
- begin
- if hexvalue^ IN ['A'..'F','a'..'f'] then
- h:=((ord(hexvalue^)+9) and 15)
- else if hexvalue^ IN ['0'..'9'] then
- h:=((ord(hexvalue^)) and 15)
- else
- break;
- inc(hexvalue);
- if hexvalue^ IN ['A'..'F','a'..'f'] then
- l:=(ord(hexvalue^)+9) and 15
- else if hexvalue^ IN ['0'..'9'] then
- l:=(ord(hexvalue^)) and 15
- else
- break;
- j := l + (h shl 4);
- inc(hexvalue);
- binvalue^:=j;
- inc(binvalue);
- dec(i);
- end;
- result:=binbufsize-i;
-end;
-
-
-end.
-
diff --git a/uutlGraph.pas b/uutlGraph.pas
deleted file mode 100644
index f1b7495..0000000
--- a/uutlGraph.pas
+++ /dev/null
@@ -1,413 +0,0 @@
-unit uutlGraph;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit implementiert einen generischen Graphen }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils, contnrs, uutlCommon;
-
-type
- TutlGraph = class;
- TutlGraphNodeData = class(TObject)
- public
- constructor Create; virtual;
- end;
- TutlGraphNodeDataClass = class of TutlGraphNodeData;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlGraphNode = class;
- TutlGraphNodeClass = class of TutlGraphNode;
- TutlGraphNode = class(TutlInterfaceNoRefCount)
- private type
- TNodeEnumerator = class(TObject)
- private
- fOwner: TutlGraphNode;
- fPos: Integer;
- function GetCurrent: TutlGraphNode;
- public
- property Current: TutlGraphNode read GetCurrent;
- function MoveNext: Boolean;
- constructor Create(const aOwner: TutlGraphNode);
- end;
- protected
- fParent: TutlGraphNode;
- fOwner: TutlGraph;
- fData: TutlGraphNodeData;
- fItems: TObjectList;
-
- class function GetDataClass: TutlGraphNodeDataClass; virtual;
-
- function GetCount: Integer; virtual;
- function GetItems(const aIndex: Integer): TutlGraphNode; virtual;
- function AttachNode(const aNode: TutlGraphNode): Boolean; virtual;
- function DetachNode(const aNode: TutlGraphNode): Boolean; virtual;
- public
- property Parent: TutlGraphNode read fParent;
- property Owner: TutlGraph read fOwner;
- property Data: TutlGraphNodeData read fData;
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: TutlGraphNode read GetItems; default;
-
- function AddItem: TutlGraphNode;
- function IndexOf(const aItem: TutlGraphNode): Integer;
- procedure DelItem(const aIndex: Integer);
- procedure Clear;
- function IsParent(const aNode: TutlGraphNode): Boolean;
- function Move(const aParent: TutlGraphNode): Boolean;
-
- function GetEnumerator: TNodeEnumerator;
-
- constructor Create(const aParent: TutlGraphNode; const aOwner: TutlGraph);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlGraph = class(TutlInterfaceNoRefCount)
- protected
- fRootNode: TutlGraphNode;
-
- class function GetItemClass: TutlGraphNodeClass; virtual;
- public
- property RootNode: TutlGraphNode read fRootNode;
-
- constructor Create;
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlGenericGraphNode = class(TutlGraphNode)
- private type
- TGenericNodeEnumerator = class(TObject)
- private
- fOwner: TutlGraphNode;
- fPos: Integer;
- function GetCurrent: GNode;
- public
- property Current: GNode read GetCurrent;
- function MoveNext: Boolean;
- constructor Create(const aOwner: TutlGraphNode);
- end;
- private
- function GetParent: GNode;
- function GetOwner: GOwner;
- function GetData: GData;
- function GetItemsGeneric(const aIndex: Integer): GNode;
- public
- property Parent: GNode read GetParent;
- property Owner: GOwner read GetOwner;
- property Data: GData read GetData;
- property Items[const aIndex: Integer]: GNode read GetItemsGeneric; default;
-
- function AddItem: GNode;
- function IndexOf(const aItem: GNode): Integer;
- function IsParent(const aNode: GNode): Boolean;
- function Move(const aParent: GNode): Boolean;
-
- function GetEnumerator: TGenericNodeEnumerator;
-
- constructor Create(const aParent: GNode; const aOwner: GOwner);
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlGenericGraph = class(TutlGraph)
- private
- function GetRootNode: T;
- public
- property RootNode: T read GetRootNode;
- end;
-
-implementation
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlGraphNodeData/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlGraphNodeData.Create;
-begin
- inherited Create;
- //nothing to do here
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlGraphNode.TNodeEnumerator//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.TNodeEnumerator.GetCurrent: TutlGraphNode;
-begin
- result := fOwner.Items[fPos];
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.TNodeEnumerator.MoveNext: Boolean;
-begin
- inc(fPos);
- result := (fPos < fOwner.Count);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlGraphNode.TNodeEnumerator.Create(const aOwner: TutlGraphNode);
-begin
- inherited Create;
- fPos := -1;
- fOwner := aOwner;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlGraphNode/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-class function TutlGraphNode.GetDataClass: TutlGraphNodeDataClass;
-begin
- result := TutlGraphNodeData;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.GetCount: Integer;
-begin
- result := fItems.Count;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.GetItems(const aIndex: Integer): TutlGraphNode;
-begin
- if (aIndex >= 0) and (aIndex < Count) then
- result := (fItems[aIndex] as TutlGraphNode)
- else
- raise Exception.Create(Format('index (%d) is out of Range (%d - %d)', [aIndex, 0, Count-1]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.AttachNode(const aNode: TutlGraphNode): Boolean;
-begin
- result := true;
- fItems.Add(aNode);
- aNode.fParent := self;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.DetachNode(const aNode: TutlGraphNode): Boolean;
-var
- i: Integer;
-begin
- result := false;
- i := fItems.IndexOf(aNode);
- if (i < 0) then
- exit;
- try
- fItems.OwnsObjects := false;
- fItems.Delete(i);
- aNode.fParent := nil;
- finally
- fItems.OwnsObjects := true;
- end;
- result := true;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.AddItem: TutlGraphNode;
-begin
- if Assigned(Owner) then
- result := Owner.GetItemClass().Create(self, Owner)
- else
- result := TutlGraphNode.Create(self, Owner);
- fItems.Add(result);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.IndexOf(const aItem: TutlGraphNode): Integer;
-begin
- result := fItems.IndexOf(aItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlGraphNode.DelItem(const aIndex: Integer);
-begin
- if (aIndex >= 0) and (aIndex < Count) then begin
- fItems.Delete(aIndex);
- end else
- raise Exception.Create(Format('index (%d) is out of Range (%d - %d)', [aIndex, 0, Count-1]));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlGraphNode.Clear;
-begin
- fItems.Clear;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.IsParent(const aNode: TutlGraphNode): Boolean;
-var
- n: TutlGraphNode;
-begin
- n := self;
- result := true;
- while Assigned(n.Parent) do begin
- if (aNode = n.Parent) then
- exit;
- n := n.Parent;
- end;
- result := false;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.Move(const aParent: TutlGraphNode): Boolean;
-var
- oldParent: TutlGraphNode;
-begin
- result := false;
- if (aParent.IsParent(self)) then
- exit;
- oldParent := Parent;
- if Assigned(oldParent) and not oldParent.DetachNode(self) then
- exit;
- if not aParent.AttachNode(self) then begin
- if Assigned(oldParent) then
- oldParent.AttachNode(self);
- exit;
- end;
- result := true;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGraphNode.GetEnumerator: TNodeEnumerator;
-begin
- result := TNodeEnumerator.Create(self);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlGraphNode.Create(const aParent: TutlGraphNode; const aOwner: TutlGraph);
-begin
- inherited Create;
- fParent := aParent;
- fOwner := aOwner;
- fData := GetDataClass().Create();
- fItems := TObjectList.create(true);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlGraphNode.Destroy;
-begin
- FreeAndNil(fData);
- FreeAndNil(fItems);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlGraph/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-class function TutlGraph.GetItemClass: TutlGraphNodeClass;
-begin
- result := TutlGraphNode;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlGraph.Create;
-begin
- inherited Create;
- fRootNode := GetItemClass().Create(nil, self);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlGraph.Destroy;
-begin
- FreeAndNil(fRootNode);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlGenericGraphNode.TGenericNodeEnumerator///////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.TGenericNodeEnumerator.GetCurrent: GNode;
-begin
- result := GNode(fOwner.Items[fPos]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.TGenericNodeEnumerator.MoveNext: Boolean;
-begin
- inc(fPos);
- result := (fPos < fOwner.Count);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlGenericGraphNode.TGenericNodeEnumerator.Create(const aOwner: TutlGraphNode);
-begin
- inherited Create;
- fPos := -1;
- fOwner := aOwner;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlGenericGraphNode//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.GetParent: GNode;
-begin
- result := GNode(fParent);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.GetOwner: GOwner;
-begin
- result := GOwner(fOwner);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.GetData: GData;
-begin
- result := GData(fData);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.GetItemsGeneric(const aIndex: Integer): GNode;
-begin
- result := GNode(inherited GetItems(aIndex));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.AddItem: GNode;
-begin
- result := GNode(inherited AddItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.IndexOf(const aItem: GNode): Integer;
-begin
- result := inherited IndexOf(aItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.IsParent(const aNode: GNode): Boolean;
-begin
- result := inherited IsParent(aNode);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.Move(const aParent: GNode): Boolean;
-begin
- result := inherited Move(aParent);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraphNode.GetEnumerator: TGenericNodeEnumerator;
-begin
- result := TGenericNodeEnumerator.Create(self);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlGenericGraphNode.Create(const aParent: GNode; const aOwner: GOwner);
-begin
- inherited Create(TutlGraphNode(aParent), TutlGraph(aOwner));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlGenericGraph//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlGenericGraph.GetRootNode: T;
-begin
- result := (fRootNode as T);
-end;
-
-end.
-
diff --git a/uutlLocalization.pas b/uutlLocalization.pas
deleted file mode 100644
index b18e8db..0000000
--- a/uutlLocalization.pas
+++ /dev/null
@@ -1,244 +0,0 @@
-unit uutlLocalization;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit stellt Mechanismen zur Übersetzung von Texten mit Hilfe von PO/MO-Files zur Verfügung }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils, gettext,
- uutlCommon, uutlGenerics, uutlStreamHelper;
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlLocalizationItem = class(TObject)
- Name, Comment: String;
- constructor Create;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlLocalizationDatabase = class(TObject)
- private type
- TStringObjMap = specialize TutlMap;
- private
- fStringList: TStringObjMap;
- fLangFile: TMOFile;
-
- function GetCount: Integer;
- function GetObject(Index: Integer): TutlLocalizationItem;
- public
- property Count : Integer read GetCount;
- property Objects[Index: Integer]: TutlLocalizationItem read GetObject;
- function AddName(const Name, Comment: string): TutlLocalizationItem;
- function RemoveName(const Name: string): boolean;
-
- procedure LoadFromStream(const aStream: TStream);
- procedure SaveToStream(const aStream: TStream);
-
- procedure LoadLanguage(const aStream: TStream);
- function Translate(const Name: string): string;
-
- constructor Create;
- destructor Destroy; override;
- end;
-
-function utlLocalizationDatabase: TutlLocalizationDatabase;
-function __(Name: string; Default: string = #0): string; overload;
-
-implementation
-
-uses
- Dialogs, uvfsManager;
-
-var
- Entity: TutlLocalizationDatabase;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlLocalizationDatabase: TutlLocalizationDatabase;
-var
- str: IStreamHandle;
-begin
- if not Assigned(Entity) then begin
- Entity := TutlLocalizationDatabase.Create;
- if vfsManager.ReadFile('lang/strings', str) then
- Entity.LoadFromStream(str.GetStream);
- end;
- result := Entity;
-end;
-
-
-function __(Name: string; Default: string): string;
-begin
- if Default=#0 then
- Default := Name;
- Result := utlLocalizationDatabase.Translate(Name);
- if (Result = '') then
- Result := Default;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlLocalizationItem////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//erstellt das Objekt
-constructor TutlLocalizationItem.Create;
-begin
- inherited Create;
- Name := '';
- Comment := '';
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlLocalizationDatabase///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//Get-Methode der Count-Eigenschaft
-function TutlLocalizationDatabase.GetCount: Integer;
-begin
- result := fStringList.Count;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//Get-Methode der Value-Eigenschaft
-function TutlLocalizationDatabase.GetObject(Index: Integer): TutlLocalizationItem;
-begin
- if (Index >= 0) and (Index < fStringList.Count) then
- result := fStringList.ValueAt[Index]
- else
- result := nil;
-end;
-
-function TutlLocalizationDatabase.AddName(const Name, Comment: string): TutlLocalizationItem;
-var
- e: TutlLocalizationItem;
- i: Integer;
-begin
- i := fStringList.IndexOf(Name);
- if i >= 0 then
- Result:= Objects[i]
- else begin
- e := TutlLocalizationItem.Create;
- e.Name := Name;
- e.Comment := Comment;
- fStringList.Add(e.Name, e);
- result := e;
- end;
-end;
-
-function TutlLocalizationDatabase.RemoveName(const Name: string): boolean;
-begin
- Result:= fStringList.IndexOf(Name) >= 0;
- if Result then
- fStringList.Delete(Name);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//läd die Datenbank aus einem Stream
-//@aStream: Stream aus der geladen werden soll;
-procedure TutlLocalizationDatabase.LoadFromStream(const aStream: TStream);
-const
- HEADER = 'StringDatabase';
-var
- rd: TutlStreamReader;
- csv: TutlCSVList;
- co: string;
-begin
- rd:= TutlStreamReader.Create(aStream);
- try
- if HEADER <> rd.ReadLine then
- raise Exception.Create('TStringDatabase.LoadFromStream - invalid Stream');
- fStringList.Clear;
- csv:= TutlCSVList.Create;
- try
- csv.Delimiter:= ';';
- csv.StrictDelimitedText:= rd.ReadLine;
- while csv.Count>=1 do begin
- co:= '';
- if csv.Count>1 then
- co:= csv[1];
- AddName(csv[0],co);
- // next line
- csv.StrictDelimitedText:= rd.ReadLine;
- end;
- finally
- FreeAndNil(csv);
- end;
- finally
- FreeAndNil(rd);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//speichert die Datenbank in einem Stream
-//@aStream: Stream in dem gespeichert werden soll;
-procedure TutlLocalizationDatabase.SaveToStream(const aStream: TStream);
-const
- HEADER = 'StringDatabase';
-var
- i: Integer;
- wr: TutlStreamWriter;
- csv: TutlCSVList;
- o: TutlLocalizationItem;
-begin
- wr:= TutlStreamWriter.Create(aStream);
- try
- wr.WriteLine(HEADER);
- csv:= TutlCSVList.Create;
- try
- csv.Delimiter:= ';';
- for i := 0 to fStringList.Count-1 do begin
- csv.Clear;
- o:= Objects[i];
- csv.Add(o.Name);
- csv.Add(o.Comment);
- wr.WriteLine(csv.StrictDelimitedText);
- end;
- finally
- FreeAndNil(csv);
- end;
- finally
- FreeAndNil(wr);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlLocalizationDatabase.LoadLanguage(const aStream: TStream);
-begin
- fLangFile.Free;
- fLangFile := nil;
- fLangFile := TMOFile.Create(aStream);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlLocalizationDatabase.Translate(const Name: string): string;
-begin
- if Assigned(fLangFile) then
- Result := UTF8Encode(fLangFile.Translate(Name))
- else
- Result := '';
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//erstellt das Objekt
-constructor TutlLocalizationDatabase.Create;
-begin
- inherited Create;
- fStringList := TStringObjMap.Create(True);
- fLangFile := nil;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//gibt das Objekt frei
-destructor TutlLocalizationDatabase.Destroy;
-begin
- fLangFile.Free;
- fStringList.Free;
- inherited Destroy;
-end;
-
-finalization
- FreeAndNil(Entity);
-
-end.
-
diff --git a/uutlMcfHelper.pas b/uutlMcfHelper.pas
deleted file mode 100644
index 5495dd2..0000000
--- a/uutlMcfHelper.pas
+++ /dev/null
@@ -1,100 +0,0 @@
-unit uutlMcfHelper;
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- ugluMatrix, ugluVector, uutlMCF, uglcLight;
-
-procedure utlWriteMatrix4f(const aSection: TutlMCFSection; const aMatrix: TgluMatrix4f);
-function utlReadMatrix4f(const aSection: TutlMCFSection): TgluMatrix4f;
-procedure utlWriteMaterial(const aSection: TutlMCFSection; const aMaterial: TglcMaterialRec);
-function utlReadMaterial(const aSection: TutlMCFSection): TglcMaterialRec;
-procedure utlWriteLight(const aSection: TutlMCFSection; const aLight: TglcLightRec);
-function utlReadLight(const aSection: TutlMCFSection): TglcLightRec;
-
-implementation
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure utlWriteMatrix4f(const aSection: TutlMCFSection; const aMatrix: TgluMatrix4f);
-begin
- with aSection do begin
- SetString('AxisX', gluVector4fToStr(aMatrix[maAxisX]));
- SetString('AxisY', gluVector4fToStr(aMatrix[maAxisY]));
- SetString('AxisZ', gluVector4fToStr(aMatrix[maAxisZ]));
- SetString('Pos', gluVector4fToStr(aMatrix[maPos]));
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlReadMatrix4f(const aSection: TutlMCFSection): TgluMatrix4f;
-begin
- with aSection do begin
- result[maAxisX] := gluStrToVector4f(GetString('AxisX', '1; 0; 0; 0;'));
- result[maAxisY] := gluStrToVector4f(GetString('AxisY', '0; 1; 0; 0;'));
- result[maAxisZ] := gluStrToVector4f(GetString('AxisZ', '0; 0; 1; 0;'));
- result[maPos] := gluStrToVector4f(GetString('Pos', '0; 0; 0; 1;'));
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure utlWriteMaterial(const aSection: TutlMCFSection; const aMaterial: TglcMaterialRec);
-begin
- with aSection do begin
- SetString('Ambient', gluVector4fToStr(aMaterial.Ambient));
- SetString('Diffuse', gluVector4fToStr(aMaterial.Diffuse));
- SetString('Specular', gluVector4fToStr(aMaterial.Specular));
- SetString('Emission', gluVector4fToStr(aMaterial.Emission));
- SetFloat ('Shininess', aMaterial.Shininess);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlReadMaterial(const aSection: TutlMCFSection): TglcMaterialRec;
-begin
- with aSection do begin
- result.Ambient := gluStrToVector4f(GetString('Ambient', gluVector4fToStr(MAT_DEFAULT_AMBIENT)));
- result.Diffuse := gluStrToVector4f(GetString('Diffuse', gluVector4fToStr(MAT_DEFAULT_DIFFUSE)));
- result.Specular := gluStrToVector4f(GetString('Specular', gluVector4fToStr(MAT_DEFAULT_SPECULAR)));
- result.Emission := gluStrToVector4f(GetString('Emission', gluVector4fToStr(MAT_DEFAULT_EMISSION)));
- result.Shininess := GetFloat('Shininess', MAT_DEFAULT_SHININESS);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure utlWriteLight(const aSection: TutlMCFSection; const aLight: TglcLightRec);
-begin
- with aSection do begin
- SetString('Ambient', gluVector4fToStr(aLight.Ambient));
- SetString('Diffuse', gluVector4fToStr(aLight.Diffuse));
- SetString('Specular', gluVector4fToStr(aLight.Specular));
- SetString('Position', gluVector4fToStr(aLight.Position));
- SetString('SpotDirection', gluVector3fToStr(aLight.SpotDirection));
- SetFloat ('SpotExponent', aLight.SpotExponent);
- SetFloat ('SpotCutoff', aLight.SpotCutoff);
- SetFloat ('ConstantAtt', aLight.ConstantAtt);
- SetFloat ('LinearAtt', aLight.LinearAtt);
- SetFloat ('QuadraticAtt', aLight.QuadraticAtt);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlReadLight(const aSection: TutlMCFSection): TglcLightRec;
-begin
- with aSection do begin
- result.Ambient := gluStrToVector4f(GetString('Ambient', gluVector4fToStr(LIGHT_DEFAULT_AMBIENT)));
- result.Diffuse := gluStrToVector4f(GetString('Diffuse', gluVector4fToStr(LIGHT_DEFAULT_DIFFUSE)));
- result.Specular := gluStrToVector4f(GetString('Specular', gluVector4fToStr(LIGHT_DEFAULT_SPECULAR)));
- result.Position := gluStrToVector4f(GetString('Position', gluVector4fToStr(LIGHT_DEFAULT_POSITION)));
- result.SpotDirection := gluStrToVector3f(GetString('SpotDirection', gluVector3fToStr(LIGHT_DEFAULT_SPOT_DIRECTION)));
- result.SpotExponent := GetFloat ('SpotExponent', LIGHT_DEFAULT_SPOT_EXPONENT);
- result.SpotCutoff := GetFloat ('SpotCutoff', LIGHT_DEFAULT_SPOT_CUTOFF);
- result.ConstantAtt := GetFloat ('ConstantAtt', LIGHT_DEFAULT_CONSTANT_ATT);
- result.LinearAtt := GetFloat ('LinearAtt', LIGHT_DEFAULT_LINEAR_ATT);
- result.QuadraticAtt := GetFloat ('QuadraticAtt', LIGHT_DEFAULT_QUADRATIC_ATT);
- end;
-end;
-
-end.
-
diff --git a/uutlMessageThread.pas b/uutlMessageThread.pas
deleted file mode 100644
index 21a04a3..0000000
--- a/uutlMessageThread.pas
+++ /dev/null
@@ -1,396 +0,0 @@
-unit uutlMessageThread;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit definiert einen Thread, der mit Hilfe von Messages Daten synchronisiert
- mit anderen Threads austauschen kann }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils, syncobjs, uutlMessages, uutlGenerics;
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlMessageThread = class(TThread, IUnknown)
- public type
- TMessageProgressCallback = procedure(const aMsg: TutlMessage) of Object;
- TMessageQueue = class(specialize TutlSyncQueue)
- private
- fEvent: TSimpleEvent;
- public
- procedure Push(const aItem: TutlMessage); override;
- function Pop(out aItem: TutlMessage): Boolean; override;
-
- function WaitForMessages(const aWaitTime: Cardinal = INFINITE): Boolean;
- function ProcessMessages(const aProgressCallback: TMessageProgressCallback): Boolean;
-
- constructor Create(const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
- protected
- fMessages: TMessageQueue;
- fRefCount : longint;
- { implement methods of IUnknown }
- function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
- function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual;
- function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual;
- protected
- function CreateMessageQueue: TMessageQueue; virtual;
- function WaitForMessages(const aWaitTime: Cardinal): Boolean;
- function ProcessMessages: Boolean; virtual;
- procedure ProcessMessage(const {%H-}aMessage: TutlMessage); virtual;
- public
- //Messages Objects passed to PostMessage will be freed automatically
- procedure PostMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload;
- procedure PostMessage(const aID: Cardinal; const aArgs: TObject); overload;
- procedure PostMessage(const aMsg: TutlMessage); virtual; overload;
-
- //Messages Objects passed to SendMessage must be freed by user when WaitResult is wrSignaled (otherwise the thread will handle it)
- function SendMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt;
- const aWaitTime: Cardinal = INFINITE): TWaitResult; overload;
- function SendMessage(const aID: Cardinal; const aArgs: TObject;
- const aWaitTime: Cardinal = INFINITE): TWaitResult; overload;
- function SendMessage(const aMsg: TutlSynchronousMessage;
- const aWaitTime: Cardinal = INFINITE): TWaitResult; virtual; overload;
-
- constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt=DefaultStackSize);
- destructor Destroy; override;
- end;
-
- //Messages Objects passed to PostMessage will be freed automatically
- function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt): Boolean; overload;
- function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject): Boolean; overload;
- function utlPostMessage(const aThreadID: TThreadID; const aMsg: TutlMessage): Boolean; overload;
-
- //Messages Objects passed to SendMessage must be freed by user when WaitResult is wrSignaled (otherwise the thread will handle it)
- function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt;
- const aWaitTime: Cardinal = INFINITE): TWaitResult; overload;
- function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject;
- const aWaitTime: Cardinal = INFINITE): TWaitResult; overload;
- function utlSendMessage(const aThreadID: TThreadID; const aMsg: TutlSynchronousMessage;
- const aWaitTime: Cardinal = INFINITE): TWaitResult; overload;
-
-implementation
-
-uses
- uutlLogger, uutlExceptions;
-
-type
- TutlMessageThreadMap = class(specialize TutlMap)
- private
- fCS: TCriticalSection;
- public
- procedure Lock;
- procedure Release;
- constructor Create(const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
-var
- Threads: TutlMessageThreadMap;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt): Boolean;
-begin
- result := utlPostMessage(aThreadID, TutlMessage.Create(aID, aWParam, aLParam));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject): Boolean;
-begin
- result := utlPostMessage(aThreadID, TutlMessage.Create(aID, aArgs));
-end;
-
-function utlPostMessage(const aThreadID: TThreadID; const aMsg: TutlMessage): Boolean;
-var
- t: TutlMessageThread;
-begin
- Threads.Lock;
- try
- t := Threads[aThreadID];
- finally
- Threads.Release;
- end;
- result := Assigned(t);
- if (result) then
- t.PostMessage(aMsg)
- else
- aMsg.Free;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt; const aWaitTime: Cardinal): TWaitResult;
-begin
- result := utlSendMessage(aThreadID, TutlSynchronousMessage.Create(aID, aWParam, aLParam), aWaitTime);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject; const aWaitTime: Cardinal): TWaitResult;
-begin
- result := utlSendMessage(aThreadID, TutlSynchronousMessage.Create(aID, aArgs), aWaitTime);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function utlSendMessage(const aThreadID: TThreadID; const aMsg: TutlSynchronousMessage; const aWaitTime: Cardinal): TWaitResult;
-var
- t: TutlMessageThread;
-begin
- Threads.Lock;
- try
- t := Threads[aThreadID];
- finally
- Threads.Release;
- end;
- if Assigned(t) then
- result := t.SendMessage(aMsg)
- else begin
- result := wrError;
- aMsg.Free;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMessageThread.TMessageQueue///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMessageThread.TMessageQueue.Push(const aItem: TutlMessage);
-begin
- inherited Push(aItem);
- fEvent.SetEvent;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.TMessageQueue.Pop(out aItem: TutlMessage): Boolean;
-begin
- result := inherited Pop(aItem);
- if (Count <= 0) then
- fEvent.ResetEvent;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.TMessageQueue.WaitForMessages(const aWaitTime: Cardinal): Boolean;
-var
- wr: TWaitResult;
-begin
- wr := fEvent.WaitFor(aWaitTime);
- result := (wr = wrSignaled);
- if not result and (wr <> wrTimeout) then
- raise EWait.Create('Error while waiting for messages', wr);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.TMessageQueue.ProcessMessages(const aProgressCallback: TMessageProgressCallback): Boolean;
-var
- m: TutlMessage;
- empty: Boolean;
-begin
- empty := false;
- result := false;
- if not Assigned(aProgressCallback) then
- exit;
- repeat
- try
- if Pop(m) then begin
- result := true;
- try
- aProgressCallback(m);
- finally
- if (m is TutlSynchronousMessage) then
- (m as TutlSynchronousMessage).Finish
- else
- FreeAndNil(m);
- end;
- end else
- empty := true;
- except
- on e: Exception do begin
- utlLogger.Error(self, 'error while progressing message: %s - %s', [e.ClassName, e.Message]);
- end;
- end;
- until empty;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMessageThread.TMessageQueue.Create(const aOwnsObjects: Boolean);
-begin
- inherited Create(aOwnsObjects);
- fEvent := TSimpleEvent.Create;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMessageThread.TMessageQueue.Destroy;
-begin
- inherited Destroy;
- FreeAndNil(fEvent); // do not free event before all messages has been deleted
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMessageThreadMap//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMessageThreadMap.Lock;
-begin
- fCS.Acquire;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMessageThreadMap.Release;
-begin
- fCS.Release;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMessageThreadMap.Create(const aOwnsObjects: Boolean);
-begin
- inherited;
- fCS:= TCriticalSection.Create;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMessageThreadMap.Destroy;
-begin
- fCS.Acquire;
- try
- inherited Destroy;
- finally
- fCS.Release;
- end;
- FreeAndNil(fCS);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMessageThread/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.QueryInterface(constref iid: tguid; out obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
-begin
- if getinterface(iid,obj) then
- result := S_OK
- else
- result := longint(E_NOINTERFACE);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread._AddRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
-begin
- result := InterLockedIncrement(fRefCount);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
-begin
- result := InterLockedDecrement(fRefCount);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.CreateMessageQueue: TMessageQueue;
-begin
- result := TMessageQueue.Create(true);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.WaitForMessages(const aWaitTime: Cardinal): Boolean;
-begin
- result := fMessages.WaitForMessages(aWaitTime);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.ProcessMessages: Boolean;
-begin
- result := fMessages.ProcessMessages(@ProcessMessage);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMessageThread.ProcessMessage(const aMessage: TutlMessage);
-begin
- case aMessage.ID of
- MSG_CALLBACK:
- (aMessage as TutlCallbackMsg).ExecuteCallback;
- MSG_SYNC_CALLBACK:
- (aMessage as TutlSyncCallbackMsg).ExecuteCallback;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMessageThread.PostMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt);
-begin
- fMessages.Push(TutlMessage.Create(aID, aWParam, aLParam));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMessageThread.PostMessage(const aID: Cardinal; const aArgs: TObject);
-begin
- fMessages.Push(TutlMessage.Create(aID, aArgs));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlMessageThread.PostMessage(const aMsg: TutlMessage);
-begin
- fMessages.Push(aMsg);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.SendMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt; const aWaitTime: Cardinal): TWaitResult;
-begin
- result := SendMessage(TutlSynchronousMessage.Create(aID, aWParam, aLParam), aWaitTime);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.SendMessage(const aID: Cardinal; const aArgs: TObject; const aWaitTime: Cardinal): TWaitResult;
-begin
- result := SendMessage(TutlSynchronousMessage.Create(aID, aArgs), aWaitTime);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlMessageThread.SendMessage(const aMsg: TutlSynchronousMessage; const aWaitTime: Cardinal): TWaitResult;
-begin
- fMessages.Push(aMsg);
- result := aMsg.WaitFor(aWaitTime);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMessageThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt);
-begin
- inherited Create(CreateSuspended, StackSize);
- fMessages := CreateMessageQueue;
- Threads.Lock;
- try
- Threads.Add(ThreadID, self);
- finally
- Threads.Release;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMessageThread.Destroy;
-begin
- Threads.Lock;
- try
- Threads.Delete(ThreadID);
- finally
- Threads.Release;
- end;
- FreeAndNil(fMessages);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-initialization
- Threads := TutlMessageThreadMap.Create(false);
-
-finalization
- Threads.Lock;
- try
- while (Threads.Count > 0) do
- Threads.ValueAt[Threads.Count-1].Free;
- finally
- Threads.Release;
- end;
- FreeAndNil(Threads);
-
-end.
-
diff --git a/uutlMessages.pas b/uutlMessages.pas
deleted file mode 100644
index 3f5ab93..0000000
--- a/uutlMessages.pas
+++ /dev/null
@@ -1,171 +0,0 @@
-unit uutlMessages;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit enthält verschiedene Klassen, die Messages definieren,
- die zwischen utlMessageThreads ausgetauscht werden können }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils, syncobjs;
-
-const
- //General
- MSG_CALLBACK = $00010001; //TutlCallbackMsg
-
- MSG_SYNC_CALLBACK = $00010002; //TutlSyncCallbackMsg
-
- //User
- MSG_USER = $F0000000;
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlMessage = class(TObject)
- protected
- fID: Cardinal;
- fWParam: PtrInt;
- fLParam: PtrInt;
- fArgs: TObject;
- fOwnsObjects: Boolean;
- public
- property ID: Cardinal read fID;
- property WParam: PtrInt read fWParam;
- property LParam: PtrInt read fLParam;
- property Args: TObject read fArgs;
- property OwnsObjects: Boolean read fOwnsObjects write fOwnsObjects;
-
- constructor Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload;
- constructor Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean = true); overload;
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlSynchronousMessage = class(TutlMessage)
- private
- fEvent: TEvent;
- public
- procedure Finish;
- function WaitFor(const aTimeout: Cardinal): TWaitResult;
-
- constructor Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload;
- constructor Create(const {%H-}aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean = true); overload;
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlCallbackMsg = class(TutlMessage)
- public
- procedure ExecuteCallback; virtual;
- constructor Create; overload;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlSyncCallbackMsg = class(TutlSynchronousMessage)
- public
- procedure ExecuteCallback; virtual;
- constructor Create; overload;
- end;
-
-implementation
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlMessage///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMessage.Create(const aID: Cardinal; const aWParam, aLParam: PtrInt);
-begin
- inherited Create;
- fID := aID;
- fWParam := aWParam;
- fLParam := aLParam;
- fArgs := nil;
- fOwnsObjects := true;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlMessage.Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean);
-begin
- inherited Create;
- fID := aID;
- fWParam := 0;
- fLParam := 0;
- fArgs := aArgs;
- fOwnsObjects := aOwnsObjects;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlMessage.Destroy;
-begin
- if Assigned(fArgs) and fOwnsObjects then
- FreeAndNil(fArgs);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlSynchronousMessage//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlSynchronousMessage.Finish;
-begin
- fEvent.SetEvent;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlSynchronousMessage.WaitFor(const aTimeout: Cardinal): TWaitResult;
-begin
- result := fEvent.WaitFor(aTimeout);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlSynchronousMessage.Create(const aID: Cardinal; const aWParam, aLParam: PtrInt);
-begin
- inherited Create(aID, aWParam, aLParam);
- fEvent := TEvent.Create(nil, true, false, '');
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlSynchronousMessage.Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean);
-begin
- inherited Create(ID, aArgs, aOwnsObjects);
- fEvent := TEvent.Create(nil, true, false, '');
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlSynchronousMessage.Destroy;
-begin
- fEvent.SetEvent;
- FreeAndNil(fEvent);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlCallbackMsg///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlCallbackMsg.ExecuteCallback;
-begin
- //DUMMY
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlCallbackMsg.Create;
-begin
- inherited Create(MSG_CALLBACK, 0, 0);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlSyncCallbackMsg///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlSyncCallbackMsg.ExecuteCallback;
-begin
- //DUMMY
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlSyncCallbackMsg.Create;
-begin
- inherited Create(MSG_SYNC_CALLBACK, 0, 0);
-end;
-
-end.
-
diff --git a/uutlObservableGenerics.pas b/uutlObservableGenerics.pas
deleted file mode 100644
index f89ea03..0000000
--- a/uutlObservableGenerics.pas
+++ /dev/null
@@ -1,369 +0,0 @@
-unit uutlObservableGenerics;
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils,
- uutlGenerics, uutlInterfaces;
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlEventList = class(specialize TutlHashSetBase)
- private type
- TComparer = class(TInterfacedObject, IComparer)
- public
- function Compare(const i1, i2: T): Integer;
- end;
-
- public
- function RegisterEvent(const aEvent: T): Boolean;
- function UnregisterEvent(const aEvent: T): Boolean;
-
- constructor Create;
- end;
- TutlNotifyEventList = specialize TutlEventList;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlObservableCustomList = class(specialize TutlCustomList)
- public type
- TEventList = specialize TutlEventList;
- private
- fOnAddItem: TEventList;
- fOnRemoveItem: TEventList;
- protected
- procedure InsertIntern(const aIndex: Integer; const aItem: T); override;
- procedure DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean = true); override;
-
- procedure DoAddItem(const aIndex: Integer; const aItem: T); virtual;
- procedure DoRemoveItem(const aIndex: Integer; const aItem: T); virtual;
- public
- property OnAddItem: TEventList read fOnAddItem;
- property OnRemoveItem: TEventList read fOnRemoveItem;
-
- constructor Create(aEqualityComparer: IEqualityComparer; const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlObservableList = class(specialize TutlObservableCustomList)
- public type
- TEqualityComparer = specialize TutlEqualityComparer;
- public
- constructor Create(const aOwnsObjects: Boolean = true);
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlObservableCustomHashSet = class(specialize TutlCustomHashSet)
- public type
- TEventList = specialize TutlEventList;
- private
- fOnAddItem: TEventList;
- fOnRemoveItem: TEventList;
- protected
- procedure InsertIntern(const aIndex: Integer; const aItem: T); override;
- procedure DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean = true); override;
-
- procedure DoAddItem(const aItem: T); virtual;
- procedure DoRemoveItem(const aItem: T); virtual;
- public
- property OnAddItem: TEventList read fOnAddItem;
- property OnRemoveItem: TEventList read fOnRemoveItem;
-
- constructor Create(aComparer: IComparer; const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlObservableHashSet = class(specialize TutlObservableCustomHashSet)
- public type
- TComparer = specialize TutlComparer;
- public
- constructor Create(const aOwnsObjects: Boolean = true);
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlObservableCustomMap = class(specialize TutlMapBase)
- public type
- TEventList = specialize TutlEventList;
- TObservableHashSet = class(THashSet)
- private
- fOwner: TutlObservableCustomMap;
- protected
- procedure InsertIntern(const aIndex: Integer; const aItem: TKeyValuePair); override;
- procedure DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean = true); override;
- public
- constructor Create(const aOwner: TutlObservableCustomMap; const aComparer: IComparer; const aOwnsObjects: Boolean = true);
- end;
-
- private
- fHashSetImpl: TObservableHashSet;
- fOnAddItem: TEventList;
- fOnRemoveItem: TEventList;
- protected
- procedure DoAddItem(const aKey: TKey; const aValue: TValue); virtual;
- procedure DoRemoveItem(const aKey: TKey; const aValue: TValue); virtual;
- public
- property OnAddItem: TEventList read fOnAddItem;
- property OnRemoveItem: TEventList read fOnRemoveItem;
-
- constructor Create(const aComparer: IComparer; const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlObservableMap = class(specialize TutlObservableCustomMap)
- public type
- TComparer = specialize TutlComparer;
- public
- constructor Create(const aOwnsObjects: Boolean = true);
- end;
-
-implementation
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlEventList/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlEventList.TComparer.Compare(const i1, i2: T): Integer;
-var
- m1, m2: TMethod;
-begin
- m1 := TMethod(i1);
- m2 := TMethod(i2);
- if (m1.Data < m2.Data) then
- result := -1
- else if (m1.Data > m2.Data) then
- result := 1
- else if (m1.Code < m2.Code) then
- result := -1
- else if (m1.Code > m2.Code) then
- result := 1
- else
- result := 0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlEventList.RegisterEvent(const aEvent: T): Boolean;
-var
- i: Integer;
-begin
- result := (SearchItem(0, List.Count-1, aEvent, i) < 0);
- if result then
- InsertIntern(i, aEvent);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlEventList.UnregisterEvent(const aEvent: T): Boolean;
-var
- i, tmp: Integer;
-begin
- i := SearchItem(0, List.Count-1, aEvent, tmp);
- result := (i >= 0);
- if result then
- DeleteIntern(i);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlEventList.Create;
-begin
- inherited Create(TComparer.Create, true);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlObservableCustomList//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomList.InsertIntern(const aIndex: Integer; const aItem: T);
-begin
- inherited InsertIntern(aIndex, aItem);
- DoAddItem(aIndex, aItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomList.DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean);
-begin
- DoRemoveItem(aIndex, aIndex);
- inherited DeleteIntern(aIndex, aFreeItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomList.DoAddItem(const aIndex: Integer; const aItem: T);
-var
- e: TItemEvent;
-begin
- if Assigned(fOnAddItem) then
- for e in fOnAddItem do
- e(self, aIndex, aItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomList.DoRemoveItem(const aIndex: Integer; const aItem: T);
-var
- e: TItemEvent;
-begin
- if Assigned(fOnRemoveItem) then
- for e in fOnRemoveItem do
- e(self, aIndex, GetItem(aIndex));
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlObservableCustomList.Create(aEqualityComparer: IEqualityComparer; const aOwnsObjects: Boolean);
-begin
- inherited Create(aEqualityComparer, aOwnsObjects);
- fOnAddItem := TEventList.Create;
- fOnRemoveItem := TEventList.Create;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlObservableCustomList.Destroy;
-begin
- FreeAndNil(fOnRemoveItem);
- FreeAndNil(fOnAddItem);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlObservableList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlObservableList.Create(const aOwnsObjects: Boolean);
-begin
- inherited Create(TEqualityComparer.Create, aOwnsObjects);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlObservableCustomHashSet///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomHashSet.InsertIntern(const aIndex: Integer; const aItem: T);
-begin
- inherited InsertIntern(aIndex, aItem);
- DoAddItem(aItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomHashSet.DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean);
-begin
- DoRemoveItem(GetItem(aIndex));
- inherited DeleteIntern(aIndex, aFreeItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomHashSet.DoAddItem(const aItem: T);
-var
- e: THashItemEvent;
-begin
- if Assigned(fOnAddItem) then
- for e in fOnAddItem do
- e(self, aItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomHashSet.DoRemoveItem(const aItem: T);
-var
- e: THashItemEvent;
-begin
- if Assigned(fOnRemoveItem) then
- for e in fOnRemoveItem do
- e(self, aItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlObservableCustomHashSet.Create(aComparer: IComparer; const aOwnsObjects: Boolean);
-begin
- inherited Create(aComparer, aOwnsObjects);
- fOnAddItem := TEventList.Create;
- fOnRemoveItem := TEventList.Create;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlObservableCustomHashSet.Destroy;
-begin
- inherited Destroy; // calls clear -> Free EventLists after
- FreeAndNil(fOnAddItem);
- FreeAndNil(fOnRemoveItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlObservableHashSet/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlObservableHashSet.Create(const aOwnsObjects: Boolean);
-begin
- inherited Create(TComparer.Create, aOwnsObjects);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlObservableCustomMap///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomMap.TObservableHashSet.InsertIntern(const aIndex: Integer; const aItem: TKeyValuePair);
-begin
- inherited InsertIntern(aIndex, aItem);
- fOwner.DoAddItem(aItem.Key, aItem.Value);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomMap.TObservableHashSet.DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean);
-var
- kvp: TKeyValuePair;
-begin
- kvp := GetItem(aIndex);
- fOwner.DoRemoveItem(kvp.Key, kvp.Value);
- inherited DeleteIntern(aIndex, aFreeItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlObservableCustomMap.TObservableHashSet.Create(
- const aOwner: TutlObservableCustomMap; const aComparer: IComparer; const aOwnsObjects: Boolean);
-begin
- inherited Create(aComparer, aOwnsObjects);
- fOwner := aOwner;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomMap.DoAddItem(const aKey: TKey; const aValue: TValue);
-var
- e: TKeyValuePairEvent;
-begin
- if not Assigned(fOnAddItem) then
- exit;
- for e in fOnAddItem do
- e(self, aKey, aValue);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlObservableCustomMap.DoRemoveItem(const aKey: TKey; const aValue: TValue);
-var
- e: TKeyValuePairEvent;
-begin
- if not Assigned(fOnRemoveItem) then
- exit;
- for e in fOnRemoveItem do
- e(self, aKey, aValue);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlObservableCustomMap.Create(const aComparer: IComparer; const aOwnsObjects: Boolean);
-begin
- fOnAddItem := TEventList.Create;
- fOnRemoveItem := TEventList.Create;
- fHashSetImpl := TObservableHashSet.Create(self, TKeyValuePairComparer.Create(aComparer), aOwnsObjects);
- inherited Create(fHashSetImpl);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlObservableCustomMap.Destroy;
-begin
- inherited Destroy;
- FreeAndNil(fHashSetImpl);
- FreeAndNil(fOnAddItem);
- FreeAndNil(fOnRemoveItem);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlObservableMap/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlObservableMap.Create(const aOwnsObjects: Boolean);
-begin
- inherited Create(TComparer.Create, aOwnsObjects);
-end;
-
-end.
-
diff --git a/uutlPlatform.pas b/uutlPlatform.pas
deleted file mode 100644
index 2426798..0000000
--- a/uutlPlatform.pas
+++ /dev/null
@@ -1,93 +0,0 @@
-unit uutlPlatform;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit implementiert Methoden mit denen ein String generiert werden kann,
- welcher das System auf dem die Anwendung läuft identifiziert }
-
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils;
-
-function GetPlatformIdentitfier: string;
-
-implementation
-
-uses
- {$ifdef WINDOWS}
- Windows
- {$endif}
- ;
-
-{$ifdef WINDOWS}
-function GetWindowsVersionStr(const aDefault: String): string;
-var
- osv: TOSVERSIONINFO;
- ver: cardinal;
-begin
- Result:= aDefault;
- osv.dwOSVersionInfoSize:= SizeOf(osv);
- if GetVersionEx(osv) then begin
- ver:= MAKELONG(osv.dwMinorVersion, osv.dwMajorVersion);
- // positive overflow: if system is newer, always detect as newest we knew instead of failing
- if ver >= $00060003 then
- Result:= '8_1'
- else
- if ver >= $00060002 then
- Result:= '8'
- else
- if ver >= $00060001 then
- Result:= '7'
- else
- if ver >= $00060000 then
- Result:= 'Vista'
- else
- if ver >= $00050002 then
- Result:= '2003'
- else
- if ver >= $00050001 then
- Result:= 'XP'
- else
- if ver >= $00050000 then
- Result:= '2000'
- else
- if ver >= $00040000 then
- Result:= 'NT4';
- // ignore NT3, hmkay?;
- end;
-end;
-{$endif}
-
-function GetPlatformIdentitfier: string;
-var
- os,ver,arch: string;
-begin
- Result:= '';
- os:= '';
- ver:= 'generic';
- arch:= '';
- {$if defined(WINDOWS)}
- os:= 'mswin';
- ver:= GetWindowsVersionStr(ver);
- {$elseif defined(LINUX)}
- os:= 'linux';
- {$Warning System Version String missing!}
- {$endif}
-
- {$if defined(CPUX86)}
- arch:= 'x86';
- {$elseif defined(cpux86_64)}
- arch:= 'x64';
- {$else}
- {$Error Unknown Architecture!}
- {$endif}
- Result:= format('%s-%s-%s', [os, ver, arch]);
-end;
-
-
-end.
-
diff --git a/uutlSerialization.pas b/uutlSerialization.pas
deleted file mode 100644
index 81a740f..0000000
--- a/uutlSerialization.pas
+++ /dev/null
@@ -1,126 +0,0 @@
-unit uutlSerialization;
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils;
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- IutlFileReader = interface
- ['{3A9C3AE3-CAEE-44C9-85BE-0BCAA5C1BE7A}']
- function LoadStream(const aFilename: String; const aStream: TStream): Boolean;
- end;
-
- IutlFileWriter = interface
- ['{3DF84644-9FC4-4A8A-88C2-73F13E72B1ED}']
- procedure SaveStream(const aFilename: String; const aStream: TStream);
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlSimpleFileReader = class(TInterfacedObject, IutlFileReader)
- public
- function LoadStream(const aFilename: String; const aStream: TStream): Boolean;
- end;
-
- TutlSimpleFileWriter = class(TInterfacedObject, IutlFileWriter)
- public
- procedure SaveStream(const aFilename: String; const aStream: TStream);
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlFileReaderProxy = class(TInterfacedObject, IutlFileReader)
- private
- fReader: IutlFileReader;
- fPrefix: String;
- public
- function LoadStream(const aFilename: String; const aStream: TStream): Boolean;
- constructor Create(const aReader: IutlFileReader; const aPrefix: String);
- end;
-
- TutlFileWriterProxy = class(TInterfacedObject, IutlFileWriter)
- private
- fWriter: IutlFileWriter;
- fPrefix: String;
- public
- procedure SaveStream(const aFilename: String; const aStream: TStream);
- constructor Create(const aWriter: IutlFileWriter; const aPrefix: String);
- end;
-
-implementation
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlSimpleFileReader//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlSimpleFileReader.LoadStream(const aFilename: String; const aStream: TStream): Boolean;
-var
- fs: TFileStream;
-begin
- result := FileExists(aFilename);
- if result then begin
- fs := TFileStream.Create(aFilename, fmOpenRead);
- try
- aStream.CopyFrom(fs, fs.Size - fs.Position);
- finally
- FreeAndNil(fs);
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlSimpleFileWriter//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlSimpleFileWriter.SaveStream(const aFilename: String; const aStream: TStream);
-var
- fs: TFileStream;
-begin
- fs := TFileStream.Create(aFilename, fmCreate);
- try
- fs.CopyFrom(aStream, aStream.Size - aStream.Position);
- finally
- FreeAndNil(fs);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlFileReaderProxy///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlFileReaderProxy.LoadStream(const aFilename: String; const aStream: TStream): Boolean;
-var
- dir, name: String;
-begin
- dir := ExtractFilePath(aFilename);
- name := ExtractFileName(aFilename);
- result := fReader.LoadStream(dir + fPrefix + name, aStream);
-end;
-
-constructor TutlFileReaderProxy.Create(const aReader: IutlFileReader; const aPrefix: String);
-begin
- inherited Create;
- fReader := aReader;
- fPrefix := aPrefix;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlFileWriterProxy///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlFileWriterProxy.SaveStream(const aFilename: String; const aStream: TStream);
-var
- dir, name: String;
-begin
- dir := ExtractFilePath(aFilename);
- name := ExtractFileName(aFilename);
- fWriter.SaveStream(dir + fPrefix + name, aStream);
-end;
-
-constructor TutlFileWriterProxy.Create(const aWriter: IutlFileWriter; const aPrefix: String);
-begin
- inherited Create;
- fWriter := aWriter;
- fPrefix := aPrefix;
-end;
-
-end.
-
diff --git a/uutlSetHelper.inc b/uutlSetHelper.inc
deleted file mode 100644
index 136b0f5..0000000
--- a/uutlSetHelper.inc
+++ /dev/null
@@ -1,88 +0,0 @@
-{$IF defined(__SET_INTERFACE)}
-
-type __SET_HELPER = class
-public
- class function {%H}ToString(const Value: __SET_TYPE): String; reintroduce;
- class function TryToSet(const Str: String; out Value: __SET_TYPE): boolean; overload;
- class function ToSet(const Str: String; const aDefault: __SET_TYPE): __SET_TYPE; overload;
- class function ToSet(const Str: String): __SET_TYPE; overload;
- class function Compare(const aSet1, aSet2: __SET_TYPE): Integer;
-end;
-{$ELSEIF defined (__SET_IMPLEMENTATION)}
-
-class function __SET_HELPER.ToString(const Value: __SET_TYPE): String;
-var
- m: __ENUM_TYPE;
-begin
- Result:= '';
- for m in __ENUM_HELPER.Values do
- if m in Value then begin
- if Result > '' then
- Result:= Result + ', ';
- Result:= Result + __ENUM_HELPER.ToString(m);
- end;
-end;
-
-class function __SET_HELPER.ToSet(const Str: String): __SET_TYPE;
-begin
- if not TryToSet(Str, Result) then
- raise SysUtils.EConvertError.CreateFmt('"%s" is an invalid value',[Str]);
-end;
-
-class function __SET_HELPER.ToSet(const Str: String; const aDefault: __SET_TYPE): __SET_TYPE;
-begin
- if not TryToSet(Str, Result) then
- Result:= aDefault;
-end;
-
-class function __SET_HELPER.TryToSet(const Str: String; out Value: __SET_TYPE): boolean;
-var
- i, j: Integer;
- s: String;
- m: __ENUM_TYPE;
-begin
- Result:= true;
- Value := [];
- i := 1;
- j := 1;
- while (i <= Length(Str)) do begin
- if (Str[i] = ',') then begin
- s := Trim(copy(Str, j, i-j));
- Result:= Result and __ENUM_HELPER.TryToEnum(s, m);
- if not Result then
- Exit;
- Include(Value, m);
- j := i+1;
- end;
- inc(i);
- end;
- s := Trim(copy(Str, j, i-j));
- if (s <> '') then begin
- Result:= Result and __ENUM_HELPER.TryToEnum(s, m);
- if not Result then
- Exit;
- Include(Value, m);
- end;
-end;
-
-class function __SET_HELPER.Compare(const aSet1, aSet2: __SET_TYPE): Integer;
-var
- i: __ENUM_TYPE;
-begin
- result := 0;
- for i := High(i) downto Low(i) do begin
- if (i in aSet1) and not (i in aSet2) then begin
- result := 1;
- break;
- end else if not (i in aSet1) and (i in aSet2) then begin
- result := -1;
- break;
- end;
- end;
-end;
-
-{$ENDIF}
-{$undef __SET_HELPER}
-{$undef __SET_TYPE}
-{$undef __ENUM_TYPE}
-{$undef __ENUM_HELPER}
diff --git a/uutlSettings.pas b/uutlSettings.pas
deleted file mode 100644
index dd8bfa7..0000000
--- a/uutlSettings.pas
+++ /dev/null
@@ -1,406 +0,0 @@
-unit uutlSettings;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit stellt ein Framework zur Verfügung mit dessen Hilfe Einstellungs-Blöcke
- in ein MCF File geladen und geschreieben werden können }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils,
- uutlMCF, uutlGenerics, uutlMessageThread;
-
-type
- TutlSettingsBlock = class
- constructor Create; virtual;
-
- procedure LoadDefaults; virtual; abstract;
- procedure LoadFromConfig(const aMcf: TutlMCFSection); virtual; abstract;
- procedure SaveToConfig(const aMcf: TutlMCFSection); virtual; abstract;
- end;
- TutlSettingsBlockClass = class of TutlSettingsBlock;
-
- TutlSettingsUpdateOp = (opInstanceChanged, opDataChanged);
- TutlSettingsUpdateEvent = procedure (const aUpdateOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock) of object;
- TutlSettingsUpdateEventCntr = packed record
- Callback: TutlSettingsUpdateEvent;
- ThreadID: TThreadID;
- end;
- TutlSettingsUpdateEventCntrEqComp = class(TInterfacedObject, specialize IutlEqualityComparer)
- public
- function EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean;
- end;
-
- TutlSettings = class
- private type
- TutlSettingsUpdateEventList = specialize TutlCustomList;
- TBlockData = class
- Instance, OldInstance: TutlSettingsBlock;
- Events: TutlSettingsUpdateEventList;
- procedure CallEvents(const aOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock);
- constructor Create;
- destructor Destroy; override;
- end;
-
- TBlockList = specialize TutlMap;
- private
- fBlocks: TBlockList;
- fRaiseChangedEventOnLoad: Boolean;
- procedure CopyInstance(O, N: TutlSettingsBlock);
- public
- property RaiseChangedEventOnLoad: Boolean read fRaiseChangedEventOnLoad write fRaiseChangedEventOnLoad;
-
- function RegisterBlock(const aName: String; const aClass: TutlSettingsBlockClass; const aOnUpdateEvent: TutlSettingsUpdateEvent): TutlSettingsBlock;
- procedure UnregisterBlockCallback(const aName: String; const aOnUpdateEvent: TutlSettingsUpdateEvent);
- procedure UnregisterBlockCallbacks(const aObj: TObject);
-
- function Block(const aName: String; out aBlock): boolean;
- procedure Changed(const aBlock: TutlSettingsBlock);
-
- procedure LoadFromConfig(const aMcf: TutlMCFSection);
- procedure SaveToConfig(const aMcf: TutlMCFSection);
-
- procedure LoadFromFile(const aFile: string);
- procedure SaveToFile(const aFile: string);
-
- constructor Create;
- destructor Destroy; override;
- end;
-
-operator = (const i1, i2: TutlSettingsUpdateEventCntr): Boolean; inline;
-
-var
- utlSettings: TutlSettings;
-
-implementation
-
-uses
- uutlExceptions, Forms{$IFDEF USE_VFS}, uvfsManager{$ENDIF}, uutlMessages, syncobjs;
-
-const
- SETTINGS_MSG_WAIT_TIME = 1000; //ms
-
-type
- TSettingsBlockChangedMsg = class(TutlSyncCallbackMsg)
- private
- fCallback: TutlSettingsUpdateEvent;
- fOperation: TutlSettingsUpdateOp;
- fOld: TutlSettingsBlock;
- fNew: TutlSettingsBlock;
- public
- procedure ExecuteCallback; override;
- constructor Create(const aCallback: TutlSettingsUpdateEvent; const aOp: TutlSettingsUpdateOp;
- const aOld, aNew: TutlSettingsBlock);
- end;
-
-operator = (const i1, i2: TutlSettingsUpdateEventCntr): Boolean;
-begin
- result :=
- (i1.Callback = i2.Callback) and
- (i2.ThreadID = i2.ThreadID);
-end;
-
-function TutlSettingsUpdateEventCntrEqComp.EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean;
-begin
- result := (i1 = i2);
-end;
-
-{ TSettingsBlockChangedMsg }
-
-procedure TSettingsBlockChangedMsg.ExecuteCallback;
-begin
- fCallback(fOperation, fOld, fNew);
-end;
-
-constructor TSettingsBlockChangedMsg.Create(const aCallback: TutlSettingsUpdateEvent;
- const aOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock);
-begin
- inherited Create;
- fCallback := aCallback;
- fOperation := aOp;
- fOld := aOld;
- fNew := aNew;
-end;
-
-{ TutlSettings.TBlockData }
-
-procedure TutlSettings.TBlockData.CallEvents(const aOp: TutlSettingsUpdateOp;
- const aOld, aNew: TutlSettingsBlock);
-var
- current: TThreadID;
- cntr: TutlSettingsUpdateEventCntr;
- msg: TSettingsBlockChangedMsg;
-begin
- current := GetCurrentThreadId;
- for cntr in Events do begin
- if (cntr.ThreadID <> current) then begin
- msg := TSettingsBlockChangedMsg.Create(cntr.Callback, aOp, aOld, aNew);
- if utlSendMessage(cntr.ThreadID, msg, SETTINGS_MSG_WAIT_TIME) = wrSignaled then
- msg.Free;
- end else
- cntr.Callback(aOp, aOld, aNew);
- end;
-end;
-
-constructor TutlSettings.TBlockData.Create;
-begin
- inherited;
- Events:= TutlSettingsUpdateEventList.Create(TutlSettingsUpdateEventCntrEqComp.Create);
-end;
-
-destructor TutlSettings.TBlockData.Destroy;
-begin
- FreeAndNil(Events);
- FreeAndNil(Instance);
- FreeAndNil(OldInstance);
- inherited Destroy;
-end;
-
-{ TutlSettingsBlock }
-
-constructor TutlSettingsBlock.Create;
-begin
- inherited;
- LoadDefaults;
-end;
-
-{ TutlSettings }
-
-function TutlSettings.RegisterBlock(const aName: String; const aClass: TutlSettingsBlockClass;
- const aOnUpdateEvent: TutlSettingsUpdateEvent): TutlSettingsBlock;
-var
- i: integer;
- bd: TBlockData;
- cntr: TutlSettingsUpdateEventCntr;
-begin
- Result:= nil;
-
- if aName = '' then
- raise EInvalidOperation.Create('Empty Settings section name.');
-
- i:= fBlocks.IndexOf(aName);
- if i>=0 then begin
- bd:= fBlocks.ValueAt[i];
- // gleicher name, instance ist gleiche oder spezifischere klasse
- if bd.Instance is aClass then begin
- if Assigned(aOnUpdateEvent) then begin
- cntr.Callback := aOnUpdateEvent;
- cntr.ThreadID := GetCurrentThreadId;
- bd.Events.Add(cntr);
- end;
- Exit(bd.Instance)
- end else
- // gleicher name, neue klasse ist spezifischer
- if aClass.InheritsFrom(bd.Instance.ClassType) then begin
- Result:= aClass.Create;
- CopyInstance(bd.Instance, Result);
- bd.CallEvents(opInstanceChanged, bd.Instance, Result);
- bd.Instance.Free;
- bd.OldInstance.Free;
- bd.Instance:= aClass.Create;
- bd.OldInstance:= aClass.Create;
- if Assigned(aOnUpdateEvent) then begin
- cntr.Callback := aOnUpdateEvent;
- cntr.ThreadID := GetCurrentThreadId;
- bd.Events.Add(cntr);
- end;
- Exit;
- end
- // gleicher name, aber komplett andere klasse
- else
- raise EInvalidOperation.CreateFmt('Duplicate Settings entry: %s', [aName]);
- end;
-
- for bd in fBlocks do
- // verwandte klasse aber anderer name (wäre es der gleiche wäre das schon oben abgefangen)
- if (bd.Instance is aClass) or (aClass.InheritsFrom(bd.Instance.ClassType)) then
- raise EInvalidOperation.CreateFmt('Reused Settings class: %s', [aClass.ClassName]);
-
- // neuer name, neue klasse
- bd:= TBlockData.Create;
- bd.Instance:= aClass.Create;
- bd.OldInstance:= aClass.Create;
- if Assigned(aOnUpdateEvent) then begin
- cntr.Callback := aOnUpdateEvent;
- cntr.ThreadID := GetCurrentThreadId;
- bd.Events.Add(cntr);
- end;
-
- fBlocks.Add(aName, bd);
- Result:= bd.Instance;
-end;
-
-procedure TutlSettings.UnregisterBlockCallback(const aName: String; const aOnUpdateEvent: TutlSettingsUpdateEvent);
-var
- i: integer;
- bd: TBlockData;
-begin
- i:= fBlocks.IndexOf(aName);
- if i >= 0 then begin
- bd := fBlocks.ValueAt[i];
- for i := bd.Events.Count-1 downto 0 do
- if (bd.Events.Items[i].Callback = aOnUpdateEvent) then
- bd.Events.Delete(i);
- end;
-end;
-
-procedure TutlSettings.UnregisterBlockCallbacks(const aObj: TObject);
-var
- bd: TBlockData;
- i: integer;
-begin
- for bd in fBlocks do
- for i:= bd.Events.Count-1 downto 0 do
- if TMethod(bd.Events[i].Callback).Data = Pointer(aObj) then
- bd.Events.Delete(i);
-end;
-
-procedure TutlSettings.CopyInstance(O, N: TutlSettingsBlock);
-var
- tmp: TutlMCFSection;
-begin
- tmp:= TutlMCFSection.Create;
- try
- O.SaveToConfig(tmp);
- N.LoadFromConfig(tmp);
- finally
- FreeAndNil(tmp);
- end;
-end;
-
-function TutlSettings.Block(const aName: String; out aBlock): boolean;
-var
- i: integer;
- bd: TBlockData;
-begin
- i := fBlocks.IndexOf(aName);
- Result := (i >= 0);
- if Result then begin
- bd:= fBlocks.ValueAt[i];
- CopyInstance(bd.Instance, bd.OldInstance);
- TutlSettingsBlock(aBlock):= bd.Instance;
- end;
-end;
-
-procedure TutlSettings.Changed(const aBlock: TutlSettingsBlock);
-var
- bd: TBlockData;
-begin
- for bd in fBlocks do
- if bd.Instance = aBlock then begin
- bd.CallEvents(opDataChanged, bd.OldInstance, bd.Instance);
- exit;
- end;
-end;
-
-procedure TutlSettings.LoadFromConfig(const aMcf: TutlMCFSection);
-var
- i: Integer;
- b: TBlockData;
-begin
- for i := 0 to fBlocks.Count-1 do begin
- b := fBlocks.ValueAt[i];
- b.Instance.LoadFromConfig(aMcf.Section(fBlocks.Keys[i]));
- if fRaiseChangedEventOnLoad then
- Changed(b.Instance);
- end;
-end;
-
-procedure TutlSettings.SaveToConfig(const aMcf: TutlMCFSection);
-var
- i: integer;
-begin
- for i:= 0 to fBlocks.Count-1 do
- fBlocks.ValueAt[i].Instance.SaveToConfig(aMcf.Section(fBlocks.Keys[i]));
-end;
-
-{$IFDEF USE_VFS}
-procedure TutlSettings.LoadFromFile(const aFile: string);
-var
- sh: IStreamHandle;
- mcf: TutlMCFFile;
-begin
- if vfsManager.ReadFile(aFile, sh) then begin
- mcf:= TutlMCFFile.Create(sh);
- try
- LoadFromConfig(mcf);
- finally
- FreeAndNil(mcf);
- end;
- end;
-end;
-{$ELSE}
-procedure TutlSettings.LoadFromFile(const aFile: string);
-var
- fs: TFileStream;
- mcf: TutlMCFFile;
-begin
- fs := TFileStream.Create(aFile, fmOpenRead);
- mcf := TutlMCFFile.Create(nil);
- try
- mcf.LoadFromStream(fs);
- LoadFromConfig(mcf);
- finally
- FreeAndNil(fs);
- end;
-end;
-{$ENDIF}
-
-{$IFDEF USE_VFS}
-procedure TutlSettings.SaveToFile(const aFile: string);
-var
- sh: IStreamHandle;
- mcf: TutlMCFFile;
-begin
- if vfsManager.CreateFile(aFile, sh) then begin
- mcf:= TutlMCFFile.Create(nil);
- try
- SaveToConfig(mcf);
- mcf.SaveToStream(sh);
- finally
- FreeAndNil(mcf);
- end;
- end;
-end;
-{$ELSE}
-procedure TutlSettings.SaveToFile(const aFile: string);
-var
- fs: TFileStream;
- mcf: TutlMCFFile;
-begin
- fs := TFileStream.Create(aFile, fmCreate);
- mcf := TutlMCFFile.Create(nil);
- try
- SaveToConfig(mcf);
- mcf.SaveToStream(fs);
- finally
- FreeAndNil(mcf);
- FreeAndNil(fs);
- end;
-end;
-{$ENDIF}
-
-constructor TutlSettings.Create;
-begin
- inherited Create;
- fBlocks:= TBlockList.Create(true);
- fRaiseChangedEventOnLoad := true;
-end;
-
-destructor TutlSettings.Destroy;
-begin
- FreeAndNil(fBlocks);
- inherited Destroy;
-end;
-
-initialization
- utlSettings := TutlSettings.Create;
-
-finalization
- FreeAndNil(utlSettings);
-
-end.
-
diff --git a/uutlSystemInfo.pas b/uutlSystemInfo.pas
deleted file mode 100644
index 9a0ae0a..0000000
--- a/uutlSystemInfo.pas
+++ /dev/null
@@ -1,523 +0,0 @@
-unit uutlSystemInfo;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit enthält Klassen zum Auslesen von System Informationen (CPU, Grafikkarte, OpenGL) }
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes, SysUtils, uutlGenerics
- {$IFDEF WINDOWS}, ActiveX, ComObj, variants {$ENDIF};
-
-type
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlSystemInfo = class;
- TutlSystemInfoList = specialize TutlList;
- TutlSystemInfo = class(TObject)
- private
- fName: String;
- fValue: String;
- fItems: TutlSystemInfoList;
- function GetCount: Integer;
- function GetItems(const aIndex: Integer): TutlSystemInfo;
- public
- property Name: String read fName;
- property Value: String read fValue;
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: TutlSystemInfo read GetItems; default;
-
- procedure Update; virtual;
- function ToString: String; override;
-
- constructor Create; virtual;
- destructor Destroy; override;
- end;
- TutlSystemInfoClass = class of TutlSystemInfo;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlOpenGLInfo = class(TutlSystemInfo)
- public
- procedure Update; override;
- end;
-
- {$IFDEF WINDOWS}
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlWmiSystemInfo = class(TutlSystemInfo)
- protected type
- TStringArr = array of String;
- protected
- function GetComputer: String; virtual;
- function GetNamespace: String; virtual;
- function GetUsername: String; virtual;
- function GetPassword: String; virtual;
- function GetQuery: String; virtual;
- function GetProperties: TStringArr; virtual;
- function GetSubItemName(const aIndex: Integer): String; virtual;
- public
- procedure Update; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlProcessorInfo = class(TutlWmiSystemInfo)
- private const
- PROCESSOR_PROPERTIES: array[0..11] of String = ('AddressWidth', 'Caption',
- 'CurrentClockSpeed', 'Description', 'ExtClock', 'Family', 'Manufacturer',
- 'MaxClockSpeed', 'Name', 'NumberOfCores', 'NumberOfLogicalProcessors',
- 'Version');
- protected
- function GetQuery: String; override;
- function GetProperties: TStringArr; override;
- function GetSubItemName(const aIndex: Integer): String; override;
- public
- procedure Update; override;
- end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlVideoControllerInfo = class(TutlWmiSystemInfo)
- private const
- VIDEO_CONTROLLER_PROPERTIES: array[0..11] of String = ('AdapterRAM', 'Caption',
- 'CurrentBitsPerPixel', 'CurrentHorizontalResolution', 'CurrentRefreshRate',
- 'CurrentScanMode', 'CurrentVerticalResolution', 'Description', 'DriverDate',
- 'DriverVersion', 'Name', 'VideoProcessor');
- protected
- function GetQuery: String; override;
- function GetProperties: TStringArr; override;
- function GetSubItemName(const aIndex: Integer): String; override;
- public
- procedure Update; override;
- end;
- {$ENDIF}
-
-procedure LogSystemInfo(const aClass: TutlSystemInfoClass);
-
-const
- SYTEM_INFO_CLASSES_COUNT = {$IFDEF WINDOWS}2+{$ENDIF}1;
- SYTEM_INFO_CLASSES: array[0..SYTEM_INFO_CLASSES_COUNT-1] of TutlSystemInfoClass = (
- {$IFDEF WINDOWS}TutlProcessorInfo,
- TutlVideoControllerInfo,{$ENDIF}
- TutlOpenGLInfo);
-
-implementation
-
-uses
- uutlExceptions, math, dglOpenGL, uutlLogger;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function CreateItem(const aName, aValue: String): TutlSystemInfo;
-begin
- result := TutlSystemInfo.Create;
- result.fName := aName;
- result.fValue := aValue;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function VariantToStr(const aVariant: Variant): String;
-begin
- result := '';
- if (TVarData(aVariant).vtype <> varempty) and
- (TVarData(aVariant).vtype <> varnull) and
- (TVarData(aVariant).vtype <> varerror) then begin
- result := aVariant;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure LogSystemInfo(const aClass: TutlSystemInfoClass);
-var
- info: TutlSystemInfo;
- sList: TStringList;
- i: Integer;
-begin
- info := aClass.Create;
- sList := TStringList.Create;
- try try
- info.Update;
- sList.Text := info.ToString;
- for i := 0 to sList.Count-1 do
- utlLogger.Log('SystemInfo', sList[i], []);
- except on e: Exception do
- utlLogger.Error('SystemInfo', 'Error while logging system info: %s', [e.Message]);
- end;
- finally
- FreeAndNil(info);
- FreeAndNil(sList);
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlSystemInfo////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlSystemInfo.GetCount: Integer;
-begin
- result := fItems.Count;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlSystemInfo.GetItems(const aIndex: Integer): TutlSystemInfo;
-begin
- if (aIndex >= 0) and (aIndex < fItems.Count) then
- result := fItems[aIndex]
- else
- raise EOutOfRange.Create(aIndex, 0, fItems.Count-1);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlSystemInfo.Update;
-begin
-//DUMMY
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlSystemInfo.ToString: String;
-var
- str: String;
-
- procedure FillStr(var aStr: String; const aLen: Integer; const aChar: Char = ' ');
- begin
- while (Length(aStr) < aLen) do
- aStr := aStr + aChar;
- end;
-
- procedure WriteItem(const aPrefix: String; const aItem: TutlSystemInfo; const aItemLen: Integer);
- var
- len, i: Integer;
- line: String;
- begin
- line := aItem.Name + ':';
- if (aItem.Count = 0) then begin
- line := line;
- FillStr(line, aItemLen + 2);
- line := line + aItem.Value;
- end;
- str := str + aPrefix + line + sLineBreak;
- if (aItem.Count > 0) then begin
- len := 0;
- for i := 0 to aItem.Count-1 do
- len := max(len, Length(aItem[i].Name));
- for i := 0 to aItem.Count-1 do
- WriteItem(aPrefix+' ', aItem[i], len);
- end;
- end;
-
-begin
- str := '';
- WriteItem('', self, 0);
- result := str;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-constructor TutlSystemInfo.Create;
-begin
- inherited Create;
- fName := '';
- fValue := '';
- fItems := TutlSystemInfoList.Create(true);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-destructor TutlSystemInfo.Destroy;
-begin
- FreeAndNil(fItems);
- inherited Destroy;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlOpenGLInfo////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlOpenGLInfo.Update;
-
- function AddItem(const aParent: TutlSystemInfo; const aName, aValue: String): TutlSystemInfo;
- begin
- result := CreateItem(aName, aValue);
- aParent.fItems.Add(result);
- end;
-
- function GetInteger(const aName: GLenum): String;
- var
- i: GLint;
- begin
- i := 0;
- glGetIntegerv(aName, @i);
- result := IntToStr(i);
- end;
-
-var
- item: TutlSystemInfo;
-begin
- inherited Update;
- fName := 'OpenGL Information';
- fValue := '';
- item := AddItem(self, 'ImplementationBasics', '');
- AddItem(item, 'GL_VENDOR', glGetString(GL_VENDOR));
- AddItem(item, 'GL_RENDER', glGetString(GL_RENDER));
- AddItem(item, 'GL_VERSION', glGetString(GL_VERSION));
- AddItem(item, 'GL_SHADING_LANGUAGE_VERSION', glGetString(GL_SHADING_LANGUAGE_VERSION));
-
- item := AddItem(self, 'Basics', '');
- AddItem(item, 'GL_MAX_VIEWPORT_DIMS', GetInteger(GL_MAX_VIEWPORT_DIMS));
- AddItem(item, 'GL_MAX_LIGHTS', GetInteger(GL_MAX_LIGHTS));
- AddItem(item, 'GL_MAX_CLIP_PLANES', GetInteger(GL_MAX_CLIP_PLANES));
- AddItem(item, 'GL_MAX_MODELVIEW_STACK_DEPTH', GetInteger(GL_MAX_MODELVIEW_STACK_DEPTH));
- AddItem(item, 'GL_MAX_PROJECTION_STACK_DEPTH', GetInteger(GL_MAX_PROJECTION_STACK_DEPTH));
- AddItem(item, 'GL_MAX_TEXTURE_STACK_DEPTH', GetInteger(GL_MAX_TEXTURE_STACK_DEPTH));
- AddItem(item, 'GL_MAX_ATTRIB_STACK_DEPTH', GetInteger(GL_MAX_ATTRIB_STACK_DEPTH));
- AddItem(item, 'GL_MAX_COLOR_MATRIX_STACK_DEPTH', GetInteger(GL_MAX_COLOR_MATRIX_STACK_DEPTH));
- AddItem(item, 'GL_MAX_LIST_NESTING', GetInteger(GL_MAX_LIST_NESTING));
- AddItem(item, 'GL_SUBPIXEL_BITS', GetInteger(GL_SUBPIXEL_BITS));
- AddItem(item, 'GL_MAX_ELEMENTS_INDICES', GetInteger(GL_MAX_ELEMENTS_INDICES));
- AddItem(item, 'GL_MAX_ELEMENTS_VERTICES', GetInteger(GL_MAX_ELEMENTS_VERTICES));
- AddItem(item, 'GL_MAX_TEXTURE_UNITS', GetInteger(GL_MAX_TEXTURE_UNITS));
- AddItem(item, 'GL_MAX_TEXTURE_COORDS', GetInteger(GL_MAX_TEXTURE_COORDS));
- AddItem(item, 'GL_MAX_SAMPLE_MASK_WORDS', GetInteger(GL_MAX_SAMPLE_MASK_WORDS));
- AddItem(item, 'GL_MAX_COLOR_TEXTURE_SAMPLES', GetInteger(GL_MAX_COLOR_TEXTURE_SAMPLES));
- AddItem(item, 'GL_MAX_DEPTH_TEXTURE_SAMPLES', GetInteger(GL_MAX_DEPTH_TEXTURE_SAMPLES));
- AddItem(item, 'GL_MAX_INTEGER_SAMPLES', GetInteger(GL_MAX_INTEGER_SAMPLES));
-
- item := AddItem(self, 'Textures', '');
- AddItem(item, 'GL_MAX_TEXTURE_SIZE', GetInteger(GL_MAX_TEXTURE_SIZE));
- AddItem(item, 'GL_MAX_3D_TEXTURE_SIZE', GetInteger(GL_MAX_3D_TEXTURE_SIZE));
- AddItem(item, 'GL_MAX_CUBE_MAP_TEXTURE_SIZE', GetInteger(GL_MAX_CUBE_MAP_TEXTURE_SIZE));
- AddItem(item, 'GL_MAX_TEXTURE_LOD_BIAS', GetInteger(GL_MAX_TEXTURE_LOD_BIAS));
- AddItem(item, 'GL_MAX_ARRAY_TEXTURE_LAYERS', GetInteger(GL_MAX_ARRAY_TEXTURE_LAYERS));
- AddItem(item, 'GL_MAX_TEXTURE_BUFFER_SIZE', GetInteger(GL_MAX_TEXTURE_BUFFER_SIZE));
- AddItem(item, 'GL_MAX_RECTANGLE_TEXTURE_SIZE', GetInteger(GL_MAX_RECTANGLE_TEXTURE_SIZE));
- AddItem(item, 'GL_MAX_RENDERBUFFER_SIZE', GetInteger(GL_MAX_RENDERBUFFER_SIZE));
-
- item := AddItem(self, 'FrameBuffers', '');
- AddItem(item, 'GL_MAX_DRAW_BUFFERS', GetInteger(GL_MAX_DRAW_BUFFERS));
- AddItem(item, 'GL_MAX_COLOR_ATTACHMENTS', GetInteger(GL_MAX_COLOR_ATTACHMENTS));
- AddItem(item, 'GL_MAX_SAMPLES', GetInteger(GL_MAX_SAMPLES));
-
- item := AddItem(self, 'VertexShaderLimits', '');
- AddItem(item, 'GL_MAX_VERTEX_ATTRIBS', GetInteger(GL_MAX_VERTEX_ATTRIBS));
- AddItem(item, 'GL_MAX_VERTEX_UNIFORM_COMPONENTS', GetInteger(GL_MAX_VERTEX_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_VERTEX_UNIFORM_VECTORS', GetInteger(GL_MAX_VERTEX_UNIFORM_VECTORS));
- AddItem(item, 'GL_MAX_VERTEX_UNIFORM_BLOCKS', GetInteger(GL_MAX_VERTEX_UNIFORM_BLOCKS));
- AddItem(item, 'GL_MAX_VERTEX_OUTPUT_COMPONENTS', GetInteger(GL_MAX_VERTEX_OUTPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS));
-
- item := AddItem(self, 'FragmentShaderLimits', '');
- AddItem(item, 'GL_MAX_FRAGMENT_UNIFORM_COMPONENTS', GetInteger(GL_MAX_FRAGMENT_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_FRAGMENT_UNIFORM_VECTORS', GetInteger(GL_MAX_FRAGMENT_UNIFORM_VECTORS));
- AddItem(item, 'GL_MAX_FRAGMENT_UNIFORM_BLOCKS', GetInteger(GL_MAX_FRAGMENT_UNIFORM_BLOCKS));
- AddItem(item, 'GL_MAX_FRAGMENT_INPUT_COMPONENTS', GetInteger(GL_MAX_FRAGMENT_INPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_IMAGE_UNITS', GetInteger(GL_MAX_IMAGE_UNITS));
- AddItem(item, 'GL_MAX_FRAGMENT_IMAGE_UNIFORMS', GetInteger(GL_MAX_FRAGMENT_IMAGE_UNIFORMS));
- AddItem(item, 'GL_MIN_PROGRAM_TEXEL_OFFSET', GetInteger(GL_MIN_PROGRAM_TEXEL_OFFSET));
- AddItem(item, 'GL_MAX_PROGRAM_TEXEL_OFFSET', GetInteger(GL_MAX_PROGRAM_TEXEL_OFFSET));
- AddItem(item, 'GL_MIN_PROGRAM_TEXTURE_GATHER_OFFSET', GetInteger(GL_MIN_PROGRAM_TEXTURE_GATHER_OFFSET));
- AddItem(item, 'GL_MAX_PROGRAM_TEXTURE_GATHER_OFFSET', GetInteger(GL_MAX_PROGRAM_TEXTURE_GATHER_OFFSET));
-
- item := AddItem(self, 'CombinedFragmentAndVertexShaderLimits', '');
- AddItem(item, 'GL_MAX_UNIFORM_BUFFER_BINDINGS', GetInteger(GL_MAX_UNIFORM_BUFFER_BINDINGS));
- AddItem(item, 'GL_MAX_UNIFORM_BLOCK_SIZE', GetInteger(GL_MAX_UNIFORM_BLOCK_SIZE));
- AddItem(item, 'GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT', GetInteger(GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT));
- AddItem(item, 'GL_MAX_COMBINED_UNIFORM_BLOCKS', GetInteger(GL_MAX_COMBINED_UNIFORM_BLOCKS));
- AddItem(item, 'GL_MAX_VARYING_FLOATS', GetInteger(GL_MAX_VARYING_FLOATS));
- AddItem(item, 'GL_MAX_VARYING_COMPONENTS', GetInteger(GL_MAX_VARYING_COMPONENTS));
- AddItem(item, 'GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS));
- AddItem(item, 'GL_MAX_SUBROUTINES', GetInteger(GL_MAX_SUBROUTINES));
- AddItem(item, 'GL_MAX_SUBROUTINE_UNIFORM_LOCATIONS', GetInteger(GL_MAX_SUBROUTINE_UNIFORM_LOCATIONS));
- AddItem(item, 'GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_COMBINED_GEOMETRY_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_GEOMETRY_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_COMBINED_TESS_CONTROL_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_TESS_CONTROL_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_COMBINED_TESS_EVALUATION_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_TESS_EVALUATION_UNIFORM_COMPONENTS));
-
- item := AddItem(self, 'GeometryShaderLimits', '');
- AddItem(item, 'GL_MAX_GEOMETRY_UNIFORM_BLOCKS', GetInteger(GL_MAX_GEOMETRY_UNIFORM_BLOCKS));
- AddItem(item, 'GL_MAX_GEOMETRY_INPUT_COMPONENTS', GetInteger(GL_MAX_GEOMETRY_INPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_GEOMETRY_OUTPUT_COMPONENTS', GetInteger(GL_MAX_GEOMETRY_OUTPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_GEOMETRY_OUTPUT_VERTICES', GetInteger(GL_MAX_GEOMETRY_OUTPUT_VERTICES));
- AddItem(item, 'GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS', GetInteger(GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS));
- AddItem(item, 'GL_MAX_GEOMETRY_SHADER_INVOCATIONS', GetInteger(GL_MAX_GEOMETRY_SHADER_INVOCATIONS));
-
- item := AddItem(self, 'TesselationShaderLimits', '');
- AddItem(item, 'GL_MAX_TESS_GEN_LEVEL', GetInteger(GL_MAX_TESS_GEN_LEVEL));
- AddItem(item, 'GL_MAX_PATCH_VERTICES', GetInteger(GL_MAX_PATCH_VERTICES));
- AddItem(item, 'GL_MAX_TESS_PATCH_COMPONENTS', GetInteger(GL_MAX_TESS_PATCH_COMPONENTS));
- AddItem(item, 'GL_MAX_TESS_CONTROL_UNIFORM_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_TESS_CONTROL_UNIFORM_BLOCKS', GetInteger(GL_MAX_TESS_CONTROL_UNIFORM_BLOCKS));
- AddItem(item, 'GL_MAX_TESS_CONTROL_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_TESS_CONTROL_TEXTURE_IMAGE_UNITS));
- AddItem(item, 'GL_MAX_TESS_CONTROL_TOTAL_OUTPUT_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_TOTAL_OUTPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_TESS_CONTROL_INPUT_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_INPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_TESS_CONTROL_OUTPUT_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_OUTPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_TESS_EVALUATION_UNIFORM_COMPONENTS', GetInteger(GL_MAX_TESS_EVALUATION_UNIFORM_COMPONENTS));
- AddItem(item, 'GL_MAX_TESS_EVALUATION_UNIFORM_BLOCKS', GetInteger(GL_MAX_TESS_EVALUATION_UNIFORM_BLOCKS));
- AddItem(item, 'GL_MAX_TESS_EVALUATION_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_TESS_EVALUATION_TEXTURE_IMAGE_UNITS));
- AddItem(item, 'GL_MAX_TESS_EVALUATION_OUTPUT_COMPONENTS', GetInteger(GL_MAX_TESS_EVALUATION_OUTPUT_COMPONENTS));
- AddItem(item, 'GL_MAX_TESS_EVALUATION_INPUT_COMPONENTS', GetInteger(GL_MAX_TESS_EVALUATION_INPUT_COMPONENTS));
-
- item := AddItem(self, 'TransformFeedbackShaderLimits', '');
- AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS));
- AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS));
- AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS));
- AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_BUFFERS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_BUFFERS));
-end;
-
-{$IFDEF WINDOWS}
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlWmiSystemInfo/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlWmiSystemInfo.GetComputer: String;
-begin
- result := 'localhost'#0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlWmiSystemInfo.GetNamespace: String;
-begin
- result := 'root\CIMV2'#0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlWmiSystemInfo.GetUsername: String;
-begin
- result := #0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlWmiSystemInfo.GetPassword: String;
-begin
- result := #0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlWmiSystemInfo.GetQuery: String;
-begin
- result := #0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlWmiSystemInfo.GetProperties: TStringArr;
-begin
- SetLength(result, 0);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlWmiSystemInfo.GetSubItemName(const aIndex: Integer): String;
-begin
- result := IntToStr(aIndex);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlWmiSystemInfo.Update;
-var
- SWbemLocator: OLEVariant;
- WMIService: OLEVariant;
- WbemObjectSet, WbemObject: OLEVariant;
- s: Variant;
- pCeltFetched: LongWord;
- oEnum: IEnumvariant;
- i, j: Integer;
- properties: TStringArr;
- item: TutlSystemInfo;
-
- computer: Variant;
- namespace: Variant;
- username: Variant;
- password: Variant;
- query: Variant;
-const
- WBEM_FLAGFORWARDONLY = $00000020;
-begin
- inherited Update;
- fItems.Clear;
- CoInitialize(nil);
- SWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
- //WMIService := SWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
- computer := GetComputer;
- namespace := GetNamespace;
- username := GetUsername;
- password := GetPassword;
- query := GetQuery;
- WMIService := SWbemLocator.ConnectServer(computer, namespace, username, password);
- WbemObjectSet := WMIService.ExecQuery(query, 'WQL', WBEM_FLAGFORWARDONLY);
- oEnum := IUnknown(WbemObjectSet._NewEnum) as IEnumVariant;
- i := 0;
- properties := GetProperties;
- while oEnum.Next(1, WbemObject, pCeltFetched) = 0 do begin
- inc(i);
- item := TutlSystemInfo.Create;
- item.fName := GetSubItemName(i);
- fItems.Add(item);
- for j := low(properties) to high(properties) do begin
- s := properties[j];
- item.fItems.Add(CreateItem(
- properties[j],
- VariantToStr(WbemObject.Properties_.Item(s).Value)));
- end;
- end;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-//TutlProcessorInfo/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlProcessorInfo.GetQuery: String;
-begin
- result := 'SELECT * FROM Win32_Processor'#0;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlProcessorInfo.GetProperties: TStringArr;
-var
- i: Integer;
-begin
- SetLength(result, Length(PROCESSOR_PROPERTIES));
- for i := low(result) to high(result) do
- result[i] := PROCESSOR_PROPERTIES[i];
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlProcessorInfo.GetSubItemName(const aIndex: Integer): String;
-begin
- result := format('Processor %d', [aIndex]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlProcessorInfo.Update;
-begin
- fName := 'Processor Information';
- fValue := '';
- inherited Update;
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlVideoControllerInfo.GetQuery: String;
-begin
- Result := 'SELECT * FROM Win32_VideoController';
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlVideoControllerInfo.GetProperties: TStringArr;
-var
- i: Integer;
-begin
- SetLength(result, Length(VIDEO_CONTROLLER_PROPERTIES));
- for i := low(result) to high(result) do
- result[i] := VIDEO_CONTROLLER_PROPERTIES[i];
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-function TutlVideoControllerInfo.GetSubItemName(const aIndex: Integer): String;
-begin
- Result := format('Video Controller %d', [aIndex]);
-end;
-
-////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
-procedure TutlVideoControllerInfo.Update;
-begin
- fName := 'Video Controller Information';
- fValue := '';
- inherited Update;
-end;
-{$ENDIF}
-
-end.
-
diff --git a/uutlTiming.pas b/uutlTiming.pas
deleted file mode 100644
index 4bb9794..0000000
--- a/uutlTiming.pas
+++ /dev/null
@@ -1,90 +0,0 @@
-unit uutlTiming;
-
-{ Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit enthält platformunabhängige Methoden für Zeitberechnungen und -messungen
- Mehr oder weniger platformunabhängige Timestampgenerierung.
- GetTickCount64 ms-Timer
- GetMicroTime us-Timer analog php microtime()
- Achtung: windows.pp deklariert auch eine GetTickCount64, wird gegen diese gelinkt
- läuft die exe nicht mehr unter XP. Unbeding uutlTiming *nach* windows einbinden. }
-
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
- Classes
- {$ifdef Windows}
- , Windows
- {$else}
- , Unix, BaseUnix
- {$endif};
-
-function GetTickCount64: QWord;
-function GetMicroTime: QWord;
-
-function utlRateLimited(const Reference: QWord; const Interval: QWord): boolean;
-
-implementation
-
-{$IF defined(WINDOWS)}
-var
- PERF_FREQ: Int64;
-
-function GetTickCount64: QWord;
-begin
- // GetTickCount64 is better, but we need to check the Windows version to use it
- Result := Windows.GetTickCount();
-end;
-
-function GetMicroTime: QWord;
-var
- pc: Int64;
-begin
- pc := 0;
- QueryPerformanceCounter(pc);
- Result:= (pc * 1000*1000) div PERF_FREQ;
-end;
-{$ELSEIF defined(UNIX)}
-function GetTickCount64: QWord;
-var
- tp: TTimeVal;
-begin
- fpgettimeofday(@tp, nil);
- Result := (Int64(tp.tv_sec) * 1000) + (tp.tv_usec div 1000);
-end;
-
-function GetMicroTime: QWord;
-var
- tp: TTimeVal;
-begin
- fpgettimeofday(@tp, nil);
- Result := (Int64(tp.tv_sec) * 1000*1000) + tp.tv_usec;
-end;
-{$ELSE}
-function GetTickCount64: QWord;
-begin
- Result := Trunc(Now * 24 * 60 * 60 * 1000);
-end;
-
-function GetMicroTime: QWord;
-begin
- Result := Trunc(Now * 24 * 60 * 60 * 1000*1000);
-end;
-
-{$ENDIF}
-
-function utlRateLimited(const Reference: QWord; const Interval: QWord): boolean;
-begin
- Result:= GetMicroTime - Reference > Interval;
-end;
-
-initialization
-{$IF defined(WINDOWS)}
- PERF_FREQ := 0;
- QueryPerformanceFrequency(PERF_FREQ);
-{$ENDIF}
-end.
-