nativexmlobjectstorage.pas

Delphi 中处理XML的类库

  S := TStringStream.Create(Value);
  try
    Result := FormCreateFromXmlStream(S, Owner, Name);
  finally
    S.Free;
  end;
end;

procedure ObjectLoadFromXmlFile(AObject: TObject; const FileName: string;
  AParent: TComponent = nil);
var
  S: TStream;
begin
  S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    ObjectLoadFromXmlStream(AObject, S, AParent);
  finally
    S.Free;
  end;
end;

procedure ObjectLoadFromXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil);
var
  AReader: TsdXmlObjectReader;
begin
  if not assigned(AObject) or not assigned(ANode) then exit;
  // Create writer
  AReader := TsdXmlObjectReader.Create;
  try
    // Write the object to the document
    if AObject is TComponent then
      AReader.ReadComponent(ANode, TComponent(AObject), AParent)
    else
      AReader.ReadObject(ANode, AObject, AParent);
  finally
    AReader.Free;
  end;
end;

procedure ObjectLoadFromXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil);
var
  ADoc: TNativeXml;
begin
  if not assigned(S) then exit;
  // Create XML document
  ADoc := TNativeXml.Create;
  try
    // Load XML
    ADoc.LoadFromStream(S);
    // Load from XML node
    ObjectLoadFromXmlNode(AObject, ADoc.Root, AParent);
  finally
    ADoc.Free;
  end;
end;

procedure ObjectLoadFromXmlString(AObject: TObject; const Value: string; AParent: TComponent = nil);
var
  S: TStringStream;
begin
  S := TStringStream.Create(Value);
  try
    ObjectLoadFromXmlStream(AObject, S, AParent);
  finally
    S.Free;
  end;
end;

procedure ObjectSaveToXmlFile(AObject: TObject; const FileName: string;
  AParent: TComponent = nil);
var
  S: TStream;
begin
  S := TFileStream.Create(FileName, fmCreate);
  try
    ObjectSaveToXmlStream(AObject, S, AParent);
  finally
    S.Free;
  end;
end;

procedure ObjectSaveToXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil);
var
  AWriter: TsdXmlObjectWriter;
begin
  if not assigned(AObject) or not assigned(ANode) then exit;
  // Create writer
  AWriter := TsdXmlObjectWriter.Create;
  try
    // Write the object to the document
    if AObject is TComponent then
      AWriter.WriteComponent(ANode, TComponent(AObject), AParent)
    else begin
      ANode.Name := AObject.ClassName;
      AWriter.WriteObject(ANode, AObject, AParent);
    end;
  finally
    AWriter.Free;
  end;
end;

procedure ObjectSaveToXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil);
var
  ADoc: TNativeXml;
begin
  if not assigned(S) then exit;
  // Create XML document
  ADoc := TNativeXml.Create;
  try
    ADoc.Utf8Encoded := True;
    ADoc.EncodingString := 'UTF-8';
    ADoc.XmlFormat := xfReadable;
    // Save to XML node
    ObjectSaveToXmlNode(AObject, ADoc.Root, AParent);
    // Save to stream
    ADoc.SaveToStream(S);
  finally
    ADoc.Free;
  end;
end;

function ObjectSaveToXmlString(AObject: TObject; AParent: TComponent = nil): string;
var
  S: TStringStream;
begin
  S := TStringStream.Create('');
  try
    ObjectSaveToXmlStream(AObject, S, AParent);
    Result := S.DataString;
  finally
    S.Free;
  end;
end;

procedure ComponentSaveToXmlFile(AComponent: TComponent; const FileName: string;
  AParent: TComponent = nil);
begin
  ObjectSaveToXmlFile(AComponent, FileName, AParent);
end;

procedure ComponentSaveToXmlNode(AComponent: TComponent; ANode: TXmlNode;
  AParent: TComponent = nil);
begin
  ObjectSaveToXmlNode(AComponent, ANode, AParent);
end;

procedure ComponentSaveToXmlStream(AComponent: TComponent; S: TStream;
  AParent: TComponent = nil);
begin
  ObjectSaveToXmlStream(AComponent, S, AParent);
end;

function ComponentSaveToXmlString(AComponent: TComponent; AParent: TComponent = nil): string;
begin
  Result := ObjectSaveToXmlString(AComponent, AParent);
end;

procedure FormSaveToXmlFile(AForm: TForm; const FileName: string);
begin
  ComponentSaveToXmlFile(AForm, FileName, AForm);
end;

procedure FormSaveToXmlStream(AForm: TForm; S: TStream);
begin
  ComponentSaveToXmlStream(AForm, S, AForm);
end;

function FormSaveToXmlString(AForm: TForm): string;
begin
  Result := ComponentSaveToXmlString(AForm, AForm);
end;


{ TsdXmlObjectWriter }

procedure TsdXmlObjectWriter.WriteComponent(ANode: TXmlNode; AComponent,
  AParent: TComponent);
begin
  if not assigned(ANode) or not assigned(AComponent) then exit;
  ANode.Name := AComponent.ClassName;
  if length(AComponent.Name) > 0 then
    ANode.AttributeAdd('Name', AComponent.Name);
  WriteObject(ANode, AComponent, AParent);
end;

procedure TsdXmlObjectWriter.WriteObject(ANode: TXmlNode; AObject: TObject;
  AParent: TComponent);
var
  i, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
  S: TStringStream;
  AWriter: TWriter;
  AChildNode: TXmlNode;
  AComponentNode: TXmlNode;
begin
  if not assigned(ANode) or not assigned(AObject) then exit;

  // If this is a component, store child components
  if AObject is TComponent then with TComponent(AObject) do begin
    if ComponentCount > 0 then begin
      AChildNode := ANode.NodeNew('Components');
      for i := 0 to ComponentCount - 1 do begin
        AComponentNode := AChildNode.NodeNew(Components[i].ClassName);
        if length(Components[i].Name) > 0 then
          AComponentNode.AttributeAdd('Name', Components[i].Name);
        WriteObject(AComponentNode, Components[i], TComponent(AObject));
      end;
    end;
  end;

  // Save all regular properties that need storing
  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
          WriteProperty(ANode, AObject, AParent, PropInfo);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;

  // Save defined properties
  if AObject is TPersistent then begin
    S := TStringStream.Create('');
    try
      AWriter := TWriter.Create(S, 4096);
      try
        THackPersistent(AObject).DefineProperties(AWriter);
      finally
        AWriter.Free;
      end;
      // Do we have data from DefineProperties?
      if S.Size > 0 then begin
        // Yes, add a node with binary data
        ANode.NodeNew('DefinedProperties').BinaryString := S.DataString;
      end;
    finally
      S.Free;
    end;
  end;
end;

procedure TsdXmlObjectWriter.WriteProperty(ANode: TXmlNode; AObject: TObject;
  AParent: TComponent; PropInfo: PPropInfo);
var
  PropType: PTypeInfo;
  AChildNode: TXmlNode;
  ACollectionNode: TXmlNode;

  procedure WritePropName;
  begin
    AChildNode := ANode.NodeNew(PPropInfo(PropInfo)^.Name);
  end;

  procedure WriteInteger(Value: Int64);
  begin
    AChildNode.ValueAsString := IntToStr(Value);
  end;

  procedure WriteString(Value: string);
  begin
    AChildNode.ValueAsString := Value;
  end;

  procedure WriteSet(Value: Longint);
  var
    I: Integer;
    BaseType: PTypeInfo;
    S, Enum: string;
  begin
    BaseType := GetTypeData(PropType)^.CompType^;
    for i := 0 to SizeOf(TIntegerSet) * 8 - 1 do begin
      if i in TIntegerSet(Value) then begin
        Enum := GetEnumName(BaseType, i);
        if i > 0 then
          S := S + ',' + Enum
        else
          S := Enum;
      end;
    end;
    AChildNode.ValueAsString := Format('[%s]', [S]);
  end;

  procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  var
    Ident: string;
    IntToIdent: TIntToIdent;
  begin
    IntToIdent := FindIntToIdent(IntType);
    if Assigned(IntToIdent) and IntToIdent(Value, Ident) then
      WriteString(Ident)
    else
      WriteInteger(Value);
  end;

  procedure WriteCollectionProp(Collection: TCollection);
  var
    i: integer;
  begin
    if assigned(Collection) then begin
      for i := 0 to Collection.Count - 1 do
      begin
        ACollectionNode := AChildNode.NodeNew(Collection.Items[i].ClassName);
        WriteObject(ACollectionNode, Collection.Items[I], AParent);
      end;
    end;
  end;

  procedure WriteOrdProp;
  var
    Value: Longint;
  begin
    Value := GetOrdProp(AObject, PropInfo);
    if not (Value = PPropInfo(PropInfo)^.Default) then begin
      WritePropName;
      case PropType^.Kind of
      tkInteger:     WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value);
      tkChar:        WriteString(Chr(Value));
      tkSet:         WriteSet(Value);
      tkEnumeration: WriteString(GetEnumName(PropType, Value));
      end;
    end;
  end;

  procedure WriteFloatProp;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(AObject, PropInfo);
    if not (Value = 0) then
      ANode.WriteFloat(PPropInfo(PropInfo)^.Name, Value);
  end;

  procedure WriteInt64Prop;
  var
    Value: Int64;
  begin
    Value := GetInt64Prop(AObject, PropInfo);
    if not (Value = 0) then
      ANode.WriteInt64(PPropInfo(PropInfo)^.Name, Value);
  end;

  procedure WriteStrProp;
  var
    Value: string;
  begin
    Value := GetStrProp(AObject, PropInfo);
    if not (length(Value) = 0) then
      ANode.WriteString(PPropInfo(PropInfo)^.Name, Value);
  end;

  procedure WriteObjectProp;
  var
    Value: TObject;
    ComponentName: string;
    function GetComponentName(Component: TComponent): string;
    begin
      if Component.Owner = AParent then
        Result := Component.Name
      else if Component = AParent then
        Result := 'Owner'
      else if assigned(Component.Owner) and (length(Component.Owner.Name) > 0)
        and (length(Component.Name) > 0) then
        Result := Component.Owner.Name + '.' + Component.Name
      else if length(Component.Name) > 0 then
        Result := Component.Name + '.Owner'
      else Result := '';
    end;

  begin
    Value := TObject(GetOrdProp(AObject, PropInfo));
    if not assigned(Value) then exit;
    WritePropName;
    if Value is TComponent then begin
      ComponentName := GetComponentName(TComponent(Value));
      if length(ComponentName) > 0 then
        WriteString(ComponentName);
    end else begin
      WriteString(Format('(%s)', [Value.ClassName]));
      if Value is TCollection then
        WriteCollectionProp(TCollection(Value))
      else begin
        if AObject is TComponent then
          WriteObject(AChildNode, Value, TComponent(AObject))
        else
          WriteObject(AChildNode, Value, AParent)
      end;
      // No need to store an empty child.. so check and remove
      if AChildNode.NodeCount = 0 then
        ANode.NodeRemove(AChildNode);
    end;
  end;

  procedure WriteMethodProp;
  var
    Value: TMethod;
    function IsDefaultValue: Boolean;
    begin
      Result := (Value.Code = nil) or
        ((Value.Code <> nil) and assigned(AParent) and (AParent.MethodName(Value.Code) = ''));
    end;
  begin
    Value := GetMethodProp(AObject, PropInfo);
    if not IsDefaultValue then begin
      if assigned(Value.Code) then begin
        WritePropName;
        if assigned(AParent) then
          WriteString(AParent.MethodName(Value.Code))
        else
          AChildNode.ValueAsString := '???';
      end;