{*******************************************************}
{                                                       }
{    Delphi / Kylix Cross-Platform Runtime Library      }
{                                                       }
{                     EhLib v4.2.1                      }
{                                                       }
{          TPropWriter, TPropReader objects             }
{                                                       }
{   Copyright (c) 2002-2006 by Dmitry V. Bolshakov      }
{                                                       }
{*******************************************************}

{$I EhLib.Inc}
//{$I EhLibClx.Inc}

{$IFDEF EH_LIB_CLX}
unit QPropFilerEh;
{$ELSE}
unit PropFilerEh {$IFDEF CIL} platform {$ENDIF};
{$ENDIF}

interface

uses
{$IFDEF EH_LIB_CLX}
  Types, QForms, QGraphics, QControls,
{$ELSE}
  Windows, Forms, Controls,
  {$IFDEF EH_LIB_6} Variants, Types, {$ENDIF}

{$IFDEF CIL}
  EhLibVCLNET,
  System.Runtime.InteropServices, System.Reflection,
{$ELSE}
  EhLibVCL,
{$ENDIF}

{$ENDIF} //$ELSE EH_LIB_CLX
  SysUtils, Classes, TypInfo;

type
  TPropWriterEh = class;
  TPropReaderEh = class;

  TWriteOwnerPropsEventEh = procedure(Writer: TPropWriterEh) of object;
  TReadOwnerPropEventEh = procedure(Reader: TPropReaderEh; PropName: String;
    var Processed: Boolean) of object;

 {TPropWriterEh}

  TPropWriterEh = class(TWriter)
  private
    FCurRootsList: TList;
    FDefnBinPropList: TStringList;
    FDefnPropList: TStringList;
    FInterceptorList: TList;
    FLastRootsList: TList;
//    FLookupRoot: TComponent;
    FPropPath: String;
    FOnWriteOwnerProps: TWriteOwnerPropsEventEh;
    procedure BuildPropsList(AObject: TObject; sl: TStrings);
  protected
    procedure WriteAllProperties(Instance: TObject);
  public
    constructor Create(Stream: TStream; BufSize: Integer);
    destructor Destroy; override;
    procedure WritePropName(const PropName: string);
    procedure DefineBinaryProperty(const Name: string; ReadData, WriteData: TStreamProc; HasData: Boolean); override;
    procedure DefineObjectProperties(Instance: TObject);
    procedure DefineProperty(const Name: string; ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean); override;
    procedure SaveObjectProperyValue(Instance: TObject; Path, FullPath: String);
    procedure WriteCollection(Value: TCollection);
    procedure WriteOwnerProperties(Owner: TComponent; PropList: TStrings);
    property OnWriteOwnerProps: TWriteOwnerPropsEventEh read FOnWriteOwnerProps write FOnWriteOwnerProps;
  end;

 {TPropReaderEh}

  TPropReaderEh = class(TReader)
  private
    FCanHandleExcepts: Boolean;
    FCollectionList: TList;
    FInterceptorList: TList;
    FPropName: String;
    FOnReadOwnerProp: TReadOwnerPropEventEh;
    function ReadSet(SetType: PTypeInfo): Integer;
    procedure SkipSetBody;
{$IFNDEF EH_LIB_5}
    procedure SkipValue;
    procedure SkipProperty;
    procedure PropertyError;
{$ENDIF}
  protected
    function Error(const Message: string): Boolean; override;
    procedure ReadCollection(Collection: TCollection);
    procedure ReadProperty(AInstance: TPersistent);
    procedure ReadPropValue(Instance: TPersistent; PropInfo: PPropInfo);
  public
    constructor Create(Stream: TStream; BufSize: Integer);
    destructor Destroy; override;
    procedure DefineBinaryProperty(const Name: string; ReadData,
      WriteData: TStreamProc; HasData: Boolean); override;
    procedure DefineProperty(const Name: string; ReadData: TReaderProc;
      WriteData: TWriterProc; HasData: Boolean); override;
    procedure ReadComponent(Component: TComponent);
    procedure ReadOwnerProperties(Component: TComponent);
    property OnReadOwnerProp: TReadOwnerPropEventEh read FOnReadOwnerProp write FOnReadOwnerProp;
  end;

{ TStoragePropertyInterceptor }

  TStoragePropertyInterceptor = class(TPersistent)
    FTarget: TObject;
  public
    constructor Create(ATarget: TObject); virtual;
    function NeedIntercept: Boolean; virtual;
    procedure Readed; virtual;
    property Target: TObject read FTarget;
  end;

{ TFormStoragePropertyInterceptor }

  TFormStoragePropertyInterceptor = class(TStoragePropertyInterceptor)
  private
    FActiveControl: TWinControl;
    FHeight: Integer;
    FLeft: Integer;
    FPixelsPerInch: Integer;
    FPosPresent: Boolean;
    FTop: Integer;
    FWidth: Integer;
    FWindowState: TWindowState;
    function GetHeight: Integer;
    function GetLeft: Integer;
    function GetTop: Integer;
    function GetWidth: Integer;
    procedure SetLeft(const Value: Integer);
    procedure SetTop(const Value: Integer);
  public
    constructor Create(ATarget: TObject); override;
    procedure Readed; override;
    function GetNotmalFormPlacement: TRect;
  published
    property ActiveControl: TWinControl write FActiveControl;
    property Height: Integer read GetHeight write FHeight;
    property Left: Integer read GetLeft write SetLeft;
    property PixelsPerInch: Integer write FPixelsPerInch;
    property Top: Integer read GetTop write SetTop;
    property Width: Integer read GetWidth write FWidth;
    property WindowState: TWindowState write FWindowState;
  end;

  TReadPropertyInterceptorClass = class of TStoragePropertyInterceptor;

  procedure RegisterReadPropertyInterceptor(Target: TClass; Interceptor: TReadPropertyInterceptorClass);
  procedure UnregisterReadPropertyInterceptor(Target: TClass; Interceptor: TReadPropertyInterceptorClass);
  function GetInterceptorForTarget(Target: TClass): TReadPropertyInterceptorClass;

  function GetNextPointSeparatedToken(Path: String): String;

  procedure GetComponentChildListEh(ParentComp, Root: TComponent; cl: TStrings; CheckInline: Boolean);
  function FindChildComponent(ParentComp, Root: TComponent; const AName: string; CheckInline: Boolean): TComponent;

var
  IsRaiseReadErrorEh: Boolean = False;

implementation

uses {$IFDEF EH_LIB_6} ConvUtils, RTLConsts {$ELSE} Consts {$ENDIF};

{$IFDEF CIL}

function CanRead(APropInfo: TPropInfo): Boolean;
begin
  Result := Borland.Vcl.TypInfo.CanRead(APropInfo);
end;

function CanWrite(APropInfo: TPropInfo): Boolean;
begin
  Result := Borland.Vcl.TypInfo.CanWrite(APropInfo);
end;

{$ELSE}

function CanRead(APropInfo: PPropInfo): Boolean;
begin
  Result := APropInfo^.GetProc <> nil;
end;

function CanWrite(APropInfo: PPropInfo): Boolean;
begin
  Result := APropInfo^.SetProc <> nil;
end;

{$ENDIF}

type

  TForChildListObj = class(TObject)
  private
    FChildList: TStringList;
    procedure GetChildList(ParentComp, Root: TComponent; cl: TStrings);
    procedure GetChildProc(Child: TComponent);
  public
    constructor Create;
    destructor Destroy; override;
  end;

constructor TForChildListObj.Create;
begin
  inherited Create;
  FChildList := TStringList.Create;
end;

destructor TForChildListObj.Destroy;
begin
  FreeAndNil(FChildList);
end;

procedure TForChildListObj.GetChildList(ParentComp, Root: TComponent; cl: TStrings);
var
  FilerAccess: TFilerAccess;
begin
  FChildList.Clear;
  FilerAccess := TFilerAccess.Create(ParentComp);
  FilerAccess.GetChildren(GetChildProc, Root);
  FilerAccess.Free;
  cl.Assign(FChildList);
end;

procedure TForChildListObj.GetChildProc(Child: TComponent);
begin
  FChildList.AddObject(Child.Name, Child);
end;

var
  ForChildListObj: TForChildListObj;

procedure GetComponentChildListEh(ParentComp, Root: TComponent; cl: TStrings; CheckInline: Boolean);
begin
  if ForChildListObj = nil then
    ForChildListObj := TForChildListObj.Create;

{$IFDEF EH_LIB_5}
  if CheckInline and (csInline in ParentComp.ComponentState) then
    ForChildListObj.GetChildList(ParentComp, ParentComp, cl)
  else
{$ENDIF}
  if CheckInline and (ParentComp <> Root) then
    ForChildListObj.GetChildList(ParentComp, ParentComp.Owner, cl)
  else
    ForChildListObj.GetChildList(ParentComp, Root, cl);
end;

function FindChildComponent(ParentComp, Root: TComponent; const AName: string; CheckInline: Boolean): TComponent;
var
  ChildList: TStringList;
  Idx: Integer;
begin
  ChildList := TStringList.Create;
  try
    GetComponentChildListEh(ParentComp, Root, ChildList, CheckInline);

    Idx := ChildList.IndexOf(AName);
    if Idx > -1
      then Result := TComponent(ChildList.Objects[Idx])
      else Result := nil;

  finally
    ChildList.Free;
  end;
end;

function GetNextPointSeparatedToken(Path: String): String;
var
  PPos: Integer;
begin
  PPos := Pos('.', Path);
  if PPos > 0
    then Result := Copy(Path, 1, PPos-1)
    else Result := Path;
end;

type
//  PMethod = ^TMethod;
  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;

  TMethodObj = class(TObject)
  private
    FMethod: TMethod;
  public
    property Method: TMethod read FMethod write FMethod;
  end;

  TStreamProcObj = class(TObject)
  private
    FMethod: TStreamProc;
  public
    property Method: TStreamProc read FMethod write FMethod;
  end;


var
  InterceptorList: TList;
  TargetList: TList;

procedure RegisterReadPropertyInterceptor(Target: TClass; Interceptor: TReadPropertyInterceptorClass);
var
  i: Integer;
begin
  if InterceptorList = nil then
  begin
    InterceptorList := TList.Create;
    TargetList := TList.Create;
  end;
  for i:= TargetList.Count - 1 downto 0 do
    if (TargetList[i] = TObject(Target)) then
      UnregisterReadPropertyInterceptor(Target, TReadPropertyInterceptorClass(InterceptorList[i]));
  InterceptorList.Add(TObject(Interceptor));
  TargetList.Add(TObject(Target));
end;

procedure UnregisterReadPropertyInterceptor(Target: TClass; Interceptor: TReadPropertyInterceptorClass);
var
  i: Integer;
begin
  for i:= TargetList.Count - 1 downto 0 do
    if (TargetList[i] = TObject(Target)) and (InterceptorList[i] = TObject(Interceptor)) then
    begin
      InterceptorList.Delete(i);
      TargetList.Delete(i);
    end;
end;

function GetInterceptorForTarget(Target: TClass): TReadPropertyInterceptorClass;

  function GetClassDeep(Target: TClass; ClassName: String): Integer;
  var
    ParentTarget: TClass;
  begin
    Result := 0;
    ParentTarget := Target;
    while True do
    begin
      if UpperCase(ParentTarget.ClassName) = UpperCase(ClassName) then
        Exit;
      Inc(Result);
      ParentTarget := ParentTarget.ClassParent;
      if ParentTarget = nil then
      begin
        Result := MAXINT;
        Exit;
      end;
    end;
  end;

var
  Deep, MeenDeep, i: Integer;
begin
  Result := nil;
  if TargetList = nil then Exit;
  MeenDeep := MAXINT;
  for i := 0 to TargetList.Count - 1 do
  begin
    if Target.InheritsFrom(TClass(TargetList[i])) then
    begin
      Deep := GetClassDeep(Target, TClass(TargetList[i]).ClassName);
      if Deep < MeenDeep then
      begin
        MeenDeep := Deep;
        Result := TReadPropertyInterceptorClass(InterceptorList[i]);
      end;
    end;
  end;
end;

function SameText(const S1, S2: string): Boolean;
begin
  Result := (CompareText(S1, S2) = 0)
end;


{$IFNDEF EH_LIB_5}

function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent;
var
  Current, Found: TComponent;
  S, P: PChar;
  Name: string;
begin
  Result := nil;
  if NamePath = '' then Exit;
  Current := Root;
  P := PChar(Pointer(NamePath));
  while P^ <> #0 do
  begin
    S := P;
    while not (P^ in ['.', '-', #0]) do Inc(P);
    SetString(Name, S, P - S);
    Found := Current.FindComponent(Name);
    if (Found = nil) and SameText(Name, 'Owner') then  { Do not translate }
      Found := Current;
    if Found = nil then Exit;
    if P^ = '.' then Inc(P);
    if P^ = '-' then Inc(P);
    if P^ = '>' then Inc(P);
    Current := Found;
  end;
  Result := Current;
end;

{$ENDIF}

{ TPropWriterEh }

constructor TPropWriterEh.Create(Stream: TStream; BufSize: Integer);
begin
  inherited Create(Stream, BufSize);
  FDefnPropList := TStringList.Create;
  FDefnBinPropList := TStringList.Create;
  FLastRootsList := TList.Create;
  FCurRootsList := TList.Create;
end;

destructor TPropWriterEh.Destroy;
var
 i: Integer;
begin
  for i := 0 to FDefnPropList.Count-1 do
    FDefnPropList.Objects[i].Free;
  FreeAndNil(FDefnPropList);
  for i := 0 to FDefnBinPropList.Count-1 do
    FDefnBinPropList.Objects[i].Free;
  FreeAndNil(FDefnBinPropList);
  FreeAndNil(FLastRootsList);
  FreeAndNil(FCurRootsList);
  inherited Destroy;
end;

procedure TPropWriterEh.BuildPropsList(AObject: TObject; sl: TStrings);
var
//  PropList: PPropList;
  PropList: TPropListArray;
//  {PropCount,} FSize: Integer;
  i, j: Integer;
  SubO: TObject;
  subsl: TStrings;
begin
  subsl := TStringList.Create;
{  PropCount := GetPropList(AObject.ClassInfo, tkProperties, nil);
  FSize := PropCount * SizeOf(Pointer);
  GetMem(PropList, FSize);
  GetPropList(AObject.ClassInfo, tkProperties, PropList);}
  PropList := GetPropListAsArray(AObject.ClassInfo, tkProperties);
  for i := 0 to Length(PropList) - 1 do
  begin
    if PropType_getKind(PropInfo_getPropType(PropList[i])) = tkClass then
    begin
      SubO := GetObjectProp(AObject, PropList[i]);
      if Assigned(SubO) then
      begin
        subsl.Clear;
        if not (SubO is TComponent) then
        begin
          BuildPropsList(SubO, subsl);
          for j := 0 to subsl.Count - 1 do
            sl.Add(PropList[i].Name + '.' + subsl[j]);
        end;
        if (SubO is TCollection) then
          sl.Add(PropList[i].Name);
      end;
    end else
      sl.Add(PropList[i].Name);
  end;
//  FreeMem(PropList, FSize);
  subsl.Clear;

  DefineObjectProperties(AObject);
  sl.AddStrings(FDefnPropList);
  sl.AddStrings(FDefnBinPropList);

  subsl.Free;
end;

procedure TPropWriterEh.WriteOwnerProperties(Owner: TComponent; PropList: TStrings);
var
  i, j, Level: Integer;
  Path: String;
  PPos: Integer;
  CompName: String;
  NewComponent, CurOwner: TComponent;
begin
  Root := Owner;
//  FLookupRoot := Root;
  WriteSignature;
  WriteStr(Owner.ClassName);
  WriteStr(Owner.Name);

  FInterceptorList := TList.Create;

  //Write Owner properties
  for i := 0 to PropList.Count-1 do
  begin
    Path := PropList[i];
    PPos := Pos('.', Path);
    if PPos > 0