omnixmlpersistent.pas

OmniXML源码

{ $OmniXML: OmniXML/OmniXMLPersistent.pas,v 1.1.1.1 2004/04/17 11:16:33 mr Exp $ }

(*******************************************************************************
* The contents of this file are subject to the Mozilla Public License Version  *
* 1.1 (the "License"); you may not use this file except in compliance with the *
* License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ *
*                                                                              *
* Software distributed under the License is distributed on an "AS IS" basis,   *
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *
* the specific language governing rights and limitations under the License.    *
*                                                                              *
* The Original Code is mr_Storage_XML.pas                                      *
*                                                                              *
* The Initial Developer of the Original Code is Miha Remec,                    *
*   http://www.MihaRemec.com/                                                  *
*                                                                              *
* Contributor(s):                                                              *
*   Miha Vrhovnik (mv)                                                         *
*******************************************************************************)
unit OmniXMLPersistent;

interface

{$I OmniXML.inc}

// if you want to use MS XML parser, uncomment (in your program!!!)
// the following compiler directive {.$DEFINE USE_MSXML}

uses
  Classes, SysUtils,
{$IFDEF COMPLIB_VCL} Controls, {$ENDIF}
  TypInfo,
{$IFDEF COMPILER6_UP} Variants, {$ENDIF}
  OmniXML,
{$IFDEF USE_MSXML} OmniXML_MSXML, {$ENDIF}
  OmniXMLUtils;

type
  TPropsFormat = (pfAuto, pfAttributes, pfNodes);
  EOmniXMLPersistent = class(Exception);

{$IFDEF COMPLIB_CLX}
  TTime = type TDateTime;
  TDate = type TDateTime;
{$ENDIF}

type
  TOmniXMLWriter = class
  protected
    Doc: IXMLDocument;
    procedure WriteProperty(Instance: TPersistent; PropInfo: PPropInfo; Element: IXMLElement);
    procedure InternalWriteText(Root: IXMLElement; Name, Value: String);
    procedure WriteCollection(Collection: TCollection; Root: IXMLElement);
  public
    PropsFormat: TPropsFormat;
    constructor Create(Doc: IXMLDocument; const PropFormat: TPropsFormat = pfAuto);
    class procedure SaveToFile(const Instance: TPersistent; const FileName: String; const PropFormat: TPropsFormat = pfAuto; const OutputFormat: TOutputFormat = ofNone);
    class procedure SaveXML(const Instance: TPersistent; var XML: WideString; const PropFormat: TPropsFormat = pfAuto; const OutputFormat: TOutputFormat = ofNone);
    procedure Write(Instance: TPersistent; Root: IXMLElement; const WriteRoot: Boolean = True; const CheckIfEmpty: Boolean = True);
  end;

  TOmniXMLReader = class
  private
    function FindElement(const Root: IXMLElement; const TagName: String): IXMLElement;
    procedure ReadProperty(Instance: TPersistent; PropInfo: Pointer; Element: IXMLElement);
    function InternalReadText(Root: IXMLElement; Name: String; var Value: WideString): Boolean;
    procedure ReadCollection(Collection: TCollection; Root: IXMLElement);
  public
    PropsFormat: TPropsFormat;
    constructor Create(const PropFormat: TPropsFormat = pfAuto);
    class procedure LoadFromFile(Instance: TPersistent; FileName: String); overload;
    class procedure LoadFromFile(Collection: TCollection; FileName: String); overload;
    class procedure LoadXML(Instance: TPersistent; const XML: WideString); overload;
    procedure Read(Instance: TPersistent; Root: IXMLElement; const ReadRoot: Boolean = False);
  end;

var
  DefaultPropFormat: TPropsFormat = pfNodes;

implementation

const
  COLLECTIONITEM_NODENAME = 'o';  // do not change!
  PROP_FORMAT = 'PropFormat';  // do not change!
  StringS_COUNT_NODENAME = 'Count';  // do not change!
  StringS_PREFIX = 'l';  // do not change!

var
  PropFormatValues: array[TPropsFormat] of String = ('auto', 'attr', 'node');

function IsElementEmpty(Element: IXMLElement; PropsFormat: TPropsFormat): Boolean;
begin
  Result := ((PropsFormat = pfAttributes) and (Element.Attributes.Length = 0)) or
    ((PropsFormat = pfNodes) and (Element.ChildNodes.Length = 0));
end;

procedure CreateDocument(var XMLDoc: IXMLDocument; var Root: IXMLElement; RootNodeName: String);
begin
  XMLDoc := CreateXMLDoc;
  Root := XMLDoc.CreateElement(RootNodeName);
  XMLDoc.DocumentElement := Root;
end;

procedure Load(var XMLDoc: IXMLDocument; var XMLRoot: IXMLElement; var PropsFormat: TPropsFormat);
var
  i: TPropsFormat;
  PropFormatValue: String;
begin
  // set root element
  XMLRoot := XMLDoc.documentElement;
  PropsFormat := pfNodes;

  if XMLRoot = nil then
    Exit;

  PropFormatValue := XMLRoot.GetAttribute(PROP_FORMAT);

  for i := Low(TPropsFormat) to High(TPropsFormat) do begin
    if SameText(PropFormatValue, PropFormatValues[i]) then begin
      PropsFormat := i;
      Break;
    end;
  end;
end;

procedure LoadDocument(const FileName: String; var XMLDoc: IXMLDocument; var XMLRoot: IXMLElement; var PropsFormat: TPropsFormat);
begin
  XMLDoc := CreateXMLDoc;
  { TODO : implement and test preserveWhiteSpace }
  XMLDoc.preserveWhiteSpace := True;
  XMLDoc.Load(FileName);

  Load(XMLDoc, XMLRoot, PropsFormat);
end;

{ TOmniXMLWriter }

class procedure TOmniXMLWriter.SaveToFile(const Instance: TPersistent; const FileName: String; const PropFormat: TPropsFormat = pfAuto; const OutputFormat: TOutputFormat = ofNone);
var
  XMLDoc: IXMLDocument;
  Root: IXMLElement;
  Writer: TOmniXMLWriter;
begin
  if Instance is TCollection then
    CreateDocument(XMLDoc, Root, Instance.ClassName)
  else
    CreateDocument(XMLDoc, Root, 'data');

  Writer := TOmniXMLWriter.Create(XMLDoc, PropFormat);
  try
    if Instance is TCollection then
      Writer.WriteCollection(TCollection(Instance), Root)
    else
      Writer.Write(Instance, Root);
  finally
    Writer.Free;
  end;

{$IFNDEF USE_MSXML}
  XMLDoc.Save(FileName, OutputFormat);
{$ELSE}
  XMLDoc.Save(FileName);
{$ENDIF}
end;

class procedure TOmniXMLWriter.SaveXML(const Instance: TPersistent;
  var XML: WideString; const PropFormat: TPropsFormat;
  const OutputFormat: TOutputFormat);
var
  XMLDoc: IXMLDocument;
  Root: IXMLElement;
  Writer: TOmniXMLWriter;
begin
  if Instance is TCollection then
    CreateDocument(XMLDoc, Root, Instance.ClassName)
  else
    CreateDocument(XMLDoc, Root, 'data');

  Writer := TOmniXMLWriter.Create(XMLDoc, PropFormat);
  try
    if Instance is TCollection then
      Writer.WriteCollection(TCollection(Instance), Root)
    else
      Writer.Write(Instance, Root);
  finally
    Writer.Free;
  end;

  XML := XMLDoc.XML;
end;

constructor TOmniXMLWriter.Create(Doc: IXMLDocument; const PropFormat: TPropsFormat = pfAuto);
begin
  Self.Doc := Doc;
  if PropFormat <> pfAuto then
    PropsFormat := PropFormat
  else
    PropsFormat := DefaultPropFormat;
  Doc.DocumentElement.SetAttribute(PROP_FORMAT, PropFormatValues[PropsFormat]);
end;

procedure TOmniXMLWriter.InternalWriteText(Root: IXMLElement; Name, Value: String);
var
  PropNode: IXMLElement;
begin
  case PropsFormat of
    pfAttributes: Root.SetAttribute(Name, Value);
    pfNodes:
      begin
        PropNode := Doc.CreateElement(Name);
        PropNode.Text := Value;
        Root.appendChild(PropNode);
      end;
  end;
end;

procedure TOmniXMLWriter.WriteCollection(Collection: TCollection; Root: IXMLElement);
var
  i: Integer;
begin
  for i := 0 to Collection.Count - 1 do
    Write(Collection.Items[i], Root, True, False);
end;

procedure TOmniXMLWriter.WriteProperty(Instance: TPersistent; PropInfo: PPropInfo; Element: IXMLElement);
var
  PropType: PTypeInfo;

  procedure WriteStrProp;
  var
    Value: String;
  begin
    Value := GetStrProp(Instance, PropInfo);
    if Value <> '' then
      InternalWriteText(Element, PPropInfo(PropInfo)^.Name, EncodeText(Value));
  end;

  procedure WriteOrdProp;
  var
    Value: Longint;
  begin
    Value := GetOrdProp(Instance, PropInfo);
    if Value <> PPropInfo(PropInfo)^.Default then begin
      case PropType^.Kind of
        tkInteger: InternalWriteText(Element, PPropInfo(PropInfo)^.Name, XMLIntToStr(Value));
        tkChar: InternalWriteText(Element, PPropInfo(PropInfo)^.Name, Chr(Value));
        tkSet: InternalWriteText(Element, PPropInfo(PropInfo)^.Name, GetSetProp(Instance, PPropInfo(PropInfo), True));
        tkEnumeration:
          begin
            if PropType = System.TypeInfo(Boolean) then
              InternalWriteText(Element, PPropInfo(PropInfo)^.Name, XMLBoolToStr(Boolean(Value)))
            else if PropType^.Kind = tkInteger then
              InternalWriteText(Element, PPropInfo(PropInfo)^.Name, XMLIntToStr(Value))
            // 2003-05-27 (mr): added tkEnumeration processing
            else if PropType^.Kind = tkEnumeration then
              InternalWriteText(Element, PPropInfo(PropInfo)^.Name, GetEnumName(PropType, Value));
          end;
      end;
    end;
  end;

  procedure WriteFloatProp;
  var
    Value: Real;
  begin
    Value := GetFloatProp(Instance, PropInfo);
    if Value <> 0 then
      InternalWriteText(Element, PPropInfo(PropInfo)^.Name, XMLRealToStr(Value));
  end;

  procedure WriteDateTimeProp;
  var
    Value: TDateTime;
  begin
    Value := VarAsType(GetFloatProp(Instance, PropInfo), varDate);
    if Value <> 0 then
      InternalWriteText(Element, PPropInfo(PropInfo)^.Name, XMLDateTimeToStrEx(Value));
  end;

  procedure WriteInt64Prop;
  var
    Value: Int64;
  begin
    Value := GetInt64Prop(Instance, PropInfo);
    if Value <> 0 then
      InternalWriteText(Element, PPropInfo(PropInfo)^.Name, XMLInt64ToStr(Value));
  end;

  procedure WriteObjectProp;
  var
    Value: TObject;
    PropNode: IXMLElement;

    procedure WriteStrings(const Strings: TStrings);
    var
      i: Integer;
    begin
      SetNodeAttrInt(PropNode, StringS_COUNT_NODENAME, Strings.Count);
      for i := 0 to Strings.Count - 1 do begin
        if Strings[i] <> '' then
          InternalWriteText(PropNode, StringS_PREFIX + IntToStr(i), EncodeText(Strings[i]));
      end;
    end;
  begin
    Value := TObject(GetOrdProp(Instance, PropInfo));
    if (Value <> nil) and (Value is TPersistent) then begin
      PropNode := Doc.CreateElement(PPropInfo(PropInfo)^.Name);

      // write object's properties
      Write(TPersistent(Value), PropNode, False);
      if Value is TCollection then begin
        WriteCollection(TCollection(Value), PropNode);
        if not IsElementEmpty(PropNode, pfNodes) then
          Element.AppendChild(PropNode);
      end
      else if Value is TStrings then begin
        WriteStrings(TStrings(Value));
        Element.AppendChild(PropNode);
      end
      else if not IsElementEmpty(PropNode, PropsFormat) then
        Element.AppendChild(PropNode);
    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;
      tkString, tkLString, tkWString: WriteStrProp;
      tkFloat:
        if (PropType = System.TypeInfo(TDateTime)) or (PropType = System.TypeInfo(TTime)) or (PropType = System.TypeInfo(TDate)) then
          WriteDateTimeProp
        else
          WriteFloatProp;
      tkInt64: WriteInt64Prop;
      tkClass: WriteObjectProp;
    end;
  end;
end;

procedure TOmniXMLWriter.Write(Instance: TPersistent; Root: IXMLElement; const WriteRoot: Boolean; const CheckIfEmpty: Boolean);
var
  PropCount: Integer;
  PropList: PPropList;
  i: Integer;
  PropInfo: PPropInfo;
  Element: IXMLElement;
begin