xmlworks2.pas

delphi的XMPRPC通讯例子

unit XMLWorks2;

{
  XMLWorks2

  Version   : 2.5 devel
  Date      : 8/05/2002
    
  Descripton:
  For Latest Versions:
          http://www.DelphiHome.com/xml (North America)
          http://www.XMLWorks.de (German Mirror)


  Author: Marc Bir
          http://www.DelphiHome.com
          [e-mail]


  Author: Thomas Weinert (subjective)
          http://www.subjective.de
          [e-mail]

  Author: Sancho Fock (thsfock)
          www.thsfock.de
          [e-mail]

  Thanks to:
    Chad Hower
      www.AtoZedSoftware.com
     
      
          
  Major Additions to Version 2

  - Correctly supports nested elements of the same name
  - Added Several new objects, support for IXMLWorksObject interface
  - Reorganized code to allow quick creation of new custom objects for streaming
  - Added support for Interfaced Properties
  - Fixed Variant Support
  - Changed ancestor of XMLObject to TObject
  - Supports Delphi through Version 6



  Description

    XMLWorks is a collection of OpenSource utilities designed to help Delphi developers create XML
    documents.

    XMLWorks is in no way designed to be an all encompassing package for XML, but it does offer
    many features that should help Delphi developers working with XML.

    The basic idea behind XMLWorks is to use Delphi Objects to generate DTD and entity
    information.  All you have to do is create a descendant class of one of the XML classes creating
    published properties for the data you want converted to XML.  To convert back from XML the 
    property
    must not be read only.

    In general you don't need to do more than declare a descendant class of TXMLCollection named
    something like TAuthorCollection.  When generating the DTD it will automatically use the name
    'Author' (whatever text is between the 'T' and 'Collection') + '-list'.

    Most of the classes have basic rules for how the class name translates to a tag name, however 
    this default behaviour can be changed by overriding the class function getTagName.
    
}




interface
uses
    Classes     // TPersistent
  , SysUtils    // Exceptions
  , Graphics    // TColor utilities
  , TypInfo;    // RTTI Stuff


type

{:
 We must turn TypeInfo on here to ensure all classes or created with RTTI (otherwise TInterfacedXMLObject would not)
 RTTI Data is the foundation of XMLWorks
}

{$TYPEINFO ON}


{:  
  XMLString is a special type that tells the streaming mechanism not to encode the contents.
} 
  XMLString = type ansistring;

{:  
  XMLString is a special type that tells the streaming mechanism to use MIME encoding.
} 
  XMLMIMEString = type ansistring;

{:  
  XMLRGBTColor is a special type that tells the streaming mechanism to use HEX encoding and to swap 
  the R and B values.  This allows users to edit the XML using standard RGB values, and programmers
  to directly use the value as a TColor.
} 
  XMLRGBTColor = type integer;

  IXMLWorksObject = interface (IUnknown)
    ['{FF809F5B-0856-4BFB-A1D0-7271DFD306A5}']
    function getDTDElements: string;
    function getDTDSequence: string;
    function GetElementText: string;
    function GetXML: string;
    procedure LoadFromFile(FileName:string);
    procedure SaveToFile(FileName:string);
    procedure SetElementText(const p_sXML: string);
    procedure SetXML(const p_sXML: string);
    property ElementText: string read GetElementText write SetElementText;
    property XML: string read GetXML write SetXML;
  end;
  
  TXMLInterfacedObject = class (TInterfacedObject, IXMLWorksObject)
  protected
    function GetElementText: string; virtual;
    function GetXML: string;
    procedure SetElementText(const p_sXML: string); virtual;
    procedure SetXML(const p_sXML: string);
  public
    constructor Create(p_sXML: String = ''); overload; virtual;
    function getDTDElements: string;
    function getDTDSequence: string;
    class function getTagName: string; virtual;
    procedure LoadFromFile(FileName:string);
    procedure SaveToFile(FileName:string);
    property ElementText: string read GetElementText write SetElementText;
    property XML: string read GetXML write SetXML;
  end;
  
  TXMLObject = class (TObject)
  protected
    function GetElementText: string; virtual;
    function GetXML: string;
    procedure SetElementText(const p_sXML: string); virtual;
    procedure SetXML(const p_sXML: string);
  public
    constructor Create(p_sXML: String = ''); overload; virtual;
    function GetDTD: string;
    function getDTDElements: string;
    function getDTDSequence: string;
    class function getTagName: string; virtual;
    procedure LoadFromFile(FileName:string);
    procedure SaveToFile(FileName:string);
    property ElementText: string read GetElementText write SetElementText;
    property XML: string read GetXML write SetXML;
  end;
  
  TXMLList = class (TStringList)
  protected
    function GetElementText: string; virtual;
    function GetXML: string;
    procedure SetElementText(const p_sXML: string); virtual;
    procedure SetXML(const p_sXML: string);
  public
    function getDTDElements: string;
    function getDTDSequence: string;
    class function getItemTagName: string; virtual;
    class function getTagName: string; virtual;
    property ElementText: string read GetElementText write SetElementText;
    property XML: string read GetXML write SetXML;
  end;
  
  TXMLCollectionItem = class (TCollectionItem)
  protected
    function GetElementText: string; virtual;
    function GetXML: string;
    function getXMLAsProperties: string;
    procedure SetElementText(const p_sXML: string); virtual;
    procedure SetXML(const p_sXML: string);
  public
    function getDTDElements: string;
    function getDTDSequence: string;
    class function getTagName: string; virtual;
    property ElementText: string read GetElementText write SetElementText;
    property XML: string read GetXML write SetXML;
  end;
  

  TXMLCollectionItemClass = class of TXMLCollectionItem;
  TCollectionStringCompare = function (const Value: String; const Item2: TXMLCollectionItem): Integer;
  TCollectionIntegerCompare = function (const Value: Integer; const Item2: TXMLCollectionItem): Integer;
  TXMLCollection = class (TCollection)
  protected
    function GetElementText: string; virtual;
    function GetXML: string; 
    function GetXMLCollectionItem(Index:Integer): TXMLCollectionItem;
    procedure SetElementText(const p_sXML: string); virtual;
    procedure SetXML(const p_sXML: string);
    procedure SetXMLCollectionItem(Index:Integer; Value: TXMLCollectionItem);
  public
    constructor Create(ItemClass: TXMLCollectionItemClass); virtual;
    function Add: TXMLCollectionItem;
    function FindInt(Value: Integer; Compare: TCollectionIntegerCompare): 
            TXMLCollectionItem;
    function FindStr(Value: String; Compare: TCollectionStringCompare): 
            TXMLCollectionItem;
    function getDTDElements: string;
    function getDTDSequence: string;
    function getItemTagName: string; virtual;
    function getPropertiesXML: string;
    function getSubsetElementText(Start, Ct: Integer): string;
    class function getTagName: string; virtual;
    procedure LoadFromFile(FileName:string);
    procedure SaveToFile(FileName:string);
    procedure Sort(Compare: TListSortCompare);
    property ElementText: string read GetElementText write SetElementText;
    property Items[Index:Integer]: TXMLCollectionItem read GetXMLCollectionItem 
            write SetXMLCollectionItem; default;
    property XML: string read GetXML write SetXML;
  end;
  

  EXMLException = class (Exception)
  end;
  
  EXMLInterfaceException = class (EXMLException)
  end;
  
  EXMLIOException = class (EXMLException)
  end;
  


function ObjectToXMLElements(const aObject:TObject): String;
function ObjectToXMLProperties(const aObject:TObject): String;

function StrToXML(const p_sXML:string):string;
function XMLtoStr(const p_sXML:string):string;

function getTagContent(const p_sXML, TargetTagName: String): string;

procedure setPropAsString(Instance: TObject; PropInfo: PPropInfo; const value : 
        string);

procedure SaveStringToFile(const Str, FileName:string);

const
  kernel = 'kernel32.dll';

function InterlockedIncrement(var Addend: Integer): Integer; stdcall;
  external kernel name 'InterlockedIncrement';

function InterlockedDecrement(var Addend: Integer): Integer; stdcall;
  external kernel name 'InterlockedDecrement';

function getPropertyList(const ClassInfo: Pointer): TList;

function getObjectDTDElements(const aObject:TObject): string;

function getObjectDTDSequence(const aObject:TObject): string;

function LoadStringFromFile(const FileName:string): string;

procedure setXMLObject(Instance: TObject; p_sXML: AnsiString);

function InterfaceToXML(Unk : IUnknown): string;

procedure XMLtoInterface(pXML : string; unk : IUnknown);

function FastParseTag(const Source,Start,Stop:AnsiString;var Index:Integer): 
        AnsiString;

function FastParseTagXML(const Source, Tag : AnsiString;var Index:Integer):
        AnsiString;

function FastParse(const Source: AnsiString; const Delim: Char; var Index:
        Integer): AnsiString;

function FastToken(const Source: AnsiString; const Delim: Char; Index:
        Integer): AnsiString;

function SwapRandB(inRGB: XMLRGBTColor): TColor;

function LoadStringFromStream(Stream:TStream): string;

procedure SaveStringToStream(const Str:string; Stream:TStream);

var
  // Global Boolean specifies the sort order of generated XML strings, False uses the declared order
  gb_XMLAlphaSortProperties : Boolean = true;
  // Global Boolean causes an exception to be raised when generating XML for a class property that is not supported
  gb_XMLRaiseInvalidPropertyClass : Boolean = false;


implementation

uses
   Windows     // RGB
  , FastStrings
  , FastStringFuncs
  , XMLVariants;


const
{MMWIN:ENDEXPAND}
  cs_XMLPrologTag = '?xml version = "1.0"?';
  cs_XMLProlog = '<' + cs_XMLPrologTag + '>';
  cs_XMLLIST_itemTagName = 'value';
  cs_CDATA_Descriptor = '<![CDATA[';
  cs_CDATA_Descriptor_Close = ']]>';
  cs_DocTypeHeader = '<!DOCTYPE ';
  cs_DocTypeHeader_Close = ']>';
  cs_ElementHeader = '<!ELEMENT ';

{MMWIN:STARTEXPAND}

function SwapRandB(inRGB: XMLRGBTColor): TColor;
asm
  BSwap EAX
  ShR   EAX, 8
end;

{:

}
function getPropertyList(const ClassInfo: Pointer): TList;
var
  i, iPropCount: integer;
  PropList: PPropList;
begin
  result := TList.Create;
  try
    iPropCount := GetTypeData(ClassInfo)^.PropCount;
    if iPropCount > 0 then
    begin
      GetMem(PropList, iPropCount * SizeOf(Pointer));
      try
        iPropCount := GetPropList(ClassInfo, tkProperties, PropList);

        if gb_XMLAlphaSortProperties then
        begin // Alpha Order
          for i := 0 to (iPropCount-1) do
            result.Add(PropList^[i]);
        end
        else // Declared Order
        begin
          result.Count := iPropCount;
          { TODO : Weird issue to work around... needs more research }
          for i := 0 to (iPropCount-1) do
            if (PropList^[i].NameIndex > result.Count-1) then
              result.Count := PropList^[i].NameIndex+1;

          for i := 0 to (iPropCount-1) do
            Result[PropList^[i].NameIndex] := (PropList^[i]);

          for i := result.Count-1 downto 0 do
            if not assigned(result[i]) then
              result.Delete(i);


        end;

      finally
        FreeMem(PropList);
      end;
    end;
  except
    Result.Free;
    Raise
  end;
end;

function StrToXML(const p_sXML:string):string;
const
  ValidCharTable = (['a'..'z','A'..'Z','0'..'9','-',' ',',','.','\','/','_','[',']','!',';',':','=']);
var
  c : char;
  i : integer;
begin
  result := p_sXML;
  for i := Length(result) downto 1 do
  begin
    c := result[i];
    if not (c in ValidCharTable)  then
    begin
      result[i] := '&';
      Insert('#x' + IntToHex(Ord(c),2) + ';', result,i+1);
    end;
  end;
end;

function XMLToStr(const p_sXML:string): string;
var
  hexno : string;
  i, h : integer;
begin
  Result := p_sXML;
  if AnsiSameText(Copy(Result, 0, 9), cs_CDATA_Descriptor) then
  begin
    // Trims the Open and close tags off the string and returns it. 
    Delete(Result, 1, 9);
    Delete(Result, Length(Result)-2, 3);
    exit;
  end;

  for i := Length(Result)-5 downto 1 do begin
    if (Result[i] = '&') and (Length(Result) >= i+5) then
    begin
      if (Result[i+1] = '#') and (Result[i+2] = 'x') then
      begin
        hexno := Result[i+3]+Result[i+4];
        // Must add '0x' to force Hex type, otherwise StrToInt assumes base 10
        h := StrToInt('0x' + hexno);
        Delete(Result, i, 5);
        Result[i] := chr(h);
      end;
    end;
  end;
  Result := Trim(Result);
end;

{: 
  AssignIntf/GetIntfProp are here to provide the most basic access to
  published properties and should be immediately suspect if you are having any
  problems with XML classes that have published interfaces.  Although no known 
  issues have surfaced as of yet.  NOTE: This has only been tested with Delphi
  5 and 6
}

procedure AssignIntf(var Dest: IUnknown; const Source: IUnknown);
begin
  Dest := Source;
end;

function GetIntfProp(Instance: TObject; PropInfo: PPropInfo): IUnknown;
asm
        { ->    EAX Pointer to instance         }
        {       EDX Pointer to property info    }
        {       ECX Pointer to result interface }

        PUSH    ESI
        PUSH    EDI
        MOV     EDI,EDX

        MOV     EDX,[EDI].TPropInfo.Index       { pass index in EDX }
        CMP     EDX,$80000000
        JNE     @@hasIndex
        MOV     EDX,ECX                         { pass value in EDX }
@@hasIndex:
        MOV     ESI,[EDI].TPropInfo.GetProc
        CMP     [EDI].TPropInfo.GetProc.Byte[3],$FE
        JA      @@isField
        JB      @@isStaticMethod

@@isVirtualMethod:
        MOVSX   ESI,SI                          { sign extend slot offset }
        ADD     ESI,[EAX]                       { vmt + slot offset }
        CALL    DWORD PTR [ESI]
        JMP     @@exit

@@isStaticMethod:
        CALL    ESI
        JMP     @@exit

@@isField:
  AND  ESI,$00FFFFFF
  ADD  EAX, ESI
  MOV  EDX,[EAX]
  MOV  EAX, ECX

  CALL  AssignIntf

@@exit:
        POP     EDI
        POP     ESI
end;

function InterfaceToXML(Unk : IUnknown): string;
var
  Intf : IXMLWorksObject;
begin
  if Assigned(Unk) then
  begin
    Unk.QueryInterface(IXMLWorksObject, Intf);
    if assigned(Intf) then
      result := Intf.ElementText
//    else if gb_XMLRaiseInvalidPropertyClass then 
//      raise EXMLInterfaceException.Create('Invalid Interface Property (' + PropInfo.Name + ')');
  end
end;

procedure XMLtoInterface(pXML : string; unk : IUnknown);
var
  Intf : IXMLWorksObject;
begin
  if Assigned(Unk) then
  begin
    Unk.QueryInterface(IXMLWorksObject, Intf);
    if assigned(Intf) then
      Intf.ElementText := pXML;
  end
end;


function GetPropAsString(const Instance: TObject; const PropInfo: PPropInfo): string;
var
  ObjectProp : TObject;
  Intf: IXMLWorksObject;

begin
  result := '';
  case PropInfo^.PropType^.Kind of
    tkString,
    tkLString,
    tkWString:
      if AnsiSameText(PropInfo^.PropType^.Name, 'XMLString') then
        result := GetStrProp(Instance, PropInfo)
      else if AnsiSameText(PropInfo^.PropType^.Name, 'XMLMIMEString') then
        result := Base64Encode(GetStrProp(Instance, PropInfo))
      else
        result := StrToXML(GetStrProp(Instance, PropInfo));

    tkInt64: result := IntToStr(GetInt64Prop(Instance, PropInfo));
    tkSet,
    tkInteger: 
      if AnsiSameText(PropInfo^.PropType^.Name, 'XMLRGBTColor') then
        result := '$' + IntToHex(SwapRandB(GetOrdProp(Instance, PropInfo)), 6)
      else
        result := IntToStr(GetOrdProp(Instance, PropInfo));
    tkFloat:
      if AnsiSameText(PropInfo^.PropType^.Name, 'TDateTime') then
        result := DateTimeToStr(GetFloatProp(Instance, PropInfo))
      else if AnsiSameText(PropInfo^.PropType^.Name, 'TTime') then
        result := TimeToStr(GetFloatProp(Instance, PropInfo))
      else if AnsiSameText(PropInfo^.PropType^.Name, 'TDate') then
        result := DateToStr(GetFloatProp(Instance, PropInfo))
      else
        result := FloatToStr(GetFloatProp(Instance, PropInfo));
    tkVariant: result := VariantToXML(GetVariantProp(Instance, PropInfo));
    tkChar,
    tkWChar: result := StrToXML(Chr(GetOrdProp(Instance, PropInfo)));