propfilereh.pas

最新的 DBGRIDEH4.0

          TMethodObj(FDefnPropList.Objects[Index]).Method.Invoke([Self]);
{$ELSE}
          TWriterProc((TMethodObj(FDefnPropList.Objects[Index]).Method))(Self);
{$ENDIF}
        end;
      end else if FDefnBinPropList.IndexOf(PropName) >= 0 then
      begin
        Index := FDefnBinPropList.IndexOf(PropName);
        if Assigned(FDefnBinPropList.Objects[Index]) then
        begin
          WritePropName(PropName);
//{$IFDEF CIL}
//{ DONE : Convert TMethod to delegate }
          WriteBinary(TStreamProcObj(FDefnBinPropList.Objects[Index]).Method);
//{$ELSE}
//          WriteBinary(TStreamProc((TMethodObj(FDefnBinPropList.Objects[Index]).Method)));
//{$ENDIF}
        end;
      end else
        raise Exception.Create('Invalide property name: ' + PropName);
    end else
    begin
      if  CanRead(PropInfo) and
{$IFDEF EH_LIB_6}
       ((CanWrite(PropInfo)) or
       ((PropType_getKind(PropInfo_getPropType(PropInfo)) = tkClass) and
        (GetObjectProp(Instance, PropInfo) is TComponent) and
        (csSubComponent in TComponent(GetObjectProp(Instance, PropInfo)).ComponentStyle))) then
{$ELSE}
        (PPropInfo(PropInfo)^.GetProc <> nil) then
{$ENDIF}
      begin
        PropType := PropInfo_getPropType(PropInfo);
        case PropType_getKind(PropType) of
          tkInteger, tkChar, tkEnumeration, tkSet:
            WriteOrdProp;
          tkFloat:
            WriteFloatProp;
          tkString, tkLString, tkWString:
            WriteStrProp;
          tkClass:
            WriteObjectProp;
          tkMethod:
            WriteMethodProp;
          tkVariant:
            WriteVariantProp;
          tkInt64:
            WriteInt64Prop;
{$IFDEF EH_LIB_6}
          tkInterface:
            WriteInterfaceProp;
{$ENDIF}
        end;
      end;
    end
  end;
end;

procedure TPropWriterEh.WritePropName(const PropName: string);
begin
  WriteStr(FPropPath + PropName);
end;

procedure TPropWriterEh.DefineBinaryProperty(const Name: string; ReadData,
  WriteData: TStreamProc; HasData: Boolean);
var
  Pm: TStreamProcObj;
begin
  Pm := TStreamProcObj.Create;
{$IFDEF CIL}
  Pm.Method := @WriteData;
{$ELSE}
  Pm.Method := WriteData;
//  Pm.Method := TMethod(WriteData);
{$ENDIF}
  FDefnBinPropList.AddObject(Name, Pm);
end;

procedure TPropWriterEh.DefineProperty(const Name: string;
  ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
var
  Pm: TMethodObj;
begin
  Pm := TMethodObj.Create;
{$IFDEF CIL}
  Pm.Method := @WriteData;
{$ELSE}
  Pm.Method := TMethod(WriteData);
{$ENDIF}
  FDefnPropList.AddObject(Name, Pm);
end;

procedure TPropWriterEh.WriteCollection(Value: TCollection);
var
  I: Integer;
  OldAncestor: TPersistent;
begin
  OldAncestor := Ancestor;
  Ancestor := nil;
  try
    WriteValue(vaCollection);
    if Value <> nil then
      for I := 0 to Value.Count - 1 do
      begin
        WriteListBegin;
        WriteAllProperties(Value.Items[I]);
        WriteListEnd;
      end;
    WriteListEnd;
  finally
    Ancestor := OldAncestor;
  end;
end;

procedure TPropWriterEh.WriteAllProperties(Instance: TObject);
var
  I: Integer;
  sl: TStringList;
begin
  sl := TStringList.Create;
  BuildPropsList(Instance, sl);

  for I := 0 to sl.Count - 1 do
    SaveObjectProperyValue(Instance, sl[i], sl[i]);
  sl.Free;
end;

procedure TPropWriterEh.DefineObjectProperties(Instance: TObject);
var
  i: Integer;
  FilerAccess: TFilerAccess;
begin
  for i := 0 to FDefnPropList.Count-1 do
    FDefnPropList.Objects[i].Free;
  FDefnPropList.Clear;
  for i := 0 to FDefnBinPropList.Count-1 do
    FDefnBinPropList.Objects[i].Free;
  FDefnBinPropList.Clear;
  if Instance is TPersistent then
  begin
    FilerAccess := TFilerAccess.Create(TPersistent(Instance));
    FilerAccess.DefineProperties(Self);
    FilerAccess.Free;
  end;
end;

{ TPropReaderEh }

procedure ReadError(const Ident: string);
begin
  raise EReadError.Create(Ident);
end;

procedure PropValueError;
begin
  ReadError(SInvalidPropertyValue);
end;

{$IFNDEF EH_LIB_5}

procedure PropertyNotFound;
begin
  ReadError(SUnknownProperty);
end;

{$ENDIF}

constructor TPropReaderEh.Create(Stream: TStream; BufSize: Integer);
begin
  inherited Create(Stream, BufSize);
  FCollectionList := TList.Create;
end;

destructor TPropReaderEh.Destroy;
begin
  FreeAndNil(FCollectionList);
  inherited Destroy;
end;

procedure TPropReaderEh.ReadComponent(Component: TComponent);
var
  I: Integer;
  Flags: TFilerFlags;
  CompName: String;
  OldOwner, OldParen, SubsComp: TComponent;
  FilerAccess: TFilerAccess;
begin
  SubsComp := nil;
  FilerAccess := nil;
  ReadPrefix(Flags, I);

  ReadStr; { Ignore class name }
  CompName := ReadStr;

  if Component = nil
    then Component := FindChildComponent(Parent, Root, CompName, True)
    else Owner := Component;

  if Component = nil then
  begin
    SubsComp := TComponent.Create(nil);
    Component := SubsComp;
  end;

  FInterceptorList := TList.Create;

  while not EndOfList do ReadProperty(Component);
  ReadListEnd;

  for i := 0 to FCollectionList.Count-1 do
    TCollection(FCollectionList[i]).EndUpdate;
  FCollectionList.Clear;

  for i := FInterceptorList.Count-1 downto 0 do
    with TStoragePropertyInterceptor(FInterceptorList[i]) do
      begin
        Readed;
        Free;
      end;
  FInterceptorList.Free;

  OldOwner := Owner;
  OldParen := Parent;
  try
    FilerAccess := TFilerAccess.Create(Component);
    Owner := FilerAccess.GetChildOwner;
    Parent := FilerAccess.GetChildParent;
    while not EndOfList do ReadComponent(nil);
    ReadListEnd;
  finally
    Owner := OldOwner;
    Parent := OldParen;
    FilerAccess.Free;
  end;

  if SubsComp <> nil then
    SubsComp.Free;
end;

procedure TPropReaderEh.ReadCollection(Collection: TCollection);
var
  Item: TPersistent;
begin
  Collection.BeginUpdate;
  try
    if not EndOfList then Collection.Clear;
    while not EndOfList do
    begin
      if NextValue in [vaInt8, vaInt16, vaInt32] then ReadInteger;
      Item := Collection.Add;
      ReadListBegin;
      while not EndOfList do ReadProperty(Item);
      ReadListEnd;
    end;
    ReadListEnd;
  finally
    Collection.EndUpdate;
  end;
end;

procedure TPropReaderEh.ReadProperty(AInstance: TPersistent);
var
  I, J, L: Integer;
  Instance: TPersistent;
  PropInfo: PPropInfo;
  PropValue: TObject;
  PropPath: string;

  procedure HandleException(E: Exception);
  var
    Name: string;
  begin
    Name := '';
    if AInstance is TComponent then
      Name := TComponent(AInstance).Name;
    if Name = '' then Name := AInstance.ClassName;
    raise EReadError.CreateFmt(SPropertyException, [Name, DotSep, PropPath, E.Message]);
  end;

  procedure PropPathError;
  begin
    SkipValue;
    ReadError(SInvalidPropertyPath);
  end;

  function ReadCollectionItemAsProperty(Collection: TCollection; var PropName: String): TPersistent;
  var
    i, Index: Integer;
    S, SIndex: String;
  begin
    S := Copy(PropName, Length('__Item') + 1, Length(PropName));
    SIndex := '';
    Result := Collection;
    for i := 1 to Length(S) do
      if (S[i] in ['0','1','2','3','4','5','6','7','8','9'])
        then SIndex := SIndex + S[i]
        else Break;
    if SIndex <> ''
      then Index := StrToInt(SIndex)
      else Exit;
    if Collection.Count > Index then
    begin
      PropName := Copy(PropName, Length('__Item') + Length('SIndex') + 1, Length(PropName));
      Result := Collection.Items[Index];
    end;
    if FCollectionList.IndexOf(Collection) = -1 then
    begin
      Collection.BeginUpdate;
      FCollectionList.Add(Collection);
    end;
  end;

  function CheckInterceptor(Instance: TPersistent; const PropName: string): Boolean;
  var
    InterceptorClass: TReadPropertyInterceptorClass;
    Interceptor: TStoragePropertyInterceptor;
    i: Integer;
  begin
    Result := False;
    InterceptorClass := GetInterceptorForTarget(Instance.ClassType);
    if InterceptorClass = nil then Exit;
    Interceptor := nil;
    for i := 0 to FInterceptorList.Count - 1 do
    begin
//      if InterceptorClass = TStoragePropertyInterceptor(FInterceptorList[i]).ClassType then
      if Instance = TStoragePropertyInterceptor(FInterceptorList[i]).FTarget then
      begin
        Interceptor := TStoragePropertyInterceptor(FInterceptorList[i]);
        Break;
      end;
    end;
    if Interceptor = nil then
    begin
      Interceptor := InterceptorClass.Create(Instance);
      FInterceptorList.Add(Interceptor);
    end;
    PropInfo := GetPropInfo(Interceptor.ClassInfo, PropName);
    if (PropInfo = nil) or not CanWrite(PropInfo) then Exit;
    ReadPropValue(Interceptor, PropInfo);
    Result := True;
  end;

var
  Processed: Boolean;
  FilerAccess: TFilerAccess;
begin
  try
    PropPath := ReadStr;
    try
      I := 1;
      L := Length(PropPath);
      Instance := AInstance;
      FCanHandleExcepts := True;
      PropValue := nil;
      while True do
      begin
        J := I;
        while (I <= L) and (PropPath[I] <> '.') do Inc(I);
        FPropName := Copy(PropPath, J, I - J);

        if (PropValue is TCollection) and (Copy(FPropName, 1, 6) = '__Item') then
        begin
          Instance := ReadCollectionItemAsProperty(TCollection(PropValue), FPropName);
          if Instance <> nil then
          begin
            Inc(I);
            Continue;
          end;
        end;

        if I > L then Break;
        PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
        if PropInfo = nil then
{$IFDEF EH_LIB_6}
          PropertyError(FPropName);
{$ELSE}
          PropertyError;
{$ENDIF}
        PropValue := nil;
        if PropType_getKind(PropInfo_getPropType(PropInfo)) = tkClass then
          PropValue := GetObjectProp(Instance, PropInfo);
        if not (PropValue is TPersistent) then PropPathError;
        Instance := TPersistent(PropValue);
        Inc(I);
      end;
      if CheckInterceptor(Instance, FPropName) then Exit;
      if (Instance = AInstance) and Assigned(OnReadOwnerProp) then
      begin
        Processed := False; 
        OnReadOwnerProp(Self, FPropName, Processed);
        if Processed then Exit;
      end;
      PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
      if PropInfo <> nil
        then ReadPropValue(Instance, PropInfo)
      else
      begin
        { Cannot reliably recover from an error in a defined property }
        FCanHandleExcepts := False;
        FilerAccess := TFilerAccess.Create(Instance);
        FilerAccess.DefineProperties(Self);
        FilerAccess.Free;
        FCanHandleExcepts := True;
        if FPropName <> '' then
{$IFDEF EH_LIB_6}
          PropertyError(FPropName);
{$ELSE}
          PropertyError;
{$ENDIF}
      end;
    except
      on E: Exception do HandleException(E);
    end;
  except
    on E: Exception do
      if not FCanHandleExcepts or not Error(E.Message) then raise;
  end;
end;

function TPropReaderEh.Error(const Message: string): Boolean;
begin
  Result := inherited Error(Message);
  if not IsRaiseReadErrorEh then
    Result := True;
end;

procedure TPropReaderEh.ReadPropValue(Instance: TPersistent; PropInfo: PPropInfo);
//const
//  NilMethod: TMethod = (Code: nil; Data: nil);
var
  PropType: PTypeInfo;
//  Method: TMethod;

  procedure SetIntIdent(Instance: TPersistent; PropInfo: PPropInfo;
    const Ident: string);
{$IFDEF EH_LIB_5}
  var
    V: Longint;
    IdentToInt: TIdentToInt;
{$ENDIF}
  begin
{$IFDEF EH_LIB_5}
    IdentToInt := FindIdentToInt(PropInfo_getPropType(PropInfo));
    if Assigned(IdentToInt) and IdentToInt(Ident, V) then
      SetOrdProp(Instance, PropInfo, V)
    else
{$ENDIF}
      PropValueError;
  end;

  procedure SetObjectIdent(Instance: TPersistent; PropInfo: PPropInfo; Ident: string);
  var
    Component: TComponent;
    GlobalName: String;

    function MakeGlobalReference: Boolean;
    var
      P: Integer;
    begin
      Result := False;
      P := 1;
      while (P <= Length(Ident)) and (Ident[P] <> '.') do
        Inc(P);
      if P > Length(Ident) then
        Exit;
      GlobalName := Copy(Ident, 1, P - 1);
      Ident := Copy(Ident, P + 1, 1024);
      Result := True;
    end;

  begin
    Component := FindNestedComponent(Root, Ident);
    if Component <> nil then
      SetObjectProp(Instance, PropInfo, Component)
    else if MakeGlobalReference then
    begin
      Component := FindGlobalComponent(GlobalName);
      if Component <> nil then
      begin
        Component := FindNestedComponent(Component, Ident);
        if Component <> nil then
          SetObjectProp(Instance, PropInfo, Component);
      end;
    end;
    //FFixups.Add(TPropFixup.Create(Instance, Root, PropInfo, '', Ident));
  end;

{$IFNDEF EH_LIB_6}

  function ReadVariant: Variant;
  const
    ValTtoVarT: array[TValueType] of Integer = (varNull, varError, varByte,
      varSmallInt, varInteger, varDouble, varString, varError, varBoolean,
      varBoolean, varError, varError, varString, varEmpty, varError, varSingle,
      varCurrency, varDate, varOleStr
{$IFDEF EH_LIB_5}
      , varError
{$ENDIF}
      );
  var
    ValType: TValueType;
  begin
    ValType := NextValue;
    case ValType of
      vaNil, vaNull:
      begin