1
0
mirror of synced 2024-12-22 09:13:07 +01:00
x2utils/X2UtPersist.pas
Mark van Renswoude 06e559505d Fixes for Delphi XE2
Fixed compatibility with D2007
2013-04-09 14:48:41 +00:00

899 lines
24 KiB
ObjectPascal

{
:: X2UtPersist provides a framework for persisting objects and settings.
::
:: Last changed: $Date$
:: Revision: $Rev$
:: Author: $Author$
}
unit X2UtPersist;
interface
uses
Classes,
Contnrs,
Types,
TypInfo,
X2UtPersistIntf;
type
TX2IterateObjectProc = procedure(AObject: TObject; APropInfo: PPropInfo; var AContinue: Boolean) of object;
TX2CustomPersist = class(TInterfacedPersistent, IX2Persist)
protected
function CreateFiler(AIsReader: Boolean): IX2PersistFiler; virtual; abstract;
public
function Read(AObject: TObject): Boolean; virtual;
procedure Write(AObject: TObject); virtual;
function CreateReader: IX2PersistReader; virtual;
function CreateWriter: IX2PersistWriter; virtual;
function CreateSectionReader(const ASection: String): IX2PersistReader; virtual;
function CreateSectionWriter(const ASection: String): IX2PersistWriter; virtual;
end;
TX2CustomPersistFiler = class(TInterfacedObject, IInterface, IX2PersistFiler,
IX2PersistReader, IX2PersistWriter)
private
FIsReader: Boolean;
FSections: TStrings;
protected
{ IInterface }
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function IterateObject(AObject: TObject; ACallback: TX2IterateObjectProc): Boolean; virtual;
procedure ReadObject(AObject: TObject; APropInfo: PPropInfo; var AContinue: Boolean); virtual;
procedure WriteObject(AObject: TObject; APropInfo: PPropInfo; var AContinue: Boolean); virtual;
property IsReader: Boolean read FIsReader;
property Sections: TStrings read FSections;
public
constructor Create(AIsReader: Boolean);
destructor Destroy; override;
{ IX2PersistFiler }
function BeginSection(const AName: String): Boolean; virtual;
procedure EndSection; virtual;
procedure GetKeys(const ADest: TStrings); virtual; abstract;
procedure GetSections(const ADest: TStrings); virtual; abstract;
{ IX2PersistReader }
function Read(AObject: TObject): Boolean; virtual;
function ReadBoolean(const AName: String; out AValue: Boolean): Boolean; 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;
function ReadStream(const AName: String; AStream: TStream): Boolean; virtual;
procedure ReadCollection(ACollection: TCollection); virtual;
{ IX2PersistWriter }
procedure Write(AObject: TObject); virtual;
function WriteBoolean(const AName: String; AValue: Boolean): Boolean; 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;
function WriteStream(const AName: String; AStream: TStream): Boolean; virtual;
procedure ClearCollection; virtual;
procedure WriteCollection(ACollection: TCollection); virtual;
procedure DeleteKey(const AName: String); virtual; abstract;
procedure DeleteSection(const AName: String); virtual; abstract;
{ IX2PersistReader2 }
function ReadVariant(const AName: string; out AValue: Variant): Boolean; virtual;
{ IX2PersistWriter2 }
function WriteVariant(const AName: Variant; const AValue: Variant): Boolean; virtual;
end;
implementation
uses
SysUtils,
Variants,
X2UtStrings;
{$I X2UtCompilerVersion.inc}
type
{ This class has to proxy all the interfaces in order for
reference counting to go through this class. }
TX2PersistSectionFilerProxy = class(TInterfacedObject, IInterface,
IX2PersistFiler, IX2PersistReader,
IX2PersistWriter, IX2PersistReader2,
IX2PersistWriter2)
private
FFiler: IX2PersistFiler;
FSectionCount: Integer;
protected
property Filer: IX2PersistFiler read FFiler;
property SectionCount: Integer read FSectionCount;
{ IInterface }
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
{ IX2PersistFiler }
function BeginSection(const AName: String): Boolean;
procedure EndSection;
procedure GetKeys(const ADest: TStrings);
procedure GetSections(const ADest: TStrings);
{ IX2PersistReader }
function Read(AObject: TObject): Boolean;
function ReadBoolean(const AName: string; out AValue: Boolean): Boolean;
function ReadInteger(const AName: String; out AValue: Integer): Boolean;
function ReadFloat(const AName: String; out AValue: Extended): Boolean;
function ReadString(const AName: String; out AValue: String): Boolean;
function ReadInt64(const AName: String; out AValue: Int64): Boolean;
function ReadStream(const AName: String; AStream: TStream): Boolean;
{ IX2PersistWriter }
procedure Write(AObject: TObject);
function WriteBoolean(const AName: String; AValue: Boolean): Boolean;
function WriteInteger(const AName: String; AValue: Integer): Boolean;
function WriteFloat(const AName: String; AValue: Extended): Boolean;
function WriteString(const AName, AValue: String): Boolean;
function WriteInt64(const AName: String; AValue: Int64): Boolean;
function WriteStream(const AName: String; AStream: TStream): Boolean;
procedure DeleteKey(const AName: String);
procedure DeleteSection(const AName: String);
{ IX2PersistReader2 }
function ReadVariant(const AName: string; out AValue: Variant): Boolean;
{ IX2PersistWriter2 }
function WriteVariant(const AName: Variant; const AValue: Variant): Boolean;
public
constructor Create(const AFiler: IX2PersistFiler; const ASection: String);
destructor Destroy; override;
end;
{ TX2CustomPersist }
function TX2CustomPersist.CreateReader: IX2PersistReader;
begin
Result := (CreateFiler(True) as IX2PersistReader);
end;
function TX2CustomPersist.CreateWriter: IX2PersistWriter;
begin
Result := (CreateFiler(False) as IX2PersistWriter);
end;
function TX2CustomPersist.CreateSectionReader(const ASection: String): IX2PersistReader;
begin
Result := (TX2PersistSectionFilerProxy.Create(CreateReader, ASection) as IX2PersistReader);
end;
function TX2CustomPersist.CreateSectionWriter(const ASection: String): IX2PersistWriter;
begin
Result := (TX2PersistSectionFilerProxy.Create(CreateWriter, ASection) as IX2PersistWriter);
end;
function TX2CustomPersist.Read(AObject: TObject): Boolean;
begin
with CreateReader do
Result := Read(AObject);
end;
procedure TX2CustomPersist.Write(AObject: TObject);
begin
with CreateWriter do
Write(AObject);
end;
{ TX2CustomPersistFiler }
constructor TX2CustomPersistFiler.Create(AIsReader: Boolean);
begin
inherited Create;
FIsReader := AIsReader;
FSections := TStringList.Create;
end;
destructor TX2CustomPersistFiler.Destroy;
begin
FreeAndNil(FSections);
inherited;
end;
function TX2CustomPersistFiler.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
Pointer(Obj) := nil;
Result := E_NOINTERFACE;
{ A filer is one-way, prevent the wrong interface from being obtained }
if IsEqualGUID(IID, IX2PersistReader) and (not IsReader) then
Exit;
if IsEqualGUID(IID, IX2PersistWriter) and IsReader then
Exit;
Result := inherited QueryInterface(IID, Obj);
end;
function TX2CustomPersistFiler.BeginSection(const AName: String): Boolean;
begin
FSections.Add(AName);
Result := True;
end;
procedure TX2CustomPersistFiler.EndSection;
begin
Assert(FSections.Count > 0, 'EndSection called without BeginSection');
FSections.Delete(Pred(FSections.Count));
end;
function TX2CustomPersistFiler.IterateObject(AObject: TObject; ACallback: TX2IterateObjectProc): Boolean;
var
propCount: Integer;
propList: PPropList;
propIndex: Integer;
propInfo: PPropInfo;
continue: Boolean;
begin
Result := (AObject.ClassInfo <> nil);
if not Result then
Exit;
{ 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 TX2CustomPersistFiler.Read(AObject: TObject): Boolean;
var
customDataIntf: IX2PersistCustomData;
begin
Assert(Assigned(AObject), 'AObject must be assigned.');
if AObject is TCollection then
ReadCollection(TCollection(AObject));
Result := IterateObject(AObject, ReadObject);
if Result and Supports(AObject, IX2PersistCustomData, customDataIntf) then
customDataIntf.Read(Self);
end;
function TX2CustomPersistFiler.ReadBoolean(const AName: String; out AValue: Boolean): Boolean;
var
value: String;
begin
AValue := False;
Result := ReadString(AName, value) and
TryStrToBool(value, AValue);
end;
procedure TX2CustomPersistFiler.ReadObject(AObject: TObject; APropInfo: PPropInfo;
var AContinue: Boolean);
var
ordValue: Integer;
floatValue: Extended;
stringValue: String;
int64Value: Int64;
objectProp: TObject;
variantValue: Variant;
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(string(APropInfo^.Name), ordValue) then
SetOrdProp(AObject, APropInfo, ordValue);
tkFloat:
if ReadFloat(string(APropInfo^.Name), floatValue) then
SetFloatProp(AObject, APropInfo, floatValue);
tkEnumeration:
if ReadString(string(APropInfo^.Name), stringValue) then
begin
ordValue := GetEnumValue(APropInfo^.PropType^, stringValue);
if ordValue >= 0 then
SetOrdProp(AObject, APropInfo, ordValue);
end;
tkString,
{$IFDEF D2009PLUS}
tkUString,
{$ENDIF}
tkLString,
tkWString:
if ReadString(string(APropInfo^.Name), stringValue) then
SetStrProp(AObject, APropInfo, stringValue);
tkSet:
if ReadString(string(APropInfo^.Name), stringValue) then
begin
try
ordValue := StringToSet(APropInfo, stringValue);
SetOrdProp(AObject, APropInfo, ordValue);
except
on E:EPropertyConvertError do;
end;
end;
tkVariant:
if ReadVariant(string(APropInfo^.Name), variantValue) then
SetVariantProp(AObject, APropInfo, variantValue);
tkInt64:
if ReadInt64(string(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(string(APropInfo^.Name), TStream(objectProp));
end else
begin
{ Recurse into object properties }
if BeginSection(string(APropInfo^.Name)) then
try
AContinue := Read(objectProp);
finally
EndSection;
end;
end;
end;
end;
end;
end;
procedure TX2CustomPersistFiler.Write(AObject: TObject);
var
customDataIntf: IX2PersistCustomData;
begin
Assert(Assigned(AObject), 'AObject must be assigned.');
if AObject is TCollection then
WriteCollection(TCollection(AObject));
if IterateObject(AObject, WriteObject) and
Supports(AObject, IX2PersistCustomData, customDataIntf) then
customDataIntf.Write(Self);
end;
function TX2CustomPersistFiler.WriteBoolean(const AName: String; AValue: Boolean): Boolean;
begin
Result := WriteString(AName, BoolToStr(AValue, True));
end;
procedure TX2CustomPersistFiler.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(string(APropInfo^.Name), ordValue);
end;
tkFloat:
begin
floatValue := GetFloatProp(AObject, APropInfo);
WriteFloat(string(APropInfo^.Name), floatValue);
end;
tkEnumeration:
begin
ordValue := GetOrdProp(AObject, APropInfo);
stringValue := GetEnumName(APropInfo^.PropType^, ordValue);
WriteString(string(APropInfo^.Name), stringValue);
end;
tkString,
{$IFDEF D2009PLUS}
tkUString,
{$ENDIF}
tkLString,
tkWString:
begin
stringValue := GetStrProp(AObject, APropInfo);
WriteString(string(APropInfo^.Name), stringValue);
end;
tkSet:
begin
ordValue := GetOrdProp(AObject, APropInfo);
stringValue := SetToString(APropInfo, ordValue, True);
WriteString(string(APropInfo^.Name), stringValue);
end;
tkVariant:
begin
WriteVariant(APropInfo^.Name, GetVariantProp(AObject, APropInfo));
end;
tkInt64:
begin
int64Value := GetInt64Prop(AObject, APropInfo);
WriteInt64(string(APropInfo^.Name), int64Value);
end;
tkClass:
begin
objectProp := GetObjectProp(AObject, APropInfo);
if Assigned(objectProp) then
begin
if objectProp is TStream then
begin
WriteStream(string(APropInfo^.Name), TStream(objectProp));
end else
begin
{ Recurse into object properties }
if BeginSection(string(APropInfo^.Name)) then
try
Write(objectProp);
finally
EndSection;
end;
end;
end;
end;
end;
end;
procedure TX2CustomPersistFiler.ReadCollection(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;
Read(collectionItem);
finally
EndSection;
end;
end;
finally
ACollection.EndUpdate;
end;
end;
end;
function TX2CustomPersistFiler.ReadStream(const AName: String; AStream: TStream): Boolean;
var
data: String;
begin
Result := ReadString(AName, data);
if Result then
AStream.WriteBuffer(PChar(data)^, Length(data));
end;
procedure TX2CustomPersistFiler.ClearCollection;
var
sections: TStringList;
sectionIndex: Integer;
begin
inherited;
sections := TStringList.Create;
try
GetSections(sections);
for sectionIndex := 0 to Pred(sections.Count) do
if SameTextS(sections[sectionIndex], CollectionItemNamePrefix) then
DeleteSection(sections[sectionIndex]);
finally
FreeAndNil(sections);
end;
end;
procedure TX2CustomPersistFiler.WriteCollection(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
Write(ACollection.Items[itemIndex]);
finally
EndSection;
end;
end;
end;
function TX2CustomPersistFiler.WriteStream(const AName: String; AStream: TStream): Boolean;
var
data: String;
begin
Result := True;
AStream.Position := 0;
SetLength(data, AStream.Size);
AStream.ReadBuffer(PChar(data)^, AStream.Size);
WriteString(AName, data);
end;
function TX2CustomPersistFiler.ReadVariant(const AName: string; out AValue: Variant): Boolean;
var
stringValue: string;
begin
AValue := Unassigned;
Result := ReadString(AName, stringValue);
if Result then
AValue := stringValue;
end;
function TX2CustomPersistFiler.WriteVariant(const AName, AValue: Variant): Boolean;
begin
Result := WriteString(AName, AValue);
end;
{ TX2PersistSectionFilerProxy }
constructor TX2PersistSectionFilerProxy.Create(const AFiler: IX2PersistFiler; const ASection: String);
var
sections: TSplitArray;
sectionIndex: Integer;
undoIndex: Integer;
begin
inherited Create;
FFiler := AFiler;
Split(ASection, SectionSeparator, sections);
FSectionCount := 0;
for sectionIndex := Low(sections) to High(sections) do
begin
if Length(sections[sectionIndex]) > 0 then
begin
if not Filer.BeginSection(sections[sectionIndex]) then
begin
{ Undo all sections so far }
for undoIndex := 0 to Pred(SectionCount) do
Filer.EndSection;
FFiler := nil;
Break;
end else
Inc(FSectionCount);
end;
end;
end;
destructor TX2PersistSectionFilerProxy.Destroy;
var
sectionIndex: Integer;
begin
if Assigned(Filer) then
for sectionIndex := 0 to Pred(SectionCount) do
Filer.EndSection;
inherited;
end;
function TX2PersistSectionFilerProxy.QueryInterface(const IID: TGUID; out Obj): HResult;
var
filerInterface: IInterface;
begin
if Assigned(Filer) then
begin
{ Only return interfaces supported by the filer
- see TX2CustomPersistFiler.QueryInterface }
if Filer.QueryInterface(IID, filerInterface) = S_OK then
{ ...but always return the proxy version of the interface to prevent
issues with reference counting. }
Result := inherited QueryInterface(IID, Obj)
else
Result := E_NOINTERFACE;
end else
Result := inherited QueryInterface(IID, Obj);
end;
function TX2PersistSectionFilerProxy.BeginSection(const AName: String): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := Filer.BeginSection(AName);
end;
procedure TX2PersistSectionFilerProxy.EndSection;
begin
if Assigned(Filer) then
Filer.EndSection;
end;
procedure TX2PersistSectionFilerProxy.GetKeys(const ADest: TStrings);
begin
if Assigned(Filer) then
Filer.GetKeys(ADest);
end;
procedure TX2PersistSectionFilerProxy.GetSections(const ADest: TStrings);
begin
if Assigned(Filer) then
Filer.GetSections(ADest);
end;
function TX2PersistSectionFilerProxy.Read(AObject: TObject): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistReader).Read(AObject);
end;
function TX2PersistSectionFilerProxy.ReadBoolean(const AName: string; out AValue: Boolean): Boolean;
begin
Result := False;
AValue := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistReader).ReadBoolean(AName, AValue);
end;
function TX2PersistSectionFilerProxy.ReadInteger(const AName: String; out AValue: Integer): Boolean;
begin
Result := False;
AValue := 0;
if Assigned(Filer) then
Result := (Filer as IX2PersistReader).ReadInteger(AName, AValue);
end;
function TX2PersistSectionFilerProxy.ReadFloat(const AName: String; out AValue: Extended): Boolean;
begin
Result := False;
AValue := 0;
if Assigned(Filer) then
Result := (Filer as IX2PersistReader).ReadFloat(AName, AValue);
end;
function TX2PersistSectionFilerProxy.ReadString(const AName: String; out AValue: String): Boolean;
begin
Result := False;
AValue := '';
if Assigned(Filer) then
Result := (Filer as IX2PersistReader).ReadString(AName, AValue);
end;
function TX2PersistSectionFilerProxy.ReadInt64(const AName: String; out AValue: Int64): Boolean;
begin
Result := False;
AValue := 0;
if Assigned(Filer) then
Result := (Filer as IX2PersistReader).ReadInt64(AName, AValue);
end;
function TX2PersistSectionFilerProxy.ReadStream(const AName: String; AStream: TStream): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistReader).ReadStream(AName, AStream);
end;
function TX2PersistSectionFilerProxy.ReadVariant(const AName: string; out AValue: Variant): Boolean;
var
reader2: IX2PersistReader2;
begin
Result := False;
if Assigned(Filer) and Supports(Filer, IX2PersistReader2, reader2) then
Result := reader2.ReadVariant(AName, AValue);
end;
procedure TX2PersistSectionFilerProxy.Write(AObject: TObject);
begin
if Assigned(Filer) then
(Filer as IX2PersistWriter).Write(AObject);
end;
function TX2PersistSectionFilerProxy.WriteBoolean(const AName: String; AValue: Boolean): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistWriter).WriteBoolean(AName, AValue);
end;
function TX2PersistSectionFilerProxy.WriteInteger(const AName: String; AValue: Integer): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistWriter).WriteInteger(AName, AValue);
end;
function TX2PersistSectionFilerProxy.WriteFloat(const AName: String; AValue: Extended): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistWriter).WriteFloat(AName, AValue);
end;
function TX2PersistSectionFilerProxy.WriteString(const AName, AValue: String): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistWriter).WriteString(AName, AValue);
end;
function TX2PersistSectionFilerProxy.WriteVariant(const AName, AValue: Variant): Boolean;
var
writer2: IX2PersistWriter2;
begin
Result := False;
if Assigned(Filer) and Supports(Filer, IX2PersistWriter2, writer2) then
Result := writer2.WriteVariant(AName, AValue);
end;
function TX2PersistSectionFilerProxy.WriteInt64(const AName: String; AValue: Int64): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistWriter).WriteInt64(AName, AValue);
end;
function TX2PersistSectionFilerProxy.WriteStream(const AName: String; AStream: TStream): Boolean;
begin
Result := False;
if Assigned(Filer) then
Result := (Filer as IX2PersistWriter).WriteStream(AName, AStream);
end;
procedure TX2PersistSectionFilerProxy.DeleteKey(const AName: String);
begin
if Assigned(Filer) then
(Filer as IX2PersistWriter).DeleteKey(AName);
end;
procedure TX2PersistSectionFilerProxy.DeleteSection(const AName: String);
begin
if Assigned(Filer) then
(Filer as IX2PersistWriter).DeleteSection(AName);
end;
end.