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

Changed: TSplitArray -> TStringDynArray (backwards compatible)

X2UtPersist.pas

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

X2UtPersistRegistry.pas

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

X2UtStrings.pas

@@ -7,9 +7,13 @@
 unit X2UtStrings;
 
 interface
+uses
+  Types;
+
 type
-  //** Array of string values.
+  {** Backwards compatibility }
-  TSplitArray = array of String;
+  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;