@@ -0,0 +1,84 @@ | |||
<?xml version="1.0" encoding="UTF-8"?> | |||
<CONFIG> | |||
<ProjectOptions> | |||
<Version Value="9"/> | |||
<PathDelim Value="\"/> | |||
<General> | |||
<SessionStorage Value="InProjectDir"/> | |||
<MainUnit Value="0"/> | |||
<Title Value="UtilsTests"/> | |||
<ResourceType Value="res"/> | |||
<UseXPManifest Value="True"/> | |||
<Icon Value="0"/> | |||
</General> | |||
<i18n> | |||
<EnableI18N LFM="False"/> | |||
</i18n> | |||
<VersionInfo> | |||
<StringTable ProductVersion=""/> | |||
</VersionInfo> | |||
<BuildModes Count="1"> | |||
<Item1 Name="Default" Default="True"/> | |||
</BuildModes> | |||
<PublishOptions> | |||
<Version Value="2"/> | |||
</PublishOptions> | |||
<RunParams> | |||
<local> | |||
<FormatVersion Value="1"/> | |||
</local> | |||
</RunParams> | |||
<RequiredPackages Count="3"> | |||
<Item1> | |||
<PackageName Value="FPCUnitTestRunner"/> | |||
</Item1> | |||
<Item2> | |||
<PackageName Value="LCL"/> | |||
</Item2> | |||
<Item3> | |||
<PackageName Value="FCL"/> | |||
</Item3> | |||
</RequiredPackages> | |||
<Units Count="2"> | |||
<Unit0> | |||
<Filename Value="UtilsTests.lpr"/> | |||
<IsPartOfProject Value="True"/> | |||
</Unit0> | |||
<Unit1> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<IsPartOfProject Value="True"/> | |||
<UnitName Value="uGenericsTests"/> | |||
</Unit1> | |||
</Units> | |||
</ProjectOptions> | |||
<CompilerOptions> | |||
<Version Value="11"/> | |||
<PathDelim Value="\"/> | |||
<Target> | |||
<Filename Value="UtilsTests"/> | |||
</Target> | |||
<SearchPaths> | |||
<IncludeFiles Value="$(ProjOutDir)"/> | |||
<OtherUnitFiles Value=".."/> | |||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> | |||
</SearchPaths> | |||
<Linking> | |||
<Debugging> | |||
<UseHeaptrc Value="True"/> | |||
</Debugging> | |||
</Linking> | |||
</CompilerOptions> | |||
<Debugging> | |||
<Exceptions Count="3"> | |||
<Item1> | |||
<Name Value="EAbort"/> | |||
</Item1> | |||
<Item2> | |||
<Name Value="ECodetoolError"/> | |||
</Item2> | |||
<Item3> | |||
<Name Value="EFOpenError"/> | |||
</Item3> | |||
</Exceptions> | |||
</Debugging> | |||
</CONFIG> |
@@ -0,0 +1,23 @@ | |||
program UtilsTests; | |||
{$mode objfpc}{$H+} | |||
uses | |||
sysutils, Interfaces, Forms, GuiTestRunner, uGenericsTests; | |||
{$R *.res} | |||
var | |||
heaptrcFile: String; | |||
begin | |||
heaptrcFile := ChangeFileExt(Application.ExeName, '.heaptrc'); | |||
if (FileExists(heaptrcFile)) then | |||
DeleteFile(heaptrcFile); | |||
SetHeapTraceOutput(heaptrcFile); | |||
Application.Initialize; | |||
Application.CreateForm(TGuiTestRunner, TestRunner); | |||
Application.Run; | |||
end. | |||
@@ -0,0 +1,170 @@ | |||
<?xml version="1.0" encoding="UTF-8"?> | |||
<CONFIG> | |||
<ProjectSession> | |||
<PathDelim Value="\"/> | |||
<Version Value="9"/> | |||
<BuildModes Active="Default"/> | |||
<Units Count="5"> | |||
<Unit0> | |||
<Filename Value="UtilsTests.lpr"/> | |||
<IsPartOfProject Value="True"/> | |||
<EditorIndex Value="2"/> | |||
<CursorPos X="12" Y="6"/> | |||
<UsageCount Value="22"/> | |||
<Loaded Value="True"/> | |||
</Unit0> | |||
<Unit1> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<IsPartOfProject Value="True"/> | |||
<UnitName Value="uGenericsTests"/> | |||
<IsVisibleTab Value="True"/> | |||
<TopLine Value="559"/> | |||
<CursorPos X="54" Y="580"/> | |||
<UsageCount Value="22"/> | |||
<Loaded Value="True"/> | |||
</Unit1> | |||
<Unit2> | |||
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\packages\fcl-fpcunit\src\fpcunit.pp"/> | |||
<UnitName Value="fpcunit"/> | |||
<EditorIndex Value="1"/> | |||
<TopLine Value="113"/> | |||
<CursorPos X="21" Y="129"/> | |||
<UsageCount Value="11"/> | |||
<Loaded Value="True"/> | |||
</Unit2> | |||
<Unit3> | |||
<Filename Value="..\uutlGenerics.pas"/> | |||
<UnitName Value="uutlGenerics"/> | |||
<EditorIndex Value="3"/> | |||
<TopLine Value="308"/> | |||
<CursorPos X="15" Y="111"/> | |||
<UsageCount Value="11"/> | |||
<Loaded Value="True"/> | |||
</Unit3> | |||
<Unit4> | |||
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\wstringh.inc"/> | |||
<EditorIndex Value="-1"/> | |||
<CursorPos X="11" Y="30"/> | |||
<UsageCount Value="10"/> | |||
</Unit4> | |||
</Units> | |||
<JumpHistory Count="29" HistoryIndex="28"> | |||
<Position1> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="376" Column="30" TopLine="359"/> | |||
</Position1> | |||
<Position2> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="470" Column="13" TopLine="447"/> | |||
</Position2> | |||
<Position3> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="472" Column="41" TopLine="446"/> | |||
</Position3> | |||
<Position4> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="88" Column="23" TopLine="63"/> | |||
</Position4> | |||
<Position5> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="97" TopLine="86"/> | |||
</Position5> | |||
<Position6> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="86" Column="8" TopLine="74"/> | |||
</Position6> | |||
<Position7> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="101" Column="20" TopLine="88"/> | |||
</Position7> | |||
<Position8> | |||
<Filename Value="..\uutlGenerics.pas"/> | |||
<Caret Line="303" Column="50" TopLine="284"/> | |||
</Position8> | |||
<Position9> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="524" Column="14" TopLine="514"/> | |||
</Position9> | |||
<Position10> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="89" Column="50" TopLine="74"/> | |||
</Position10> | |||
<Position11> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="90" Column="37" TopLine="70"/> | |||
</Position11> | |||
<Position12> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="530" Column="33" TopLine="509"/> | |||
</Position12> | |||
<Position13> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="583" Column="32" TopLine="565"/> | |||
</Position13> | |||
<Position14> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="598" Column="5" TopLine="567"/> | |||
</Position14> | |||
<Position15> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="655" Column="19" TopLine="626"/> | |||
</Position15> | |||
<Position16> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="95" Column="29" TopLine="85"/> | |||
</Position16> | |||
<Position17> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="666" Column="45" TopLine="657"/> | |||
</Position17> | |||
<Position18> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="563" Column="23" TopLine="547"/> | |||
</Position18> | |||
<Position19> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="566" Column="23" TopLine="547"/> | |||
</Position19> | |||
<Position20> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="687" TopLine="663"/> | |||
</Position20> | |||
<Position21> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="686" Column="58" TopLine="670"/> | |||
</Position21> | |||
<Position22> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="700" Column="9" TopLine="682"/> | |||
</Position22> | |||
<Position23> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="704" Column="38" TopLine="692"/> | |||
</Position23> | |||
<Position24> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="700" Column="19" TopLine="685"/> | |||
</Position24> | |||
<Position25> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="612" TopLine="587"/> | |||
</Position25> | |||
<Position26> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="717" Column="17" TopLine="689"/> | |||
</Position26> | |||
<Position27> | |||
<Filename Value="..\uutlGenerics.pas"/> | |||
<Caret Line="1161" Column="3" TopLine="1148"/> | |||
</Position27> | |||
<Position28> | |||
<Filename Value="..\uutlGenerics.pas"/> | |||
<Caret Line="887" Column="3" TopLine="884"/> | |||
</Position28> | |||
<Position29> | |||
<Filename Value="uGenericsTests.pas"/> | |||
<Caret Line="658" Column="28" TopLine="652"/> | |||
</Position29> | |||
</JumpHistory> | |||
</ProjectSession> | |||
</CONFIG> |
@@ -0,0 +1,710 @@ | |||
unit uGenericsTests; | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, fpcunit, testregistry, | |||
uutlGenerics; | |||
type | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TTestObject = class | |||
private | |||
fData: Integer; | |||
fOnDestroy: TNotifyEvent; | |||
public | |||
property Data: Integer read fData; | |||
constructor Create(const aData: Integer; const aOnDestroy: TNotifyEvent); | |||
destructor Destroy; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlListTest = class(TTestCase) | |||
private type | |||
TTestList = specialize TutlList<TTestObject>; | |||
private | |||
fList: TTestList; | |||
fTestObjs: array[0..9] of TTestObject; | |||
procedure TestObjectDestroy(aSender: TObject); | |||
protected | |||
procedure SetUp; override; | |||
procedure TearDown; override; | |||
published | |||
procedure GetItem; | |||
procedure SetItem; | |||
procedure Add; | |||
procedure Insert; | |||
procedure IndexOf; | |||
procedure Exchange; | |||
procedure Move; | |||
procedure Delete; | |||
procedure Extract; | |||
procedure Remove; | |||
procedure Clear; | |||
procedure First; | |||
procedure PushFirst; | |||
procedure PopFirst; | |||
procedure Last; | |||
procedure PushLast; | |||
procedure PopLast; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlHashSetTest = class(TTestCase) | |||
private type | |||
TTestObjComparer = specialize TutlEventComparer<TTestObject>; | |||
TTestHashSet = specialize TutlCustomHashSet<TTestObject>; | |||
private | |||
fHashSet: TTestHashSet; | |||
fTestObjs: array[0..9] of TTestObject; | |||
procedure TestObjectDestroy(aSender: TObject); | |||
protected | |||
procedure SetUp; override; | |||
procedure TearDown; override; | |||
public | |||
function CompareTestObjects(const i1, i2: TTestObject): Integer; | |||
published | |||
procedure Add; | |||
procedure Contains; | |||
procedure IndexOf; | |||
procedure Remove; | |||
procedure Delete; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlMapTest = class(TTestCase) | |||
private type | |||
TTestMap = specialize TutlMap<Integer, TTestObject>; | |||
private | |||
fMap: TTestMap; | |||
fTestObjs: array[0..9] of TTestObject; | |||
fLastRemovedIndex: Integer; | |||
procedure TestObjectDestroy(aSender: TObject); | |||
function Key(const aIndex: Integer): Integer; | |||
function CreateObj: TTestObject; | |||
protected | |||
procedure SetUp; override; | |||
procedure TearDown; override; | |||
procedure AddExistingKey; | |||
published | |||
procedure GetValue; | |||
procedure SetValue; | |||
procedure GetValueAt; | |||
procedure SetValueAt; | |||
procedure GetKey; | |||
procedure Add; | |||
procedure IndexOf; | |||
procedure Delete; | |||
end; | |||
implementation | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TTestObject/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TTestObject.Create(const aData: Integer; const aOnDestroy: TNotifyEvent); | |||
begin | |||
inherited Create; | |||
fData := aData; | |||
fOnDestroy := aOnDestroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TTestObject.Destroy; | |||
begin | |||
if Assigned(fOnDestroy) then | |||
fOnDestroy(self); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlListTest////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.TestObjectDestroy(aSender: TObject); | |||
var | |||
i: Integer; | |||
begin | |||
for i := Low(fTestObjs) to High(fTestObjs) do | |||
if (fTestObjs[i] = aSender) then | |||
fTestObjs[i] := nil; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.SetUp; | |||
var | |||
i: Integer; | |||
begin | |||
inherited SetUp; | |||
fList := TTestList.Create(true); | |||
for i := Low(fTestObjs) to High(fTestObjs) do begin | |||
fTestObjs[i] := TTestObject.Create(i, @TestObjectDestroy); | |||
fList.Add(fTestObjs[i]); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.TearDown; | |||
begin | |||
FreeAndNil(fList); | |||
inherited TearDown; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.GetItem; | |||
var | |||
i: Integer; | |||
begin | |||
for i := Low(fTestObjs) to High(fTestObjs) do | |||
AssertTrue(fTestObjs[i] = fList[i - Low(fTestObjs)]); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.SetItem; | |||
var | |||
o1, o2: TTestObject; | |||
begin | |||
o1 := fList[3]; | |||
o2 := fList[6]; | |||
fList[3] := o2; | |||
fList[6] := o1; | |||
AssertTrue(fList[6] = o1); | |||
AssertTrue(fList[3] = o2); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Add; | |||
var | |||
t: TTestObject; | |||
c: Integer; | |||
begin | |||
t := TTestObject.Create(123456, @TestObjectDestroy); | |||
c := fList.Count; | |||
fList.Add(t); | |||
AssertEquals(c+1, fList.Count); | |||
AssertTrue(fList[c] = t); | |||
AssertTrue(fList.Last = t); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Insert; | |||
var | |||
t: TTestObject; | |||
c: Integer; | |||
begin | |||
t := TTestObject.Create(123456, @TestObjectDestroy); | |||
c := fList.Count; | |||
fList.Insert(3, t); | |||
AssertEquals(c+1, fList.Count); | |||
AssertTrue(fList[3] = t); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.IndexOf; | |||
var | |||
i: Integer; | |||
begin | |||
for i := Low(fTestObjs) to High(fTestObjs) do | |||
AssertEquals(i - Low(fTestObjs), fList.IndexOf(fTestObjs[i])); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Exchange; | |||
var | |||
o1, o2: TTestObject; | |||
begin | |||
o1 := fList[3]; | |||
o2 := fList[7]; | |||
fList.Exchange(3, 7); | |||
AssertTrue(fList[3] = o2); | |||
AssertTrue(fList[7] = o1); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Move; | |||
begin | |||
fList.Move(3, 6); | |||
AssertTrue(fList[3] = fTestObjs[4]); | |||
AssertTrue(fList[4] = fTestObjs[5]); | |||
AssertTrue(fList[5] = fTestObjs[6]); | |||
AssertTrue(fList[6] = fTestObjs[3]); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Delete; | |||
begin | |||
fList.Delete(3); | |||
AssertTrue(fTestObjs[3] = nil); | |||
AssertEquals(Length(fTestObjs)-1, fList.Count); | |||
fList.OwnsObjects := false; | |||
fList.Delete(4); | |||
AssertTrue(fTestObjs[5] <> nil); | |||
AssertEquals(Length(fTestObjs)-2, fList.Count); | |||
AssertTrue(fList[4] = fTestObjs[6]); | |||
FreeAndNil(fTestObjs[5]); | |||
fList.OwnsObjects := true; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Extract; | |||
var | |||
o1, o2, o3: TTestObject; | |||
begin | |||
o1 := fList[1]; | |||
o2 := TTestObject.Create(1234, @TestObjectDestroy); | |||
o3 := fList.Extract(o1, o2); | |||
try | |||
AssertTrue(o1 = o3); | |||
AssertEquals(Length(fTestObjs)-1, fList.Count); | |||
AssertTrue(fTestObjs[1] <> nil); | |||
finally | |||
FreeAndNil(o1); | |||
FreeAndNil(o2); | |||
end; | |||
o1 := fList[1]; | |||
o2 := TTestObject.Create(1234, @TestObjectDestroy); | |||
o3 := fList.Extract(o2, o1); | |||
try | |||
AssertTrue(o1 = o3); | |||
AssertEquals(Length(fTestObjs)-1, fList.Count); | |||
finally | |||
FreeAndNil(o2); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Remove; | |||
var | |||
o1: TTestObject; | |||
i: Integer; | |||
begin | |||
o1 := fList[3]; | |||
i := fList.Remove(o1); | |||
AssertEquals(3, i); | |||
AssertEquals(Length(fTestObjs)-1, fList.Count); | |||
AssertTrue(fTestObjs[3] = nil); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Clear; | |||
var | |||
o: TTestObject; | |||
begin | |||
fList.Clear; | |||
AssertEquals(0, fList.Count); | |||
for o in fTestObjs do | |||
AssertTrue(o = nil); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.First; | |||
begin | |||
AssertTrue(fTestObjs[Low(fTestObjs)] = fList.First); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.PushFirst; | |||
var | |||
o1: TTestObject; | |||
begin | |||
o1 := TTestObject.Create(1234, @TestObjectDestroy); | |||
fList.PushFirst(o1); | |||
AssertEquals(Length(fTestObjs)+1, fList.Count); | |||
AssertTrue(fList.First = o1); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.PopFirst; | |||
var | |||
o1: TTestObject; | |||
begin | |||
o1 := fList.PopFirst; | |||
AssertEquals(Length(fTestObjs)-1, fList.Count); | |||
AssertTrue(o1 = fTestObjs[0]); | |||
FreeAndNil(o1); | |||
o1 := fList.PopFirst(true); | |||
AssertEquals(Length(fTestObjs)-2, fList.Count); | |||
AssertTrue(o1 = nil); | |||
AssertTrue(fTestObjs[1] = nil); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.Last; | |||
begin | |||
AssertTrue(fTestObjs[High(fTestObjs)] = fList.Last); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.PushLast; | |||
var | |||
o1: TTestObject; | |||
begin | |||
o1 := TTestObject.Create(1234, @TestObjectDestroy); | |||
fList.PushLast(o1); | |||
AssertEquals(Length(fTestObjs)+1, fList.Count); | |||
AssertTrue(fList.Last = o1); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlListTest.PopLast; | |||
var | |||
o1: TTestObject; | |||
begin | |||
o1 := fList.PopLast; | |||
AssertEquals(Length(fTestObjs)-1, fList.Count); | |||
AssertTrue(o1 = fTestObjs[High(fTestObjs)]); | |||
FreeAndNil(o1); | |||
o1 := fList.PopLast(true); | |||
AssertEquals(Length(fTestObjs)-2, fList.Count); | |||
AssertTrue(o1 = nil); | |||
AssertTrue(fTestObjs[High(fTestObjs)-1] = nil); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlHashSetTest/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.TestObjectDestroy(aSender: TObject); | |||
var | |||
i: Integer; | |||
begin | |||
for i := Low(fTestObjs) to High(fTestObjs) do | |||
if (fTestObjs[i] = aSender) then | |||
fTestObjs[i] := nil; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.SetUp; | |||
var | |||
i: Integer; | |||
begin | |||
inherited SetUp; | |||
fHashSet := TTestHashSet.Create(TTestObjComparer.Create(@CompareTestObjects), true); | |||
for i := Low(fTestObjs) to High(fTestObjs) do begin | |||
fTestObjs[i] := TTestObject.Create(i, @TestObjectDestroy); | |||
fHashSet.Add(fTestObjs[i]); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.TearDown; | |||
begin | |||
FreeAndNil(fHashSet); | |||
inherited TearDown; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlHashSetTest.CompareTestObjects(const i1, i2: TTestObject): Integer; | |||
begin | |||
if (i1.Data < i2.Data) then | |||
result := -1 | |||
else if (i1.Data > i2.Data) then | |||
result := 1 | |||
else | |||
result := 0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.Add; | |||
var | |||
o1: TTestObject; | |||
b: Boolean; | |||
begin | |||
o1 := TTestObject.Create(1234, @TestObjectDestroy); | |||
b := fHashSet.Add(o1); | |||
AssertTrue(b); | |||
AssertEquals(Length(fTestObjs)+1, fHashSet.Count); | |||
b := fHashSet.Add(o1); | |||
AssertFalse(b); | |||
AssertEquals(Length(fTestObjs)+1, fHashSet.Count); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.Contains; | |||
var | |||
o1: TTestObject; | |||
b: Boolean; | |||
begin | |||
o1 := TTestObject.Create(1234, @TestObjectDestroy); | |||
try | |||
b := fHashSet.Contains(fTestObjs[0]); | |||
AssertTrue(b); | |||
b := fHashSet.Contains(o1); | |||
AssertFalse(b); | |||
finally | |||
FreeAndNil(o1); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.IndexOf; | |||
var | |||
o1: TTestObject; | |||
i: Integer; | |||
begin | |||
o1 := TTestObject.Create(1234, @TestObjectDestroy); | |||
try | |||
i := fHashSet.IndexOf(fTestObjs[4]); | |||
AssertEquals(4, i); | |||
i := fHashSet.IndexOf(o1); | |||
AssertEquals(-1, i); | |||
finally | |||
FreeAndNil(o1); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.Remove; | |||
var | |||
b: Boolean; | |||
begin | |||
b := fHashSet.Remove(fTestObjs[5]); | |||
AssertTrue(fTestObjs[5] = nil); | |||
AssertTrue(b); | |||
AssertEquals(Length(fTestObjs)-1, fHashSet.Count); | |||
fHashSet.OwnsObjects := false; | |||
try | |||
b := fHashSet.Remove(fTestObjs[0]); | |||
AssertTrue(fTestObjs[0] <> nil); | |||
AssertEquals(Length(fTestObjs)-2, fHashSet.Count); | |||
AssertTrue(b); | |||
b := fHashSet.Remove(fTestObjs[0]); | |||
AssertFalse(b); | |||
AssertEquals(Length(fTestObjs)-2, fHashSet.Count); | |||
finally | |||
FreeAndNil(fTestObjs[0]); | |||
fHashSet.OwnsObjects := true; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlHashSetTest.Delete; | |||
begin | |||
fHashSet.Delete(0); | |||
AssertEquals(Length(fTestObjs)-1, fHashSet.Count); | |||
AssertTrue(fTestObjs[0] = nil); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlMapTest/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.TestObjectDestroy(aSender: TObject); | |||
var | |||
i: Integer; | |||
begin | |||
for i := Low(fTestObjs) to High(fTestObjs) do | |||
if (fTestObjs[i] = aSender) then begin | |||
fLastRemovedIndex := i; | |||
fTestObjs[i] := nil; | |||
exit; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMapTest.Key(const aIndex: Integer): Integer; | |||
begin | |||
result := fTestObjs[aIndex].Data; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMapTest.CreateObj: TTestObject; | |||
var | |||
k: Integer; | |||
begin | |||
repeat | |||
k := random(10000); | |||
until not fMap.Contains(k); | |||
result := TTestObject.Create(k, @TestObjectDestroy); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.SetUp; | |||
var | |||
i: Integer; | |||
o: TTestObject; | |||
begin | |||
inherited SetUp; | |||
fMap := TTestMap.Create(true); | |||
Randomize; | |||
for i := Low(fTestObjs) to High(fTestObjs) do begin | |||
o := CreateObj; | |||
fTestObjs[i] := o; | |||
fMap.Add(o.Data, o); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.TearDown; | |||
begin | |||
FreeAndNil(fMap); | |||
inherited TearDown; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.AddExistingKey; | |||
var | |||
o1: TTestObject; | |||
begin | |||
o1 := TTestObject.Create(fTestObjs[0].Data, @TestObjectDestroy); | |||
try | |||
fMap.Add(o1.Data, o1); | |||
finally | |||
FreeAndNil(o1); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.GetValue; | |||
var | |||
i: Integer; | |||
begin | |||
for i := Low(fTestObjs) to High(fTestObjs) do | |||
AssertTrue(fMap[Key(i)] = fTestObjs[i]); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.SetValue; | |||
var | |||
o1, o2: TTestObject; | |||
begin | |||
o1 := fMap[Key(2)]; | |||
o2 := CreateObj; | |||
fMap[Key(2)] := o2; | |||
try | |||
AssertTrue(fMap[Key(2)] = o2); | |||
finally | |||
FreeAndNil(o1); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.GetValueAt; | |||
type | |||
TIntList = specialize TutlList<Integer>; | |||
TIntComparer = specialize TutlComparer<Integer>; | |||
var | |||
o: TTestObject; | |||
l: TIntList; | |||
i: Integer; | |||
begin | |||
l := TIntList.Create; | |||
try | |||
for o in fTestObjs do | |||
l.Add(o.Data); | |||
l.Sort(TIntComparer.Create); | |||
for i := 0 to l.Count-1 do | |||
AssertEquals(l[i], fMap.ValueAt[i].Data); | |||
finally | |||
FreeAndNil(l); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.SetValueAt; | |||
var | |||
o1, o2: TTestObject; | |||
begin | |||
o1 := fMap.ValueAt[4]; | |||
o2 := TTestObject.Create(o1.Data, @TestObjectDestroy); | |||
fMap.ValueAt[4] := o2; | |||
try | |||
AssertTrue(fMap.ValueAt[4] = o2); | |||
finally | |||
FreeAndNil(o1); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.GetKey; | |||
type | |||
TIntList = specialize TutlList<Integer>; | |||
TIntComparer = specialize TutlComparer<Integer>; | |||
var | |||
o: TTestObject; | |||
l: TIntList; | |||
i: Integer; | |||
begin | |||
l := TIntList.Create; | |||
try | |||
for o in fTestObjs do | |||
l.Add(o.Data); | |||
l.Sort(TIntComparer.Create); | |||
for i := 0 to l.Count-1 do | |||
AssertEquals(l[i], fMap.Keys[i]); | |||
finally | |||
FreeAndNil(l); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.Add; | |||
var | |||
o1: TTestObject; | |||
begin | |||
o1 := CreateObj; | |||
fMap.Add(o1.Data, o1); | |||
AssertEquals(Length(fTestObjs)+1, fMap.Count); | |||
AssertException(EutlMap, @AddExistingKey); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.IndexOf; | |||
type | |||
TIntList = specialize TutlList<Integer>; | |||
TIntComparer = specialize TutlComparer<Integer>; | |||
var | |||
o: TTestObject; | |||
l: TIntList; | |||
begin | |||
l := TIntList.Create; | |||
try | |||
for o in fTestObjs do | |||
l.Add(o.Data); | |||
l.Sort(TIntComparer.Create); | |||
for o in fTestObjs do | |||
AssertEquals(l.IndexOf(o.Data), fMap.IndexOf(o.Data)); | |||
finally | |||
FreeAndNil(l); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMapTest.Delete; | |||
var | |||
i: Integer; | |||
begin | |||
for i := Low(fTestObjs) to High(fTestObjs) do begin | |||
fMap.Delete(Key(i)); | |||
AssertNull(fTestObjs[i]); | |||
AssertEquals('Count', Length(fTestObjs)-i-1, fMap.Count); | |||
AssertEquals('Index', fLastRemovedIndex, i); | |||
end; | |||
end; | |||
initialization | |||
RegisterTest(TutlListTest); | |||
RegisterTest(TutlHashSetTest); | |||
RegisterTest(TutlMapTest); | |||
end. | |||
@@ -0,0 +1,394 @@ | |||
unit uutlCommon; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit implementiert allgemein nützliche nicht-generische Klassen } | |||
{$mode objfpc}{$H+} | |||
{$modeswitch nestedprocvars} | |||
interface | |||
uses | |||
Classes, SysUtils, syncobjs, versionresource, versiontypes, typinfo, uutlGenerics | |||
{$IFDEF UNIX}, unixtype, pthreads {$ENDIF}; | |||
type | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlStringStack = class(TStringList) | |||
public | |||
procedure Push(const aStr: String); | |||
function Pop: String; | |||
function Seek: String; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlInterfaceNoRefCount = class(TObject, IUnknown) | |||
protected | |||
fRefCount : longint; | |||
{ implement methods of IUnknown } | |||
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; | |||
function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; | |||
public | |||
property RefCount: LongInt read fRefCount; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlCSVList = class(TStringList) | |||
private | |||
FSkipDelims: boolean; | |||
function GetStrictDelText: string; | |||
procedure SetStrictDelText(const Value: string); | |||
public | |||
property StrictDelimitedText: string read GetStrictDelText write SetStrictDelText; | |||
// Skip repeated delims instead of reading empty lines? | |||
property SkipDelims: boolean read FSkipDelims write FSkipDelims; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlCheckSynchronizeEvent = class(TObject) | |||
private | |||
fEvent: TEvent; | |||
function WaitMainThread(const aTimeout: Cardinal): TWaitResult; | |||
public const | |||
MAIN_WAIT_GRANULARITY = 10; | |||
public | |||
procedure SetEvent; | |||
procedure ResetEvent; | |||
function WaitFor(const aTimeout: Cardinal): TWaitResult; | |||
constructor Create(const aEventAttributes: syncobjs.PSecurityAttributes; | |||
const aManualReset, aInitialState: Boolean; const aName: string); | |||
destructor Destroy; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlBaseEventList = specialize TutlList<TutlCheckSynchronizeEvent>; | |||
TutlEventList = class(TutlBaseEventList) | |||
public | |||
function AddEvent(const aEventAttributes: syncobjs.PSecurityAttributes; const aManualReset, | |||
aInitialState: Boolean; const aName : string): TutlCheckSynchronizeEvent; | |||
function AddDefaultEvent: TutlCheckSynchronizeEvent; | |||
function WaitAll(const aTimeout: Cardinal): TWaitResult; | |||
constructor Create; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlVersionInfo = class(TObject) | |||
private | |||
fVersionRes: TVersionResource; | |||
function GetFixedInfo: TVersionFixedInfo; | |||
function GetStringFileInfo: TVersionStringFileInfo; | |||
function GetVarFileInfo: TVersionVarFileInfo; | |||
public | |||
property FixedInfo: TVersionFixedInfo read GetFixedInfo; | |||
property StringFileInfo: TVersionStringFileInfo read GetStringFileInfo; | |||
property VarFileInfo: TVersionVarFileInfo read GetVarFileInfo; | |||
function Load(const aInstance: THandle): Boolean; | |||
constructor Create; | |||
destructor Destroy; override; | |||
end; | |||
function utlEventEqual(const aEvent1, aEvent2): Boolean; | |||
implementation | |||
uses | |||
{uutlTiming needs to be included after Windows because of GetTickCount64} | |||
uutlLogger{$IFDEF WINDOWS},Windows{$ENDIF}, uutlTiming; | |||
{$IFNDEF WINDOWS} | |||
function CharNext(const C: PChar): PChar; | |||
begin | |||
//TODO: prüfen ob das für UnicodeString auch stimmt | |||
Result:= C; | |||
if Result^>#0 then | |||
inc(Result); | |||
end; | |||
{$IFEND} | |||
function utlEventEqual(const aEvent1, aEvent2): Boolean; | |||
begin | |||
result := | |||
(TMethod(aEvent1).Code = TMethod(aEvent2).Code) and | |||
(TMethod(aEvent1).Data = TMethod(aEvent2).Data); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlStringStack////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlStringStack.Push(const aStr: String); | |||
begin | |||
Insert(0, aStr); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlStringStack.Pop: String; | |||
begin | |||
result := ''; | |||
if Count > 0 then begin | |||
result := Strings[0]; | |||
Delete(0); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlStringStack.Seek: String; | |||
begin | |||
result := ''; | |||
if Count > 0 then | |||
result := Strings[0]; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlInterfaceNoRefCount/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlInterfaceNoRefCount.QueryInterface(constref iid: tguid; out obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
begin | |||
if getinterface(iid,obj) then | |||
result:=S_OK | |||
else | |||
result:=longint(E_NOINTERFACE); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlInterfaceNoRefCount._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
begin | |||
result := InterLockedIncrement(fRefCount); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlInterfaceNoRefCount._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
begin | |||
result := InterLockedDecrement(fRefCount); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlCSVList/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlCSVList.GetStrictDelText: string; | |||
var | |||
S: string; | |||
I, J, Cnt: Integer; | |||
q: boolean; | |||
LDelimiters: TSysCharSet; | |||
begin | |||
Cnt := GetCount; | |||
if (Cnt = 1) and (Get(0) = '') then | |||
Result := QuoteChar + QuoteChar | |||
else | |||
begin | |||
Result := ''; | |||
LDelimiters := [QuoteChar, Delimiter]; | |||
for I := 0 to Cnt - 1 do | |||
begin | |||
S := Get(I); | |||
q:= false; | |||
if S>'' then begin | |||
for J:= 1 to length(S) do | |||
if S[J] in LDelimiters then begin | |||
q:= true; | |||
break; | |||
end; | |||
if q then S := AnsiQuotedStr(S, QuoteChar); | |||
end else | |||
S := AnsiQuotedStr(S, QuoteChar); | |||
Result := Result + S + Delimiter; | |||
end; | |||
System.Delete(Result, Length(Result), 1); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlCSVList.SetStrictDelText(const Value: string); | |||
var | |||
S: String; | |||
P, P1: PChar; | |||
begin | |||
BeginUpdate; | |||
try | |||
Clear; | |||
P:= PChar(Value); | |||
if FSkipDelims then begin | |||
while (P^<>#0) and (P^=Delimiter) do begin | |||
P:= CharNext(P); | |||
end; | |||
end; | |||
while (P^<>#0) do begin | |||
if (P^ = QuoteChar) then begin | |||
S:= AnsiExtractQuotedStr(P, QuoteChar); | |||
end else begin | |||
P1:= P; | |||
while (P^<>#0) and (P^<>Delimiter) do begin | |||
P:= CharNext(P); | |||
end; | |||
SetString(S, P1, P - P1); | |||
end; | |||
Add(S); | |||
while (P^<>#0) and (P^<>Delimiter) do begin | |||
P:= CharNext(P); | |||
end; | |||
if (P^<>#0) then | |||
P:= CharNext(P); | |||
if FSkipDelims then begin | |||
while (P^<>#0) and (P^=Delimiter) do begin | |||
P:= CharNext(P); | |||
end; | |||
end; | |||
end; | |||
finally | |||
EndUpdate; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlCheckSynchronizeEvent///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlCheckSynchronizeEvent.WaitMainThread(const aTimeout: Cardinal): TWaitResult; | |||
var | |||
timeout: qword; | |||
begin | |||
timeout:= GetTickCount64 + aTimeout; | |||
repeat | |||
result := fEvent.WaitFor(TutlCheckSynchronizeEvent.MAIN_WAIT_GRANULARITY); | |||
CheckSynchronize(); | |||
until (result <> wrTimeout) or ((GetTickCount64 > timeout) and (aTimeout <> INFINITE)); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlCheckSynchronizeEvent.SetEvent; | |||
begin | |||
fEvent.SetEvent; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlCheckSynchronizeEvent.ResetEvent; | |||
begin | |||
fEvent.ResetEvent; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlCheckSynchronizeEvent.WaitFor(const aTimeout: Cardinal): TWaitResult; | |||
begin | |||
if (GetCurrentThreadId = MainThreadID) then | |||
result := WaitMainThread(aTimeout) | |||
else | |||
result := fEvent.WaitFor(aTimeout); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlCheckSynchronizeEvent.Create(const aEventAttributes: syncobjs.PSecurityAttributes; | |||
const aManualReset, aInitialState: Boolean; const aName: string); | |||
begin | |||
inherited Create; | |||
fEvent := TEvent.Create(aEventAttributes, aManualReset, aInitialState, aName); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlCheckSynchronizeEvent.Destroy; | |||
begin | |||
FreeAndNil(fEvent); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlEventList///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlEventList.AddEvent(const aEventAttributes: syncobjs.PSecurityAttributes; const aManualReset, | |||
aInitialState: Boolean; const aName: string): TutlCheckSynchronizeEvent; | |||
begin | |||
result := TutlCheckSynchronizeEvent.Create(aEventAttributes, aManualReset, aInitialState, aName); | |||
Add(result); | |||
end; | |||
function TutlEventList.AddDefaultEvent: TutlCheckSynchronizeEvent; | |||
begin | |||
result := AddEvent(nil, true, false, ''); | |||
result.ResetEvent; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlEventList.WaitAll(const aTimeout: Cardinal): TWaitResult; | |||
var | |||
i: integer; | |||
timeout, tick: qword; | |||
begin | |||
timeout := GetTickCount64 + aTimeout; | |||
for i := 0 to Count-1 do begin | |||
if (aTimeout <> INFINITE) then begin | |||
tick := GetTickCount64; | |||
if (tick >= timeout) then begin | |||
result := wrTimeout; | |||
exit; | |||
end else | |||
result := Items[i].WaitFor(timeout - tick); | |||
end else | |||
result := Items[i].WaitFor(INFINITE); | |||
if result <> wrSignaled then | |||
exit; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlEventList.Create; | |||
begin | |||
inherited Create(true); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlVersionInfo/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlVersionInfo.GetFixedInfo: TVersionFixedInfo; | |||
begin | |||
result := fVersionRes.FixedInfo; | |||
end; | |||
function TutlVersionInfo.GetStringFileInfo: TVersionStringFileInfo; | |||
begin | |||
result := fVersionRes.StringFileInfo; | |||
end; | |||
function TutlVersionInfo.GetVarFileInfo: TVersionVarFileInfo; | |||
begin | |||
result := fVersionRes.VarFileInfo; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlVersionInfo.Load(const aInstance: THandle): Boolean; | |||
var | |||
Stream: TResourceStream; | |||
begin | |||
result := false; | |||
if (FindResource(aInstance, PChar(PtrInt(1)), PChar(RT_VERSION)) = 0) then | |||
exit; | |||
Stream := TResourceStream.CreateFromID(aInstance, 1, PChar(RT_VERSION)); | |||
try | |||
fVersionRes.SetCustomRawDataStream(Stream); | |||
fVersionRes.FixedInfo;// access some property to force load from the stream | |||
fVersionRes.SetCustomRawDataStream(nil); | |||
finally | |||
Stream.Free; | |||
end; | |||
result := true; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlVersionInfo.Create; | |||
begin | |||
inherited Create; | |||
fVersionRes := TVersionResource.Create; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlVersionInfo.Destroy; | |||
begin | |||
FreeAndNil(fVersionRes); | |||
inherited Destroy; | |||
end; | |||
end. | |||
@@ -0,0 +1,66 @@ | |||
unit uutlConversion; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit stellt Methoden für Konvertierung verschiedener Datentypen zur Verfügung } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils; | |||
function Supports(const aInstance: TObject; const aClass: TClass; out aObj): Boolean; overload; | |||
function HexToBinary(HexValue: PChar; BinValue: PByte; BinBufSize: Integer): Integer; | |||
implementation | |||
function Supports(const aInstance: TObject; const aClass: TClass; out aObj): Boolean; | |||
begin | |||
result := Assigned(aInstance) and aInstance.InheritsFrom(aClass); | |||
if result then | |||
TObject(aObj) := aInstance | |||
else | |||
TObject(aObj) := nil; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//wandelt einen Hex-String in einen Blob um | |||
//@hexvalue: Hex-String | |||
//@binvalue: Zeiger auf einen Speicherbereich | |||
//@binbufsize: maximale größe die geschrieben werden darf | |||
//@result: gelesene bytes | |||
function HexToBinary(HexValue: PChar; BinValue: PByte; BinBufSize: Integer): Integer; | |||
var i,j,h,l : integer; | |||
begin | |||
i:=binbufsize; | |||
while (i>0) do | |||
begin | |||
if hexvalue^ IN ['A'..'F','a'..'f'] then | |||
h:=((ord(hexvalue^)+9) and 15) | |||
else if hexvalue^ IN ['0'..'9'] then | |||
h:=((ord(hexvalue^)) and 15) | |||
else | |||
break; | |||
inc(hexvalue); | |||
if hexvalue^ IN ['A'..'F','a'..'f'] then | |||
l:=(ord(hexvalue^)+9) and 15 | |||
else if hexvalue^ IN ['0'..'9'] then | |||
l:=(ord(hexvalue^)) and 15 | |||
else | |||
break; | |||
j := l + (h shl 4); | |||
inc(hexvalue); | |||
binvalue^:=j; | |||
inc(binvalue); | |||
dec(i); | |||
end; | |||
result:=binbufsize-i; | |||
end; | |||
end. | |||
@@ -0,0 +1,45 @@ | |||
{$IFNDEF PROFILER_DISABLE} | |||
{.$DEFINE PROFILER_ENABLE} | |||
{.$DEFINE PROFILER_DISABLE_NAMES} | |||
{$ENDIF} | |||
(****************************************************************************** | |||
Usage: | |||
Somewhere, use this: | |||
{.$DEFINE PROFILER_DISABLE} //use this to disable profiling for specific unit | |||
{$I uutlEmbeddedProfiler.inc} | |||
(also add wherever that file is to the project's include search path -Fi, | |||
unit search path is not enough) | |||
In Uses-List: SysUtils, ... __PROFUSE; | |||
(notice: no comma before __PROFUSE) | |||
In Code: | |||
begin | |||
__PROFENTER | |||
... code here ... | |||
__PROFLEAVE | |||
end; | |||
******************************************************************************) | |||
{$macro on} | |||
{$IFDEF PROFILER_ENABLE} | |||
{$DEFINE __PROFENTER:=uutlEmbeddedProfiler.ProfilerEnterProc(Get_pc_addr); try} | |||
{$DEFINE __PROFLEAVE:=finally uutlEmbeddedProfiler.ProfilerLeaveProc; end;} | |||
{$DEFINE __PROFUSE:=, uutlEmbeddedProfiler} | |||
{$DEFINE __PROFUSEPREV:=uutlEmbeddedProfiler, } | |||
{$IFNDEF PROFILER_DISABLE_NAMES} | |||
{$DEFINE __PROFSETNAME:=uutlEmbeddedProfiler.ProfilerEnterProc(Get_pc_addr,} | |||
{$DEFINE __PROFENTERNAME:=); try} | |||
{$ELSE} | |||
{$DEFINE __PROFSETNAME:=//} | |||
{$DEFINE __PROFENTERNAME:=__PROFENTER} | |||
{$ENDIF} | |||
{$ELSE} | |||
{$DEFINE __PROFENTER:=} | |||
{$DEFINE __PROFLEAVE:=} | |||
{$DEFINE __PROFUSE:=} | |||
{$DEFINE __PROFUSEPREV:=} | |||
{$DEFINE __PROFSETNAME:=//} | |||
{$DEFINE __PROFENTERNAME:=} | |||
{$ENDIF} | |||
@@ -0,0 +1,301 @@ | |||
unit uutlEmbeddedProfiler; | |||
{$mode objfpc}{$H+} | |||
{$OPTIMIZATION ON} | |||
{$OPTIMIZATION REGVAR} | |||
{$OPTIMIZATION PEEPHOLE} | |||
{$OPTIMIZATION CSE} | |||
{$OPTIMIZATION ASMCSE} | |||
interface | |||
uses | |||
SysUtils; | |||
var | |||
ProfilerEnabled: boolean; | |||
procedure ProfilerEnterProc(const Addr: Pointer); | |||
procedure ProfilerEnterProc(const Addr: Pointer; const aName: String); | |||
procedure ProfilerLeaveProc; | |||
implementation | |||
{$I uutlEmbeddedProfiler.inc} | |||
{$IFDEF PROFILER_ENABLE} | |||
uses | |||
Windows, lineinfo{%H-}, Classes, fgl, unFastFileStream; | |||
type | |||
TWriterThread = class(TThread) | |||
private type | |||
TCacheEntry = record | |||
Name, Src: ShortString; Line: integer; | |||
end; | |||
TCacheList = specialize TFPGMap<PtrUInt, TCacheEntry>; | |||
private | |||
fAddressCache: TCacheList; | |||
fPF: Int64; | |||
procedure SaveCurrentWrite; | |||
public | |||
constructor Create; | |||
destructor Destroy; override; | |||
procedure Execute; override; | |||
end; | |||
PEventRecord = ^TEventRecord; | |||
TEventRecord = packed record | |||
Name: String; | |||
Func: PtrUInt; | |||
Thread: TThreadID; | |||
When: Int64; | |||
end; | |||
TProfileDataFile = class | |||
public | |||
constructor Create(const {%H-}aFileName: string); | |||
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); virtual; abstract; | |||
procedure WriteLeave(Thread: TThreadID; When: Int64); virtual; abstract; | |||
end; | |||
{$DEFINE __HEAD} | |||
//{$I uutlProfilerPlainText.inc} | |||
{$I uutlProfilerPlainTextMMap.inc} | |||
{$UnDef __HEAD} | |||
//{$I uutlProfilerPlainText.inc} | |||
{$I uutlProfilerPlainTextMMap.inc} | |||
const | |||
MAX_EVENT_COUNT = 1000; | |||
RETURN_FUNCTION : PtrUInt = PtrUInt(-1); | |||
var | |||
ProfilerDataFile: TProfileDataFile; | |||
LineNumberComp: PtrUInt; | |||
Events: array[0..MAX_EVENT_COUNT-1] of TEventRecord; | |||
InsertPtr, WritePtr: Integer; | |||
WriterThread: TWriterThread; | |||
SLInsert: Cardinal; | |||
procedure InstallWriterThread; | |||
begin | |||
if not Assigned(WriterThread) then | |||
WriterThread:= TWriterThread.Create; | |||
end; | |||
procedure UninstallWriterThread; | |||
begin | |||
if Assigned(WriterThread) then begin | |||
WriterThread.Terminate; | |||
WriterThread.WaitFor; | |||
FreeAndNil(WriterThread); | |||
end; | |||
end; | |||
procedure NextInsert; | |||
begin | |||
inc(InsertPtr); | |||
if InsertPtr >= MAX_EVENT_COUNT then | |||
InsertPtr:= 0; | |||
// wait until writer cleared this element | |||
While Events[InsertPtr].Func <> 0 do | |||
ThreadSwitch; | |||
end; | |||
procedure CalibrateLineNumberCompensation1(const Addr: PtrUInt); | |||
begin | |||
LineNumberComp:= Addr; | |||
end; | |||
procedure CalibrateLineNumberCompensation; | |||
label | |||
mark; | |||
begin | |||
mark: | |||
CalibrateLineNumberCompensation1({%H-}PtrUInt(Get_pc_addr)); | |||
//measure out one CALL | |||
LineNumberComp:= LineNumberComp - {%H-}PtrUInt(@mark); | |||
//go somewhere into the stack prep before the call | |||
inc(LineNumberComp); | |||
end; | |||
procedure TestDebugInfoPresent; | |||
var | |||
f,s: ShortString; | |||
l: LongInt; | |||
begin | |||
f:= ''; | |||
s:= ''; | |||
l:= 0; | |||
if not GetLineInfo({%H-}PtrUInt(@TestDebugInfoPresent),f,s,l) then begin | |||
raise Exception.Create('Profiler is enabled, but no suitable debug info could be found.'); | |||
Halt(); | |||
end; | |||
end; | |||
procedure ProfilerEnterProc(const Addr: Pointer); | |||
begin | |||
ProfilerEnterProc(Addr, ''); | |||
end; | |||
procedure ProfilerEnterProc(const Addr: Pointer; const aName: String); | |||
var | |||
f: PtrUInt; | |||
tid: TThreadID; | |||
er: PEventRecord; | |||
begin | |||
if not ProfilerEnabled then | |||
exit; | |||
tid:= GetCurrentThreadId; | |||
InstallWriterThread; | |||
repeat | |||
System.InterlockedCompareExchange(SLInsert, tid, 0); | |||
until SLInsert = tid; | |||
try | |||
// measure as late (close to measured code) as possible, but still write .Func last, because that's our lockvar | |||
f:= {%H-}PtrUInt(addr) - LineNumberComp; | |||
er:= @Events[InsertPtr]; | |||
er^.Thread := tid; | |||
er^.Name := aName; | |||
QueryPerformanceCounter(er^.When); | |||
er^.Func := f; | |||
NextInsert; | |||
finally | |||
System.InterLockedExchange(SLInsert, 0); | |||
end; | |||
end; | |||
procedure ProfilerLeaveProc; | |||
var | |||
t: Int64; | |||
tid: TThreadID; | |||
er: PEventRecord; | |||
begin | |||
if not ProfilerEnabled then | |||
exit; | |||
QueryPerformanceCounter(t{%H-}); | |||
tid:= GetCurrentThreadId; | |||
repeat | |||
System.InterlockedCompareExchange(SLInsert, tid, 0); | |||
until SLInsert = tid; | |||
try | |||
// measure as early (close to measured code) as possible, but still write .Func last, because that's our lockvar | |||
er := @Events[InsertPtr]; | |||
er^.Thread := tid; | |||
er^.When := t; | |||
er^.Name := ''; | |||
er^.Func := RETURN_FUNCTION; | |||
NextInsert; | |||
finally | |||
System.InterLockedExchange(SLInsert, 0); | |||
end; | |||
end; | |||
{ TProfileDataFile } | |||
constructor TProfileDataFile.Create(const aFileName: string); | |||
begin | |||
inherited Create; | |||
end; | |||
{ TWriterThread } | |||
constructor TWriterThread.Create; | |||
begin | |||
inherited Create(false); | |||
fAddressCache:= TCacheList.Create; | |||
fAddressCache.Sorted:= true; | |||
QueryPerformanceFrequency(fPF); | |||
end; | |||
destructor TWriterThread.Destroy; | |||
begin | |||
FreeAndNil(fAddressCache); | |||
inherited Destroy; | |||
end; | |||
procedure TWriterThread.Execute; | |||
begin | |||
while not Terminated do begin | |||
while Events[WritePtr].Func<>0 do begin | |||
SaveCurrentWrite; | |||
inc(WritePtr); | |||
if WritePtr >= MAX_EVENT_COUNT then | |||
WritePtr:= 0; | |||
end; | |||
Sleep(1); | |||
end; | |||
//finish up remaining data, by now, writing is disabled | |||
while Events[WritePtr].Func<>0 do begin | |||
SaveCurrentWrite; | |||
inc(WritePtr); | |||
if WritePtr >= MAX_EVENT_COUNT then | |||
WritePtr:= 0; | |||
end; | |||
end; | |||
procedure TWriterThread.SaveCurrentWrite; | |||
var | |||
ce: TCacheEntry; | |||
i: integer; | |||
begin | |||
if Events[WritePtr].Func = 0 then | |||
exit; | |||
if Events[WritePtr].Func = RETURN_FUNCTION then | |||
ProfilerDataFile.WriteLeave(Events[WritePtr].Thread, (Events[WritePtr].When * 1000 * 1000) div fPF) | |||
else begin | |||
i:= fAddressCache.IndexOf(Events[WritePtr].Func); | |||
if i < 0 then begin | |||
ce.Line:= 0; | |||
ce.Src:= ''; | |||
GetLineInfo(Events[WritePtr].Func,ce.Name,ce.Src,ce.Line); | |||
if (ce.Name = '') then | |||
ce.Name := Format('0x%.16x', [Events[WritePtr].Func]); | |||
fAddressCache.Add(Events[WritePtr].Func, ce); | |||
end else | |||
ce:= fAddressCache.Data[i]; | |||
if (Events[WritePtr].Name <> '') then | |||
ce.Name := '[' + Events[WritePtr].Name + '] ' + ce.Name; | |||
ProfilerDataFile.WriteEnter(Events[WritePtr].Thread, (Events[WritePtr].When * 1000 * 1000) div fPF, ce.Name, ce.Src, ce.Line); | |||
end; | |||
Events[WritePtr].Func:= 0; | |||
end; | |||
{$ELSE} | |||
procedure ProfilerEnterProc(const Addr: Pointer); inline; | |||
begin end; | |||
procedure ProfilerEnterProc(const Addr: Pointer; const aName: String); inline; | |||
begin end; | |||
procedure ProfilerLeaveProc; inline; | |||
begin end; | |||
{$ENDIF} | |||
initialization | |||
{$IFDEF PROFILER_ENABLE} | |||
ProfilerEnabled:= false; | |||
InsertPtr:= 0; | |||
WritePtr:= 0; | |||
WriterThread:= nil; | |||
CalibrateLineNumberCompensation; | |||
TestDebugInfoPresent; | |||
//ProfilerDataFile:= TProfilePlainText.Create(ChangeFileExt(ParamStr(0), '.profraw')); | |||
//ProfilerDataFile:= TProfileBinary.Create(ChangeFileExt(ParamStr(0), '.profbin')); | |||
ProfilerDataFile:= TProfilePlainTextMMap.Create(ChangeFileExt(ParamStr(0), '.profraw')); | |||
ProfilerEnabled:= true; | |||
{$ENDIF} | |||
finalization | |||
{$IFDEF PROFILER_ENABLE} | |||
ProfilerEnabled:= false; | |||
UninstallWriterThread; | |||
FreeAndNil(ProfilerDataFile); | |||
{$ENDIF} | |||
end. | |||
@@ -0,0 +1,58 @@ | |||
{$IF defined(__ENUM_INTERFACE)} | |||
type __ENUM_HELPER = class | |||
private type | |||
TValueArray = packed array[0..__ENUM_LENGTH-1] of __ENUM_TYPE; | |||
public | |||
class function {%H}ToString(const Value: __ENUM_TYPE): String; reintroduce; | |||
class function TryToEnum(const Str: String; out Value: __ENUM_TYPE): boolean; overload; | |||
class function ToEnum(const Str: String; const aDefault: __ENUM_TYPE): __ENUM_TYPE; overload; | |||
class function ToEnum(const Str: String): __ENUM_TYPE; overload; | |||
class function Values: TValueArray; | |||
strict private | |||
const TABLE: packed record | |||
E: TValueArray; // array of values | |||
N: AnsiString; // comma-separated string of names | |||
end = | |||
{$ELSEIF defined (__ENUM_IMPLEMENTATION)} | |||
class function __ENUM_HELPER.ToString(const Value: __ENUM_TYPE): String; | |||
var | |||
i: integer; | |||
begin | |||
Result:= ''; | |||
if LookupVal(@Value, @TABLE.E, sizeof(__ENUM_TYPE), length(TABLE.E), i) then | |||
Result:= PickString(TABLE.N, i); | |||
end; | |||
class function __ENUM_HELPER.ToEnum(const Str: String): __ENUM_TYPE; | |||
begin | |||
if not TryToEnum(Str, Result) then | |||
raise EConvertErrorAlias.CreateFmt('"%s" is an invalid value',[Str]); | |||
end; | |||
class function __ENUM_HELPER.ToEnum(const Str: String; const aDefault: __ENUM_TYPE): __ENUM_TYPE; | |||
begin | |||
if not TryToEnum(Str, Result) then | |||
Result:= aDefault; | |||
end; | |||
class function __ENUM_HELPER.TryToEnum(const Str: String; out Value: __ENUM_TYPE): boolean; | |||
var | |||
i: integer; | |||
begin | |||
Result:= LookupString(Str, TABLE.N, i); | |||
if Result then | |||
Value:= TABLE.E[i]; | |||
end; | |||
class function __ENUM_HELPER.Values: TValueArray; | |||
begin | |||
Result:= TABLE.E; | |||
end; | |||
{$ENDIF} | |||
{$undef __ENUM_TYPE} | |||
{$undef __ENUM_LENGTH} | |||
{$undef __ENUM_HELPER} |
@@ -0,0 +1,101 @@ | |||
unit uutlEnumHelper; | |||
(* Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit stellt einen Mechanismus zur Verfügung, ohne viel Aufwand, | |||
Helper Klassen für Enums zu implementieren | |||
Verwendung: | |||
{$MACRO ON} | |||
interface | |||
{$define __ENUM_INTERFACE} | |||
{$define __ENUM_HELPER:=TSomeEnumH}{$define __ENUM_TYPE:=TSomeEnum}{$define __ENUM_LENGTH:=4} | |||
{$I uutlEnumHelper.inc}( | |||
E: (enVal1, enVal2, enVal3, enVal4); | |||
N: 'enVal1,enVal2,enVal3,enVal4'; | |||
); end; | |||
//... mehr davon | |||
{$undef __ENUM_INTERFACE} | |||
implementation | |||
{$define __ENUM_IMPLEMENTATION} | |||
{$define __ENUM_HELPER:=TSomeEnumH}{$define __ENUM_TYPE:=TSomeEnum}{$I uutlEnumHelper.inc} | |||
{$undef __ENUM_IMPLEMENTATION} *) | |||
interface | |||
uses | |||
SysUtils, StrUtils; | |||
type | |||
EConvertErrorAlias = SysUtils.EConvertError; | |||
function LookupString(const aStr, aTable: String; out found: integer): boolean; | |||
function PickString(const aTable: String; const aIndex: integer): string; | |||
function LookupVal(const aVal: Pointer; const aPtr: Pointer; const aStep, aCount: PtrInt; out found: integer): boolean; | |||
implementation | |||
function LookupString(const aStr, aTable: String; out found: integer): boolean; | |||
var | |||
tbl: string; | |||
i,p,k: integer; | |||
t: string; | |||
begin | |||
Result:= false; | |||
tbl:= aTable + ','; | |||
t:= ''; | |||
k:= 0; | |||
i:= 1; | |||
while i < Length(tbl) do begin | |||
p:= PosEx(',',tbl,i); | |||
t:= Trim(Copy(tbl, i, p-i)); | |||
i:= p+1; | |||
if CompareText(t, aStr)=0 then begin | |||
found:= k; | |||
Result:= true; | |||
exit; | |||
end else | |||
inc(k); | |||
end; | |||
end; | |||
function PickString(const aTable: String; const aIndex: integer): string; | |||
var | |||
tbl: String; | |||
k,i,p: integer; | |||
begin | |||
result:= ''; | |||
tbl:= aTable + ','; | |||
i:= 1; | |||
k:= aIndex; | |||
while (k>0) and (i>0) do begin | |||
i:= PosEx(',',tbl, i) + 1; | |||
dec(k); | |||
end; | |||
p:= PosEx(',',tbl, i); | |||
if p<=0 then | |||
Result:= '' | |||
else | |||
Result:= Trim(Copy(tbl, i, p-i)); | |||
end; | |||
function LookupVal(const aVal: Pointer; const aPtr: Pointer; const aStep, aCount: PtrInt; out found: integer): boolean; | |||
var | |||
pt: Pointer; | |||
i: integer; | |||
begin | |||
Result:= false; | |||
pt:= aPtr; | |||
for i:= 0 to aCount-1 do begin | |||
if CompareMem(pt, aVal, aStep) then begin | |||
Result:= true; | |||
found:= i; | |||
exit; | |||
end; | |||
inc(pt, aStep); | |||
end; | |||
end; | |||
end. |
@@ -0,0 +1,712 @@ | |||
unit uutlEventManager; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit verwaltet Events und verteilt diese an registrierte Programm-Teile } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, uutlGenerics, syncobjs, uutlTiming, Controls, Forms, uutlMessageThread, uutlMessages; | |||
type | |||
TutlEventType = ( | |||
MOUSE_DOWN = 10, | |||
MOUSE_UP, | |||
MOUSE_WHEEL_UP, | |||
MOUSE_WHEEL_DOWN, | |||
MOUSE_MOVE, | |||
MOUSE_ENTER, | |||
MOUSE_LEAVE, | |||
MOUSE_CLICK, | |||
MOUSE_DBL_CLICK, | |||
KEY_DOWN = 20, | |||
KEY_REPEAT, | |||
KEY_UP, | |||
WINDOW_RESIZE = 30, | |||
WINDOW_ACTIVATE, | |||
WINDOW_DEACTIVATE | |||
); | |||
TutlEventTypes = set of TutlEventType; | |||
{ TutlInputEvent } | |||
TutlInputEvent = class | |||
protected | |||
function CreateInstance: TutlInputEvent; virtual; | |||
procedure Assign(const aEvent: TutlInputEvent); virtual; | |||
public | |||
Timestamp: QWord; | |||
EventType: TutlEventType; | |||
function Clone: TutlInputEvent; | |||
constructor Create(aType: TutlEventType); | |||
end; | |||
TutlInputEventList = specialize TutlList<TutlInputEvent>; | |||
{ TutlMouseEvent } | |||
TutlMouseEvent = class(TutlInputEvent) | |||
protected | |||
function CreateInstance: TutlInputEvent; override; | |||
procedure Assign(const aEvent: TutlInputEvent); override; | |||
public | |||
Button: TMouseButton; | |||
ClientPos, | |||
ScreenPos: TPoint; | |||
constructor Create(aType: TutlEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint); | |||
constructor Create(aType: TutlEventType; aClientPos, aScreenPos: TPoint); | |||
end; | |||
{ TutlKeyEvent } | |||
TutlKeyEvent = class(TutlInputEvent) | |||
protected | |||
function CreateInstance: TutlInputEvent; override; | |||
procedure Assign(const aEvent: TutlInputEvent); override; | |||
public | |||
CharCode: WideChar; | |||
KeyCode: Word; | |||
constructor Create(aType: TutlEventType; aCharCode: WideChar; aKeyCode: Word); | |||
end; | |||
{ TutlWindowEvent } | |||
TutlWindowEvent = class(TutlInputEvent) | |||
protected | |||
function CreateInstance: TutlInputEvent; override; | |||
procedure Assign(const aEvent: TutlInputEvent); override; | |||
public | |||
ScreenRect: TRect; | |||
ClientWidth, | |||
ClientHeight: Cardinal; | |||
constructor Create(aType: TutlEventType; aScreenRect: TRect; aClientWidth, aClientHeight: Cardinal); | |||
constructor Create(aType: TutlEventType; aScreenTopLeft: TPoint; aClientWidth, aClientHeight: Cardinal); | |||
end; | |||
{ TutlEventManager } | |||
TutlInputEventHandler = procedure (Sender: TObject; Event: TutlInputEvent; var DoneEvent: boolean) of object; | |||
TMouseButtons = set of TMouseButton; | |||
TutlEventManager = class | |||
private type | |||
TInputState = record | |||
Keyboard: record | |||
Modifiers: TShiftState; | |||
KeyState: array[Byte] of Boolean; | |||
end; | |||
Mouse: record | |||
ScreenPos, ClientPos: TPoint; | |||
Buttons: TMouseButtons; | |||
end; | |||
Window: record | |||
Active: boolean; | |||
ScreenRect: TRect; | |||
ClientWidth: Integer; | |||
ClientHeight: Integer; | |||
end; | |||
end; | |||
TEventListener = class | |||
ThreadID: TThreadID; | |||
Synchronous: Boolean; | |||
Filter: TutlEventTypes; | |||
Handler: TutlInputEventHandler; | |||
end; | |||
TEventListenerList = specialize TutlList<TEventListener>; | |||
TInputEventMsg = class(TutlCallbackMsg) | |||
private | |||
fSender: TObject; | |||
fHandler: TutlInputEventHandler; | |||
fInputEvent: TutlInputEvent; | |||
public | |||
procedure ExecuteCallback; override; | |||
constructor Create(const aSender: TObject; const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent); | |||
destructor Destroy; override; | |||
end; | |||
TSyncInputEventMsg = class(TutlSyncCallbackMsg) | |||
private | |||
fSender: TObject; | |||
fHandler: TutlInputEventHandler; | |||
fInputEvent: TutlInputEvent; | |||
fDoneEvent: Boolean; | |||
public | |||
property DoneEvent: Boolean read fDoneEvent; | |||
procedure ExecuteCallback; override; | |||
constructor Create(const aSender: TObject; const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent); | |||
destructor Destroy; override; | |||
end; | |||
private | |||
fEventQueue: TutlInputEventList; | |||
fEventQueueLock: TCriticalSection; | |||
fListeners: TEventListenerList; | |||
protected | |||
fCanonicalState: TInputState; | |||
procedure EventHandlerMouseDown(Sender: TObject; Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer); | |||
procedure EventHandlerMouseUp(Sender: TObject; Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: Integer); | |||
procedure EventHandlerMouseWheel(Sender: TObject; {%H-}Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); | |||
procedure EventHandlerMouseMove(Sender: TObject; {%H-}Shift: TShiftState; X, Y: Integer); | |||
procedure EventHandlerMouseEnter(Sender: TObject); | |||
procedure EventHandlerMouseLeave(Sender: TObject); | |||
procedure EventHandlerClick(Sender: TObject); | |||
procedure EventHandlerDblClick(Sender: TObject); | |||
procedure EventHandlerKeyDown(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState); | |||
procedure EventHandlerKeyUp(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState); | |||
procedure EventHandlerResize(Sender: TObject); | |||
procedure EventHandlerActivate(Sender: TObject); | |||
procedure EventHandlerDeactivate(Sender: TObject); | |||
function QueuePush(const aEvent: TutlInputEvent): TutlInputEvent; | |||
function DispatchEvent(const aEvent: TutlInputEvent): boolean; | |||
procedure RecordEvent(const aEvent: TutlInputEvent); | |||
public | |||
property CanonicalState: TInputState read fCanonicalState; | |||
procedure AttachEvents(const fControl: TCustomForm; aEventMask: TutlEventTypes); | |||
function IsKeyDown(const aChar: Char): Boolean; | |||
procedure RegisterListener(const aEventMask: TutlEventTypes; const aHandler: TutlInputEventHandler; const aSynchronous: Boolean = false); | |||
procedure UnregisterListener(const aHandler: TutlInputEventHandler); | |||
procedure DispatchEvents; | |||
constructor Create; | |||
destructor Destroy; override; | |||
end; | |||
function utlEventManager: TutlEventManager; | |||
const | |||
utlInput_Events_Mouse = [MOUSE_DOWN, MOUSE_UP, MOUSE_WHEEL_UP, MOUSE_WHEEL_DOWN, MOUSE_MOVE, | |||
MOUSE_ENTER, MOUSE_LEAVE, MOUSE_CLICK, MOUSE_DBL_CLICK]; | |||
utlInput_Events_Keyboard = [KEY_DOWN, KEY_REPEAT, KEY_UP]; | |||
utlInput_Events_Window = [WINDOW_RESIZE, WINDOW_ACTIVATE, WINDOW_DEACTIVATE]; | |||
utlInput_Events_All = utlInput_Events_Mouse+utlInput_Events_Keyboard+utlInput_Events_Window; | |||
implementation | |||
uses uutlKeyCodes, uutlLogger, LCLIntf; | |||
type | |||
TCustomFormVisibilityClass = class(TCustomForm) | |||
published | |||
property OnMouseDown; | |||
property OnMouseMove; | |||
property OnMouseUp; | |||
property OnMouseWheel; | |||
property OnMouseEnter; | |||
property OnMouseLeave; | |||
property OnActivate; | |||
property OnDeactivate; | |||
property OnClick; | |||
property OnDblClick; | |||
end; | |||
var | |||
utlEventManager_Singleton: TutlEventManager; | |||
function utlEventManager: TutlEventManager; | |||
begin | |||
if not Assigned(utlEventManager_Singleton) then | |||
utlEventManager_Singleton := TutlEventManager.Create; | |||
result := utlEventManager_Singleton; | |||
end; | |||
{ TSyncInputEventMsg } | |||
procedure TutlEventManager.TSyncInputEventMsg.ExecuteCallback; | |||
begin | |||
fHandler(fSender, fInputEvent, fDoneEvent); | |||
end; | |||
constructor TutlEventManager.TSyncInputEventMsg.Create(const aSender: TObject; | |||
const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent); | |||
begin | |||
inherited Create; | |||
fSender := aSender; | |||
fInputEvent := aInputEvent.Clone; | |||
fHandler := aHandler; | |||
fDoneEvent := false; | |||
end; | |||
destructor TutlEventManager.TSyncInputEventMsg.Destroy; | |||
begin | |||
FreeAndNil(fInputEvent); | |||
inherited Destroy; | |||
end; | |||
{ TInputEventMsg } | |||
procedure TutlEventManager.TInputEventMsg.ExecuteCallback; | |||
var | |||
done: Boolean; | |||
begin | |||
done := false; | |||
fHandler(fSender, fInputEvent, done); | |||
end; | |||
constructor TutlEventManager.TInputEventMsg.Create(const aSender: TObject; | |||
const aHandler: TutlInputEventHandler; const aInputEvent: TutlInputEvent); | |||
begin | |||
inherited Create; | |||
fSender := aSender; | |||
fInputEvent := aInputEvent.Clone; | |||
fHandler := aHandler; | |||
end; | |||
destructor TutlEventManager.TInputEventMsg.Destroy; | |||
begin | |||
FreeAndNil(fInputEvent); | |||
inherited Destroy; | |||
end; | |||
{ TutlInputEvent } | |||
function TutlInputEvent.CreateInstance: TutlInputEvent; | |||
begin | |||
result := TutlInputEvent.Create(EventType); | |||
end; | |||
procedure TutlInputEvent.Assign(const aEvent: TutlInputEvent); | |||
begin | |||
EventType := aEvent.EventType; | |||
Timestamp := aEvent.Timestamp; | |||
end; | |||
function TutlInputEvent.Clone: TutlInputEvent; | |||
begin | |||
result := CreateInstance; | |||
result.Assign(self); | |||
end; | |||
constructor TutlInputEvent.Create(aType: TutlEventType); | |||
begin | |||
inherited Create; | |||
Timestamp:= GetMicroTime; | |||
EventType:= aType; | |||
end; | |||
{ TutlMouseEvent } | |||
function TutlMouseEvent.CreateInstance: TutlInputEvent; | |||
begin | |||
result := TutlMouseEvent.Create(EventType, ClientPos, ScreenPos); | |||
end; | |||
procedure TutlMouseEvent.Assign(const aEvent: TutlInputEvent); | |||
var | |||
e: TutlMouseEvent; | |||
begin | |||
inherited Assign(aEvent); | |||
e := aEvent as TutlMouseEvent; | |||
Button := e.Button; | |||
ClientPos := e.ClientPos; | |||
ScreenPos := e.ScreenPos; | |||
end; | |||
constructor TutlMouseEvent.Create(aType: TutlEventType; aButton: TMouseButton; aClientPos, aScreenPos: TPoint); | |||
begin | |||
inherited Create(aType); | |||
Button:= aButton; | |||
ClientPos:= aClientPos; | |||
ScreenPos:= aScreenPos; | |||
end; | |||
constructor TutlMouseEvent.Create(aType: TutlEventType; aClientPos, aScreenPos: TPoint); | |||
begin | |||
inherited Create(aType); | |||
ClientPos:= aClientPos; | |||
ScreenPos:= aScreenPos; | |||
end; | |||
{ TutlKeyEvent } | |||
function TutlKeyEvent.CreateInstance: TutlInputEvent; | |||
begin | |||
result := TutlKeyEvent.Create(EventType, CharCode, KeyCode); | |||
end; | |||
procedure TutlKeyEvent.Assign(const aEvent: TutlInputEvent); | |||
var | |||
e: TutlKeyEvent; | |||
begin | |||
inherited Assign(aEvent); | |||
e := (aEvent as TutlKeyEvent); | |||
CharCode := e.CharCode; | |||
KeyCode := e.KeyCode; | |||
end; | |||
constructor TutlKeyEvent.Create(aType: TutlEventType; aCharCode: WideChar; aKeyCode: Word); | |||
begin | |||
inherited Create(aType); | |||
CharCode:= aCharCode; | |||
KeyCode:= aKeyCode; | |||
end; | |||
{ TutlWindowEvent } | |||
function TutlWindowEvent.CreateInstance: TutlInputEvent; | |||
begin | |||
result := TutlWindowEvent.Create(EventType, ScreenRect, ClientWidth, ClientHeight); | |||
end; | |||
procedure TutlWindowEvent.Assign(const aEvent: TutlInputEvent); | |||
var | |||
e: TutlWindowEvent; | |||
begin | |||
inherited Assign(aEvent); | |||
e := (aEvent as TutlWindowEvent); | |||
ScreenRect := e.ScreenRect; | |||
ClientWidth := e.ClientWidth; | |||
ClientHeight := e.ClientHeight; | |||
end; | |||
constructor TutlWindowEvent.Create(aType: TutlEventType; aScreenRect: TRect; aClientWidth, | |||
aClientHeight: Cardinal); | |||
begin | |||
inherited Create(aType); | |||
ScreenRect:= aScreenRect; | |||
ClientWidth:= aClientWidth; | |||
ClientHeight:= aClientHeight; | |||
end; | |||
constructor TutlWindowEvent.Create(aType: TutlEventType; aScreenTopLeft: TPoint; aClientWidth, aClientHeight: Cardinal); | |||
begin | |||
inherited Create(aType); | |||
ClientWidth:= aClientWidth; | |||
ClientHeight:= aClientHeight; | |||
ScreenRect.TopLeft:= aScreenTopLeft; | |||
ScreenRect.BottomRight:= aScreenTopLeft; | |||
inc(ScreenRect.Right, ClientWidth); | |||
inc(ScreenRect.Bottom, ClientHeight); | |||
end; | |||
{ TutlEventManager } | |||
{$REGION EventHandler} | |||
procedure TutlEventManager.EventHandlerMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); | |||
begin | |||
QueuePush(TutlMouseEvent.Create(MOUSE_DOWN, Button, Point(X,Y), TWinControl(Sender).ClientToScreen(Point(X,Y)))); | |||
end; | |||
procedure TutlEventManager.EventHandlerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); | |||
begin | |||
QueuePush(TutlMouseEvent.Create(MOUSE_MOVE, Point(X,Y), TWinControl(Sender).ClientToScreen(Point(X,Y)))); | |||
end; | |||
procedure TutlEventManager.EventHandlerMouseEnter(Sender: TObject); | |||
begin | |||
QueuePush(TutlMouseEvent.Create(MOUSE_ENTER, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos)); | |||
end; | |||
procedure TutlEventManager.EventHandlerMouseLeave(Sender: TObject); | |||
begin | |||
QueuePush(TutlMouseEvent.Create(MOUSE_LEAVE, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos)); | |||
end; | |||
procedure TutlEventManager.EventHandlerClick(Sender: TObject); | |||
begin | |||
QueuePush(TutlMouseEvent.Create(MOUSE_CLICK, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos)); | |||
end; | |||
procedure TutlEventManager.EventHandlerDblClick(Sender: TObject); | |||
begin | |||
QueuePush(TutlMouseEvent.Create(MOUSE_DBL_CLICK, TWinControl(Sender).ScreenToClient(Mouse.CursorPos), Mouse.CursorPos)); | |||
end; | |||
procedure TutlEventManager.EventHandlerMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); | |||
begin | |||
QueuePush(TutlMouseEvent.Create(MOUSE_UP, Button, Point(X,Y), TWinControl(Sender).ClientToScreen(Point(X,Y)))); | |||
end; | |||
procedure TutlEventManager.EventHandlerMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); | |||
begin | |||
if WheelDelta < 0 then | |||
QueuePush(TutlMouseEvent.Create(MOUSE_WHEEL_DOWN, MousePos, TWinControl(Sender).ClientToScreen(MousePos))) | |||
else | |||
QueuePush(TutlMouseEvent.Create(MOUSE_WHEEL_UP, MousePos, TWinControl(Sender).ClientToScreen(MousePos))); | |||
Handled:= false; | |||
end; | |||
procedure TutlEventManager.EventHandlerKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); | |||
var | |||
ch: WideChar; | |||
begin | |||
ch:= VKCodeToCharCode(Key, fCanonicalState.Keyboard.Modifiers); | |||
if fCanonicalState.Keyboard.KeyState[Key and $FF] then | |||
QueuePush(TutlKeyEvent.Create(KEY_REPEAT, ch, Key)) | |||
else | |||
QueuePush(TutlKeyEvent.Create(KEY_DOWN, ch, Key)); | |||
end; | |||
procedure TutlEventManager.EventHandlerKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); | |||
var | |||
ch: WideChar; | |||
begin | |||
ch:= VKCodeToCharCode(Key, fCanonicalState.Keyboard.Modifiers); | |||
QueuePush(TutlKeyEvent.Create(KEY_UP, ch, Key)); | |||
end; | |||
procedure TutlEventManager.EventHandlerResize(Sender: TObject); | |||
var | |||
w: TControl; | |||
begin | |||
w := (Sender as TControl); | |||
QueuePush(TutlWindowEvent.Create(WINDOW_RESIZE, w.ClientToScreen(Point(0,0)), w.ClientWidth, w.ClientHeight)); | |||
end; | |||
procedure TutlEventManager.EventHandlerActivate(Sender: TObject); | |||
var | |||
w: TControl; | |||
begin | |||
w := (Sender as TControl); | |||
QueuePush(TutlWindowEvent.Create(WINDOW_ACTIVATE, w.ClientToScreen(Point(0,0)), w.ClientWidth, w.ClientHeight)); | |||
end; | |||
procedure TutlEventManager.EventHandlerDeactivate(Sender: TObject); | |||
var | |||
w: TControl; | |||
begin | |||
w := (Sender as TControl); | |||
QueuePush(TutlWindowEvent.Create(WINDOW_DEACTIVATE, w.ClientToScreen(Point(0,0)), w.ClientWidth, w.ClientHeight)); | |||
end; | |||
{$ENDREGION} | |||
function TutlEventManager.QueuePush(const aEvent: TutlInputEvent): TutlInputEvent; | |||
begin | |||
fEventQueueLock.Acquire; | |||
try | |||
if Assigned(fEventQueue) then | |||
fEventQueue.Add(aEvent); | |||
Result:= aEvent; | |||
finally | |||
fEventQueueLock.Release; | |||
end; | |||
end; | |||
function TutlEventManager.DispatchEvent(const aEvent: TutlInputEvent): boolean; | |||
var | |||
i: integer; | |||
ls: TEventListener; | |||
msg: TSyncInputEventMsg; | |||
begin | |||
Result:= false; | |||
for i:= 0 to fListeners.Count-1 do begin | |||
if aEvent.EventType in fListeners[i].Filter then begin | |||
ls := fListeners[i]; | |||
if (GetCurrentThreadId <> ls.ThreadID) then begin | |||
if (ls.Synchronous) then begin | |||
msg := TSyncInputEventMsg.Create(self, ls.Handler, aEvent); | |||
if utlSendMessage(ls.ThreadID, msg, 5000) = wrSignaled then begin | |||
result := msg.DoneEvent; | |||
msg.Free; //only free on wrSignal, otherwise thread will free message | |||
end | |||
end else | |||
utlPostMessage(ls.ThreadID, TInputEventMsg.Create(self, ls.Handler, aEvent)); | |||
end else | |||
fListeners[i].Handler(Self, aEvent, Result); | |||
end; | |||
if Result then | |||
break; | |||
end; | |||
end; | |||
procedure TutlEventManager.RecordEvent(const aEvent: TutlInputEvent); | |||
function GetPressedButtons: TMouseButtons; | |||
begin | |||
result := []; | |||
if (GetKeyState(VK_LBUTTON) < 0) then | |||
result := result + [mbLeft]; | |||
if (GetKeyState(VK_RBUTTON) < 0) then | |||
result := result + [mbRight]; | |||
if (GetKeyState(VK_MBUTTON) < 0) then | |||
result := result + [mbMiddle]; | |||
if (GetKeyState(VK_XBUTTON1) < 0) then | |||
result := result + [mbExtra1]; | |||
if (GetKeyState(VK_XBUTTON2) < 0) then | |||
result := result + [mbExtra2]; | |||
end; | |||
begin | |||
if aEvent is TutlMouseEvent then | |||
with TutlMouseEvent(aEvent) do begin | |||
fCanonicalState.Mouse.ClientPos := ClientPos; | |||
fCanonicalState.Mouse.ScreenPos := ScreenPos; | |||
case EventType of | |||
MOUSE_DOWN: | |||
Include(fCanonicalState.Mouse.Buttons, Button); | |||
MOUSE_UP: | |||
Exclude(fCanonicalState.Mouse.Buttons, Button); | |||
MOUSE_LEAVE: | |||
fCanonicalState.Mouse.Buttons := []; | |||
MOUSE_ENTER: | |||
fCanonicalState.Mouse.Buttons := GetPressedButtons; | |||
MOUSE_CLICK, | |||
MOUSE_DBL_CLICK, | |||
MOUSE_MOVE, | |||
MOUSE_WHEEL_DOWN, | |||
MOUSE_WHEEL_UP: ; //nothing to record here | |||
end; | |||
end | |||
else if aEvent is TutlKeyEvent then | |||
with TutlKeyEvent(aEvent) do begin | |||
case EventType of | |||
KEY_DOWN, | |||
KEY_REPEAT: begin | |||
fCanonicalState.Keyboard.KeyState[KeyCode and $FF]:= true; | |||
case KeyCode of | |||
VK_SHIFT: include(fCanonicalState.Keyboard.Modifiers, ssShift); | |||
VK_MENU: include(fCanonicalState.Keyboard.Modifiers, ssAlt); | |||
VK_CONTROL: include(fCanonicalState.Keyboard.Modifiers, ssCtrl); | |||
end; | |||
end; | |||
KEY_UP: begin | |||
fCanonicalState.Keyboard.KeyState[KeyCode and $FF]:= false; | |||
case KeyCode of | |||
VK_SHIFT: Exclude(fCanonicalState.Keyboard.Modifiers, ssShift); | |||
VK_MENU: Exclude(fCanonicalState.Keyboard.Modifiers, ssAlt); | |||
VK_CONTROL: Exclude(fCanonicalState.Keyboard.Modifiers, ssCtrl); | |||
end; | |||
end; | |||
end; | |||
if [ssCtrl, ssAlt] - fCanonicalState.Keyboard.Modifiers = [] then | |||
include(fCanonicalState.Keyboard.Modifiers, ssAltGr) | |||
else | |||
exclude(fCanonicalState.Keyboard.Modifiers, ssAltGr); | |||
end | |||
else if aEvent is TutlWindowEvent then | |||
with TutlWindowEvent(aEvent) do begin | |||
case EventType of | |||
WINDOW_ACTIVATE: fCanonicalState.Window.Active:= true; | |||
WINDOW_DEACTIVATE: fCanonicalState.Window.Active:= true; | |||
WINDOW_RESIZE: begin | |||
fCanonicalState.Window.ScreenRect := ScreenRect; | |||
fCanonicalState.Window.ClientWidth := ClientWidth; | |||
fCanonicalState.Window.ClientHeight := ClientHeight; | |||
end; | |||
end; | |||
end | |||
end; | |||
procedure TutlEventManager.DispatchEvents; | |||
var | |||
i: integer; | |||
begin | |||
fEventQueueLock.Acquire; | |||
try | |||
if Assigned(fEventQueue) then begin | |||
//process ALL events | |||
for i:= 0 to fEventQueue.Count-1 do begin | |||
DispatchEvent(fEventQueue[i]); | |||
RecordEvent(fEventQueue[i]); | |||
end; | |||
//now that we're done, free them | |||
fEventQueue.Clear; | |||
end; | |||
finally | |||
fEventQueueLock.Release; | |||
end; | |||
end; | |||
procedure TutlEventManager.AttachEvents(const fControl: TCustomForm; aEventMask: TutlEventTypes); | |||
var | |||
ctl: TCustomFormVisibilityClass; | |||
begin | |||
ctl:= TCustomFormVisibilityClass(fControl); | |||
ctl.KeyPreview:= true; | |||
if MOUSE_DOWN in aEventMask then ctl.OnMouseDown:= @EventHandlerMouseDown; | |||
if MOUSE_UP in aEventMask then ctl.OnMouseUp:= @EventHandlerMouseUp; | |||
if (MOUSE_WHEEL_DOWN in aEventMask) or | |||
(MOUSE_WHEEL_UP in aEventMask) then ctl.OnMouseWheel:= @EventHandlerMouseWheel; | |||
if MOUSE_MOVE in aEventMask then ctl.OnMouseMove:= @EventHandlerMouseMove; | |||
if MOUSE_ENTER in aEventMask then ctl.OnMouseEnter := @EventHandlerMouseEnter; | |||
if MOUSE_LEAVE in aEventMask then ctl.OnMouseLeave := @EventHandlerMouseLeave; | |||
if MOUSE_CLICK in aEventMask then ctl.OnClick := @EventHandlerClick; | |||
if MOUSE_DBL_CLICK in aEventMask then ctl.OnDblClick := @EventHandlerDblClick; | |||
if KEY_DOWN in aEventMask then ctl.OnKeyDown:= @EventHandlerKeyDown; | |||
if KEY_UP in aEventMask then ctl.OnKeyUp:= @EventHandlerKeyUp; | |||
if WINDOW_RESIZE in aEventMask then ctl.OnResize:= @EventHandlerResize; | |||
if WINDOW_ACTIVATE in aEventMask then ctl.OnActivate:= @EventHandlerActivate; | |||
if WINDOW_DEACTIVATE in aEventMask then ctl.OnDeactivate:= @EventHandlerDeactivate; | |||
end; | |||
function TutlEventManager.IsKeyDown(const aChar: Char): Boolean; | |||
begin | |||
result := CanonicalState.Keyboard.KeyState[Ord(UpCase(aChar))]; | |||
end; | |||
procedure TutlEventManager.RegisterListener(const aEventMask: TutlEventTypes; | |||
const aHandler: TutlInputEventHandler; const aSynchronous: Boolean); | |||
var | |||
ls: TEventListener; | |||
begin | |||
UnregisterListener(aHandler); | |||
ls:= TEventListener.Create; | |||
try | |||
ls.Filter := aEventMask; | |||
ls.Handler := aHandler; | |||
ls.ThreadID := GetCurrentThreadId; | |||
ls.Synchronous := aSynchronous; | |||
fListeners.Add(ls); | |||
except | |||
ls.Free; | |||
end; | |||
end; | |||
procedure TutlEventManager.UnregisterListener(const aHandler: TutlInputEventHandler); | |||
var | |||
i: integer; | |||
m1, m2: TMethod; | |||
begin | |||
m1 := TMethod(aHandler); | |||
for i:= fListeners.Count-1 downto 0 do begin | |||
m2 := TMethod(fListeners[i].Handler); | |||
if (m1.Data = m2.Data) and | |||
(m2.Code = m2.Code)then | |||
fListeners.Delete(i); | |||
end; | |||
end; | |||
constructor TutlEventManager.Create; | |||
begin | |||
inherited Create; | |||
fEventQueue:= TutlInputEventList.Create(true); | |||
fEventQueueLock:= TCriticalSection.Create; | |||
fListeners:= TEventListenerList.Create(true); | |||
end; | |||
destructor TutlEventManager.Destroy; | |||
begin | |||
FreeAndNil(fListeners); | |||
fEventQueueLock.Acquire; | |||
try | |||
fEventQueue.Clear; | |||
FreeAndNil(fEventQueue); | |||
finally | |||
fEventQueueLock.Release; | |||
end; | |||
FreeAndNil(fEventQueueLock); | |||
inherited Destroy; | |||
end; | |||
finalization | |||
if Assigned(utlEventManager_Singleton) then | |||
FreeAndNil(utlEventManager_Singleton); | |||
end. | |||
@@ -0,0 +1,103 @@ | |||
unit uutlExceptions; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält Definitionen für verschiedene Exceptions } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, syncobjs; | |||
type | |||
EOutOfRange = class(Exception) | |||
constructor Create(const aIndex, aMin, aMax: Integer); | |||
end; | |||
EUnknownType = class(Exception) | |||
public | |||
constructor Create(const aObj: TObject); | |||
end; | |||
EArgumentNil = class(Exception) | |||
public | |||
constructor Create(const aArgName: String); | |||
end; | |||
EArgument = class(Exception) | |||
public | |||
constructor Create(const aArg, aMsg: String); | |||
constructor Create(const aMsg: String); | |||
end; | |||
EParameter = EArgument; | |||
EFileDoesntExists = class(Exception) | |||
public | |||
constructor Create(const aFilename: string); | |||
end; | |||
EFileNotFound = EFileDoesntExists; | |||
EInvalidFile = class(Exception); | |||
EInvalidOperation = class(Exception); | |||
ENotSupported = class(Exception); | |||
EWait = class(Exception) | |||
private | |||
fWaitResult: TWaitResult; | |||
public | |||
property WaitResult: TWaitResult read fWaitResult; | |||
constructor Create(const msg: string; const aWaitResult: TWaitResult); | |||
end; | |||
implementation | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor EOutOfRange.Create(const aIndex, aMin, aMax: Integer); | |||
begin | |||
inherited Create(format('index (%d) out of range (%d:%d)', [aIndex, aMin, aMax])); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor EUnknownType.Create(const aObj: TObject); | |||
begin | |||
inherited Create(format('unknown type: %s', [aObj.ClassName])); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor EArgumentNil.Create(const aArgName: String); | |||
begin | |||
inherited Create(format('argument ''%s'' can not be nil!', [aArgName])); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor EArgument.Create(const aArg, aMsg: String); | |||
begin | |||
inherited Create(format('invalid argument "%s" - %s', [aArg, aMsg])) | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor EArgument.Create(const aMsg: String); | |||
begin | |||
inherited Create(aMsg); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor EFileDoesntExists.Create(const aFilename: string); | |||
begin | |||
inherited Create('file doesn''t exists: ' + aFilename); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor EWait.Create(const msg: string; const aWaitResult: TWaitResult); | |||
begin | |||
inherited Create(msg); | |||
fWaitResult := aWaitResult; | |||
end; | |||
end. | |||
@@ -0,0 +1,413 @@ | |||
unit uutlGraph; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit implementiert einen generischen Graphen } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, contnrs, uutlCommon; | |||
type | |||
TutlGraph = class; | |||
TutlGraphNodeData = class(TObject) | |||
public | |||
constructor Create; virtual; | |||
end; | |||
TutlGraphNodeDataClass = class of TutlGraphNodeData; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlGraphNode = class; | |||
TutlGraphNodeClass = class of TutlGraphNode; | |||
TutlGraphNode = class(TutlInterfaceNoRefCount) | |||
private type | |||
TNodeEnumerator = class(TObject) | |||
private | |||
fOwner: TutlGraphNode; | |||
fPos: Integer; | |||
function GetCurrent: TutlGraphNode; | |||
public | |||
property Current: TutlGraphNode read GetCurrent; | |||
function MoveNext: Boolean; | |||
constructor Create(const aOwner: TutlGraphNode); | |||
end; | |||
protected | |||
fParent: TutlGraphNode; | |||
fOwner: TutlGraph; | |||
fData: TutlGraphNodeData; | |||
fItems: TObjectList; | |||
class function GetDataClass: TutlGraphNodeDataClass; virtual; | |||
function GetCount: Integer; virtual; | |||
function GetItems(const aIndex: Integer): TutlGraphNode; virtual; | |||
function AttachNode(const aNode: TutlGraphNode): Boolean; virtual; | |||
function DetachNode(const aNode: TutlGraphNode): Boolean; virtual; | |||
public | |||
property Parent: TutlGraphNode read fParent; | |||
property Owner: TutlGraph read fOwner; | |||
property Data: TutlGraphNodeData read fData; | |||
property Count: Integer read GetCount; | |||
property Items[const aIndex: Integer]: TutlGraphNode read GetItems; default; | |||
function AddItem: TutlGraphNode; | |||
function IndexOf(const aItem: TutlGraphNode): Integer; | |||
procedure DelItem(const aIndex: Integer); | |||
procedure Clear; | |||
function IsParent(const aNode: TutlGraphNode): Boolean; | |||
function Move(const aParent: TutlGraphNode): Boolean; | |||
function GetEnumerator: TNodeEnumerator; | |||
constructor Create(const aParent: TutlGraphNode; const aOwner: TutlGraph); | |||
destructor Destroy; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlGraph = class(TutlInterfaceNoRefCount) | |||
protected | |||
fRootNode: TutlGraphNode; | |||
class function GetItemClass: TutlGraphNodeClass; virtual; | |||
public | |||
property RootNode: TutlGraphNode read fRootNode; | |||
constructor Create; | |||
destructor Destroy; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
generic TutlGenericGraphNode<GData: TutlGraphNodeData; GNode, GOwner> = class(TutlGraphNode) | |||
private type | |||
TGenericNodeEnumerator = class(TObject) | |||
private | |||
fOwner: TutlGraphNode; | |||
fPos: Integer; | |||
function GetCurrent: GNode; | |||
public | |||
property Current: GNode read GetCurrent; | |||
function MoveNext: Boolean; | |||
constructor Create(const aOwner: TutlGraphNode); | |||
end; | |||
private | |||
function GetParent: GNode; | |||
function GetOwner: GOwner; | |||
function GetData: GData; | |||
function GetItemsGeneric(const aIndex: Integer): GNode; | |||
public | |||
property Parent: GNode read GetParent; | |||
property Owner: GOwner read GetOwner; | |||
property Data: GData read GetData; | |||
property Items[const aIndex: Integer]: GNode read GetItemsGeneric; default; | |||
function AddItem: GNode; | |||
function IndexOf(const aItem: GNode): Integer; | |||
function IsParent(const aNode: GNode): Boolean; | |||
function Move(const aParent: GNode): Boolean; | |||
function GetEnumerator: TGenericNodeEnumerator; | |||
constructor Create(const aParent: GNode; const aOwner: GOwner); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
generic TutlGenericGraph<T: TutlGraphNode> = class(TutlGraph) | |||
private | |||
function GetRootNode: T; | |||
public | |||
property RootNode: T read GetRootNode; | |||
end; | |||
implementation | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlGraphNodeData///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlGraphNodeData.Create; | |||
begin | |||
inherited Create; | |||
//nothing to do here | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlGraphNode.TNodeEnumerator////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.TNodeEnumerator.GetCurrent: TutlGraphNode; | |||
begin | |||
result := fOwner.Items[fPos]; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.TNodeEnumerator.MoveNext: Boolean; | |||
begin | |||
inc(fPos); | |||
result := (fPos < fOwner.Count); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlGraphNode.TNodeEnumerator.Create(const aOwner: TutlGraphNode); | |||
begin | |||
inherited Create; | |||
fPos := -1; | |||
fOwner := aOwner; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlGraphNode///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
class function TutlGraphNode.GetDataClass: TutlGraphNodeDataClass; | |||
begin | |||
result := TutlGraphNodeData; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.GetCount: Integer; | |||
begin | |||
result := fItems.Count; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.GetItems(const aIndex: Integer): TutlGraphNode; | |||
begin | |||
if (aIndex >= 0) and (aIndex < Count) then | |||
result := (fItems[aIndex] as TutlGraphNode) | |||
else | |||
raise Exception.Create(Format('index (%d) is out of Range (%d - %d)', [aIndex, 0, Count-1])); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.AttachNode(const aNode: TutlGraphNode): Boolean; | |||
begin | |||
result := true; | |||
fItems.Add(aNode); | |||
aNode.fParent := self; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.DetachNode(const aNode: TutlGraphNode): Boolean; | |||
var | |||
i: Integer; | |||
begin | |||
result := false; | |||
i := fItems.IndexOf(aNode); | |||
if (i < 0) then | |||
exit; | |||
try | |||
fItems.OwnsObjects := false; | |||
fItems.Delete(i); | |||
aNode.fParent := nil; | |||
finally | |||
fItems.OwnsObjects := true; | |||
end; | |||
result := true; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.AddItem: TutlGraphNode; | |||
begin | |||
if Assigned(Owner) then | |||
result := Owner.GetItemClass().Create(self, Owner) | |||
else | |||
result := TutlGraphNode.Create(self, Owner); | |||
fItems.Add(result); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.IndexOf(const aItem: TutlGraphNode): Integer; | |||
begin | |||
result := fItems.IndexOf(aItem); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlGraphNode.DelItem(const aIndex: Integer); | |||
begin | |||
if (aIndex >= 0) and (aIndex < Count) then begin | |||
fItems.Delete(aIndex); | |||
end else | |||
raise Exception.Create(Format('index (%d) is out of Range (%d - %d)', [aIndex, 0, Count-1])); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlGraphNode.Clear; | |||
begin | |||
fItems.Clear; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.IsParent(const aNode: TutlGraphNode): Boolean; | |||
var | |||
n: TutlGraphNode; | |||
begin | |||
n := self; | |||
result := true; | |||
while Assigned(n.Parent) do begin | |||
if (aNode = n.Parent) then | |||
exit; | |||
n := n.Parent; | |||
end; | |||
result := false; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.Move(const aParent: TutlGraphNode): Boolean; | |||
var | |||
oldParent: TutlGraphNode; | |||
begin | |||
result := false; | |||
if (aParent.IsParent(self)) then | |||
exit; | |||
oldParent := Parent; | |||
if Assigned(oldParent) and not oldParent.DetachNode(self) then | |||
exit; | |||
if not aParent.AttachNode(self) then begin | |||
if Assigned(oldParent) then | |||
oldParent.AttachNode(self); | |||
exit; | |||
end; | |||
result := true; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGraphNode.GetEnumerator: TNodeEnumerator; | |||
begin | |||
result := TNodeEnumerator.Create(self); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlGraphNode.Create(const aParent: TutlGraphNode; const aOwner: TutlGraph); | |||
begin | |||
inherited Create; | |||
fParent := aParent; | |||
fOwner := aOwner; | |||
fData := GetDataClass().Create(); | |||
fItems := TObjectList.create(true); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlGraphNode.Destroy; | |||
begin | |||
FreeAndNil(fData); | |||
FreeAndNil(fItems); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlGraph///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
class function TutlGraph.GetItemClass: TutlGraphNodeClass; | |||
begin | |||
result := TutlGraphNode; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlGraph.Create; | |||
begin | |||
inherited Create; | |||
fRootNode := GetItemClass().Create(nil, self); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlGraph.Destroy; | |||
begin | |||
FreeAndNil(fRootNode); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlGenericGraphNode.TGenericNodeEnumerator/////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.TGenericNodeEnumerator.GetCurrent: GNode; | |||
begin | |||
result := GNode(fOwner.Items[fPos]); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.TGenericNodeEnumerator.MoveNext: Boolean; | |||
begin | |||
inc(fPos); | |||
result := (fPos < fOwner.Count); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlGenericGraphNode.TGenericNodeEnumerator.Create(const aOwner: TutlGraphNode); | |||
begin | |||
inherited Create; | |||
fPos := -1; | |||
fOwner := aOwner; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlGenericGraphNode////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.GetParent: GNode; | |||
begin | |||
result := GNode(fParent); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.GetOwner: GOwner; | |||
begin | |||
result := GOwner(fOwner); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.GetData: GData; | |||
begin | |||
result := GData(fData); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.GetItemsGeneric(const aIndex: Integer): GNode; | |||
begin | |||
result := GNode(inherited GetItems(aIndex)); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.AddItem: GNode; | |||
begin | |||
result := GNode(inherited AddItem); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.IndexOf(const aItem: GNode): Integer; | |||
begin | |||
result := inherited IndexOf(aItem); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.IsParent(const aNode: GNode): Boolean; | |||
begin | |||
result := inherited IsParent(aNode); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.Move(const aParent: GNode): Boolean; | |||
begin | |||
result := inherited Move(aParent); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraphNode.GetEnumerator: TGenericNodeEnumerator; | |||
begin | |||
result := TGenericNodeEnumerator.Create(self); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlGenericGraphNode.Create(const aParent: GNode; const aOwner: GOwner); | |||
begin | |||
inherited Create(TutlGraphNode(aParent), TutlGraph(aOwner)); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlGenericGraph////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlGenericGraph.GetRootNode: T; | |||
begin | |||
result := (fRootNode as T); | |||
end; | |||
end. | |||
@@ -0,0 +1,263 @@ | |||
unit uutlKeyCodes; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält alle virtuellen Key Codes } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses Classes; | |||
{$REGION SCANCODES} | |||
const | |||
VK_UNKNOWN = 0; // defined by LCL | |||
VK_LBUTTON = 1; | |||
VK_RBUTTON = 2; | |||
VK_CANCEL = 3; | |||
VK_MBUTTON = 4; | |||
VK_XBUTTON1 = 5; | |||
VK_XBUTTON2 = 6; | |||
VK_BACK = 8; // The "Backspace" key, dont confuse with the | |||
// Android BACK key which is mapped to VK_ESCAPE | |||
VK_TAB = 9; | |||
VK_CLEAR = 12; | |||
VK_RETURN = 13; // The "Enter" key, also used for a keypad center press | |||
VK_SHIFT = 16; // See also VK_LSHIFT, VK_RSHIFT | |||
VK_CONTROL = 17; // See also VK_LCONTROL, VK_RCONTROL | |||
VK_MENU = 18; | |||
// The ALT key. Also called "Option" in Mac OS X. See also VK_LMENU, VK_RMENU | |||
VK_PAUSE = 19; // Pause/Break key | |||
VK_CAPITAL = 20; // CapsLock key | |||
VK_KANA = 21; | |||
VK_HANGUL = 21; | |||
VK_JUNJA = 23; | |||
VK_FINAL = 24; | |||
VK_HANJA = 25; | |||
VK_KANJI = 25; | |||
VK_ESCAPE = 27; // Also used for the hardware Back key in Android | |||
VK_CONVERT = 28; | |||
VK_NONCONVERT = 29; | |||
VK_ACCEPT = 30; | |||
VK_MODECHANGE = 31; | |||
VK_SPACE = 32; | |||
VK_PRIOR = 33; // Page Up | |||
VK_NEXT = 34; // Page Down | |||
VK_END = 35; | |||
VK_HOME = 36; | |||
VK_LEFT = 37; | |||
VK_UP = 38; | |||
VK_RIGHT = 39; | |||
VK_DOWN = 40; | |||
VK_SELECT = 41; | |||
VK_PRINT = 42; // PrintScreen key | |||
VK_EXECUTE = 43; | |||
VK_SNAPSHOT = 44; | |||
VK_INSERT = 45; | |||
VK_DELETE = 46; | |||
VK_HELP = 47; | |||
VK_0 = $30; | |||
VK_1 = $31; | |||
VK_2 = $32; | |||
VK_3 = $33; | |||
VK_4 = $34; | |||
VK_5 = $35; | |||
VK_6 = $36; | |||
VK_7 = $37; | |||
VK_8 = $38; | |||
VK_9 = $39; | |||
//3A-40 Undefined | |||
VK_A = $41; | |||
VK_B = $42; | |||
VK_C = $43; | |||
VK_D = $44; | |||
VK_E = $45; | |||
VK_F = $46; | |||
VK_G = $47; | |||
VK_H = $48; | |||
VK_I = $49; | |||
VK_J = $4A; | |||
VK_K = $4B; | |||
VK_L = $4C; | |||
VK_M = $4D; | |||
VK_N = $4E; | |||
VK_O = $4F; | |||
VK_P = $50; | |||
VK_Q = $51; | |||
VK_R = $52; | |||
VK_S = $53; | |||
VK_T = $54; | |||
VK_U = $55; | |||
VK_V = $56; | |||
VK_W = $57; | |||
VK_X = $58; | |||
VK_Y = $59; | |||
VK_Z = $5A; | |||
VK_LWIN = $5B; | |||
// In Mac OS X this is the Apple, or Command key. Windows Key in PC keyboards | |||
VK_RWIN = $5C; | |||
// In Mac OS X this is the Apple, or Command key. Windows Key in PC keyboards | |||
VK_APPS = $5D; // The PopUp key in PC keyboards | |||
// $5E reserved | |||
VK_SLEEP = $5F; | |||
VK_NUMPAD0 = 96; // $60 | |||
VK_NUMPAD1 = 97; | |||
VK_NUMPAD2 = 98; | |||
VK_NUMPAD3 = 99; | |||
VK_NUMPAD4 = 100; | |||
VK_NUMPAD5 = 101; | |||
VK_NUMPAD6 = 102; | |||
VK_NUMPAD7 = 103; | |||
VK_NUMPAD8 = 104; | |||
VK_NUMPAD9 = 105; | |||
VK_MULTIPLY = 106; | |||
// VK_MULTIPLY up to VK_DIVIDE are usually in the numeric keypad in PC keyboards | |||
VK_ADD = 107; | |||
VK_SEPARATOR = 108; | |||
VK_SUBTRACT = 109; | |||
VK_DECIMAL = 110; | |||
VK_DIVIDE = 111; | |||
VK_F1 = 112; | |||
VK_F2 = 113; | |||
VK_F3 = 114; | |||
VK_F4 = 115; | |||
VK_F5 = 116; | |||
VK_F6 = 117; | |||
VK_F7 = 118; | |||
VK_F8 = 119; | |||
VK_F9 = 120; | |||
VK_F10 = 121; | |||
VK_F11 = 122; | |||
VK_F12 = 123; | |||
VK_F13 = 124; | |||
VK_F14 = 125; | |||
VK_F15 = 126; | |||
VK_F16 = 127; | |||
VK_F17 = 128; | |||
VK_F18 = 129; | |||
VK_F19 = 130; | |||
VK_F20 = 131; | |||
VK_F21 = 132; | |||
VK_F22 = 133; | |||
VK_F23 = 134; | |||
VK_F24 = 135; // $87 | |||
// $88-$8F unassigned | |||
VK_NUMLOCK = $90; | |||
VK_SCROLL = $91; | |||
{$ENDREGION} | |||
function CharCodeToVKCode(Ch: WideChar; out shift: TShiftState): word; | |||
function VKCodeToCharCode(key: word; Shift: TShiftState): WideChar; | |||
implementation | |||
{$IFDEF WINDOWS} | |||
uses Windows; | |||
function CharCodeToVKCode(Ch: WideChar; out shift: TShiftState): word; | |||
var | |||
st: SmallInt; | |||
begin | |||
shift:= []; | |||
Result:= 0; | |||
if ch=#0 then | |||
exit; | |||
st:= VkKeyScan(AnsiChar(UnicodeChar(ch))); | |||
if (hi(st)=$FF) and (lo(st)=$FF) then | |||
exit; | |||
Result:= lo(st); | |||
if Result and (1 shl 8) > 0 then include(shift, ssShift); | |||
if Result and (2 shl 8) > 0 then include(shift, ssCtrl); | |||
if Result and (4 shl 8) > 0 then include(shift, ssAlt); | |||
if [ssCtrl, ssAlt] - shift = [] then | |||
include(shift, ssAltGr); | |||
end; | |||
function VKCodeToCharCode(key: word; Shift: TShiftState): WideChar; | |||
var | |||
sc: word; | |||
ks: array[0..255] of byte; | |||
buf: array[0..1] of AnsiChar; | |||
begin | |||
Result:= #0; | |||
sc:= MapVirtualKey(key, {MAPVK_VK_TO_VSC} 0); | |||
FillChar({%H-}ks[0], sizeof(ks), 0); | |||
if ssShift in Shift then ks[VK_SHIFT]:= $80; | |||
if ssCtrl in Shift then ks[VK_CONTROL]:= $80; | |||
if ssAlt in Shift then ks[VK_MENU]:= $80; | |||
if ssCaps in Shift then ks[VK_CAPITAL]:= $81; | |||
buf:= #0#0; | |||
case ToAscii(key, sc, @ks[0], LPWORD(@buf[0]), 0) of | |||
0: Result:= #0;//The specified virtual key has no translation for the current state of the keyboard. | |||
1: Result:= UnicodeChar(AnsiChar(buf[0]));//One character was copied to the buffer | |||
2: Result:= UnicodeChar(AnsiChar(buf[1]));//Two characters were copied to the buffer. This usually happens when a dead-key character (accent or diacritic) stored in the keyboard layout cannot be composed with the specified virtual key to form a single character. | |||
end; | |||
end; | |||
{$ELSE} | |||
uses SysUtils, gtk2proc; | |||
function VKCodeToCharCode(key: word; Shift: TShiftState): WideChar; | |||
var | |||
vki: TVKeyInfo; | |||
dt: PAnsiChar; | |||
begin | |||
Result:= #0; | |||
vki:= GetVKeyInfo(Key); | |||
if strlen(vki.KeyChar[0])>0 then begin | |||
dt:= ''; | |||
if []=Shift then | |||
dt:= vki.KeyChar[0] | |||
else | |||
if ([ssShift]=Shift) or ([ssCaps]=Shift) then | |||
dt:= vki.KeyChar[1] | |||
else | |||
if ([ssCtrl, ssAlt]=Shift) or ([ssAltGr]=Shift) then | |||
dt:= vki.KeyChar[2]; | |||
Utf8ToUnicode(@Result, 1, PChar(dt), strlen(dt)); | |||
end; | |||
end; | |||
function CharCodeToVKCode(Ch: WideChar; out shift: TShiftState): word; | |||
var | |||
k: Word; | |||
vki: TVKeyInfo; | |||
utf8ch: array[0..high(TVKeyUTF8Char)] of AnsiChar; | |||
begin | |||
Result:= 0; | |||
if ch=#0 then | |||
exit; | |||
utf8ch:= #0#0#0#0#0#0#0#0; //wat | |||
UnicodeToUTF8(@utf8ch[0], sizeof(utf8ch), @ch, 1); | |||
for k:= low(byte) to high(byte) do begin | |||
vki:= GetVKeyInfo(k); | |||
if CompareMem(@utf8ch, @vki.KeyChar[0], sizeof(utf8ch)) then begin | |||
Result:= k; | |||
shift:= []; | |||
exit; | |||
end else | |||
if CompareMem(@utf8ch, @vki.KeyChar[1], sizeof(utf8ch)) then begin | |||
Result:= k; | |||
shift:= [ssShift]; | |||
exit; | |||
end else | |||
if CompareMem(@utf8ch, @vki.KeyChar[2], sizeof(utf8ch)) then begin | |||
Result:= k; | |||
shift:= [ssAltGr, ssAlt, ssCtrl]; | |||
exit; | |||
end; | |||
end; | |||
end; | |||
{$ENDIF} | |||
end. |
@@ -0,0 +1,244 @@ | |||
unit uutlLocalization; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit stellt Mechanismen zur Übersetzung von Texten mit Hilfe von PO/MO-Files zur Verfügung } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, gettext, | |||
uutlCommon, uutlGenerics, uutlStreamHelper; | |||
type | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlLocalizationItem = class(TObject) | |||
Name, Comment: String; | |||
constructor Create; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlLocalizationDatabase = class(TObject) | |||
private type | |||
TStringObjMap = specialize TutlMap<String, TutlLocalizationItem>; | |||
private | |||
fStringList: TStringObjMap; | |||
fLangFile: TMOFile; | |||
function GetCount: Integer; | |||
function GetObject(Index: Integer): TutlLocalizationItem; | |||
public | |||
property Count : Integer read GetCount; | |||
property Objects[Index: Integer]: TutlLocalizationItem read GetObject; | |||
function AddName(const Name, Comment: string): TutlLocalizationItem; | |||
function RemoveName(const Name: string): boolean; | |||
procedure LoadFromStream(const aStream: TStream); | |||
procedure SaveToStream(const aStream: TStream); | |||
procedure LoadLanguage(const aStream: TStream); | |||
function Translate(const Name: string): string; | |||
constructor Create; | |||
destructor Destroy; override; | |||
end; | |||
function utlLocalizationDatabase: TutlLocalizationDatabase; | |||
function __(Name: string; Default: string = #0): string; overload; | |||
implementation | |||
uses | |||
Dialogs, uvfsManager; | |||
var | |||
Entity: TutlLocalizationDatabase; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlLocalizationDatabase: TutlLocalizationDatabase; | |||
var | |||
str: IStreamHandle; | |||
begin | |||
if not Assigned(Entity) then begin | |||
Entity := TutlLocalizationDatabase.Create; | |||
if vfsManager.ReadFile('lang/strings', str) then | |||
Entity.LoadFromStream(str.GetStream); | |||
end; | |||
result := Entity; | |||
end; | |||
function __(Name: string; Default: string): string; | |||
begin | |||
if Default=#0 then | |||
Default := Name; | |||
Result := utlLocalizationDatabase.Translate(Name); | |||
if (Result = '') then | |||
Result := Default; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlLocalizationItem//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//erstellt das Objekt | |||
constructor TutlLocalizationItem.Create; | |||
begin | |||
inherited Create; | |||
Name := ''; | |||
Comment := ''; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlLocalizationDatabase/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//Get-Methode der Count-Eigenschaft | |||
function TutlLocalizationDatabase.GetCount: Integer; | |||
begin | |||
result := fStringList.Count; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//Get-Methode der Value-Eigenschaft | |||
function TutlLocalizationDatabase.GetObject(Index: Integer): TutlLocalizationItem; | |||
begin | |||
if (Index >= 0) and (Index < fStringList.Count) then | |||
result := fStringList.ValueAt[Index] | |||
else | |||
result := nil; | |||
end; | |||
function TutlLocalizationDatabase.AddName(const Name, Comment: string): TutlLocalizationItem; | |||
var | |||
e: TutlLocalizationItem; | |||
i: Integer; | |||
begin | |||
i := fStringList.IndexOf(Name); | |||
if i >= 0 then | |||
Result:= Objects[i] | |||
else begin | |||
e := TutlLocalizationItem.Create; | |||
e.Name := Name; | |||
e.Comment := Comment; | |||
fStringList.Add(e.Name, e); | |||
result := e; | |||
end; | |||
end; | |||
function TutlLocalizationDatabase.RemoveName(const Name: string): boolean; | |||
begin | |||
Result:= fStringList.IndexOf(Name) >= 0; | |||
if Result then | |||
fStringList.Delete(Name); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//läd die Datenbank aus einem Stream | |||
//@aStream: Stream aus der geladen werden soll; | |||
procedure TutlLocalizationDatabase.LoadFromStream(const aStream: TStream); | |||
const | |||
HEADER = 'StringDatabase'; | |||
var | |||
rd: TutlStreamReader; | |||
csv: TutlCSVList; | |||
co: string; | |||
begin | |||
rd:= TutlStreamReader.Create(aStream); | |||
try | |||
if HEADER <> rd.ReadLine then | |||
raise Exception.Create('TStringDatabase.LoadFromStream - invalid Stream'); | |||
fStringList.Clear; | |||
csv:= TutlCSVList.Create; | |||
try | |||
csv.Delimiter:= ';'; | |||
csv.StrictDelimitedText:= rd.ReadLine; | |||
while csv.Count>=1 do begin | |||
co:= ''; | |||
if csv.Count>1 then | |||
co:= csv[1]; | |||
AddName(csv[0],co); | |||
// next line | |||
csv.StrictDelimitedText:= rd.ReadLine; | |||
end; | |||
finally | |||
FreeAndNil(csv); | |||
end; | |||
finally | |||
FreeAndNil(rd); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//speichert die Datenbank in einem Stream | |||
//@aStream: Stream in dem gespeichert werden soll; | |||
procedure TutlLocalizationDatabase.SaveToStream(const aStream: TStream); | |||
const | |||
HEADER = 'StringDatabase'; | |||
var | |||
i: Integer; | |||
wr: TutlStreamWriter; | |||
csv: TutlCSVList; | |||
o: TutlLocalizationItem; | |||
begin | |||
wr:= TutlStreamWriter.Create(aStream); | |||
try | |||
wr.WriteLine(HEADER); | |||
csv:= TutlCSVList.Create; | |||
try | |||
csv.Delimiter:= ';'; | |||
for i := 0 to fStringList.Count-1 do begin | |||
csv.Clear; | |||
o:= Objects[i]; | |||
csv.Add(o.Name); | |||
csv.Add(o.Comment); | |||
wr.WriteLine(csv.StrictDelimitedText); | |||
end; | |||
finally | |||
FreeAndNil(csv); | |||
end; | |||
finally | |||
FreeAndNil(wr); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlLocalizationDatabase.LoadLanguage(const aStream: TStream); | |||
begin | |||
fLangFile.Free; | |||
fLangFile := nil; | |||
fLangFile := TMOFile.Create(aStream); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlLocalizationDatabase.Translate(const Name: string): string; | |||
begin | |||
if Assigned(fLangFile) then | |||
Result := UTF8Encode(fLangFile.Translate(Name)) | |||
else | |||
Result := ''; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//erstellt das Objekt | |||
constructor TutlLocalizationDatabase.Create; | |||
begin | |||
inherited Create; | |||
fStringList := TStringObjMap.Create(True); | |||
fLangFile := nil; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//gibt das Objekt frei | |||
destructor TutlLocalizationDatabase.Destroy; | |||
begin | |||
fLangFile.Free; | |||
fStringList.Free; | |||
inherited Destroy; | |||
end; | |||
finalization | |||
FreeAndNil(Entity); | |||
end. | |||
@@ -0,0 +1,436 @@ | |||
unit uutlLogger; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält das Logging-Framework | |||
Anzusprechen über Singleton: utlLogger | |||
Die einzelnen Level sind über die Methoden Debug(), Info(), Warning(), Error() zugänglich. | |||
Sender: entweder eigener Text oder TObject-Referenz, dann wird Klassenname und Adresse ausgegeben. | |||
Log-Zeilen werden nicht weiter behandelt, sondern an Consumer verteilt. | |||
Es können beliebig viele Consumer per RegisterConsumer für bestimmte Level registriert werden. | |||
Jeder davon bekommt die Rohdaten eines Logeintrags auf einer beobachteten Stufe. | |||
Zum einfacheren Ausgeben gibt es eine Hilfsfunktion FormatLine vom Logger. | |||
Vordefinierte Consumer: | |||
TutlFileLogger - schreibt in eine Datei | |||
TutlConsoleLogger - schreibt auf die Konsole (ggf. mit CriticalSection) | |||
TutlEventLogger - ruft beliebiges Event auf | |||
} | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
{$IFDEF MSWINDOWS}Windows{$ELSE}unix{$ENDIF}, | |||
Classes, SysUtils, uutlGenerics, syncobjs, uutlCommon; | |||
type | |||
TutlLogLevel = (llDebug, llInfo, llWarning, llError); | |||
TutlLogLevels = set of TutlLogLevel; | |||
const | |||
utlLogLevel_Any = [low(TutlLogLevel)..high(TutlLogLevel)]; | |||
utlLogLevel_NoDebug = utlLogLevel_Any - [llDebug]; | |||
utlLogLevelStrings: array[TutlLogLevel] of string = | |||
('Debug','Info','Warning','Error'); | |||
type | |||
TutlLogger = class; | |||
IutlLogConsumer = interface(IUnknown) | |||
procedure WriteLog(const aLogger: TutlLogger; const aTime:TDateTime; const aLevel:TutlLogLevel; const aSender: string; const aMessage: String); | |||
end; | |||
TutlLogConsumerList = specialize TutlInterfaceList<IutlLogConsumer>; | |||
{ TutlLogger } | |||
TutlLogger = class(TObject) | |||
private | |||
fConsumersLock: TCriticalSection; | |||
fConsumers: array[TutlLogLevel] of TutlLogConsumerList; | |||
protected | |||
class function FormatTime(const aTime:TDateTime): string; | |||
function FormatSender(const aSender: TObject): String; | |||
procedure InternalLog(const aLevel:TutlLogLevel; const aSender: TObject; const aMessage: String; const aParams: array of const); overload; | |||
procedure InternalLog(const aLevel:TutlLogLevel; const aSender: String; const aMessage: String; const aParams: array of const); overload; | |||
public | |||
procedure RegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter:TutlLogLevels=utlLogLevel_Any); | |||
procedure UnRegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter:TutlLogLevels=utlLogLevel_Any); | |||
class function FormatLine(const aTime:TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String): string; | |||
procedure Debug(const aSender: TObject; const aMessage: String; const aParams: array of const); overload; | |||
procedure Debug(const aSender: String; const aMessage: String; const aParams: array of const); overload; | |||
procedure Log(const aSender: TObject; const aMessage: String; const aParams: array of const); overload; | |||
procedure Log(const aSender: String; const aMessage: String; const aParams: array of const); overload; | |||
procedure Warning(const aSender: TObject; const aMessage: String; const aParams: array of const); overload; | |||
procedure Warning(const aSender: String; const aMessage: String; const aParams: array of const); overload; | |||
procedure Error(const aSender: TObject; const aMessage: String; const aParams: array of const); overload; | |||
procedure Error(const aSender: String; const aMessage: String; const aParams: array of const); overload; | |||
procedure Error(const aSender: String; const aMessage: String; const aException: Exception); overload; | |||
procedure Error(const aSender: TObject; const aMessage: String; const aException: Exception); overload; | |||
constructor Create; | |||
destructor Destroy; override; | |||
end; | |||
{ TutlFileLogger } | |||
TutlFileLoggerMode = (flmCreateNew, flmAppend); | |||
TutlFileLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer) | |||
private | |||
fStream: TFileStream; | |||
fAutoFlush: boolean; | |||
protected | |||
procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); | |||
public | |||
constructor Create(const aFilename: String; const aMode: TutlFileLoggerMode); | |||
destructor Destroy; override; | |||
procedure Flush(); overload; | |||
published | |||
property AutoFlush:boolean read fAutoFlush write fAutoFlush; | |||
end; | |||
{ TutlConsoleLogger } | |||
TutlConsoleLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer) | |||
private | |||
fFreeConsoleCS: boolean; | |||
fConsoleCS: TCriticalSection; | |||
fOnBeforeLog: TNotifyEvent; | |||
fOnAfterLog: TNotifyEvent; | |||
protected | |||
procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); virtual; | |||
public | |||
property ConsoleCS: TCriticalSection read fConsoleCS; | |||
property OnBeforeLog: TNotifyEvent read fOnBeforeLog write fOnBeforeLog; | |||
property OnAfterLog: TNotifyEvent read fOnAfterLog write fOnAfterLog; | |||
constructor Create(const aSection: TCriticalSection = nil); | |||
destructor Destroy; override; | |||
end; | |||
{ TutlEventLogger } | |||
TutlWriteLogEvent = procedure (const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String) of object; | |||
TutlEventLogger = class(TutlInterfaceNoRefCount, IutlLogConsumer) | |||
private | |||
fWriteLogEvt: TutlWriteLogEvent; | |||
protected | |||
procedure WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); | |||
public | |||
constructor Create(const aEvent: TutlWriteLogEvent); | |||
end; | |||
function utlLogger: TutlLogger; | |||
function utlCreateStackTrace(const aMessage: String; const aException: Exception): String; | |||
implementation | |||
var | |||
utlLogger_Singleton: TutlLogger; | |||
function utlLogger: TutlLogger; | |||
begin | |||
if not Assigned(utlLogger_Singleton) then | |||
utlLogger_Singleton:= TutlLogger.Create; | |||
Result:= utlLogger_Singleton; | |||
end; | |||
function utlCreateStackTrace(const aMessage: String; const aException: Exception): String; | |||
var | |||
i: Integer; | |||
frames: PPointer; | |||
begin | |||
result := aMessage; | |||
if Assigned(aException) then | |||
result := result + sLineBreak + | |||
' Exception: ' + aException.ClassName + sLineBreak + | |||
' Message: ' + aException.Message + sLineBreak + | |||
' StackTrace:' + sLineBreak + | |||
' ' + BackTraceStrFunc(ExceptAddr) | |||
else | |||
result := result + 'no Exception passed'; | |||
frames := ExceptFrames; | |||
for i := 0 to ExceptFrameCount-1 do | |||
result := result + sLineBreak + ' ' + BackTraceStrFunc(frames[i]); | |||
end; | |||
{ TutlFileLogger } | |||
function FileFlush(Handle: THandle): Boolean; | |||
begin | |||
{$IFDEF MSWINDOWS} | |||
Result:= FlushFileBuffers(Handle); | |||
{$ELSE} | |||
Result:= (fpfsync(Handle) = 0); | |||
{$ENDIF} | |||
end; | |||
procedure TutlFileLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; | |||
const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); | |||
var | |||
buf: AnsiString; | |||
begin | |||
if Assigned(fStream) then begin | |||
buf:= aLogger.FormatLine(aTime, aLevel, aSender, aMessage)+sLineBreak; | |||
fStream.Write(buf[1], Length(buf)); | |||
if AutoFlush then | |||
FileFlush(fStream.Handle); | |||
end; | |||
end; | |||
constructor TutlFileLogger.Create(const aFilename: String; const aMode: TutlFileLoggerMode); | |||
const | |||
RIGHTS: Cardinal = {$IFNDEF UNIX}fmShareDenyWrite{$ELSE}%0100100100 {-r--r--r--}{$ENDIF}; | |||
begin | |||
try | |||
if (aMode = flmCreateNew) or not FileExists(aFilename) then begin | |||
if FileExists(aFilename) then | |||
DeleteFile(aFilename); | |||
fStream := TFileStream.Create(aFilename, fmCreate{$IFNDEF UNIX} or RIGHTS{$ENDIF}, RIGHTS) | |||
end else | |||
fStream := TFileStream.Create(aFilename, fmOpenReadWrite{$IFNDEF UNIX} or RIGHTS{$ENDIF}, RIGHTS); | |||
fStream.Position := fStream.Size; | |||
except | |||
on e: EStreamError do begin | |||
fStream:= nil; | |||
utlLogger.Error('Logger', 'Could not open log file "%s"',[aFilename]); | |||
end else | |||
raise; | |||
end; | |||
AutoFlush:=true; | |||
end; | |||
destructor TutlFileLogger.Destroy; | |||
begin | |||
FreeAndNil(fStream); | |||
inherited Destroy; | |||
end; | |||
procedure TutlFileLogger.Flush; | |||
begin | |||
if Assigned(fStream) then | |||
FileFlush(fStream.Handle); | |||
end; | |||
{ TutlConsoleLogger } | |||
procedure TutlConsoleLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; | |||
const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); | |||
begin | |||
fConsoleCS.Acquire; | |||
try | |||
if Assigned(fOnBeforeLog) then | |||
fOnBeforeLog(Self); | |||
WriteLn(aLogger.FormatLine(aTime, aLevel, aSender, aMessage)); | |||
if Assigned(fOnAfterLog) then | |||
fOnAfterLog(Self); | |||
finally | |||
fConsoleCS.Release; | |||
end; | |||
end; | |||
constructor TutlConsoleLogger.Create(const aSection: TCriticalSection); | |||
begin | |||
inherited Create; | |||
if Assigned(aSection) then | |||
fConsoleCS:= aSection | |||
else | |||
fConsoleCS:= TCriticalSection.Create; | |||
fFreeConsoleCS:= not Assigned(aSection); | |||
end; | |||
destructor TutlConsoleLogger.Destroy; | |||
begin | |||
if fFreeConsoleCS then | |||
FreeAndNil(fConsoleCS); | |||
inherited Destroy; | |||
end; | |||
{ TutlEventLogger } | |||
procedure TutlEventLogger.WriteLog(const aLogger: TutlLogger; const aTime: TDateTime; | |||
const aLevel: TutlLogLevel; const aSender: string; const aMessage: String); | |||
begin | |||
fWriteLogEvt(aLogger,aTime, aLevel, aSender, aMessage); | |||
end; | |||
constructor TutlEventLogger.Create(const aEvent: TutlWriteLogEvent); | |||
begin | |||
inherited Create; | |||
fWriteLogEvt:= aEvent; | |||
end; | |||
{ TutlLogger } | |||
procedure TutlLogger.RegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter: TutlLogLevels); | |||
var | |||
ll: TutlLogLevel; | |||
begin | |||
fConsumersLock.Acquire; | |||
try | |||
for ll:= low(ll) to high(ll) do | |||
if (ll in aFilter) and (fConsumers[ll].IndexOf(aConsumer)<0) then | |||
fConsumers[ll].Add(aConsumer); | |||
finally | |||
fConsumersLock.Release; | |||
end; | |||
if llDebug in aFilter then | |||
aConsumer.WriteLog(Self, Now, llDebug, 'System', 'Attached to Logger'); | |||
end; | |||
procedure TutlLogger.UnRegisterConsumer(const aConsumer: IutlLogConsumer; const aFilter: TutlLogLevels); | |||
var | |||
ll: TutlLogLevel; | |||
begin | |||
fConsumersLock.Acquire; | |||
try | |||
for ll:= low(ll) to high(ll) do | |||
if ll in aFilter then | |||
fConsumers[ll].Remove(aConsumer); | |||
finally | |||
fConsumersLock.Release; | |||
end; | |||
end; | |||
class function TutlLogger.FormatTime(const aTime: TDateTime): string; | |||
begin | |||
Result:= FormatDateTime('hh:nn:ss.zzz',aTime); | |||
end; | |||
function TutlLogger.FormatSender(const aSender: TObject): String; | |||
begin | |||
if Assigned(aSender) then | |||
result := format('%s[0x%P]', [aSender.ClassName, Pointer(aSender)]) | |||
else | |||
result := ''; | |||
end; | |||
class function TutlLogger.FormatLine(const aTime: TDateTime; const aLevel: TutlLogLevel; const aSender: string; const aMessage: String): string; | |||
begin | |||
if (aSender <> '') then | |||
Result:= Format('%s %-9s %s: %s', [FormatTime(aTime), UpperCase(utlLogLevelStrings[aLevel]), aSender, aMessage]) | |||
else | |||
Result:= Format('%s %-9s %s', [FormatTime(aTime), UpperCase(utlLogLevelStrings[aLevel]), aMessage]); | |||
end; | |||
procedure TutlLogger.InternalLog(const aLevel: TutlLogLevel; const aSender: TObject; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(aLevel, FormatSender(aSender), aMessage, aParams); | |||
end; | |||
procedure TutlLogger.InternalLog(const aLevel: TutlLogLevel; const aSender: String; const aMessage: String; const aParams: array of const); | |||
var | |||
msg: string; | |||
when: TDateTime; | |||
i: integer; | |||
begin | |||
if length(aParams) = 0 then | |||
msg:= aMessage | |||
else | |||
msg:= Format(aMessage, aParams); | |||
when:= Now; | |||
fConsumersLock.Acquire; | |||
try | |||
for i:= 0 to fConsumers[aLevel].Count-1 do begin | |||
fConsumers[aLevel][i].WriteLog(Self, when, aLevel, aSender, msg); | |||
end; | |||
finally | |||
fConsumersLock.Release; | |||
end; | |||
end; | |||
procedure TutlLogger.Debug(const aSender: TObject; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llDebug, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Debug(const aSender: String; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llDebug, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Log(const aSender: TObject; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llInfo, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Log(const aSender: String; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llInfo, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Warning(const aSender: TObject; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llWarning, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Warning(const aSender: String; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llWarning, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Error(const aSender: TObject; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llError, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Error(const aSender: String; const aMessage: String; const aParams: array of const); | |||
begin | |||
InternalLog(llError, aSender, aMessage, aParams); | |||
end; | |||
procedure TutlLogger.Error(const aSender: String; const aMessage: String; const aException: Exception); | |||
begin | |||
InternalLog(llError, aSender, utlCreateStackTrace(aMessage, aException), []); | |||
end; | |||
procedure TutlLogger.Error(const aSender: TObject; const aMessage: String; const aException: Exception); | |||
begin | |||
InternalLog(llError, aSender, utlCreateStackTrace(aMessage, aException), []); | |||
end; | |||
constructor TutlLogger.Create; | |||
var | |||
ll: TutlLogLevel; | |||
begin | |||
inherited Create; | |||
fConsumersLock:= TCriticalSection.Create; | |||
fConsumersLock.Acquire; | |||
try | |||
for ll:= low(ll) to high(ll) do begin | |||
fConsumers[ll]:= TutlLogConsumerList.Create; | |||
end; | |||
finally | |||
fConsumersLock.Release; | |||
end; | |||
end; | |||
destructor TutlLogger.Destroy; | |||
var | |||
ll: TutlLogLevel; | |||
begin | |||
fConsumersLock.Acquire; | |||
try | |||
for ll:= low(ll) to high(ll) do begin | |||
fConsumers[ll].Clear; | |||
FreeAndNil(fConsumers[ll]); | |||
end; | |||
finally | |||
fConsumersLock.Release; | |||
end; | |||
FreeAndNil(fConsumersLock); | |||
inherited Destroy; | |||
end; | |||
finalization | |||
FreeAndNil(utlLogger_Singleton); | |||
end. | |||
@@ -0,0 +1,645 @@ | |||
unit uutlMCF; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält Klassen zum Lesen und Schreiben eines MuoConfgiFiles (kurz MCF) | |||
Lesen/Schreiben in/von Stream über TutlMCFFile | |||
LineEndMode zur Kompatibilität mit MCF-alt und KCF: | |||
leNone - Kein Semikolon erlaubt (KCF) | |||
leAcceptNoWrite - Semikolon wird beim Lesen ignoriert, beim Schreiben weggelassen | |||
leAlways - Beim Lesen erforderlich, immer geschrieben (MCF-alt) | |||
Jeder SectionName und jeder ValueName ist Unique, es kann aber ein Value und eine | |||
Section mit dem gleichen Namen existieren | |||
Zugriff auf Subsections über .Section(), mehrere Stufen auf einmal mit . getrennt: | |||
mcf.Section('foo.bar.baz') === mcf.Section('foo').Section('bar').Section('baz') | |||
Zugriff erstellt automatisch eine Section, falls sie nicht existiert. Prüfung mit | |||
SectionExists (nur direkt, keine Pfade!). | |||
Zugriff auf Werte von der Section aus: | |||
Get/Set[Int,Float,String,Bool](Key, Default) | |||
ValueExists() | |||
UnsetValue() | |||
Strings sind Widestrings, Un/Escaping passiert beim Dateizugriff automatisch | |||
Enumeration: ValueCount/ValueNameAt, SectionCount/SectionNameAt } | |||
interface | |||
uses | |||
SysUtils, Classes, uutlStreamHelper; | |||
type | |||
EConfigException = class(Exception) | |||
end; | |||
TutlMCFSection = class; | |||
TutlMCFFile = class; | |||
TutlMCFLineEndMarkerMode = (leNone, leAcceptNoWrite, leAlways); | |||
{ TutlMCFSection } | |||
TutlMCFSection = class | |||
private type | |||
TSectionEnumerator = class(TObject) | |||
private | |||
fList: TStringList; | |||
fPosition: Integer; | |||
function GetCurrent: TutlMCFSection; | |||
public | |||
property Current: TutlMCFSection read GetCurrent; | |||
function MoveNext: Boolean; | |||
constructor Create(const aList: TStringList); | |||
end; | |||
private | |||
FSections, | |||
FValues: TStringList; | |||
function GetSection(aPath: String): TutlMCFSection; | |||
function GetSectionCount: integer; | |||
function GetSectionName(Index: integer): string; | |||
function GetSectionByIndex(aIndex: Integer): TutlMCFSection; | |||
function GetValueCount: integer; | |||
function GetValueName(Index: integer): string; | |||
protected | |||
procedure ClearSections; | |||
procedure ClearValues; | |||
procedure SaveData(Stream: TStream; Indent: string; LineEnds: TutlMCFLineEndMarkerMode); | |||
procedure LoadData(Data: TStream; LineEnds: TutlMCFLineEndMarkerMode; Depth: Integer); | |||
procedure AddValueChecked(Name: String; Val: TObject); | |||
procedure SplitPath(const Path: String; out First, Rest: String); | |||
public | |||
constructor Create; | |||
destructor Destroy; override; | |||
function GetEnumerator: TSectionEnumerator; | |||
property ValueCount: integer read GetValueCount; | |||
property ValueNameAt[Index: integer]: string read GetValueName; | |||
property SectionCount: integer read GetSectionCount; | |||
property SectionNameAt[Index: integer]: string read GetSectionName; | |||
property Sections[aPath: String]: TutlMCFSection read GetSection; default; | |||
property SectionByIndex[aIndex: Integer]: TutlMCFSection read GetSectionByIndex; | |||
function SectionExists(Path: string): boolean; | |||
function Section(Path: string): TutlMCFSection; | |||
procedure DeleteSection(Name: string); | |||
function ValueExists(Name: string): boolean; | |||
function GetInt(Name: string; Default: Int64 = 0): Int64; overload; | |||
function GetFloat(Name: string; Default: Double = 0): Double; overload; | |||
function GetString(Name: string; Default: AnsiString = ''): AnsiString; overload; | |||
function GetStringW(Name: string; Default: UnicodeString = ''): UnicodeString; overload; | |||
function GetBool(Name: string; Default: Boolean = false): Boolean; overload; | |||
procedure SetInt(Name: string; Value: Int64); overload; | |||
procedure SetFloat(Name: string; Value: Double); overload; | |||
procedure SetString(Name: string; Value: WideString); overload; | |||
procedure SetString(Name: string; Value: AnsiString); overload; | |||
procedure SetBool(Name: string; Value: Boolean); overload; | |||
procedure UnsetValue(Name: string); | |||
end; | |||
{ TutlMCFFile } | |||
TutlMCFFile = class(TutlMCFSection) | |||
private | |||
fLineEndMode: TutlMCFLineEndMarkerMode; | |||
public | |||
constructor Create(Data: TStream; LineEndMode: TutlMCFLineEndMarkerMode = leAcceptNoWrite); | |||
procedure LoadFromStream(Stream: TStream); | |||
procedure SaveToStream(Stream: TStream); | |||
end; | |||
implementation | |||
uses Variants, StrUtils; | |||
const | |||
sComment = '#'; | |||
sSectionEnd = 'end'; | |||
sSectionMarker = ':'; | |||
sSectionPathDelim = '.'; | |||
sLineEndMarker = ';'; | |||
sValueDelim = '='; | |||
sValueQuote = ''''; | |||
sValueDecimal = '.'; | |||
sIndentOnSave = ' '; | |||
sNameValidChars = [' ' .. #$7F] - [sValueDelim]; | |||
sWhitespaceChars = [#0 .. ' ']; | |||
type | |||
StoredValue = Variant; | |||
{ TutlMCFValue } | |||
TutlMCFValue = class | |||
private | |||
Format: TFormatSettings; | |||
FValue: StoredValue; | |||
procedure SetValue(const Value: StoredValue); | |||
protected | |||
function CheckSpecialChars(Data: WideString): boolean; | |||
procedure LoadData(Data: string); | |||
function SaveData: string; | |||
class function Escape(Value: WideString): AnsiString; | |||
class function Unescape(Value: AnsiString): WideString; | |||
public | |||
constructor Create(Val: StoredValue); | |||
property Value: StoredValue read FValue write SetValue; | |||
end; | |||
{ TkcfValue } | |||
constructor TutlMCFValue.Create(Val: StoredValue); | |||
begin | |||
inherited Create; | |||
SetValue(Val); | |||
Format.DecimalSeparator:= sValueDecimal; | |||
end; | |||
procedure TutlMCFValue.SetValue(const Value: StoredValue); | |||
begin | |||
FValue:= Value; | |||
end; | |||
function TutlMCFValue.CheckSpecialChars(Data: WideString): boolean; | |||
var | |||
i: Integer; | |||
begin | |||
result := false; | |||
for i:= 1 to Length(Data) do | |||
if Data[i] in [sSectionMarker, sValueQuote, sValueDelim, sLineEndMarker, ' '] then | |||
exit; | |||
result := true; | |||
end; | |||
procedure TutlMCFValue.LoadData(Data: string); | |||
var | |||
b: boolean; | |||
i: int64; | |||
d: double; | |||
p: PChar; | |||
begin | |||
if TryStrToInt64(Data, i) then | |||
Value:= i | |||
else if TryStrToFloat(Data, d, Format) then | |||
Value:= d | |||
else if TryStrToBool(Data, b) then | |||
Value:= b | |||
else begin | |||
p:= PChar(Data); | |||
if p^ = sValueQuote then | |||
Data := AnsiExtractQuotedStr(p, sValueQuote); | |||
Value:= Unescape(Trim(Data)); | |||
end; | |||
end; | |||
function TutlMCFValue.SaveData: string; | |||
begin | |||
if VarIsType(FValue, varBoolean) then | |||
Result:= BoolToStr(FValue, false) | |||
else if VarIsType(FValue, varInt64) then | |||
Result:= IntToStr(FValue) | |||
else if VarIsType(FValue, varDouble) then | |||
Result:= FloatToStr(Double(FValue), Format) | |||
else begin | |||
Result:= Escape(FValue); | |||
if not CheckSpecialChars(WideString(Result)) then | |||
Result:= AnsiQuotedStr(Result, sValueQuote); | |||
end; | |||
end; | |||
class function TutlMCFValue.Escape(Value: WideString): AnsiString; | |||
var | |||
i: integer; | |||
wc: WideChar; | |||
begin | |||
Result:= ''; | |||
for i:= 1 to length(Value) do begin | |||
wc:= Value[i]; | |||
case Ord(wc) of | |||
Ord('\'), | |||
$007F..$FFFF: Result:= Result + '\'+IntToHex(ord(wc),4); | |||
else | |||
Result:= Result + AnsiChar(wc); | |||
end; | |||
end; | |||
end; | |||
class function TutlMCFValue.Unescape(Value: AnsiString): WideString; | |||
var | |||
i: integer; | |||
c: Char; | |||
begin | |||
Result:= ''; | |||
i:= 1; | |||
while i <= length(value) do begin | |||
c:= Value[i]; | |||
if c='\' then begin | |||
Result:= Result + WideChar(StrToInt('$'+Copy(Value,i+1,4))); | |||
inc(i, 4); | |||
end else | |||
Result:= Result + WideChar(c); | |||
inc(i); | |||
end; | |||
end; | |||
{ TutlMCFSection.TSectionEnumerator } | |||
function TutlMCFSection.TSectionEnumerator.GetCurrent: TutlMCFSection; | |||
begin | |||
result := TutlMCFSection(fList.Objects[fPosition]); | |||
end; | |||
function TutlMCFSection.TSectionEnumerator.MoveNext: Boolean; | |||
begin | |||
inc(fPosition); | |||
result := (fPosition < fList.Count); | |||
end; | |||
constructor TutlMCFSection.TSectionEnumerator.Create(const aList: TStringList); | |||
begin | |||
inherited Create; | |||
fList := aList; | |||
fPosition := -1; | |||
end; | |||
{ TkcfCompound } | |||
constructor TutlMCFSection.Create; | |||
begin | |||
inherited; | |||
FSections:= TStringList.Create; | |||
FSections.CaseSensitive:= false; | |||
FSections.Sorted:= true; | |||
FSections.Duplicates:= dupError; | |||
FValues:= TStringList.Create; | |||
FValues.CaseSensitive:= false; | |||
FValues.Sorted:= true; | |||
FValues.Duplicates:= dupError; | |||
end; | |||
destructor TutlMCFSection.Destroy; | |||
begin | |||
ClearSections; | |||
ClearValues; | |||
FreeAndNil(FSections); | |||
FreeAndNil(FValues); | |||
inherited; | |||
end; | |||
function TutlMCFSection.GetEnumerator: TSectionEnumerator; | |||
begin | |||
result := TSectionEnumerator.Create(FSections); | |||
end; | |||
function TutlMCFSection.GetSectionCount: integer; | |||
begin | |||
Result:= FSections.Count; | |||
end; | |||
function TutlMCFSection.GetSection(aPath: String): TutlMCFSection; | |||
begin | |||
result := Section(aPath); | |||
end; | |||
function TutlMCFSection.GetSectionByIndex(aIndex: Integer): TutlMCFSection; | |||
begin | |||
result := (FSections.Objects[aIndex] as TutlMCFSection); | |||
end; | |||
function TutlMCFSection.GetSectionName(Index: integer): string; | |||
begin | |||
Result:= FSections[Index]; | |||
end; | |||
function TutlMCFSection.GetValueCount: integer; | |||
begin | |||
Result:= FValues.Count; | |||
end; | |||
function TutlMCFSection.GetValueName(Index: integer): string; | |||
begin | |||
Result:= FValues[Index]; | |||
end; | |||
procedure TutlMCFSection.ClearSections; | |||
var | |||
i: integer; | |||
begin | |||
for i:= FSections.Count - 1 downto 0 do | |||
FSections.Objects[i].Free; | |||
FSections.Clear; | |||
end; | |||
procedure TutlMCFSection.ClearValues; | |||
var | |||
i: integer; | |||
begin | |||
for i:= FValues.Count - 1 downto 0 do | |||
FValues.Objects[i].Free; | |||
FValues.Clear; | |||
end; | |||
procedure TutlMCFSection.SplitPath(const Path: String; out First, Rest: String); | |||
begin | |||
First:= Copy(Path, 1, Pos(sSectionPathDelim, Path)-1); | |||
if First='' then begin | |||
First:= Path; | |||
Rest:= ''; | |||
end else begin | |||
Rest:= Copy(Path, Length(First)+2, MaxInt); | |||
end; | |||
end; | |||
function TutlMCFSection.SectionExists(Path: string): boolean; | |||
var | |||
f,r: String; | |||
i: integer; | |||
begin | |||
SplitPath(Path, f, r); | |||
i:= FSections.IndexOf(f); | |||
Result:= (i >= 0) and ((r='') or (TutlMCFSection(FSections.Objects[i]).SectionExists(r))); | |||
end; | |||
function TutlMCFSection.Section(Path: string): TutlMCFSection; | |||
var | |||
f,r: String; | |||
i: integer; | |||
begin | |||
SplitPath(Path, f, r); | |||
i:= FSections.IndexOf(f); | |||
if r <> '' then begin | |||
if (i >= 0) then | |||
Result:= TutlMCFSection(FSections.Objects[i]).Section(r) | |||
else begin | |||
result := TutlMCFSection.Create; | |||
fSections.AddObject(f, result); | |||
result := result.Section(r); | |||
end; | |||
end else begin | |||
if i >= 0 then | |||
Result:= TutlMCFSection(FSections.Objects[i]) | |||
else begin | |||
Result:= TutlMCFSection.Create; | |||
FSections.AddObject(f, Result); | |||
end; | |||
end; | |||
end; | |||
procedure TutlMCFSection.DeleteSection(Name: string); | |||
var | |||
i: integer; | |||
begin | |||
i:= FSections.IndexOf(Name); | |||
if i >= 0 then begin | |||
FSections.Objects[i].Free; | |||
FSections.Delete(i); | |||
end; | |||
end; | |||
function TutlMCFSection.ValueExists(Name: string): boolean; | |||
begin | |||
Result:= FValues.IndexOf(Name) >= 0; | |||
end; | |||
function TutlMCFSection.GetInt(Name: string; Default: Int64): Int64; | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
Result:= Default | |||
else | |||
Result:= TutlMCFValue(FValues.Objects[i]).Value; | |||
end; | |||
function TutlMCFSection.GetFloat(Name: string; Default: Double): Double; | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
Result:= Default | |||
else | |||
Result:= TutlMCFValue(FValues.Objects[i]).Value; | |||
end; | |||
function TutlMCFSection.GetStringW(Name: string; Default: UnicodeString): UnicodeString; | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
Result:= Default | |||
else | |||
Result:= TutlMCFValue(FValues.Objects[i]).Value; | |||
end; | |||
function TutlMCFSection.GetString(Name: string; Default: AnsiString): AnsiString; | |||
begin | |||
Result := AnsiString(GetStringW(Name, UnicodeString(Default))); | |||
end; | |||
function TutlMCFSection.GetBool(Name: string; Default: Boolean): Boolean; | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
Result:= Default | |||
else | |||
Result:= TutlMCFValue(FValues.Objects[i]).Value; | |||
end; | |||
procedure TutlMCFSection.AddValueChecked(Name: String; Val: TObject); | |||
var | |||
i: integer; | |||
begin | |||
if (Length(Name) < 1) or | |||
(Name[1] in sWhitespaceChars) or | |||
(Name[Length(Name)] in sWhitespaceChars) then | |||
raise EConfigException.CreateFmt('Invalid Value Name: "%s"',[Name]); | |||
for i:= 1 to Length(Name) do | |||
if not (Name[i] in sNameValidChars) then | |||
raise EConfigException.CreateFmt('Invalid Value Name: "%s"',[Name]); | |||
FValues.AddObject(Name, Val); | |||
end; | |||
procedure TutlMCFSection.SetInt(Name: string; Value: Int64); | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
AddValueChecked(Name, TutlMCFValue.Create(Value)) | |||
else | |||
TutlMCFValue(FValues.Objects[i]).Value:= Value; | |||
end; | |||
procedure TutlMCFSection.SetFloat(Name: string; Value: Double); | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
AddValueChecked(Name, TutlMCFValue.Create(Value)) | |||
else | |||
TutlMCFValue(FValues.Objects[i]).Value:= Value; | |||
end; | |||
procedure TutlMCFSection.SetString(Name: string; Value: WideString); | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
AddValueChecked(Name, TutlMCFValue.Create(Value)) | |||
else | |||
TutlMCFValue(FValues.Objects[i]).Value:= Value; | |||
end; | |||
procedure TutlMCFSection.SetString(Name: string; Value: AnsiString); | |||
begin | |||
SetString(Name, WideString(Value)); | |||
end; | |||
procedure TutlMCFSection.SetBool(Name: string; Value: Boolean); | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i < 0 then | |||
AddValueChecked(Name, TutlMCFValue.Create(Value)) | |||
else | |||
TutlMCFValue(FValues.Objects[i]).Value:= Value; | |||
end; | |||
procedure TutlMCFSection.UnsetValue(Name: string); | |||
var | |||
i: integer; | |||
begin | |||
i:= FValues.IndexOf(Name); | |||
if i >= 0 then begin | |||
FValues.Objects[i].Free; | |||
FValues.Delete(i); | |||
end; | |||
end; | |||
procedure TutlMCFSection.LoadData(Data: TStream; LineEnds: TutlMCFLineEndMarkerMode; Depth: Integer); | |||
var | |||
reader: TutlStreamReader; | |||
l, sn, vn, vs: string; | |||
se: TutlMCFSection; | |||
va: TutlMCFValue; | |||
begin | |||
reader:= TutlStreamReader.Create(Data); | |||
try | |||
repeat | |||
l:= reader.ReadLine; | |||
l:= trim(l); | |||
if (l = '') or AnsiStartsStr(sComment, l) then | |||
continue; | |||
if ((LineEnds in [leNone, leAcceptNoWrite]) and (l = sSectionEnd)) or | |||
((LineEnds in [leAcceptNoWrite, leAlways]) and (l = sSectionEnd+sLineEndMarker)) then begin | |||
if Depth > 0 then | |||
exit | |||
else | |||
raise EConfigException.Create('Encountered Section End where none was expected.'); | |||
end; | |||
if AnsiEndsStr(sSectionMarker, l) then begin | |||
sn:= trim(Copy(l, 1, length(l) - length(sSectionMarker))); | |||
if SectionExists(sn) then | |||
raise EConfigException.Create('Redeclared Section: '+sn); | |||
if Pos(sSectionPathDelim,sn) > 0 then | |||
raise EConfigException.Create('Invalid Section Name: '+sn); | |||
se:= TutlMCFSection.Create; | |||
try | |||
se.LoadData(Data, LineEnds, Depth + 1); | |||
FSections.AddObject(sn, se); | |||
except | |||
FreeAndNil(se); | |||
end; | |||
end else if (Pos(sValueDelim, l) > 0) then begin | |||
if (LineEnds in [leAcceptNoWrite, leAlways]) and AnsiEndsStr(sLineEndMarker, l) then | |||
Delete(l, length(l), 1); | |||
vn:= trim(Copy(l, 1, Pos(sValueDelim, l) - 1)); | |||
vs:= trim(Copy(l, Pos(sValueDelim, l) + 1, Maxint)); | |||
if ValueExists(vn) then | |||
raise EConfigException.Create('Redeclared Value: '+vn); | |||
va:= TutlMCFValue.Create(''); | |||
try | |||
va.LoadData(vs); | |||
AddValueChecked(vn, va); | |||
except | |||
FreeAndNil(va); | |||
end; | |||
end else | |||
raise EConfigException.Create('Cannot Parse Line: '+l); | |||
until reader.IsEOF; | |||
if Depth > 0 then | |||
raise EConfigException.Create('Expected Section End, but reached stream end.'); | |||
Depth:= Depth - 1; | |||
finally | |||
FreeAndNil(reader); | |||
end; | |||
end; | |||
procedure TutlMCFSection.SaveData(Stream: TStream; Indent: string; | |||
LineEnds: TutlMCFLineEndMarkerMode); | |||
var | |||
writer: TutlStreamWriter; | |||
i: integer; | |||
ele, s: AnsiString; | |||
begin | |||
if LineEnds in [leAlways] then | |||
ele:= sLineEndMarker | |||
else | |||
ele:= ''; | |||
writer:= TutlStreamWriter.Create(Stream); | |||
try | |||
for i:= 0 to FValues.Count - 1 do begin | |||
s:= Indent + FValues[i] + ' ' + sValueDelim + ' ' + TutlMCFValue(FValues.Objects[i]).SaveData + ele; | |||
writer.WriteLine(s); | |||
end; | |||
for i:= 0 to FSections.Count - 1 do begin | |||
s:= Indent + FSections[i] + sSectionMarker; | |||
writer.WriteLine(s); | |||
TutlMCFSection(FSections.Objects[i]).SaveData(Stream, Indent + sIndentOnSave, LineEnds); | |||
s:= Indent + sSectionEnd + ele; | |||
writer.WriteLine(s); | |||
end; | |||
finally | |||
FreeAndNil(writer); | |||
end; | |||
end; | |||
{ TutlMCFFile } | |||
constructor TutlMCFFile.Create(Data: TStream; LineEndMode: TutlMCFLineEndMarkerMode); | |||
begin | |||
inherited Create; | |||
fLineEndMode:= LineEndMode; | |||
if Assigned(Data) then | |||
LoadFromStream(Data); | |||
end; | |||
procedure TutlMCFFile.LoadFromStream(Stream: TStream); | |||
begin | |||
ClearSections; | |||
ClearValues; | |||
LoadData(Stream, fLineEndMode, 0); | |||
end; | |||
procedure TutlMCFFile.SaveToStream(Stream: TStream); | |||
begin | |||
SaveData(Stream, '', fLineEndMode); | |||
end; | |||
end. | |||
@@ -0,0 +1,100 @@ | |||
unit uutlMcfHelper; | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
ugluMatrix, ugluVector, uutlMCF, uglcLight; | |||
procedure utlWriteMatrix4f(const aSection: TutlMCFSection; const aMatrix: TgluMatrix4f); | |||
function utlReadMatrix4f(const aSection: TutlMCFSection): TgluMatrix4f; | |||
procedure utlWriteMaterial(const aSection: TutlMCFSection; const aMaterial: TglcMaterialRec); | |||
function utlReadMaterial(const aSection: TutlMCFSection): TglcMaterialRec; | |||
procedure utlWriteLight(const aSection: TutlMCFSection; const aLight: TglcLightRec); | |||
function utlReadLight(const aSection: TutlMCFSection): TglcLightRec; | |||
implementation | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure utlWriteMatrix4f(const aSection: TutlMCFSection; const aMatrix: TgluMatrix4f); | |||
begin | |||
with aSection do begin | |||
SetString('AxisX', gluVector4fToStr(aMatrix[maAxisX])); | |||
SetString('AxisY', gluVector4fToStr(aMatrix[maAxisY])); | |||
SetString('AxisZ', gluVector4fToStr(aMatrix[maAxisZ])); | |||
SetString('Pos', gluVector4fToStr(aMatrix[maPos])); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlReadMatrix4f(const aSection: TutlMCFSection): TgluMatrix4f; | |||
begin | |||
with aSection do begin | |||
result[maAxisX] := gluStrToVector4f(GetString('AxisX', '1; 0; 0; 0;')); | |||
result[maAxisY] := gluStrToVector4f(GetString('AxisY', '0; 1; 0; 0;')); | |||
result[maAxisZ] := gluStrToVector4f(GetString('AxisZ', '0; 0; 1; 0;')); | |||
result[maPos] := gluStrToVector4f(GetString('Pos', '0; 0; 0; 1;')); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure utlWriteMaterial(const aSection: TutlMCFSection; const aMaterial: TglcMaterialRec); | |||
begin | |||
with aSection do begin | |||
SetString('Ambient', gluVector4fToStr(aMaterial.Ambient)); | |||
SetString('Diffuse', gluVector4fToStr(aMaterial.Diffuse)); | |||
SetString('Specular', gluVector4fToStr(aMaterial.Specular)); | |||
SetString('Emission', gluVector4fToStr(aMaterial.Emission)); | |||
SetFloat ('Shininess', aMaterial.Shininess); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlReadMaterial(const aSection: TutlMCFSection): TglcMaterialRec; | |||
begin | |||
with aSection do begin | |||
result.Ambient := gluStrToVector4f(GetString('Ambient', gluVector4fToStr(MAT_DEFAULT_AMBIENT))); | |||
result.Diffuse := gluStrToVector4f(GetString('Diffuse', gluVector4fToStr(MAT_DEFAULT_DIFFUSE))); | |||
result.Specular := gluStrToVector4f(GetString('Specular', gluVector4fToStr(MAT_DEFAULT_SPECULAR))); | |||
result.Emission := gluStrToVector4f(GetString('Emission', gluVector4fToStr(MAT_DEFAULT_EMISSION))); | |||
result.Shininess := GetFloat('Shininess', MAT_DEFAULT_SHININESS); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure utlWriteLight(const aSection: TutlMCFSection; const aLight: TglcLightRec); | |||
begin | |||
with aSection do begin | |||
SetString('Ambient', gluVector4fToStr(aLight.Ambient)); | |||
SetString('Diffuse', gluVector4fToStr(aLight.Diffuse)); | |||
SetString('Specular', gluVector4fToStr(aLight.Specular)); | |||
SetString('Position', gluVector4fToStr(aLight.Position)); | |||
SetString('SpotDirection', gluVector3fToStr(aLight.SpotDirection)); | |||
SetFloat ('SpotExponent', aLight.SpotExponent); | |||
SetFloat ('SpotCutoff', aLight.SpotCutoff); | |||
SetFloat ('ConstantAtt', aLight.ConstantAtt); | |||
SetFloat ('LinearAtt', aLight.LinearAtt); | |||
SetFloat ('QuadraticAtt', aLight.QuadraticAtt); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlReadLight(const aSection: TutlMCFSection): TglcLightRec; | |||
begin | |||
with aSection do begin | |||
result.Ambient := gluStrToVector4f(GetString('Ambient', gluVector4fToStr(LIGHT_DEFAULT_AMBIENT))); | |||
result.Diffuse := gluStrToVector4f(GetString('Diffuse', gluVector4fToStr(LIGHT_DEFAULT_DIFFUSE))); | |||
result.Specular := gluStrToVector4f(GetString('Specular', gluVector4fToStr(LIGHT_DEFAULT_SPECULAR))); | |||
result.Position := gluStrToVector4f(GetString('Position', gluVector4fToStr(LIGHT_DEFAULT_POSITION))); | |||
result.SpotDirection := gluStrToVector3f(GetString('SpotDirection', gluVector3fToStr(LIGHT_DEFAULT_SPOT_DIRECTION))); | |||
result.SpotExponent := GetFloat ('SpotExponent', LIGHT_DEFAULT_SPOT_EXPONENT); | |||
result.SpotCutoff := GetFloat ('SpotCutoff', LIGHT_DEFAULT_SPOT_CUTOFF); | |||
result.ConstantAtt := GetFloat ('ConstantAtt', LIGHT_DEFAULT_CONSTANT_ATT); | |||
result.LinearAtt := GetFloat ('LinearAtt', LIGHT_DEFAULT_LINEAR_ATT); | |||
result.QuadraticAtt := GetFloat ('QuadraticAtt', LIGHT_DEFAULT_QUADRATIC_ATT); | |||
end; | |||
end; | |||
end. | |||
@@ -0,0 +1,453 @@ | |||
unit uutlMessageThread; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit definiert einen Thread, der mit Hilfe von Messages Daten synchronisiert | |||
mit anderen Threads austauschen kann } | |||
{$mode objfpc}{$H+} | |||
{$DEFINE USE_SPINLOCK} | |||
interface | |||
uses | |||
Classes, SysUtils, syncobjs, uutlMessages; | |||
type | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlMessageThread = class(TThread, IUnknown) | |||
protected type | |||
TSingleLinkedListItem = class | |||
msg: TutlMessage; | |||
next: TSingleLinkedListItem; | |||
end; | |||
private | |||
{$IFDEF USE_SPINLOCK} | |||
fLocked: Cardinal; | |||
{$ELSE} | |||
fCritSec: TCriticalSection; | |||
{$ENDIF} | |||
fMsgEvent: TEvent; | |||
procedure PushMsg(aMessage: TutlMessage); | |||
function PullMsg: TutlMessage; | |||
procedure ClearMessages; | |||
protected | |||
fRefCount : longint; | |||
{ implement methods of IUnknown } | |||
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; | |||
function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; | |||
protected | |||
fFirst: TSingleLinkedListItem; | |||
fLast: TSingleLinkedListItem; | |||
procedure LockMessages; | |||
procedure UnlockMessages; | |||
function WaitForMessages(const aWaitTime: Cardinal = INFINITE): Boolean; | |||
function ProcessMessages: Boolean; virtual; | |||
procedure ProcessMessage(const {%H-}aMessage: TutlMessage); virtual; | |||
public | |||
//Messages Objects passed to PostMessage will be freed automatically | |||
procedure PostMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload; | |||
procedure PostMessage(const aID: Cardinal; const aArgs: TObject); overload; | |||
procedure PostMessage(const aMsg: TutlMessage); overload; | |||
//Messages Objects passed to SendMessage must be freed by user when WaitResult is wrSignaled (otherwise the thread will handle it) | |||
function SendMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt; | |||
const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||
function SendMessage(const aID: Cardinal; const aArgs: TObject; | |||
const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||
function SendMessage(const aMsg: TutlSynchronousMessage; | |||
const aWaitTime: Cardinal = INFINITE): TWaitResult; | |||
constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt=DefaultStackSize); | |||
destructor Destroy; override; | |||
end; | |||
//Messages Objects passed to PostMessage will be freed automatically | |||
function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt): Boolean; overload; | |||
function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject): Boolean; overload; | |||
function utlPostMessage(const aThreadID: TThreadID; const aMsg: TutlMessage): Boolean; overload; | |||
//Messages Objects passed to SendMessage must be freed by user when WaitResult is wrSignaled (otherwise the thread will handle it) | |||
function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt; | |||
const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||
function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject; | |||
const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||
function utlSendMessage(const aThreadID: TThreadID; const aMsg: TutlSynchronousMessage; | |||
const aWaitTime: Cardinal = INFINITE): TWaitResult; overload; | |||
implementation | |||
uses | |||
uutlLogger, uutlGenerics, uutlExceptions; | |||
type | |||
TutlMessageThreadMap = class(specialize TutlMap<TThreadID, TutlMessageThread>) | |||
private | |||
fCS: TCriticalSection; | |||
public | |||
procedure Lock; | |||
procedure Release; | |||
constructor Create(const aOwnsObjects: Boolean = true); | |||
destructor Destroy; override; | |||
end; | |||
var | |||
Threads: TutlMessageThreadMap; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt): Boolean; | |||
begin | |||
result := utlPostMessage(aThreadID, TutlMessage.Create(aID, aWParam, aLParam)); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlPostMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject): Boolean; | |||
begin | |||
result := utlPostMessage(aThreadID, TutlMessage.Create(aID, aArgs)); | |||
end; | |||
function utlPostMessage(const aThreadID: TThreadID; const aMsg: TutlMessage): Boolean; | |||
var | |||
t: TutlMessageThread; | |||
begin | |||
Threads.Lock; | |||
try | |||
t := Threads[aThreadID]; | |||
finally | |||
Threads.Release; | |||
end; | |||
result := Assigned(t); | |||
if (result) then | |||
t.PostMessage(aMsg) | |||
else | |||
aMsg.Free; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aWParam, aLParam: PtrInt; const aWaitTime: Cardinal): TWaitResult; | |||
begin | |||
result := utlSendMessage(aThreadID, TutlSynchronousMessage.Create(aID, aWParam, aLParam), aWaitTime); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlSendMessage(const aThreadID: TThreadID; const aID: Cardinal; const aArgs: TObject; const aWaitTime: Cardinal): TWaitResult; | |||
begin | |||
result := utlSendMessage(aThreadID, TutlSynchronousMessage.Create(aID, aArgs), aWaitTime); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function utlSendMessage(const aThreadID: TThreadID; const aMsg: TutlSynchronousMessage; const aWaitTime: Cardinal): TWaitResult; | |||
var | |||
t: TutlMessageThread; | |||
begin | |||
Threads.Lock; | |||
try | |||
t := Threads[aThreadID]; | |||
finally | |||
Threads.Release; | |||
end; | |||
if Assigned(t) then | |||
result := t.SendMessage(aMsg) | |||
else begin | |||
result := wrError; | |||
aMsg.Free; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlMessageThreadMap////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThreadMap.Lock; | |||
begin | |||
fCS.Acquire; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThreadMap.Release; | |||
begin | |||
fCS.Release; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlMessageThreadMap.Create(const aOwnsObjects: Boolean); | |||
begin | |||
inherited; | |||
fCS:= TCriticalSection.Create; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlMessageThreadMap.Destroy; | |||
begin | |||
fCS.Acquire; | |||
try | |||
inherited Destroy; | |||
finally | |||
fCS.Release; | |||
end; | |||
FreeAndNil(fCS); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlMessageThread///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.PushMsg(aMessage: TutlMessage); | |||
begin | |||
LockMessages; | |||
try | |||
if not Assigned(fLast) then | |||
exit; | |||
fLast.next := TSingleLinkedListItem.Create; | |||
fLast.next.msg := aMessage; | |||
fLast := fLast.next; | |||
fMsgEvent.SetEvent; | |||
finally | |||
UnlockMessages; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread.PullMsg: TutlMessage; | |||
var | |||
old: TSingleLinkedListItem; | |||
begin | |||
result := nil; | |||
LockMessages; | |||
try | |||
if Assigned(fFirst) and Assigned(fFirst.next) then begin | |||
old := fFirst; | |||
fFirst := old.next; | |||
result := fFirst.msg; | |||
old.Free; | |||
if not Assigned(fFirst.next) then | |||
fMsgEvent.ResetEvent; | |||
end; | |||
finally | |||
UnlockMessages; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.ClearMessages; | |||
var | |||
m: TutlMessage; | |||
begin | |||
repeat | |||
m := PullMsg; | |||
if Assigned(m) then | |||
m.Free; | |||
until not Assigned(m); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread.QueryInterface(constref iid: tguid; out obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
begin | |||
if getinterface(iid,obj) then | |||
result := S_OK | |||
else | |||
result := longint(E_NOINTERFACE); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread._AddRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
begin | |||
result := InterLockedIncrement(fRefCount); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; | |||
begin | |||
result := InterLockedDecrement(fRefCount); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.LockMessages; | |||
{$IFDEF USE_SPINLOCK} | |||
var | |||
lock: Cardinal; | |||
begin | |||
repeat | |||
lock := InterLockedExchange(fLocked, 1); | |||
until (lock = 0); | |||
{$ELSE} | |||
begin | |||
fCritSec.Enter; | |||
{$ENDIF} | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.UnlockMessages; | |||
begin | |||
{$IFDEF USE_SPINLOCK} | |||
InterLockedExchange(fLocked, 0); | |||
{$ELSE} | |||
fCritSec.Leave; | |||
{$ENDIF} | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread.WaitForMessages(const aWaitTime: Cardinal): Boolean; | |||
var | |||
wr: TWaitResult; | |||
begin | |||
wr := fMsgEvent.WaitFor(aWaitTime); | |||
result := (wr = wrSignaled); | |||
if not result and (wr <> wrTimeout) then | |||
raise EWait.Create('Error while waiting for messages', wr); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread.ProcessMessages: Boolean; | |||
var | |||
m: TutlMessage; | |||
empty: Boolean; | |||
begin | |||
empty := false; | |||
result := false; | |||
repeat | |||
try | |||
m := PullMsg; //nur beim holen einer Message Locken sonst evtl. DeadLock | |||
if Assigned(m) then begin | |||
result := true; | |||
try | |||
ProcessMessage(m); | |||
finally | |||
if (m is TutlSynchronousMessage) then | |||
(m as TutlSynchronousMessage).Finish | |||
else | |||
FreeAndNil(m); | |||
end; | |||
end else | |||
empty := true; | |||
except | |||
on e: Exception do begin | |||
utlLogger.Error(self, 'error while progressing message %s(ID: %d; wParam: %s; lParam: %s): %s - %s', [ | |||
m.ClassName, | |||
m.ID, | |||
IntToHex(m.wParam, SizeOf(m.wParam) div 4), | |||
IntToHex(m.wParam, SizeOf(m.wParam) div 4), | |||
e.ClassName, | |||
e.Message]); | |||
end; | |||
end; | |||
until empty; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.ProcessMessage(const aMessage: TutlMessage); | |||
begin | |||
case aMessage.ID of | |||
MSG_CALLBACK: | |||
(aMessage as TutlCallbackMsg).ExecuteCallback; | |||
MSG_SYNC_CALLBACK: | |||
(aMessage as TutlSyncCallbackMsg).ExecuteCallback; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.PostMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt); | |||
var | |||
m: TutlMessage; | |||
begin | |||
m := TutlMessage.Create(aID, aWParam, aLParam); | |||
PushMsg(m); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.PostMessage(const aID: Cardinal; const aArgs: TObject); | |||
var | |||
m: TutlMessage; | |||
begin | |||
m := TutlMessage.Create(aID, aArgs); | |||
PushMsg(m); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlMessageThread.PostMessage(const aMsg: TutlMessage); | |||
begin | |||
PushMsg(aMsg); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread.SendMessage(const aID: Cardinal; const aWParam, aLParam: PtrInt; const aWaitTime: Cardinal): TWaitResult; | |||
var | |||
m: TutlSynchronousMessage; | |||
begin | |||
m := TutlSynchronousMessage.Create(aID, aWParam, aLParam); | |||
result := SendMessage(m, aWaitTime); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread.SendMessage(const aID: Cardinal; const aArgs: TObject; const aWaitTime: Cardinal): TWaitResult; | |||
var | |||
m: TutlSynchronousMessage; | |||
begin | |||
m := TutlSynchronousMessage.Create(aID, aArgs); | |||
result := SendMessage(m, aWaitTime); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlMessageThread.SendMessage(const aMsg: TutlSynchronousMessage; const aWaitTime: Cardinal): TWaitResult; | |||
begin | |||
PushMsg(aMsg); | |||
result := aMsg.WaitFor(aWaitTime); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlMessageThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt); | |||
begin | |||
inherited Create(CreateSuspended, StackSize); | |||
fMsgEvent := TEvent.Create(nil, true, false, ''); | |||
fFirst := TSingleLinkedListItem.Create; | |||
fLast := fFirst; | |||
Threads.Lock; | |||
try | |||
Threads.Add(ThreadID, self); | |||
finally | |||
Threads.Release; | |||
end; | |||
{$IFNDEF USE_SPINLOCK} | |||
fCritSec := TCriticalSection.Create; | |||
{$ENDIF} | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlMessageThread.Destroy; | |||
begin | |||
Threads.Lock; | |||
try | |||
Threads.Delete(ThreadID); | |||
finally | |||
Threads.Release; | |||
end; | |||
ClearMessages; | |||
FreeAndNil(fFirst); | |||
fLast := nil; | |||
{$IFNDEF USE_SPINLOCK} | |||
FreeAndNil(fCritSec); | |||
{$ENDIF} | |||
FreeAndNil(fMsgEvent); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
initialization | |||
Threads := TutlMessageThreadMap.Create(false); | |||
finalization | |||
Threads.Lock; | |||
try | |||
while (Threads.Count > 0) do | |||
Threads.ValueAt[Threads.Count-1].Free; | |||
finally | |||
Threads.Release; | |||
end; | |||
FreeAndNil(Threads); | |||
end. | |||
@@ -0,0 +1,201 @@ | |||
unit uutlMessages; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält verschiedene Klassen, die Messages definieren, | |||
die zwischen utlMessageThreads ausgetauscht werden können } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, syncobjs; | |||
const | |||
//General | |||
MSG_CALLBACK = $00010001; //TutlCallbackMsg | |||
MSG_SYNC_CALLBACK = $00010002; //TutlSyncCallbackMsg | |||
//User | |||
MSG_USER = $F0000000; | |||
type | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlMessage = class(TObject) | |||
private | |||
fID: Cardinal; | |||
fWParam: PtrInt; | |||
fLParam: PtrInt; | |||
fArgs: TObject; | |||
fOwnsObjects: Boolean; | |||
public | |||
property ID: Cardinal read fID; | |||
property WParam: PtrInt read fWParam; | |||
property LParam: PtrInt read fLParam; | |||
property Args: TObject read fArgs; | |||
property OwnsObjects: Boolean read fOwnsObjects write fOwnsObjects; | |||
constructor Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload; | |||
constructor Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean = true); overload; | |||
destructor Destroy; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlSynchronousMessage = class(TutlMessage) | |||
private | |||
fEvent: TEvent; | |||
fFreeOnFinish: Boolean; | |||
fLock: Integer; | |||
procedure Lock; | |||
procedure Unlock; | |||
public | |||
procedure Finish; | |||
function WaitFor(const aTimeout: Cardinal): TWaitResult; | |||
constructor Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); overload; | |||
constructor Create(const {%H-}aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean = true); overload; | |||
destructor Destroy; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlCallbackMsg = class(TutlMessage) | |||
public | |||
procedure ExecuteCallback; virtual; | |||
constructor Create; overload; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlSyncCallbackMsg = class(TutlSynchronousMessage) | |||
public | |||
procedure ExecuteCallback; virtual; | |||
constructor Create; overload; | |||
end; | |||
implementation | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlMessage/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlMessage.Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); | |||
begin | |||
inherited Create; | |||
fID := aID; | |||
fWParam := aWParam; | |||
fLParam := aLParam; | |||
fArgs := nil; | |||
fOwnsObjects := true; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlMessage.Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean); | |||
begin | |||
inherited Create; | |||
fID := aID; | |||
fWParam := 0; | |||
fLParam := 0; | |||
fArgs := aArgs; | |||
fOwnsObjects := aOwnsObjects; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlMessage.Destroy; | |||
begin | |||
if Assigned(fArgs) and fOwnsObjects then | |||
FreeAndNil(fArgs); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlSynchronousMessage////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlSynchronousMessage.Lock; | |||
begin | |||
repeat until (InterLockedExchange(fLock, 1) = 0); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlSynchronousMessage.Unlock; | |||
begin | |||
InterLockedExchange(fLock, 0); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlSynchronousMessage.Finish; | |||
begin | |||
fEvent.SetEvent; | |||
Lock; | |||
if fFreeOnFinish then | |||
Free | |||
else | |||
Unlock; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlSynchronousMessage.WaitFor(const aTimeout: Cardinal): TWaitResult; | |||
begin | |||
Lock; | |||
try | |||
result := fEvent.WaitFor(aTimeout); | |||
fFreeOnFinish := (result <> wrSignaled); | |||
finally | |||
Unlock; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlSynchronousMessage.Create(const aID: Cardinal; const aWParam, aLParam: PtrInt); | |||
begin | |||
inherited Create(aID, aWParam, aLParam); | |||
fEvent := TEvent.Create(nil, true, false, ''); | |||
fFreeOnFinish := false; | |||
fLock := 0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlSynchronousMessage.Create(const aID: Cardinal; const aArgs: TObject; const aOwnsObjects: Boolean); | |||
begin | |||
inherited Create(ID, aArgs, aOwnsObjects); | |||
fEvent := TEvent.Create(nil, true, false, ''); | |||
fFreeOnFinish := false; | |||
fLock := 0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlSynchronousMessage.Destroy; | |||
begin | |||
fEvent.SetEvent; | |||
FreeAndNil(fEvent); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlCallbackMsg/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlCallbackMsg.ExecuteCallback; | |||
begin | |||
//DUMMY | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlCallbackMsg.Create; | |||
begin | |||
inherited Create(MSG_CALLBACK, 0, 0); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlSyncCallbackMsg/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlSyncCallbackMsg.ExecuteCallback; | |||
begin | |||
//DUMMY | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlSyncCallbackMsg.Create; | |||
begin | |||
inherited Create(MSG_SYNC_CALLBACK, 0, 0); | |||
end; | |||
end. | |||
@@ -0,0 +1,93 @@ | |||
unit uutlPlatform; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit implementiert Methoden mit denen ein String generiert werden kann, | |||
welcher das System auf dem die Anwendung läuft identifiziert } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils; | |||
function GetPlatformIdentitfier: string; | |||
implementation | |||
uses | |||
{$ifdef WINDOWS} | |||
Windows | |||
{$endif} | |||
; | |||
{$ifdef WINDOWS} | |||
function GetWindowsVersionStr(const aDefault: String): string; | |||
var | |||
osv: TOSVERSIONINFO; | |||
ver: cardinal; | |||
begin | |||
Result:= aDefault; | |||
osv.dwOSVersionInfoSize:= SizeOf(osv); | |||
if GetVersionEx(osv) then begin | |||
ver:= MAKELONG(osv.dwMinorVersion, osv.dwMajorVersion); | |||
// positive overflow: if system is newer, always detect as newest we knew instead of failing | |||
if ver >= $00060003 then | |||
Result:= '8_1' | |||
else | |||
if ver >= $00060002 then | |||
Result:= '8' | |||
else | |||
if ver >= $00060001 then | |||
Result:= '7' | |||
else | |||
if ver >= $00060000 then | |||
Result:= 'Vista' | |||
else | |||
if ver >= $00050002 then | |||
Result:= '2003' | |||
else | |||
if ver >= $00050001 then | |||
Result:= 'XP' | |||
else | |||
if ver >= $00050000 then | |||
Result:= '2000' | |||
else | |||
if ver >= $00040000 then | |||
Result:= 'NT4'; | |||
// ignore NT3, hmkay?; | |||
end; | |||
end; | |||
{$endif} | |||
function GetPlatformIdentitfier: string; | |||
var | |||
os,ver,arch: string; | |||
begin | |||
Result:= ''; | |||
os:= ''; | |||
ver:= 'generic'; | |||
arch:= ''; | |||
{$if defined(WINDOWS)} | |||
os:= 'mswin'; | |||
ver:= GetWindowsVersionStr(ver); | |||
{$elseif defined(LINUX)} | |||
os:= 'linux'; | |||
{$Warning System Version String missing!} | |||
{$endif} | |||
{$if defined(CPUX86)} | |||
arch:= 'x86'; | |||
{$elseif defined(cpux86_64)} | |||
arch:= 'x64'; | |||
{$else} | |||
{$Error Unknown Architecture!} | |||
{$endif} | |||
Result:= format('%s-%s-%s', [os, ver, arch]); | |||
end; | |||
end. | |||
@@ -0,0 +1,63 @@ | |||
{$ERROR Do not use, untested/WIP/useless!} | |||
{$ifdef __HEAD} | |||
TProfileBinary = class(TProfileDataFile) | |||
private type | |||
TEnterRec = packed record | |||
Thread: TThreadID; | |||
When: Int64; | |||
Line: Integer; | |||
Func, Src: ShortString; | |||
end; | |||
TLeaveRec = packed record | |||
Thread: TThreadID; | |||
When: Int64; | |||
end; | |||
private | |||
fDF: TMemoryStream; | |||
public | |||
constructor Create(const aFileName: string); | |||
destructor Destroy; override; | |||
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); override; | |||
procedure WriteLeave(Thread: TThreadID; When: Int64); override; | |||
end; | |||
{$ELSE} | |||
{ TProfileBinary } | |||
constructor TProfileBinary.Create(const aFileName: string); | |||
begin | |||
inherited; | |||
fDF:= TMemoryStream.Create; | |||
fDF.SetSize(50000000); | |||
end; | |||
destructor TProfileBinary.Destroy; | |||
begin | |||
FreeAndNil(fDF); | |||
inherited; | |||
end; | |||
procedure TProfileBinary.WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); | |||
var | |||
t: TEnterRec; | |||
begin | |||
t.When:= When; | |||
t.Thread:= Thread; | |||
t.Func:= Func; | |||
t.Src:= Src; | |||
t.Line:= Line; | |||
fDF.Write(t, sizeof(t)); | |||
end; | |||
procedure TProfileBinary.WriteLeave(Thread: TThreadID; When: Int64); | |||
var | |||
t: TLeaveRec; | |||
begin | |||
t.When:= When; | |||
t.Thread:= Thread; | |||
fDF.Write(t, sizeof(t)); | |||
end; | |||
{$ENDIF} | |||
@@ -0,0 +1,49 @@ | |||
{$ifdef __HEAD} | |||
TProfilePlainText = class(TProfileDataFile) | |||
private | |||
fDF: Textfile; | |||
fBuffer: array[0..16*1024-1] of byte; | |||
public | |||
constructor Create(const aFileName: string); | |||
destructor Destroy; override; | |||
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); override; | |||
procedure WriteLeave(Thread: TThreadID; When: Int64); override; | |||
end; | |||
{$ELSE} | |||
{ TProfilePlainText } | |||
constructor TProfilePlainText.Create(const aFileName: string); | |||
begin | |||
inherited; | |||
AssignFile(fDF, aFileName); | |||
SetTextBuf(fDF, {%H-}fBuffer[0], sizeof(fBuffer)); | |||
Rewrite(fDF); | |||
end; | |||
destructor TProfilePlainText.Destroy; | |||
begin | |||
CloseFile(fDF); | |||
inherited; | |||
end; | |||
procedure TProfilePlainText.WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); | |||
var | |||
l: string; | |||
begin | |||
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';'+Src+ ';'+IntToStr(Line)+';'+Func; | |||
WriteLn(fDF, l); | |||
end; | |||
procedure TProfilePlainText.WriteLeave(Thread: TThreadID; When: Int64); | |||
var | |||
l: string; | |||
begin | |||
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';'; | |||
WriteLn(fDF, l); | |||
end; | |||
{$ENDIF} | |||
@@ -0,0 +1,46 @@ | |||
{$ifdef __HEAD} | |||
TProfilePlainTextMMap = class(TProfileDataFile) | |||
private | |||
fDF: TFastFileStream; | |||
public | |||
constructor Create(const aFileName: string); | |||
destructor Destroy; override; | |||
procedure WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); override; | |||
procedure WriteLeave(Thread: TThreadID; When: Int64); override; | |||
end; | |||
{$ELSE} | |||
{ TProfilePlainTextMMap } | |||
constructor TProfilePlainTextMMap.Create(const aFileName: string); | |||
begin | |||
inherited; | |||
fDF:= TFastFileStream.Create(aFileName, fmCreate, fmShareExclusive); | |||
end; | |||
destructor TProfilePlainTextMMap.Destroy; | |||
begin | |||
FreeAndNil(fDF); | |||
inherited; | |||
end; | |||
procedure TProfilePlainTextMMap.WriteEnter(Thread: TThreadID; When: Int64; Func, Src: String; Line: Integer); | |||
var | |||
l: string; | |||
begin | |||
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';'+Src+ ';'+IntToStr(Line)+';'+Func + #13#10; | |||
fDF.Write(l[1], Length(l)); | |||
end; | |||
procedure TProfilePlainTextMMap.WriteLeave(Thread: TThreadID; When: Int64); | |||
var | |||
l: string; | |||
begin | |||
l:= hexStr(When, 16)+ ';'+hexStr(Thread, 4)+ ';'#13#10; | |||
fDF.Write(l[1], Length(l)); | |||
end; | |||
{$ENDIF} | |||
@@ -0,0 +1,71 @@ | |||
{$IF defined(__SET_INTERFACE)} | |||
type __SET_HELPER = class | |||
public | |||
class function {%H}ToString(const Value: __SET_TYPE): String; reintroduce; | |||
class function TryToSet(const Str: String; out Value: __SET_TYPE): boolean; overload; | |||
class function ToSet(const Str: String; const aDefault: __SET_TYPE): __SET_TYPE; overload; | |||
class function ToSet(const Str: String): __SET_TYPE; overload; | |||
end; | |||
{$ELSEIF defined (__SET_IMPLEMENTATION)} | |||
class function __SET_HELPER.ToString(const Value: __SET_TYPE): String; | |||
var | |||
m: __ENUM_TYPE; | |||
begin | |||
Result:= ''; | |||
for m in __ENUM_HELPER.Values do | |||
if m in Value then begin | |||
if Result > '' then | |||
Result:= Result + ', '; | |||
Result:= Result + __ENUM_HELPER.ToString(m); | |||
end; | |||
end; | |||
class function __SET_HELPER.ToSet(const Str: String): __SET_TYPE; | |||
begin | |||
if not TryToSet(Str, Result) then | |||
raise SysUtils.EConvertError.CreateFmt('"%s" is an invalid value',[Str]); | |||
end; | |||
class function __SET_HELPER.ToSet(const Str: String; const aDefault: __SET_TYPE): __SET_TYPE; | |||
begin | |||
if not TryToSet(Str, Result) then | |||
Result:= aDefault; | |||
end; | |||
class function __SET_HELPER.TryToSet(const Str: String; out Value: __SET_TYPE): boolean; | |||
var | |||
i, j: Integer; | |||
s: String; | |||
m: __ENUM_TYPE; | |||
begin | |||
Result:= true; | |||
Value := []; | |||
i := 1; | |||
j := 1; | |||
while (i <= Length(Str)) do begin | |||
if (Str[i] = ',') then begin | |||
s := Trim(copy(Str, j, i-j)); | |||
Result:= Result and __ENUM_HELPER.TryToEnum(s, m); | |||
if not Result then | |||
Exit; | |||
Include(Value, m); | |||
j := i+1; | |||
end; | |||
inc(i); | |||
end; | |||
s := Trim(copy(Str, j, i-j)); | |||
if (s <> '') then begin | |||
Result:= Result and __ENUM_HELPER.TryToEnum(s, m); | |||
if not Result then | |||
Exit; | |||
Include(Value, m); | |||
end; | |||
end; | |||
{$ENDIF} | |||
{$undef __SET_HELPER} | |||
{$undef __SET_TYPE} | |||
{$undef __ENUM_TYPE} | |||
{$undef __ENUM_HELPER} |
@@ -0,0 +1,371 @@ | |||
unit uutlSettings; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit stellt ein Framework zur Verfügung mit dessen Hilfe Einstellungs-Blöcke | |||
in ein MCF File geladen und geschreieben werden können } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, | |||
uutlMCF, uutlGenerics, uutlMessageThread; | |||
type | |||
TutlSettingsBlock = class | |||
constructor Create; virtual; | |||
procedure LoadDefaults; virtual; abstract; | |||
procedure LoadFromConfig(const aMcf: TutlMCFSection); virtual; abstract; | |||
procedure SaveToConfig(const aMcf: TutlMCFSection); virtual; abstract; | |||
end; | |||
TutlSettingsBlockClass = class of TutlSettingsBlock; | |||
TutlSettingsUpdateOp = (opInstanceChanged, opDataChanged); | |||
TutlSettingsUpdateEvent = procedure (const aUpdateOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock) of object; | |||
TutlSettingsUpdateEventCntr = packed record | |||
Callback: TutlSettingsUpdateEvent; | |||
ThreadID: TThreadID; | |||
end; | |||
TutlSettingsUpdateEventCntrEqComp = class(TInterfacedObject, specialize IutlEqualityComparer<TutlSettingsUpdateEventCntr>) | |||
public | |||
function EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean; | |||
end; | |||
TutlSettings = class | |||
private type | |||
TutlSettingsUpdateEventList = specialize TutlCustomList<TutlSettingsUpdateEventCntr>; | |||
TBlockData = class | |||
Instance, OldInstance: TutlSettingsBlock; | |||
Events: TutlSettingsUpdateEventList; | |||
procedure CallEvents(const aOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock); | |||
constructor Create; | |||
destructor Destroy; override; | |||
end; | |||
TBlockList = specialize TutlMap<String, TBlockData>; | |||
private | |||
fBlocks: TBlockList; | |||
fRaiseChangedEventOnLoad: Boolean; | |||
procedure CopyInstance(O, N: TutlSettingsBlock); | |||
public | |||
property RaiseChangedEventOnLoad: Boolean read fRaiseChangedEventOnLoad write fRaiseChangedEventOnLoad; | |||
function RegisterBlock(const aName: String; const aClass: TutlSettingsBlockClass; const aOnUpdateEvent: TutlSettingsUpdateEvent): TutlSettingsBlock; | |||
procedure UnregisterBlockCallback(const aName: String; const aOnUpdateEvent: TutlSettingsUpdateEvent); | |||
procedure UnregisterBlockCallbacks(const aObj: TObject); | |||
function Block(const aName: String; out aBlock): boolean; | |||
procedure Changed(const aBlock: TutlSettingsBlock); | |||
procedure LoadFromConfig(const aMcf: TutlMCFSection); | |||
procedure SaveToConfig(const aMcf: TutlMCFSection); | |||
procedure LoadFromFile(const aFile: string); | |||
procedure SaveToFile(const aFile: string); | |||
constructor Create; | |||
destructor Destroy; override; | |||
end; | |||
operator = (const i1, i2: TutlSettingsUpdateEventCntr): Boolean; inline; | |||
var | |||
utlSettings: TutlSettings; | |||
implementation | |||
uses | |||
uutlExceptions, Forms, uvfsManager, uutlMessages, syncobjs; | |||
const | |||
SETTINGS_MSG_WAIT_TIME = 1000; //ms | |||
type | |||
TSettingsBlockChangedMsg = class(TutlSyncCallbackMsg) | |||
private | |||
fCallback: TutlSettingsUpdateEvent; | |||
fOperation: TutlSettingsUpdateOp; | |||
fOld: TutlSettingsBlock; | |||
fNew: TutlSettingsBlock; | |||
public | |||
procedure ExecuteCallback; override; | |||
constructor Create(const aCallback: TutlSettingsUpdateEvent; const aOp: TutlSettingsUpdateOp; | |||
const aOld, aNew: TutlSettingsBlock); | |||
end; | |||
operator = (const i1, i2: TutlSettingsUpdateEventCntr): Boolean; | |||
begin | |||
result := | |||
(i1.Callback = i2.Callback) and | |||
(i2.ThreadID = i2.ThreadID); | |||
end; | |||
function TutlSettingsUpdateEventCntrEqComp.EqualityCompare(const i1, i2: TutlSettingsUpdateEventCntr): Boolean; | |||
begin | |||
result := (i1 = i2); | |||
end; | |||
{ TSettingsBlockChangedMsg } | |||
procedure TSettingsBlockChangedMsg.ExecuteCallback; | |||
begin | |||
fCallback(fOperation, fOld, fNew); | |||
end; | |||
constructor TSettingsBlockChangedMsg.Create(const aCallback: TutlSettingsUpdateEvent; | |||
const aOp: TutlSettingsUpdateOp; const aOld, aNew: TutlSettingsBlock); | |||
begin | |||
inherited Create; | |||
fCallback := aCallback; | |||
fOperation := aOp; | |||
fOld := aOld; | |||
fNew := aNew; | |||
end; | |||
{ TutlSettings.TBlockData } | |||
procedure TutlSettings.TBlockData.CallEvents(const aOp: TutlSettingsUpdateOp; | |||
const aOld, aNew: TutlSettingsBlock); | |||
var | |||
current: TThreadID; | |||
cntr: TutlSettingsUpdateEventCntr; | |||
msg: TSettingsBlockChangedMsg; | |||
begin | |||
current := GetCurrentThreadId; | |||
for cntr in Events do begin | |||
if (cntr.ThreadID <> current) then begin | |||
msg := TSettingsBlockChangedMsg.Create(cntr.Callback, aOp, aOld, aNew); | |||
if utlSendMessage(cntr.ThreadID, msg, SETTINGS_MSG_WAIT_TIME) = wrSignaled then | |||
msg.Free; | |||
end else | |||
cntr.Callback(aOp, aOld, aNew); | |||
end; | |||
end; | |||
constructor TutlSettings.TBlockData.Create; | |||
begin | |||
inherited; | |||
Events:= TutlSettingsUpdateEventList.Create(TutlSettingsUpdateEventCntrEqComp.Create); | |||
end; | |||
destructor TutlSettings.TBlockData.Destroy; | |||
begin | |||
FreeAndNil(Events); | |||
FreeAndNil(Instance); | |||
FreeAndNil(OldInstance); | |||
inherited Destroy; | |||
end; | |||
{ TutlSettingsBlock } | |||
constructor TutlSettingsBlock.Create; | |||
begin | |||
inherited; | |||
LoadDefaults; | |||
end; | |||
{ TutlSettings } | |||
function TutlSettings.RegisterBlock(const aName: String; const aClass: TutlSettingsBlockClass; | |||
const aOnUpdateEvent: TutlSettingsUpdateEvent): TutlSettingsBlock; | |||
var | |||
i: integer; | |||
bd: TBlockData; | |||
cntr: TutlSettingsUpdateEventCntr; | |||
begin | |||
Result:= nil; | |||
if aName = '' then | |||
raise EInvalidOperation.Create('Empty Settings section name.'); | |||
i:= fBlocks.IndexOf(aName); | |||
if i>=0 then begin | |||
bd:= fBlocks.ValueAt[i]; | |||
// gleicher name, instance ist gleiche oder spezifischere klasse | |||
if bd.Instance is aClass then begin | |||
if Assigned(aOnUpdateEvent) then begin | |||
cntr.Callback := aOnUpdateEvent; | |||
cntr.ThreadID := GetCurrentThreadId; | |||
bd.Events.Add(cntr); | |||
end; | |||
Exit(bd.Instance) | |||
end else | |||
// gleicher name, neue klasse ist spezifischer | |||
if aClass.InheritsFrom(bd.Instance.ClassType) then begin | |||
Result:= aClass.Create; | |||
CopyInstance(bd.Instance, Result); | |||
bd.CallEvents(opInstanceChanged, bd.Instance, Result); | |||
bd.Instance.Free; | |||
bd.OldInstance.Free; | |||
bd.Instance:= aClass.Create; | |||
bd.OldInstance:= aClass.Create; | |||
if Assigned(aOnUpdateEvent) then begin | |||
cntr.Callback := aOnUpdateEvent; | |||
cntr.ThreadID := GetCurrentThreadId; | |||
bd.Events.Add(cntr); | |||
end; | |||
Exit; | |||
end | |||
// gleicher name, aber komplett andere klasse | |||
else | |||
raise EInvalidOperation.CreateFmt('Duplicate Settings entry: %s', [aName]); | |||
end; | |||
for bd in fBlocks do | |||
// verwandte klasse aber anderer name (wäre es der gleiche wäre das schon oben abgefangen) | |||
if (bd.Instance is aClass) or (aClass.InheritsFrom(bd.Instance.ClassType)) then | |||
raise EInvalidOperation.CreateFmt('Reused Settings class: %s', [aClass.ClassName]); | |||
// neuer name, neue klasse | |||
bd:= TBlockData.Create; | |||
bd.Instance:= aClass.Create; | |||
bd.OldInstance:= aClass.Create; | |||
if Assigned(aOnUpdateEvent) then begin | |||
cntr.Callback := aOnUpdateEvent; | |||
cntr.ThreadID := GetCurrentThreadId; | |||
bd.Events.Add(cntr); | |||
end; | |||
fBlocks.Add(aName, bd); | |||
Result:= bd.Instance; | |||
end; | |||
procedure TutlSettings.UnregisterBlockCallback(const aName: String; const aOnUpdateEvent: TutlSettingsUpdateEvent); | |||
var | |||
i: integer; | |||
bd: TBlockData; | |||
begin | |||
i:= fBlocks.IndexOf(aName); | |||
if i >= 0 then begin | |||
bd := fBlocks.ValueAt[i]; | |||
for i := bd.Events.Count-1 downto 0 do | |||
if (bd.Events.Items[i].Callback = aOnUpdateEvent) then | |||
bd.Events.Delete(i); | |||
end; | |||
end; | |||
procedure TutlSettings.UnregisterBlockCallbacks(const aObj: TObject); | |||
var | |||
bd: TBlockData; | |||
i: integer; | |||
begin | |||
for bd in fBlocks do | |||
for i:= bd.Events.Count-1 downto 0 do | |||
if TMethod(bd.Events[i].Callback).Data = Pointer(aObj) then | |||
bd.Events.Delete(i); | |||
end; | |||
procedure TutlSettings.CopyInstance(O, N: TutlSettingsBlock); | |||
var | |||
tmp: TutlMCFSection; | |||
begin | |||
tmp:= TutlMCFSection.Create; | |||
try | |||
O.SaveToConfig(tmp); | |||
N.LoadFromConfig(tmp); | |||
finally | |||
FreeAndNil(tmp); | |||
end; | |||
end; | |||
function TutlSettings.Block(const aName: String; out aBlock): boolean; | |||
var | |||
i: integer; | |||
bd: TBlockData; | |||
begin | |||
i := fBlocks.IndexOf(aName); | |||
Result := (i >= 0); | |||
if Result then begin | |||
bd:= fBlocks.ValueAt[i]; | |||
CopyInstance(bd.Instance, bd.OldInstance); | |||
TutlSettingsBlock(aBlock):= bd.Instance; | |||
end; | |||
end; | |||
procedure TutlSettings.Changed(const aBlock: TutlSettingsBlock); | |||
var | |||
bd: TBlockData; | |||
begin | |||
for bd in fBlocks do | |||
if bd.Instance = aBlock then begin | |||
bd.CallEvents(opDataChanged, bd.OldInstance, bd.Instance); | |||
exit; | |||
end; | |||
end; | |||
procedure TutlSettings.LoadFromConfig(const aMcf: TutlMCFSection); | |||
var | |||
i: Integer; | |||
b: TBlockData; | |||
begin | |||
for i := 0 to fBlocks.Count-1 do begin | |||
b := fBlocks.ValueAt[i]; | |||
b.Instance.LoadFromConfig(aMcf.Section(fBlocks.Keys[i])); | |||
if fRaiseChangedEventOnLoad then | |||
Changed(b.Instance); | |||
end; | |||
end; | |||
procedure TutlSettings.SaveToConfig(const aMcf: TutlMCFSection); | |||
var | |||
i: integer; | |||
begin | |||
for i:= 0 to fBlocks.Count-1 do | |||
fBlocks.ValueAt[i].Instance.SaveToConfig(aMcf.Section(fBlocks.Keys[i])); | |||
end; | |||
procedure TutlSettings.LoadFromFile(const aFile: string); | |||
var | |||
sh: IStreamHandle; | |||
mcf: TutlMCFFile; | |||
begin | |||
if vfsManager.ReadFile(aFile, sh) then begin | |||
mcf:= TutlMCFFile.Create(sh); | |||
try | |||
LoadFromConfig(mcf); | |||
finally | |||
FreeAndNil(mcf); | |||
end; | |||
end; | |||
end; | |||
procedure TutlSettings.SaveToFile(const aFile: string); | |||
var | |||
sh: IStreamHandle; | |||
mcf: TutlMCFFile; | |||
begin | |||
if vfsManager.CreateFile(aFile, sh) then begin | |||
mcf:= TutlMCFFile.Create(nil); | |||
try | |||
SaveToConfig(mcf); | |||
mcf.SaveToStream(sh); | |||
finally | |||
FreeAndNil(mcf); | |||
end; | |||
end; | |||
end; | |||
constructor TutlSettings.Create; | |||
begin | |||
inherited Create; | |||
fBlocks:= TBlockList.Create(true); | |||
fRaiseChangedEventOnLoad := true; | |||
end; | |||
destructor TutlSettings.Destroy; | |||
begin | |||
FreeAndNil(fBlocks); | |||
inherited Destroy; | |||
end; | |||
initialization | |||
utlSettings := TutlSettings.Create; | |||
finalization | |||
FreeAndNil(utlSettings); | |||
end. | |||
@@ -0,0 +1,673 @@ | |||
unit uutlStreamHelper; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält Klassen zum lesen und schreiben von Werten in einen Stream | |||
TutlStreamReader - Wrapper für beliebige Streams, handelt Datentypen | |||
TutlStreamWriter - Wrapper für beliebige Streams, handelt Datentypen } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, Contnrs, syncobjs; | |||
type | |||
TutlFourCC = string[4]; | |||
{ TutlStreamUtility } | |||
TutlStreamUtility = class | |||
private | |||
FStream: TStream; | |||
FOwnsStream: boolean; | |||
FPositions: TStack; | |||
protected | |||
public | |||
constructor Create(BaseStream: TStream; OwnsStream: Boolean=false); | |||
destructor Destroy; override; | |||
property Stream: TStream read FStream; | |||
procedure Push; | |||
procedure Pop; | |||
procedure Drop; | |||
end; | |||
{ TutlStreamReader } | |||
TutlStreamReader = class(TutlStreamUtility) | |||
protected | |||
function ReadBuffer(Var Buffer; Size: int64): int64; | |||
public | |||
function ReadFourCC: TutlFourCC; | |||
function CheckFourCC(Correct: TutlFourCC): boolean; | |||
function ReadByte: Byte; | |||
function ReadWord: Word; | |||
function ReadCardinal: Cardinal; | |||
function ReadInteger: Integer; | |||
function ReadInt64: Int64; | |||
function ReadSingle: Single; | |||
function ReadDouble: Double; | |||
function ReadAnsiString: AnsiString; | |||
function ReadLine: AnsiString; | |||
function IsEOF: boolean; | |||
end; | |||
{ TutlStreamWriter } | |||
TutlStreamWriter = class(TutlStreamUtility) | |||
protected | |||
procedure WriteBuffer(var Data; Size: int64); | |||
public | |||
procedure WriteFourCC(FCC: TutlFourCC); | |||
procedure WriteByte(A: Byte); | |||
procedure WriteWord(A: Word); | |||
procedure WriteCardinal(A: Cardinal); | |||
procedure WriteInteger(A: Integer); | |||
procedure WriteInt64(A: Int64); | |||
procedure WriteSingle(A: Single); | |||
procedure WriteDouble(A: Double); | |||
procedure WriteAnsiString(A: AnsiString); | |||
procedure WriteAnsiBytes(A: AnsiString); | |||
procedure WriteLine(A: AnsiString); | |||
end; | |||
{ TutlReadBufferStream } | |||
TutlReadBufferStream = class(TStream) | |||
private | |||
FBaseStream: TStream; | |||
FBuffer: Pointer; | |||
FBufferValid: boolean; | |||
FBufferStart, FBufferLen, FBufferAvail: Int64; | |||
FPosition: int64; | |||
protected | |||
function GetSize: Int64; override; | |||
procedure SetSize(const NewSize: Int64); override; | |||
public | |||
constructor Create(const BaseStream: TStream; const BufferSize: Cardinal); | |||
destructor Destroy; override; | |||
function Read(var Buffer; Count: Integer): Integer; override; | |||
function Write(const Buffer; Count: Integer): Integer; override; | |||
function Seek(Offset: Integer; Origin: Word): Integer; override; | |||
end; | |||
{ TutlFIFOStream } | |||
TutlFIFOStream = class(TStream) | |||
private const MAX_PAGE_SIZE = 4096; | |||
private type | |||
PPage = ^TPage; | |||
TPage = record | |||
Next: PPage; | |||
Data: packed array[0..MAX_PAGE_SIZE-1] of byte; | |||
end; | |||
private | |||
fLockFree: boolean; | |||
fPageFirst, fPageLast: PPage; | |||
fReadPtr, fWritePtr: Cardinal; | |||
fTotalSize: Int64; | |||
fDataLock: TCriticalSection; | |||
protected | |||
function GetSize: Int64; override; | |||
public | |||
constructor Create(const aLockFree: boolean = false); | |||
destructor Destroy; override; | |||
function Read(var Buffer; Count: Longint): Longint; override; | |||
function Reserve(var Buffer; Count: Longint): Longint; | |||
function Discard(Count: Longint): Longint; | |||
function Write(const Buffer; Count: Longint): Longint; override; | |||
function Seek(const {%H-}Offset: Int64; {%H-}Origin: TSeekOrigin): Int64; override; overload; | |||
procedure BeginOperation; | |||
procedure EndOperation; | |||
property LockFree: boolean read fLockFree; | |||
end; | |||
TutlBase64Decoder = class(TStringStream) | |||
public const | |||
CODE64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; | |||
PADDING_CHARACTER = '='; | |||
protected | |||
public | |||
function Read(var Buffer; Count: Longint): Longint; override; | |||
function Decode(const aOutput: TStream): boolean; | |||
constructor Create; | |||
end; | |||
implementation | |||
uses SysUtils,RtlConsts, uutlExceptions; | |||
type | |||
TPositionData = class | |||
Position: Int64; | |||
constructor Create(Pos: Int64); | |||
end; | |||
constructor TPositionData.Create(Pos: Int64); | |||
begin | |||
inherited Create; | |||
Position:= Pos; | |||
end; | |||
{ TutlStreamUtility } | |||
constructor TutlStreamUtility.Create(BaseStream: TStream; OwnsStream: Boolean); | |||
begin | |||
inherited Create; | |||
FStream:= BaseStream; | |||
FOwnsStream:= OwnsStream; | |||
FPositions:= TStack.Create; | |||
end; | |||
destructor TutlStreamUtility.Destroy; | |||
begin | |||
if FOwnsStream then | |||
FreeAndNil(FStream) | |||
else | |||
FStream:= nil; | |||
while FPositions.AtLeast(1) do | |||
TPositionData(FPositions.Pop).Free; | |||
FreeAndNil(FPositions); | |||
inherited; | |||
end; | |||
procedure TutlStreamUtility.Pop; | |||
var | |||
p: TPositionData; | |||
begin | |||
p:= TPositionData(FPositions.Pop); | |||
FStream.Position:= p.Position; | |||
p.Free; | |||
end; | |||
procedure TutlStreamUtility.Drop; | |||
var | |||
p: TPositionData; | |||
begin | |||
p:= TPositionData(FPositions.Pop); | |||
if Assigned(p) then | |||
p.Free; | |||
end; | |||
procedure TutlStreamUtility.Push; | |||
begin | |||
FPositions.Push(TPositionData.Create(FStream.Position)); | |||
end; | |||
{ TutlStreamReader } | |||
function TutlStreamReader.ReadBuffer(var Buffer; Size: int64): int64; | |||
begin | |||
if (FStream.Position + Size > FStream.Size) then | |||
raise EInvalidOperation.Create('stream is to small'); | |||
Result:= FStream.Read(Buffer, Size); | |||
end; | |||
function TutlStreamReader.ReadFourCC: TutlFourCC; | |||
begin | |||
SetLength(Result, 4); | |||
ReadBuffer(Result[1], 4); | |||
end; | |||
function TutlStreamReader.CheckFourCC(Correct: TutlFourCC): boolean; | |||
begin | |||
Result:= ReadFourCC=Correct; | |||
end; | |||
function TutlStreamReader.ReadByte: Byte; | |||
begin | |||
ReadBuffer(Result{%H-}, Sizeof(Result)); | |||
end; | |||
function TutlStreamReader.ReadWord: Word; | |||
begin | |||
ReadBuffer(Result{%H-}, Sizeof(Result)); | |||
end; | |||
function TutlStreamReader.ReadCardinal: Cardinal; | |||
begin | |||
ReadBuffer(Result{%H-}, Sizeof(Result)); | |||
end; | |||
function TutlStreamReader.ReadInteger: Integer; | |||
begin | |||
ReadBuffer(Result{%H-}, Sizeof(Result)); | |||
end; | |||
function TutlStreamReader.ReadInt64: Int64; | |||
begin | |||
ReadBuffer(Result{%H-}, Sizeof(Result)); | |||
end; | |||
function TutlStreamReader.ReadSingle: Single; | |||
begin | |||
ReadBuffer(Result{%H-}, Sizeof(Result)); | |||
end; | |||
function TutlStreamReader.ReadDouble: Double; | |||
begin | |||
ReadBuffer(Result{%H-}, Sizeof(Result)); | |||
end; | |||
function TutlStreamReader.ReadAnsiString: AnsiString; | |||
begin | |||
SetLength(Result, ReadCardinal); | |||
ReadBuffer(Result[1], Length(Result)); | |||
end; | |||
function TutlStreamReader.ReadLine: AnsiString; | |||
const | |||
READ_LENGTH = 80; | |||
var | |||
rp, rl: integer; | |||
cp: PAnsiChar; | |||
bpos: Int64; | |||
r: integer; | |||
EOF: Boolean; | |||
procedure ReadSome; | |||
begin | |||
SetLength(Result, rl + READ_LENGTH); | |||
r:= FStream.Read(Result[rl + 1], READ_LENGTH); | |||
inc(rl, r); | |||
EOF:= r <> READ_LENGTH; | |||
cp:= @Result[rp]; | |||
end; | |||
begin | |||
Result:= ''; | |||
rl:= 0; | |||
bpos:= FStream.Position; | |||
repeat | |||
rp:= rl + 1; | |||
ReadSome; | |||
while rp <= rl do begin | |||
if cp^ in [#10, #13] then begin | |||
inc(bpos, rp); | |||
// never a second char after #10 | |||
if cp^ = #13 then begin | |||
if (rp = rl) and not EOF then begin | |||
ReadSome; | |||
end; | |||
if (rp <= rl) then begin | |||
inc(cp); | |||
if cp^ = #10 then | |||
inc(bpos); | |||
end; | |||
end; | |||
FStream.Position:= bpos; | |||
SetLength(Result, rp-1); | |||
Exit; | |||
end; | |||
inc(cp); | |||
inc(rp); | |||
end; | |||
until EOF; | |||
SetLength(Result, rl); | |||
end; | |||
function TutlStreamReader.IsEOF: boolean; | |||
begin | |||
Result:= FStream.Position = FStream.Size; | |||
end; | |||
{ TutlStreamWriter } | |||
procedure TutlStreamWriter.WriteBuffer(var Data; Size: int64); | |||
begin | |||
FStream.Write(Data, Size); | |||
end; | |||
procedure TutlStreamWriter.WriteFourCC(FCC: TutlFourCC); | |||
begin | |||
WriteBuffer(FCC[1], 4); | |||
end; | |||
procedure TutlStreamWriter.WriteByte(A: Byte); | |||
begin | |||
WriteBuffer(A, SizeOf(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteWord(A: Word); | |||
begin | |||
WriteBuffer(A, SizeOf(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteCardinal(A: Cardinal); | |||
begin | |||
WriteBuffer(A, SizeOf(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteInteger(A: Integer); | |||
begin | |||
WriteBuffer(A, SizeOf(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteInt64(A: Int64); | |||
begin | |||
WriteBuffer(A, SizeOf(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteSingle(A: Single); | |||
begin | |||
WriteBuffer(A, SizeOf(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteDouble(A: Double); | |||
begin | |||
WriteBuffer(A, SizeOf(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteAnsiString(A: AnsiString); | |||
begin | |||
WriteCardinal(Length(A)); | |||
WriteBuffer(A[1], Length(a)); | |||
end; | |||
procedure TutlStreamWriter.WriteAnsiBytes(A: AnsiString); | |||
begin | |||
WriteBuffer(A[1], Length(A)); | |||
end; | |||
procedure TutlStreamWriter.WriteLine(A: AnsiString); | |||
begin | |||
WriteAnsiBytes(A + sLineBreak); | |||
end; | |||
{ TutlReadBufferStream } | |||
constructor TutlReadBufferStream.Create(const BaseStream: TStream; const BufferSize: Cardinal); | |||
begin | |||
inherited Create; | |||
FBaseStream:= BaseStream; | |||
FBufferLen:= BufferSize; | |||
FBuffer:= GetMemory(FBufferLen); | |||
FPosition:= 0; | |||
end; | |||
destructor TutlReadBufferStream.Destroy; | |||
begin | |||
FBufferValid:= false; | |||
//FBaseStream.Free; | |||
FreeMemory(FBuffer); | |||
inherited; | |||
end; | |||
function TutlReadBufferStream.Seek(Offset: Integer; Origin: Word): Integer; | |||
begin | |||
case Origin of | |||
soFromBeginning: FPosition := Offset; | |||
soFromCurrent: Inc(FPosition, Offset); | |||
soFromEnd: FPosition := Size + Offset; | |||
end; | |||
Result := FPosition; | |||
end; | |||
function TutlReadBufferStream.GetSize: Int64; | |||
begin | |||
Result:= FBaseStream.Size; | |||
end; | |||
procedure TutlReadBufferStream.SetSize(const NewSize: Int64); | |||
begin | |||
FBaseStream.Size:= NewSize; | |||
end; | |||
function TutlReadBufferStream.Write(const Buffer; Count: Integer): Integer; | |||
begin | |||
FBufferValid:= false; | |||
FBaseStream.Position:= FPosition; | |||
Result:= FBaseStream.Write(Buffer, Count); | |||
FPosition:= FBaseStream.Position; | |||
end; | |||
function TutlReadBufferStream.Read(var Buffer; Count: Integer): Integer; | |||
var | |||
rp, br, c: Int64; | |||
bp: Pointer; | |||
begin | |||
br:= 0; | |||
bp:= @Buffer; | |||
while (br < Count) and (FPosition<Size) do begin | |||
// Welches Buffer-Segment wird gesucht? | |||
rp:= (FPosition div FBufferLen) * FBufferLen; | |||
// ist das das aktuelle? | |||
if not FBufferValid or (FBufferStart <> rp) then begin | |||
// Segment holen | |||
FBaseStream.Position:= rp; | |||
FBufferAvail:= FBaseStream.Read(FBuffer^, FBufferLen); | |||
FBufferStart:= rp; | |||
FBufferValid:= true; | |||
end; | |||
// Wie viel Daten daraus brauchen wir bzw. können wir kriegen? | |||
c:= Count - br; | |||
if c > FBufferAvail - (FPosition-FBufferStart) then | |||
c:= FBufferAvail - (FPosition-FBufferStart); | |||
// das rausholen und buffer weiterschieben | |||
{$IFDEF FPC} | |||
// FPC: kein Cast, direkt mit Pointer in richtiger Größe rechnen | |||
Move(Pointer(FBuffer + (FPosition-FBufferStart))^, bp^, c); | |||
Inc(Bp, c); | |||
{$ELSE} | |||
// Delphi ist eh nur i386, also fix 32bit | |||
Move(Pointer(Cardinal(FBuffer) + (FPosition-FBufferStart))^, bp^, c); | |||
Inc(Cardinal(Bp), c); | |||
{$ENDIF} | |||
Inc(br, c); | |||
Inc(FPosition, c); | |||
end; | |||
Result:= br; | |||
end; | |||
{ TutlFIFOStream } | |||
constructor TutlFIFOStream.Create(const aLockFree: boolean); | |||
begin | |||
inherited Create; | |||
fDataLock:= TCriticalSection.Create; | |||
fTotalSize:= 0; | |||
New(fPageFirst); | |||
fPageFirst^.Next:= nil; | |||
fPageLast:= fPageFirst; | |||
fReadPtr:= 0; | |||
fWritePtr:= 0; | |||
fLockFree:= aLockFree; | |||
end; | |||
destructor TutlFIFOStream.Destroy; | |||
var | |||
p,q: PPage; | |||
begin | |||
BeginOperation; | |||
try | |||
fTotalSize:= 0; | |||
fReadPtr:= 0; | |||
fWritePtr:= 0; | |||
p:= fPageFirst; | |||
while p<>nil do begin | |||
q:= p; | |||
p:= p^.Next; | |||
Dispose(q); | |||
end; | |||
finally | |||
EndOperation; | |||
end; | |||
FreeAndNil(fDataLock); | |||
inherited Destroy; | |||
end; | |||
function TutlFIFOStream.GetSize: Int64; | |||
begin | |||
Result:= fTotalSize; | |||
end; | |||
function TutlFIFOStream.Read(var Buffer; Count: Longint): Longint; | |||
begin | |||
BeginOperation; | |||
try | |||
Result:= Reserve(Buffer, Count); | |||
Discard(Result); | |||
finally | |||
EndOperation; | |||
end; | |||
end; | |||
function TutlFIFOStream.Reserve(var Buffer; Count: Longint): Longint; | |||
var | |||
pbuf: PByteArray; | |||
mx: LongInt; | |||
rp: Int64; | |||
p: PPage; | |||
begin | |||
BeginOperation; | |||
try | |||
pbuf:= @Buffer; | |||
Result:= 0; | |||
rp:= fReadPtr; | |||
p:= fPageFirst; | |||
while Count > 0 do begin | |||
mx:= MAX_PAGE_SIZE - rp; | |||
if mx > Count then mx:= Count; | |||
if (p=fPageLast) and (mx > fWritePtr-rp) then mx:= fWritePtr-rp; | |||
if mx=0 then exit; | |||
Move(p^.Data[rp], pbuf^[Result], mx); | |||
inc(rp, mx); | |||
inc(Result, mx); | |||
Dec(Count, mx); | |||
if rp = MAX_PAGE_SIZE then begin | |||
p:= p^.Next; | |||
rp:= 0; | |||
end; | |||
end; | |||
finally | |||
EndOperation; | |||
end; | |||
end; | |||
function TutlFIFOStream.Discard(Count: Longint): Longint; | |||
var | |||
mx: LongInt; | |||
n: PPage; | |||
begin | |||
BeginOperation; | |||
try | |||
Result:= 0; | |||
while Count > 0 do begin | |||
mx:= MAX_PAGE_SIZE - fReadPtr; | |||
if mx > Count then mx:= Count; | |||
if (fPageFirst=fPageLast) and (mx > fWritePtr-fReadPtr) then mx:= fWritePtr-fReadPtr; | |||
if mx=0 then exit; | |||
inc(fReadPtr, mx); | |||
inc(Result, mx); | |||
dec(Count, mx); | |||
dec(fTotalSize, mx); | |||
if fReadPtr=MAX_PAGE_SIZE then begin | |||
n:= fPageFirst^.Next; | |||
if Assigned(n) then begin | |||
Dispose(fPageFirst); | |||
fPageFirst:= n; | |||
fReadPtr:= 0; | |||
end;// else kann nicht passieren, das wird mit (mx > fWritePtr-fReadPtr) und (mx=0) schon bedient | |||
end; | |||
end; | |||
finally | |||
EndOperation; | |||
end; | |||
end; | |||
function TutlFIFOStream.Write(const Buffer; Count: Longint): Longint; | |||
var | |||
mx: LongInt; | |||
pbuf: PByteArray; | |||
begin | |||
BeginOperation; | |||
try | |||
pbuf:= @Buffer; | |||
Result:= 0; | |||
while Count > 0 do begin | |||
mx:= MAX_PAGE_SIZE - fWritePtr; | |||
if mx > Count then mx:= Count; | |||
Move(pbuf^[Result], fPageLast^.Data[fWritePtr], mx); | |||
inc(fWritePtr, mx); | |||
inc(fTotalSize, mx); | |||
dec(Count, mx); | |||
inc(Result, mx); | |||
if fWritePtr = MAX_PAGE_SIZE then begin | |||
New(fPageLast^.Next); | |||
fPageLast:= fPageLast^.Next; | |||
fPageLast^.Next:= nil; | |||
fWritePtr:= 0; | |||
end; | |||
end; | |||
finally | |||
EndOperation; | |||
end; | |||
end; | |||
function TutlFIFOStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; | |||
begin | |||
Result:= 0; | |||
raise EStreamError.CreateFmt(SStreamInvalidSeek,[ClassName]); | |||
end; | |||
procedure TutlFIFOStream.BeginOperation; | |||
begin | |||
if not fLockFree then | |||
fDataLock.Acquire; | |||
end; | |||
procedure TutlFIFOStream.EndOperation; | |||
begin | |||
if not fLockFree then | |||
fDataLock.Release; | |||
end; | |||
{ TutlBase64Decoder } | |||
function TutlBase64Decoder.{%H-}Read(var Buffer; Count: Longint): Longint; | |||
begin | |||
ReadNotImplemented; | |||
end; | |||
function TutlBase64Decoder.Decode(const aOutput: TStream): boolean; | |||
var | |||
a: Integer; | |||
x: Integer; | |||
b: Integer; | |||
c: AnsiChar; | |||
begin | |||
Result:= false; | |||
a := 0; | |||
b := 0; | |||
Position:= 0; | |||
while inherited Read(c{%H-}, sizeof(c)) = sizeof(c) do begin | |||
x := Pos(c, CODE64) - 1; | |||
if (x >= 0) then begin | |||
b := b * 64 + x; | |||
a := a + 6; | |||
if a >= 8 then begin | |||
a := a - 8; | |||
x := b shr a; | |||
b := b mod (1 shl a); | |||
aOutput.WriteByte(x); | |||
end; | |||
end else if c = PADDING_CHARACTER then | |||
break | |||
else | |||
Exit; | |||
end; | |||
Result:= true; | |||
end; | |||
constructor TutlBase64Decoder.Create; | |||
begin | |||
inherited Create(''); | |||
end; | |||
end. |
@@ -0,0 +1,523 @@ | |||
unit uutlSystemInfo; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält Klassen zum Auslesen von System Informationen (CPU, Grafikkarte, OpenGL) } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, uutlGenerics | |||
{$IFDEF WINDOWS}, ActiveX, ComObj, variants {$ENDIF}; | |||
type | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlSystemInfo = class; | |||
TutlSystemInfoList = specialize TutlList<TutlSystemInfo>; | |||
TutlSystemInfo = class(TObject) | |||
private | |||
fName: String; | |||
fValue: String; | |||
fItems: TutlSystemInfoList; | |||
function GetCount: Integer; | |||
function GetItems(const aIndex: Integer): TutlSystemInfo; | |||
public | |||
property Name: String read fName; | |||
property Value: String read fValue; | |||
property Count: Integer read GetCount; | |||
property Items[const aIndex: Integer]: TutlSystemInfo read GetItems; default; | |||
procedure Update; virtual; | |||
function ToString: String; override; | |||
constructor Create; virtual; | |||
destructor Destroy; override; | |||
end; | |||
TutlSystemInfoClass = class of TutlSystemInfo; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlOpenGLInfo = class(TutlSystemInfo) | |||
public | |||
procedure Update; override; | |||
end; | |||
{$IFDEF WINDOWS} | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlWmiSystemInfo = class(TutlSystemInfo) | |||
protected type | |||
TStringArr = array of String; | |||
protected | |||
function GetComputer: String; virtual; | |||
function GetNamespace: String; virtual; | |||
function GetUsername: String; virtual; | |||
function GetPassword: String; virtual; | |||
function GetQuery: String; virtual; | |||
function GetProperties: TStringArr; virtual; | |||
function GetSubItemName(const aIndex: Integer): String; virtual; | |||
public | |||
procedure Update; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlProcessorInfo = class(TutlWmiSystemInfo) | |||
private const | |||
PROCESSOR_PROPERTIES: array[0..11] of String = ('AddressWidth', 'Caption', | |||
'CurrentClockSpeed', 'Description', 'ExtClock', 'Family', 'Manufacturer', | |||
'MaxClockSpeed', 'Name', 'NumberOfCores', 'NumberOfLogicalProcessors', | |||
'Version'); | |||
protected | |||
function GetQuery: String; override; | |||
function GetProperties: TStringArr; override; | |||
function GetSubItemName(const aIndex: Integer): String; override; | |||
public | |||
procedure Update; override; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
TutlVideoControllerInfo = class(TutlWmiSystemInfo) | |||
private const | |||
VIDEO_CONTROLLER_PROPERTIES: array[0..11] of String = ('AdapterRAM', 'Caption', | |||
'CurrentBitsPerPixel', 'CurrentHorizontalResolution', 'CurrentRefreshRate', | |||
'CurrentScanMode', 'CurrentVerticalResolution', 'Description', 'DriverDate', | |||
'DriverVersion', 'Name', 'VideoProcessor'); | |||
protected | |||
function GetQuery: String; override; | |||
function GetProperties: TStringArr; override; | |||
function GetSubItemName(const aIndex: Integer): String; override; | |||
public | |||
procedure Update; override; | |||
end; | |||
{$ENDIF} | |||
procedure LogSystemInfo(const aClass: TutlSystemInfoClass); | |||
const | |||
SYTEM_INFO_CLASSES_COUNT = {$IFDEF WINDOWS}2+{$ENDIF}1; | |||
SYTEM_INFO_CLASSES: array[0..SYTEM_INFO_CLASSES_COUNT-1] of TutlSystemInfoClass = ( | |||
{$IFDEF WINDOWS}TutlProcessorInfo, | |||
TutlVideoControllerInfo,{$ENDIF} | |||
TutlOpenGLInfo); | |||
implementation | |||
uses | |||
uutlExceptions, math, dglOpenGL, uutlLogger; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function CreateItem(const aName, aValue: String): TutlSystemInfo; | |||
begin | |||
result := TutlSystemInfo.Create; | |||
result.fName := aName; | |||
result.fValue := aValue; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function VariantToStr(const aVariant: Variant): String; | |||
begin | |||
result := ''; | |||
if (TVarData(aVariant).vtype <> varempty) and | |||
(TVarData(aVariant).vtype <> varnull) and | |||
(TVarData(aVariant).vtype <> varerror) then begin | |||
result := aVariant; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure LogSystemInfo(const aClass: TutlSystemInfoClass); | |||
var | |||
info: TutlSystemInfo; | |||
sList: TStringList; | |||
i: Integer; | |||
begin | |||
info := aClass.Create; | |||
sList := TStringList.Create; | |||
try try | |||
info.Update; | |||
sList.Text := info.ToString; | |||
for i := 0 to sList.Count-1 do | |||
utlLogger.Log('SystemInfo', sList[i], []); | |||
except on e: Exception do | |||
utlLogger.Error('SystemInfo', 'Error while logging system info: %s', [e.Message]); | |||
end; | |||
finally | |||
FreeAndNil(info); | |||
FreeAndNil(sList); | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlSystemInfo//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlSystemInfo.GetCount: Integer; | |||
begin | |||
result := fItems.Count; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlSystemInfo.GetItems(const aIndex: Integer): TutlSystemInfo; | |||
begin | |||
if (aIndex >= 0) and (aIndex < fItems.Count) then | |||
result := fItems[aIndex] | |||
else | |||
raise EOutOfRange.Create(aIndex, 0, fItems.Count-1); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlSystemInfo.Update; | |||
begin | |||
//DUMMY | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlSystemInfo.ToString: String; | |||
var | |||
str: String; | |||
procedure FillStr(var aStr: String; const aLen: Integer; const aChar: Char = ' '); | |||
begin | |||
while (Length(aStr) < aLen) do | |||
aStr := aStr + aChar; | |||
end; | |||
procedure WriteItem(const aPrefix: String; const aItem: TutlSystemInfo; const aItemLen: Integer); | |||
var | |||
len, i: Integer; | |||
line: String; | |||
begin | |||
line := aItem.Name + ':'; | |||
if (aItem.Count = 0) then begin | |||
line := line; | |||
FillStr(line, aItemLen + 2); | |||
line := line + aItem.Value; | |||
end; | |||
str := str + aPrefix + line + sLineBreak; | |||
if (aItem.Count > 0) then begin | |||
len := 0; | |||
for i := 0 to aItem.Count-1 do | |||
len := max(len, Length(aItem[i].Name)); | |||
for i := 0 to aItem.Count-1 do | |||
WriteItem(aPrefix+' ', aItem[i], len); | |||
end; | |||
end; | |||
begin | |||
str := ''; | |||
WriteItem('', self, 0); | |||
result := str; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
constructor TutlSystemInfo.Create; | |||
begin | |||
inherited Create; | |||
fName := ''; | |||
fValue := ''; | |||
fItems := TutlSystemInfoList.Create(true); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
destructor TutlSystemInfo.Destroy; | |||
begin | |||
FreeAndNil(fItems); | |||
inherited Destroy; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlOpenGLInfo//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlOpenGLInfo.Update; | |||
function AddItem(const aParent: TutlSystemInfo; const aName, aValue: String): TutlSystemInfo; | |||
begin | |||
result := CreateItem(aName, aValue); | |||
aParent.fItems.Add(result); | |||
end; | |||
function GetInteger(const aName: GLenum): String; | |||
var | |||
i: GLint; | |||
begin | |||
i := 0; | |||
glGetIntegerv(aName, @i); | |||
result := IntToStr(i); | |||
end; | |||
var | |||
item: TutlSystemInfo; | |||
begin | |||
inherited Update; | |||
fName := 'OpenGL Information'; | |||
fValue := ''; | |||
item := AddItem(self, 'ImplementationBasics', ''); | |||
AddItem(item, 'GL_VENDOR', glGetString(GL_VENDOR)); | |||
AddItem(item, 'GL_RENDER', glGetString(GL_RENDER)); | |||
AddItem(item, 'GL_VERSION', glGetString(GL_VERSION)); | |||
AddItem(item, 'GL_SHADING_LANGUAGE_VERSION', glGetString(GL_SHADING_LANGUAGE_VERSION)); | |||
item := AddItem(self, 'Basics', ''); | |||
AddItem(item, 'GL_MAX_VIEWPORT_DIMS', GetInteger(GL_MAX_VIEWPORT_DIMS)); | |||
AddItem(item, 'GL_MAX_LIGHTS', GetInteger(GL_MAX_LIGHTS)); | |||
AddItem(item, 'GL_MAX_CLIP_PLANES', GetInteger(GL_MAX_CLIP_PLANES)); | |||
AddItem(item, 'GL_MAX_MODELVIEW_STACK_DEPTH', GetInteger(GL_MAX_MODELVIEW_STACK_DEPTH)); | |||
AddItem(item, 'GL_MAX_PROJECTION_STACK_DEPTH', GetInteger(GL_MAX_PROJECTION_STACK_DEPTH)); | |||
AddItem(item, 'GL_MAX_TEXTURE_STACK_DEPTH', GetInteger(GL_MAX_TEXTURE_STACK_DEPTH)); | |||
AddItem(item, 'GL_MAX_ATTRIB_STACK_DEPTH', GetInteger(GL_MAX_ATTRIB_STACK_DEPTH)); | |||
AddItem(item, 'GL_MAX_COLOR_MATRIX_STACK_DEPTH', GetInteger(GL_MAX_COLOR_MATRIX_STACK_DEPTH)); | |||
AddItem(item, 'GL_MAX_LIST_NESTING', GetInteger(GL_MAX_LIST_NESTING)); | |||
AddItem(item, 'GL_SUBPIXEL_BITS', GetInteger(GL_SUBPIXEL_BITS)); | |||
AddItem(item, 'GL_MAX_ELEMENTS_INDICES', GetInteger(GL_MAX_ELEMENTS_INDICES)); | |||
AddItem(item, 'GL_MAX_ELEMENTS_VERTICES', GetInteger(GL_MAX_ELEMENTS_VERTICES)); | |||
AddItem(item, 'GL_MAX_TEXTURE_UNITS', GetInteger(GL_MAX_TEXTURE_UNITS)); | |||
AddItem(item, 'GL_MAX_TEXTURE_COORDS', GetInteger(GL_MAX_TEXTURE_COORDS)); | |||
AddItem(item, 'GL_MAX_SAMPLE_MASK_WORDS', GetInteger(GL_MAX_SAMPLE_MASK_WORDS)); | |||
AddItem(item, 'GL_MAX_COLOR_TEXTURE_SAMPLES', GetInteger(GL_MAX_COLOR_TEXTURE_SAMPLES)); | |||
AddItem(item, 'GL_MAX_DEPTH_TEXTURE_SAMPLES', GetInteger(GL_MAX_DEPTH_TEXTURE_SAMPLES)); | |||
AddItem(item, 'GL_MAX_INTEGER_SAMPLES', GetInteger(GL_MAX_INTEGER_SAMPLES)); | |||
item := AddItem(self, 'Textures', ''); | |||
AddItem(item, 'GL_MAX_TEXTURE_SIZE', GetInteger(GL_MAX_TEXTURE_SIZE)); | |||
AddItem(item, 'GL_MAX_3D_TEXTURE_SIZE', GetInteger(GL_MAX_3D_TEXTURE_SIZE)); | |||
AddItem(item, 'GL_MAX_CUBE_MAP_TEXTURE_SIZE', GetInteger(GL_MAX_CUBE_MAP_TEXTURE_SIZE)); | |||
AddItem(item, 'GL_MAX_TEXTURE_LOD_BIAS', GetInteger(GL_MAX_TEXTURE_LOD_BIAS)); | |||
AddItem(item, 'GL_MAX_ARRAY_TEXTURE_LAYERS', GetInteger(GL_MAX_ARRAY_TEXTURE_LAYERS)); | |||
AddItem(item, 'GL_MAX_TEXTURE_BUFFER_SIZE', GetInteger(GL_MAX_TEXTURE_BUFFER_SIZE)); | |||
AddItem(item, 'GL_MAX_RECTANGLE_TEXTURE_SIZE', GetInteger(GL_MAX_RECTANGLE_TEXTURE_SIZE)); | |||
AddItem(item, 'GL_MAX_RENDERBUFFER_SIZE', GetInteger(GL_MAX_RENDERBUFFER_SIZE)); | |||
item := AddItem(self, 'FrameBuffers', ''); | |||
AddItem(item, 'GL_MAX_DRAW_BUFFERS', GetInteger(GL_MAX_DRAW_BUFFERS)); | |||
AddItem(item, 'GL_MAX_COLOR_ATTACHMENTS', GetInteger(GL_MAX_COLOR_ATTACHMENTS)); | |||
AddItem(item, 'GL_MAX_SAMPLES', GetInteger(GL_MAX_SAMPLES)); | |||
item := AddItem(self, 'VertexShaderLimits', ''); | |||
AddItem(item, 'GL_MAX_VERTEX_ATTRIBS', GetInteger(GL_MAX_VERTEX_ATTRIBS)); | |||
AddItem(item, 'GL_MAX_VERTEX_UNIFORM_COMPONENTS', GetInteger(GL_MAX_VERTEX_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_VERTEX_UNIFORM_VECTORS', GetInteger(GL_MAX_VERTEX_UNIFORM_VECTORS)); | |||
AddItem(item, 'GL_MAX_VERTEX_UNIFORM_BLOCKS', GetInteger(GL_MAX_VERTEX_UNIFORM_BLOCKS)); | |||
AddItem(item, 'GL_MAX_VERTEX_OUTPUT_COMPONENTS', GetInteger(GL_MAX_VERTEX_OUTPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS)); | |||
item := AddItem(self, 'FragmentShaderLimits', ''); | |||
AddItem(item, 'GL_MAX_FRAGMENT_UNIFORM_COMPONENTS', GetInteger(GL_MAX_FRAGMENT_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_FRAGMENT_UNIFORM_VECTORS', GetInteger(GL_MAX_FRAGMENT_UNIFORM_VECTORS)); | |||
AddItem(item, 'GL_MAX_FRAGMENT_UNIFORM_BLOCKS', GetInteger(GL_MAX_FRAGMENT_UNIFORM_BLOCKS)); | |||
AddItem(item, 'GL_MAX_FRAGMENT_INPUT_COMPONENTS', GetInteger(GL_MAX_FRAGMENT_INPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_IMAGE_UNITS', GetInteger(GL_MAX_IMAGE_UNITS)); | |||
AddItem(item, 'GL_MAX_FRAGMENT_IMAGE_UNIFORMS', GetInteger(GL_MAX_FRAGMENT_IMAGE_UNIFORMS)); | |||
AddItem(item, 'GL_MIN_PROGRAM_TEXEL_OFFSET', GetInteger(GL_MIN_PROGRAM_TEXEL_OFFSET)); | |||
AddItem(item, 'GL_MAX_PROGRAM_TEXEL_OFFSET', GetInteger(GL_MAX_PROGRAM_TEXEL_OFFSET)); | |||
AddItem(item, 'GL_MIN_PROGRAM_TEXTURE_GATHER_OFFSET', GetInteger(GL_MIN_PROGRAM_TEXTURE_GATHER_OFFSET)); | |||
AddItem(item, 'GL_MAX_PROGRAM_TEXTURE_GATHER_OFFSET', GetInteger(GL_MAX_PROGRAM_TEXTURE_GATHER_OFFSET)); | |||
item := AddItem(self, 'CombinedFragmentAndVertexShaderLimits', ''); | |||
AddItem(item, 'GL_MAX_UNIFORM_BUFFER_BINDINGS', GetInteger(GL_MAX_UNIFORM_BUFFER_BINDINGS)); | |||
AddItem(item, 'GL_MAX_UNIFORM_BLOCK_SIZE', GetInteger(GL_MAX_UNIFORM_BLOCK_SIZE)); | |||
AddItem(item, 'GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT', GetInteger(GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT)); | |||
AddItem(item, 'GL_MAX_COMBINED_UNIFORM_BLOCKS', GetInteger(GL_MAX_COMBINED_UNIFORM_BLOCKS)); | |||
AddItem(item, 'GL_MAX_VARYING_FLOATS', GetInteger(GL_MAX_VARYING_FLOATS)); | |||
AddItem(item, 'GL_MAX_VARYING_COMPONENTS', GetInteger(GL_MAX_VARYING_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS)); | |||
AddItem(item, 'GL_MAX_SUBROUTINES', GetInteger(GL_MAX_SUBROUTINES)); | |||
AddItem(item, 'GL_MAX_SUBROUTINE_UNIFORM_LOCATIONS', GetInteger(GL_MAX_SUBROUTINE_UNIFORM_LOCATIONS)); | |||
AddItem(item, 'GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_COMBINED_GEOMETRY_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_GEOMETRY_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_COMBINED_TESS_CONTROL_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_TESS_CONTROL_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_COMBINED_TESS_EVALUATION_UNIFORM_COMPONENTS', GetInteger(GL_MAX_COMBINED_TESS_EVALUATION_UNIFORM_COMPONENTS)); | |||
item := AddItem(self, 'GeometryShaderLimits', ''); | |||
AddItem(item, 'GL_MAX_GEOMETRY_UNIFORM_BLOCKS', GetInteger(GL_MAX_GEOMETRY_UNIFORM_BLOCKS)); | |||
AddItem(item, 'GL_MAX_GEOMETRY_INPUT_COMPONENTS', GetInteger(GL_MAX_GEOMETRY_INPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_GEOMETRY_OUTPUT_COMPONENTS', GetInteger(GL_MAX_GEOMETRY_OUTPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_GEOMETRY_OUTPUT_VERTICES', GetInteger(GL_MAX_GEOMETRY_OUTPUT_VERTICES)); | |||
AddItem(item, 'GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS', GetInteger(GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS)); | |||
AddItem(item, 'GL_MAX_GEOMETRY_SHADER_INVOCATIONS', GetInteger(GL_MAX_GEOMETRY_SHADER_INVOCATIONS)); | |||
item := AddItem(self, 'TesselationShaderLimits', ''); | |||
AddItem(item, 'GL_MAX_TESS_GEN_LEVEL', GetInteger(GL_MAX_TESS_GEN_LEVEL)); | |||
AddItem(item, 'GL_MAX_PATCH_VERTICES', GetInteger(GL_MAX_PATCH_VERTICES)); | |||
AddItem(item, 'GL_MAX_TESS_PATCH_COMPONENTS', GetInteger(GL_MAX_TESS_PATCH_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TESS_CONTROL_UNIFORM_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TESS_CONTROL_UNIFORM_BLOCKS', GetInteger(GL_MAX_TESS_CONTROL_UNIFORM_BLOCKS)); | |||
AddItem(item, 'GL_MAX_TESS_CONTROL_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_TESS_CONTROL_TEXTURE_IMAGE_UNITS)); | |||
AddItem(item, 'GL_MAX_TESS_CONTROL_TOTAL_OUTPUT_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_TOTAL_OUTPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TESS_CONTROL_INPUT_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_INPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TESS_CONTROL_OUTPUT_COMPONENTS', GetInteger(GL_MAX_TESS_CONTROL_OUTPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TESS_EVALUATION_UNIFORM_COMPONENTS', GetInteger(GL_MAX_TESS_EVALUATION_UNIFORM_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TESS_EVALUATION_UNIFORM_BLOCKS', GetInteger(GL_MAX_TESS_EVALUATION_UNIFORM_BLOCKS)); | |||
AddItem(item, 'GL_MAX_TESS_EVALUATION_TEXTURE_IMAGE_UNITS', GetInteger(GL_MAX_TESS_EVALUATION_TEXTURE_IMAGE_UNITS)); | |||
AddItem(item, 'GL_MAX_TESS_EVALUATION_OUTPUT_COMPONENTS', GetInteger(GL_MAX_TESS_EVALUATION_OUTPUT_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TESS_EVALUATION_INPUT_COMPONENTS', GetInteger(GL_MAX_TESS_EVALUATION_INPUT_COMPONENTS)); | |||
item := AddItem(self, 'TransformFeedbackShaderLimits', ''); | |||
AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS)); | |||
AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS)); | |||
AddItem(item, 'GL_MAX_TRANSFORM_FEEDBACK_BUFFERS', GetInteger(GL_MAX_TRANSFORM_FEEDBACK_BUFFERS)); | |||
end; | |||
{$IFDEF WINDOWS} | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlWmiSystemInfo///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlWmiSystemInfo.GetComputer: String; | |||
begin | |||
result := 'localhost'#0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlWmiSystemInfo.GetNamespace: String; | |||
begin | |||
result := 'root\CIMV2'#0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlWmiSystemInfo.GetUsername: String; | |||
begin | |||
result := #0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlWmiSystemInfo.GetPassword: String; | |||
begin | |||
result := #0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlWmiSystemInfo.GetQuery: String; | |||
begin | |||
result := #0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlWmiSystemInfo.GetProperties: TStringArr; | |||
begin | |||
SetLength(result, 0); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlWmiSystemInfo.GetSubItemName(const aIndex: Integer): String; | |||
begin | |||
result := IntToStr(aIndex); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlWmiSystemInfo.Update; | |||
var | |||
SWbemLocator: OLEVariant; | |||
WMIService: OLEVariant; | |||
WbemObjectSet, WbemObject: OLEVariant; | |||
s: Variant; | |||
pCeltFetched: LongWord; | |||
oEnum: IEnumvariant; | |||
i, j: Integer; | |||
properties: TStringArr; | |||
item: TutlSystemInfo; | |||
computer: Variant; | |||
namespace: Variant; | |||
username: Variant; | |||
password: Variant; | |||
query: Variant; | |||
const | |||
WBEM_FLAGFORWARDONLY = $00000020; | |||
begin | |||
inherited Update; | |||
fItems.Clear; | |||
CoInitialize(nil); | |||
SWbemLocator := CreateOleObject('WbemScripting.SWbemLocator'); | |||
//WMIService := SWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword); | |||
computer := GetComputer; | |||
namespace := GetNamespace; | |||
username := GetUsername; | |||
password := GetPassword; | |||
query := GetQuery; | |||
WMIService := SWbemLocator.ConnectServer(computer, namespace, username, password); | |||
WbemObjectSet := WMIService.ExecQuery(query, 'WQL', WBEM_FLAGFORWARDONLY); | |||
oEnum := IUnknown(WbemObjectSet._NewEnum) as IEnumVariant; | |||
i := 0; | |||
properties := GetProperties; | |||
while oEnum.Next(1, WbemObject, pCeltFetched) = 0 do begin | |||
inc(i); | |||
item := TutlSystemInfo.Create; | |||
item.fName := GetSubItemName(i); | |||
fItems.Add(item); | |||
for j := low(properties) to high(properties) do begin | |||
s := properties[j]; | |||
item.fItems.Add(CreateItem( | |||
properties[j], | |||
VariantToStr(WbemObject.Properties_.Item(s).Value))); | |||
end; | |||
end; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//TutlProcessorInfo///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlProcessorInfo.GetQuery: String; | |||
begin | |||
result := 'SELECT * FROM Win32_Processor'#0; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlProcessorInfo.GetProperties: TStringArr; | |||
var | |||
i: Integer; | |||
begin | |||
SetLength(result, Length(PROCESSOR_PROPERTIES)); | |||
for i := low(result) to high(result) do | |||
result[i] := PROCESSOR_PROPERTIES[i]; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlProcessorInfo.GetSubItemName(const aIndex: Integer): String; | |||
begin | |||
result := format('Processor %d', [aIndex]); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlProcessorInfo.Update; | |||
begin | |||
fName := 'Processor Information'; | |||
fValue := ''; | |||
inherited Update; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlVideoControllerInfo.GetQuery: String; | |||
begin | |||
Result := 'SELECT * FROM Win32_VideoController'; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlVideoControllerInfo.GetProperties: TStringArr; | |||
var | |||
i: Integer; | |||
begin | |||
SetLength(result, Length(VIDEO_CONTROLLER_PROPERTIES)); | |||
for i := low(result) to high(result) do | |||
result[i] := VIDEO_CONTROLLER_PROPERTIES[i]; | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
function TutlVideoControllerInfo.GetSubItemName(const aIndex: Integer): String; | |||
begin | |||
Result := format('Video Controller %d', [aIndex]); | |||
end; | |||
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// | |||
procedure TutlVideoControllerInfo.Update; | |||
begin | |||
fName := 'Video Controller Information'; | |||
fValue := ''; | |||
inherited Update; | |||
end; | |||
{$ENDIF} | |||
end. | |||
@@ -0,0 +1,84 @@ | |||
unit uutlTiming; | |||
{ Package: Utils | |||
Prefix: utl - UTiLs | |||
Beschreibung: diese Unit enthält platformunabhängige Methoden für Zeitberechnungen und -messungen | |||
Mehr oder weniger platformunabhängige Timestampgenerierung. | |||
GetTickCount64 ms-Timer | |||
GetMicroTime us-Timer analog php microtime() | |||
Achtung: windows.pp deklariert auch eine GetTickCount64, wird gegen diese gelinkt | |||
läuft die exe nicht mehr unter XP. Unbeding uutlTiming *nach* windows einbinden. } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes | |||
{$ifdef Windows} | |||
, Windows | |||
{$else} | |||
, Unix, BaseUnix | |||
{$endif}; | |||
function GetTickCount64: QWord; | |||
function GetMicroTime: QWord; | |||
implementation | |||
{$IF defined(WINDOWS)} | |||
var | |||
PERF_FREQ: Int64; | |||
function GetTickCount64: QWord; | |||
begin | |||
// GetTickCount64 is better, but we need to check the Windows version to use it | |||
Result := Windows.GetTickCount(); | |||
end; | |||
function GetMicroTime: QWord; | |||
var | |||
pc: Int64; | |||
begin | |||
pc := 0; | |||
QueryPerformanceCounter(pc); | |||
Result:= (pc * 1000*1000) div PERF_FREQ; | |||
end; | |||
initialization | |||
PERF_FREQ := 0; | |||
QueryPerformanceFrequency(PERF_FREQ); | |||
{$ELSEIF defined(UNIX)} | |||
function GetTickCount64: QWord; | |||
var | |||
tp: TTimeVal; | |||
begin | |||
fpgettimeofday(@tp, nil); | |||
Result := (Int64(tp.tv_sec) * 1000) + (tp.tv_usec div 1000); | |||
end; | |||
function GetMicroTime: QWord; | |||
var | |||
tp: TTimeVal; | |||
begin | |||
fpgettimeofday(@tp, nil); | |||
Result := (Int64(tp.tv_sec) * 1000*1000) + tp.tv_usec; | |||
end; | |||
{$ELSE} | |||
function GetTickCount64: QWord; | |||
begin | |||
Result := Trunc(Now * 24 * 60 * 60 * 1000); | |||
end; | |||
function GetMicroTime: QWord; | |||
begin | |||
Result := Trunc(Now * 24 * 60 * 60 * 1000*1000); | |||
end; | |||
{$ENDIF} | |||
end. | |||