optosoapdomconv.pas

Delphi开发webservice的一套例子

  Response.Position := 0;
  Hdr := SSoapXMLHeader;
  Response.Write(Hdr[1], Length(Hdr) * 2);
  WResp := Trim(WResp);
  Response.Write(WResp[1], Length(WResp) * 2);
  Response.Position := 0;
end;

function TOPToSoapDomConvert.GetSoapNS(MD: TIntfMetaData): InvString;
var
  ExtName: WideString;
begin
  if Assigned(WSDLView) then
  begin
    ExtName :=  InvRegistry.GetMethExternalName(MD.Info, WSDLVIew.Operation);
    Result := WSDLView.WSDL.GetSoapBodyAttribute(GetBinding, ExtName, WSDLBind.SInput, WSDLBind.SNameSpace)
  end else
    Result := InvRegistry.GetNamespaceByGUID(MD.IID);
end;

function TOPToSoapDomConvert.MakeFault(const Ex: Exception): InvString;
var
  XmlDoc: IXMLDocument;
  EnvNode, BodyNode, FaultNode, FC, FS, FD: IXMLNode;
  I, Count: Integer;
  PropList: PPropList;
  URI, TypeName: WideString;
  IsScalar: Boolean;
begin
  Result := '';
  XMLDoc := NewXMLDocument('');
  EnvNode := Envelope.MakeEnvelope(XMLDoc);
  BodyNode := Envelope.MakeBody(EnvNode);
  FaultNode := Envelope.MakeFault(BodyNode);
  FC := FaultNode.AddChild(SSoapFaultCode);
  FC.Text := 'SOAP-ENV:Server'; // todo          { do not localize }
  FS := FaultNode.AddChild(SSoapFaultString);
  FS.Text := Ex.Message;
  if Ex.InheritsFrom(ERemotableException) then
  begin
    RemClassRegistry.ClassToURI(Ex.ClassType, URI, TypeName, IsScalar);
    FD := FaultNode.AddChild(SSoapFaultDetails, URI, True);
    FD.Attributes[FindPrefixForURI(EnvNode, BodyNode, XMLSchemaInstNameSpace)  + ':' + SSoapType] := FD.Prefix + ':' + TypeName;   { do not localize }
    Count := GetTypeData(Ex.ClassInfo)^.PropCount;
    if Count > 0 then
    begin
      GetMem(PropList, Count * SizeOf(Pointer));
      try
        GetPropInfos(Ex.ClassInfo, PropList);
        for I := 0 to Count - 1 do
        begin
          if not RemTypeRegistry.TypeInfoToXSD( (PropList[I].PropType)^, URI, TypeName) then
            raise ESOAPDomConvertError.CreateFmt(SRemTypeNotRegistered, [(PropList[I].PropType)^.Name]);
          CreateScalarNodeXS(FaultNode, FD, PropList[I].Name, URI, TypeName, GetObjectPropAsText(Ex, PropList[I]));
        end;
      finally
        FreeMem(PropList, Count * SizeOf(Pointer));
      end;
    end;
  end;

  XmlDoc.SaveToXML(Result);
  Result := SSOAPXMLHeader + Trim(Result);
end;

function TOPToSoapDomConvert.InvContextToMsg(const IntfMD: TIntfMetaData; MethNum: Integer; Con: TInvContext): InvString;
var
  XMLDoc: IXMLDocument;
  EnvNode, BodyNode, MethNode: IXMLNode;
  I: Integer;
  SoapMethNS: InvString;
  MethMD: TIntfMethEntry;
  P: Pointer;
  Indir: Integer;
  ExtMethName, ExtParamName: InvString;
begin
  MethMD := IntfMD.MDA[MethNum];
  if Assigned(WSDLView) then
  begin
    WSDLView.Operation := MethMD.Name;
    WSDLView.IntfInfo := IntfMD.Info;
  end;
  XMLDoc := NewXMLDocument('');
  EnvNode := Envelope.MakeEnvelope(XMLDoc);
  BodyNode := Envelope.MakeBody(EnvNode);

  SoapMethNS := GetSoapNS(IntfMD);
  // Add Method node with appropriate namespace
  ExtMethName := InvRegistry.GetMethExternalName(IntfMD.Info, MethMD.Name);
  MethNode := BodyNode.AddChild(ExtMethName, SoapMethNS, (SoapMethNS <> ''));
  // Use encoding style defined by SOAP 1.1 section 5
  MethNode.Attributes[FindPrefixForURI(EnvNode, BodyNode, SSoapNameSpace) + ':' + SSoapEncodingAttr] := SSoap11EncodingS5;  { do not localize }
  
  FIDS := 1;
  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
        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(MethNode, MethNode, ExtParamName, MethMD.Params[I].Info, P, Indir);
      end;
    end;
    FinalizeMultiRefNodes;
  finally
    ResetMultiRef;
  end;
  XMLDoc.SaveToXML(Result);
  Result := SSoapXMLHeader + trim(Result);
end;

procedure TOPToSoapDomConvert.ProcessSuccess(RespNode: IXMLNode; MD: TIntfMethEntry;
          InvContext: TInvContext);
var
  I, J: Integer;
  InvData: Pointer;
  Node: IXMLNode;
  ByRef: Boolean;
  Indir: Integer;
  ParamProcessed: TBooleanDynArray;
  ReturnProcessed: Boolean;
  NodeCount: Integer;
begin
  SetLength(ParamProcessed, MD.ParamCount);
  ReturnProcessed := False;
  for J := 0 to Length(ParamProcessed) - 1 do
    ParamProcessed[J] := False;
  NodeCount := RespNode.childNodes.Count;
  for I := 0 to RespNode.childNodes.Count - 1 do
  begin
    Node := RespNode.childNodes[I];
    if (CompareText(Node.LocalName, SDefaultReturnName) = 0) or
       (CompareText(Node.LocalName, SDefaultResultName) = 0) or
       (NodeCount = 1) then
    begin
      if ReturnProcessed or (MD.ResultInfo = nil) then
        continue;
      ReturnProcessed := True;
      if (MD.ResultInfo <> nil) and (I <> 0) then
        raise ESOAPDomConvertError.CreateFmt(SMissingSoapReturn, [Node.LocalName]);
      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
        if MD.Params[J].Name = Node.LocalName 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 IsParamByRef(MD.Params[J].Flags, MD.Params[J].Info, MD.CC) then
          Inc(Indir);
        ConvertSoapToNativeData(InvData, MD.Params[J].Info, InvContext, RespNode, Node, True, ByRef,  Indir);
      end;
    end;
  end;
end;


procedure TOPToSoapDomConvert.ProcessFault(FaultNode: IXMLNode);
var
  FC, FS, FD: IXMLNode;
  I, J: Integer;
  Message: WideString;
  AClass: TClass;
  URI, TypeName: WideString;
  IsScalar: Boolean;
  Count: Integer;
  PropList: PPropList;
  Ex: Exception;
begin
  FS := nil;
  FC := nil;
  FD := nil;
  Ex := nil;
  for I := 0 to FaultNode.ChildNodes.Count - 1 do
    if SameText(FaultNode.ChildNodes[I].LocalName, SSoapFaultCode) then
    begin
       FC := FaultNode.ChildNodes[I];
       break;
    end;
  for I := 0 to FaultNode.ChildNodes.Count - 1 do
    if SameText(FaultNode.ChildNodes[I].LocalName, SSoapFaultString) then
      begin
        FS := FaultNode.ChildNodes[I];
        break;
      end;
  for I := 0 to FaultNode.ChildNodes.Count - 1 do
    if SameText(FaultNode.ChildNodes[I].LocalName, SSoapFaultDetails) then
      begin
        FD := FaultNode.ChildNodes[I];
        break;
      end;
  if FS <> nil then
    Message := FS.Text;
  if FD <> nil then
  begin
    GetElementType(FD, URI, TypeName);
    AClass := RemClassRegistry.URIToClass(URI, TypeName, IsScalar);
    if AClass <> nil then
    begin
      if AClass.InheritsFrom(ERemotableException) then
      begin
        Ex := ERemotableExceptionClass(AClass).Create(Message);
        Count := GetTypeData(Ex.ClassInfo)^.PropCount;
        if (Count > 0) and Assigned(FD.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 FD.ChildNodes.Count - 1 do
                if FD.ChildNodes[J].LocalName = PropList[I].Name then
                 SetObjectPropFromText(Ex, PropList[I], FD.ChildNodes[J].Text);
            end;
          finally
            FreeMem(PropList, Count * SizeOf(Pointer));
          end;
        end;
      end;
    end;
  end;
  if Ex = nil then
    Ex := Exception.Create(Message);
  raise Ex;
end;


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

procedure TOPToSoapDomConvert.ProcessResponse(const Resp: TStream;
  const MD: TIntfMethEntry; Context: TInvContext);
var
  XmlDoc: IXMLDocument;
  I: Integer;
  EnvNode, RespNode, Node: IXMLNode;
  ProcessedHeader, ProcessedBody: Boolean;
  HeaderProcessor:   IDOMHeaderProcessor;
  HeaderHandled, AbortRequest: Boolean;
begin
  XmlDoc := NewXMLDocument;
  Resp.Position := 0;
  XmlDoc.LoadFromStream(Resp);
  EnvNode := XmlDoc.DocumentElement;
  if EnvNode = nil then
    raise ESOAPDomConvertError.Create(SInvalidResponse); 
  if (EnvNode.LocalName <> SSoapEnvelope) or (EnvNode.NamespaceURI <>  SSoapNameSpace) then
    raise ESOAPDomConvertError.CreateFmt(SWrongDocElem, [SSoapNameSpace, SSoapEnvelope, EnvNode.NamespaceURI, EnvNode.LocalName]);

  ProcessedHeader := False;
  ProcessedBody := False;

  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
        if ProcessedHeader then
          raise ESOAPDomConvertError.Create(SInvalidSOAPRequest);
        ProcessedHeader := True;
        HeaderProcessor := FindHeaderProcessor(Node.NameSpaceURI, Node.LocalName, '');
        if HeaderProcessor <> nil then
          HeaderProcessor.ProcessHeader(Node, HeaderHandled, AbortRequest)
        else
          DefaultProcessHeader(Node, HeaderHandled, AbortRequest);

      end
      else if Node.LocalName = SSoapBody then
      begin
        if ProcessedBody then
          raise ESOAPDomConvertError.Create(SInvalidSOAPRequest);
        ProcessedBody := True;
        RespNode := Node.childNodes[0];
        try
          if RespNode.LocalName = SSoapFault then
            ProcessFault(RespNode)
          else
            ProcessSuccess(RespNode, MD, Context);
        finally
          ResetMultiRef;
        end;
      end;
    end
  end else
    raise ESOAPDomConvertError.Create(SInvalidSOAPRequest);
end;

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

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

procedure  TOPToSoapDomConvert.CheckWSDL;
begin
  if Assigned(WSDLView.WSDL) then
  begin
    if not WSDLView.WSDL.Active then
      WSDLView.WSDL.Active := True;
  end
  else
    raise ESOAPDomConvertError.Create(SNoWSDL);
end;

function  TOPToSoapDomConvert.GetBinding: InvString;
var
  I: Integer;
begin
  CheckWSDL;
  Result := WSDLView.WSDL.GetBindingForServicePort(WSDLView.Service, WSDLView.Port);
  I := Pos(':', Result);    { do not localize }
  if I  > 0 then
    Result := Copy(Result, I + 1, High(Integer));
end;

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




{ TSOAPDomConv }
constructor TSOAPDomConv.Create(AOwner: TComponent);
begin
  inherited;
end;


procedure TSOAPDomConv.ConvertVariantToSoap(RootNode, Node: IXMLNode;
  Name: InvString; Info: PTypeInfo; P: PVarData; NumIndirect: Integer; V: Variant; UseVariant: Boolean);
var
  DataP: Pointer;
begin
  if UseVariant then
  begin
    if VarIsNull(V) then
      CreateNULLNode(RootNode, Node, Name)
    else
      WriteVariant(RootNode, Node, Name, V);
  end else
  begin
    DataP := P;
    if NumIndirect > 1 then
      DataP := Pointer(PInteger(DataP)^);
    if (DataP = nil) or VarIsNull(Variant(DataP^)) then
      CreateNULLNode(RootNode,Node, Name)
    else
      WriteVariant(RootNode, Node, Name, Variant(DataP^));
  end;
end;