nativexmlobjectstorage.pas

此程序演示了利用xml控件（当然也可以不通过xml控件）

    end;
  end;

  procedure WriteVariantProp;
  var
    AValue: Variant;
    ACurrency: Currency;
  var
    VType: Integer;
  begin
    AValue := GetVariantProp(AObject, PropInfo);
    if not VarIsEmpty(AValue) then begin
      if VarIsArray(AValue) then
        raise Exception.Create(sxwIllegalVarType);
      WritePropName;
      VType := VarType(AValue);
      AChildNode.AttributeAdd('VarType', IntToHex(VType, 4));
      case VType and varTypeMask of
      varOleStr:  AChildNode.ValueAsWideString := AValue;
      varString:  AChildNode.ValueAsString := AValue;
      varByte,
      varSmallInt,
      varInteger: AChildNode.ValueAsInteger := AValue;
      varSingle,
      varDouble:  AChildNode.ValueAsFloat := AValue;
      varCurrency:
        begin
          ACurrency := AValue;
          AChildNode.BufferWrite(ACurrency, SizeOf(ACurrency));
        end;
      varDate:    AChildNode.ValueAsDateTime := AValue;
      varBoolean: AChildNode.ValueAsBool := AValue;
      else
        try
          ANode.ValueAsString := AValue;
        except
          raise Exception.Create(sxwIllegalVarType);
        end;
      end;//case
    end;
  end;

begin
  if (PPropInfo(PropInfo)^.SetProc <> nil) and
    (PPropInfo(PropInfo)^.GetProc <> nil) then
  begin
    PropType := PPropInfo(PropInfo)^.PropType^;
    case PropType^.Kind of
    tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp;
    tkFloat:                                 WriteFloatProp;
    tkString, tkLString, tkWString:          WriteStrProp;
    tkClass:                                 WriteObjectProp;
    tkMethod:                                WriteMethodProp;
    tkVariant:                               WriteVariantProp;
    tkInt64:                                 WriteInt64Prop;
    end;
  end;
end;

{ TsdXmlObjectReader }

function TsdXmlObjectReader.CreateComponent(ANode: TXmlNode;
  AOwner, AParent: TComponent; AName: string): TComponent;
var
  AClass: TComponentClass;
begin
  AClass := TComponentClass(GetClass(ANode.Name));
  if not assigned(AClass) then
    raise Exception.Create(sxrUnregisteredClassType);
  Result := AClass.Create(AOwner);
  if length(AName) = 0 then
    Result.Name := ANode.AttributeByName['Name']
  else
    Result.Name := AName;
  if not assigned(AParent) then
    AParent := Result;
  ReadComponent(ANode, Result, AParent);
end;

procedure TsdXmlObjectReader.ReadComponent(ANode: TXmlNode; AComponent,
  AParent: TComponent);
begin
  ReadObject(ANode, AComponent, AParent);
end;

procedure TsdXmlObjectReader.ReadObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent);
var
  i, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
  S: TStringStream;
  AReader: TReader;
  AChildNode: TXmlNode;
  AComponentNode: TXmlNode;
  AClass: TComponentClass;
  AComponent: TComponent;
begin
  if not assigned(ANode) or not assigned(AObject) then exit;

  // Start loading
  if AObject is TComponent then with THackComponent(AObject) do begin
    THackComponent(AObject).Updating;
    SetComponentState(ComponentState + [csLoading, csReading]);
  end;
  try

    // If this is a component, load child components
    if AObject is TComponent then with TComponent(AObject) do begin
      AChildNode := ANode.NodeByName('Components');
      if assigned(AChildNode) then begin
        for i := 0 to AChildNode.NodeCount - 1 do begin
          AComponentNode := AChildNode.Nodes[i];
          AComponent := FindComponent(AComponentNode.AttributeByName['Name']);
          if not assigned(AComponent) then begin
            AClass := TComponentClass(GetClass(AComponentNode.Name));
            if not assigned(AClass) then
              raise Exception.Create(sxrUnregisteredClassType);
            AComponent := AClass.Create(TComponent(AObject));
            AComponent.Name := AComponentNode.AttributeByName['Name'];
            // In case of new (visual) controls we set the parent
            if (AComponent is TControl) and (AObject is TWinControl) then
              TControl(AComponent).Parent := TWinControl(AObject);
          end;
          ReadComponent(AComponentNode, AComponent, TComponent(AObject));
        end;
      end;
    end;

    // Load all loadable regular properties
    Count := GetTypeData(AObject.ClassInfo)^.PropCount;
    if Count > 0 then begin
      GetMem(PropList, Count * SizeOf(Pointer));
      try
        GetPropInfos(AObject.ClassInfo, PropList);
        for i := 0 to Count - 1 do begin
          PropInfo := PropList^[i];
          if PropInfo = nil then continue;
          if IsStoredProp(AObject, PropInfo) then
            ReadProperty(ANode, AObject, AParent, PropInfo);
        end;
      finally
        FreeMem(PropList, Count * SizeOf(Pointer));
      end;
    end;

    // Load defined properties
    if AObject is TPersistent then begin
      AChildNode := ANode.NodeByName('DefinedProperties');
      if assigned(AChildNode) then begin
        S := TStringStream.Create(AChildNode.BinaryString);
        try
          AReader := TReader.Create(S, 4096);
          try
            THackReader(AReader).ReadProperty(TPersistent(AObject));
          finally
            AReader.Free;
          end;
        finally
          S.Free;
        end;
      end;
    end;

  finally
    // End loading
    if AObject is TComponent then with THackComponent(AObject) do begin
      SetComponentState(ComponentState - [csReading]);
      THackComponent(AObject).Loaded;
      THackComponent(AObject).Updated;
    end;
  end;
end;

procedure TsdXmlObjectReader.ReadProperty(ANode: TXmlNode;
  AObject: TObject; AParent: TComponent; PropInfo: PPropInfo);
var
  PropType: PTypeInfo;
  AChildNode: TXmlNode;
  Method: TMethod;
  PropObject: TObject;

  procedure SetSetProp(const AValue: string);
  var
    S: string;
    P: integer;
    ASet: integer;
    EnumType: PTypeInfo;

    procedure AddToEnum(const EnumName: string);
    var
      V: integer;
    begin
      if length(EnumName) = 0 then exit;
      V := GetEnumValue(EnumType, EnumName);
      if V = -1 then
        raise Exception.Create(sxrInvalidPropertyValue);
      Include(TIntegerSet(ASet), V);
    end;
  begin
    ASet := 0;
    EnumType := GetTypeData(PropType)^.CompType^;
    S := copy(AValue, 2, length(AValue) - 2);
    repeat
      P := Pos(',', S);
      if P > 0 then begin
        AddToEnum(copy(S, 1, P - 1));
        S := copy(S, P + 1, length(S));
      end else begin
        AddToEnum(S);
        break;
      end;
    until False;
    SetOrdProp(AObject, PropInfo, ASet);
  end;

  procedure SetIntProp(const AValue: string);
  var
    V: Longint;
    IdentToInt: TIdentToInt;
  begin
    IdentToInt := FindIdentToInt(PropType);
    if Assigned(IdentToInt) and IdentToInt(AValue, V) then
      SetOrdProp(AObject, PropInfo, V)
    else
      SetOrdProp(AObject, PropInfo, StrToInt(AValue));
  end;

  procedure SetCharProp(const AValue: string);
  begin
    if length(AValue) <> 1 then
      raise Exception.Create(sxrInvalidPropertyValue);
    SetOrdProp(AObject, PropInfo, Ord(AValue[1]));
  end;

  procedure SetEnumProp(const AValue: string);
  var
    V: integer;
  begin
    V := GetEnumValue(PropType, AValue);
    if V = -1 then
      raise Exception.Create(sxrInvalidPropertyValue);
    SetOrdProp(AObject, PropInfo, V)
  end;

  procedure ReadCollectionProp(ACollection: TCollection);
  var
    i: integer;
    Item: TPersistent;
  begin
    ACollection.BeginUpdate;
    try
      ACollection.Clear;
      for i := 0 to AChildNode.NodeCount - 1 do begin
        Item := ACollection.Add;
        ReadObject(AChildNode.Nodes[i], Item, AParent);
      end;
    finally
      ACollection.EndUpdate;
    end;
  end;

  procedure SetObjectProp(const AValue: string);
  var
    AClassName: string;
    PropObject: TObject;
    Reference: TComponent;
  begin
    if length(AValue) = 0 then exit;
    if AValue[1] = '(' then begin
      // Persistent class
      AClassName := Copy(AValue, 2, length(AValue) - 2);
      PropObject := TObject(GetOrdProp(AObject, PropInfo));
      if assigned(PropObject) and (PropObject.ClassName = AClassName) then begin
        if PropObject is TCollection then
          ReadCollectionProp(TCollection(PropObject))
        else begin
          if AObject is TComponent then
            ReadObject(AChildNode, PropObject, TComponent(AObject))
          else
            ReadObject(AChildNode, PropObject, AParent);
        end;
      end else
        raise Exception.Create(sxrUnregisteredClassType);
    end else begin
      // Component reference
      if assigned(AParent) then begin
        Reference := FindNestedComponent(AParent, AValue);
        SetOrdProp(AObject, PropInfo, Longint(Reference));
      end;
    end;
  end;

  procedure SetMethodProp(const AValue: string);
  var
    Method: TMethod;
  begin
    // to do: add OnFindMethod
    if not assigned(AParent) then exit;
    Method.Code := AParent.MethodAddress(AValue);
    if not assigned(Method.Code) then
      raise Exception.Create(sxwInvalidMethodName);
    Method.Data := AParent;
    TypInfo.SetMethodProp(AObject, PropInfo, Method);
  end;

  procedure SetVariantProp(const AValue: string);
  var
    VType: integer;
    Value: Variant;
    ACurrency: Currency;
  begin
    VType := StrToInt(AChildNode.AttributeByName['VarType']);

    case VType and varTypeMask of
    varOleStr:  Value := AChildNode.ValueAsWideString;
    varString:  Value := AChildNode.ValueAsString;
    varByte,
    varSmallInt,
    varInteger: Value := AChildNode.ValueAsInteger;
    varSingle,
    varDouble:  Value := AChildNode.ValueAsFloat;
    varCurrency:
      begin
        AChildNode.BufferWrite(ACurrency, SizeOf(ACurrency));
        Value := ACurrency;
      end;
    varDate:    Value := AChildNode.ValueAsDateTime;
    varBoolean: Value := AChildNode.ValueAsBool;
    else
      try
        Value := ANode.ValueAsString;
      except
        raise Exception.Create(sxwIllegalVarType);
      end;
    end;//case

    TVarData(Value).VType := VType;
    TypInfo.SetVariantProp(AObject, PropInfo, Value);
  end;

begin
  if (PPropInfo(PropInfo)^.SetProc <> nil) and
    (PPropInfo(PropInfo)^.GetProc <> nil) then
  begin
    PropType := PPropInfo(PropInfo)^.PropType^;
    AChildNode := ANode.NodeByName(PPropInfo(PropInfo)^.Name);
    if assigned(AChildNode) then begin
      // Non-default values from XML
      case PropType^.Kind of
      tkInteger:     SetIntProp(AChildNode.ValueAsString);
      tkChar:        SetCharProp(AChildNode.ValueAsString);
      tkSet:         SetSetProp(AChildNode.ValueAsString);
      tkEnumeration: SetEnumProp(AChildNode.ValueAsString);
      tkFloat:       SetFloatProp(AObject, PropInfo, AChildNode.ValueAsFloat);
      tkString,
      tkLString,
      tkWString:     SetStrProp(AObject, PropInfo, AChildNode.ValueAsString);
      tkClass:       SetObjectProp(AChildNode.ValueAsString);
      tkMethod:      SetMethodProp(AChildNode.ValueAsString);
      tkVariant:     SetVariantProp(AChildNode.ValueAsString);
      tkInt64:       SetInt64Prop(AObject, PropInfo, AChildNode.ValueAsInt64);
      end;//case
    end else begin
      // Set Default value
      case PropType^.Kind of
      tkInteger:     SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkChar:        SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkSet:         SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkEnumeration: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkFloat:       SetFloatProp(AObject, PropInfo, 0);
      tkString,
      tkLString,
      tkWString:     SetStrProp(AObject, PropInfo, '');
      tkClass:
        begin
          PropObject := TObject(GetOrdProp(AObject, PropInfo));
          if PropObject is TComponent then
            SetOrdProp(AObject, PropInfo, 0);
        end;
      tkMethod:
        begin
          Method := TypInfo.GetMethodProp(AObject, PropInfo);
          Method.Code := nil;
          TypInfo.SetMethodProp(AObject, PropInfo, Method);
        end;
      tkInt64:       SetInt64Prop(AObject, PropInfo, 0);
      end;//case
    end;
  end;
end;

{ THackComponent }

procedure THackComponent.SetComponentState(const AState: TComponentState);
type
  PInteger = ^integer;
var
  PSet: PInteger;
  AInfo: PPropInfo;
begin
  // This is a "severe" hack in order to set a non-writable property value,
  // also using RTTI
  PSet := PInteger(@AState);
  AInfo := GetPropInfo(THackComponent, 'ComponentState');
  if assigned(AInfo.GetProc) then
    PInteger(Integer(Self) + Integer(AInfo.GetProc) and $00FFFFFF)^ := PSet^;
end;

initialization

  {$IFDEF TRIALXML}
  ShowMessage('ObjectToXml demo.'#13#10'For more information please visit:'#13#10 +
    'http://www.simdesign.nl/xml.html');
  {$ENDIF}

end.