diff --git a/X2UtPersist.pas b/X2UtPersist.pas new file mode 100644 index 0000000..711084d --- /dev/null +++ b/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. + diff --git a/X2UtPersistRegistry.pas b/X2UtPersistRegistry.pas new file mode 100644 index 0000000..c00362f --- /dev/null +++ b/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. + diff --git a/X2UtStrings.pas b/X2UtStrings.pas index 2c8bf8f..9434061 100644 --- a/X2UtStrings.pas +++ b/X2UtStrings.pas @@ -7,10 +7,14 @@ unit X2UtStrings; interface -type - //** Array of string values. - TSplitArray = array of String; +uses + Types; +type + {** Backwards compatibility } + TSplitArray = TStringDynArray; + + {** Formats the specified size. * * @param ABytes the size to format in bytes. @@ -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;