propfilereh.pas

自己做的用delphi开发的学生成绩管理系统。

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

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

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

interface

uses
{$IFDEF EH_LIB_CLX}
  Types, QForms, QGraphics, QControls,
{$ELSE}
  Windows, Forms, Controls,
{$ENDIF}
  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: Pointer): 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: Pointer);
  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};

type
  TComponentCrack = class(TComponent) end;

  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
  FChildList := TStringList.Create;
end;

destructor TForChildListObj.Destroy;
begin
  FChildList.Free;
end;

procedure TForChildListObj.GetChildList(ParentComp, Root: TComponent; cl: TStrings);
begin
  FChildList.Clear;
  TComponentCrack(ParentComp).GetChildren(GetChildProc, Root);
  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
  TPersistentCrack = class(TPersistent) end;
  PMethod = ^TMethod;
  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;

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] = Target) then
      UnregisterReadPropertyInterceptor(Target, InterceptorList[i]);
  InterceptorList.Add(Interceptor);
  TargetList.Add(Target);
end;

procedure UnregisterReadPropertyInterceptor(Target: TClass; Interceptor: TReadPropertyInterceptorClass);
var
  i: Integer;
begin
  for i:= TargetList.Count - 1 downto 0 do
    if (TargetList[i] = Target) and (InterceptorList[i] = 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 := InterceptorList[i];
      end;
    end;
  end;
end;

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

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;

{ 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
    Dispose(Pointer(FDefnPropList.Objects[i]));
  FDefnPropList.Free;
  for i := 0 to FDefnBinPropList.Count-1 do
    Dispose(Pointer(FDefnBinPropList.Objects[i]));
  FDefnBinPropList.Free;
  FLastRootsList.Free;
  FCurRootsList.Free;
  inherited Destroy;
end;

procedure TPropWriterEh.BuildPropsList(AObject: TObject; sl: TStrings);
var
  PropList: PPropList;
  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);
  for i := 0 to PropCount - 1 do
  begin
    if PropList^[i].PropType^.Kind = tkClass then
    begin
      SubO := TObject(GetOrdProp(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
      then CompName := Copy(Path, 1, PPos-1)
      else raise Exception.Create('Component name is empty.');
    Delete(Path, 1, PPos);
    if CompName = '<P>' then
      SaveObjectProperyValue(Owner, Path, PropList[i]);

    FLastRootsList.Clear;
    FLastRootsList.Capacity := FCurRootsList.Capacity;
    for j := 0 to FCurRootsList.Count - 1 do
      FLastRootsList.Add(FCurRootsList[j]);

//    FLastRootsList.Assign(FCurRootsList);
    FCurRootsList.Clear;

  end;

  if Assigned(OnWriteOwnerProps) then
    OnWriteOwnerProps(Self);

  WriteListEnd;

  //Write Owned components
  for i := 0 to PropList.Count-1 do