1
0
mirror of synced 2024-12-22 09:13:07 +01:00

Added: object persistancy classes (writing an object to the registry using RTTI)

Changed: TSplitArray -> TStringDynArray (backwards compatible)
This commit is contained in:
Mark van Renswoude 2007-06-08 14:10:03 +00:00
parent 5a274c11ef
commit b86e2def4a
3 changed files with 709 additions and 7 deletions

413
X2UtPersist.pas Normal file
View File

@ -0,0 +1,413 @@
unit X2UtPersist;
interface
uses
Classes,
Types,
TypInfo;
type
TX2IterateObjectProc = procedure(AObject: TObject; APropInfo: PPropInfo; var AContinue: Boolean) of object;
TX2CustomPersist = class(TObject)
private
FSections: TStrings;
protected
function IterateObject(AObject: TObject; ACallback: TX2IterateObjectProc): Boolean; virtual;
procedure ReadObject(AObject: TObject; APropInfo: PPropInfo; var AContinue: Boolean);
procedure WriteObject(AObject: TObject; APropInfo: PPropInfo; var AContinue: Boolean);
protected
function DoRead(AObject: TObject): Boolean; virtual;
procedure DoWrite(AObject: TObject); virtual;
function BeginSection(const AName: String): Boolean; virtual;
procedure EndSection(); virtual;
function ReadInteger(const AName: String; out AValue: Integer): Boolean; virtual; abstract;
function ReadFloat(const AName: String; out AValue: Extended): Boolean; virtual; abstract;
function ReadString(const AName: String; out AValue: String): Boolean; virtual; abstract;
function ReadInt64(const AName: String; out AValue: Int64): Boolean; virtual; abstract;
procedure ReadCollection(const AName: String; ACollection: TCollection); virtual;
procedure ReadStream(const AName: String; AStream: TStream); virtual;
function WriteInteger(const AName: String; AValue: Integer): Boolean; virtual; abstract;
function WriteFloat(const AName: String; AValue: Extended): Boolean; virtual; abstract;
function WriteString(const AName, AValue: String): Boolean; virtual; abstract;
function WriteInt64(const AName: String; AValue: Int64): Boolean; virtual; abstract;
procedure ClearCollection(); virtual;
procedure WriteCollection(const AName: String; ACollection: TCollection); virtual;
procedure WriteStream(const AName: String; AStream: TStream); virtual;
property Sections: TStrings read FSections;
public
constructor Create();
destructor Destroy(); override;
function Read(AObject: TObject): Boolean; virtual;
procedure Write(AObject: TObject); virtual;
end;
const
CollectionCountName = 'Count';
CollectionItemNamePrefix = 'Item';
implementation
uses
SysUtils,
X2UtStrings;
{ TX2CustomPersist }
constructor TX2CustomPersist.Create();
begin
inherited;
FSections := TStringList.Create();
end;
destructor TX2CustomPersist.Destroy();
begin
FreeAndNil(FSections);
inherited;
end;
function TX2CustomPersist.IterateObject(AObject: TObject; ACallback: TX2IterateObjectProc): Boolean;
var
propCount: Integer;
propList: PPropList;
propIndex: Integer;
propInfo: PPropInfo;
continue: Boolean;
begin
Result := True;
{ Iterate through published properties }
propCount := GetPropList(AObject.ClassInfo, tkProperties, nil);
if propCount > 0 then
begin
GetMem(propList, propCount * SizeOf(PPropInfo));
try
GetPropList(AObject.ClassInfo, tkProperties, propList);
continue := True;
for propIndex := 0 to Pred(propCount) do
begin
propInfo := propList^[propIndex];
ACallback(AObject, propInfo, continue);
if not continue then
begin
Result := False;
Break;
end;
end;
finally
FreeMem(propList, propCount * SizeOf(PPropInfo));
end;
end;
end;
function TX2CustomPersist.Read(AObject: TObject): Boolean;
begin
Assert(Assigned(AObject), 'AObject must be assigned.');
Result := DoRead(AObject);
end;
procedure TX2CustomPersist.Write(AObject: TObject);
begin
Assert(Assigned(AObject), 'AObject must be assigned.');
DoWrite(AObject);
end;
function TX2CustomPersist.DoRead(AObject: TObject): Boolean;
begin
IterateObject(AObject, ReadObject);
Result := True;
end;
procedure TX2CustomPersist.DoWrite(AObject: TObject);
begin
IterateObject(AObject, WriteObject);
end;
function TX2CustomPersist.BeginSection(const AName: String): Boolean;
begin
FSections.Add(AName);
Result := True;
end;
procedure TX2CustomPersist.EndSection();
begin
Assert(FSections.Count > 0, 'EndSection called without BeginSection');
FSections.Delete(Pred(FSections.Count));
end;
procedure TX2CustomPersist.ReadObject(AObject: TObject; APropInfo: PPropInfo;
var AContinue: Boolean);
var
ordValue: Integer;
floatValue: Extended;
stringValue: String;
int64Value: Int64;
objectProp: TObject;
begin
{ Only read writable properties }
if (APropInfo^.PropType^.Kind <> tkClass) and
(not Assigned(APropInfo^.SetProc)) then
Exit;
case APropInfo^.PropType^.Kind of
tkInteger,
tkChar,
tkWChar:
if ReadInteger(APropInfo^.Name, ordValue) then
SetOrdProp(AObject, APropInfo, ordValue);
tkFloat:
if ReadFloat(APropInfo^.Name, floatValue) then
SetFloatProp(AObject, APropInfo, floatValue);
tkEnumeration:
if ReadString(APropInfo^.Name, stringValue) then
begin
ordValue := GetEnumValue(APropInfo^.PropType^, stringValue);
if ordValue >= 0 then
SetOrdProp(AObject, APropInfo, ordValue);
end;
tkString,
tkLString,
tkWString:
if ReadString(APropInfo^.Name, stringValue) then
SetStrProp(AObject, APropInfo, stringValue);
tkSet:
if ReadString(APropInfo^.Name, stringValue) then
begin
try
ordValue := StringToSet(APropInfo, stringValue);
SetOrdProp(AObject, APropInfo, ordValue);
except
on E:EPropertyConvertError do;
end;
end;
tkVariant:
if ReadString(APropInfo^.Name, stringValue) then
SetVariantProp(AObject, APropInfo, stringValue);
tkInt64:
if ReadInt64(APropInfo^.Name, int64Value) then
SetInt64Prop(AObject, APropInfo, int64Value);
tkClass:
begin
objectProp := GetObjectProp(AObject, APropInfo);
if Assigned(objectProp) then
begin
if objectProp is TStream then
begin
ReadStream(APropInfo^.Name, TStream(objectProp));
end else
begin
{ Recurse into object properties }
if BeginSection(APropInfo^.Name) then
try
if objectProp is TCollection then
ReadCollection(APropInfo^.Name, TCollection(objectProp));
AContinue := IterateObject(objectProp, ReadObject);
finally
EndSection();
end;
end;
end;
end;
end;
end;
procedure TX2CustomPersist.WriteObject(AObject: TObject; APropInfo: PPropInfo; var AContinue: Boolean);
var
ordValue: Integer;
floatValue: Extended;
stringValue: String;
int64Value: Int64;
objectProp: TObject;
begin
{ Only write read/writable properties which have IsStored True }
if (APropInfo^.PropType^.Kind <> tkClass) and
(not (Assigned(APropInfo^.GetProc) and
Assigned(APropInfo^.SetProc) and
IsStoredProp(AObject, APropInfo))) then
Exit;
case APropInfo^.PropType^.Kind of
tkInteger,
tkChar,
tkWChar:
begin
ordValue := GetOrdProp(AObject, APropInfo);
WriteInteger(APropInfo^.Name, ordValue);
end;
tkFloat:
begin
floatValue := GetFloatProp(AObject, APropInfo);
WriteFloat(APropInfo^.Name, floatValue);
end;
tkEnumeration:
begin
ordValue := GetOrdProp(AObject, APropInfo);
stringValue := GetEnumName(APropInfo^.PropType^, ordValue);
WriteString(APropInfo^.Name, stringValue);
end;
tkString,
tkLString,
tkWString:
begin
stringValue := GetStrProp(AObject, APropInfo);
WriteString(APropInfo^.Name, stringValue);
end;
tkSet:
begin
ordValue := GetOrdProp(AObject, APropInfo);
stringValue := SetToString(APropInfo, ordValue, True);
WriteString(APropInfo^.Name, stringValue);
end;
tkVariant:
begin
stringValue := GetVariantProp(AObject, APropInfo);
WriteString(APropInfo^.Name, stringValue);
end;
tkInt64:
begin
int64Value := GetInt64Prop(AObject, APropInfo);
WriteInt64(APropInfo^.Name, int64Value);
end;
tkClass:
begin
objectProp := GetObjectProp(AObject, APropInfo);
if Assigned(objectProp) then
begin
if objectProp is TStream then
begin
WriteStream(APropInfo^.Name, TStream(objectProp));
end else
begin
{ Recurse into object properties }
if BeginSection(APropInfo^.Name) then
try
if objectProp is TCollection then
WriteCollection(APropInfo^.Name, TCollection(objectProp));
AContinue := IterateObject(objectProp, WriteObject);
finally
EndSection();
end;
end;
end;
end;
end;
end;
procedure TX2CustomPersist.ReadCollection(const AName: String; ACollection: TCollection);
var
itemCount: Integer;
itemIndex: Integer;
collectionItem: TCollectionItem;
begin
if ReadInteger(CollectionCountName, itemCount) then
begin
ACollection.BeginUpdate();
try
ACollection.Clear();
for itemIndex := 0 to Pred(itemCount) do
begin
if BeginSection(CollectionItemNamePrefix + IntToStr(itemIndex)) then
try
collectionItem := ACollection.Add();
IterateObject(collectionItem, ReadObject);
finally
EndSection();
end;
end;
finally
ACollection.EndUpdate();
end;
end;
end;
procedure TX2CustomPersist.ReadStream(const AName: String; AStream: TStream);
begin
// #ToDo1 (MvR) 8-6-2007: ReadStream
end;
procedure TX2CustomPersist.ClearCollection();
begin
end;
procedure TX2CustomPersist.WriteCollection(const AName: String; ACollection: TCollection);
var
itemIndex: Integer;
begin
ClearCollection();
WriteInteger(CollectionCountName, ACollection.Count);
for itemIndex := 0 to Pred(ACollection.Count) do
begin
if BeginSection(CollectionItemNamePrefix + IntToStr(itemIndex)) then
try
IterateObject(ACollection.Items[itemIndex], WriteObject);
finally
EndSection();
end;
end;
end;
procedure TX2CustomPersist.WriteStream(const AName: String; AStream: TStream);
begin
// #ToDo1 (MvR) 8-6-2007: WriteStream
end;
end.

285
X2UtPersistRegistry.pas Normal file
View File

@ -0,0 +1,285 @@
unit X2UtPersistRegistry;
interface
uses
Classes,
Registry,
Windows,
X2UtPersist;
type
TX2UtPersistRegistry = class(TX2CustomPersist)
private
FKey: String;
FRootKey: HKEY;
FRegistry: TRegistry;
FReading: Boolean;
protected
procedure InitRegistry(AReading: Boolean);
procedure FinalizeRegistry();
function OpenKey(const ANewKey: String): Boolean;
function DoRead(AObject: TObject): Boolean; override;
procedure DoWrite(AObject: TObject); override;
function BeginSection(const AName: String): Boolean; override;
procedure EndSection(); override;
function ReadInteger(const AName: String; out AValue: Integer): Boolean; override;
function ReadFloat(const AName: String; out AValue: Extended): Boolean; override;
function ReadString(const AName: String; out AValue: String): Boolean; override;
function ReadInt64(const AName: String; out AValue: Int64): Boolean; override;
function WriteInteger(const AName: String; AValue: Integer): Boolean; override;
function WriteFloat(const AName: String; AValue: Extended): Boolean; override;
function WriteString(const AName, AValue: String): Boolean; override;
function WriteInt64(const AName: String; AValue: Int64): Boolean; override;
procedure ClearCollection(); override;
property Registry: TRegistry read FRegistry;
public
constructor Create();
destructor Destroy(); override;
property Key: String read FKey write FKey;
property RootKey: HKEY read FRootKey write FRootKey;
end;
{ Wrapper functions }
function ReadFromRegistry(AObject: TObject; const AKey: String; ARootKey: HKEY = HKEY_CURRENT_USER): Boolean;
procedure WriteToRegistry(AObject: TObject; const AKey: String; ARootKey: HKEY = HKEY_CURRENT_USER);
implementation
uses
SysUtils,
X2UtStrings;
const
RegistrySeparator = '\';
{ Wrapper functions }
function ReadFromRegistry(AObject: TObject; const AKey: String; ARootKey: HKEY): Boolean;
begin
with TX2UtPersistRegistry.Create() do
try
RootKey := ARootKey;
Key := AKey;
Result := Read(AObject);
finally
Free();
end;
end;
procedure WriteToRegistry(AObject: TObject; const AKey: String; ARootKey: HKEY);
begin
with TX2UtPersistRegistry.Create() do
try
RootKey := ARootKey;
Key := AKey;
Write(AObject);
finally
Free();
end;
end;
{ TX2UtPersistRegistry }
constructor TX2UtPersistRegistry.Create();
begin
inherited;
FRootKey := HKEY_CURRENT_USER;
end;
destructor TX2UtPersistRegistry.Destroy();
begin
inherited;
end;
procedure TX2UtPersistRegistry.InitRegistry(AReading: Boolean);
begin
FReading := AReading;
if AReading then
FRegistry := TRegistry.Create(KEY_READ)
else
FRegistry := TRegistry.Create();
FRegistry.RootKey := Self.RootKey;
end;
procedure TX2UtPersistRegistry.FinalizeRegistry();
begin
FreeAndNil(FRegistry);
end;
function TX2UtPersistRegistry.OpenKey(const ANewKey: String): Boolean;
var
keyName: String;
sectionIndex: Integer;
begin
keyName := Self.Key;
if (Length(keyName) > 0) and (keyName[Length(keyName)] = RegistrySeparator) then
SetLength(keyName, Pred(Length(keyName)));
for sectionIndex := 0 to Pred(Sections.Count) do
keyName := keyName + RegistrySeparator + Sections[sectionIndex];
if Length(ANewKey) > 0 then
keyName := keyName + RegistrySeparator + ANewKey;
if Length(keyName) > 0 then
begin
if FReading then
Result := FRegistry.OpenKeyReadOnly(keyName)
else
Result := FRegistry.OpenKey(keyName, True);
end else
Result := False;
end;
function TX2UtPersistRegistry.DoRead(AObject: TObject): Boolean;
begin
InitRegistry(True);
try
OpenKey('');
Result := inherited DoRead(AObject);
finally
FinalizeRegistry();
end;
end;
procedure TX2UtPersistRegistry.DoWrite(AObject: TObject);
begin
InitRegistry(False);
try
OpenKey('');
inherited DoWrite(AObject);
finally
FinalizeRegistry();
end;
end;
function TX2UtPersistRegistry.BeginSection(const AName: String): Boolean;
begin
Result := OpenKey(AName);
if Result then
inherited BeginSection(AName);
end;
procedure TX2UtPersistRegistry.EndSection();
begin
inherited;
{ Re-open the previous section }
OpenKey('');
end;
function TX2UtPersistRegistry.ReadInteger(const AName: String; out AValue: Integer): Boolean;
begin
Result := Registry.ValueExists(AName);
if Result then
AValue := Registry.ReadInteger(AName);
end;
function TX2UtPersistRegistry.ReadFloat(const AName: String; out AValue: Extended): Boolean;
begin
Result := Registry.ValueExists(AName);
if Result then
AValue := Registry.ReadFloat(AName);
end;
function TX2UtPersistRegistry.ReadString(const AName: String; out AValue: String): Boolean;
begin
Result := Registry.ValueExists(AName);
if Result then
AValue := Registry.ReadString(AName);
end;
function TX2UtPersistRegistry.ReadInt64(const AName: String; out AValue: Int64): Boolean;
begin
Result := (Registry.GetDataSize(AName) = SizeOf(AValue));
if Result then
Registry.ReadBinaryData(AName, AValue, SizeOf(AValue));
end;
function TX2UtPersistRegistry.WriteInteger(const AName: String; AValue: Integer): Boolean;
begin
Registry.WriteInteger(AName, AValue);
Result := True;
end;
function TX2UtPersistRegistry.WriteFloat(const AName: String; AValue: Extended): Boolean;
begin
Registry.WriteFloat(AName, AValue);
Result := True;
end;
function TX2UtPersistRegistry.WriteString(const AName, AValue: String): Boolean;
begin
Registry.WriteString(AName, AValue);
Result := True;
end;
function TX2UtPersistRegistry.WriteInt64(const AName: String; AValue: Int64): Boolean;
begin
Registry.WriteBinaryData(AName, AValue, SizeOf(AValue));
Result := True;
end;
procedure TX2UtPersistRegistry.ClearCollection();
var
keyNames: TStringList;
keyIndex: Integer;
begin
inherited;
keyNames := TStringList.Create();
try
Registry.GetKeyNames(keyNames);
for keyIndex := 0 to Pred(keyNames.Count) do
if SameTextS(keyNames[keyIndex], CollectionItemNamePrefix) then
Registry.DeleteKey(keyNames[keyIndex]);
finally
FreeAndNil(keyNames);
end;
end;
end.

View File

@ -7,9 +7,13 @@
unit X2UtStrings;
interface
uses
Types;
type
//** Array of string values.
TSplitArray = array of String;
{** Backwards compatibility }
TSplitArray = TStringDynArray;
{** Formats the specified size.
*
@ -74,7 +78,7 @@ type
* @todo though optimized, it now fails on #0 characters, need
* to determine the end by checking the AnsiString length.
*}
procedure Split(const ASource, ADelimiter: String; out ADest: TSplitArray);
procedure Split(const ASource, ADelimiter: String; out ADest: TStringDynArray);
{** Appends string parts with a specified glue value.
*
@ -82,7 +86,7 @@ type
* @param AGlue the string added between the parts
* @result the composed parts
*}
function Join(const ASource: TSplitArray; const AGlue: String): String;
function Join(const ASource: TStringDynArray; const AGlue: String): String;
{** Determines if one path is the child of another path.
*
@ -196,7 +200,7 @@ begin
end;
procedure Split(const ASource, ADelimiter: String; out ADest: TSplitArray);
procedure Split(const ASource, ADelimiter: String; out ADest: TStringDynArray);
// StrPos is slow. Sloooooow slow. This function may not be advanced or
// the fastest one around, but it sure kicks StrPos' ass.
// 11.5 vs 1.7 seconds on a 2.4 Ghz for 10.000 iterations, baby!
@ -317,7 +321,7 @@ begin
until False;
end;
function Join(const ASource: TSplitArray; const AGlue: String): String;
function Join(const ASource: TStringDynArray; const AGlue: String): String;
var
iGlue: Integer;
iHigh: Integer;