optosoapdomconv.pas

Delphi的Soap一些使用功能控件

  { Here we update the WSDLView to inform it of
    the Operation we're about to execute }
  if Assigned(WSDLView) then
  begin
    WSDLView.Operation := MethMD.Name;
    WSDLView.IntfInfo := IntfMD.Info;
  end;

  XMLDoc := NewXMLDocument;
  XMLDoc.Encoding := FEncoding;
  EnvNode := Envelope.MakeEnvelope(XMLDoc, Options);

  { Result MultiRef IDs are we're about to create new request }
  FIDS := 1;
  FAttachments.Clear;

  { Any headers }
  if (Headers <> nil) and (Headers.Count > 0) then
  begin
    HeaderNode := Envelope.MakeHeader(EnvNode);
    if not (soDocument in Options) then
      HeaderNode.SetAttributeNS(SSoapEncodingAttr, SSoapNameSpace, SSoap11EncodingS5);
    for I := 0 to Headers.Count-1 do
    begin
      Header := Headers[I];
      WriteHeader(Header, HeaderNode, HeaderNode);
    end;
  end;

  BodyNode := Envelope.MakeBody(EnvNode);

  { If we're sending unwrapped literal params, then skip the method node }
  if not (soLiteralParams in Options) then
  begin
    SoapMethNS := GetSoapNS(IntfMD);
    { Add Method node with appropriate namespace }
    ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
    if not (soDocument in Options) then
    begin
      MethNode := BodyNode.AddChild(ExtMethName, SoapMethNS, (SoapMethNS <> ''));
      { Use encoding style defined by SOAP 1.1 section 5 }
      { NOTE: We used to put this on the method node; it seems more intuitive on
              the body node; Keep this in mind when investigating interop issues }
      BodyNode.SetAttributeNS(SSoapEncodingAttr, SSoapNameSpace, SSoap11EncodingS5);
    end
    else
    begin
      { In document mode, SoapMethNS is the default namespace }
      MethNode := BodyNode.AddChild(ExtMethName, SoapMethNS);
{$IFDEF FIX_ELEM_NODE_NS}
      ElemNodeNamespace := SoapMethNS;
{$ENDIF}
    end;
  end
  else
  begin
    MethNode := BodyNode;
  end;

  try
    { Add each parameter to the method node }
    for I := 0 to MethMD.ParamCount - 1  do
    begin
      if not (pfOut in MethMD.Params[I].Flags) then
      begin
        { In doc|lit mode, we use the typename for the node }
        if (soDocument in Options) and (soLiteralParams in Options) then
          RemTypeRegistry.TypeInfoToXSD(MethMD.Params[I].Info, URI, ExtParamName)
        else
          ExtParamName := InvRegistry.GetParamExternalName(IntfMD.Info, MethMD.Name, MethMD.Params[I].Name);
        P := Con.GetParamPointer(I);
        Indir := 1;
        if IsParamByRef(MethMd.Params[I].Flags, MethMD.Params[I].Info, MethMD.CC) then
          Inc(Indir);
        ConvertNativeDataToSoap(BodyNode, MethNode, ExtParamName,
                                MethMD.Params[I].Info, P, Indir);
      end;
    end;
    FinalizeMultiRefNodes;
  finally
    ResetMultiRef;
{$IFDEF FIX_ELEM_NODE_NS}
    ElemNodeNamespace := '';
{$ENDIF}
  end;

  Result := TMemoryStream.Create();
  DOMToStream(XMLDoc, Result);
end;

procedure TOPToSoapDomConvert.ProcessSuccess(RespNode: IXMLNode;
                                             const IntfMD: TIntfMetaData;
                                             const MD: TIntfMethEntry;
                                             InvContext: TInvContext);

  function WideStringAsArray(const Params: WideString): TWideStringDynArray;
  var
    I, Prev: Integer;
  begin
    SetLength(Result, 0);
    Prev := 1;
    for I := 1 to Length(Params)+1 do
    begin
      if (I > Length(Params)) or (Params[I] = ',') or (Params[I] = ';') then
      begin
        SetLength(Result, Length(Result)+1);
        Result[Length(Result)-1] := Copy(Params, Prev, I-Prev);
        Prev := I+1;
      end;
    end;
  end;

  { This is the tricky part of deserializing; How to determine the return index;
    This function should only be used if we're processing a function - IOW, this
    function should only be called if the method we're processing has
    MD.ResultInfo <> nil }

  { EXACT_MATCH_RETURN_PARAM is a safer way to match the return elements with what
    might have been registered for this interface. However, there are couple of issues:
    1. It will only work for interfaces that derived directly from IUnknown/IInvokable.
       That's because we cannot compute the index of the method within the interface
       from its position in the vtable otherwise. When the interface derives from
       IInvokable we know that there are only 3 methods in the base interface.
    2. In previous versions we used all names registered on each method.
      Of course this latter behaviour (#2) is what's error prone for cases where a wacky
      service has the name of an out element of an operation match that of the
      the out of another element of another operation and we made only one of the
      two the return element

      Of course the 'parameterOrder' attribute was meant to help with fuzzy detection
      of the return value part but hardly anyone uses it - including Delphi :( }
  function FindReturnNodeIndex: integer;
  var
    X, First, Ret, Count: Integer;
    Node: IXMLNode;
    ReturnParams: TWideStringDynArray;
{$IFDEF EXACT_MATCH_RETURN_PARAM}
    ReturnParam: WideString;
{$ELSE}
    Y: Integer;
{$ENDIF}
  begin
    First := -1;
    Ret := -1;
    Count := 0;
    { Get array of return parameter names }
    ReturnParams := WideStringAsArray(InvRegistry.GetReturnParamNames(IntfMD.Info));
{$IFDEF EXACT_MATCH_RETURN_PARAM}
    if (Length(ReturnParams) > (MD.Pos-3)) then
      ReturnParam := ReturnParams[MD.Pos-3]
    else
      ReturnParam := '';
{$ENDIF}
    for X := 0 to RespNode.ChildNodes.Count-1 do
    begin
      Node := RespNode.ChildNodes[X];
      if Node.NodeType <> ntElement then
        continue;
      { Save first valid node }
      if First = -1 then
        First := X;
      { Save Return param name(s) matches }
{$IFDEF EXACT_MATCH_RETURN_PARAM}
      if (Ret = -1) and (Length(ReturnParam) > 0)  then
        if SameText(ExtractLocalName(Node.NodeName), ReturnParam) then
          Ret := X;
{$ELSE}
      if (Ret = -1) and (Length(ReturnParams) > 0)  then
      begin
        for Y := 0 to Length(ReturnParams)-1 do
        begin
          if SameText(ExtractLocalName(Node.NodeName), ReturnParams[Y]) then
            Ret := X;
        end;
      end;
{$ENDIF}
      Inc(Count);
    end;
    if Count = 1 then
      Result := First
    else
      Result := Ret;
  end;

  function IsNillable(TypeInfo: PTypeInfo): Boolean;
  begin
    Result := (TypeInfo.Kind = tkClass) or
              (TypeInfo.Kind = tkVariant);
  end;

var
  I, J, RetIndex: Integer;
  InvData: Pointer;
  Node: IXMLNode;
  ByRef: Boolean;
  Indir: Integer;
  ParamProcessed: TBooleanDynArray;
  UnboundedArrayRet: Boolean;
  ParamName: WideString;
begin
  SetLength(ParamProcessed, MD.ParamCount);
  for J := 0 to Length(ParamProcessed) - 1 do
    ParamProcessed[J] := False;

  { Are we expecting an unbounded array }
  UnboundedArrayRet := (MD.ResultInfo <> nil) and (MD.ResultInfo.Kind = tkDynArray) and
                       (xoInlineArrays in RemClassRegistry.SerializeOptions(MD.ResultInfo));
  if UnboundedArrayRet then
  begin
    InvData := InvContext.GetResultPointer;
    ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);
    ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, RespNode, True, ByRef, 1);
    RetIndex := -1;
  end
  else
  begin
    { Find index of return node - if we're expecting one }
    if (MD.ResultInfo <> nil) then
    begin
      RetIndex := FindReturnNodeIndex;
      { We'll be lenient about nillable types }
      if (RetIndex = -1) and not IsNillable(MD.ResultInfo) then
        raise ESOAPDomConvertError.CreateFmt(SMissingSoapReturn, [RespNode.XML]);
    end
    else
      RetIndex := -1;
  end;

  { Process returned nodes }
  if RespNode.HasChildNodes then
  begin
    if (RetIndex <> -1) or (MD.ParamCount > 0) then
    begin
      for I := 0 to RespNode.childNodes.Count - 1 do
      begin
        Node := RespNode.childNodes[I];
        { Skip non-valid nodes }
        if Node.NodeType <> ntElement then
          continue;
        { Process Return value, if we're expecting one }
        if I = RetIndex then
        begin
          InvData := InvContext.GetResultPointer;
          ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);
          ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, Node, True, ByRef, 1);
        end
        else
        begin
          J := 0;
          while J < MD.ParamCount do
          begin
            ParamName := InvRegistry.GetParamExternalName(IntfMD.Info, MD.Name, MD.Params[J].Name);
            if ParamName = ExtractLocalName(Node.NodeName) then
              break;
            Inc(J);
          end;
          if (J < MD.ParamCount) and not ParamProcessed[J]  then
          begin
            ParamProcessed[J] := True;
            InvData := InvContext.GetParamPointer(J);
            ByRef := IsParamByRef(MD.Params[J].Flags, MD.Params[J].Info, MD.CC);
            Indir := 1;
            if ByRef then
              Inc(Indir);
            ConvertSoapToNativeData(InvData, MD.Params[J].Info, InvContext, RespNode, Node, True, ByRef,  Indir);
          end;
        end;
      end;
    end;
  end else if (MD.ResultInfo <> nil) and IsNillable(MD.ResultInfo) and (not UnboundedArrayRet) then
  begin
    InvData := InvContext.GetResultPointer;
    ByRef := IsParamByRef([pfOut], MD.ResultInfo, MD.CC);
    ConvertSoapToNativeData(InvData, MD.ResultInfo, InvContext, RespNode, nil, True, ByRef, 1);
  end;
end;


procedure TOPToSoapDomConvert.ProcessFault(FaultNode: IXMLNode);
var
  FA, FC, FD, FS, CustNode: IXMLNode;
  I, J: Integer;
  AMessage: WideString;
  AClass: TClass;
  URI, TypeName: WideString;
  Count: Integer;
  PropList: PPropList;
  Ex: ERemotableException;
begin
  FA := nil;
  FC := nil;
  FD := nil;
  FS := nil;
  Ex := nil;
  for I := 0 to FaultNode.ChildNodes.Count - 1 do
  begin
    if      SameText(ExtractLocalName(FaultNode.ChildNodes[I].NodeName), SSoapFaultCode) then
      FC := FaultNode.ChildNodes[I]
    else if SameText(ExtractLocalName(FaultNode.ChildNodes[I].NodeName), SSoapFaultString) then
      FS := FaultNode.ChildNodes[I]
    else if SameText(ExtractLocalName(FaultNode.ChildNodes[I].NodeName), SSoapFaultDetails) then
      FD := FaultNode.ChildNodes[I]
    else if SameText(ExtractLocalName(FaultNode.ChildNodes[I].NodeName), SSoapFaultActor) then
      FA := FaultNode.ChildNodes[I];
  end;

  { Retrieve message from FaultString node }
  if FS <> nil then
    AMessage := FS.Text;

  { If there's a <detail> node, try to map it to a registered type }
  if FD <> nil then
  begin
    { Some SOAP stacks, including Delphi6 and others (see
      http://softwaredev.earthweb.com/script/article/0,,12063_641361_2,00.html)
      use the approach of putting custom fault info right at the <detail> node:

      Listing 4 - Application Fault Details
      <SOAP-ENV:Fault>
        <faultcode>300</faultcode>
        <faultstring>Invalid Request</faultstring>
        <runcode>1</runcode>
        <detail xmlns:e="GetTemperatureErr-URI"
                xmlns:xsi="http://www.w3.org/1999/XMLSchema-instance"
                xsi:type="e:GetTemperatureFault">
            <number>5575910</number>
            <description>Sensor Failure</description>
            <file>GetTemperatureClass.cpp</file>
            <line>481</line>
        </detail>
      </SOAP-ENV:Fault>

      However, much more common is the approach where the type and namespace
      are on the childnode of the <detail> node. Apache, MS and the SOAP spec.
      seem to lean towards that approach:

      Example 10 from the SOAP 1.1 Spec:

      <SOAP-ENV:Envelope
        xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">
         <SOAP-ENV:Body>
             <SOAP-ENV:Fault>
                 <faultcode>SOAP-ENV:Server</faultcode>
                 <faultstring>Server Error</faultstring>
                 <detail>
                     <e:myfaultdetails xmlns:e="Some-URI">
                       <message>
                         My application didn't work
                       </message>
                       <errorcode>
                         1001
                       </errorcode>
                     </e:myfaultdetails>
                 </detail>
             </SOAP-ENV:Fault>
         </SOAP-ENV:Body>
      </SOAP-ENV:Envelope>

      For interop reasons we favor the later approach but we'll support both here!!