optosoapdomconv.pas

Delphi的Soap一些使用功能控件

    }
    CustNode := nil;
    if GetElementType(FD, URI, TypeName) then
      CustNode := FD
    else
    begin
      if ntElementChildCount(FD) > 0 then
      begin
        if GetElementType(ntElementChild(FD, 0), URI, TypeName) then
          CustNode := ntElementChild(FD, 0);
      end;
    end;

    AClass := RemClassRegistry.URIToClass(URI, TypeName);
    if AClass <> nil then
    begin
      if AClass.InheritsFrom(ERemotableException) then
      begin
        Ex := ERemotableExceptionClass(AClass).Create(AMessage);
        Count := GetTypeData(Ex.ClassInfo)^.PropCount;
        if (Count > 0) and Assigned(CustNode.ChildNodes) then
        begin
          GetMem(PropList, Count * SizeOf(Pointer));
          try
            GetPropInfos(Ex.ClassInfo, PropList);
            for I := 0 to Count - 1 do
            begin
              for J := 0 to CustNode.ChildNodes.Count - 1 do
              begin
                if CustNode.ChildNodes[J].NodeType <> ntElement then
                  continue;
                if ExtractLocalName(CustNode.ChildNodes[J].NodeName) = PropList[I].Name then
                  SetObjectPropFromText(Ex, PropList[I], GetNodeAsText(CustNode.ChildNodes[J]));
              end;
            end;
          finally
            FreeMem(PropList, Count * SizeOf(Pointer));
          end;
        end;
      end;
    end;
  end;

  { Create default SOAP invocation exception if no suitable class was found }
  if Ex = nil then
    Ex := ERemotableException.Create(AMessage);
  if FA <> nil then
    Ex.FaultActor := FA.Text;
  if FC <> nil then
    Ex.FaultCode := FC.Text;
  if FD <> nil then
    Ex.FaultDetail := FD.XML;
  raise Ex;
end;


procedure TOPToSoapDomConvert.ProcessResponse(const Resp: InvString;
                                              const IntfMD: TIntfMetaData;
                                              const MD: TIntfMethEntry;
                                              Context: TInvContext);
var
 Stream: TMemoryStream;
begin
   Stream := TMemoryStream.Create;
  try
    Stream.Write(Resp[1], Length(Resp));
    ProcessResponse(Stream, IntfMD, MD, Context, nil);
  finally
    Stream.Free;
  end
end;

procedure TOPToSoapDomConvert.ProcessResponse(const XMLDoc: IXMLDocument;
                                              const IntfMD: TIntfMetaData;
                                              const MD: TIntfMethEntry;
                                              Context: TInvContext;
                                              Headers: THeaderList);
var
  I, J, RespNodeIndex: Integer;
  EnvNode, RespNode, Node, HdrNode: IXMLNode;
  ProcessedHeader, ProcessedBody: Boolean;
begin
{$IFDEF FASTER_CONVERTER}
  CreateHREFList(Self, XMLDoc.Node);
{$ENDIF}
  EnvNode := XMLDoc.DocumentElement;
  if EnvNode = nil then
    raise ESOAPDomConvertError.Create(SInvalidResponse);
  if (ExtractLocalName(EnvNode.NodeName) <> SSoapEnvelope) or
     (EnvNode.NamespaceURI <>  SSoapNameSpace) then
    raise ESOAPDomConvertError.CreateFmt(SWrongDocElem, [SSoapNameSpace, SSoapEnvelope, EnvNode.NamespaceURI,
                                                         ExtractLocalName(EnvNode.NodeName)]);
  ProcessedHeader := False;
  ProcessedBody := False;

  if EnvNode.hasChildNodes then
  begin
    for I := 0 to EnvNode.childNodes.Count -1 do
    begin
      { Skip to first ntElement node }
      Node := EnvNode.childNodes[I];
      if Node.NodeType <> ntElement then
        continue;

      { Is node a Header Node }
      if ExtractLocalName(Node.NodeName) = SSoapHeader then
      begin
        { If we've already processed header, we have an invalid Response }
        if ProcessedHeader then
          raise ESOAPDomConvertError.Create(SInvalidSOAPResponse);

        ProcessedHeader := True;
        if Node.hasChildNodes then
        begin
          for J := 0 to Node.childNodes.Count-1 do
          begin
            HdrNode := Node.childNodes[J];
            if HdrNode.NodeType <> ntElement then
              continue;
            ReadHeader(EnvNode, HdrNode, Headers);
          end;
        end;
      end
      else if ExtractLocalName(Node.NodeName) = SSoapBody then
      begin
        if ProcessedBody then
          raise ESOAPDomConvertError.Create(SInvalidSOAPResponse);
        ProcessedBody := True;

        { Find the response node -- }
        { In literal mode, the body node is the response node for processing Success... }
        if (soLiteralParams in Options) then
        begin
          RespNode := Node;
          { Unless there's a fault }
          if RespNode.HasChildNodes then
            if ExtractLocalName(RespNode.ChildNodes[0].NodeName) = SSoapFault then
              RespNode := RespNode.ChildNodes[0];
        end
        else
        begin
          if Node.HasChildNodes then
          begin
            RespNode := nil;
            { Skip non-ntElement nodes }
            RespNodeIndex := 0;
            while (Node.childNodes[RespNodeIndex].NodeType <> ntElement) and
                  (RespNodeIndex < Node.ChildNodes.Count) do
              Inc(RespNodeIndex);
            if RespNodeIndex < Node.ChildNodes.Count then
              { Response Node found - NOTE: Much better would be to use root attribute!! }
              RespNode := Node.childNodes[RespNodeIndex];
          end;
        end;

        if RespNode <> nil then
        begin
          try
            if ExtractLocalName(RespNode.NodeName) = SSoapFault then
              ProcessFault(RespNode)
            else
              ProcessSuccess(RespNode, IntfMD, MD, Context);
          finally
            ResetMultiRef;
          end;
        end;
      end;
    end
  end else
    raise ESOAPDomConvertError.Create(SInvalidSOAPRequest);
end;

procedure TOPToSoapDomConvert.ProcessResponse(const Resp: TStream;
                                              const IntfMD: TIntfMetaData;
                                              const MD: TIntfMethEntry;
                                              Context: TInvContext;
                                              Headers: THeaderList);
var
  XMLDoc: IXMLDocument;
begin
  XMLDoc := NewXMLDocument;
  XMLDoc.Encoding := FEncoding;
  Resp.Position := 0;
  XMLDoc.LoadFromStream(Resp);
  ProcessResponse(XMLDoc, IntfMD, MD, Context, Headers);
end;

constructor TOPToSoapDomConvert.Create(AOwner: TComponent);
begin
  inherited;
  Envelope := TSoapEnvelope.Create;
  FIDs := 1;
  Options := Options + [soSendMultiRefObj,
                        soRootRefNodesToBody,
                        soTryAllSchema,
                        soCacheMimeResponse,
                        soUTF8EncodeXML ];

end;

destructor TOPToSoapDomConvert.Destroy;
begin
  Envelope.Free;
  inherited;
end;

function TOPToSoapDomConvert.GetAttachments: TSoapDataList;
begin
  Result := FAttachments;
end;

procedure TOPToSoapDomConvert.SetAttachments(Value: TSoapDataList);
begin
  FAttachments := Value;
end;

function TOPToSoapDomConvert.GetTempDir: string;
begin
  Result := FTempDir;
end;

procedure TOPToSoapDomConvert.SetTempDir(const Value: string);
begin
  FTempDir := Value;
  if (Value <> '') and (Value[Length(Value)] <> PathDelim) then
    FTempDir := FTempDir + PathDelim;
end;

function TOPToSoapDomConvert.GetEncoding: WideString;
begin
  Result := FEncoding;
end;

function TOPToSoapDomConvert.NewXMLDocument: IXMLDocument;
begin
  Result := XMLDoc.NewXMLDocument;
{$IFDEF MSWINDOWS}
{$IFDEF DEVELOPERS}
  { For testing purposes - make sure we handle WhiteSpace properly }
  Result.Options := Result.Options + [doNodeAutoIndent];
  Result.ParseOptions := Result.ParseOptions + [poPreserveWhiteSpace];
{$ENDIF}
{$ENDIF}
end;

procedure TOPToSoapDomConvert.SetEncoding(const Encoding: WideString);
begin
  FEncoding := Encoding;
end;

procedure TOPToSoapDomConvert.CheckWSDL;
begin
  if Assigned(WSDLView.WSDL) then
  begin
    WSDLView.Activate;
  end
  else
    raise ESOAPDomConvertError.Create(SNoWSDL);
end;

function TOPToSoapDomConvert.GetBinding: InvString;
var
  QName: IQualifiedName;
begin
  CheckWSDL;
  QName := WSDLView.WSDL.GetBindingForServicePort(WSDLView.Service, WSDLView.Port);
  if QName <> nil then
    Result := QName.Name;
end;

procedure TOPToSoapDomConvert.SetWSDLView(const WSDLView: TWSDLView);
begin
  FWSDLView := WSDLView;
end;

{ ParamName = '' implies function return value }
function TOPToSoapDomConvert.GetPartName(MethMD: TIntfMetaData; const ParamName: InvString): InvString;
begin
  if ParamName = '' then
    Result := SDefaultReturnName
  else
    Result := InvRegistry.GetNamespaceByGUID(MethMD.IID);
end;


{ TSOAPDomConv }
constructor TSOAPDomConv.Create(AOwner: TComponent);
begin
  inherited;
  FAttachments := TSoapDataListEx.Create;
{$IFDEF FASTER_CONVERTER}
{$IFNDEF HIGHLANDER_UP}
  SetLength(RefMap, 1);
  RefMap[0].Instance := TRefCache.Create();
{$ELSE}
  FRefCache := TRefCache.Create();
{$ENDIF}
{$ENDIF}
end;

destructor TSOAPDomConv.Destroy;
begin
{$IFDEF FASTER_CONVERTER}
{$IFNDEF HIGHLANDER_UP}
  TRefCache(RefMap[0].Instance).Free;
  SetLength(RefMap, 0);
{$ELSE}
  FRefCache.Free;
{$ENDIF}
{$ENDIF}
  FAttachments.Free;
  inherited;
end;

procedure TSOAPDomConv.AddAttachment(Attachment: TSOAPAttachment; const AContentId: string);
var
  Attach: TSOAPAttachmentData;
begin
  Attach := TSOAPAttachmentData.Create;
  with Attach do
  begin
    Id := AContentId;
    Headers.Add(Format(SContentId + ': <%s>', [AContentId]));
    if Attachment.CacheFile <> '' then
      SetCacheFile(Attachment.CacheFile)
    else if Assigned(Attachment.SourceStream) then
    begin
      SetSourceStream(Attachment.SourceStream, Attachment.Ownership);
      Attachment.Ownership := soReference;
    end else SourceString := Attachment.SourceString;
    DataContext := Nil;
  end;
  Attach.ContentType := Attachment.ContentType;
  Attach.Encoding := Attachment.Encoding;
  FAttachments.Add(Attach);
end;


function TSOAPDomConv.FindAttachment(const AContentId: string): TSOAPAttachment;

  function SameId(Id1, Id2: string): Boolean;
  begin
    { if by ContentId, extract Id by removing 'cid:' and compare }
    if AnsiSameText(SAttachmentIdPrefix, Copy(Id2, 2, Length(SAttachmentIdPrefix))) then
      Result := AnsiSameText(Id1, '<' + Copy(Id2, Pos(':', Id2) + 1, MaxInt))
    { GLUE uses http:// to identify ContentId }
    else if AnsiSameText(sHTTPPrefix, Copy(Id2, 2, Length(SHTTPPrefix))) then
      Result := AnsiSameText(Id1, Id2)
    else  { if by location, extract Location by removing DefaultBaseURI }
    begin
      if Pos(SDefaultBaseURI, Id2) = 1 then
        Result := AnsiSameText(Id1, Copy(Id2, Length(SDefaultBaseURI) + 1, MaxInt))
      else  { extract Location by removing name space }
        Result := AnsiSameText(Id1, '<' + Copy(Id2, Pos(':', Id2) + 1, MaxInt));
    end;
  end;

var
  I: Integ