propfilereh.pas

最新的 DBGRIDEH4.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
  begin
    Path := PropList[i];
    CompName := GetNextPointSeparatedToken(Path);
    Delete(Path, 1, Length(CompName)+1);

    if CompName = '<P>'
      then Continue
      ;//else NewComponent := Owner.FindComponent(CompName);

    CurOwner := Owner;
    Level := 1;

    while CompName <> '<P>' do
    begin
      if CompName = '' then
        raise Exception.Create('Component name is empty.');

      NewComponent := FindChildComponent(CurOwner, Root, CompName, True);
      if NewComponent = nil then Break;
//      NewComponent := CurOwner.FindComponent(CompName);
      CurOwner := NewComponent;

      if FCurRootsList.Count < Level then
      begin
        if FCurRootsList.Count > 0 then
          WriteListEnd; // End of properties
        WriteStr(NewComponent.ClassName);
        WriteStr(NewComponent.Name);
        FCurRootsList.Add(NewComponent);
      end else if FCurRootsList.Count > Level then
      begin
        if CompName <> TComponent(FCurRootsList[Level-1]).Name then
        begin
          WriteListEnd; // End of properties
          for j := FCurRootsList.Count - 1 downto Level - 1 do
          begin
            WriteListEnd; // End of object
            FCurRootsList.Delete(j);
          end;
//          FCurRootsList.Delete(FCurRootsList.Count-1);
          WriteStr(NewComponent.ClassName);
          WriteStr(NewComponent.Name);
          FCurRootsList.Add(NewComponent);
        end;
      end else
      begin  // FCurRootsList.Count = Level
        if CompName <> TComponent(FCurRootsList[Level-1]).Name then
        begin
          WriteListEnd; // End of properties
          for j := FCurRootsList.Count downto Level do
          begin
            WriteListEnd; // End of object
//            WriteListEnd;
            FCurRootsList.Delete(j-1);
          end;
          WriteStr(NewComponent.ClassName);
          WriteStr(NewComponent.Name);
          FCurRootsList.Add(NewComponent);
        end;
      end;

      CompName := GetNextPointSeparatedToken(Path);
      Delete(Path, 1, Length(CompName)+1);
      Inc(Level);
    end;

    SaveObjectProperyValue(TObject(FCurRootsList[FCurRootsList.Count-1]), Path, PropList[i]);
  end;

  WriteListEnd; // End of properties
  for j := FCurRootsList.Count - 1 downto 0 do
  begin
    WriteListEnd; // End of object
    FCurRootsList.Delete(j);
  end;
  WriteListEnd;

  FlushBuffer;

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

procedure TPropWriterEh.SaveObjectProperyValue(Instance: TObject; Path, FullPath: String);
var
  PropInfo: PPropInfo;
  PropType: PTypeInfo;
  PropName: String;

  procedure WriteCollectionItemAsProperty(Item: TCollectionItem; Path, FullPath: String);
  var
    OldAncestor: TPersistent;
    SavePropPath: string;
  begin
    OldAncestor := Ancestor;
    SavePropPath := FPropPath;
    try
      FPropPath := FPropPath + '__Item' + IntToStr(Item.Index) + '.';
      SaveObjectProperyValue(Item, Path, FullPath);
    finally
      Ancestor := OldAncestor;
      FPropPath := SavePropPath;
    end;
  end;

  procedure WritePropPath;
  begin
    WritePropName(PropInfo_getName(PropInfo));
  end;

  procedure WriteSet(Value: Longint);
  var
    I: Integer;
    BaseType: PTypeInfo;
  begin
{$IFDEF CIL}
    BaseType := GetTypeData(PropType).CompType;
{$ELSE}
    BaseType := GetTypeData(PropType)^.CompType^;
{$ENDIF}
    WriteValue(vaSet);
    for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do
      if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I));
    WriteStr('');
  end;

  procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
{$IFDEF EH_LIB_5}
  var
    Ident: string;
    IntToIdent: TIntToIdent;
{$ENDIF}
  begin
{$IFDEF EH_LIB_5}
    IntToIdent := FindIntToIdent(IntType);
    if Assigned(IntToIdent) and IntToIdent(Value, Ident) then
      WriteIdent(Ident)
    else
{$ENDIF}
      WriteInteger(Value);
  end;

  procedure WriteCollectionProp(Collection: TCollection);
  var
    SavePropPath: string;
  begin
    WritePropPath;
    SavePropPath := FPropPath;
    try
      FPropPath := '';
      WriteCollection(Collection);
    finally
      FPropPath := SavePropPath;
    end;
  end;

  procedure WriteOrdProp;
  var
    Value: Longint;
  begin
    Value := GetOrdProp(Instance, PropInfo);
    WritePropPath;
    case PropType_GetKind(PropType) of
      tkInteger:
        WriteIntProp(PropInfo_getPropType(PropInfo), Value);
      tkChar:
        WriteChar(Chr(Value));
      tkSet:
        WriteSet(Value);
      tkEnumeration:
        WriteIdent(GetEnumName(PropType, Value));
    end;
  end;

  procedure WriteFloatProp;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(Instance, PropInfo);
    WritePropPath;
    WriteFloat(Value);
  end;

  procedure WriteInt64Prop;
  var
    Value: Int64;
  begin
    Value := GetInt64Prop(Instance, PropInfo);
    WritePropPath;
    WriteInteger(Value);
  end;

  procedure WriteStrProp;
  var
    Value: WideString;
  begin
{$IFDEF EH_LIB_6}
    Value := GetWideStrProp(Instance, PropInfo);
    WritePropPath;
    WriteWideString(Value);
{$ELSE}
    Value := GetStrProp(Instance, PropInfo);
    WritePropPath;
    WriteString(Value);
{$ENDIF}
  end;

  function OwnedBy(Component, Owner: TComponent): Boolean;
  begin
    Result := True;
    while Component <> nil do
      if Component = Owner then
        Exit
      else
        Component := Component.Owner;
    Result := False;
  end;

  function GetComponentValue(Component: TComponent): string;
  begin
    if Component.Owner = Root then //LookupRoot then
      Result := Component.Name
    else if Component = Root then //LookupRoot then
      Result := 'Owner'                                                       { Do not translate }
    else if (Component.Owner <> nil) and (Component.Owner.Name <> '') and
      (Component.Name <> '') then
      if OwnedBy(Component.Owner, Root) then//LookupRoot) then
        Result := GetComponentValue(Component.Owner) + '.' + Component.Name
      else
        Result := Component.Owner.Name + '.' + Component.Name
    else if Component.Name <> '' then
      Result := Component.Name + '.Owner'                                     { Do not translate }
    else Result := '';
  end;

  procedure WriteObjectProp;
  var
    Value: TObject;
    OldAncestor: TPersistent;
    SavePropPath, ComponentValue: string;
  begin
    Value := GetObjectProp(Instance, PropInfo);
    if Value = nil then
    begin
      WritePropPath;
      WriteValue(vaNil);
    end
    else if Value is TPersistent then
      if (Value is TComponent)
{$IFDEF EH_LIB_6} and not (csSubComponent in TComponent(Value).ComponentStyle) {$ENDIF} then
      begin
        ComponentValue := GetComponentValue(TComponent(Value));
        // ComponentValue will never be '' since we are to always
        // write out the value (in other words: it is not the default)
        // but it doesn't hurt to check
        if ComponentValue <> '' then
        begin
          WritePropPath;
          WriteIdent(ComponentValue);
        end;
      end else
      begin

        OldAncestor := Ancestor;
        SavePropPath := FPropPath;
        try
          FPropPath := FPropPath + PropInfo_getName(PropInfo) + '.';

          if Path <> '' then
            SaveObjectProperyValue(Value, Path, FullPath)
          else
          begin
            WriteAllProperties(Value);
          end;

        finally
          Ancestor := OldAncestor;
          FPropPath := SavePropPath;
        end;

        if (Value is TCollection) and (Path = '') then
          WriteCollectionProp(TCollection(Value));
      end;
  end;

{$IFDEF EH_LIB_6}

{$IFDEF CIL}
  procedure WriteInterfaceProp;
  begin
  end;
{$ELSE}
  procedure WriteInterfaceProp;
  var
    Intf: IInterface;
    Value: TComponent;
  var
    SR: IInterfaceComponentReference;
    RefStr: String;
  begin
    Intf := GetInterfaceProp(Instance, PropInfo);
    if Intf = nil then
    begin
      WritePropPath;
      WriteValue(vaNil);
    end
    else if Supports(Intf, IInterfaceComponentReference, SR) then
    begin
      Value := SR.GetComponent;
      RefStr := GetComponentValue(Value);
      Assert(RefStr <> '', 'Component reference name should always be non blank');
      WritePropPath;
      WriteIdent(RefStr);
    end;
    // The else case will not happen because we are to always write out the
    // property at this point, so it will be nil, or support the reference
  end;
{$ENDIF} // {CIL $ELSE}

{$ENDIF} // EH_LIB_6

  procedure WriteMethodProp;
  var
    Value: TMethod;
  begin
    Value := GetMethodProp(Instance, PropInfo);
    WritePropPath;
    if Value.Code = nil then
      WriteValue(vaNil)
    else
      WriteIdent(Root.MethodName(Value.Code));//LookupRoot.MethodName(Value.Code));
  end;

{$IFNDEF EH_LIB_6}

  procedure WriteVariant(const Value: Variant);
  var
    VType: Integer;
  begin
    if VarIsArray(Value) then raise EWriteError.Create(SWriteError);
    VType := VarType(Value);
    case VType and varTypeMask of
      varEmpty: WriteValue(vaNil);
      varNull: WriteValue(vaNull);
      varOleStr: WriteWideString(Value);
      varString: WriteString(Value);
      varByte, varSmallInt, varInteger: WriteInteger(Value);
      varSingle: WriteSingle(Value);
      varDouble: WriteFloat(Value);
      varCurrency: WriteCurrency(Value);
      varDate: WriteDate(Value);
      varBoolean:
        if Value then
          WriteValue(vaTrue) else
          WriteValue(vaFalse);
    else
      try
        WriteString(Value);
      except
        raise EWriteError.Create(SWriteError);
      end;
    end;
  end;

{$ENDIF}

  procedure WriteVariantProp;
  var
    Value: Variant;
  begin
    Value := GetVariantProp(Instance, PropInfo);
    WritePropPath;
    WriteVariant(Value);
  end;

  function CheckInterceptor(var Instance: TObject; 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 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 CanRead(PropInfo) then Exit;
    Instance := Interceptor;
    Result := True;
  end;

var
  PPos, Index, i, j: Integer;
//  WriterProc: TWriterProc;
  Collection: TCollection;
  sl: TStringList;
  Suffix: String;
begin
  if Path = '' then
    raise Exception.Create('Property name is empty.');
  PPos := Pos('.', Path);
  if PPos > 0 then
  begin
    PropName := Copy(Path, 1, PPos-1);
    Delete(Path, 1, PPos);
  end else
  begin
    PropName := Path;
    Path := '';
  end;
  if (PropName = '<ForAllItems>') or (Copy(PropName, 1, 5) = '<Item') then
  begin
    if not (Instance is TCollection) then
      raise Exception.Create('Component type is not Collection.');
    Collection := TCollection(Instance);

    if PropName = '<ForAllItems>' then
    begin
      if (Path = '') and (Collection.Count > 0) then
      begin
        sl := TStringList.Create;
        BuildPropsList(Collection.Items[0], sl);
        for i := 0 to Collection.Count - 1 do
          for j := 0 to sl.Count - 1 do
          begin
            Suffix := sl[j];
            WriteCollectionItemAsProperty(Collection.Items[i], Suffix,
              Copy(FullPath, 1, Length(FullPath) - Length(Path) - Length('.<ForAllItems>')) + '<Item' + IntToStr(j) + '>.' + Suffix);
          end;
        sl.Free;
      end else
        for i := 0 to Collection.Count-1 do
          WriteCollectionItemAsProperty(Collection.Items[i], Path,
            Copy(FullPath, 1, Length(FullPath) - Length(Path) - Length('.<ForAllItems>')) + '<Item' + IntToStr(i) + '>.' + Path);
    end else
    begin
      i := StrToInt(Copy(Copy(PropName, 1, Length(PropName)-1), 6, 100));
      if Path = '' then
      begin
        sl := TStringList.Create;
        BuildPropsList(Collection.Items[i], sl);
        for j := 0 to sl.Count - 1 do
        begin
          Suffix := sl[j];
          WriteCollectionItemAsProperty(Collection.Items[i], Suffix, FullPath + '.' + Suffix);
        end;
        sl.Free;
      end else
        WriteCollectionItemAsProperty(Collection.Items[i], Path, FullPath);
    end

  end else
  begin

    if not CheckInterceptor(Instance, PropName) then
      PropInfo := GetPropInfo(Instance.ClassInfo, PropName);

    if PropInfo = nil then // Check in Define properies list
    begin
      DefineObjectProperties(Instance);
      if (FDefnPropList.IndexOf(PropName) >= 0) then
      begin
        Index := FDefnPropList.IndexOf(PropName);
        if Assigned(FDefnPropList.Objects[Index]) and
           (TMethodObj(FDefnPropList.Objects[Index]).Method.Code <> nil) then
        begin
          WritePropName(PropName);
{$IFDEF CIL}