| @@ -1,90 +0,0 @@ | |||||
| <?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> | |||||
| <CodeGeneration> | |||||
| <Optimizations> | |||||
| <OptimizationLevel Value="0"/> | |||||
| </Optimizations> | |||||
| </CodeGeneration> | |||||
| <Linking> | |||||
| <Debugging> | |||||
| <UseHeaptrc Value="True"/> | |||||
| <UseExternalDbgSyms 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> | |||||
| @@ -1,23 +0,0 @@ | |||||
| program UtilsTests; | |||||
| {$mode objfpc}{$H+} | |||||
| uses | |||||
| sysutils, Interfaces, Forms, GuiTestRunner, uGenericsTests; | |||||
| {$R *.res} | |||||
| var | |||||
| heaptrcFile: String; | |||||
| begin | |||||
| heaptrcFile := ChangeFileExt(Application.ExeName, '.heaptrc'); | |||||
| if (FileExists(heaptrcFile)) then | |||||
| DeleteFile(heaptrcFile); | |||||
| SetHeapTraceOutput(heaptrcFile); | |||||
| Application.Initialize; | |||||
| Application.CreateForm(TGuiTestRunner, TestRunner); | |||||
| Application.Run; | |||||
| end. | |||||
| @@ -1,110 +0,0 @@ | |||||
| <?xml version="1.0" encoding="UTF-8"?> | |||||
| <CONFIG> | |||||
| <ProjectSession> | |||||
| <PathDelim Value="\"/> | |||||
| <Version Value="9"/> | |||||
| <BuildModes Active="Default"/> | |||||
| <Units Count="7"> | |||||
| <Unit0> | |||||
| <Filename Value="UtilsTests.lpr"/> | |||||
| <IsPartOfProject Value="True"/> | |||||
| <EditorIndex Value="-1"/> | |||||
| <CursorPos Y="22"/> | |||||
| <UsageCount Value="30"/> | |||||
| </Unit0> | |||||
| <Unit1> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <IsPartOfProject Value="True"/> | |||||
| <UnitName Value="uGenericsTests"/> | |||||
| <TopLine Value="1127"/> | |||||
| <CursorPos X="73" Y="1148"/> | |||||
| <UsageCount Value="30"/> | |||||
| <Loaded Value="True"/> | |||||
| </Unit1> | |||||
| <Unit2> | |||||
| <Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\packages\fcl-fpcunit\src\fpcunit.pp"/> | |||||
| <UnitName Value="fpcunit"/> | |||||
| <IsVisibleTab Value="True"/> | |||||
| <EditorIndex Value="1"/> | |||||
| <UsageCount Value="12"/> | |||||
| <Loaded Value="True"/> | |||||
| </Unit2> | |||||
| <Unit3> | |||||
| <Filename Value="..\uutlGenerics.pas"/> | |||||
| <UnitName Value="uutlGenerics"/> | |||||
| <EditorIndex Value="-1"/> | |||||
| <TopLine Value="1952"/> | |||||
| <CursorPos Y="1969"/> | |||||
| <UsageCount Value="14"/> | |||||
| </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> | |||||
| <Unit5> | |||||
| <Filename Value="C:\Zusatzprogramme\Lazarus\components\fpcunit\guitestrunner.pas"/> | |||||
| <ComponentName Value="GUITestRunner"/> | |||||
| <HasResources Value="True"/> | |||||
| <ResourceBaseClass Value="Form"/> | |||||
| <EditorIndex Value="-1"/> | |||||
| <TopLine Value="78"/> | |||||
| <CursorPos X="3" Y="41"/> | |||||
| <UsageCount Value="10"/> | |||||
| </Unit5> | |||||
| <Unit6> | |||||
| <Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\objpas.inc"/> | |||||
| <EditorIndex Value="-1"/> | |||||
| <UsageCount Value="10"/> | |||||
| </Unit6> | |||||
| </Units> | |||||
| <JumpHistory Count="8" HistoryIndex="7"> | |||||
| <Position1> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="1145" TopLine="1122"/> | |||||
| </Position1> | |||||
| <Position2> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="1140" Column="19" TopLine="1122"/> | |||||
| </Position2> | |||||
| <Position3> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="1139" TopLine="1122"/> | |||||
| </Position3> | |||||
| <Position4> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="1143" TopLine="1122"/> | |||||
| </Position4> | |||||
| <Position5> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="1148" Column="59" TopLine="1122"/> | |||||
| </Position5> | |||||
| <Position6> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="1143" TopLine="1125"/> | |||||
| </Position6> | |||||
| <Position7> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="133" Column="15" TopLine="117"/> | |||||
| </Position7> | |||||
| <Position8> | |||||
| <Filename Value="uGenericsTests.pas"/> | |||||
| <Caret Line="1146" Column="33" TopLine="1127"/> | |||||
| </Position8> | |||||
| </JumpHistory> | |||||
| </ProjectSession> | |||||
| <Debugging> | |||||
| <Watches Count="3"> | |||||
| <Item1> | |||||
| <Expression Value="aCount"/> | |||||
| </Item1> | |||||
| <Item2> | |||||
| <Expression Value="aConsumer"/> | |||||
| </Item2> | |||||
| <Item3> | |||||
| <Expression Value="PChar(@ReadPage^.Data[1023])"/> | |||||
| </Item3> | |||||
| </Watches> | |||||
| </Debugging> | |||||
| </CONFIG> | |||||
| @@ -1,66 +0,0 @@ | |||||
| unit uutlConversion; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit stellt Methoden für Konvertierung verschiedener Datentypen zur Verfügung } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils; | |||||
| function Supports(const aInstance: TObject; const aClass: TClass; out aObj): Boolean; overload; | |||||
| function HexToBinary(HexValue: PChar; BinValue: PByte; BinBufSize: Integer): Integer; | |||||
| implementation | |||||
| function Supports(const aInstance: TObject; const aClass: TClass; out aObj): Boolean; | |||||
| begin | |||||
| result := Assigned(aInstance) and aInstance.InheritsFrom(aClass); | |||||
| if result then | |||||
| TObject(aObj) := aInstance | |||||
| else | |||||
| TObject(aObj) := nil; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //wandelt einen Hex-String in einen Blob um | |||||
| //@hexvalue: Hex-String | |||||
| //@binvalue: Zeiger auf einen Speicherbereich | |||||
| //@binbufsize: maximale größe die geschrieben werden darf | |||||
| //@result: gelesene bytes | |||||
| function HexToBinary(HexValue: PChar; BinValue: PByte; BinBufSize: Integer): Integer; | |||||
| var i,j,h,l : integer; | |||||
| begin | |||||
| i:=binbufsize; | |||||
| while (i>0) do | |||||
| begin | |||||
| if hexvalue^ IN ['A'..'F','a'..'f'] then | |||||
| h:=((ord(hexvalue^)+9) and 15) | |||||
| else if hexvalue^ IN ['0'..'9'] then | |||||
| h:=((ord(hexvalue^)) and 15) | |||||
| else | |||||
| break; | |||||
| inc(hexvalue); | |||||
| if hexvalue^ IN ['A'..'F','a'..'f'] then | |||||
| l:=(ord(hexvalue^)+9) and 15 | |||||
| else if hexvalue^ IN ['0'..'9'] then | |||||
| l:=(ord(hexvalue^)) and 15 | |||||
| else | |||||
| break; | |||||
| j := l + (h shl 4); | |||||
| inc(hexvalue); | |||||
| binvalue^:=j; | |||||
| inc(binvalue); | |||||
| dec(i); | |||||
| end; | |||||
| result:=binbufsize-i; | |||||
| end; | |||||
| end. | |||||
| @@ -1,413 +0,0 @@ | |||||
| unit uutlGraph; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit implementiert einen generischen Graphen } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils, contnrs, uutlCommon; | |||||
| type | |||||
| TutlGraph = class; | |||||
| TutlGraphNodeData = class(TObject) | |||||
| public | |||||
| constructor Create; virtual; | |||||
| end; | |||||
| TutlGraphNodeDataClass = class of TutlGraphNodeData; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlGraphNode = class; | |||||
| TutlGraphNodeClass = class of TutlGraphNode; | |||||
| TutlGraphNode = class(TutlInterfaceNoRefCount) | |||||
| private type | |||||
| TNodeEnumerator = class(TObject) | |||||
| private | |||||
| fOwner: TutlGraphNode; | |||||
| fPos: Integer; | |||||
| function GetCurrent: TutlGraphNode; | |||||
| public | |||||
| property Current: TutlGraphNode read GetCurrent; | |||||
| function MoveNext: Boolean; | |||||
| constructor Create(const aOwner: TutlGraphNode); | |||||
| end; | |||||
| protected | |||||
| fParent: TutlGraphNode; | |||||
| fOwner: TutlGraph; | |||||
| fData: TutlGraphNodeData; | |||||
| fItems: TObjectList; | |||||
| class function GetDataClass: TutlGraphNodeDataClass; virtual; | |||||
| function GetCount: Integer; virtual; | |||||
| function GetItems(const aIndex: Integer): TutlGraphNode; virtual; | |||||
| function AttachNode(const aNode: TutlGraphNode): Boolean; virtual; | |||||
| function DetachNode(const aNode: TutlGraphNode): Boolean; virtual; | |||||
| public | |||||
| property Parent: TutlGraphNode read fParent; | |||||
| property Owner: TutlGraph read fOwner; | |||||
| property Data: TutlGraphNodeData read fData; | |||||
| property Count: Integer read GetCount; | |||||
| property Items[const aIndex: Integer]: TutlGraphNode read GetItems; default; | |||||
| function AddItem: TutlGraphNode; | |||||
| function IndexOf(const aItem: TutlGraphNode): Integer; | |||||
| procedure DelItem(const aIndex: Integer); | |||||
| procedure Clear; | |||||
| function IsParent(const aNode: TutlGraphNode): Boolean; | |||||
| function Move(const aParent: TutlGraphNode): Boolean; | |||||
| function GetEnumerator: TNodeEnumerator; | |||||
| constructor Create(const aParent: TutlGraphNode; const aOwner: TutlGraph); | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlGraph = class(TutlInterfaceNoRefCount) | |||||
| protected | |||||
| fRootNode: TutlGraphNode; | |||||
| class function GetItemClass: TutlGraphNodeClass; virtual; | |||||
| public | |||||
| property RootNode: TutlGraphNode read fRootNode; | |||||
| constructor Create; | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlGenericGraphNode<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. | |||||
| @@ -1,244 +0,0 @@ | |||||
| unit uutlLocalization; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit stellt Mechanismen zur Übersetzung von Texten mit Hilfe von PO/MO-Files zur Verfügung } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils, gettext, | |||||
| uutlCommon, uutlGenerics, uutlStreamHelper; | |||||
| type | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlLocalizationItem = class(TObject) | |||||
| Name, Comment: String; | |||||
| constructor Create; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlLocalizationDatabase = class(TObject) | |||||
| private type | |||||
| TStringObjMap = specialize TutlMap<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. | |||||
| @@ -1,100 +0,0 @@ | |||||
| unit uutlMcfHelper; | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| ugluMatrix, ugluVector, uutlMCF, uglcLight; | |||||
| procedure utlWriteMatrix4f(const aSection: TutlMCFSection; const aMatrix: TgluMatrix4f); | |||||
| function utlReadMatrix4f(const aSection: TutlMCFSection): TgluMatrix4f; | |||||
| procedure utlWriteMaterial(const aSection: TutlMCFSection; const aMaterial: TglcMaterialRec); | |||||
| function utlReadMaterial(const aSection: TutlMCFSection): TglcMaterialRec; | |||||
| procedure utlWriteLight(const aSection: TutlMCFSection; const aLight: TglcLightRec); | |||||
| function utlReadLight(const aSection: TutlMCFSection): TglcLightRec; | |||||
| implementation | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure utlWriteMatrix4f(const aSection: TutlMCFSection; const aMatrix: TgluMatrix4f); | |||||
| begin | |||||
| with aSection do begin | |||||
| SetString('AxisX', gluVector4fToStr(aMatrix[maAxisX])); | |||||
| SetString('AxisY', gluVector4fToStr(aMatrix[maAxisY])); | |||||
| SetString('AxisZ', gluVector4fToStr(aMatrix[maAxisZ])); | |||||
| SetString('Pos', gluVector4fToStr(aMatrix[maPos])); | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function utlReadMatrix4f(const aSection: TutlMCFSection): TgluMatrix4f; | |||||
| begin | |||||
| with aSection do begin | |||||
| result[maAxisX] := gluStrToVector4f(GetString('AxisX', '1; 0; 0; 0;')); | |||||
| result[maAxisY] := gluStrToVector4f(GetString('AxisY', '0; 1; 0; 0;')); | |||||
| result[maAxisZ] := gluStrToVector4f(GetString('AxisZ', '0; 0; 1; 0;')); | |||||
| result[maPos] := gluStrToVector4f(GetString('Pos', '0; 0; 0; 1;')); | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure utlWriteMaterial(const aSection: TutlMCFSection; const aMaterial: TglcMaterialRec); | |||||
| begin | |||||
| with aSection do begin | |||||
| SetString('Ambient', gluVector4fToStr(aMaterial.Ambient)); | |||||
| SetString('Diffuse', gluVector4fToStr(aMaterial.Diffuse)); | |||||
| SetString('Specular', gluVector4fToStr(aMaterial.Specular)); | |||||
| SetString('Emission', gluVector4fToStr(aMaterial.Emission)); | |||||
| SetFloat ('Shininess', aMaterial.Shininess); | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function utlReadMaterial(const aSection: TutlMCFSection): TglcMaterialRec; | |||||
| begin | |||||
| with aSection do begin | |||||
| result.Ambient := gluStrToVector4f(GetString('Ambient', gluVector4fToStr(MAT_DEFAULT_AMBIENT))); | |||||
| result.Diffuse := gluStrToVector4f(GetString('Diffuse', gluVector4fToStr(MAT_DEFAULT_DIFFUSE))); | |||||
| result.Specular := gluStrToVector4f(GetString('Specular', gluVector4fToStr(MAT_DEFAULT_SPECULAR))); | |||||
| result.Emission := gluStrToVector4f(GetString('Emission', gluVector4fToStr(MAT_DEFAULT_EMISSION))); | |||||
| result.Shininess := GetFloat('Shininess', MAT_DEFAULT_SHININESS); | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure utlWriteLight(const aSection: TutlMCFSection; const aLight: TglcLightRec); | |||||
| begin | |||||
| with aSection do begin | |||||
| SetString('Ambient', gluVector4fToStr(aLight.Ambient)); | |||||
| SetString('Diffuse', gluVector4fToStr(aLight.Diffuse)); | |||||
| SetString('Specular', gluVector4fToStr(aLight.Specular)); | |||||
| SetString('Position', gluVector4fToStr(aLight.Position)); | |||||
| SetString('SpotDirection', gluVector3fToStr(aLight.SpotDirection)); | |||||
| SetFloat ('SpotExponent', aLight.SpotExponent); | |||||
| SetFloat ('SpotCutoff', aLight.SpotCutoff); | |||||
| SetFloat ('ConstantAtt', aLight.ConstantAtt); | |||||
| SetFloat ('LinearAtt', aLight.LinearAtt); | |||||
| SetFloat ('QuadraticAtt', aLight.QuadraticAtt); | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function utlReadLight(const aSection: TutlMCFSection): TglcLightRec; | |||||
| begin | |||||
| with aSection do begin | |||||
| result.Ambient := gluStrToVector4f(GetString('Ambient', gluVector4fToStr(LIGHT_DEFAULT_AMBIENT))); | |||||
| result.Diffuse := gluStrToVector4f(GetString('Diffuse', gluVector4fToStr(LIGHT_DEFAULT_DIFFUSE))); | |||||
| result.Specular := gluStrToVector4f(GetString('Specular', gluVector4fToStr(LIGHT_DEFAULT_SPECULAR))); | |||||
| result.Position := gluStrToVector4f(GetString('Position', gluVector4fToStr(LIGHT_DEFAULT_POSITION))); | |||||
| result.SpotDirection := gluStrToVector3f(GetString('SpotDirection', gluVector3fToStr(LIGHT_DEFAULT_SPOT_DIRECTION))); | |||||
| result.SpotExponent := GetFloat ('SpotExponent', LIGHT_DEFAULT_SPOT_EXPONENT); | |||||
| result.SpotCutoff := GetFloat ('SpotCutoff', LIGHT_DEFAULT_SPOT_CUTOFF); | |||||
| result.ConstantAtt := GetFloat ('ConstantAtt', LIGHT_DEFAULT_CONSTANT_ATT); | |||||
| result.LinearAtt := GetFloat ('LinearAtt', LIGHT_DEFAULT_LINEAR_ATT); | |||||
| result.QuadraticAtt := GetFloat ('QuadraticAtt', LIGHT_DEFAULT_QUADRATIC_ATT); | |||||
| end; | |||||
| end; | |||||
| end. | |||||
| @@ -1,396 +0,0 @@ | |||||
| unit uutlMessageThread; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit definiert einen Thread, der mit Hilfe von Messages Daten synchronisiert | |||||
| mit anderen Threads austauschen kann } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils, syncobjs, uutlMessages, uutlGenerics; | |||||
| type | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlMessageThread = class(TThread, IUnknown) | |||||
| public type | |||||
| TMessageProgressCallback = procedure(const aMsg: TutlMessage) of Object; | |||||
| TMessageQueue = class(specialize TutlSyncQueue<TutlMessage>) | |||||
| private | |||||
| fEvent: TSimpleEvent; | |||||
| public | |||||
| procedure Push(const aItem: TutlMessage); override; | |||||
| function Pop(out aItem: TutlMessage): Boolean; override; | |||||
| function WaitForMessages(const aWaitTime: Cardinal = INFINITE): Boolean; | |||||
| function ProcessMessages(const aProgressCallback: TMessageProgressCallback): Boolean; | |||||
| constructor Create(const aOwnsObjects: Boolean = true); | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| protected | |||||
| fMessages: TMessageQueue; | |||||
| fRefCount : longint; | |||||
| { implement methods of IUnknown } | |||||
| function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||||
| function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; | |||||
| function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; | |||||
| protected | |||||
| function CreateMessageQueue: TMessageQueue; virtual; | |||||
| function WaitForMessages(const aWaitTime: Cardinal): Boolean; | |||||
| function ProcessMessages: Boolean; virtual; | |||||
| procedure ProcessMessage(const {%H-}aMessage: TutlMessage); virtual; | |||||
| public | |||||
| //Messages Objects passed to PostMessage will be freed automatically | |||||
| procedure PostMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload; | |||||
| procedure PostMessage(const aID: Cardinal; const aArgs: TObject); overload; | |||||
| procedure PostMessage(const aMsg: TutlMessage); virtual; overload; | |||||
| //Messages Objects passed to SendMessage must be freed by user when WaitResult is wrSignaled (otherwise the thread will handle it) | |||||
| function SendMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt; | |||||
| const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||||
| function SendMessage(const aID: Cardinal; const aArgs: TObject; | |||||
| const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||||
| function SendMessage(const aMsg: TutlSynchronousMessage; | |||||
| const aWaitTime: Cardinal = INFINITE): TWaitResult; virtual; overload; | |||||
| constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt=DefaultStackSize); | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //Messages Objects passed to PostMessage will be freed automatically | |||||
| function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt): Boolean; overload; | |||||
| function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject): Boolean; overload; | |||||
| function utlPostMessage(const aThreadID: TThreadID; const aMsg: TutlMessage): Boolean; overload; | |||||
| //Messages Objects passed to SendMessage must be freed by user when WaitResult is wrSignaled (otherwise the thread will handle it) | |||||
| function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt; | |||||
| const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||||
| function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject; | |||||
| const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||||
| function utlSendMessage(const aThreadID: TThreadID; const aMsg: TutlSynchronousMessage; | |||||
| const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||||
| implementation | |||||
| uses | |||||
| uutlLogger, uutlExceptions; | |||||
| type | |||||
| TutlMessageThreadMap = class(specialize TutlMap<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; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlMessageThread.TMessageQueue/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlMessageThread.TMessageQueue.Push(const aItem: TutlMessage); | |||||
| begin | |||||
| inherited Push(aItem); | |||||
| fEvent.SetEvent; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.TMessageQueue.Pop(out aItem: TutlMessage): Boolean; | |||||
| begin | |||||
| result := inherited Pop(aItem); | |||||
| if (Count <= 0) then | |||||
| fEvent.ResetEvent; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.TMessageQueue.WaitForMessages(const aWaitTime: Cardinal): Boolean; | |||||
| var | |||||
| wr: TWaitResult; | |||||
| begin | |||||
| wr := fEvent.WaitFor(aWaitTime); | |||||
| result := (wr = wrSignaled); | |||||
| if not result and (wr <> wrTimeout) then | |||||
| raise EWait.Create('Error while waiting for messages', wr); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.TMessageQueue.ProcessMessages(const aProgressCallback: TMessageProgressCallback): Boolean; | |||||
| var | |||||
| m: TutlMessage; | |||||
| empty: Boolean; | |||||
| begin | |||||
| empty := false; | |||||
| result := false; | |||||
| if not Assigned(aProgressCallback) then | |||||
| exit; | |||||
| repeat | |||||
| try | |||||
| if Pop(m) then begin | |||||
| result := true; | |||||
| try | |||||
| aProgressCallback(m); | |||||
| finally | |||||
| if (m is TutlSynchronousMessage) then | |||||
| (m as TutlSynchronousMessage).Finish | |||||
| else | |||||
| FreeAndNil(m); | |||||
| end; | |||||
| end else | |||||
| empty := true; | |||||
| except | |||||
| on e: Exception do begin | |||||
| utlLogger.Error(self, 'error while progressing message: %s - %s', [e.ClassName, e.Message]); | |||||
| end; | |||||
| end; | |||||
| until empty; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlMessageThread.TMessageQueue.Create(const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(aOwnsObjects); | |||||
| fEvent := TSimpleEvent.Create; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlMessageThread.TMessageQueue.Destroy; | |||||
| begin | |||||
| inherited Destroy; | |||||
| FreeAndNil(fEvent); // do not free event before all messages has been deleted | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlMessageThreadMap////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlMessageThreadMap.Lock; | |||||
| begin | |||||
| fCS.Acquire; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlMessageThreadMap.Release; | |||||
| begin | |||||
| fCS.Release; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlMessageThreadMap.Create(const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited; | |||||
| fCS:= TCriticalSection.Create; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlMessageThreadMap.Destroy; | |||||
| begin | |||||
| fCS.Acquire; | |||||
| try | |||||
| inherited Destroy; | |||||
| finally | |||||
| fCS.Release; | |||||
| end; | |||||
| FreeAndNil(fCS); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlMessageThread///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.QueryInterface(constref iid: tguid; out obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||||
| begin | |||||
| if getinterface(iid,obj) then | |||||
| result := S_OK | |||||
| else | |||||
| result := longint(E_NOINTERFACE); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread._AddRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||||
| begin | |||||
| result := InterLockedIncrement(fRefCount); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||||
| begin | |||||
| result := InterLockedDecrement(fRefCount); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.CreateMessageQueue: TMessageQueue; | |||||
| begin | |||||
| result := TMessageQueue.Create(true); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.WaitForMessages(const aWaitTime: Cardinal): Boolean; | |||||
| begin | |||||
| result := fMessages.WaitForMessages(aWaitTime); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.ProcessMessages: Boolean; | |||||
| begin | |||||
| result := fMessages.ProcessMessages(@ProcessMessage); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlMessageThread.ProcessMessage(const aMessage: TutlMessage); | |||||
| begin | |||||
| case aMessage.ID of | |||||
| MSG_CALLBACK: | |||||
| (aMessage as TutlCallbackMsg).ExecuteCallback; | |||||
| MSG_SYNC_CALLBACK: | |||||
| (aMessage as TutlSyncCallbackMsg).ExecuteCallback; | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlMessageThread.PostMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt); | |||||
| begin | |||||
| fMessages.Push(TutlMessage.Create(aID, aWParam, aLParam)); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlMessageThread.PostMessage(const aID: Cardinal; const aArgs: TObject); | |||||
| begin | |||||
| fMessages.Push(TutlMessage.Create(aID, aArgs)); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlMessageThread.PostMessage(const aMsg: TutlMessage); | |||||
| begin | |||||
| fMessages.Push(aMsg); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.SendMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt; const aWaitTime: Cardinal): TWaitResult; | |||||
| begin | |||||
| result := SendMessage(TutlSynchronousMessage.Create(aID, aWParam, aLParam), aWaitTime); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.SendMessage(const aID: Cardinal; const aArgs: TObject; const aWaitTime: Cardinal): TWaitResult; | |||||
| begin | |||||
| result := SendMessage(TutlSynchronousMessage.Create(aID, aArgs), aWaitTime); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlMessageThread.SendMessage(const aMsg: TutlSynchronousMessage; const aWaitTime: Cardinal): TWaitResult; | |||||
| begin | |||||
| fMessages.Push(aMsg); | |||||
| result := aMsg.WaitFor(aWaitTime); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlMessageThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt); | |||||
| begin | |||||
| inherited Create(CreateSuspended, StackSize); | |||||
| fMessages := CreateMessageQueue; | |||||
| Threads.Lock; | |||||
| try | |||||
| Threads.Add(ThreadID, self); | |||||
| finally | |||||
| Threads.Release; | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlMessageThread.Destroy; | |||||
| begin | |||||
| Threads.Lock; | |||||
| try | |||||
| Threads.Delete(ThreadID); | |||||
| finally | |||||
| Threads.Release; | |||||
| end; | |||||
| FreeAndNil(fMessages); | |||||
| inherited Destroy; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| initialization | |||||
| Threads := TutlMessageThreadMap.Create(false); | |||||
| finalization | |||||
| Threads.Lock; | |||||
| try | |||||
| while (Threads.Count > 0) do | |||||
| Threads.ValueAt[Threads.Count-1].Free; | |||||
| finally | |||||
| Threads.Release; | |||||
| end; | |||||
| FreeAndNil(Threads); | |||||
| end. | |||||
| @@ -1,171 +0,0 @@ | |||||
| unit uutlMessages; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit enthält verschiedene Klassen, die Messages definieren, | |||||
| die zwischen utlMessageThreads ausgetauscht werden können } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils, syncobjs; | |||||
| const | |||||
| //General | |||||
| MSG_CALLBACK = $00010001; //TutlCallbackMsg | |||||
| MSG_SYNC_CALLBACK = $00010002; //TutlSyncCallbackMsg | |||||
| //User | |||||
| MSG_USER = $F0000000; | |||||
| type | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlMessage = class(TObject) | |||||
| protected | |||||
| fID: Cardinal; | |||||
| fWParam: PtrInt; | |||||
| fLParam: PtrInt; | |||||
| fArgs: TObject; | |||||
| fOwnsObjects: Boolean; | |||||
| public | |||||
| property ID: Cardinal read fID; | |||||
| property WParam: PtrInt read fWParam; | |||||
| property LParam: PtrInt read fLParam; | |||||
| property Args: TObject read fArgs; | |||||
| property OwnsObjects: Boolean read fOwnsObjects write fOwnsObjects; | |||||
| constructor Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload; | |||||
| constructor Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean = true); overload; | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlSynchronousMessage = class(TutlMessage) | |||||
| private | |||||
| fEvent: TEvent; | |||||
| public | |||||
| procedure Finish; | |||||
| function WaitFor(const aTimeout: Cardinal): TWaitResult; | |||||
| constructor Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload; | |||||
| constructor Create(const {%H-}aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean = true); overload; | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlCallbackMsg = class(TutlMessage) | |||||
| public | |||||
| procedure ExecuteCallback; virtual; | |||||
| constructor Create; overload; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlSyncCallbackMsg = class(TutlSynchronousMessage) | |||||
| public | |||||
| procedure ExecuteCallback; virtual; | |||||
| constructor Create; overload; | |||||
| end; | |||||
| implementation | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlMessage/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlMessage.Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); | |||||
| begin | |||||
| inherited Create; | |||||
| fID := aID; | |||||
| fWParam := aWParam; | |||||
| fLParam := aLParam; | |||||
| fArgs := nil; | |||||
| fOwnsObjects := true; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlMessage.Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create; | |||||
| fID := aID; | |||||
| fWParam := 0; | |||||
| fLParam := 0; | |||||
| fArgs := aArgs; | |||||
| fOwnsObjects := aOwnsObjects; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlMessage.Destroy; | |||||
| begin | |||||
| if Assigned(fArgs) and fOwnsObjects then | |||||
| FreeAndNil(fArgs); | |||||
| inherited Destroy; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlSynchronousMessage////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlSynchronousMessage.Finish; | |||||
| begin | |||||
| fEvent.SetEvent; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlSynchronousMessage.WaitFor(const aTimeout: Cardinal): TWaitResult; | |||||
| begin | |||||
| result := fEvent.WaitFor(aTimeout); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlSynchronousMessage.Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); | |||||
| begin | |||||
| inherited Create(aID, aWParam, aLParam); | |||||
| fEvent := TEvent.Create(nil, true, false, ''); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlSynchronousMessage.Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(ID, aArgs, aOwnsObjects); | |||||
| fEvent := TEvent.Create(nil, true, false, ''); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlSynchronousMessage.Destroy; | |||||
| begin | |||||
| fEvent.SetEvent; | |||||
| FreeAndNil(fEvent); | |||||
| inherited Destroy; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlCallbackMsg/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlCallbackMsg.ExecuteCallback; | |||||
| begin | |||||
| //DUMMY | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlCallbackMsg.Create; | |||||
| begin | |||||
| inherited Create(MSG_CALLBACK, 0, 0); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlSyncCallbackMsg/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlSyncCallbackMsg.ExecuteCallback; | |||||
| begin | |||||
| //DUMMY | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlSyncCallbackMsg.Create; | |||||
| begin | |||||
| inherited Create(MSG_SYNC_CALLBACK, 0, 0); | |||||
| end; | |||||
| end. | |||||
| @@ -1,369 +0,0 @@ | |||||
| unit uutlObservableGenerics; | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils, | |||||
| uutlGenerics, uutlInterfaces; | |||||
| type | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlEventList<T> = class(specialize TutlHashSetBase<T>) | |||||
| private type | |||||
| TComparer = class(TInterfacedObject, IComparer) | |||||
| public | |||||
| function Compare(const i1, i2: T): Integer; | |||||
| end; | |||||
| public | |||||
| function RegisterEvent(const aEvent: T): Boolean; | |||||
| function UnregisterEvent(const aEvent: T): Boolean; | |||||
| constructor Create; | |||||
| end; | |||||
| TutlNotifyEventList = specialize TutlEventList<TNotifyEvent>; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlObservableCustomList<T> = class(specialize TutlCustomList<T>) | |||||
| public type | |||||
| TEventList = specialize TutlEventList<TItemEvent>; | |||||
| private | |||||
| fOnAddItem: TEventList; | |||||
| fOnRemoveItem: TEventList; | |||||
| protected | |||||
| procedure InsertIntern(const aIndex: Integer; const aItem: T); override; | |||||
| procedure DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean = true); override; | |||||
| procedure DoAddItem(const aIndex: Integer; const aItem: T); virtual; | |||||
| procedure DoRemoveItem(const aIndex: Integer; const aItem: T); virtual; | |||||
| public | |||||
| property OnAddItem: TEventList read fOnAddItem; | |||||
| property OnRemoveItem: TEventList read fOnRemoveItem; | |||||
| constructor Create(aEqualityComparer: IEqualityComparer; const aOwnsObjects: Boolean = true); | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlObservableList<T> = class(specialize TutlObservableCustomList<T>) | |||||
| public type | |||||
| TEqualityComparer = specialize TutlEqualityComparer<T>; | |||||
| public | |||||
| constructor Create(const aOwnsObjects: Boolean = true); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlObservableCustomHashSet<T> = class(specialize TutlCustomHashSet<T>) | |||||
| public type | |||||
| TEventList = specialize TutlEventList<THashItemEvent>; | |||||
| private | |||||
| fOnAddItem: TEventList; | |||||
| fOnRemoveItem: TEventList; | |||||
| protected | |||||
| procedure InsertIntern(const aIndex: Integer; const aItem: T); override; | |||||
| procedure DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean = true); override; | |||||
| procedure DoAddItem(const aItem: T); virtual; | |||||
| procedure DoRemoveItem(const aItem: T); virtual; | |||||
| public | |||||
| property OnAddItem: TEventList read fOnAddItem; | |||||
| property OnRemoveItem: TEventList read fOnRemoveItem; | |||||
| constructor Create(aComparer: IComparer; const aOwnsObjects: Boolean = true); | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlObservableHashSet<T> = class(specialize TutlObservableCustomHashSet<T>) | |||||
| public type | |||||
| TComparer = specialize TutlComparer<T>; | |||||
| public | |||||
| constructor Create(const aOwnsObjects: Boolean = true); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlObservableCustomMap<TKey, TValue> = class(specialize TutlMapBase<TKey, TValue>) | |||||
| public type | |||||
| TEventList = specialize TutlEventList<TKeyValuePairEvent>; | |||||
| TObservableHashSet = class(THashSet) | |||||
| private | |||||
| fOwner: TutlObservableCustomMap; | |||||
| protected | |||||
| procedure InsertIntern(const aIndex: Integer; const aItem: TKeyValuePair); override; | |||||
| procedure DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean = true); override; | |||||
| public | |||||
| constructor Create(const aOwner: TutlObservableCustomMap; const aComparer: IComparer; const aOwnsObjects: Boolean = true); | |||||
| end; | |||||
| private | |||||
| fHashSetImpl: TObservableHashSet; | |||||
| fOnAddItem: TEventList; | |||||
| fOnRemoveItem: TEventList; | |||||
| protected | |||||
| procedure DoAddItem(const aKey: TKey; const aValue: TValue); virtual; | |||||
| procedure DoRemoveItem(const aKey: TKey; const aValue: TValue); virtual; | |||||
| public | |||||
| property OnAddItem: TEventList read fOnAddItem; | |||||
| property OnRemoveItem: TEventList read fOnRemoveItem; | |||||
| constructor Create(const aComparer: IComparer; const aOwnsObjects: Boolean = true); | |||||
| destructor Destroy; override; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| generic TutlObservableMap<TKey, TValue> = class(specialize TutlObservableCustomMap<TKey, TValue>) | |||||
| public type | |||||
| TComparer = specialize TutlComparer<TKey>; | |||||
| public | |||||
| constructor Create(const aOwnsObjects: Boolean = true); | |||||
| end; | |||||
| implementation | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlEventList///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlEventList.TComparer.Compare(const i1, i2: T): Integer; | |||||
| var | |||||
| m1, m2: TMethod; | |||||
| begin | |||||
| m1 := TMethod(i1); | |||||
| m2 := TMethod(i2); | |||||
| if (m1.Data < m2.Data) then | |||||
| result := -1 | |||||
| else if (m1.Data > m2.Data) then | |||||
| result := 1 | |||||
| else if (m1.Code < m2.Code) then | |||||
| result := -1 | |||||
| else if (m1.Code > m2.Code) then | |||||
| result := 1 | |||||
| else | |||||
| result := 0; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlEventList.RegisterEvent(const aEvent: T): Boolean; | |||||
| var | |||||
| i: Integer; | |||||
| begin | |||||
| result := (SearchItem(0, List.Count-1, aEvent, i) < 0); | |||||
| if result then | |||||
| InsertIntern(i, aEvent); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlEventList.UnregisterEvent(const aEvent: T): Boolean; | |||||
| var | |||||
| i, tmp: Integer; | |||||
| begin | |||||
| i := SearchItem(0, List.Count-1, aEvent, tmp); | |||||
| result := (i >= 0); | |||||
| if result then | |||||
| DeleteIntern(i); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlEventList.Create; | |||||
| begin | |||||
| inherited Create(TComparer.Create, true); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlObservableCustomList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomList.InsertIntern(const aIndex: Integer; const aItem: T); | |||||
| begin | |||||
| inherited InsertIntern(aIndex, aItem); | |||||
| DoAddItem(aIndex, aItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomList.DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean); | |||||
| begin | |||||
| DoRemoveItem(aIndex, aIndex); | |||||
| inherited DeleteIntern(aIndex, aFreeItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomList.DoAddItem(const aIndex: Integer; const aItem: T); | |||||
| var | |||||
| e: TItemEvent; | |||||
| begin | |||||
| if Assigned(fOnAddItem) then | |||||
| for e in fOnAddItem do | |||||
| e(self, aIndex, aItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomList.DoRemoveItem(const aIndex: Integer; const aItem: T); | |||||
| var | |||||
| e: TItemEvent; | |||||
| begin | |||||
| if Assigned(fOnRemoveItem) then | |||||
| for e in fOnRemoveItem do | |||||
| e(self, aIndex, GetItem(aIndex)); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlObservableCustomList.Create(aEqualityComparer: IEqualityComparer; const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(aEqualityComparer, aOwnsObjects); | |||||
| fOnAddItem := TEventList.Create; | |||||
| fOnRemoveItem := TEventList.Create; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlObservableCustomList.Destroy; | |||||
| begin | |||||
| FreeAndNil(fOnRemoveItem); | |||||
| FreeAndNil(fOnAddItem); | |||||
| inherited Destroy; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlObservableList//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlObservableList.Create(const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(TEqualityComparer.Create, aOwnsObjects); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlObservableCustomHashSet/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomHashSet.InsertIntern(const aIndex: Integer; const aItem: T); | |||||
| begin | |||||
| inherited InsertIntern(aIndex, aItem); | |||||
| DoAddItem(aItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomHashSet.DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean); | |||||
| begin | |||||
| DoRemoveItem(GetItem(aIndex)); | |||||
| inherited DeleteIntern(aIndex, aFreeItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomHashSet.DoAddItem(const aItem: T); | |||||
| var | |||||
| e: THashItemEvent; | |||||
| begin | |||||
| if Assigned(fOnAddItem) then | |||||
| for e in fOnAddItem do | |||||
| e(self, aItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomHashSet.DoRemoveItem(const aItem: T); | |||||
| var | |||||
| e: THashItemEvent; | |||||
| begin | |||||
| if Assigned(fOnRemoveItem) then | |||||
| for e in fOnRemoveItem do | |||||
| e(self, aItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlObservableCustomHashSet.Create(aComparer: IComparer; const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(aComparer, aOwnsObjects); | |||||
| fOnAddItem := TEventList.Create; | |||||
| fOnRemoveItem := TEventList.Create; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlObservableCustomHashSet.Destroy; | |||||
| begin | |||||
| inherited Destroy; // calls clear -> Free EventLists after | |||||
| FreeAndNil(fOnAddItem); | |||||
| FreeAndNil(fOnRemoveItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlObservableHashSet///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlObservableHashSet.Create(const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(TComparer.Create, aOwnsObjects); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlObservableCustomMap/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomMap.TObservableHashSet.InsertIntern(const aIndex: Integer; const aItem: TKeyValuePair); | |||||
| begin | |||||
| inherited InsertIntern(aIndex, aItem); | |||||
| fOwner.DoAddItem(aItem.Key, aItem.Value); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomMap.TObservableHashSet.DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean); | |||||
| var | |||||
| kvp: TKeyValuePair; | |||||
| begin | |||||
| kvp := GetItem(aIndex); | |||||
| fOwner.DoRemoveItem(kvp.Key, kvp.Value); | |||||
| inherited DeleteIntern(aIndex, aFreeItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlObservableCustomMap.TObservableHashSet.Create( | |||||
| const aOwner: TutlObservableCustomMap; const aComparer: IComparer; const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(aComparer, aOwnsObjects); | |||||
| fOwner := aOwner; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomMap.DoAddItem(const aKey: TKey; const aValue: TValue); | |||||
| var | |||||
| e: TKeyValuePairEvent; | |||||
| begin | |||||
| if not Assigned(fOnAddItem) then | |||||
| exit; | |||||
| for e in fOnAddItem do | |||||
| e(self, aKey, aValue); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlObservableCustomMap.DoRemoveItem(const aKey: TKey; const aValue: TValue); | |||||
| var | |||||
| e: TKeyValuePairEvent; | |||||
| begin | |||||
| if not Assigned(fOnRemoveItem) then | |||||
| exit; | |||||
| for e in fOnRemoveItem do | |||||
| e(self, aKey, aValue); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlObservableCustomMap.Create(const aComparer: IComparer; const aOwnsObjects: Boolean); | |||||
| begin | |||||
| fOnAddItem := TEventList.Create; | |||||
| fOnRemoveItem := TEventList.Create; | |||||
| fHashSetImpl := TObservableHashSet.Create(self, TKeyValuePairComparer.Create(aComparer), aOwnsObjects); | |||||
| inherited Create(fHashSetImpl); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| destructor TutlObservableCustomMap.Destroy; | |||||
| begin | |||||
| inherited Destroy; | |||||
| FreeAndNil(fHashSetImpl); | |||||
| FreeAndNil(fOnAddItem); | |||||
| FreeAndNil(fOnRemoveItem); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlObservableMap///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| constructor TutlObservableMap.Create(const aOwnsObjects: Boolean); | |||||
| begin | |||||
| inherited Create(TComparer.Create, aOwnsObjects); | |||||
| end; | |||||
| end. | |||||
| @@ -1,93 +0,0 @@ | |||||
| unit uutlPlatform; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit implementiert Methoden mit denen ein String generiert werden kann, | |||||
| welcher das System auf dem die Anwendung läuft identifiziert } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils; | |||||
| function GetPlatformIdentitfier: string; | |||||
| implementation | |||||
| uses | |||||
| {$ifdef WINDOWS} | |||||
| Windows | |||||
| {$endif} | |||||
| ; | |||||
| {$ifdef WINDOWS} | |||||
| function GetWindowsVersionStr(const aDefault: String): string; | |||||
| var | |||||
| osv: TOSVERSIONINFO; | |||||
| ver: cardinal; | |||||
| begin | |||||
| Result:= aDefault; | |||||
| osv.dwOSVersionInfoSize:= SizeOf(osv); | |||||
| if GetVersionEx(osv) then begin | |||||
| ver:= MAKELONG(osv.dwMinorVersion, osv.dwMajorVersion); | |||||
| // positive overflow: if system is newer, always detect as newest we knew instead of failing | |||||
| if ver >= $00060003 then | |||||
| Result:= '8_1' | |||||
| else | |||||
| if ver >= $00060002 then | |||||
| Result:= '8' | |||||
| else | |||||
| if ver >= $00060001 then | |||||
| Result:= '7' | |||||
| else | |||||
| if ver >= $00060000 then | |||||
| Result:= 'Vista' | |||||
| else | |||||
| if ver >= $00050002 then | |||||
| Result:= '2003' | |||||
| else | |||||
| if ver >= $00050001 then | |||||
| Result:= 'XP' | |||||
| else | |||||
| if ver >= $00050000 then | |||||
| Result:= '2000' | |||||
| else | |||||
| if ver >= $00040000 then | |||||
| Result:= 'NT4'; | |||||
| // ignore NT3, hmkay?; | |||||
| end; | |||||
| end; | |||||
| {$endif} | |||||
| function GetPlatformIdentitfier: string; | |||||
| var | |||||
| os,ver,arch: string; | |||||
| begin | |||||
| Result:= ''; | |||||
| os:= ''; | |||||
| ver:= 'generic'; | |||||
| arch:= ''; | |||||
| {$if defined(WINDOWS)} | |||||
| os:= 'mswin'; | |||||
| ver:= GetWindowsVersionStr(ver); | |||||
| {$elseif defined(LINUX)} | |||||
| os:= 'linux'; | |||||
| {$Warning System Version String missing!} | |||||
| {$endif} | |||||
| {$if defined(CPUX86)} | |||||
| arch:= 'x86'; | |||||
| {$elseif defined(cpux86_64)} | |||||
| arch:= 'x64'; | |||||
| {$else} | |||||
| {$Error Unknown Architecture!} | |||||
| {$endif} | |||||
| Result:= format('%s-%s-%s', [os, ver, arch]); | |||||
| end; | |||||
| end. | |||||
| @@ -1,126 +0,0 @@ | |||||
| unit uutlSerialization; | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils; | |||||
| type | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| IutlFileReader = interface | |||||
| ['{3A9C3AE3-CAEE-44C9-85BE-0BCAA5C1BE7A}'] | |||||
| function LoadStream(const aFilename: String; const aStream: TStream): Boolean; | |||||
| end; | |||||
| IutlFileWriter = interface | |||||
| ['{3DF84644-9FC4-4A8A-88C2-73F13E72B1ED}'] | |||||
| procedure SaveStream(const aFilename: String; const aStream: TStream); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlSimpleFileReader = class(TInterfacedObject, IutlFileReader) | |||||
| public | |||||
| function LoadStream(const aFilename: String; const aStream: TStream): Boolean; | |||||
| end; | |||||
| TutlSimpleFileWriter = class(TInterfacedObject, IutlFileWriter) | |||||
| public | |||||
| procedure SaveStream(const aFilename: String; const aStream: TStream); | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlFileReaderProxy = class(TInterfacedObject, IutlFileReader) | |||||
| private | |||||
| fReader: IutlFileReader; | |||||
| fPrefix: String; | |||||
| public | |||||
| function LoadStream(const aFilename: String; const aStream: TStream): Boolean; | |||||
| constructor Create(const aReader: IutlFileReader; const aPrefix: String); | |||||
| end; | |||||
| TutlFileWriterProxy = class(TInterfacedObject, IutlFileWriter) | |||||
| private | |||||
| fWriter: IutlFileWriter; | |||||
| fPrefix: String; | |||||
| public | |||||
| procedure SaveStream(const aFilename: String; const aStream: TStream); | |||||
| constructor Create(const aWriter: IutlFileWriter; const aPrefix: String); | |||||
| end; | |||||
| implementation | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlSimpleFileReader////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlSimpleFileReader.LoadStream(const aFilename: String; const aStream: TStream): Boolean; | |||||
| var | |||||
| fs: TFileStream; | |||||
| begin | |||||
| result := FileExists(aFilename); | |||||
| if result then begin | |||||
| fs := TFileStream.Create(aFilename, fmOpenRead); | |||||
| try | |||||
| aStream.CopyFrom(fs, fs.Size - fs.Position); | |||||
| finally | |||||
| FreeAndNil(fs); | |||||
| end; | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlSimpleFileWriter////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlSimpleFileWriter.SaveStream(const aFilename: String; const aStream: TStream); | |||||
| var | |||||
| fs: TFileStream; | |||||
| begin | |||||
| fs := TFileStream.Create(aFilename, fmCreate); | |||||
| try | |||||
| fs.CopyFrom(aStream, aStream.Size - aStream.Position); | |||||
| finally | |||||
| FreeAndNil(fs); | |||||
| end; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlFileReaderProxy/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| function TutlFileReaderProxy.LoadStream(const aFilename: String; const aStream: TStream): Boolean; | |||||
| var | |||||
| dir, name: String; | |||||
| begin | |||||
| dir := ExtractFilePath(aFilename); | |||||
| name := ExtractFileName(aFilename); | |||||
| result := fReader.LoadStream(dir + fPrefix + name, aStream); | |||||
| end; | |||||
| constructor TutlFileReaderProxy.Create(const aReader: IutlFileReader; const aPrefix: String); | |||||
| begin | |||||
| inherited Create; | |||||
| fReader := aReader; | |||||
| fPrefix := aPrefix; | |||||
| end; | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //TutlFileWriterProxy/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| procedure TutlFileWriterProxy.SaveStream(const aFilename: String; const aStream: TStream); | |||||
| var | |||||
| dir, name: String; | |||||
| begin | |||||
| dir := ExtractFilePath(aFilename); | |||||
| name := ExtractFileName(aFilename); | |||||
| fWriter.SaveStream(dir + fPrefix + name, aStream); | |||||
| end; | |||||
| constructor TutlFileWriterProxy.Create(const aWriter: IutlFileWriter; const aPrefix: String); | |||||
| begin | |||||
| inherited Create; | |||||
| fWriter := aWriter; | |||||
| fPrefix := aPrefix; | |||||
| end; | |||||
| end. | |||||
| @@ -1,88 +0,0 @@ | |||||
| {$IF defined(__SET_INTERFACE)} | |||||
| type __SET_HELPER = class | |||||
| public | |||||
| class function {%H}ToString(const Value: __SET_TYPE): String; reintroduce; | |||||
| class function TryToSet(const Str: String; out Value: __SET_TYPE): boolean; overload; | |||||
| class function ToSet(const Str: String; const aDefault: __SET_TYPE): __SET_TYPE; overload; | |||||
| class function ToSet(const Str: String): __SET_TYPE; overload; | |||||
| class function Compare(const aSet1, aSet2: __SET_TYPE): Integer; | |||||
| end; | |||||
| {$ELSEIF defined (__SET_IMPLEMENTATION)} | |||||
| class function __SET_HELPER.ToString(const Value: __SET_TYPE): String; | |||||
| var | |||||
| m: __ENUM_TYPE; | |||||
| begin | |||||
| Result:= ''; | |||||
| for m in __ENUM_HELPER.Values do | |||||
| if m in Value then begin | |||||
| if Result > '' then | |||||
| Result:= Result + ', '; | |||||
| Result:= Result + __ENUM_HELPER.ToString(m); | |||||
| end; | |||||
| end; | |||||
| class function __SET_HELPER.ToSet(const Str: String): __SET_TYPE; | |||||
| begin | |||||
| if not TryToSet(Str, Result) then | |||||
| raise SysUtils.EConvertError.CreateFmt('"%s" is an invalid value',[Str]); | |||||
| end; | |||||
| class function __SET_HELPER.ToSet(const Str: String; const aDefault: __SET_TYPE): __SET_TYPE; | |||||
| begin | |||||
| if not TryToSet(Str, Result) then | |||||
| Result:= aDefault; | |||||
| end; | |||||
| class function __SET_HELPER.TryToSet(const Str: String; out Value: __SET_TYPE): boolean; | |||||
| var | |||||
| i, j: Integer; | |||||
| s: String; | |||||
| m: __ENUM_TYPE; | |||||
| begin | |||||
| Result:= true; | |||||
| Value := []; | |||||
| i := 1; | |||||
| j := 1; | |||||
| while (i <= Length(Str)) do begin | |||||
| if (Str[i] = ',') then begin | |||||
| s := Trim(copy(Str, j, i-j)); | |||||
| Result:= Result and __ENUM_HELPER.TryToEnum(s, m); | |||||
| if not Result then | |||||
| Exit; | |||||
| Include(Value, m); | |||||
| j := i+1; | |||||
| end; | |||||
| inc(i); | |||||
| end; | |||||
| s := Trim(copy(Str, j, i-j)); | |||||
| if (s <> '') then begin | |||||
| Result:= Result and __ENUM_HELPER.TryToEnum(s, m); | |||||
| if not Result then | |||||
| Exit; | |||||
| Include(Value, m); | |||||
| end; | |||||
| end; | |||||
| class function __SET_HELPER.Compare(const aSet1, aSet2: __SET_TYPE): Integer; | |||||
| var | |||||
| i: __ENUM_TYPE; | |||||
| begin | |||||
| result := 0; | |||||
| for i := High(i) downto Low(i) do begin | |||||
| if (i in aSet1) and not (i in aSet2) then begin | |||||
| result := 1; | |||||
| break; | |||||
| end else if not (i in aSet1) and (i in aSet2) then begin | |||||
| result := -1; | |||||
| break; | |||||
| end; | |||||
| end; | |||||
| end; | |||||
| {$ENDIF} | |||||
| {$undef __SET_HELPER} | |||||
| {$undef __SET_TYPE} | |||||
| {$undef __ENUM_TYPE} | |||||
| {$undef __ENUM_HELPER} | |||||
| @@ -1,406 +0,0 @@ | |||||
| unit uutlSettings; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit stellt ein Framework zur Verfügung mit dessen Hilfe Einstellungs-Blöcke | |||||
| in ein MCF File geladen und geschreieben werden können } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils, | |||||
| uutlMCF, uutlGenerics, uutlMessageThread; | |||||
| type | |||||
| TutlSettingsBlock = class | |||||
| constructor Create; virtual; | |||||
| procedure LoadDefaults; virtual; abstract; | |||||
| procedure LoadFromConfig(const aMcf: TutlMCFSection); virtual; abstract; | |||||
| procedure SaveToConfig(const aMcf: TutlMCFSection); virtual; abstract; | |||||
| end; | |||||
| TutlSettingsBlockClass = class of TutlSettingsBlock; | |||||
| TutlSettingsUpdateOp = (opInstanceChanged, opDataChanged); | |||||
| TutlSettingsUpdateEvent = procedure (const aUpdateOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock) of object; | |||||
| TutlSettingsUpdateEventCntr = packed record | |||||
| Callback: TutlSettingsUpdateEvent; | |||||
| ThreadID: TThreadID; | |||||
| end; | |||||
| TutlSettingsUpdateEventCntrEqComp = class(TInterfacedObject, specialize IutlEqualityComparer<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{$IFDEF USE_VFS}, uvfsManager{$ENDIF}, uutlMessages, syncobjs; | |||||
| const | |||||
| SETTINGS_MSG_WAIT_TIME = 1000; //ms | |||||
| type | |||||
| TSettingsBlockChangedMsg = class(TutlSyncCallbackMsg) | |||||
| private | |||||
| fCallback: TutlSettingsUpdateEvent; | |||||
| fOperation: TutlSettingsUpdateOp; | |||||
| fOld: TutlSettingsBlock; | |||||
| fNew: TutlSettingsBlock; | |||||
| public | |||||
| procedure ExecuteCallback; override; | |||||
| constructor Create(const aCallback: TutlSettingsUpdateEvent; const aOp: TutlSettingsUpdateOp; | |||||
| const aOld, aNew: TutlSettingsBlock); | |||||
| end; | |||||
| operator = (const i1, i2: TutlSettingsUpdateEventCntr): Boolean; | |||||
| begin | |||||
| result := | |||||
| (i1.Callback = i2.Callback) and | |||||
| (i2.ThreadID = i2.ThreadID); | |||||
| end; | |||||
| function TutlSettingsUpdateEventCntrEqComp.EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean; | |||||
| begin | |||||
| result := (i1 = i2); | |||||
| end; | |||||
| { TSettingsBlockChangedMsg } | |||||
| procedure TSettingsBlockChangedMsg.ExecuteCallback; | |||||
| begin | |||||
| fCallback(fOperation, fOld, fNew); | |||||
| end; | |||||
| constructor TSettingsBlockChangedMsg.Create(const aCallback: TutlSettingsUpdateEvent; | |||||
| const aOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock); | |||||
| begin | |||||
| inherited Create; | |||||
| fCallback := aCallback; | |||||
| fOperation := aOp; | |||||
| fOld := aOld; | |||||
| fNew := aNew; | |||||
| end; | |||||
| { TutlSettings.TBlockData } | |||||
| procedure TutlSettings.TBlockData.CallEvents(const aOp: TutlSettingsUpdateOp; | |||||
| const aOld, aNew: TutlSettingsBlock); | |||||
| var | |||||
| current: TThreadID; | |||||
| cntr: TutlSettingsUpdateEventCntr; | |||||
| msg: TSettingsBlockChangedMsg; | |||||
| begin | |||||
| current := GetCurrentThreadId; | |||||
| for cntr in Events do begin | |||||
| if (cntr.ThreadID <> current) then begin | |||||
| msg := TSettingsBlockChangedMsg.Create(cntr.Callback, aOp, aOld, aNew); | |||||
| if utlSendMessage(cntr.ThreadID, msg, SETTINGS_MSG_WAIT_TIME) = wrSignaled then | |||||
| msg.Free; | |||||
| end else | |||||
| cntr.Callback(aOp, aOld, aNew); | |||||
| end; | |||||
| end; | |||||
| constructor TutlSettings.TBlockData.Create; | |||||
| begin | |||||
| inherited; | |||||
| Events:= TutlSettingsUpdateEventList.Create(TutlSettingsUpdateEventCntrEqComp.Create); | |||||
| end; | |||||
| destructor TutlSettings.TBlockData.Destroy; | |||||
| begin | |||||
| FreeAndNil(Events); | |||||
| FreeAndNil(Instance); | |||||
| FreeAndNil(OldInstance); | |||||
| inherited Destroy; | |||||
| end; | |||||
| { TutlSettingsBlock } | |||||
| constructor TutlSettingsBlock.Create; | |||||
| begin | |||||
| inherited; | |||||
| LoadDefaults; | |||||
| end; | |||||
| { TutlSettings } | |||||
| function TutlSettings.RegisterBlock(const aName: String; const aClass: TutlSettingsBlockClass; | |||||
| const aOnUpdateEvent: TutlSettingsUpdateEvent): TutlSettingsBlock; | |||||
| var | |||||
| i: integer; | |||||
| bd: TBlockData; | |||||
| cntr: TutlSettingsUpdateEventCntr; | |||||
| begin | |||||
| Result:= nil; | |||||
| if aName = '' then | |||||
| raise EInvalidOperation.Create('Empty Settings section name.'); | |||||
| i:= fBlocks.IndexOf(aName); | |||||
| if i>=0 then begin | |||||
| bd:= fBlocks.ValueAt[i]; | |||||
| // gleicher name, instance ist gleiche oder spezifischere klasse | |||||
| if bd.Instance is aClass then begin | |||||
| if Assigned(aOnUpdateEvent) then begin | |||||
| cntr.Callback := aOnUpdateEvent; | |||||
| cntr.ThreadID := GetCurrentThreadId; | |||||
| bd.Events.Add(cntr); | |||||
| end; | |||||
| Exit(bd.Instance) | |||||
| end else | |||||
| // gleicher name, neue klasse ist spezifischer | |||||
| if aClass.InheritsFrom(bd.Instance.ClassType) then begin | |||||
| Result:= aClass.Create; | |||||
| CopyInstance(bd.Instance, Result); | |||||
| bd.CallEvents(opInstanceChanged, bd.Instance, Result); | |||||
| bd.Instance.Free; | |||||
| bd.OldInstance.Free; | |||||
| bd.Instance:= aClass.Create; | |||||
| bd.OldInstance:= aClass.Create; | |||||
| if Assigned(aOnUpdateEvent) then begin | |||||
| cntr.Callback := aOnUpdateEvent; | |||||
| cntr.ThreadID := GetCurrentThreadId; | |||||
| bd.Events.Add(cntr); | |||||
| end; | |||||
| Exit; | |||||
| end | |||||
| // gleicher name, aber komplett andere klasse | |||||
| else | |||||
| raise EInvalidOperation.CreateFmt('Duplicate Settings entry: %s', [aName]); | |||||
| end; | |||||
| for bd in fBlocks do | |||||
| // verwandte klasse aber anderer name (wäre es der gleiche wäre das schon oben abgefangen) | |||||
| if (bd.Instance is aClass) or (aClass.InheritsFrom(bd.Instance.ClassType)) then | |||||
| raise EInvalidOperation.CreateFmt('Reused Settings class: %s', [aClass.ClassName]); | |||||
| // neuer name, neue klasse | |||||
| bd:= TBlockData.Create; | |||||
| bd.Instance:= aClass.Create; | |||||
| bd.OldInstance:= aClass.Create; | |||||
| if Assigned(aOnUpdateEvent) then begin | |||||
| cntr.Callback := aOnUpdateEvent; | |||||
| cntr.ThreadID := GetCurrentThreadId; | |||||
| bd.Events.Add(cntr); | |||||
| end; | |||||
| fBlocks.Add(aName, bd); | |||||
| Result:= bd.Instance; | |||||
| end; | |||||
| procedure TutlSettings.UnregisterBlockCallback(const aName: String; const aOnUpdateEvent: TutlSettingsUpdateEvent); | |||||
| var | |||||
| i: integer; | |||||
| bd: TBlockData; | |||||
| begin | |||||
| i:= fBlocks.IndexOf(aName); | |||||
| if i >= 0 then begin | |||||
| bd := fBlocks.ValueAt[i]; | |||||
| for i := bd.Events.Count-1 downto 0 do | |||||
| if (bd.Events.Items[i].Callback = aOnUpdateEvent) then | |||||
| bd.Events.Delete(i); | |||||
| end; | |||||
| end; | |||||
| procedure TutlSettings.UnregisterBlockCallbacks(const aObj: TObject); | |||||
| var | |||||
| bd: TBlockData; | |||||
| i: integer; | |||||
| begin | |||||
| for bd in fBlocks do | |||||
| for i:= bd.Events.Count-1 downto 0 do | |||||
| if TMethod(bd.Events[i].Callback).Data = Pointer(aObj) then | |||||
| bd.Events.Delete(i); | |||||
| end; | |||||
| procedure TutlSettings.CopyInstance(O, N: TutlSettingsBlock); | |||||
| var | |||||
| tmp: TutlMCFSection; | |||||
| begin | |||||
| tmp:= TutlMCFSection.Create; | |||||
| try | |||||
| O.SaveToConfig(tmp); | |||||
| N.LoadFromConfig(tmp); | |||||
| finally | |||||
| FreeAndNil(tmp); | |||||
| end; | |||||
| end; | |||||
| function TutlSettings.Block(const aName: String; out aBlock): boolean; | |||||
| var | |||||
| i: integer; | |||||
| bd: TBlockData; | |||||
| begin | |||||
| i := fBlocks.IndexOf(aName); | |||||
| Result := (i >= 0); | |||||
| if Result then begin | |||||
| bd:= fBlocks.ValueAt[i]; | |||||
| CopyInstance(bd.Instance, bd.OldInstance); | |||||
| TutlSettingsBlock(aBlock):= bd.Instance; | |||||
| end; | |||||
| end; | |||||
| procedure TutlSettings.Changed(const aBlock: TutlSettingsBlock); | |||||
| var | |||||
| bd: TBlockData; | |||||
| begin | |||||
| for bd in fBlocks do | |||||
| if bd.Instance = aBlock then begin | |||||
| bd.CallEvents(opDataChanged, bd.OldInstance, bd.Instance); | |||||
| exit; | |||||
| end; | |||||
| end; | |||||
| procedure TutlSettings.LoadFromConfig(const aMcf: TutlMCFSection); | |||||
| var | |||||
| i: Integer; | |||||
| b: TBlockData; | |||||
| begin | |||||
| for i := 0 to fBlocks.Count-1 do begin | |||||
| b := fBlocks.ValueAt[i]; | |||||
| b.Instance.LoadFromConfig(aMcf.Section(fBlocks.Keys[i])); | |||||
| if fRaiseChangedEventOnLoad then | |||||
| Changed(b.Instance); | |||||
| end; | |||||
| end; | |||||
| procedure TutlSettings.SaveToConfig(const aMcf: TutlMCFSection); | |||||
| var | |||||
| i: integer; | |||||
| begin | |||||
| for i:= 0 to fBlocks.Count-1 do | |||||
| fBlocks.ValueAt[i].Instance.SaveToConfig(aMcf.Section(fBlocks.Keys[i])); | |||||
| end; | |||||
| {$IFDEF USE_VFS} | |||||
| procedure TutlSettings.LoadFromFile(const aFile: string); | |||||
| var | |||||
| sh: IStreamHandle; | |||||
| mcf: TutlMCFFile; | |||||
| begin | |||||
| if vfsManager.ReadFile(aFile, sh) then begin | |||||
| mcf:= TutlMCFFile.Create(sh); | |||||
| try | |||||
| LoadFromConfig(mcf); | |||||
| finally | |||||
| FreeAndNil(mcf); | |||||
| end; | |||||
| end; | |||||
| end; | |||||
| {$ELSE} | |||||
| procedure TutlSettings.LoadFromFile(const aFile: string); | |||||
| var | |||||
| fs: TFileStream; | |||||
| mcf: TutlMCFFile; | |||||
| begin | |||||
| fs := TFileStream.Create(aFile, fmOpenRead); | |||||
| mcf := TutlMCFFile.Create(nil); | |||||
| try | |||||
| mcf.LoadFromStream(fs); | |||||
| LoadFromConfig(mcf); | |||||
| finally | |||||
| FreeAndNil(fs); | |||||
| end; | |||||
| end; | |||||
| {$ENDIF} | |||||
| {$IFDEF USE_VFS} | |||||
| procedure TutlSettings.SaveToFile(const aFile: string); | |||||
| var | |||||
| sh: IStreamHandle; | |||||
| mcf: TutlMCFFile; | |||||
| begin | |||||
| if vfsManager.CreateFile(aFile, sh) then begin | |||||
| mcf:= TutlMCFFile.Create(nil); | |||||
| try | |||||
| SaveToConfig(mcf); | |||||
| mcf.SaveToStream(sh); | |||||
| finally | |||||
| FreeAndNil(mcf); | |||||
| end; | |||||
| end; | |||||
| end; | |||||
| {$ELSE} | |||||
| procedure TutlSettings.SaveToFile(const aFile: string); | |||||
| var | |||||
| fs: TFileStream; | |||||
| mcf: TutlMCFFile; | |||||
| begin | |||||
| fs := TFileStream.Create(aFile, fmCreate); | |||||
| mcf := TutlMCFFile.Create(nil); | |||||
| try | |||||
| SaveToConfig(mcf); | |||||
| mcf.SaveToStream(fs); | |||||
| finally | |||||
| FreeAndNil(mcf); | |||||
| FreeAndNil(fs); | |||||
| end; | |||||
| end; | |||||
| {$ENDIF} | |||||
| constructor TutlSettings.Create; | |||||
| begin | |||||
| inherited Create; | |||||
| fBlocks:= TBlockList.Create(true); | |||||
| fRaiseChangedEventOnLoad := true; | |||||
| end; | |||||
| destructor TutlSettings.Destroy; | |||||
| begin | |||||
| FreeAndNil(fBlocks); | |||||
| inherited Destroy; | |||||
| end; | |||||
| initialization | |||||
| utlSettings := TutlSettings.Create; | |||||
| finalization | |||||
| FreeAndNil(utlSettings); | |||||
| end. | |||||
| @@ -1,523 +0,0 @@ | |||||
| unit uutlSystemInfo; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit enthält Klassen zum Auslesen von System Informationen (CPU, Grafikkarte, OpenGL) } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes, SysUtils, uutlGenerics | |||||
| {$IFDEF WINDOWS}, ActiveX, ComObj, variants {$ENDIF}; | |||||
| type | |||||
| //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||||
| TutlSystemInfo = class; | |||||
| TutlSystemInfoList = specialize TutlList<TutlSystemInfo>; | |||||
| 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. | |||||
| @@ -1,90 +0,0 @@ | |||||
| unit uutlTiming; | |||||
| { Package: Utils | |||||
| Prefix: utl - UTiLs | |||||
| Beschreibung: diese Unit enthält platformunabhängige Methoden für Zeitberechnungen und -messungen | |||||
| Mehr oder weniger platformunabhängige Timestampgenerierung. | |||||
| GetTickCount64 ms-Timer | |||||
| GetMicroTime us-Timer analog php microtime() | |||||
| Achtung: windows.pp deklariert auch eine GetTickCount64, wird gegen diese gelinkt | |||||
| läuft die exe nicht mehr unter XP. Unbeding uutlTiming *nach* windows einbinden. } | |||||
| {$mode objfpc}{$H+} | |||||
| interface | |||||
| uses | |||||
| Classes | |||||
| {$ifdef Windows} | |||||
| , Windows | |||||
| {$else} | |||||
| , Unix, BaseUnix | |||||
| {$endif}; | |||||
| function GetTickCount64: QWord; | |||||
| function GetMicroTime: QWord; | |||||
| function utlRateLimited(const Reference: QWord; const Interval: QWord): boolean; | |||||
| implementation | |||||
| {$IF defined(WINDOWS)} | |||||
| var | |||||
| PERF_FREQ: Int64; | |||||
| function GetTickCount64: QWord; | |||||
| begin | |||||
| // GetTickCount64 is better, but we need to check the Windows version to use it | |||||
| Result := Windows.GetTickCount(); | |||||
| end; | |||||
| function GetMicroTime: QWord; | |||||
| var | |||||
| pc: Int64; | |||||
| begin | |||||
| pc := 0; | |||||
| QueryPerformanceCounter(pc); | |||||
| Result:= (pc * 1000*1000) div PERF_FREQ; | |||||
| end; | |||||
| {$ELSEIF defined(UNIX)} | |||||
| function GetTickCount64: QWord; | |||||
| var | |||||
| tp: TTimeVal; | |||||
| begin | |||||
| fpgettimeofday(@tp, nil); | |||||
| Result := (Int64(tp.tv_sec) * 1000) + (tp.tv_usec div 1000); | |||||
| end; | |||||
| function GetMicroTime: QWord; | |||||
| var | |||||
| tp: TTimeVal; | |||||
| begin | |||||
| fpgettimeofday(@tp, nil); | |||||
| Result := (Int64(tp.tv_sec) * 1000*1000) + tp.tv_usec; | |||||
| end; | |||||
| {$ELSE} | |||||
| function GetTickCount64: QWord; | |||||
| begin | |||||
| Result := Trunc(Now * 24 * 60 * 60 * 1000); | |||||
| end; | |||||
| function GetMicroTime: QWord; | |||||
| begin | |||||
| Result := Trunc(Now * 24 * 60 * 60 * 1000*1000); | |||||
| end; | |||||
| {$ENDIF} | |||||
| function utlRateLimited(const Reference: QWord; const Interval: QWord): boolean; | |||||
| begin | |||||
| Result:= GetMicroTime - Reference > Interval; | |||||
| end; | |||||
| initialization | |||||
| {$IF defined(WINDOWS)} | |||||
| PERF_FREQ := 0; | |||||
| QueryPerformanceFrequency(PERF_FREQ); | |||||
| {$ENDIF} | |||||
| end. | |||||