{***************************************************************************}
{ TMS IntraWeb Component Pack Pro                                           }
{ for Delphi & C++Builder                                                   }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright © 2002 - 2007                                        }
{            Email : info@tmssoftware.com                                   }
{            Web : http://www.tmssoftware.com                               }
{                                                                           }
{ The source code is given as is. The author is not responsible             }
{ for any possible damage done due to the use of this code.                 }
{ The component can be freely used in any application. The complete         }
{ source code remains property of the author and may not be distributed,    }
{ published, given or sold in any form as such. No parts of the source      }
{ code can be included in any other component or application without        }
{ written authorization of the author.                                      }
{***************************************************************************}

unit IWPropPersist;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, TypInfo, INIFiles, Dialogs;


type
  TIWPropertyPersister = class(TComponent)
  private
    FIgnoreProperties: TStrings;
    FComponent: TComponent;
    procedure SetIgnoreProperties(const Value: TStrings);
  protected
    procedure LoadRTTIComponent(AReader: TReader; const Value: TPersistent; Position: Boolean);
    procedure SaveRTTIComponent(AWriter: TWriter; const Value: TPersistent; Position: Boolean);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure IniLoadRTTIComponent(AINIFile: TIniFile; const Value: TPersistent; Position: Boolean);
    procedure IniSaveRTTIComponent(AINIFile: TIniFile; const Value: TPersistent; Position: Boolean);

    procedure StoreProperties(AComponent: TComponent; AStream: TStream; Position: Boolean);
    procedure RestoreProperties(AComponent:TComponent; AStream: TStream; Position: Boolean);

    procedure StorePropertiesToFile(AComponent: TComponent; FileName: string);
    procedure RestorePropertiesToFile(AComponent:TComponent; FileName: string);
  published
    property Component: TComponent read FComponent write FComponent;
    property IgnoreProperties: TStrings read FIgnoreProperties write SetIgnoreProperties;
  end;

implementation

function IsReadAndWriteProp(AInstance: TObject; const APropName:string): Boolean;
begin
  with GetPropInfo(AInstance, APropName)^ do
    Result := (SetProc <> nil) and (GetProc <> nil);
end;

function GetSetPropModified(Instance: TObject; PropInfo: PPropInfo): string;
{Modified GetSetProp routine from TypInfo}
var
  S: TIntegerSet;
  TypeInfo: PTypeInfo;
  I: Integer;
begin
  Result:='';
  Integer(S) := GetOrdProp(Instance, PropInfo);
  TypeInfo := GetTypeData(PropInfo^.PropType^)^.CompType^;
  for I := 0 to SizeOf(Integer) * 8 - 1 do
    if I in S then
    begin
      if Result <> '' then
        Result := Result + ',';
      Result := Result + GetEnumName(TypeInfo, I);
    end;
end;

{ TIWPropertyPersister }

procedure TIWPropertyPersister.SaveRTTIComponent(AWriter: TWriter; const Value: TPersistent; Position: Boolean);

  procedure AddProps(AObject: TObject; TypeInfo: PTypeInfo; Level: Integer);
  var
    i,Count: Integer;
    PropList: PPropList;
    SubClass: TClass;
    SubObject: TObject;
    s,propname:string;

  begin
    Count := GetPropList(TypeInfo,tkProperties,nil);
    GetMem(PropList, Count * SizeOf(PPropInfo));
    try
      GetPropList(TypeInfo, tkProperties, PropList);
      for I := 1 to Count do
      begin
        s := string(PropList^[I - 1].PropType^.Name);
        propName := string(PropList^[I - 1]^.Name);

        {$IFDEF TMSDEBUG}
        outputdebugstring(pchar(propname + ': '+s));
        {$ENDIF}

        if IsReadAndWriteProp(AObject,propName) and
          not ((propname = 'Name') and (AObject = Value)) and
          not ((IgnoreProperties.IndexOf(PropName) <> -1) and (AObject = Value)) then
        begin

          case PropList^[I - 1].PropType^.Kind of
          tkFloat:
             AWriter.WriteFloat(GetFloatProp(AObject,PropList^[I - 1]));

          tkInteger,
          tkWChar,
          tkChar:
             AWriter.WriteInteger(GetOrdProp(AObject,PropList^[I - 1]));

          tkString,
          tkLString,
          tkWString:
             AWriter.WriteString(GetStrProp(AObject, PropList^[I - 1]));

          tkEnumeration:
            AWriter.WriteString(GetEnumProp(AObject, PropList^[I - 1]));

          tkSet:
            AWriter.WriteString(GetSetPropModified(AObject,PropList^[I - 1]));
          end;

          if PropList^[I - 1].PropType^.Kind in [tkClass] then
          begin
             SubClass := GetTypeData(PropList^[I - 1].PropType^).ClassType;
             SubObject := TObject(GetOrdProp(AObject,string(PropList^[I - 1].Name)));
             if Assigned(SubObject) then
               AddProps(SubObject,SubClass.ClassInfo,Level + 1);
          end;
        end;
      end;
    finally
      FreeMem(PropList);
    end;
  end;

begin
  AWriter.WriteString(Value.ClassName);
  AddProps(Value,Value.ClassInfo,0);
end;


procedure TIWPropertyPersister.IniSaveRTTIComponent(AIniFile: TIniFile; const Value: TPersistent; Position: Boolean);

  procedure AddProps(AObject: TObject;BasePropName: string; TypeInfo: PTypeInfo; Level: Integer);
  var
    i,Count: Integer;
    PropList: PPropList;
    SubClass: TClass;
    SubObject: TObject;
    s,propname:string;
    TypeData : PTypeData;

  begin
    Count := GetPropList(TypeInfo,tkProperties,nil);
    GetMem(PropList, Count * SizeOf(PPropInfo));
    try
      GetPropList(TypeInfo, tkProperties, PropList);
      for I := 1 to Count do
      begin
        s := string(PropList^[I - 1].PropType^.Name);
        propName := string(PropList^[I - 1]^.Name);

        {$IFDEF TMSDEBUG}
        outputdebugstring(pchar(propname + ': '+s));
        {$ENDIF}

        if IsReadAndWriteProp(AObject,propName) and
          not ((propname = 'Name') and (AObject = Value)) and
          not ((IgnoreProperties.IndexOf(PropName) <> -1) and (AObject = Value)) then
        begin

          case PropList^[I - 1].PropType^.Kind of
          tkFloat:
             AIniFile.WriteString(BasePropName + string(TypeInfo.Name) , string(PropName),Format('%g',[GetFloatProp(AObject,PropList^[I - 1])]));

          tkInteger,
          tkWChar,
          tkChar:
             AIniFile.WriteInteger(BasePropName + string(TypeInfo.Name), string(PropName),GetOrdProp(AObject,PropList^[I - 1]));

          tkString,
          {$IFDEF DELPHI_UNICODE}
          tkUString,
          {$ENDIF}
          tkLString,
          tkWString:
             AIniFile.WriteString(BasePropName + string(TypeInfo.Name),string(PropName),GetStrProp(AObject, PropList^[I - 1]));

          tkEnumeration:
            begin
              TypeData := GetTypeData(PropList^[I - 1].PropType^);
              AIniFile.WriteString(BasePropName + string(TypeInfo.Name),string(PropName),GetEnumName(TypeData.BaseType^, GetOrdProp(AObject,string(PropList^[I - 1].Name))));
            end;  

          tkSet:
            AIniFile.WriteString(BasePropName + string(TypeInfo.Name),string(PropName),GetSetPropModified(AObject,PropList^[I - 1]));
          end;

          if PropList^[I - 1].PropType^.Kind in [tkClass] then
          begin
             SubClass := GetTypeData(PropList^[I - 1].PropType^).ClassType;
             SubObject := TObject(GetOrdProp(AObject,string(PropList^[I - 1].Name)));
             if Assigned(SubObject) then
             begin
               AddProps(SubObject,BasePropName + string(PropName) + '_',SubClass.ClassInfo,Level + 1);
             end;  
          end;
        end;
      end;
    finally
      FreeMem(PropList);
    end;
  end;
                           
begin
  AddProps(Value,'',Value.ClassInfo,0);
end;


procedure TIWPropertyPersister.LoadRTTIComponent(AReader: TReader; const Value: TPersistent; Position: Boolean);

  procedure LoadProps(AObject: TObject; TypeInfo: PTypeInfo; Level: Integer);
  var
    i,Count: Integer;
    PropList: PPropList;
    SubClass: TClass;
    SubObject: TObject;
    s,propname:string;
  begin
    Count := GetPropList(TypeInfo,tkProperties,nil);
    GetMem(PropList, Count * SizeOf(PPropInfo));
    try
      GetPropList(TypeInfo, tkProperties, PropList);
      for I := 1 to Count do
      begin
        s := string(PropList^[I - 1].PropType^.Name);
        propName := string(PropList^[I - 1]^.Name);

        {$IFDEF TMSDEBUG}
        outputdebugstring(pchar('read:'+propname + ': '+s));
        {$ENDIF}

        if IsReadAndWriteProp(AObject,propName) and
          not ((propname = 'Name') and (AObject = Value)) and
          not ((IgnoreProperties.IndexOf(PropName) <> -1) and (AObject = Value)) then
        begin

          case PropList^[I - 1].PropType^.Kind of

          tkFloat:       SetFloatProp(AObject, PropList^[I - 1],
                         AReader.ReadFloat);

          tkInteger,
          tkChar,
          tkWChar:       SetOrdProp(AObject, PropList^[I - 1],
                         AReader.ReadInteger);

          tkString,
          {$IFDEF DELPHI_UNICODE}
          tkUString,
          {$ENDIF}
          tkLString,
          tkWString:     SetStrProp(AObject, PropList^[I - 1],
                         AReader.ReadString);

          tkEnumeration: SetEnumProp(AObject, PropList^[I - 1],
                         AReader.ReadString);

          tkSet:         SetSetProp(AObject, PropList^[I - 1],
                         AReader.ReadString);
          end;

          if PropList^[I - 1].PropType^.Kind in [tkClass] then
          begin
             SubClass := GetTypeData(PropList^[I - 1].PropType^).ClassType;
             SubObject := TObject(GetOrdProp(AObject, string(PropList^[I - 1].Name)));
             if Assigned(SubObject) then
               LoadProps(SubObject,SubClass.ClassInfo,Level + 1);
          end;
        end;
      end;
    finally
      FreeMem(PropList);
    end;
  end;

begin
  if AReader.ReadString <> Value.ClassName then
    raise Exception.Create('Class preferences of different class')
  else
    LoadProps(Value,Value.ClassInfo,0);
end;

procedure TIWPropertyPersister.IniLoadRTTIComponent(AIniFile: TIniFile; const Value: TPersistent; Position: Boolean);

  procedure LoadProps(AObject: TObject;BasePropName:string; TypeInfo: PTypeInfo; Level: Integer);
  var
    i,Count: Integer;
    PropList: PPropList;
    SubClass: TClass;
    SubObject: TObject;
    s,propname:string;
    pval: string;
  begin
    Count := GetPropList(TypeInfo,tkProperties,nil);
    GetMem(PropList, Count * SizeOf(PPropInfo));
    try
      GetPropList(TypeInfo, tkProperties, PropList);
      for I := 1 to Count do
      begin
        s := string(PropList^[I - 1].PropType^.Name);
        propName := string(PropList^[I - 1]^.Name);

        pval := AINIFile.ReadString(BasePropName + string(TypeInfo.Name), string(PropName),'');

        //showmessage(BasePropName + TypeInfo.Name+#13+PropName+#13+pval);

        {$IFDEF TMSDEBUG}
        outputdebugstring(pchar('read:'+propname + ': '+s));
        {$ENDIF}

        if IsReadAndWriteProp(AObject,propName) and
          not ((propname = 'Name') and (AObject = Value)) and
          not ((IgnoreProperties.IndexOf(PropName) <> -1) and (AObject = Value)) then
        begin
          if (pval <> '') then
          begin
            case PropList^[I - 1].PropType^.Kind of
            tkFloat:
              begin
                s := AINIFile.ReadString(BasePropName + string(TypeInfo.Name), string(PropName),'0');
                SetFloatProp(AObject, PropList^[I - 1], StrToFloat(s));
              end;

            tkInteger,
            tkChar,
            tkWChar:
               SetOrdProp(AObject, PropList^[I - 1], AINIFile.ReadInteger(BasePropName + string(TypeInfo.Name), string(PropName),0) );

            tkString,
            tkLString,
            tkWString:
              SetStrProp(AObject, PropList^[I - 1], AINIFile.ReadString(BasePropName + string(TypeInfo.Name),PropName,''));

            tkEnumeration:
              SetEnumProp(AObject, PropList^[I - 1],AINIFile.ReadString(BasePropName + string(TypeInfo.Name),PropName,''));

            tkSet:
              SetSetProp(AObject, PropList^[I - 1],AINIFile.ReadString(BasePropName + string(TypeInfo.Name),PropName,''));
            end;
          end;
          
          if PropList^[I - 1].PropType^.Kind in [tkClass] then
          begin
             SubClass := GetTypeData(PropList^[I - 1].PropType^).ClassType;
             SubObject := TObject(GetOrdProp(AObject,string(PropList^[I - 1].Name)));
             if Assigned(SubObject) then
               LoadProps(SubObject,BasePropName + PropName + '_',SubClass.ClassInfo,Level + 1);
          end;
        end;
      end;
    finally
      FreeMem(PropList);
    end;
  end;

begin
  LoadProps(Value,'',Value.ClassInfo,0);
end;




constructor TIWPropertyPersister.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIgnoreProperties := TStringList.Create;
  FIgnoreProperties.Add('Top');
  FIgnoreProperties.Add('Left');
  FIgnoreProperties.Add('Width');
  FIgnoreProperties.Add('Height');
  FIgnoreProperties.Add('Tag');
  FIgnoreProperties.Add('TabOrder');
  FIgnoreProperties.Add('TabStop');
  FIgnoreProperties.Add('Cursor');
  FIgnoreProperties.Add('ExtraTagParams');
  FIgnoreProperties.Add('Anchors');
  FIgnoreProperties.Add('Cursor');  
  FIgnoreProperties.Add('Align');
  FIgnoreProperties.Add('Name');
  FIgnoreProperties.Add('DataSource');
  FIgnoreProperties.Add('DataField');
end;

destructor TIWPropertyPersister.Destroy;
begin
  FIgnoreProperties.Free;
  inherited;
end;

procedure TIWPropertyPersister.RestoreProperties(AComponent: TComponent;
  AStream: TStream; Position: Boolean);
var
  reader: TReader;
begin
  reader := TReader.Create(AStream, $FF);
  try
    reader.ReadListBegin;
    LoadRTTIComponent(reader,AComponent, Position);
    reader.ReadListEnd;
  finally
    reader.Free;
  end;
end;

procedure TIWPropertyPersister.RestorePropertiesToFile(
  AComponent: TComponent; FileName: string);
var
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  ms.LoadFromFile(FileName);
  ReStoreProperties(AComponent,ms,false);
  ms.Free;
end;

procedure TIWPropertyPersister.SetIgnoreProperties(const Value: TStrings);
begin
  FIgnoreProperties.Assign(Value);
end;

procedure TIWPropertyPersister.StoreProperties(AComponent: TComponent;
  AStream: TStream; Position: Boolean);
var
  writer: TWriter;
begin
  writer := TWriter.Create(AStream, $FF);
  try
    writer.WriteListBegin;
    SaveRTTIComponent(writer,AComponent, Position);
    writer.WriteListEnd;
  finally
    writer.Free;
  end;
end;

procedure TIWPropertyPersister.StorePropertiesToFile(AComponent: TComponent;
  FileName: string);
var
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  StoreProperties(AComponent,ms,false);
  ms.SaveToFile(FileName);
  ms.Free;
end;

end.


