optosoapdomconv.pas

Delphi的Soap一些使用功能控件

{*******************************************************}
{                                                       }
{ Borland Delphi Visual Component Library               }
{                 SOAP Support                          }
{                                                       }
{ Copyright (c) 2001-2006 Borland Software Corporation  }
{                                                       }
{*******************************************************}

{ Converts a SOAP RPC request to/from an internal Delphi format using a DOM }

unit OPToSOAPDomConv;

{$IFNDEF VER150}
{$INCLUDE 'CompVer.inc'}
{$ENDIF}

{ NOTE: Enabling FIX_ELEM_NODE_NS introduces new members if class helper support
        is not available. Hence it's only enabled for DEXTER_UP. Earlier versions
        must define FIX_ELEM_NODE_NS explicitly and incur the interface breakage.
        This is a temporary solution in order to resolve a problem with our
        handling of element namespaces without introducing an interface change. }
{$IFDEF DEXTER_UP}
  {$DEFINE FIX_ELEM_NODE_NS}
{$ENDIF}

{$IFNDEF NO_FASTER_CONVERTER}
  {$DEFINE FASTER_CONVERTER}
{$ENDIF}

{$IFDEF HIGHLANDER_UP}
  {$DEFINE CONST_WIDESTRING_PARAMS}
{$ENDIF}
  
interface

uses SysUtils, Variants, TypInfo, Classes, xmldom, XMLDoc, IntfInfo, InvokeRegistry,
     XMLIntf, OPConvert, WSDLNode, SOAPEnv, SOAPDomConv, Types, XSBuiltIns, SOAPAttachIntf,
     Contnrs;

const
  SVarArrayType = 'VarArrayType';     { do not localize }

type

  ESOAPDomConvertError = class(Exception);

  TSOAPArrayElemDesc = record
    MultiDim: Boolean;
    Dims: TIntegerDynArray;
  end;
  TSOAPArrayDesc = array of TSOAPArrayElemDesc;

  TMultiRefNodeMapElem = record
    Instance: Pointer;
    ID: string;
  end;
  TMultiRefNodeMap = array of TMultiRefNodeMapElem;

{$IF defined(HIGHLANDER_UP) and defined(FASTER_CONVERTER)}
  TRefCache = class(TObject)
  private
    FNodes: IInterfaceList;
    FHREFs: TStringList;
    FMHREFs: TStringList;
  public
    constructor Create;
    destructor Destroy; override;
  end;
{$IFEND}

  TXMLNodeArray  = array of IXMLNode;
  TMultiRefNodeElem = record
    Node: IXMLNode;
    MultiRefChildren: TXMLNodeArray;
  end;
  TMultiRefNodes = array of TMultiRefNodeElem;

  ConvNodeState = (nsClientSend, nsServerReceive, nsServerSend, nsClientReceive);

  TMemberDataNotReceivedEvent = procedure(const ClassName: string; const Member: string) of object;
  TUnhandledNodeEvent  = procedure(const Name: string; NodeXML: WideString) of object;

  TSOAPDomConv = class(TSOAPDOMProcessor, IObjConverter)
  private
    FIDs: Integer;
    FAttachments: TSoapDataList;
{ The code from the FASTER_CONVERTER was kindly provided in QC-26063. It greatly improves
  performace when serializing multiref objets and arrays. }
{$IF defined(HIGHLANDER_UP) and defined(FASTER_CONVERTER)}
    FRefCache: TRefCache;
{$ELSE}
    RefMap: TMultiRefNodeMap;
{$IFEND}
    MultiRefNodes: TMultiRefNodes;
    FOptions: TSOAPConvertOptions;
    ObjsWriting: array of TObject;
    FOnMemberDataNotReceived: TMemberDataNotReceivedEvent;
    FOnUnhandledNode: TUnhandledNodeEvent;
{$IF not defined(DEXTER_UP) and defined(FIX_ELEM_NODE_NS)}
    FElemNodeNamespace: InvString;
    FUnqualifiedElement: Boolean;
    FObjectMetaclass: TClass;
    FObjectInstance: TObject;
{$IFEND}
  protected
    procedure AddAttachment(Attachment: TSOAPAttachment; const AContentId: string);
    function  FindAttachment(const AContentId: string): TSOAPAttachment;

    procedure ReadHeader(const EnvNode, HdrNode: IXMLNode; Headers: THeaderList);
    procedure WriteHeader(const Header: TObject; RootNode, ParentNode: IXMLNode);

    function  NodeIsNULL(Node: IXMLNode): Boolean;
    function  ChildNodesAreNull(Node: IXMLNode): Boolean;
    function  CreateNULLNode(RootNode, ParentNode: IXMLNode; const Name: InvString; UseParentNode: Boolean = False): IXMLNode;
    function  GetNewID: string;
    function  FindPrefixForURI(RootNode, Node: IXMLNode; const URI: InvString; DeclIfNone: Boolean = False): InvString;
    function  AddNamespaceDecl(Node: IXMLNode; const URI: InvString): InvString;
    function  GetElementType(Node: IXMLNode; var TypeURI, TypeName: InvString): Boolean;
    function  CreateScalarNodeXS(RootNode, ParentNode: IXMLNode;  const NodeName, URI, TypeName: WideString; const Value: WideString; GenPre: Boolean = False): IXMLNode;
    function  GetTypeBySchemaNS(Node: IXMLNode; const URI: InvString): Variant;
{$IFDEF CONST_WIDESTRING_PARAMS}
    function  CreateTypedNode(RootNode, ParentNode: IXMLNode; const NodeName, URI, TypeName: WideString; GenPre: Boolean = False): IXMLNode;
{$ELSE}
    function  CreateTypedNode(RootNode, ParentNode: IXMLNode; const NodeName, URI: WideString; TypeName: WideString; GenPre: Boolean = False): IXMLNode;
{$ENDIF}
    procedure SetNodeType(RootNode, InstNode: IXMLNode; const ElemURI, TypeName: InvString);
    function  GetNodeAsText(Node: IXMLNode): InvString;
    function  GetDataNode(RootNode, Node: IXMLNode; var ID: InvString): IXMLNode;
    procedure CheckEncodingStyle(Node: IXMLNode);
    { Methods to handle mutli-referenced nodes }
    procedure AddMultiRefNode(const ID: string; Instance: Pointer);
    function  FindMultiRefNodeByInstance(Instance: Pointer): string;
    function  FindMultiRefNodeByID(const ID: string): Pointer;
    function  CreateMultiRefNode(RootNode: IXMLNode; const Name, ID: InvString): IXMLNode;
    procedure FinalizeMultiRefNodes;
    function  FindNodeByHREF(RootNode: IXMLNode; const HREF: InvString): IXMLNode;
    procedure AddObjectAsWriting(Instance: TObject);
    procedure RemoveObjectAsWriting(Instance: TObject);
    function  IsObjectWriting(Instance: TObject): Boolean;
    procedure ResetMultiRef;
    { Methods to handle Variants }
    procedure ConvertVariantToSoap(RootNode, Node: IXMLNode;
              const Name: InvString; Info: PTypeInfo; P: PVarData; NumIndirect: Integer; V: Variant; UseVariant: Boolean);
    procedure ConvertSoapToVariant(Node: IXMLNode; InvData: Pointer);
    function  IsNodeAVarArray(const Node: IXMLNode; var VT: TVarType): Boolean;
    procedure WriteVarArray(RootNode, Node: IXMLNode; const Name: InvString; V: Variant);
    procedure WriteVariant(RootNode, Node: IXMLNode; const Name: InvString; V: Variant);
    procedure ReadVariant(Node: IXMLNode; P: Pointer);
    function  ReadVarArrayDim(Node: IXMLNode; IsVarVArray: Boolean = False; VT: TVarType = 0): Variant;
    procedure WriteVarArrayAsB64(RootNode, Node: IXMLNode; const Name: InvString; V: Variant);
    { Methods to handle native delphi array types }
    function  MakeArrayNode(RootNode, Node: IXMLNode; const Name, URI, TypeName: InvString;
                            Indices: array of Integer): IXMLNode; overload;
    function  MakeArrayNode(RootNode, Node: IXMLNode; const Name, URI, TypeName: InvString;
                            Dim, Len: Integer): IXMLNode; overload;
    procedure ConvertNativeArrayToSoap(RootNode, Node: IXMLNode;
               const Name: InvString; Info: PTypeInfo; P: Pointer; NumIndirect: Integer; InlineElements: Boolean = False);
    procedure WriteNonRectDynArray(RootNode, Node: IXMLNode; const Name: InvString; Info: PTypeInfo; const URI, TypeName: InvString; P: Pointer; Dim: Integer);
    function  WriteNonRectDynArrayElem(RootNode, Node: IXMLNode;  Info: PTypeInfo; const URI, TypeName: InvString; P: Pointer; Dim: Integer): Integer;
    function  ConvertSoapToNativeArray(DataP: Pointer;  TypeInfo: PTypeInfo;
                                       RootNode, Node: IXMLNode): Pointer;
    function  ConvertSoapToNativeArrayElem(ArrayInfo, ElemInfo: PTypeInfo;
                                           RootNode, Node: IXMLNode; ArrayDesc: TSOAPArrayDesc;
                                           Dims, CurDim: Integer; DataP: Pointer): Pointer;
    procedure ConvertByteArrayToSoap(RootNode, Node: IXMLNode; const Name: InvString;
                                     Info: PTypeInfo; P: Pointer);
    procedure WriteRectDynArrayElem(RootNode, Node: IXMLNode; Info: PTypeInfo; Size, Dim: Integer; P: Pointer; const TypeName: InvString);
    procedure WriteRectDynArray(RootNode, Node: IXMLNode; Info: PTypeInfo; Dims: Integer; P: Pointer; const TypeName: InvString);
    procedure ReadRectDynArray(RootNode, Node: IXMLNode; Info: PTypeInfo; Dims: Integer; P: Pointer; CurElem: Integer);
    procedure ReadRectDynArrayElem(RootNode, Node: IXMLNode; Info: PTypeInfo; Size, Dim: Integer; P: Pointer; var CurElem: Integer);
    procedure ReadRow(RootNode, Node: IXMLNode; var CurElem: Integer; Size: Integer; P: Pointer; Info: PTypeInfo);
    { Enums }
    function  ConvertEnumToSoap(Info: PTypeInfo; P: Pointer; NumIndirect: Integer): InvString;
{$IFDEF CONST_WIDESTRING_PARAMS}
    function  ConvertSoapToEnum(Info: PTypeInfo; const S: InvString; IsNull: Boolean): Integer;
{$ELSE}
    function  ConvertSoapToEnum(Info: PTypeInfo; S: InvString; IsNull: Boolean): Integer;
{$ENDIF}

    { Methods that handle TObjects with RTTI }
    function  MultiRefObject(Cls: TClass): Boolean;
    function  SerializationOptions(Cls: TClass): TSerializationOptions; overload;
    function  SerializationOptions(ATypeInfo: PTypeInfo): TSerializationOptions; overload;
    function  SerializationOptions(Obj: TObject): TSerializationOptions; overload;
    procedure ConvertObjectToSOAP(const Name: InvString; ObjP: Pointer; RootNode, Node: IXMLNOde; NumIndirect: Integer);
    function  ConvertSOAPToObject(RootNode, Node: IXMLNode;
              AClass: TClass; const URI, TypeName: WideString; ObjP: Pointer; NumIndirect: Integer): TObject;

    function  CreateObjectNode(Instance: TObject; RootNode, ParentNode: IXMLNode;
                               const Name, URI: InvString; ObjConvOpts: TObjectConvertOptions): InvString;
    function  ObjInstanceToSOAP(Instance: TObject; RootNode, ParentNode: IXMLNode;
                               const NodeName, NodeNamespace: InvString; ObjConvOpts: TObjectConvertOptions;
                               out RefID: InvString): IXMLNode;
    procedure LoadObject(Instance: TObject; RootNode, Node: IXMLNode);
    procedure InitObjectFromSOAP(Instance: TObject; RootNode, Node: IXMLNode);
    procedure ObjectMemberNoShow(const ClassName: string; const MemberName: string);
    procedure UnhandledNode(const Name: string; NodeXML: WideString);

    procedure SetObjectPropFromText(Instance: TObject; PropInfo: PPropInfo; const SoapData: WideString);
    function  GetObjectPropAsText(Instance: TObject; PropInfo: PPropInfo): WideString;

    function  GetOptions: TSOAPConvertOptions;
    procedure SetOptions(const Value: TSOAPConvertOptions);

{$IF not defined(DEXTER_UP) and defined(FIX_ELEM_NODE_NS)}
    procedure SetNodeTypeEx(RootNode, InstNode: IXMLNode; const ElemURI, TypeName: InvString; Forced: Boolean);
    function  HasMultipleElemNamespaces(const ClsType: TClass; out PropNamespaces: TWideStringDynArray;
                                        out PropNamespaceIndex: TIntegerDynArray): Boolean;

    property ElemNodeNamespace: InvString read FElemNodeNamespace write FElemNodeNamespace;
    property UnqualifiedElement: Boolean read FUnqualifiedElement write FUnqualifiedElement;
    property ObjectMetaclass: TClass read FObjectMetaclass write FObjectMetaclass;
    property ObjectInstance: TObject read FObjectInstance write FObjectInstance;
{$IFEND}

 public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ConvertNativeDataToSoap(RootNode, Node: IXMLNode;
                 const Name: InvString; Info: PTypeInfo; P: Pointer; NumIndirect: Integer); dynamic;
    procedure ConvertSoapToNativeData(DataP: Pointer; TypeInfo: PTypeInfo;
                 Context: TDataContext; RootNode, Node: IXMLNode; Translate, ByRef: Boolean; NumIndirect: Integer); dynamic;
  published
{$IFDEF DEXTER_UP}
    property Options: TSOAPConvertOptions read FOptions write FOptions default [soSendMultiRefObj, soTryAllSchema];
{$ELSE}
    property Options: TSOAPConvertOptions read FOptions write FOptions;
{$ENDIF}
    property OnMemberDataNotReceived: TMemberDataNotReceivedEvent read FOnMemberDataNotReceived write FOnMemberDataNotReceived;
    property OnUnhandledNode: TUnhandledNodeEvent read FOnUnhandledNode write FOnUnhandledNode;
  end;

  TOPToSoapDomConvert = class(TSOAPDomConv, IOPConvert)
  private
    FWSDLView: TWSDLView;
    FTempDir:  string;
    Envelope:  TSoapEnvelope;
    FEncoding: WideString;
    function   GetSoapNS(MD: TIntfMetaData): InvString;
    procedure  DOMToStream(const XMLDoc: IXMLDocument; Stream: TStream);
    procedure  ProcessFault(FaultNode: IXMLNode);
    procedure  ProcessSuccess(RespNode: IXMLNode; const IntfMD: TIntfMetaData;
                              const MD: TIntfMethEntry; InvContext: TInvContext);
    function   GetPartName(MethMD: TIntfMetaData; const ParamName: InvString): InvString;
    procedure  CheckWSDL;
    function   GetBinding: InvString;
    procedure  SetWSDLView(const WSDLView: TWSDLView);
    function   GetAttachments: TSoapDataList; virtual;
    procedure  SetAttachments(Value: TSoapDataList); virtual;
    function   GetTempDir: string; virtual;
    procedure  SetTempDir(const Value: string); virtual;
    function   GetEncoding: WideString;
    procedure  SetEncoding(const Encoding: WideString);
  protected
    function   NewXMLDocument: IXMLDocument;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    property    Attachments: TSOAPDataList read GetAttachments write SetAttachments;
    { IOPConvert }
    procedure MsgToInvContext(const Request: InvString; const IntfMD: TIntfMetaData;
                              var MethNum: Integer; Context: TInvContext); overload; virtual;
    procedure MsgToInvContext(const Request: TStream; const IntfMD: TIntfMetaData;
                              var MethNum: Integer; Context: TInvContext;
                              Headers: THeaderList); overload; virtual;
    function  InvContextToMsg(const IntfMD: TIntfMetaData;
                              MethNum: Integer;
                              Con: TInvContext;
                              Headers: THeaderList): TStream;
    procedure MakeResponse(const IntfMD: TIntfMetaData;
                              const MethNum: Integer;
                              Context: TInvContext;
                              Response: TStream;
                              Headers: THeaderLIst); virtual;
    procedure MakeFault(const Ex: Exception; EStream: TStream); virtual;
    procedure ProcessResponse(const Resp: InvString;
                              const IntfMD: TIntfMetaData;
                              const MD: TIntfMethEntry;
                              Context: TInvContext); overload; virtual;
    procedure ProcessResponse(const Resp: TStream;
                              const IntfMD: TIntfMetaData;
                              const MD: TIntfMethEntry;
                              Context: TInvContext;
                              Headers: THeaderList); overload; virtual;

    { Helper routine }
    procedure ProcessResponse(const XMLDoc: IXMLDocument;
                              const IntfMD: TIntfMetaData;
                              const MD: TIntfMethEntry;
                              Context: TInvContext;
                              Headers: THeaderList); overload; virtual;
  published
    property WSDLView: TWSDLView read FWSDLView write SetWSDLView;
    property TempDir: string read GetTempDir write SetTempDir;
    property Encoding: WideString read GetEncoding write SetEncoding;
  end;

function GetOrdPropEx(Instance: TObject; PropInfo: PPropInfo): Longint;

var
  DefArrayElemName: string = 'item';    { do not lcoalize }

implementation

uses
{$IFDEF MSWINDOWS}
  Windows, ComObj,
{$ENDIF}
EncdDecd, SOAPConst, InvRules, TypeTrans, OPToSOAPDomCustom, VarUtils, StrUtils,
  WSDLBind, XMLSchema, HTTPUtil, WSDLItems, SOAPAttach
  {$IFDEF MSWINDOWS}, msxmldom{$ENDIF};

type

  { Add access to CacheFile : no data members! }

  TConvertAttachment = class(TSOAPAttachment)
    procedure SetCacheFile(const Value: string);
  end;

  { This is a hack allowing us to store additional data
    in the SOAPDomConverter without making an interface change. }
  TSoapDataListEx = class(TSoapDataList)
    FElemNodeNamespace: InvString;
    FUnqualifiedElem: Boolean;
    FObjectMetaclass: TClass;
    FObjectInstance: TObject;
  end;

{$IF not defined(HIGHLANDER_UP) and defined(FASTER_CONVERTER)}
  TRefCache = class(TObject)
  private
    FNodes: IInterfaceList;
    FHREFs: TStringList;
    FMHREFs: TStringList;
  public
    constructor Create;
    destructor Destroy; override;
  end;
{$IFEND}

  ArrayOfInteger = array of Integer;

{$IF defined(DEXTER_UP) and defined(FIX_ELEM_NODE_NS)}
  { Helper to access element node namespace property }
  TSOAPDomConvHelper = class helper for TSOAPDomConv
  protected
    procedure SetNodeTypeEx(RootNode, InstNode: IXMLNode; const ElemURI, TypeName: InvString; Forced: Boolean);
    function  HasMultipleElemNamespaces(const ClsType: TClass; out PropNamespaces: TWideStringDynArray;
                                        out PropNamespaceIndex: TIntegerDynArray): Boolean;

    function  GetElementNamespace: InvString;
    procedure SetElementNamespace(const ANamespace: InvString);
    function  GetUnqualifiedElement: Boolean;
    procedure SetUnqualifiedElement(Flag: Boolean);
    function  GetObjectMetaclass: TClass;
    procedure SetObjectMetaclass(const Cls: TClass);
    function  GetObjectInstance: TObject;