x2utils/X2UtPersist.pas

{
  :: 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;
  end;


implementation
uses
  SysUtils,

  X2UtStrings;


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)
  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);
  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;

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
              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(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
              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;


{ 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;


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