optosoapdomconv.pas

Delphi开发webservice的一套例子

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

{
  converts a SOAP RPC request to/from an internal Delphi format using a DOM
}
unit OPToSoapDomConv;

interface

uses SysUtils,  Variants, TypInfo, Classes, XMLDOM, XMLDoc,  IntfInfo, InvokeRegistry,
     XMLIntf, OPConvert, WSDLNode, SoapEnv, SOAPDomConv, Types;

type

  ESOAPDomConvertError = class(Exception);

  {Already defined in TYPES.PAS}
  {TIntegerDynArray = array of Integer;}
  TSOAPArrayElemDesc = record
    MultiDim: Boolean;
    Dims: TIntegerDynArray;
  end;
  TSOAPArrayDesc = array of TSOAPArrayElemDesc;


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

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


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

  TSOAPDomConv = class(TSOAPDOMProcessor)
  private
    FIDs: Integer;
    RefMap: TMultiRefNodeMap;
    MultiRefNodes: TMultiRefNodes;
    FOptions: TSOAPConvertOptions;
    NodeState: ConvNodeState;
    ObjsWriting: array of TObject;
  protected
    function NodeIsNULL(Node: IXMLNode): Boolean;
    function CreateNULLNode(RootNode, ParentNode: IXMLNode; Name: InvString): IXMLNode;
    function GetNewID: string;
    function FindPrefixForURI(RootNode, Node: IXMLNode; URI: InvString; DeclIfNone: Boolean = False): InvString;
    function AddNamespaceDecl(Node: IXMLNode; URI: InvString): InvString;
    function GetElementType(Node: IXMLNode; var TypeURI, TypeName: InvString): Boolean;
    function CreateScalarNodeXS(RootNode, ParentNode: IXMLNode;  NodeName, URI, TypeName: WideString; Value: WideString; GenPre: Boolean = False): IXMLNode;
    function GetTypeBySchemaNS(Node: IXMLNode; URI: InvString): Variant;
    function CreateTypedNode(RootNode, ParentNode: IXMLNode; NodeName, URI, TypeName: WideString; GenPre: Boolean = False): IXMLNode;
    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(ID: string; Instance: Pointer);
    function FindMultiRefNodeByInstance(Instance: Pointer): string;
    function FindMultiRefNodeByID(ID: string): Pointer;
    function  CreateMultiRefNode(RootNode: IXMLNode; Name, ID: InvString): IXMLNode;
    procedure FinalizeMultiRefNodes;
    function FindNodeByHREF(RootNode: IXMLNode; 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;
          Name: InvString; Info: PTypeInfo; P: PVarData; NumIndirect: Integer; V: Variant; UseVariant: Boolean);
    procedure ConvertSoapToVariant(Node: IXMLNode; InvData: Pointer);
    procedure WriteVarArray(RootNode, Node: IXMLNode; Name: InvString; V: Variant);
    procedure WriteVariant(RootNode, Node: IXMLNode; Name: InvString; V: Variant);
    procedure ReadVariant(Node: IXMLNode; P: Pointer);
    function ReadVarArrayDim(Node: IXMLNode): Variant;
    procedure WriteVarArrayAsB64(RootNode, Node: IXMLNode; Name: InvString; V: Variant);
    { Methods to handle native delphi array types }
    function MakeArrayNode(RootNode, Node: IXMLNode;  Name, URI,  TypeName: InvString;
            Indices: array of Integer): IXMLNode;
    procedure ConvertNativeArrayToSoap(RootNode, Node: IXMLNode;
      Name: InvString; Info: PTypeInfo; P: Pointer; NumIndirect: Integer);
    procedure  WriteNonRectDynArray(RootNode, Node: IXMLNode; Name: InvString; Info: PTypeInfo; URI, TypeName: InvString; P: Pointer; Dims: Integer);
    function WriteNonRectDynArrayElem(RootNode, Node: IXMLNode;  Info: PTypeInfo; 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 WriteRectDynArrayElem(RootNode, Node: IXMLNode; Info: PTypeInfo; Size, Dim: Integer; P: Pointer);
    procedure  WriteRectDynArray(RootNode, Node: IXMLNode; Info: PTypeInfo; Dims: Integer; P: Pointer);
    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;
    function ConvertSoapToEnum(Info: PTypeInfo; S: InvString; IsNull: Boolean): Integer;

    { Methods that handle TObjects with RTTI }
    procedure  ConvertObjectToSOAP(Name: InvString; ObjP: Pointer; RootNode, Node: IXMLNOde; NumIndirect: Integer);
    function ConvertSOAPToObject(RootNode, Node: IXMLNode;
       AClass: TClass; URI, TypeName: WideString; ObjP: Pointer; NumIndirect: Integer): TObject;
    function CreateObjectNode(Instance: TObject; RootNode, Node: IXMLNode; Name, URI: InvString): InvString;
    procedure LoadObject(Instance: TObject; RootNode, Node: IXMLNode);
    procedure SetObjectPropFromText(Instance: TObject; PropInfo: PPropInfo; SoapData: WideString);
    function GetObjectPropAsText(Instance: TObject; PropInfo: PPropInfo): WideString;

    function GetOptions: TSOAPConvertOptions;
    procedure SetOptions(Value: TSOAPConvertOptions);
 public
    constructor Create(AOwner: TComponent); override;
    procedure ConvertNativeDataToSoap(RootNode, Node: IXMLNode;
      Name: InvString; Info: PTypeInfo; P: Pointer; NumIndirect: Integer);
    procedure ConvertSoapToNativeData(DataP: Pointer; TypeInfo: PTypeInfo;
      Context: TDataContext; RootNode, Node: IXMLNode; Translate, ByRef: Boolean; NumIndirect: Integer);
  published
    property Options: TSOAPConvertOptions read FOptions write FOptions;
  end;

  TOPToSoapDomConvert = class(TSOAPDomConv, IOPConvert)
  private
    FWSDLView: TWSDLView;
    Envelope: TSoapEnvelope;
    function GetSoapNS(MD: TIntfMetaData): InvString;
    procedure ProcessFault(FaultNode: IXMLNode);
    procedure ProcessSuccess(RespNode: IXMLNode; MD: TIntfMethEntry;
          InvContext: TInvContext);
    function GetPartName(MethMD: TIntfMetaData; ParamName: InvString): InvString;
    procedure CheckWSDL;
    function GetBinding: InvString;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { IOPConvert }
    procedure MsgToInvContext(const Request: InvString; const IntfMD: TIntfMetaData;
               var MethNum: Integer; Context: TInvContext); overload;
    procedure MsgToInvContext(const Request: TStream; const IntfMD: TIntfMetaData;
               var MethNum: Integer; Context: TInvContext); overload;
    function InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer; Con: TInvContext): InvString;
    procedure MakeResponse(const IntfMD: TIntfMetaData; const MethNum: Integer;  Context: TInvContext; Response: TStream);
    function MakeFault(const Ex: Exception): InvString;
    procedure ProcessResponse(const Resp: InvString; const MD: TIntfMethEntry;
          Context: TInvContext);  overload;
    procedure ProcessResponse(const Resp: TStream; const MD: TIntfMethEntry;
          Context: TInvContext);  overload;
  published
    property WSDLView: TWSDLView read FWSDLView write FWSDLView;
  end;

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



implementation

uses  EncdDecd, SoapConst, InvRules,  TypeTrans, OPToSoapDomCustom, VarUtils,
  XSBuiltIns, Controls, WSDLBind, XMLSchema;



procedure ParseDims(DimString: InvString; var Dims: TSOAPArrayDesc);
var
  I, J: Integer;
  CurDim, NumDims, SubDims, SubDim: Integer;
  StrLen: Integer;
  DimSize: InvString;
begin
  CurDim := 0;
  NumDims := 0;
  StrLen := Length(DimString);
  for I := 1 to StrLen do
    if DimString[I] = '[' then      { do not localize }
      Inc(NumDims);
  SetLength(Dims, NumDims);
  I := 1;
  while I < StrLen do
  begin
    if DimString[I] = '[' then       { do not localize }
    begin
      DimSize := '';
      Inc(I);
      SubDims := 1;
      SubDim := 0;
      if DimString[I] = ']' then               { do not localize }
        SetLength(Dims[CurDim].Dims, 1);
      while (DimString[I] <> ']') and (I < StrLen) do     { do not localize }
      begin
        J := I;
        while (DimString[J] <> ']') and (J < StrLen) do       { do not localize }
        begin
          if DimString[J] = ',' then
            Inc(SubDims);
          Inc(J);
        end;
        SetLength(Dims[CurDim].Dims, SubDims);
        if SubDims > 1 then
        begin
          Dims[CurDim].MultiDim := True;
          while (DimString[I] <> ']') and (I < StrLen) do     { do not localize }
          begin
            DimSize := '';
            while (DimString[I] <> ',') and (DimString[I] <> ']') and (I < StrLen) do   { do not localize }
            begin
              DimSize := DimSize + DimString[I];
              Inc(I);
            end;
            if DimString[I] = ',' then
              Inc(I);
            if trim(DimSize) <> '' then
              Dims[CurDim].Dims[SubDim] := StrToInt(trim(DimSize))
            else
              Dims[CurDim].Dims[SubDim] := 0;
            Inc(SubDim);
          end
        end else
        begin
          while (DimString[I] <> ']') and (I < StrLen) do      { do not localize }
          begin
            DimSize := DimSize + DimString[I];
            Inc(I);
          end;
          if trim(DimSize) <> '' then
            Dims[CurDim].Dims[SubDim] := StrToInt(trim(DimSize))
          else
            Dims[CurDim].Dims[SubDim] := 0;
        end;
      end;
      Inc(I);
      Inc(CurDim);
    end else
      Inc(I);
  end;
end;

{ TOPToSoapDomConvert }

type
  PTObject = ^TObject;


{ Server Recieve Message }
procedure TOPToSoapDomConvert.MsgToInvContext(const Request: InvString;
  const IntfMD: TIntfMetaData; var MethNum: Integer; Context: TInvContext);
var
  Stream: TStream;
begin
  Stream := TMemoryStream.Create;
  try
    Stream.Write(Request[1], Length(Request) * 2);
    Stream.Position := 0;
    MsgToInvContext(Stream, IntfMD, MethNum, Context);
  finally
    Stream.Free;
  end;
end;

procedure TOPToSoapDomConvert.MsgToInvContext(const Request: TStream;
  const IntfMD: TIntfMetaData; var MethNum: Integer; Context: TInvContext);
var
  XmlDoc: IXMLDocument;
  I, J, K: Integer;
  MethodName, InternalMethodName, ExtParamName: InvString;
  EnvNode, MethNode, Node: IXMLNode;
  ProcessedBody: Boolean;
  MD: TIntfMethEntry;
  HeaderProcessor:   IDOMHeaderProcessor;
  HeaderHandled, AbortRequest: Boolean;
  Translate: Boolean;
begin
  XmlDoc := NewXMLDocument;
  Request.Position := 0;
  XmlDoc.LoadFromStream(Request);
  EnvNode := XmlDoc.DocumentElement;
  if EnvNode = nil then
    raise ESOAPDomConvertError.Create(SInvalidSOAPRequest);
  if (EnvNode.LocalName <> SSoapEnvelope) or (EnvNode.NamespaceURI <> SSoapNameSpace) then
    raise ESOAPDomConvertError.Create(SInvalidSOAPRequest);

  ProcessedBody := False;
  try
    if EnvNode.hasChildNodes then
    begin
      for I := 0 to EnvNode.childNodes.Count -1 do
      begin
        Node := EnvNode.childNodes[I];
        if Node.LocalName = SSoapHeader then
        begin
           AbortRequest := False;
           HeaderProcessor := FindHeaderProcessor(Node.NameSpaceURI, Node.LocalName, ''); 
           if HeaderProcessor = nil then
             HeaderProcessor.ProcessHeader(Node, HeaderHandled, AbortRequest)
           else
             DefaultProcessHeader(Node, HeaderHandled, AbortRequest);
           if AbortRequest then
             raise ESOAPDomConvertError.CreateFmt(SHeaderError, [Node.LocalName]);
        end
        else if Node.LocalName = SSoapBody then
        begin
          if ProcessedBody then
            raise ESOAPDomConvertError.Create(SMultiBodyNotSupported);
          CheckEncodingStyle(EnvNode);
          ProcessedBody := True;
          if Node.ChildNodes.Count > 0 then
          begin
            MethNode := Node.childNodes[0];  
            CheckEncodingStyle(MethNode);
            MethodName := MethNode.LocalName;
            InternalMethodName := InvRegistry.GetMethInternalName(IntfMD.Info, MethodName);
            MethNum := GetMethNum(IntfMD, InternalMethodName);
            if MethNum = -1 then
                raise ESOAPDomConvertError.CreateFmt(SNoSuchMethod, [MethodName]);
            MD := IntfMD.MDA[MethNum];
            Context.SetMethodInfo(MD);
            Context.AllocServerData(MD);
            for K := 0 to Length(MD.Params) - 1 do
            begin
              ExtParamName := InvRegistry.GetParamExternalName(IntfMD.Info, InternalMethodName, MD.Params[K].Name);
              for J := 0 to MethNode.childNodes.Count -1 do
              begin
                if SameText(ExtParamName, MethNode.childNodes[J].LocalName) then
                begin
                  CheckEncodingStyle(MethNode.childNodes[J]);
                  Translate := (pfVar in MD.Params[K].Flags)
                    or (pfConst in  MD.Params[K].Flags)
                    or ([] =  MD.Params[K].Flags)
                    or ((pfReference in MD.Params[K].Flags) and (MD.Params[K].Info.Kind = tkVariant))
                    or ((pfReference in MD.Params[K].Flags) and (MD.Params[K].Info.Kind = tkString));
                  ConvertSoapToNativeData(Context.GetParamPointer(K), MD.Params[K].Info, Context, MethNode,
                    MethNode.childNodes[J], Translate, False,  1);
                  break;
                end;
              end;
            end;
          end;
        end;
      end;
    end else
      raise ESOAPDomConvertError.Create(SInvalidSOAPRequest);
  finally
    ResetMultiRef;
  end;
end;


procedure TOPToSoapDomConvert.MakeResponse(const IntfMD: TIntfMetaData; const MethNum: Integer;  Context: TInvContext; Response: TStream);
var
  I: Integer;
  XmlDoc: IXMLDocument;
  EnvNode, BodyNode, MethNode: IXMLNode;
  MD: TIntfMethEntry;
  SoapNS: InvString;
  ArgName: InvString;
  P: Pointer;
  Hdr, WResp: WideString;
begin
  MD := IntfMD.MDA[MethNum];
  XMLDoc := NewXMLDocument('');
  EnvNode := Envelope.MakeEnvelope(XMLDoc);
  XmlDoc.DocumentElement := EnvNode;
  BodyNode := Envelope.MakeBody(EnvNode);
  SoapNS := GetSoapNS(IntfMD);
  MethNode := BodyNode.AddChild(MD.Name + SSoapResponseSuff, SoapNS, True);
  MethNode.Attributes[FindPrefixForURI(EnvNode, BodyNode, SSoapNameSpace) + ':' + SSoapEncodingAttr] := SSoap11EncodingS5;   { do not localize }
  FIDS := 1;
  try
    if MD.ResultInfo <> nil  then
    begin
      ArgName := GetPartName(IntfMD, '');
      ConvertNativeDataToSoap(MethNode, MethNode, ArgName, MD.ResultInfo, Context.GetResultPointer, 1);
    end;
    for I := 0 to MD.ParamCount - 1  do
    begin
      if (pfVar in MD.Params[I].Flags) or (pfOut in MD.Params[I].Flags)
      then
      begin
        P := Context.GetParamPointer(I);
        ConvertNativeDataToSoap(MethNode, MethNode, MD.Params[I].Name, MD.Params[I].Info, P, 1);
      end;
    end;
  finally
    FinalizeMultiRefNodes;
    ResetMultiRef;
  end;
  XmlDoc.SaveToXML(WResp);