* initial commit

11 years ago · 98597e1a0d
--- a/BIN
+++ b/BIN
--- a/Tests/UtilsTests.lpi
+++ b/Tests/UtilsTests.lpi
@@ -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>
--- a/Tests/UtilsTests.lpr
+++ b/Tests/UtilsTests.lpr
@@ -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.

--- a/Tests/UtilsTests.lps
+++ b/Tests/UtilsTests.lps
@@ -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>
--- a/BIN
+++ b/BIN
--- a/Tests/uGenericsTests.pas
+++ b/Tests/uGenericsTests.pas
@@ -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.

--- a/uutlCommon.pas
+++ b/uutlCommon.pas
@@ -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.

--- a/uutlConsoleHelper.pas
+++ b/uutlConsoleHelper.pas
--- a/uutlConversion.pas
+++ b/uutlConversion.pas
@@ -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.

--- a/uutlEmbeddedProfiler.inc
+++ b/uutlEmbeddedProfiler.inc
@@ -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}

--- a/uutlEmbeddedProfiler.pas
+++ b/uutlEmbeddedProfiler.pas
@@ -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.

--- a/uutlEnumHelper.inc
+++ b/uutlEnumHelper.inc
@@ -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}
--- a/uutlEnumHelper.pas
+++ b/uutlEnumHelper.pas
@@ -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.
--- a/uutlEventManager.pas
+++ b/uutlEventManager.pas
@@ -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.

--- a/uutlExceptions.pas
+++ b/uutlExceptions.pas
@@ -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.

--- a/uutlGenerics.pas
+++ b/uutlGenerics.pas
--- a/uutlGraph.pas
+++ b/uutlGraph.pas
@@ -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.

--- a/uutlKeyCodes.pas
+++ b/uutlKeyCodes.pas
@@ -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.
--- a/uutlLocalization.pas
+++ b/uutlLocalization.pas
@@ -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.

--- a/uutlLogger.pas
+++ b/uutlLogger.pas
@@ -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.

--- a/uutlMCF.pas
+++ b/uutlMCF.pas
@@ -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.

--- a/uutlMcfHelper.pas
+++ b/uutlMcfHelper.pas
@@ -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.

--- a/uutlMessageThread.pas
+++ b/uutlMessageThread.pas
@@ -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.

--- a/uutlMessages.pas
+++ b/uutlMessages.pas
@@ -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.

--- a/uutlPlatform.pas
+++ b/uutlPlatform.pas
@@ -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.

--- a/uutlProfilerBinary.inc
+++ b/uutlProfilerBinary.inc
@@ -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}


--- a/uutlProfilerPlainText.inc
+++ b/uutlProfilerPlainText.inc
@@ -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}


--- a/uutlProfilerPlainTextMMap.inc
+++ b/uutlProfilerPlainTextMMap.inc
@@ -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}


--- a/uutlSetHelper.inc
+++ b/uutlSetHelper.inc
@@ -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}
--- a/uutlSettings.pas
+++ b/uutlSettings.pas
@@ -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.

--- a/uutlStreamHelper.pas
+++ b/uutlStreamHelper.pas
@@ -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.
--- a/uutlSystemInfo.pas
+++ b/uutlSystemInfo.pas
@@ -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.

--- a/uutlTiming.pas
+++ b/uutlTiming.pas
@@ -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.