Browse Source

* initial commit

master
Bergmann89 9 years ago
commit
98597e1a0d
33 changed files with 11036 additions and 0 deletions
  1. BIN
     
  2. +84
    -0
      Tests/UtilsTests.lpi
  3. +23
    -0
      Tests/UtilsTests.lpr
  4. +170
    -0
      Tests/UtilsTests.lps
  5. BIN
     
  6. +710
    -0
      Tests/uGenericsTests.pas
  7. +394
    -0
      uutlCommon.pas
  8. +2128
    -0
      uutlConsoleHelper.pas
  9. +66
    -0
      uutlConversion.pas
  10. +45
    -0
      uutlEmbeddedProfiler.inc
  11. +301
    -0
      uutlEmbeddedProfiler.pas
  12. +58
    -0
      uutlEnumHelper.inc
  13. +101
    -0
      uutlEnumHelper.pas
  14. +712
    -0
      uutlEventManager.pas
  15. +103
    -0
      uutlExceptions.pas
  16. +1413
    -0
      uutlGenerics.pas
  17. +413
    -0
      uutlGraph.pas
  18. +263
    -0
      uutlKeyCodes.pas
  19. +244
    -0
      uutlLocalization.pas
  20. +436
    -0
      uutlLogger.pas
  21. +645
    -0
      uutlMCF.pas
  22. +100
    -0
      uutlMcfHelper.pas
  23. +453
    -0
      uutlMessageThread.pas
  24. +201
    -0
      uutlMessages.pas
  25. +93
    -0
      uutlPlatform.pas
  26. +63
    -0
      uutlProfilerBinary.inc
  27. +49
    -0
      uutlProfilerPlainText.inc
  28. +46
    -0
      uutlProfilerPlainTextMMap.inc
  29. +71
    -0
      uutlSetHelper.inc
  30. +371
    -0
      uutlSettings.pas
  31. +673
    -0
      uutlStreamHelper.pas
  32. +523
    -0
      uutlSystemInfo.pas
  33. +84
    -0
      uutlTiming.pas

BIN
View File


+ 84
- 0
Tests/UtilsTests.lpi View File

@@ -0,0 +1,84 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="UtilsTests"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="FPCUnitTestRunner"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="UtilsTests.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="uGenericsTests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="uGenericsTests"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="UtilsTests"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value=".."/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseHeaptrc Value="True"/>
</Debugging>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

+ 23
- 0
Tests/UtilsTests.lpr View File

@@ -0,0 +1,23 @@
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.


+ 170
- 0
Tests/UtilsTests.lps View File

@@ -0,0 +1,170 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectSession>
<PathDelim Value="\"/>
<Version Value="9"/>
<BuildModes Active="Default"/>
<Units Count="5">
<Unit0>
<Filename Value="UtilsTests.lpr"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="2"/>
<CursorPos X="12" Y="6"/>
<UsageCount Value="22"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="uGenericsTests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="uGenericsTests"/>
<IsVisibleTab Value="True"/>
<TopLine Value="559"/>
<CursorPos X="54" Y="580"/>
<UsageCount Value="22"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\packages\fcl-fpcunit\src\fpcunit.pp"/>
<UnitName Value="fpcunit"/>
<EditorIndex Value="1"/>
<TopLine Value="113"/>
<CursorPos X="21" Y="129"/>
<UsageCount Value="11"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\uutlGenerics.pas"/>
<UnitName Value="uutlGenerics"/>
<EditorIndex Value="3"/>
<TopLine Value="308"/>
<CursorPos X="15" Y="111"/>
<UsageCount Value="11"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\wstringh.inc"/>
<EditorIndex Value="-1"/>
<CursorPos X="11" Y="30"/>
<UsageCount Value="10"/>
</Unit4>
</Units>
<JumpHistory Count="29" HistoryIndex="28">
<Position1>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="376" Column="30" TopLine="359"/>
</Position1>
<Position2>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="470" Column="13" TopLine="447"/>
</Position2>
<Position3>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="472" Column="41" TopLine="446"/>
</Position3>
<Position4>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="88" Column="23" TopLine="63"/>
</Position4>
<Position5>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="97" TopLine="86"/>
</Position5>
<Position6>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="86" Column="8" TopLine="74"/>
</Position6>
<Position7>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="101" Column="20" TopLine="88"/>
</Position7>
<Position8>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="303" Column="50" TopLine="284"/>
</Position8>
<Position9>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="524" Column="14" TopLine="514"/>
</Position9>
<Position10>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="89" Column="50" TopLine="74"/>
</Position10>
<Position11>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="90" Column="37" TopLine="70"/>
</Position11>
<Position12>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="530" Column="33" TopLine="509"/>
</Position12>
<Position13>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="583" Column="32" TopLine="565"/>
</Position13>
<Position14>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="598" Column="5" TopLine="567"/>
</Position14>
<Position15>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="655" Column="19" TopLine="626"/>
</Position15>
<Position16>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="95" Column="29" TopLine="85"/>
</Position16>
<Position17>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="666" Column="45" TopLine="657"/>
</Position17>
<Position18>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="563" Column="23" TopLine="547"/>
</Position18>
<Position19>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="566" Column="23" TopLine="547"/>
</Position19>
<Position20>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="687" TopLine="663"/>
</Position20>
<Position21>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="686" Column="58" TopLine="670"/>
</Position21>
<Position22>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="700" Column="9" TopLine="682"/>
</Position22>
<Position23>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="704" Column="38" TopLine="692"/>
</Position23>
<Position24>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="700" Column="19" TopLine="685"/>
</Position24>
<Position25>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="612" TopLine="587"/>
</Position25>
<Position26>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="717" Column="17" TopLine="689"/>
</Position26>
<Position27>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="1161" Column="3" TopLine="1148"/>
</Position27>
<Position28>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="887" Column="3" TopLine="884"/>
</Position28>
<Position29>
<Filename Value="uGenericsTests.pas"/>
<Caret Line="658" Column="28" TopLine="652"/>
</Position29>
</JumpHistory>
</ProjectSession>
</CONFIG>

BIN
View File


+ 710
- 0
Tests/uGenericsTests.pas View File

@@ -0,0 +1,710 @@
unit uGenericsTests;

{$mode objfpc}{$H+}

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<TTestObject>;
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<TTestObject>;
TTestHashSet = specialize TutlCustomHashSet<TTestObject>;
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<Integer, TTestObject>;
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;


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<Integer>;
TIntComparer = specialize TutlComparer<Integer>;
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<Integer>;
TIntComparer = specialize TutlComparer<Integer>;
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(EutlMap, @AddExistingKey);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlMapTest.IndexOf;
type
TIntList = specialize TutlList<Integer>;
TIntComparer = specialize TutlComparer<Integer>;
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;

initialization
RegisterTest(TutlListTest);
RegisterTest(TutlHashSetTest);
RegisterTest(TutlMapTest);

end.


+ 394
- 0
uutlCommon.pas View File

@@ -0,0 +1,394 @@
unit uutlCommon;

{ Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit implementiert allgemein nützliche nicht-generische Klassen }

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

interface

uses
Classes, SysUtils, syncobjs, versionresource, versiontypes, typinfo, uutlGenerics
{$IFDEF UNIX}, unixtype, pthreads {$ENDIF};

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStringStack = class(TStringList)
public
procedure Push(const aStr: String);
function Pop: String;
function Seek: String;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlInterfaceNoRefCount = class(TObject, IUnknown)
protected
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;
public
property RefCount: LongInt read fRefCount;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlCSVList = class(TStringList)
private
FSkipDelims: boolean;
function GetStrictDelText: string;
procedure SetStrictDelText(const Value: string);
public
property StrictDelimitedText: string read GetStrictDelText write SetStrictDelText;
// Skip repeated delims instead of reading empty lines?
property SkipDelims: boolean read FSkipDelims write FSkipDelims;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlCheckSynchronizeEvent = class(TObject)
private
fEvent: TEvent;
function WaitMainThread(const aTimeout: Cardinal): TWaitResult;
public const
MAIN_WAIT_GRANULARITY = 10;
public
procedure SetEvent;
procedure ResetEvent;
function WaitFor(const aTimeout: Cardinal): TWaitResult;

constructor Create(const aEventAttributes: syncobjs.PSecurityAttributes;
const aManualReset, aInitialState: Boolean; const aName: string);
destructor Destroy; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlBaseEventList = specialize TutlList<TutlCheckSynchronizeEvent>;
TutlEventList = class(TutlBaseEventList)
public
function AddEvent(const aEventAttributes: syncobjs.PSecurityAttributes; const aManualReset,
aInitialState: Boolean; const aName : string): TutlCheckSynchronizeEvent;
function AddDefaultEvent: TutlCheckSynchronizeEvent;
function WaitAll(const aTimeout: Cardinal): TWaitResult;

constructor Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVersionInfo = class(TObject)
private
fVersionRes: TVersionResource;
function GetFixedInfo: TVersionFixedInfo;
function GetStringFileInfo: TVersionStringFileInfo;
function GetVarFileInfo: TVersionVarFileInfo;
public
property FixedInfo: TVersionFixedInfo read GetFixedInfo;
property StringFileInfo: TVersionStringFileInfo read GetStringFileInfo;
property VarFileInfo: TVersionVarFileInfo read GetVarFileInfo;

function Load(const aInstance: THandle): Boolean;

constructor Create;
destructor Destroy; override;
end;

function utlEventEqual(const aEvent1, aEvent2): Boolean;

implementation

uses
{uutlTiming needs to be included after Windows because of GetTickCount64}
uutlLogger{$IFDEF WINDOWS},Windows{$ENDIF}, uutlTiming;

{$IFNDEF WINDOWS}
function CharNext(const C: PChar): PChar;
begin
//TODO: prüfen ob das für UnicodeString auch stimmt
Result:= C;
if Result^>#0 then
inc(Result);
end;
{$IFEND}

function utlEventEqual(const aEvent1, aEvent2): Boolean;
begin
result :=
(TMethod(aEvent1).Code = TMethod(aEvent2).Code) and
(TMethod(aEvent1).Data = TMethod(aEvent2).Data);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStringStack//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStringStack.Push(const aStr: String);
begin
Insert(0, aStr);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStringStack.Pop: String;
begin
result := '';
if Count > 0 then begin
result := Strings[0];
Delete(0);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStringStack.Seek: String;
begin
result := '';
if Count > 0 then
result := Strings[0];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlInterfaceNoRefCount///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfaceNoRefCount.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 TutlInterfaceNoRefCount._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result := InterLockedIncrement(fRefCount);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfaceNoRefCount._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result := InterLockedDecrement(fRefCount);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlCSVList///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlCSVList.GetStrictDelText: string;
var
S: string;
I, J, Cnt: Integer;
q: boolean;
LDelimiters: TSysCharSet;
begin
Cnt := GetCount;
if (Cnt = 1) and (Get(0) = '') then
Result := QuoteChar + QuoteChar
else
begin
Result := '';
LDelimiters := [QuoteChar, Delimiter];
for I := 0 to Cnt - 1 do
begin
S := Get(I);
q:= false;
if S>'' then begin
for J:= 1 to length(S) do
if S[J] in LDelimiters then begin
q:= true;
break;
end;
if q then S := AnsiQuotedStr(S, QuoteChar);
end else
S := AnsiQuotedStr(S, QuoteChar);
Result := Result + S + Delimiter;
end;
System.Delete(Result, Length(Result), 1);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCSVList.SetStrictDelText(const Value: string);
var
S: String;
P, P1: PChar;
begin
BeginUpdate;
try
Clear;
P:= PChar(Value);
if FSkipDelims then begin
while (P^<>#0) and (P^=Delimiter) do begin
P:= CharNext(P);
end;
end;
while (P^<>#0) do begin
if (P^ = QuoteChar) then begin
S:= AnsiExtractQuotedStr(P, QuoteChar);
end else begin
P1:= P;
while (P^<>#0) and (P^<>Delimiter) do begin
P:= CharNext(P);
end;
SetString(S, P1, P - P1);
end;
Add(S);
while (P^<>#0) and (P^<>Delimiter) do begin
P:= CharNext(P);
end;
if (P^<>#0) then
P:= CharNext(P);
if FSkipDelims then begin
while (P^<>#0) and (P^=Delimiter) do begin
P:= CharNext(P);
end;
end;
end;
finally
EndUpdate;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlCheckSynchronizeEvent/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlCheckSynchronizeEvent.WaitMainThread(const aTimeout: Cardinal): TWaitResult;
var
timeout: qword;
begin
timeout:= GetTickCount64 + aTimeout;
repeat
result := fEvent.WaitFor(TutlCheckSynchronizeEvent.MAIN_WAIT_GRANULARITY);
CheckSynchronize();
until (result <> wrTimeout) or ((GetTickCount64 > timeout) and (aTimeout <> INFINITE));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCheckSynchronizeEvent.SetEvent;
begin
fEvent.SetEvent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCheckSynchronizeEvent.ResetEvent;
begin
fEvent.ResetEvent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlCheckSynchronizeEvent.WaitFor(const aTimeout: Cardinal): TWaitResult;
begin
if (GetCurrentThreadId = MainThreadID) then
result := WaitMainThread(aTimeout)
else
result := fEvent.WaitFor(aTimeout);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlCheckSynchronizeEvent.Create(const aEventAttributes: syncobjs.PSecurityAttributes;
const aManualReset, aInitialState: Boolean; const aName: string);
begin
inherited Create;
fEvent := TEvent.Create(aEventAttributes, aManualReset, aInitialState, aName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlCheckSynchronizeEvent.Destroy;
begin
FreeAndNil(fEvent);
inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventList/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventList.AddEvent(const aEventAttributes: syncobjs.PSecurityAttributes; const aManualReset,
aInitialState: Boolean; const aName: string): TutlCheckSynchronizeEvent;
begin
result := TutlCheckSynchronizeEvent.Create(aEventAttributes, aManualReset, aInitialState, aName);
Add(result);
end;

function TutlEventList.AddDefaultEvent: TutlCheckSynchronizeEvent;
begin
result := AddEvent(nil, true, false, '');
result.ResetEvent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventList.WaitAll(const aTimeout: Cardinal): TWaitResult;
var
i: integer;
timeout, tick: qword;
begin
timeout := GetTickCount64 + aTimeout;
for i := 0 to Count-1 do begin
if (aTimeout <> INFINITE) then begin
tick := GetTickCount64;
if (tick >= timeout) then begin
result := wrTimeout;
exit;
end else
result := Items[i].WaitFor(timeout - tick);
end else
result := Items[i].WaitFor(INFINITE);
if result <> wrSignaled then
exit;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventList.Create;
begin
inherited Create(true);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVersionInfo///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVersionInfo.GetFixedInfo: TVersionFixedInfo;
begin
result := fVersionRes.FixedInfo;
end;

function TutlVersionInfo.GetStringFileInfo: TVersionStringFileInfo;
begin
result := fVersionRes.StringFileInfo;
end;

function TutlVersionInfo.GetVarFileInfo: TVersionVarFileInfo;
begin
result := fVersionRes.VarFileInfo;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVersionInfo.Load(const aInstance: THandle): Boolean;
var
Stream: TResourceStream;
begin
result := false;
if (FindResource(aInstance, PChar(PtrInt(1)), PChar(RT_VERSION)) = 0) then
exit;
Stream := TResourceStream.CreateFromID(aInstance, 1, PChar(RT_VERSION));
try
fVersionRes.SetCustomRawDataStream(Stream);
fVersionRes.FixedInfo;// access some property to force load from the stream
fVersionRes.SetCustomRawDataStream(nil);
finally
Stream.Free;
end;
result := true;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlVersionInfo.Create;
begin
inherited Create;
fVersionRes := TVersionResource.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlVersionInfo.Destroy;
begin
FreeAndNil(fVersionRes);
inherited Destroy;
end;

end.


+ 2128
- 0
uutlConsoleHelper.pas
File diff suppressed because it is too large
View File


+ 66
- 0
uutlConversion.pas View File

@@ -0,0 +1,66 @@
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.


+ 45
- 0
uutlEmbeddedProfiler.inc View File

@@ -0,0 +1,45 @@
{$IFNDEF PROFILER_DISABLE}
{.$DEFINE PROFILER_ENABLE}
{.$DEFINE PROFILER_DISABLE_NAMES}
{$ENDIF}
(******************************************************************************
Usage:
Somewhere, use this:
{.$DEFINE PROFILER_DISABLE} //use this to disable profiling for specific unit
{$I uutlEmbeddedProfiler.inc}
(also add wherever that file is to the project's include search path -Fi,
unit search path is not enough)
In Uses-List: SysUtils, ... __PROFUSE;
(notice: no comma before __PROFUSE)
In Code:
begin
__PROFENTER
... code here ...
__PROFLEAVE
end;
******************************************************************************)
{$macro on}
{$IFDEF PROFILER_ENABLE}
{$DEFINE __PROFENTER:=uutlEmbeddedProfiler.ProfilerEnterProc(Get_pc_addr); try}
{$DEFINE __PROFLEAVE:=finally uutlEmbeddedProfiler.ProfilerLeaveProc; end;}
{$DEFINE __PROFUSE:=, uutlEmbeddedProfiler}
{$DEFINE __PROFUSEPREV:=uutlEmbeddedProfiler, }
{$IFNDEF PROFILER_DISABLE_NAMES}
{$DEFINE __PROFSETNAME:=uutlEmbeddedProfiler.ProfilerEnterProc(Get_pc_addr,}
{$DEFINE __PROFENTERNAME:=); try}
{$ELSE}
{$DEFINE __PROFSETNAME:=//}
{$DEFINE __PROFENTERNAME:=__PROFENTER}
{$ENDIF}
{$ELSE}
{$DEFINE __PROFENTER:=}
{$DEFINE __PROFLEAVE:=}
{$DEFINE __PROFUSE:=}
{$DEFINE __PROFUSEPREV:=}
{$DEFINE __PROFSETNAME:=//}
{$DEFINE __PROFENTERNAME:=}
{$ENDIF}

+ 301
- 0
uutlEmbeddedProfiler.pas View File

@@ -0,0 +1,301 @@
unit uutlEmbeddedProfiler;

{$mode objfpc}{$H+}
{$OPTIMIZATION ON}
{$OPTIMIZATION REGVAR}
{$OPTIMIZATION PEEPHOLE}
{$OPTIMIZATION CSE}
{$OPTIMIZATION ASMCSE}

interface

uses
SysUtils;

var
ProfilerEnabled: boolean;

procedure ProfilerEnterProc(const Addr: Pointer);
procedure ProfilerEnterProc(const Addr: Pointer; const aName: String);
procedure ProfilerLeaveProc;

implementation

{$I uutlEmbeddedProfiler.inc}

{$IFDEF PROFILER_ENABLE}

uses
Windows, lineinfo{%H-}, Classes, fgl, unFastFileStream;

type
TWriterThread = class(TThread)
private type
TCacheEntry = record
Name, Src: ShortString; Line: integer;
end;
TCacheList = specialize TFPGMap<PtrUInt, TCacheEntry>;
private
fAddressCache: TCacheList;
fPF: Int64;
procedure SaveCurrentWrite;
public
constructor Create;
destructor Destroy; override;
procedure Execute; override;
end;

PEventRecord = ^TEventRecord;
TEventRecord = packed record
Name: String;
Func: PtrUInt;
Thread: TThreadID;
When: Int64;
end;

TProfileDataFile = class
public
constructor Create(const {%H-}aFileName: string);
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); virtual; abstract;
procedure WriteLeave(Thread: TThreadID; When: Int64); virtual; abstract;
end;

{$DEFINE __HEAD}
//{$I uutlProfilerPlainText.inc}
{$I uutlProfilerPlainTextMMap.inc}
{$UnDef __HEAD}
//{$I uutlProfilerPlainText.inc}
{$I uutlProfilerPlainTextMMap.inc}


const
MAX_EVENT_COUNT = 1000;
RETURN_FUNCTION : PtrUInt = PtrUInt(-1);

var
ProfilerDataFile: TProfileDataFile;
LineNumberComp: PtrUInt;
Events: array[0..MAX_EVENT_COUNT-1] of TEventRecord;
InsertPtr, WritePtr: Integer;
WriterThread: TWriterThread;
SLInsert: Cardinal;

procedure InstallWriterThread;
begin
if not Assigned(WriterThread) then
WriterThread:= TWriterThread.Create;
end;

procedure UninstallWriterThread;
begin
if Assigned(WriterThread) then begin
WriterThread.Terminate;
WriterThread.WaitFor;
FreeAndNil(WriterThread);
end;
end;

procedure NextInsert;
begin
inc(InsertPtr);
if InsertPtr >= MAX_EVENT_COUNT then
InsertPtr:= 0;
// wait until writer cleared this element
While Events[InsertPtr].Func <> 0 do
ThreadSwitch;
end;

procedure CalibrateLineNumberCompensation1(const Addr: PtrUInt);
begin
LineNumberComp:= Addr;
end;

procedure CalibrateLineNumberCompensation;
label
mark;
begin
mark:
CalibrateLineNumberCompensation1({%H-}PtrUInt(Get_pc_addr));
//measure out one CALL
LineNumberComp:= LineNumberComp - {%H-}PtrUInt(@mark);
//go somewhere into the stack prep before the call
inc(LineNumberComp);
end;

procedure TestDebugInfoPresent;
var
f,s: ShortString;
l: LongInt;
begin
f:= '';
s:= '';
l:= 0;
if not GetLineInfo({%H-}PtrUInt(@TestDebugInfoPresent),f,s,l) then begin
raise Exception.Create('Profiler is enabled, but no suitable debug info could be found.');
Halt();
end;
end;

procedure ProfilerEnterProc(const Addr: Pointer);
begin
ProfilerEnterProc(Addr, '');
end;

procedure ProfilerEnterProc(const Addr: Pointer; const aName: String);
var
f: PtrUInt;
tid: TThreadID;
er: PEventRecord;
begin
if not ProfilerEnabled then
exit;
tid:= GetCurrentThreadId;
InstallWriterThread;
repeat
System.InterlockedCompareExchange(SLInsert, tid, 0);
until SLInsert = tid;
try
// measure as late (close to measured code) as possible, but still write .Func last, because that's our lockvar
f:= {%H-}PtrUInt(addr) - LineNumberComp;
er:= @Events[InsertPtr];
er^.Thread := tid;
er^.Name := aName;
QueryPerformanceCounter(er^.When);
er^.Func := f;
NextInsert;
finally
System.InterLockedExchange(SLInsert, 0);
end;
end;

procedure ProfilerLeaveProc;
var
t: Int64;
tid: TThreadID;
er: PEventRecord;
begin
if not ProfilerEnabled then
exit;
QueryPerformanceCounter(t{%H-});
tid:= GetCurrentThreadId;
repeat
System.InterlockedCompareExchange(SLInsert, tid, 0);
until SLInsert = tid;
try
// measure as early (close to measured code) as possible, but still write .Func last, because that's our lockvar
er := @Events[InsertPtr];
er^.Thread := tid;
er^.When := t;
er^.Name := '';
er^.Func := RETURN_FUNCTION;
NextInsert;
finally
System.InterLockedExchange(SLInsert, 0);
end;
end;

{ TProfileDataFile }

constructor TProfileDataFile.Create(const aFileName: string);
begin
inherited Create;
end;

{ TWriterThread }

constructor TWriterThread.Create;
begin
inherited Create(false);
fAddressCache:= TCacheList.Create;
fAddressCache.Sorted:= true;
QueryPerformanceFrequency(fPF);
end;

destructor TWriterThread.Destroy;
begin
FreeAndNil(fAddressCache);
inherited Destroy;
end;

procedure TWriterThread.Execute;
begin
while not Terminated do begin
while Events[WritePtr].Func<>0 do begin
SaveCurrentWrite;
inc(WritePtr);
if WritePtr >= MAX_EVENT_COUNT then
WritePtr:= 0;
end;
Sleep(1);
end;
//finish up remaining data, by now, writing is disabled
while Events[WritePtr].Func<>0 do begin
SaveCurrentWrite;
inc(WritePtr);
if WritePtr >= MAX_EVENT_COUNT then
WritePtr:= 0;
end;
end;

procedure TWriterThread.SaveCurrentWrite;
var
ce: TCacheEntry;
i: integer;
begin
if Events[WritePtr].Func = 0 then
exit;
if Events[WritePtr].Func = RETURN_FUNCTION then
ProfilerDataFile.WriteLeave(Events[WritePtr].Thread, (Events[WritePtr].When * 1000 * 1000) div fPF)
else begin
i:= fAddressCache.IndexOf(Events[WritePtr].Func);
if i < 0 then begin
ce.Line:= 0;
ce.Src:= '';
GetLineInfo(Events[WritePtr].Func,ce.Name,ce.Src,ce.Line);
if (ce.Name = '') then
ce.Name := Format('0x%.16x', [Events[WritePtr].Func]);
fAddressCache.Add(Events[WritePtr].Func, ce);
end else
ce:= fAddressCache.Data[i];
if (Events[WritePtr].Name <> '') then
ce.Name := '[' + Events[WritePtr].Name + '] ' + ce.Name;
ProfilerDataFile.WriteEnter(Events[WritePtr].Thread, (Events[WritePtr].When * 1000 * 1000) div fPF, ce.Name, ce.Src, ce.Line);
end;
Events[WritePtr].Func:= 0;
end;

{$ELSE}

procedure ProfilerEnterProc(const Addr: Pointer); inline;
begin end;

procedure ProfilerEnterProc(const Addr: Pointer; const aName: String); inline;
begin end;

procedure ProfilerLeaveProc; inline;
begin end;

{$ENDIF}

initialization
{$IFDEF PROFILER_ENABLE}
ProfilerEnabled:= false;
InsertPtr:= 0;
WritePtr:= 0;
WriterThread:= nil;
CalibrateLineNumberCompensation;
TestDebugInfoPresent;
//ProfilerDataFile:= TProfilePlainText.Create(ChangeFileExt(ParamStr(0), '.profraw'));
//ProfilerDataFile:= TProfileBinary.Create(ChangeFileExt(ParamStr(0), '.profbin'));
ProfilerDataFile:= TProfilePlainTextMMap.Create(ChangeFileExt(ParamStr(0), '.profraw'));
ProfilerEnabled:= true;
{$ENDIF}

finalization
{$IFDEF PROFILER_ENABLE}
ProfilerEnabled:= false;
UninstallWriterThread;
FreeAndNil(ProfilerDataFile);
{$ENDIF}
end.


+ 58
- 0
uutlEnumHelper.inc View File

@@ -0,0 +1,58 @@
{$IF defined(__ENUM_INTERFACE)}

type __ENUM_HELPER = class
private type
TValueArray = packed array[0..__ENUM_LENGTH-1] of __ENUM_TYPE;
public
class function {%H}ToString(const Value: __ENUM_TYPE): String; reintroduce;
class function TryToEnum(const Str: String; out Value: __ENUM_TYPE): boolean; overload;
class function ToEnum(const Str: String; const aDefault: __ENUM_TYPE): __ENUM_TYPE; overload;
class function ToEnum(const Str: String): __ENUM_TYPE; overload;
class function Values: TValueArray;
strict private
const TABLE: packed record
E: TValueArray; // array of values
N: AnsiString; // comma-separated string of names
end =

{$ELSEIF defined (__ENUM_IMPLEMENTATION)}

class function __ENUM_HELPER.ToString(const Value: __ENUM_TYPE): String;
var
i: integer;
begin
Result:= '';
if LookupVal(@Value, @TABLE.E, sizeof(__ENUM_TYPE), length(TABLE.E), i) then
Result:= PickString(TABLE.N, i);
end;

class function __ENUM_HELPER.ToEnum(const Str: String): __ENUM_TYPE;
begin
if not TryToEnum(Str, Result) then
raise EConvertErrorAlias.CreateFmt('"%s" is an invalid value',[Str]);
end;

class function __ENUM_HELPER.ToEnum(const Str: String; const aDefault: __ENUM_TYPE): __ENUM_TYPE;
begin
if not TryToEnum(Str, Result) then
Result:= aDefault;
end;

class function __ENUM_HELPER.TryToEnum(const Str: String; out Value: __ENUM_TYPE): boolean;
var
i: integer;
begin
Result:= LookupString(Str, TABLE.N, i);
if Result then
Value:= TABLE.E[i];
end;

class function __ENUM_HELPER.Values: TValueArray;
begin
Result:= TABLE.E;
end;

{$ENDIF}
{$undef __ENUM_TYPE}
{$undef __ENUM_LENGTH}
{$undef __ENUM_HELPER}

+ 101
- 0
uutlEnumHelper.pas View File

@@ -0,0 +1,101 @@
unit uutlEnumHelper;

(* Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit stellt einen Mechanismus zur Verfügung, ohne viel Aufwand,
Helper Klassen für Enums zu implementieren
Verwendung:
{$MACRO ON}

interface
{$define __ENUM_INTERFACE}
{$define __ENUM_HELPER:=TSomeEnumH}{$define __ENUM_TYPE:=TSomeEnum}{$define __ENUM_LENGTH:=4}
{$I uutlEnumHelper.inc}(
E: (enVal1, enVal2, enVal3, enVal4);
N: 'enVal1,enVal2,enVal3,enVal4';
); end;
//... mehr davon
{$undef __ENUM_INTERFACE}

implementation
{$define __ENUM_IMPLEMENTATION}
{$define __ENUM_HELPER:=TSomeEnumH}{$define __ENUM_TYPE:=TSomeEnum}{$I uutlEnumHelper.inc}
{$undef __ENUM_IMPLEMENTATION} *)

interface

uses
SysUtils, StrUtils;

type
EConvertErrorAlias = SysUtils.EConvertError;

function LookupString(const aStr, aTable: String; out found: integer): boolean;
function PickString(const aTable: String; const aIndex: integer): string;
function LookupVal(const aVal: Pointer; const aPtr: Pointer; const aStep, aCount: PtrInt; out found: integer): boolean;

implementation

function LookupString(const aStr, aTable: String; out found: integer): boolean;
var
tbl: string;
i,p,k: integer;
t: string;
begin
Result:= false;
tbl:= aTable + ',';
t:= '';
k:= 0;
i:= 1;
while i < Length(tbl) do begin
p:= PosEx(',',tbl,i);
t:= Trim(Copy(tbl, i, p-i));
i:= p+1;
if CompareText(t, aStr)=0 then begin
found:= k;
Result:= true;
exit;
end else
inc(k);
end;
end;

function PickString(const aTable: String; const aIndex: integer): string;
var
tbl: String;
k,i,p: integer;
begin
result:= '';
tbl:= aTable + ',';
i:= 1;
k:= aIndex;
while (k>0) and (i>0) do begin
i:= PosEx(',',tbl, i) + 1;
dec(k);
end;
p:= PosEx(',',tbl, i);
if p<=0 then
Result:= ''
else
Result:= Trim(Copy(tbl, i, p-i));
end;


function LookupVal(const aVal: Pointer; const aPtr: Pointer; const aStep, aCount: PtrInt; out found: integer): boolean;
var
pt: Pointer;
i: integer;
begin
Result:= false;
pt:= aPtr;
for i:= 0 to aCount-1 do begin
if CompareMem(pt, aVal, aStep) then begin
Result:= true;
found:= i;
exit;
end;
inc(pt, aStep);
end;
end;

end.

+ 712
- 0
uutlEventManager.pas View File

@@ -0,0 +1,712 @@
unit uutlEventManager;

{ Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit verwaltet Events und verteilt diese an registrierte Programm-Teile }

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, uutlGenerics, syncobjs, uutlTiming, Controls, Forms, uutlMessageThread, uutlMessages;

type
TutlEventType = (
MOUSE_DOWN = 10,
MOUSE_UP,
MOUSE_WHEEL_UP,
MOUSE_WHEEL_DOWN,
MOUSE_MOVE,
MOUSE_ENTER,
MOUSE_LEAVE,
MOUSE_CLICK,
MOUSE_DBL_CLICK,

KEY_DOWN = 20,
KEY_REPEAT,
KEY_UP,

WINDOW_RESIZE = 30,
WINDOW_ACTIVATE,
WINDOW_DEACTIVATE
);
TutlEventTypes = set of TutlEventType;

{ TutlInputEvent }

TutlInputEvent = class
protected
function CreateInstance: TutlInputEvent; virtual;
procedure Assign(const aEvent: TutlInputEvent); virtual;
public
Timestamp: QWord;
EventType: TutlEventType;
function Clone: TutlInputEvent;
constructor Create(aType: TutlEventType);
end;
TutlInputEventList = specialize TutlList<TutlInputEvent>;

{ TutlMouseEvent }

TutlMouseEvent = class(TutlInputEvent)
protected
function CreateInstance: TutlInputEvent; override;
procedure Assign(const aEvent: TutlInputEvent); override;
public
Button: TMouseButton;
ClientPos,
ScreenPos: TPoint;
constructor Create(aType: TutlEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint);
constructor Create(aType: TutlEventType; aClientPos, aScreenPos: TPoint);
end;

{ TutlKeyEvent }

TutlKeyEvent = class(TutlInputEvent)
protected
function CreateInstance: TutlInputEvent; override;
procedure Assign(const aEvent: TutlInputEvent); override;
public
CharCode: WideChar;
KeyCode: Word;
constructor Create(aType: TutlEventType; aCharCode: WideChar; aKeyCode: Word);
end;

{ TutlWindowEvent }

TutlWindowEvent = class(TutlInputEvent)
protected
function CreateInstance: TutlInputEvent; override;
procedure Assign(const aEvent: TutlInputEvent); override;
public
ScreenRect: TRect;
ClientWidth,
ClientHeight: Cardinal;
constructor Create(aType: TutlEventType; aScreenRect: TRect; aClientWidth, aClientHeight: Cardinal);
constructor Create(aType: TutlEventType; aScreenTopLeft: TPoint; aClientWidth, aClientHeight: Cardinal);
end;

{ TutlEventManager }

TutlInputEventHandler = procedure (Sender: TObject; Event: TutlInputEvent; var DoneEvent: boolean) of object;
TMouseButtons = set of TMouseButton;
TutlEventManager = class
private type
TInputState = record
Keyboard: record
Modifiers: TShiftState;
KeyState: array[Byte] of Boolean;
end;
Mouse: record
ScreenPos, ClientPos: TPoint;
Buttons: TMouseButtons;
end;
Window: record
Active: boolean;
ScreenRect: TRect;
ClientWidth: Integer;
ClientHeight: Integer;
end;
end;

TEventListener = class
ThreadID: TThreadID;
Synchronous: Boolean;
Filter: TutlEventTypes;
Handler: TutlInputEventHandler;
end;
TEventListenerList = specialize TutlList<TEventListener>;

TInputEventMsg = class(TutlCallbackMsg)
private
fSender: TObject;
fHandler: TutlInputEventHandler;
fInputEvent: TutlInputEvent;
public
procedure ExecuteCallback; override;
constructor Create(const aSender: TObject; const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent);
destructor Destroy; override;
end;

TSyncInputEventMsg = class(TutlSyncCallbackMsg)
private
fSender: TObject;
fHandler: TutlInputEventHandler;
fInputEvent: TutlInputEvent;
fDoneEvent: Boolean;
public
property DoneEvent: Boolean read fDoneEvent;
procedure ExecuteCallback; override;
constructor Create(const aSender: TObject; const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent);
destructor Destroy; override;
end;

private
fEventQueue: TutlInputEventList;
fEventQueueLock: TCriticalSection;
fListeners: TEventListenerList;
protected
fCanonicalState: TInputState;
procedure EventHandlerMouseDown(Sender: TObject; Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer);
procedure EventHandlerMouseUp(Sender: TObject; Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer);
procedure EventHandlerMouseWheel(Sender: TObject; {%H-}Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
procedure EventHandlerMouseMove(Sender: TObject; {%H-}Shift: TShiftState; X, Y: Integer);
procedure EventHandlerMouseEnter(Sender: TObject);
procedure EventHandlerMouseLeave(Sender: TObject);

procedure EventHandlerClick(Sender: TObject);
procedure EventHandlerDblClick(Sender: TObject);

procedure EventHandlerKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
procedure EventHandlerKeyUp(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);

procedure EventHandlerResize(Sender: TObject);
procedure EventHandlerActivate(Sender: TObject);
procedure EventHandlerDeactivate(Sender: TObject);

function QueuePush(const aEvent: TutlInputEvent): TutlInputEvent;

function DispatchEvent(const aEvent: TutlInputEvent): boolean;
procedure RecordEvent(const aEvent: TutlInputEvent);
public
property CanonicalState: TInputState read fCanonicalState;

procedure AttachEvents(const fControl: TCustomForm; aEventMask: TutlEventTypes);
function IsKeyDown(const aChar: Char): Boolean;

procedure RegisterListener(const aEventMask: TutlEventTypes; const aHandler: TutlInputEventHandler; const aSynchronous: Boolean = false);
procedure UnregisterListener(const aHandler: TutlInputEventHandler);

procedure DispatchEvents;

constructor Create;
destructor Destroy; override;
end;

function utlEventManager: TutlEventManager;

const
utlInput_Events_Mouse = [MOUSE_DOWN, MOUSE_UP, MOUSE_WHEEL_UP, MOUSE_WHEEL_DOWN, MOUSE_MOVE,
MOUSE_ENTER, MOUSE_LEAVE, MOUSE_CLICK, MOUSE_DBL_CLICK];
utlInput_Events_Keyboard = [KEY_DOWN, KEY_REPEAT, KEY_UP];
utlInput_Events_Window = [WINDOW_RESIZE, WINDOW_ACTIVATE, WINDOW_DEACTIVATE];
utlInput_Events_All = utlInput_Events_Mouse+utlInput_Events_Keyboard+utlInput_Events_Window;

implementation

uses uutlKeyCodes, uutlLogger, LCLIntf;

type
TCustomFormVisibilityClass = class(TCustomForm)
published
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseEnter;
property OnMouseLeave;
property OnActivate;
property OnDeactivate;
property OnClick;
property OnDblClick;
end;

var
utlEventManager_Singleton: TutlEventManager;

function utlEventManager: TutlEventManager;
begin
if not Assigned(utlEventManager_Singleton) then
utlEventManager_Singleton := TutlEventManager.Create;
result := utlEventManager_Singleton;
end;

{ TSyncInputEventMsg }

procedure TutlEventManager.TSyncInputEventMsg.ExecuteCallback;
begin
fHandler(fSender, fInputEvent, fDoneEvent);
end;

constructor TutlEventManager.TSyncInputEventMsg.Create(const aSender: TObject;
const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent);
begin
inherited Create;
fSender := aSender;
fInputEvent := aInputEvent.Clone;
fHandler := aHandler;
fDoneEvent := false;
end;

destructor TutlEventManager.TSyncInputEventMsg.Destroy;
begin
FreeAndNil(fInputEvent);
inherited Destroy;
end;

{ TInputEventMsg }

procedure TutlEventManager.TInputEventMsg.ExecuteCallback;
var
done: Boolean;
begin
done := false;
fHandler(fSender, fInputEvent, done);
end;

constructor TutlEventManager.TInputEventMsg.Create(const aSender: TObject;
const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent);
begin
inherited Create;
fSender := aSender;
fInputEvent := aInputEvent.Clone;
fHandler := aHandler;
end;

destructor TutlEventManager.TInputEventMsg.Destroy;
begin
FreeAndNil(fInputEvent);
inherited Destroy;
end;

{ TutlInputEvent }

function TutlInputEvent.CreateInstance: TutlInputEvent;
begin
result := TutlInputEvent.Create(EventType);
end;

procedure TutlInputEvent.Assign(const aEvent: TutlInputEvent);
begin
EventType := aEvent.EventType;
Timestamp := aEvent.Timestamp;
end;

function TutlInputEvent.Clone: TutlInputEvent;
begin
result := CreateInstance;
result.Assign(self);
end;

constructor TutlInputEvent.Create(aType: TutlEventType);
begin
inherited Create;
Timestamp:= GetMicroTime;
EventType:= aType;
end;

{ TutlMouseEvent }

function TutlMouseEvent.CreateInstance: TutlInputEvent;
begin
result := TutlMouseEvent.Create(EventType, ClientPos, ScreenPos);
end;

procedure TutlMouseEvent.Assign(const aEvent: TutlInputEvent);
var
e: TutlMouseEvent;
begin
inherited Assign(aEvent);
e := aEvent as TutlMouseEvent;
Button := e.Button;
ClientPos := e.ClientPos;
ScreenPos := e.ScreenPos;
end;

constructor TutlMouseEvent.Create(aType: TutlEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint);
begin
inherited Create(aType);
Button:= aButton;
ClientPos:= aClientPos;
ScreenPos:= aScreenPos;
end;

constructor TutlMouseEvent.Create(aType: TutlEventType; aClientPos, aScreenPos: TPoint);
begin
inherited Create(aType);
ClientPos:= aClientPos;
ScreenPos:= aScreenPos;
end;

{ TutlKeyEvent }

function TutlKeyEvent.CreateInstance: TutlInputEvent;
begin
result := TutlKeyEvent.Create(EventType, CharCode, KeyCode);
end;

procedure TutlKeyEvent.Assign(const aEvent: TutlInputEvent);
var
e: TutlKeyEvent;
begin
inherited Assign(aEvent);
e := (aEvent as TutlKeyEvent);
CharCode := e.CharCode;
KeyCode := e.KeyCode;
end;

constructor TutlKeyEvent.Create(aType: TutlEventType; aCharCode: WideChar; aKeyCode: Word);
begin
inherited Create(aType);
CharCode:= aCharCode;
KeyCode:= aKeyCode;
end;

{ TutlWindowEvent }

function TutlWindowEvent.CreateInstance: TutlInputEvent;
begin
result := TutlWindowEvent.Create(EventType, ScreenRect, ClientWidth, ClientHeight);
end;

procedure TutlWindowEvent.Assign(const aEvent: TutlInputEvent);
var
e: TutlWindowEvent;
begin
inherited Assign(aEvent);
e := (aEvent as TutlWindowEvent);
ScreenRect := e.ScreenRect;
ClientWidth := e.ClientWidth;
ClientHeight := e.ClientHeight;
end;

constructor TutlWindowEvent.Create(aType: TutlEventType; aScreenRect: TRect; aClientWidth,
aClientHeight: Cardinal);
begin
inherited Create(aType);
ScreenRect:= aScreenRect;
ClientWidth:= aClientWidth;
ClientHeight:= aClientHeight;
end;

constructor TutlWindowEvent.Create(aType: TutlEventType; aScreenTopLeft: TPoint; aClientWidth, aClientHeight: Cardinal);
begin
inherited Create(aType);
ClientWidth:= aClientWidth;
ClientHeight:= aClientHeight;

ScreenRect.TopLeft:= aScreenTopLeft;
ScreenRect.BottomRight:= aScreenTopLeft;
inc(ScreenRect.Right, ClientWidth);
inc(ScreenRect.Bottom, ClientHeight);
end;

{ TutlEventManager }

{$REGION EventHandler}
procedure TutlEventManager.EventHandlerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
QueuePush(TutlMouseEvent.Create(MOUSE_DOWN, Button, Point(X,Y), TWinControl(Sender).ClientToScreen(Point(X,Y))));
end;

procedure TutlEventManager.EventHandlerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
QueuePush(TutlMouseEvent.Create(MOUSE_MOVE, Point(X,Y), TWinControl(Sender).ClientToScreen(Point(X,Y))));
end;

procedure TutlEventManager.EventHandlerMouseEnter(Sender: TObject);
begin
QueuePush(TutlMouseEvent.Create(MOUSE_ENTER, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos));
end;

procedure TutlEventManager.EventHandlerMouseLeave(Sender: TObject);
begin
QueuePush(TutlMouseEvent.Create(MOUSE_LEAVE, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos));
end;

procedure TutlEventManager.EventHandlerClick(Sender: TObject);
begin
QueuePush(TutlMouseEvent.Create(MOUSE_CLICK, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos));
end;

procedure TutlEventManager.EventHandlerDblClick(Sender: TObject);
begin
QueuePush(TutlMouseEvent.Create(MOUSE_DBL_CLICK, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos));
end;

procedure TutlEventManager.EventHandlerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
QueuePush(TutlMouseEvent.Create(MOUSE_UP, Button, Point(X,Y), TWinControl(Sender).ClientToScreen(Point(X,Y))));
end;

procedure TutlEventManager.EventHandlerMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
if WheelDelta < 0 then
QueuePush(TutlMouseEvent.Create(MOUSE_WHEEL_DOWN, MousePos, TWinControl(Sender).ClientToScreen(MousePos)))
else
QueuePush(TutlMouseEvent.Create(MOUSE_WHEEL_UP, MousePos, TWinControl(Sender).ClientToScreen(MousePos)));
Handled:= false;
end;

procedure TutlEventManager.EventHandlerKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
ch: WideChar;
begin
ch:= VKCodeToCharCode(Key, fCanonicalState.Keyboard.Modifiers);

if fCanonicalState.Keyboard.KeyState[Key and $FF] then
QueuePush(TutlKeyEvent.Create(KEY_REPEAT, ch, Key))
else
QueuePush(TutlKeyEvent.Create(KEY_DOWN, ch, Key));
end;

procedure TutlEventManager.EventHandlerKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
var
ch: WideChar;
begin
ch:= VKCodeToCharCode(Key, fCanonicalState.Keyboard.Modifiers);
QueuePush(TutlKeyEvent.Create(KEY_UP, ch, Key));
end;

procedure TutlEventManager.EventHandlerResize(Sender: TObject);
var
w: TControl;
begin
w := (Sender as TControl);
QueuePush(TutlWindowEvent.Create(WINDOW_RESIZE, w.ClientToScreen(Point(0,0)), w.ClientWidth, w.ClientHeight));
end;

procedure TutlEventManager.EventHandlerActivate(Sender: TObject);
var
w: TControl;
begin
w := (Sender as TControl);
QueuePush(TutlWindowEvent.Create(WINDOW_ACTIVATE, w.ClientToScreen(Point(0,0)), w.ClientWidth, w.ClientHeight));
end;

procedure TutlEventManager.EventHandlerDeactivate(Sender: TObject);
var
w: TControl;
begin
w := (Sender as TControl);
QueuePush(TutlWindowEvent.Create(WINDOW_DEACTIVATE, w.ClientToScreen(Point(0,0)), w.ClientWidth, w.ClientHeight));
end;
{$ENDREGION}

function TutlEventManager.QueuePush(const aEvent: TutlInputEvent): TutlInputEvent;
begin
fEventQueueLock.Acquire;
try
if Assigned(fEventQueue) then
fEventQueue.Add(aEvent);
Result:= aEvent;
finally
fEventQueueLock.Release;
end;
end;

function TutlEventManager.DispatchEvent(const aEvent: TutlInputEvent): boolean;
var
i: integer;
ls: TEventListener;
msg: TSyncInputEventMsg;
begin
Result:= false;
for i:= 0 to fListeners.Count-1 do begin
if aEvent.EventType in fListeners[i].Filter then begin
ls := fListeners[i];
if (GetCurrentThreadId <> ls.ThreadID) then begin
if (ls.Synchronous) then begin
msg := TSyncInputEventMsg.Create(self, ls.Handler, aEvent);
if utlSendMessage(ls.ThreadID, msg, 5000) = wrSignaled then begin
result := msg.DoneEvent;
msg.Free; //only free on wrSignal, otherwise thread will free message
end
end else
utlPostMessage(ls.ThreadID, TInputEventMsg.Create(self, ls.Handler, aEvent));
end else
fListeners[i].Handler(Self, aEvent, Result);
end;
if Result then
break;
end;
end;

procedure TutlEventManager.RecordEvent(const aEvent: TutlInputEvent);

function GetPressedButtons: TMouseButtons;
begin
result := [];
if (GetKeyState(VK_LBUTTON) < 0) then
result := result + [mbLeft];
if (GetKeyState(VK_RBUTTON) < 0) then
result := result + [mbRight];
if (GetKeyState(VK_MBUTTON) < 0) then
result := result + [mbMiddle];
if (GetKeyState(VK_XBUTTON1) < 0) then
result := result + [mbExtra1];
if (GetKeyState(VK_XBUTTON2) < 0) then
result := result + [mbExtra2];
end;

begin
if aEvent is TutlMouseEvent then
with TutlMouseEvent(aEvent) do begin
fCanonicalState.Mouse.ClientPos := ClientPos;
fCanonicalState.Mouse.ScreenPos := ScreenPos;
case EventType of
MOUSE_DOWN:
Include(fCanonicalState.Mouse.Buttons, Button);
MOUSE_UP:
Exclude(fCanonicalState.Mouse.Buttons, Button);
MOUSE_LEAVE:
fCanonicalState.Mouse.Buttons := [];
MOUSE_ENTER:
fCanonicalState.Mouse.Buttons := GetPressedButtons;
MOUSE_CLICK,
MOUSE_DBL_CLICK,
MOUSE_MOVE,
MOUSE_WHEEL_DOWN,
MOUSE_WHEEL_UP: ; //nothing to record here
end;
end
else if aEvent is TutlKeyEvent then
with TutlKeyEvent(aEvent) do begin
case EventType of
KEY_DOWN,
KEY_REPEAT: begin
fCanonicalState.Keyboard.KeyState[KeyCode and $FF]:= true;
case KeyCode of
VK_SHIFT: include(fCanonicalState.Keyboard.Modifiers, ssShift);
VK_MENU: include(fCanonicalState.Keyboard.Modifiers, ssAlt);
VK_CONTROL: include(fCanonicalState.Keyboard.Modifiers, ssCtrl);
end;
end;
KEY_UP: begin
fCanonicalState.Keyboard.KeyState[KeyCode and $FF]:= false;
case KeyCode of
VK_SHIFT: Exclude(fCanonicalState.Keyboard.Modifiers, ssShift);
VK_MENU: Exclude(fCanonicalState.Keyboard.Modifiers, ssAlt);
VK_CONTROL: Exclude(fCanonicalState.Keyboard.Modifiers, ssCtrl);
end;
end;
end;
if [ssCtrl, ssAlt] - fCanonicalState.Keyboard.Modifiers = [] then
include(fCanonicalState.Keyboard.Modifiers, ssAltGr)
else
exclude(fCanonicalState.Keyboard.Modifiers, ssAltGr);
end
else if aEvent is TutlWindowEvent then
with TutlWindowEvent(aEvent) do begin
case EventType of
WINDOW_ACTIVATE: fCanonicalState.Window.Active:= true;
WINDOW_DEACTIVATE: fCanonicalState.Window.Active:= true;
WINDOW_RESIZE: begin
fCanonicalState.Window.ScreenRect := ScreenRect;
fCanonicalState.Window.ClientWidth := ClientWidth;
fCanonicalState.Window.ClientHeight := ClientHeight;
end;
end;
end
end;

procedure TutlEventManager.DispatchEvents;
var
i: integer;
begin
fEventQueueLock.Acquire;
try
if Assigned(fEventQueue) then begin
//process ALL events
for i:= 0 to fEventQueue.Count-1 do begin
DispatchEvent(fEventQueue[i]);
RecordEvent(fEventQueue[i]);
end;
//now that we're done, free them
fEventQueue.Clear;
end;
finally
fEventQueueLock.Release;
end;
end;

procedure TutlEventManager.AttachEvents(const fControl: TCustomForm; aEventMask: TutlEventTypes);
var
ctl: TCustomFormVisibilityClass;
begin
ctl:= TCustomFormVisibilityClass(fControl);
ctl.KeyPreview:= true;
if MOUSE_DOWN in aEventMask then ctl.OnMouseDown:= @EventHandlerMouseDown;
if MOUSE_UP in aEventMask then ctl.OnMouseUp:= @EventHandlerMouseUp;
if (MOUSE_WHEEL_DOWN in aEventMask) or
(MOUSE_WHEEL_UP in aEventMask) then ctl.OnMouseWheel:= @EventHandlerMouseWheel;
if MOUSE_MOVE in aEventMask then ctl.OnMouseMove:= @EventHandlerMouseMove;
if MOUSE_ENTER in aEventMask then ctl.OnMouseEnter := @EventHandlerMouseEnter;
if MOUSE_LEAVE in aEventMask then ctl.OnMouseLeave := @EventHandlerMouseLeave;
if MOUSE_CLICK in aEventMask then ctl.OnClick := @EventHandlerClick;
if MOUSE_DBL_CLICK in aEventMask then ctl.OnDblClick := @EventHandlerDblClick;

if KEY_DOWN in aEventMask then ctl.OnKeyDown:= @EventHandlerKeyDown;
if KEY_UP in aEventMask then ctl.OnKeyUp:= @EventHandlerKeyUp;

if WINDOW_RESIZE in aEventMask then ctl.OnResize:= @EventHandlerResize;
if WINDOW_ACTIVATE in aEventMask then ctl.OnActivate:= @EventHandlerActivate;
if WINDOW_DEACTIVATE in aEventMask then ctl.OnDeactivate:= @EventHandlerDeactivate;
end;

function TutlEventManager.IsKeyDown(const aChar: Char): Boolean;
begin
result := CanonicalState.Keyboard.KeyState[Ord(UpCase(aChar))];
end;

procedure TutlEventManager.RegisterListener(const aEventMask: TutlEventTypes;
const aHandler: TutlInputEventHandler; const aSynchronous: Boolean);
var
ls: TEventListener;
begin
UnregisterListener(aHandler);
ls:= TEventListener.Create;
try
ls.Filter := aEventMask;
ls.Handler := aHandler;
ls.ThreadID := GetCurrentThreadId;
ls.Synchronous := aSynchronous;
fListeners.Add(ls);
except
ls.Free;
end;
end;

procedure TutlEventManager.UnregisterListener(const aHandler: TutlInputEventHandler);
var
i: integer;
m1, m2: TMethod;
begin
m1 := TMethod(aHandler);
for i:= fListeners.Count-1 downto 0 do begin
m2 := TMethod(fListeners[i].Handler);
if (m1.Data = m2.Data) and
(m2.Code = m2.Code)then
fListeners.Delete(i);
end;
end;

constructor TutlEventManager.Create;
begin
inherited Create;
fEventQueue:= TutlInputEventList.Create(true);
fEventQueueLock:= TCriticalSection.Create;
fListeners:= TEventListenerList.Create(true);
end;

destructor TutlEventManager.Destroy;
begin
FreeAndNil(fListeners);
fEventQueueLock.Acquire;
try
fEventQueue.Clear;
FreeAndNil(fEventQueue);
finally
fEventQueueLock.Release;
end;
FreeAndNil(fEventQueueLock);
inherited Destroy;
end;

finalization
if Assigned(utlEventManager_Singleton) then
FreeAndNil(utlEventManager_Singleton);

end.


+ 103
- 0
uutlExceptions.pas View File

@@ -0,0 +1,103 @@
unit uutlExceptions;

{ Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit enthält Definitionen für verschiedene Exceptions }

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, syncobjs;

type
EOutOfRange = class(Exception)
constructor Create(const aIndex, aMin, aMax: Integer);
end;

EUnknownType = class(Exception)
public
constructor Create(const aObj: TObject);
end;

EArgumentNil = class(Exception)
public
constructor Create(const aArgName: String);
end;

EArgument = class(Exception)
public
constructor Create(const aArg, aMsg: String);
constructor Create(const aMsg: String);
end;
EParameter = EArgument;

EFileDoesntExists = class(Exception)
public
constructor Create(const aFilename: string);
end;
EFileNotFound = EFileDoesntExists;

EInvalidFile = class(Exception);

EInvalidOperation = class(Exception);

ENotSupported = class(Exception);

EWait = class(Exception)
private
fWaitResult: TWaitResult;
public
property WaitResult: TWaitResult read fWaitResult;
constructor Create(const msg: string; const aWaitResult: TWaitResult);
end;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EOutOfRange.Create(const aIndex, aMin, aMax: Integer);
begin
inherited Create(format('index (%d) out of range (%d:%d)', [aIndex, aMin, aMax]));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EUnknownType.Create(const aObj: TObject);
begin
inherited Create(format('unknown type: %s', [aObj.ClassName]));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EArgumentNil.Create(const aArgName: String);
begin
inherited Create(format('argument ''%s'' can not be nil!', [aArgName]));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EArgument.Create(const aArg, aMsg: String);
begin
inherited Create(format('invalid argument "%s" - %s', [aArg, aMsg]))
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EArgument.Create(const aMsg: String);
begin
inherited Create(aMsg);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EFileDoesntExists.Create(const aFilename: string);
begin
inherited Create('file doesn''t exists: ' + aFilename);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EWait.Create(const msg: string; const aWaitResult: TWaitResult);
begin
inherited Create(msg);
fWaitResult := aWaitResult;
end;


end.


+ 1413
- 0
uutlGenerics.pas
File diff suppressed because it is too large
View File


+ 413
- 0
uutlGraph.pas View File

@@ -0,0 +1,413 @@
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<GData: TutlGraphNodeData; GNode, GOwner> = 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<T: TutlGraphNode> = 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.


+ 263
- 0
uutlKeyCodes.pas View File

@@ -0,0 +1,263 @@
unit uutlKeyCodes;
{ Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit enthält alle virtuellen Key Codes }
{$mode objfpc}{$H+}
interface
uses Classes;
{$REGION SCANCODES}
const
VK_UNKNOWN = 0; // defined by LCL
VK_LBUTTON = 1;
VK_RBUTTON = 2;
VK_CANCEL = 3;
VK_MBUTTON = 4;
VK_XBUTTON1 = 5;
VK_XBUTTON2 = 6;
VK_BACK = 8; // The "Backspace" key, dont confuse with the
// Android BACK key which is mapped to VK_ESCAPE
VK_TAB = 9;
VK_CLEAR = 12;
VK_RETURN = 13; // The "Enter" key, also used for a keypad center press
VK_SHIFT = 16; // See also VK_LSHIFT, VK_RSHIFT
VK_CONTROL = 17; // See also VK_LCONTROL, VK_RCONTROL
VK_MENU = 18;
// The ALT key. Also called "Option" in Mac OS X. See also VK_LMENU, VK_RMENU
VK_PAUSE = 19; // Pause/Break key
VK_CAPITAL = 20; // CapsLock key
VK_KANA = 21;
VK_HANGUL = 21;
VK_JUNJA = 23;
VK_FINAL = 24;
VK_HANJA = 25;
VK_KANJI = 25;
VK_ESCAPE = 27; // Also used for the hardware Back key in Android
VK_CONVERT = 28;
VK_NONCONVERT = 29;
VK_ACCEPT = 30;
VK_MODECHANGE = 31;
VK_SPACE = 32;
VK_PRIOR = 33; // Page Up
VK_NEXT = 34; // Page Down
VK_END = 35;
VK_HOME = 36;
VK_LEFT = 37;
VK_UP = 38;
VK_RIGHT = 39;
VK_DOWN = 40;
VK_SELECT = 41;
VK_PRINT = 42; // PrintScreen key
VK_EXECUTE = 43;
VK_SNAPSHOT = 44;
VK_INSERT = 45;
VK_DELETE = 46;
VK_HELP = 47;
VK_0 = $30;
VK_1 = $31;
VK_2 = $32;
VK_3 = $33;
VK_4 = $34;
VK_5 = $35;
VK_6 = $36;
VK_7 = $37;
VK_8 = $38;
VK_9 = $39;
//3A-40 Undefined
VK_A = $41;
VK_B = $42;
VK_C = $43;
VK_D = $44;
VK_E = $45;
VK_F = $46;
VK_G = $47;
VK_H = $48;
VK_I = $49;
VK_J = $4A;
VK_K = $4B;
VK_L = $4C;
VK_M = $4D;
VK_N = $4E;
VK_O = $4F;
VK_P = $50;
VK_Q = $51;
VK_R = $52;
VK_S = $53;
VK_T = $54;
VK_U = $55;
VK_V = $56;
VK_W = $57;
VK_X = $58;
VK_Y = $59;
VK_Z = $5A;
VK_LWIN = $5B;
// In Mac OS X this is the Apple, or Command key. Windows Key in PC keyboards
VK_RWIN = $5C;
// In Mac OS X this is the Apple, or Command key. Windows Key in PC keyboards
VK_APPS = $5D; // The PopUp key in PC keyboards
// $5E reserved
VK_SLEEP = $5F;
VK_NUMPAD0 = 96; // $60
VK_NUMPAD1 = 97;
VK_NUMPAD2 = 98;
VK_NUMPAD3 = 99;
VK_NUMPAD4 = 100;
VK_NUMPAD5 = 101;
VK_NUMPAD6 = 102;
VK_NUMPAD7 = 103;
VK_NUMPAD8 = 104;
VK_NUMPAD9 = 105;
VK_MULTIPLY = 106;
// VK_MULTIPLY up to VK_DIVIDE are usually in the numeric keypad in PC keyboards
VK_ADD = 107;
VK_SEPARATOR = 108;
VK_SUBTRACT = 109;
VK_DECIMAL = 110;
VK_DIVIDE = 111;
VK_F1 = 112;
VK_F2 = 113;
VK_F3 = 114;
VK_F4 = 115;
VK_F5 = 116;
VK_F6 = 117;
VK_F7 = 118;
VK_F8 = 119;
VK_F9 = 120;
VK_F10 = 121;
VK_F11 = 122;
VK_F12 = 123;
VK_F13 = 124;
VK_F14 = 125;
VK_F15 = 126;
VK_F16 = 127;
VK_F17 = 128;
VK_F18 = 129;
VK_F19 = 130;
VK_F20 = 131;
VK_F21 = 132;
VK_F22 = 133;
VK_F23 = 134;
VK_F24 = 135; // $87
// $88-$8F unassigned
VK_NUMLOCK = $90;
VK_SCROLL = $91;
{$ENDREGION}
function CharCodeToVKCode(Ch: WideChar; out shift: TShiftState): word;
function VKCodeToCharCode(key: word; Shift: TShiftState): WideChar;
implementation
{$IFDEF WINDOWS}
uses Windows;
function CharCodeToVKCode(Ch: WideChar; out shift: TShiftState): word;
var
st: SmallInt;
begin
shift:= [];
Result:= 0;
if ch=#0 then
exit;
st:= VkKeyScan(AnsiChar(UnicodeChar(ch)));
if (hi(st)=$FF) and (lo(st)=$FF) then
exit;
Result:= lo(st);
if Result and (1 shl 8) > 0 then include(shift, ssShift);
if Result and (2 shl 8) > 0 then include(shift, ssCtrl);
if Result and (4 shl 8) > 0 then include(shift, ssAlt);
if [ssCtrl, ssAlt] - shift = [] then
include(shift, ssAltGr);
end;
function VKCodeToCharCode(key: word; Shift: TShiftState): WideChar;
var
sc: word;
ks: array[0..255] of byte;
buf: array[0..1] of AnsiChar;
begin
Result:= #0;
sc:= MapVirtualKey(key, {MAPVK_VK_TO_VSC} 0);
FillChar({%H-}ks[0], sizeof(ks), 0);
if ssShift in Shift then ks[VK_SHIFT]:= $80;
if ssCtrl in Shift then ks[VK_CONTROL]:= $80;
if ssAlt in Shift then ks[VK_MENU]:= $80;
if ssCaps in Shift then ks[VK_CAPITAL]:= $81;
buf:= #0#0;
case ToAscii(key, sc, @ks[0], LPWORD(@buf[0]), 0) of
0: Result:= #0;//The specified virtual key has no translation for the current state of the keyboard.
1: Result:= UnicodeChar(AnsiChar(buf[0]));//One character was copied to the buffer
2: Result:= UnicodeChar(AnsiChar(buf[1]));//Two characters were copied to the buffer. This usually happens when a dead-key character (accent or diacritic) stored in the keyboard layout cannot be composed with the specified virtual key to form a single character.
end;
end;
{$ELSE}
uses SysUtils, gtk2proc;
function VKCodeToCharCode(key: word; Shift: TShiftState): WideChar;
var
vki: TVKeyInfo;
dt: PAnsiChar;
begin
Result:= #0;
vki:= GetVKeyInfo(Key);
if strlen(vki.KeyChar[0])>0 then begin
dt:= '';
if []=Shift then
dt:= vki.KeyChar[0]
else
if ([ssShift]=Shift) or ([ssCaps]=Shift) then
dt:= vki.KeyChar[1]
else
if ([ssCtrl, ssAlt]=Shift) or ([ssAltGr]=Shift) then
dt:= vki.KeyChar[2];
Utf8ToUnicode(@Result, 1, PChar(dt), strlen(dt));
end;
end;
function CharCodeToVKCode(Ch: WideChar; out shift: TShiftState): word;
var
k: Word;
vki: TVKeyInfo;
utf8ch: array[0..high(TVKeyUTF8Char)] of AnsiChar;
begin
Result:= 0;
if ch=#0 then
exit;
utf8ch:= #0#0#0#0#0#0#0#0; //wat
UnicodeToUTF8(@utf8ch[0], sizeof(utf8ch), @ch, 1);
for k:= low(byte) to high(byte) do begin
vki:= GetVKeyInfo(k);
if CompareMem(@utf8ch, @vki.KeyChar[0], sizeof(utf8ch)) then begin
Result:= k;
shift:= [];
exit;
end else
if CompareMem(@utf8ch, @vki.KeyChar[1], sizeof(utf8ch)) then begin
Result:= k;
shift:= [ssShift];
exit;
end else
if CompareMem(@utf8ch, @vki.KeyChar[2], sizeof(utf8ch)) then begin
Result:= k;
shift:= [ssAltGr, ssAlt, ssCtrl];
exit;
end;
end;
end;
{$ENDIF}
end.

+ 244
- 0
uutlLocalization.pas View File

@@ -0,0 +1,244 @@
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<String, TutlLocalizationItem>;
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.


+ 436
- 0
uutlLogger.pas View File

@@ -0,0 +1,436 @@
unit uutlLogger;

{ Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit enthält das Logging-Framework

Anzusprechen über Singleton: utlLogger

Die einzelnen Level sind über die Methoden Debug(), Info(), Warning(), Error() zugänglich.
Sender: entweder eigener Text oder TObject-Referenz, dann wird Klassenname und Adresse ausgegeben.

Log-Zeilen werden nicht weiter behandelt, sondern an Consumer verteilt.
Es können beliebig viele Consumer per RegisterConsumer für bestimmte Level registriert werden.
Jeder davon bekommt die Rohdaten eines Logeintrags auf einer beobachteten Stufe.
Zum einfacheren Ausgeben gibt es eine Hilfsfunktion FormatLine vom Logger.

Vordefinierte Consumer:
TutlFileLogger - schreibt in eine Datei
TutlConsoleLogger - schreibt auf die Konsole (ggf. mit CriticalSection)
TutlEventLogger - ruft beliebiges Event auf
}

{$mode objfpc}{$H+}

interface

uses
{$IFDEF MSWINDOWS}Windows{$ELSE}unix{$ENDIF},
Classes, SysUtils, uutlGenerics, syncobjs, uutlCommon;

type
TutlLogLevel = (llDebug, llInfo, llWarning, llError);
TutlLogLevels = set of TutlLogLevel;

const
utlLogLevel_Any = [low(TutlLogLevel)..high(TutlLogLevel)];
utlLogLevel_NoDebug = utlLogLevel_Any - [llDebug];
utlLogLevelStrings: array[TutlLogLevel] of string =
('Debug','Info','Warning','Error');

type
TutlLogger = class;
IutlLogConsumer = interface(IUnknown)
procedure WriteLog(const aLogger: TutlLogger; const aTime:TDateTime; const aLevel:TutlLogLevel; const aSender: string; const aMessage: String);
end;

TutlLogConsumerList = specialize TutlInterfaceList<IutlLogConsumer>;

{ TutlLogger }

TutlLogger = class(TObject)
private
fConsumersLock: TCriticalSection;
fConsumers: array[TutlLogLevel] of TutlLogConsumerList;
protected
class function FormatTime(const aTime:TDateTime): string;
function FormatSender(const aSender: TObject): String;
procedure InternalLog(const aLevel:TutlLogLevel; const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
procedure InternalLog(const aLevel:TutlLogLevel; const aSender: String; const aMessage: String; const aParams: array of const); overload;
public
procedure RegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter:TutlLogLevels=utlLogLevel_Any);
procedure UnRegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter:TutlLogLevels=utlLogLevel_Any);

class function FormatLine(const aTime:TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String): string;

procedure Debug(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
procedure Debug(const aSender: String; const aMessage: String; const aParams: array of const); overload;
procedure Log(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
procedure Log(const aSender: String; const aMessage: String; const aParams: array of const); overload;
procedure Warning(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
procedure Warning(const aSender: String; const aMessage: String; const aParams: array of const); overload;
procedure Error(const aSender: TObject; const aMessage: String; const aParams: array of const); overload;
procedure Error(const aSender: String; const aMessage: String; const aParams: array of const); overload;
procedure Error(const aSender: String; const aMessage: String; const aException: Exception); overload;
procedure Error(const aSender: TObject; const aMessage: String; const aException: Exception); overload;

constructor Create;
destructor Destroy; override;
end;

{ TutlFileLogger }

TutlFileLoggerMode = (flmCreateNew, flmAppend);
TutlFileLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer)
private
fStream: TFileStream;
fAutoFlush: boolean;
protected
procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
public
constructor Create(const aFilename: String; const aMode: TutlFileLoggerMode);
destructor Destroy; override;

procedure Flush(); overload;
published
property AutoFlush:boolean read fAutoFlush write fAutoFlush;
end;

{ TutlConsoleLogger }

TutlConsoleLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer)
private
fFreeConsoleCS: boolean;
fConsoleCS: TCriticalSection;
fOnBeforeLog: TNotifyEvent;
fOnAfterLog: TNotifyEvent;
protected
procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); virtual;
public
property ConsoleCS: TCriticalSection read fConsoleCS;
property OnBeforeLog: TNotifyEvent read fOnBeforeLog write fOnBeforeLog;
property OnAfterLog: TNotifyEvent read fOnAfterLog write fOnAfterLog;

constructor Create(const aSection: TCriticalSection = nil);
destructor Destroy; override;
end;

{ TutlEventLogger }
TutlWriteLogEvent = procedure (const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String) of object;
TutlEventLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer)
private
fWriteLogEvt: TutlWriteLogEvent;
protected
procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
public
constructor Create(const aEvent: TutlWriteLogEvent);
end;

function utlLogger: TutlLogger;
function utlCreateStackTrace(const aMessage: String; const aException: Exception): String;

implementation

var
utlLogger_Singleton: TutlLogger;

function utlLogger: TutlLogger;
begin
if not Assigned(utlLogger_Singleton) then
utlLogger_Singleton:= TutlLogger.Create;
Result:= utlLogger_Singleton;
end;

function utlCreateStackTrace(const aMessage: String; const aException: Exception): String;
var
i: Integer;
frames: PPointer;
begin
result := aMessage;
if Assigned(aException) then
result := result + sLineBreak +
' Exception: ' + aException.ClassName + sLineBreak +
' Message: ' + aException.Message + sLineBreak +
' StackTrace:' + sLineBreak +
' ' + BackTraceStrFunc(ExceptAddr)
else
result := result + 'no Exception passed';
frames := ExceptFrames;
for i := 0 to ExceptFrameCount-1 do
result := result + sLineBreak + ' ' + BackTraceStrFunc(frames[i]);
end;

{ TutlFileLogger }

function FileFlush(Handle: THandle): Boolean;
begin
{$IFDEF MSWINDOWS}
Result:= FlushFileBuffers(Handle);
{$ELSE}
Result:= (fpfsync(Handle) = 0);
{$ENDIF}
end;

procedure TutlFileLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime;
const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
var
buf: AnsiString;
begin
if Assigned(fStream) then begin
buf:= aLogger.FormatLine(aTime, aLevel, aSender, aMessage)+sLineBreak;
fStream.Write(buf[1], Length(buf));
if AutoFlush then
FileFlush(fStream.Handle);
end;
end;

constructor TutlFileLogger.Create(const aFilename: String; const aMode: TutlFileLoggerMode);
const
RIGHTS: Cardinal = {$IFNDEF UNIX}fmShareDenyWrite{$ELSE}%0100100100 {-r--r--r--}{$ENDIF};
begin
try
if (aMode = flmCreateNew) or not FileExists(aFilename) then begin
if FileExists(aFilename) then
DeleteFile(aFilename);
fStream := TFileStream.Create(aFilename, fmCreate{$IFNDEF UNIX} or RIGHTS{$ENDIF}, RIGHTS)
end else
fStream := TFileStream.Create(aFilename, fmOpenReadWrite{$IFNDEF UNIX} or RIGHTS{$ENDIF}, RIGHTS);
fStream.Position := fStream.Size;
except
on e: EStreamError do begin
fStream:= nil;
utlLogger.Error('Logger', 'Could not open log file "%s"',[aFilename]);
end else
raise;
end;
AutoFlush:=true;
end;

destructor TutlFileLogger.Destroy;
begin
FreeAndNil(fStream);
inherited Destroy;
end;

procedure TutlFileLogger.Flush;
begin
if Assigned(fStream) then
FileFlush(fStream.Handle);
end;

{ TutlConsoleLogger }

procedure TutlConsoleLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime;
const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
begin
fConsoleCS.Acquire;
try
if Assigned(fOnBeforeLog) then
fOnBeforeLog(Self);
WriteLn(aLogger.FormatLine(aTime, aLevel, aSender, aMessage));
if Assigned(fOnAfterLog) then
fOnAfterLog(Self);
finally
fConsoleCS.Release;
end;
end;

constructor TutlConsoleLogger.Create(const aSection: TCriticalSection);
begin
inherited Create;
if Assigned(aSection) then
fConsoleCS:= aSection
else
fConsoleCS:= TCriticalSection.Create;
fFreeConsoleCS:= not Assigned(aSection);
end;

destructor TutlConsoleLogger.Destroy;
begin
if fFreeConsoleCS then
FreeAndNil(fConsoleCS);
inherited Destroy;
end;

{ TutlEventLogger }

procedure TutlEventLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime;
const aLevel: TutlLogLevel; const aSender: string; const aMessage: String);
begin
fWriteLogEvt(aLogger,aTime, aLevel, aSender, aMessage);
end;

constructor TutlEventLogger.Create(const aEvent: TutlWriteLogEvent);
begin
inherited Create;
fWriteLogEvt:= aEvent;
end;

{ TutlLogger }

procedure TutlLogger.RegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter: TutlLogLevels);
var
ll: TutlLogLevel;
begin
fConsumersLock.Acquire;
try
for ll:= low(ll) to high(ll) do
if (ll in aFilter) and (fConsumers[ll].IndexOf(aConsumer)<0) then
fConsumers[ll].Add(aConsumer);
finally
fConsumersLock.Release;
end;
if llDebug in aFilter then
aConsumer.WriteLog(Self, Now, llDebug, 'System', 'Attached to Logger');
end;

procedure TutlLogger.UnRegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter: TutlLogLevels);
var
ll: TutlLogLevel;
begin
fConsumersLock.Acquire;
try
for ll:= low(ll) to high(ll) do
if ll in aFilter then
fConsumers[ll].Remove(aConsumer);
finally
fConsumersLock.Release;
end;
end;

class function TutlLogger.FormatTime(const aTime: TDateTime): string;
begin
Result:= FormatDateTime('hh:nn:ss.zzz',aTime);
end;

function TutlLogger.FormatSender(const aSender: TObject): String;
begin
if Assigned(aSender) then
result := format('%s[0x%P]', [aSender.ClassName, Pointer(aSender)])
else
result := '';
end;

class function TutlLogger.FormatLine(const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String): string;
begin
if (aSender <> '') then
Result:= Format('%s %-9s %s: %s', [FormatTime(aTime), UpperCase(utlLogLevelStrings[aLevel]), aSender, aMessage])
else
Result:= Format('%s %-9s %s', [FormatTime(aTime), UpperCase(utlLogLevelStrings[aLevel]), aMessage]);
end;

procedure TutlLogger.InternalLog(const aLevel: TutlLogLevel; const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
InternalLog(aLevel, FormatSender(aSender), aMessage, aParams);
end;

procedure TutlLogger.InternalLog(const aLevel: TutlLogLevel; const aSender: String; const aMessage: String; const aParams: array of const);
var
msg: string;
when: TDateTime;
i: integer;
begin
if length(aParams) = 0 then
msg:= aMessage
else
msg:= Format(aMessage, aParams);
when:= Now;

fConsumersLock.Acquire;
try
for i:= 0 to fConsumers[aLevel].Count-1 do begin
fConsumers[aLevel][i].WriteLog(Self, when, aLevel, aSender, msg);
end;
finally
fConsumersLock.Release;
end;
end;

procedure TutlLogger.Debug(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
InternalLog(llDebug, aSender, aMessage, aParams);
end;

procedure TutlLogger.Debug(const aSender: String; const aMessage: String; const aParams: array of const);
begin
InternalLog(llDebug, aSender, aMessage, aParams);
end;

procedure TutlLogger.Log(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
InternalLog(llInfo, aSender, aMessage, aParams);
end;

procedure TutlLogger.Log(const aSender: String; const aMessage: String; const aParams: array of const);
begin
InternalLog(llInfo, aSender, aMessage, aParams);
end;

procedure TutlLogger.Warning(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
InternalLog(llWarning, aSender, aMessage, aParams);
end;

procedure TutlLogger.Warning(const aSender: String; const aMessage: String; const aParams: array of const);
begin
InternalLog(llWarning, aSender, aMessage, aParams);
end;

procedure TutlLogger.Error(const aSender: TObject; const aMessage: String; const aParams: array of const);
begin
InternalLog(llError, aSender, aMessage, aParams);
end;

procedure TutlLogger.Error(const aSender: String; const aMessage: String; const aParams: array of const);
begin
InternalLog(llError, aSender, aMessage, aParams);
end;

procedure TutlLogger.Error(const aSender: String; const aMessage: String; const aException: Exception);
begin
InternalLog(llError, aSender, utlCreateStackTrace(aMessage, aException), []);
end;

procedure TutlLogger.Error(const aSender: TObject; const aMessage: String; const aException: Exception);
begin
InternalLog(llError, aSender, utlCreateStackTrace(aMessage, aException), []);
end;

constructor TutlLogger.Create;
var
ll: TutlLogLevel;
begin
inherited Create;
fConsumersLock:= TCriticalSection.Create;
fConsumersLock.Acquire;
try
for ll:= low(ll) to high(ll) do begin
fConsumers[ll]:= TutlLogConsumerList.Create;
end;
finally
fConsumersLock.Release;
end;
end;

destructor TutlLogger.Destroy;
var
ll: TutlLogLevel;
begin
fConsumersLock.Acquire;
try
for ll:= low(ll) to high(ll) do begin
fConsumers[ll].Clear;
FreeAndNil(fConsumers[ll]);
end;
finally
fConsumersLock.Release;
end;
FreeAndNil(fConsumersLock);
inherited Destroy;
end;

finalization
FreeAndNil(utlLogger_Singleton);

end.


+ 645
- 0
uutlMCF.pas View File

@@ -0,0 +1,645 @@
unit uutlMCF;

{ Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit enthält Klassen zum Lesen und Schreiben eines MuoConfgiFiles (kurz MCF)

Lesen/Schreiben in/von Stream über TutlMCFFile
LineEndMode zur Kompatibilität mit MCF-alt und KCF:
leNone - Kein Semikolon erlaubt (KCF)
leAcceptNoWrite - Semikolon wird beim Lesen ignoriert, beim Schreiben weggelassen
leAlways - Beim Lesen erforderlich, immer geschrieben (MCF-alt)

Jeder SectionName und jeder ValueName ist Unique, es kann aber ein Value und eine
Section mit dem gleichen Namen existieren

Zugriff auf Subsections über .Section(), mehrere Stufen auf einmal mit . getrennt:
mcf.Section('foo.bar.baz') === mcf.Section('foo').Section('bar').Section('baz')
Zugriff erstellt automatisch eine Section, falls sie nicht existiert. Prüfung mit
SectionExists (nur direkt, keine Pfade!).

Zugriff auf Werte von der Section aus:
Get/Set[Int,Float,String,Bool](Key, Default)
ValueExists()
UnsetValue()
Strings sind Widestrings, Un/Escaping passiert beim Dateizugriff automatisch

Enumeration: ValueCount/ValueNameAt, SectionCount/SectionNameAt }

interface

uses
SysUtils, Classes, uutlStreamHelper;

type
EConfigException = class(Exception)
end;
TutlMCFSection = class;
TutlMCFFile = class;
TutlMCFLineEndMarkerMode = (leNone, leAcceptNoWrite, leAlways);

{ TutlMCFSection }

TutlMCFSection = class
private type
TSectionEnumerator = class(TObject)
private
fList: TStringList;
fPosition: Integer;
function GetCurrent: TutlMCFSection;
public
property Current: TutlMCFSection read GetCurrent;
function MoveNext: Boolean;
constructor Create(const aList: TStringList);
end;
private
FSections,
FValues: TStringList;
function GetSection(aPath: String): TutlMCFSection;
function GetSectionCount: integer;
function GetSectionName(Index: integer): string;
function GetSectionByIndex(aIndex: Integer): TutlMCFSection;
function GetValueCount: integer;
function GetValueName(Index: integer): string;
protected
procedure ClearSections;
procedure ClearValues;
procedure SaveData(Stream: TStream; Indent: string; LineEnds: TutlMCFLineEndMarkerMode);
procedure LoadData(Data: TStream; LineEnds: TutlMCFLineEndMarkerMode; Depth: Integer);
procedure AddValueChecked(Name: String; Val: TObject);
procedure SplitPath(const Path: String; out First, Rest: String);
public
constructor Create;
destructor Destroy; override;

function GetEnumerator: TSectionEnumerator;

property ValueCount: integer read GetValueCount;
property ValueNameAt[Index: integer]: string read GetValueName;

property SectionCount: integer read GetSectionCount;
property SectionNameAt[Index: integer]: string read GetSectionName;
property Sections[aPath: String]: TutlMCFSection read GetSection; default;
property SectionByIndex[aIndex: Integer]: TutlMCFSection read GetSectionByIndex;

function SectionExists(Path: string): boolean;
function Section(Path: string): TutlMCFSection;
procedure DeleteSection(Name: string);

function ValueExists(Name: string): boolean;
function GetInt(Name: string; Default: Int64 = 0): Int64; overload;
function GetFloat(Name: string; Default: Double = 0): Double; overload;
function GetString(Name: string; Default: AnsiString = ''): AnsiString; overload;
function GetStringW(Name: string; Default: UnicodeString = ''): UnicodeString; overload;
function GetBool(Name: string; Default: Boolean = false): Boolean; overload;
procedure SetInt(Name: string; Value: Int64); overload;
procedure SetFloat(Name: string; Value: Double); overload;
procedure SetString(Name: string; Value: WideString); overload;
procedure SetString(Name: string; Value: AnsiString); overload;
procedure SetBool(Name: string; Value: Boolean); overload;
procedure UnsetValue(Name: string);
end;

{ TutlMCFFile }

TutlMCFFile = class(TutlMCFSection)
private
fLineEndMode: TutlMCFLineEndMarkerMode;
public
constructor Create(Data: TStream; LineEndMode: TutlMCFLineEndMarkerMode = leAcceptNoWrite);
procedure LoadFromStream(Stream: TStream);
procedure SaveToStream(Stream: TStream);
end;

implementation

uses Variants, StrUtils;

const
sComment = '#';
sSectionEnd = 'end';
sSectionMarker = ':';
sSectionPathDelim = '.';
sLineEndMarker = ';';
sValueDelim = '=';
sValueQuote = '''';
sValueDecimal = '.';
sIndentOnSave = ' ';
sNameValidChars = [' ' .. #$7F] - [sValueDelim];
sWhitespaceChars = [#0 .. ' '];

type
StoredValue = Variant;

{ TutlMCFValue }

TutlMCFValue = class
private
Format: TFormatSettings;
FValue: StoredValue;
procedure SetValue(const Value: StoredValue);
protected
function CheckSpecialChars(Data: WideString): boolean;
procedure LoadData(Data: string);
function SaveData: string;
class function Escape(Value: WideString): AnsiString;
class function Unescape(Value: AnsiString): WideString;
public
constructor Create(Val: StoredValue);
property Value: StoredValue read FValue write SetValue;
end;

{ TkcfValue }

constructor TutlMCFValue.Create(Val: StoredValue);
begin
inherited Create;
SetValue(Val);
Format.DecimalSeparator:= sValueDecimal;
end;

procedure TutlMCFValue.SetValue(const Value: StoredValue);
begin
FValue:= Value;
end;

function TutlMCFValue.CheckSpecialChars(Data: WideString): boolean;
var
i: Integer;
begin
result := false;
for i:= 1 to Length(Data) do
if Data[i] in [sSectionMarker, sValueQuote, sValueDelim, sLineEndMarker, ' '] then
exit;
result := true;
end;

procedure TutlMCFValue.LoadData(Data: string);
var
b: boolean;
i: int64;
d: double;
p: PChar;
begin
if TryStrToInt64(Data, i) then
Value:= i
else if TryStrToFloat(Data, d, Format) then
Value:= d
else if TryStrToBool(Data, b) then
Value:= b
else begin
p:= PChar(Data);
if p^ = sValueQuote then
Data := AnsiExtractQuotedStr(p, sValueQuote);
Value:= Unescape(Trim(Data));
end;
end;

function TutlMCFValue.SaveData: string;
begin
if VarIsType(FValue, varBoolean) then
Result:= BoolToStr(FValue, false)
else if VarIsType(FValue, varInt64) then
Result:= IntToStr(FValue)
else if VarIsType(FValue, varDouble) then
Result:= FloatToStr(Double(FValue), Format)
else begin
Result:= Escape(FValue);
if not CheckSpecialChars(WideString(Result)) then
Result:= AnsiQuotedStr(Result, sValueQuote);
end;
end;

class function TutlMCFValue.Escape(Value: WideString): AnsiString;
var
i: integer;
wc: WideChar;
begin
Result:= '';
for i:= 1 to length(Value) do begin
wc:= Value[i];
case Ord(wc) of
Ord('\'),
$007F..$FFFF: Result:= Result + '\'+IntToHex(ord(wc),4);
else
Result:= Result + AnsiChar(wc);
end;
end;
end;

class function TutlMCFValue.Unescape(Value: AnsiString): WideString;
var
i: integer;
c: Char;
begin
Result:= '';
i:= 1;
while i <= length(value) do begin
c:= Value[i];
if c='\' then begin
Result:= Result + WideChar(StrToInt('$'+Copy(Value,i+1,4)));
inc(i, 4);
end else
Result:= Result + WideChar(c);
inc(i);
end;
end;

{ TutlMCFSection.TSectionEnumerator }

function TutlMCFSection.TSectionEnumerator.GetCurrent: TutlMCFSection;
begin
result := TutlMCFSection(fList.Objects[fPosition]);
end;

function TutlMCFSection.TSectionEnumerator.MoveNext: Boolean;
begin
inc(fPosition);
result := (fPosition < fList.Count);
end;

constructor TutlMCFSection.TSectionEnumerator.Create(const aList: TStringList);
begin
inherited Create;
fList := aList;
fPosition := -1;
end;

{ TkcfCompound }

constructor TutlMCFSection.Create;
begin
inherited;
FSections:= TStringList.Create;
FSections.CaseSensitive:= false;
FSections.Sorted:= true;
FSections.Duplicates:= dupError;
FValues:= TStringList.Create;
FValues.CaseSensitive:= false;
FValues.Sorted:= true;
FValues.Duplicates:= dupError;
end;

destructor TutlMCFSection.Destroy;
begin
ClearSections;
ClearValues;
FreeAndNil(FSections);
FreeAndNil(FValues);
inherited;
end;

function TutlMCFSection.GetEnumerator: TSectionEnumerator;
begin
result := TSectionEnumerator.Create(FSections);
end;

function TutlMCFSection.GetSectionCount: integer;
begin
Result:= FSections.Count;
end;

function TutlMCFSection.GetSection(aPath: String): TutlMCFSection;
begin
result := Section(aPath);
end;

function TutlMCFSection.GetSectionByIndex(aIndex: Integer): TutlMCFSection;
begin
result := (FSections.Objects[aIndex] as TutlMCFSection);
end;

function TutlMCFSection.GetSectionName(Index: integer): string;
begin
Result:= FSections[Index];
end;

function TutlMCFSection.GetValueCount: integer;
begin
Result:= FValues.Count;
end;

function TutlMCFSection.GetValueName(Index: integer): string;
begin
Result:= FValues[Index];
end;

procedure TutlMCFSection.ClearSections;
var
i: integer;
begin
for i:= FSections.Count - 1 downto 0 do
FSections.Objects[i].Free;
FSections.Clear;
end;

procedure TutlMCFSection.ClearValues;
var
i: integer;
begin
for i:= FValues.Count - 1 downto 0 do
FValues.Objects[i].Free;
FValues.Clear;
end;

procedure TutlMCFSection.SplitPath(const Path: String; out First, Rest: String);
begin
First:= Copy(Path, 1, Pos(sSectionPathDelim, Path)-1);
if First='' then begin
First:= Path;
Rest:= '';
end else begin
Rest:= Copy(Path, Length(First)+2, MaxInt);
end;
end;

function TutlMCFSection.SectionExists(Path: string): boolean;
var
f,r: String;
i: integer;
begin
SplitPath(Path, f, r);
i:= FSections.IndexOf(f);
Result:= (i >= 0) and ((r='') or (TutlMCFSection(FSections.Objects[i]).SectionExists(r)));
end;

function TutlMCFSection.Section(Path: string): TutlMCFSection;
var
f,r: String;
i: integer;
begin
SplitPath(Path, f, r);
i:= FSections.IndexOf(f);
if r <> '' then begin
if (i >= 0) then
Result:= TutlMCFSection(FSections.Objects[i]).Section(r)
else begin
result := TutlMCFSection.Create;
fSections.AddObject(f, result);
result := result.Section(r);
end;
end else begin
if i >= 0 then
Result:= TutlMCFSection(FSections.Objects[i])
else begin
Result:= TutlMCFSection.Create;
FSections.AddObject(f, Result);
end;
end;
end;

procedure TutlMCFSection.DeleteSection(Name: string);
var
i: integer;
begin
i:= FSections.IndexOf(Name);
if i >= 0 then begin
FSections.Objects[i].Free;
FSections.Delete(i);
end;
end;

function TutlMCFSection.ValueExists(Name: string): boolean;
begin
Result:= FValues.IndexOf(Name) >= 0;
end;

function TutlMCFSection.GetInt(Name: string; Default: Int64): Int64;
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
Result:= Default
else
Result:= TutlMCFValue(FValues.Objects[i]).Value;
end;

function TutlMCFSection.GetFloat(Name: string; Default: Double): Double;
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
Result:= Default
else
Result:= TutlMCFValue(FValues.Objects[i]).Value;
end;

function TutlMCFSection.GetStringW(Name: string; Default: UnicodeString): UnicodeString;
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
Result:= Default
else
Result:= TutlMCFValue(FValues.Objects[i]).Value;
end;

function TutlMCFSection.GetString(Name: string; Default: AnsiString): AnsiString;
begin
Result := AnsiString(GetStringW(Name, UnicodeString(Default)));
end;

function TutlMCFSection.GetBool(Name: string; Default: Boolean): Boolean;
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
Result:= Default
else
Result:= TutlMCFValue(FValues.Objects[i]).Value;
end;


procedure TutlMCFSection.AddValueChecked(Name: String; Val: TObject);
var
i: integer;
begin
if (Length(Name) < 1) or
(Name[1] in sWhitespaceChars) or
(Name[Length(Name)] in sWhitespaceChars) then
raise EConfigException.CreateFmt('Invalid Value Name: "%s"',[Name]);

for i:= 1 to Length(Name) do
if not (Name[i] in sNameValidChars) then
raise EConfigException.CreateFmt('Invalid Value Name: "%s"',[Name]);
FValues.AddObject(Name, Val);
end;

procedure TutlMCFSection.SetInt(Name: string; Value: Int64);
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
AddValueChecked(Name, TutlMCFValue.Create(Value))
else
TutlMCFValue(FValues.Objects[i]).Value:= Value;
end;

procedure TutlMCFSection.SetFloat(Name: string; Value: Double);
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
AddValueChecked(Name, TutlMCFValue.Create(Value))
else
TutlMCFValue(FValues.Objects[i]).Value:= Value;
end;

procedure TutlMCFSection.SetString(Name: string; Value: WideString);
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
AddValueChecked(Name, TutlMCFValue.Create(Value))
else
TutlMCFValue(FValues.Objects[i]).Value:= Value;
end;

procedure TutlMCFSection.SetString(Name: string; Value: AnsiString);
begin
SetString(Name, WideString(Value));
end;

procedure TutlMCFSection.SetBool(Name: string; Value: Boolean);
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i < 0 then
AddValueChecked(Name, TutlMCFValue.Create(Value))
else
TutlMCFValue(FValues.Objects[i]).Value:= Value;
end;

procedure TutlMCFSection.UnsetValue(Name: string);
var
i: integer;
begin
i:= FValues.IndexOf(Name);
if i >= 0 then begin
FValues.Objects[i].Free;
FValues.Delete(i);
end;
end;


procedure TutlMCFSection.LoadData(Data: TStream; LineEnds: TutlMCFLineEndMarkerMode; Depth: Integer);
var
reader: TutlStreamReader;
l, sn, vn, vs: string;
se: TutlMCFSection;
va: TutlMCFValue;
begin
reader:= TutlStreamReader.Create(Data);
try
repeat
l:= reader.ReadLine;
l:= trim(l);
if (l = '') or AnsiStartsStr(sComment, l) then
continue;
if ((LineEnds in [leNone, leAcceptNoWrite]) and (l = sSectionEnd)) or
((LineEnds in [leAcceptNoWrite, leAlways]) and (l = sSectionEnd+sLineEndMarker)) then begin
if Depth > 0 then
exit
else
raise EConfigException.Create('Encountered Section End where none was expected.');
end;
if AnsiEndsStr(sSectionMarker, l) then begin
sn:= trim(Copy(l, 1, length(l) - length(sSectionMarker)));
if SectionExists(sn) then
raise EConfigException.Create('Redeclared Section: '+sn);
if Pos(sSectionPathDelim,sn) > 0 then
raise EConfigException.Create('Invalid Section Name: '+sn);
se:= TutlMCFSection.Create;
try
se.LoadData(Data, LineEnds, Depth + 1);
FSections.AddObject(sn, se);
except
FreeAndNil(se);
end;
end else if (Pos(sValueDelim, l) > 0) then begin
if (LineEnds in [leAcceptNoWrite, leAlways]) and AnsiEndsStr(sLineEndMarker, l) then
Delete(l, length(l), 1);
vn:= trim(Copy(l, 1, Pos(sValueDelim, l) - 1));
vs:= trim(Copy(l, Pos(sValueDelim, l) + 1, Maxint));
if ValueExists(vn) then
raise EConfigException.Create('Redeclared Value: '+vn);
va:= TutlMCFValue.Create('');
try
va.LoadData(vs);
AddValueChecked(vn, va);
except
FreeAndNil(va);
end;
end else
raise EConfigException.Create('Cannot Parse Line: '+l);
until reader.IsEOF;
if Depth > 0 then
raise EConfigException.Create('Expected Section End, but reached stream end.');
Depth:= Depth - 1;
finally
FreeAndNil(reader);
end;
end;

procedure TutlMCFSection.SaveData(Stream: TStream; Indent: string;
LineEnds: TutlMCFLineEndMarkerMode);
var
writer: TutlStreamWriter;
i: integer;
ele, s: AnsiString;
begin
if LineEnds in [leAlways] then
ele:= sLineEndMarker
else
ele:= '';
writer:= TutlStreamWriter.Create(Stream);
try
for i:= 0 to FValues.Count - 1 do begin
s:= Indent + FValues[i] + ' ' + sValueDelim + ' ' + TutlMCFValue(FValues.Objects[i]).SaveData + ele;
writer.WriteLine(s);
end;

for i:= 0 to FSections.Count - 1 do begin
s:= Indent + FSections[i] + sSectionMarker;
writer.WriteLine(s);
TutlMCFSection(FSections.Objects[i]).SaveData(Stream, Indent + sIndentOnSave, LineEnds);
s:= Indent + sSectionEnd + ele;
writer.WriteLine(s);
end;
finally
FreeAndNil(writer);
end;
end;

{ TutlMCFFile }

constructor TutlMCFFile.Create(Data: TStream; LineEndMode: TutlMCFLineEndMarkerMode);
begin
inherited Create;
fLineEndMode:= LineEndMode;
if Assigned(Data) then
LoadFromStream(Data);
end;

procedure TutlMCFFile.LoadFromStream(Stream: TStream);
begin
ClearSections;
ClearValues;
LoadData(Stream, fLineEndMode, 0);
end;

procedure TutlMCFFile.SaveToStream(Stream: TStream);
begin
SaveData(Stream, '', fLineEndMode);
end;

end.


+ 100
- 0
uutlMcfHelper.pas View File

@@ -0,0 +1,100 @@
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.


+ 453
- 0
uutlMessageThread.pas View File

@@ -0,0 +1,453 @@
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+}
{$DEFINE USE_SPINLOCK}

interface

uses
Classes, SysUtils, syncobjs, uutlMessages;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlMessageThread = class(TThread, IUnknown)
protected type
TSingleLinkedListItem = class
msg: TutlMessage;
next: TSingleLinkedListItem;
end;
private
{$IFDEF USE_SPINLOCK}
fLocked: Cardinal;
{$ELSE}
fCritSec: TCriticalSection;
{$ENDIF}
fMsgEvent: TEvent;
procedure PushMsg(aMessage: TutlMessage);
function PullMsg: TutlMessage;
procedure ClearMessages;
protected
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
fFirst: TSingleLinkedListItem;
fLast: TSingleLinkedListItem;

procedure LockMessages;
procedure UnlockMessages;
function WaitForMessages(const aWaitTime: Cardinal = INFINITE): 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); 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;

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, uutlGenerics, uutlExceptions;

type
TutlMessageThreadMap = class(specialize TutlMap<TThreadID, TutlMessageThread>)
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;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//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/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlMessageThread.PushMsg(aMessage: TutlMessage);
begin
LockMessages;
try
if not Assigned(fLast) then
exit;
fLast.next := TSingleLinkedListItem.Create;
fLast.next.msg := aMessage;
fLast := fLast.next;
fMsgEvent.SetEvent;
finally
UnlockMessages;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlMessageThread.PullMsg: TutlMessage;
var
old: TSingleLinkedListItem;
begin
result := nil;
LockMessages;
try
if Assigned(fFirst) and Assigned(fFirst.next) then begin
old := fFirst;
fFirst := old.next;
result := fFirst.msg;
old.Free;
if not Assigned(fFirst.next) then
fMsgEvent.ResetEvent;
end;
finally
UnlockMessages;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlMessageThread.ClearMessages;
var
m: TutlMessage;
begin
repeat
m := PullMsg;
if Assigned(m) then
m.Free;
until not Assigned(m);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlMessageThread.LockMessages;
{$IFDEF USE_SPINLOCK}
var
lock: Cardinal;
begin
repeat
lock := InterLockedExchange(fLocked, 1);
until (lock = 0);
{$ELSE}
begin
fCritSec.Enter;
{$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlMessageThread.UnlockMessages;
begin
{$IFDEF USE_SPINLOCK}
InterLockedExchange(fLocked, 0);
{$ELSE}
fCritSec.Leave;
{$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlMessageThread.WaitForMessages(const aWaitTime: Cardinal): Boolean;
var
wr: TWaitResult;
begin
wr := fMsgEvent.WaitFor(aWaitTime);
result := (wr = wrSignaled);
if not result and (wr <> wrTimeout) then
raise EWait.Create('Error while waiting for messages', wr);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlMessageThread.ProcessMessages: Boolean;
var
m: TutlMessage;
empty: Boolean;
begin
empty := false;
result := false;
repeat
try
m := PullMsg; //nur beim holen einer Message Locken sonst evtl. DeadLock
if Assigned(m) then begin
result := true;
try
ProcessMessage(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(ID: %d; wParam: %s; lParam: %s): %s - %s', [
m.ClassName,
m.ID,
IntToHex(m.wParam, SizeOf(m.wParam) div 4),
IntToHex(m.wParam, SizeOf(m.wParam) div 4),
e.ClassName,
e.Message]);
end;
end;
until empty;
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);
var
m: TutlMessage;
begin
m := TutlMessage.Create(aID, aWParam, aLParam);
PushMsg(m);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlMessageThread.PostMessage(const aID: Cardinal; const aArgs: TObject);
var
m: TutlMessage;
begin
m := TutlMessage.Create(aID, aArgs);
PushMsg(m);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlMessageThread.PostMessage(const aMsg: TutlMessage);
begin
PushMsg(aMsg);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlMessageThread.SendMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt; const aWaitTime: Cardinal): TWaitResult;
var
m: TutlSynchronousMessage;
begin
m := TutlSynchronousMessage.Create(aID, aWParam, aLParam);
result := SendMessage(m, aWaitTime);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlMessageThread.SendMessage(const aID: Cardinal; const aArgs: TObject; const aWaitTime: Cardinal): TWaitResult;
var
m: TutlSynchronousMessage;
begin
m := TutlSynchronousMessage.Create(aID, aArgs);
result := SendMessage(m, aWaitTime);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlMessageThread.SendMessage(const aMsg: TutlSynchronousMessage; const aWaitTime: Cardinal): TWaitResult;
begin
PushMsg(aMsg);
result := aMsg.WaitFor(aWaitTime);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlMessageThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt);
begin
inherited Create(CreateSuspended, StackSize);
fMsgEvent := TEvent.Create(nil, true, false, '');
fFirst := TSingleLinkedListItem.Create;
fLast := fFirst;
Threads.Lock;
try
Threads.Add(ThreadID, self);
finally
Threads.Release;
end;
{$IFNDEF USE_SPINLOCK}
fCritSec := TCriticalSection.Create;
{$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlMessageThread.Destroy;
begin
Threads.Lock;
try
Threads.Delete(ThreadID);
finally
Threads.Release;
end;
ClearMessages;
FreeAndNil(fFirst);
fLast := nil;
{$IFNDEF USE_SPINLOCK}
FreeAndNil(fCritSec);
{$ENDIF}
FreeAndNil(fMsgEvent);
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.


+ 201
- 0
uutlMessages.pas View File

@@ -0,0 +1,201 @@
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)
private
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;
fFreeOnFinish: Boolean;
fLock: Integer;
procedure Lock;
procedure Unlock;
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.Lock;
begin
repeat until (InterLockedExchange(fLock, 1) = 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlSynchronousMessage.Unlock;
begin
InterLockedExchange(fLock, 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlSynchronousMessage.Finish;
begin
fEvent.SetEvent;
Lock;
if fFreeOnFinish then
Free
else
Unlock;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlSynchronousMessage.WaitFor(const aTimeout: Cardinal): TWaitResult;
begin
Lock;
try
result := fEvent.WaitFor(aTimeout);
fFreeOnFinish := (result <> wrSignaled);
finally
Unlock;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlSynchronousMessage.Create(const aID: Cardinal; const aWParam, aLParam: PtrInt);
begin
inherited Create(aID, aWParam, aLParam);
fEvent := TEvent.Create(nil, true, false, '');
fFreeOnFinish := false;
fLock := 0;
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, '');
fFreeOnFinish := false;
fLock := 0;
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.


+ 93
- 0
uutlPlatform.pas View File

@@ -0,0 +1,93 @@
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.


+ 63
- 0
uutlProfilerBinary.inc View File

@@ -0,0 +1,63 @@
{$ERROR Do not use, untested/WIP/useless!}
{$ifdef __HEAD}
TProfileBinary = class(TProfileDataFile)
private type
TEnterRec = packed record
Thread: TThreadID;
When: Int64;
Line: Integer;
Func, Src: ShortString;
end;
TLeaveRec = packed record
Thread: TThreadID;
When: Int64;
end;
private
fDF: TMemoryStream;
public
constructor Create(const aFileName: string);
destructor Destroy; override;
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); override;
procedure WriteLeave(Thread: TThreadID; When: Int64); override;
end;

{$ELSE}

{ TProfileBinary }

constructor TProfileBinary.Create(const aFileName: string);
begin
inherited;
fDF:= TMemoryStream.Create;
fDF.SetSize(50000000);
end;

destructor TProfileBinary.Destroy;
begin
FreeAndNil(fDF);
inherited;
end;

procedure TProfileBinary.WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer);
var
t: TEnterRec;
begin
t.When:= When;
t.Thread:= Thread;
t.Func:= Func;
t.Src:= Src;
t.Line:= Line;
fDF.Write(t, sizeof(t));
end;

procedure TProfileBinary.WriteLeave(Thread: TThreadID; When: Int64);
var
t: TLeaveRec;
begin
t.When:= When;
t.Thread:= Thread;
fDF.Write(t, sizeof(t));
end;
{$ENDIF}



+ 49
- 0
uutlProfilerPlainText.inc View File

@@ -0,0 +1,49 @@
{$ifdef __HEAD}
TProfilePlainText = class(TProfileDataFile)
private
fDF: Textfile;
fBuffer: array[0..16*1024-1] of byte;
public
constructor Create(const aFileName: string);
destructor Destroy; override;
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); override;
procedure WriteLeave(Thread: TThreadID; When: Int64); override;
end;

{$ELSE}

{ TProfilePlainText }

constructor TProfilePlainText.Create(const aFileName: string);
begin
inherited;
AssignFile(fDF, aFileName);
SetTextBuf(fDF, {%H-}fBuffer[0], sizeof(fBuffer));
Rewrite(fDF);
end;

destructor TProfilePlainText.Destroy;
begin
CloseFile(fDF);
inherited;
end;

procedure TProfilePlainText.WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer);
var
l: string;
begin
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';'+Src+ ';'+IntToStr(Line)+';'+Func;
WriteLn(fDF, l);
end;

procedure TProfilePlainText.WriteLeave(Thread: TThreadID; When: Int64);
var
l: string;
begin
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';';
WriteLn(fDF, l);
end;

{$ENDIF}



+ 46
- 0
uutlProfilerPlainTextMMap.inc View File

@@ -0,0 +1,46 @@
{$ifdef __HEAD}
TProfilePlainTextMMap = class(TProfileDataFile)
private
fDF: TFastFileStream;
public
constructor Create(const aFileName: string);
destructor Destroy; override;
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); override;
procedure WriteLeave(Thread: TThreadID; When: Int64); override;
end;

{$ELSE}

{ TProfilePlainTextMMap }

constructor TProfilePlainTextMMap.Create(const aFileName: string);
begin
inherited;
fDF:= TFastFileStream.Create(aFileName, fmCreate, fmShareExclusive);
end;

destructor TProfilePlainTextMMap.Destroy;
begin
FreeAndNil(fDF);
inherited;
end;

procedure TProfilePlainTextMMap.WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer);
var
l: string;
begin
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';'+Src+ ';'+IntToStr(Line)+';'+Func + #13#10;
fDF.Write(l[1], Length(l));
end;

procedure TProfilePlainTextMMap.WriteLeave(Thread: TThreadID; When: Int64);
var
l: string;
begin
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';'#13#10;
fDF.Write(l[1], Length(l));
end;

{$ENDIF}



+ 71
- 0
uutlSetHelper.inc View File

@@ -0,0 +1,71 @@
{$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;
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;

{$ENDIF}
{$undef __SET_HELPER}
{$undef __SET_TYPE}
{$undef __ENUM_TYPE}
{$undef __ENUM_HELPER}

+ 371
- 0
uutlSettings.pas View File

@@ -0,0 +1,371 @@
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<TutlSettingsUpdateEventCntr>)
public
function EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean;
end;

TutlSettings = class
private type
TutlSettingsUpdateEventList = specialize TutlCustomList<TutlSettingsUpdateEventCntr>;
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<String, TBlockData>;
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, uvfsManager, 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;

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;

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;

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.


+ 673
- 0
uutlStreamHelper.pas View File

@@ -0,0 +1,673 @@
unit uutlStreamHelper;

{ Package: Utils
Prefix: utl - UTiLs
Beschreibung: diese Unit enthält Klassen zum lesen und schreiben von Werten in einen Stream
TutlStreamReader - Wrapper für beliebige Streams, handelt Datentypen
TutlStreamWriter - Wrapper für beliebige Streams, handelt Datentypen }

{$mode objfpc}{$H+}

interface

uses
Classes, Contnrs, syncobjs;

type
TutlFourCC = string[4];

{ TutlStreamUtility }

TutlStreamUtility = class
private
FStream: TStream;
FOwnsStream: boolean;
FPositions: TStack;
protected
public
constructor Create(BaseStream: TStream; OwnsStream: Boolean=false);
destructor Destroy; override;
property Stream: TStream read FStream;
procedure Push;
procedure Pop;
procedure Drop;
end;

{ TutlStreamReader }

TutlStreamReader = class(TutlStreamUtility)
protected
function ReadBuffer(Var Buffer; Size: int64): int64;
public
function ReadFourCC: TutlFourCC;
function CheckFourCC(Correct: TutlFourCC): boolean;
function ReadByte: Byte;
function ReadWord: Word;
function ReadCardinal: Cardinal;
function ReadInteger: Integer;
function ReadInt64: Int64;
function ReadSingle: Single;
function ReadDouble: Double;
function ReadAnsiString: AnsiString;
function ReadLine: AnsiString;
function IsEOF: boolean;
end;

{ TutlStreamWriter }

TutlStreamWriter = class(TutlStreamUtility)
protected
procedure WriteBuffer(var Data; Size: int64);
public
procedure WriteFourCC(FCC: TutlFourCC);
procedure WriteByte(A: Byte);
procedure WriteWord(A: Word);
procedure WriteCardinal(A: Cardinal);
procedure WriteInteger(A: Integer);
procedure WriteInt64(A: Int64);
procedure WriteSingle(A: Single);
procedure WriteDouble(A: Double);
procedure WriteAnsiString(A: AnsiString);
procedure WriteAnsiBytes(A: AnsiString);
procedure WriteLine(A: AnsiString);
end;

{ TutlReadBufferStream }

TutlReadBufferStream = class(TStream)
private
FBaseStream: TStream;
FBuffer: Pointer;
FBufferValid: boolean;
FBufferStart, FBufferLen, FBufferAvail: Int64;
FPosition: int64;
protected
function GetSize: Int64; override;
procedure SetSize(const NewSize: Int64); override;
public
constructor Create(const BaseStream: TStream; const BufferSize: Cardinal);
destructor Destroy; override;
function Read(var Buffer; Count: Integer): Integer; override;
function Write(const Buffer; Count: Integer): Integer; override;
function Seek(Offset: Integer; Origin: Word): Integer; override;
end;

{ TutlFIFOStream }

TutlFIFOStream = class(TStream)
private const MAX_PAGE_SIZE = 4096;
private type
PPage = ^TPage;
TPage = record
Next: PPage;
Data: packed array[0..MAX_PAGE_SIZE-1] of byte;
end;
private
fLockFree: boolean;
fPageFirst, fPageLast: PPage;
fReadPtr, fWritePtr: Cardinal;
fTotalSize: Int64;
fDataLock: TCriticalSection;
protected
function GetSize: Int64; override;
public
constructor Create(const aLockFree: boolean = false);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Reserve(var Buffer; Count: Longint): Longint;
function Discard(Count: Longint): Longint;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const {%H-}Offset: Int64; {%H-}Origin: TSeekOrigin): Int64; override; overload;
procedure BeginOperation;
procedure EndOperation;
property LockFree: boolean read fLockFree;
end;

TutlBase64Decoder = class(TStringStream)
public const
CODE64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
PADDING_CHARACTER = '=';
protected
public
function Read(var Buffer; Count: Longint): Longint; override;
function Decode(const aOutput: TStream): boolean;
constructor Create;
end;

implementation

uses SysUtils,RtlConsts, uutlExceptions;

type
TPositionData = class
Position: Int64;
constructor Create(Pos: Int64);
end;

constructor TPositionData.Create(Pos: Int64);
begin
inherited Create;
Position:= Pos;
end;

{ TutlStreamUtility }

constructor TutlStreamUtility.Create(BaseStream: TStream; OwnsStream: Boolean);
begin
inherited Create;
FStream:= BaseStream;
FOwnsStream:= OwnsStream;
FPositions:= TStack.Create;
end;

destructor TutlStreamUtility.Destroy;
begin
if FOwnsStream then
FreeAndNil(FStream)
else
FStream:= nil;
while FPositions.AtLeast(1) do
TPositionData(FPositions.Pop).Free;
FreeAndNil(FPositions);
inherited;
end;

procedure TutlStreamUtility.Pop;
var
p: TPositionData;
begin
p:= TPositionData(FPositions.Pop);
FStream.Position:= p.Position;
p.Free;
end;

procedure TutlStreamUtility.Drop;
var
p: TPositionData;
begin
p:= TPositionData(FPositions.Pop);
if Assigned(p) then
p.Free;
end;

procedure TutlStreamUtility.Push;
begin
FPositions.Push(TPositionData.Create(FStream.Position));
end;

{ TutlStreamReader }

function TutlStreamReader.ReadBuffer(var Buffer; Size: int64): int64;
begin
if (FStream.Position + Size > FStream.Size) then
raise EInvalidOperation.Create('stream is to small');
Result:= FStream.Read(Buffer, Size);
end;

function TutlStreamReader.ReadFourCC: TutlFourCC;
begin
SetLength(Result, 4);
ReadBuffer(Result[1], 4);
end;

function TutlStreamReader.CheckFourCC(Correct: TutlFourCC): boolean;
begin
Result:= ReadFourCC=Correct;
end;

function TutlStreamReader.ReadByte: Byte;
begin
ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadWord: Word;
begin
ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadCardinal: Cardinal;
begin
ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadInteger: Integer;
begin
ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadInt64: Int64;
begin
ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadSingle: Single;
begin
ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadDouble: Double;
begin
ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadAnsiString: AnsiString;
begin
SetLength(Result, ReadCardinal);
ReadBuffer(Result[1], Length(Result));
end;

function TutlStreamReader.ReadLine: AnsiString;
const
READ_LENGTH = 80;
var
rp, rl: integer;
cp: PAnsiChar;
bpos: Int64;
r: integer;
EOF: Boolean;

procedure ReadSome;
begin
SetLength(Result, rl + READ_LENGTH);
r:= FStream.Read(Result[rl + 1], READ_LENGTH);
inc(rl, r);
EOF:= r <> READ_LENGTH;
cp:= @Result[rp];
end;

begin
Result:= '';
rl:= 0;
bpos:= FStream.Position;
repeat
rp:= rl + 1;
ReadSome;
while rp <= rl do begin
if cp^ in [#10, #13] then begin
inc(bpos, rp);
// never a second char after #10
if cp^ = #13 then begin
if (rp = rl) and not EOF then begin
ReadSome;
end;
if (rp <= rl) then begin
inc(cp);
if cp^ = #10 then
inc(bpos);
end;
end;
FStream.Position:= bpos;
SetLength(Result, rp-1);
Exit;
end;
inc(cp);
inc(rp);
end;
until EOF;
SetLength(Result, rl);
end;

function TutlStreamReader.IsEOF: boolean;
begin
Result:= FStream.Position = FStream.Size;
end;


{ TutlStreamWriter }

procedure TutlStreamWriter.WriteBuffer(var Data; Size: int64);
begin
FStream.Write(Data, Size);
end;

procedure TutlStreamWriter.WriteFourCC(FCC: TutlFourCC);
begin
WriteBuffer(FCC[1], 4);
end;

procedure TutlStreamWriter.WriteByte(A: Byte);
begin
WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteWord(A: Word);
begin
WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteCardinal(A: Cardinal);
begin
WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteInteger(A: Integer);
begin
WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteInt64(A: Int64);
begin
WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteSingle(A: Single);
begin
WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteDouble(A: Double);
begin
WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteAnsiString(A: AnsiString);
begin
WriteCardinal(Length(A));
WriteBuffer(A[1], Length(a));
end;

procedure TutlStreamWriter.WriteAnsiBytes(A: AnsiString);
begin
WriteBuffer(A[1], Length(A));
end;

procedure TutlStreamWriter.WriteLine(A: AnsiString);
begin
WriteAnsiBytes(A + sLineBreak);
end;

{ TutlReadBufferStream }

constructor TutlReadBufferStream.Create(const BaseStream: TStream; const BufferSize: Cardinal);
begin
inherited Create;
FBaseStream:= BaseStream;
FBufferLen:= BufferSize;
FBuffer:= GetMemory(FBufferLen);
FPosition:= 0;
end;

destructor TutlReadBufferStream.Destroy;
begin
FBufferValid:= false;
//FBaseStream.Free;
FreeMemory(FBuffer);
inherited;
end;

function TutlReadBufferStream.Seek(Offset: Integer; Origin: Word): Integer;
begin
case Origin of
soFromBeginning: FPosition := Offset;
soFromCurrent: Inc(FPosition, Offset);
soFromEnd: FPosition := Size + Offset;
end;
Result := FPosition;
end;

function TutlReadBufferStream.GetSize: Int64;
begin
Result:= FBaseStream.Size;
end;

procedure TutlReadBufferStream.SetSize(const NewSize: Int64);
begin
FBaseStream.Size:= NewSize;
end;

function TutlReadBufferStream.Write(const Buffer; Count: Integer): Integer;
begin
FBufferValid:= false;
FBaseStream.Position:= FPosition;
Result:= FBaseStream.Write(Buffer, Count);
FPosition:= FBaseStream.Position;
end;

function TutlReadBufferStream.Read(var Buffer; Count: Integer): Integer;
var
rp, br, c: Int64;
bp: Pointer;
begin
br:= 0;
bp:= @Buffer;
while (br < Count) and (FPosition<Size) do begin
// Welches Buffer-Segment wird gesucht?
rp:= (FPosition div FBufferLen) * FBufferLen;
// ist das das aktuelle?
if not FBufferValid or (FBufferStart <> rp) then begin
// Segment holen
FBaseStream.Position:= rp;
FBufferAvail:= FBaseStream.Read(FBuffer^, FBufferLen);
FBufferStart:= rp;
FBufferValid:= true;
end;

// Wie viel Daten daraus brauchen wir bzw. können wir kriegen?
c:= Count - br;
if c > FBufferAvail - (FPosition-FBufferStart) then
c:= FBufferAvail - (FPosition-FBufferStart);

// das rausholen und buffer weiterschieben
{$IFDEF FPC}
// FPC: kein Cast, direkt mit Pointer in richtiger Größe rechnen
Move(Pointer(FBuffer + (FPosition-FBufferStart))^, bp^, c);
Inc(Bp, c);
{$ELSE}
// Delphi ist eh nur i386, also fix 32bit
Move(Pointer(Cardinal(FBuffer) + (FPosition-FBufferStart))^, bp^, c);
Inc(Cardinal(Bp), c);
{$ENDIF}
Inc(br, c);
Inc(FPosition, c);
end;
Result:= br;
end;

{ TutlFIFOStream }

constructor TutlFIFOStream.Create(const aLockFree: boolean);
begin
inherited Create;
fDataLock:= TCriticalSection.Create;
fTotalSize:= 0;
New(fPageFirst);
fPageFirst^.Next:= nil;
fPageLast:= fPageFirst;
fReadPtr:= 0;
fWritePtr:= 0;
fLockFree:= aLockFree;
end;

destructor TutlFIFOStream.Destroy;
var
p,q: PPage;
begin
BeginOperation;
try
fTotalSize:= 0;
fReadPtr:= 0;
fWritePtr:= 0;
p:= fPageFirst;
while p<>nil do begin
q:= p;
p:= p^.Next;
Dispose(q);
end;
finally
EndOperation;
end;
FreeAndNil(fDataLock);
inherited Destroy;
end;

function TutlFIFOStream.GetSize: Int64;
begin
Result:= fTotalSize;
end;

function TutlFIFOStream.Read(var Buffer; Count: Longint): Longint;
begin
BeginOperation;
try
Result:= Reserve(Buffer, Count);
Discard(Result);
finally
EndOperation;
end;
end;

function TutlFIFOStream.Reserve(var Buffer; Count: Longint): Longint;
var
pbuf: PByteArray;
mx: LongInt;
rp: Int64;
p: PPage;
begin
BeginOperation;
try
pbuf:= @Buffer;
Result:= 0;
rp:= fReadPtr;
p:= fPageFirst;
while Count > 0 do begin
mx:= MAX_PAGE_SIZE - rp;
if mx > Count then mx:= Count;
if (p=fPageLast) and (mx > fWritePtr-rp) then mx:= fWritePtr-rp;
if mx=0 then exit;
Move(p^.Data[rp], pbuf^[Result], mx);
inc(rp, mx);
inc(Result, mx);
Dec(Count, mx);
if rp = MAX_PAGE_SIZE then begin
p:= p^.Next;
rp:= 0;
end;
end;
finally
EndOperation;
end;
end;

function TutlFIFOStream.Discard(Count: Longint): Longint;
var
mx: LongInt;
n: PPage;
begin
BeginOperation;
try
Result:= 0;
while Count > 0 do begin
mx:= MAX_PAGE_SIZE - fReadPtr;
if mx > Count then mx:= Count;
if (fPageFirst=fPageLast) and (mx > fWritePtr-fReadPtr) then mx:= fWritePtr-fReadPtr;
if mx=0 then exit;
inc(fReadPtr, mx);
inc(Result, mx);
dec(Count, mx);
dec(fTotalSize, mx);
if fReadPtr=MAX_PAGE_SIZE then begin
n:= fPageFirst^.Next;
if Assigned(n) then begin
Dispose(fPageFirst);
fPageFirst:= n;
fReadPtr:= 0;
end;// else kann nicht passieren, das wird mit (mx > fWritePtr-fReadPtr) und (mx=0) schon bedient
end;
end;
finally
EndOperation;
end;
end;

function TutlFIFOStream.Write(const Buffer; Count: Longint): Longint;
var
mx: LongInt;
pbuf: PByteArray;
begin
BeginOperation;
try
pbuf:= @Buffer;
Result:= 0;
while Count > 0 do begin
mx:= MAX_PAGE_SIZE - fWritePtr;
if mx > Count then mx:= Count;
Move(pbuf^[Result], fPageLast^.Data[fWritePtr], mx);
inc(fWritePtr, mx);
inc(fTotalSize, mx);
dec(Count, mx);
inc(Result, mx);

if fWritePtr = MAX_PAGE_SIZE then begin
New(fPageLast^.Next);
fPageLast:= fPageLast^.Next;
fPageLast^.Next:= nil;
fWritePtr:= 0;
end;
end;
finally
EndOperation;
end;
end;

function TutlFIFOStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result:= 0;
raise EStreamError.CreateFmt(SStreamInvalidSeek,[ClassName]);
end;

procedure TutlFIFOStream.BeginOperation;
begin
if not fLockFree then
fDataLock.Acquire;
end;

procedure TutlFIFOStream.EndOperation;
begin
if not fLockFree then
fDataLock.Release;
end;

{ TutlBase64Decoder }

function TutlBase64Decoder.{%H-}Read(var Buffer; Count: Longint): Longint;
begin
ReadNotImplemented;
end;

function TutlBase64Decoder.Decode(const aOutput: TStream): boolean;
var
a: Integer;
x: Integer;
b: Integer;
c: AnsiChar;
begin
Result:= false;
a := 0;
b := 0;
Position:= 0;
while inherited Read(c{%H-}, sizeof(c)) = sizeof(c) do begin
x := Pos(c, CODE64) - 1;
if (x >= 0) then begin
b := b * 64 + x;
a := a + 6;
if a >= 8 then begin
a := a - 8;
x := b shr a;
b := b mod (1 shl a);
aOutput.WriteByte(x);
end;
end else if c = PADDING_CHARACTER then
break
else
Exit;
end;
Result:= true;
end;

constructor TutlBase64Decoder.Create;
begin
inherited Create('');
end;


end.

+ 523
- 0
uutlSystemInfo.pas View File

@@ -0,0 +1,523 @@
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>;
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.


+ 84
- 0
uutlTiming.pas View File

@@ -0,0 +1,84 @@
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;

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;

initialization
PERF_FREQ := 0;
QueryPerformanceFrequency(PERF_FREQ);

{$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}

end.


Loading…
Cancel
Save