Ver código fonte

* removed unneeded and old files

master
bergmann 10 anos atrás
pai
commit
65ae15f8a3
20 arquivos alterados com 0 adições e 6688 exclusões
  1. BIN
     
  2. +0
    -90
      Tests/UtilsTests.lpi
  3. +0
    -23
      Tests/UtilsTests.lpr
  4. +0
    -110
      Tests/UtilsTests.lps
  5. BIN
     
  6. +0
    -1252
      Tests/uGenericsTests.pas
  7. +0
    -2128
      uutlConsoleHelper.pas
  8. +0
    -66
      uutlConversion.pas
  9. +0
    -413
      uutlGraph.pas
  10. +0
    -244
      uutlLocalization.pas
  11. +0
    -100
      uutlMcfHelper.pas
  12. +0
    -396
      uutlMessageThread.pas
  13. +0
    -171
      uutlMessages.pas
  14. +0
    -369
      uutlObservableGenerics.pas
  15. +0
    -93
      uutlPlatform.pas
  16. +0
    -126
      uutlSerialization.pas
  17. +0
    -88
      uutlSetHelper.inc
  18. +0
    -406
      uutlSettings.pas
  19. +0
    -523
      uutlSystemInfo.pas
  20. +0
    -90
      uutlTiming.pas

+ 0
- 90
Tests/UtilsTests.lpi Ver arquivo

@@ -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>

+ 0
- 23
Tests/UtilsTests.lpr Ver arquivo

@@ -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.


+ 0
- 110
Tests/UtilsTests.lps Ver arquivo

@@ -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>


+ 0
- 1252
Tests/uGenericsTests.pas
Diferenças do arquivo suprimidas por serem muito extensas
Ver arquivo


+ 0
- 2128
uutlConsoleHelper.pas
Diferenças do arquivo suprimidas por serem muito extensas
Ver arquivo


+ 0
- 66
uutlConversion.pas Ver arquivo

@@ -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.


+ 0
- 413
uutlGraph.pas Ver arquivo

@@ -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.


+ 0
- 244
uutlLocalization.pas Ver arquivo

@@ -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.


+ 0
- 100
uutlMcfHelper.pas Ver arquivo

@@ -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.


+ 0
- 396
uutlMessageThread.pas Ver arquivo

@@ -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.


+ 0
- 171
uutlMessages.pas Ver arquivo

@@ -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.


+ 0
- 369
uutlObservableGenerics.pas Ver arquivo

@@ -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.


+ 0
- 93
uutlPlatform.pas Ver arquivo

@@ -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.


+ 0
- 126
uutlSerialization.pas Ver arquivo

@@ -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.


+ 0
- 88
uutlSetHelper.inc Ver arquivo

@@ -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}

+ 0
- 406
uutlSettings.pas Ver arquivo

@@ -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.


+ 0
- 523
uutlSystemInfo.pas Ver arquivo

@@ -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.


+ 0
- 90
uutlTiming.pas Ver arquivo

@@ -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.


Carregando…
Cancelar
Salvar