rio.pas

Delphi的Soap一些使用功能控件

        FLD     TBYTE PTR [EAX]
        RET
@@Curr:
        FILD    QWORD PTR [EAX]
end;

function XMLDocFromStream(const Stream: TStream): IXMLDocument;
begin
  Result := NewXMLDocument;
  Result.Encoding := SUTF8;
  Stream.Position := 0;
  Result.LoadFromStream(Stream);
end;

function TRIO.Generic(CallID: Integer; Params: Pointer): Int64;
{$IF CompilerVersion <= 17.0}
const
  SCantReturnInterface = 'Pascal code generated by WSDL import cannot be modified to return an interface.  GUID %s';
{$IFEND}
var
  MethMD: TIntfMethEntry;
  P: Pointer;
  ParamIdx, I, J, LeftRightOrder: Integer;
  RetP: Pointer;
  MethNum: Integer;
  Req, Resp, RespXML: TStream;
  XMLStream: TMemoryStream;
  AttachHandler: IMimeAttachmentHandler;
  BindingType, RespBindingType: TWebServiceBindingType;
  AttachHeader: String;
begin
  Result := Int64(0);
  if not Assigned(FConverter) then
    raise Exception.Create(SNoMessageConverter);
  if not Assigned(FWebNode) then
    raise Exception.Create(SNoMsgProcessingNode);

  { Here provide error about failure at GenVTable time - note: This is because
    a QueryInterface call cannot throw an exception with useful error message;
    so in order to be programmer-friendly we act as if the QI succeeded and then
    we throw a more descriptive error on the first call }
  if not IntfReg then
    raise Exception.CreateFmt(SInterfaceNotReg, [GuidToString(FIID)]);
  if not HasRTTI then
    raise Exception.CreateFmt(SInterfaceNoRTTI, [GuidToString(FIID)]);

  if not LegalCC then
  begin
    for I := 0 to Length(IntfMD.MDA) -1 do
    begin
      if IntfMD.MDA[I].HasRTTI then
        with IntfMD.MDA[I] do
          if CC in [ccReg {, ccSafeCall} ] then
            raise Exception.CreateFmt(SUnsupportedCCIntfMeth, [CallingConventionName[CC], Name, IntfMD.Name]);
    end;
  end;

  { Get MethodEntry information }
  try
    MethMD := IntfMD.MDA[CallID];
  except
    raise Exception.CreateFmt(SCantReturnInterface, [GuidToString(FIID)]);
  end;

  FContext.SetMethodInfo(MethMD);
  P := Params;
  ParamIdx := 0;

  { Set up the parameter index and left right ordering, }
  { depending on calling convention }
  if MethMD.CC = ccPascal then
  begin
    ParamIdx := MethMD.ParamCount - 1;
    LeftRightOrder := -1;
  end else if MethMD.CC in [ccCdecl, ccStdCall, ccSafeCall]  then
  begin
    ParamIdx := 0;
    LeftRightOrder := 1;
  end else
    LeftRightOrder := 0; { todo: raise unsupported  }

  if MethMd.CC <> ccSafeCall then
  begin
    if RetOnStack(MethMD.ResultInfo) then
    begin
      RetP := Pointer(PInteger(P)^);
      if MethMD.ResultInfo.Kind = tkVariant then
        IncPtr(P, sizeof(Pointer))
      else
        IncPtr(P, GetStackTypeSize(MethMD.ResultInfo, MethMD.CC));
      if MethMD.CC in [ccCdecl, ccStdCall] then
      begin
        IncPtr(P, sizeof(Pointer));   { Step over self  }
      end;
    end else
      RetP := @Result;
    FContext.SetResultPointer(RetP);
  end;

  { Walk the parameters, setting pointers to each param's data into }
  { the parameter slots in the context  }
  for  J := 0 to  MethMD.ParamCount - 1 do
  begin
    FContext.SetParamPointer(ParamIdx, P);
    with MethMD.Params[J] do
    begin
      if (Info.Kind = tkVariant) and
         (MethMD.CC in [ccCdecl, ccStdCall, ccSafeCall]) and
         not (pfVar in Flags) and
         not (pfOut in Flags) then
      begin
        IncPtr(P, sizeof(TVarData)); { NOTE: better would be to dword-align!! }
      end
      else if IsParamByRef(Flags, Info, MethMD.CC) then
        IncPtr(P, 4)
      else
        IncPtr(P, GetStackTypeSize(Info, MethMD.CC));
    end;
    Inc(ParamIdx, LeftRightOrder);
  end;

  if MethMD.CC = ccSafeCall then
  begin
    RetP := Pointer(PInteger(P)^);
    FContext.SetResultPointer(RetP);
  end;
  MethNum := CallID;

  { Any headers returned by Server in last call is now cleared }
  FHeadersInBound.Clear;

  { Convert parameter to XML packet }
  Req := FConverter.InvContextToMsg(IntfMD, MethNum, FContext, FHeadersOutBound);
  try
{$IFDEF ATTACHMENT_SUPPORT}
    { Get the Binding Type
      NOTE: We're interested in the input/call }
    BindingType := GetBindingType(MethMD, True);

    { NOTE: Creation of AttachHandler could be delayed - doesn't
            seem to matter much though }
    AttachHandler := GetMimeAttachmentHandler(BindingType);
    AttachHandler.OnGetAttachment := OnGetAttachment;
    AttachHandler.OnSendAttachment := OnSendAttachment;
{$ELSE}
    BindingType := btSOAP;
{$ENDIF}
    try
{$IFDEF ATTACHMENT_SUPPORT}
      { Create MIME stream if we're MIME bound }
      if (BindingType = btMIME) then
      begin
        { Create a MIME stream from the request and attachments }
        AttachHandler.CreateMimeStream(Req, FConverter.Attachments);

        { Set the MIME Boundary
          Investigate: Since one of the weaknesses of MIME is the boundary,
          it seems that we should be going the other way.
          IOW, since the programmer can configure IWebNode's MIMEBoundary,
          we should be using that to initialize the AttachHandler's MIME Boundary.
          IOW, allow the programmer to customize the boundary... instead of
          ignoring whatever value the programmer may have put there at design time
          and hardcoding the MIMEBoundary.

          Or maybe that property should not be exposed at the Designer Level  ????  }
        FWebNode.MimeBoundary := AttachHandler.MIMEBoundary;

        { Allow for transport-specific initialization that needs to take
          place prior to execution - NOTE: It's important to call this
          routine before calling FinalizeStream - this allows the attachment's
          stream to be modified/configured }
        { NOTE: Skip 3 for AddRef,Release & QI }
        { NOTE: Hardcoding '3' makes an assumption: that the interface derived
                directly from IInvokable (i.e. IUnknown). Under that condition
                3 represent the three standard methods of IUknown. However,
                someone could ask the RIO for an interface that derives from
                something else that derives from IUnknown. In that case, the
                '3' here would be wrong. The importer always generates interfaces
                derived from IInvokable - so we're *relatively* safe. }
        FWebNode.BeforeExecute(IntfMD, MethMD, MethNum-3, AttachHandler);

        { This is a hack - but for now, LinkedRIO requires that FinalizeStream
          be called from here - doing so, breaks HTTPRIO - so we resort to a
          hack. Ideally, I'm thinking of exposing a thin AttachHeader interface
          that the transport can use to set SOAP headers - allowing each transport
          to perform any packet customization }
        if AttachHeader <> '' then
          AttachHandler.AddSoapHeader(AttachHeader);
        AttachHandler.FinalizeStream;
      end else
{$ENDIF}
        { NOTE: Skip 3 for AddRef,Release & QI - See comment above about '3' }
        FWebNode.BeforeExecute(IntfMD, MethMD, MethNum-3, nil);

      { Allow event to see packet we're sending }
      { This allows the handler to see the whole packet - i.e. attachments too }
{$IFDEF ATTACHMENT_SUPPORT}
      if BindingType = btMIME then
        DoBeforeExecute(MethMD.Name, AttachHandler.GetMIMEStream)
      else
{$ENDIF}
        DoBeforeExecute(MethMD.Name, Req);

{$IFDEF ATTACHMENT_SUPPORT}
      RespBindingType := GetBindingType(MethMD, False);
{$ELSE}
      RespBindingType := btSOAP;
{$ENDIF}
      Resp := GetResponseStream(RespBindingType);
      try
{$IFDEF ATTACHMENT_SUPPORT}
        if (BindingType = btMIME) then
        begin
          try
            FWebNode.Execute(AttachHandler.GetMIMEStream, Resp)
          finally
            FConverter.Attachments.Clear;
            FHeadersOutBound.Clear;
          end;
        end
        else
{$ENDIF}
        try
          FWebNode.Execute(Req, Resp);
        finally
          { Clear Outbound headers }
          FHeadersOutBound.Clear;
        end;          

        { Assume the response is the SOAP Envelope in XML format. NOTE: In case
          of attachments, this could actually be a Multipart/Related response }
        RespXML := Resp;

        XMLStream := TMemoryStream.Create;
        try
          { This allows the handler to see the whole packet - i.e. attachments too }
          DoAfterExecute(MethMD.Name, Resp);

{$IFDEF ATTACHMENT_SUPPORT}
          { If we're expecting MIME parts, process 'em }
          if FWebNode.MimeBoundary <> '' then
          begin
            AttachHandler.ProcessMultiPartForm(Resp, XMLStream, FWebNode.MimeBoundary, Nil,
                                               FConverter.Attachments, FConverter.TempDir);
            { Now point RespXML to Envelope }
            RespXML := XMLStream;
          end;
{$ENDIF}
          FConverter.ProcessResponse(RespXML, IntfMD, MethMD, FContext, FHeadersInbound);
        finally
          XMLStream.Free;
        end;
      finally
        Resp.Free;
      end;
    finally
      FConverter.Attachments.Clear;
    end;
  finally
    Req.Free;
  end;

  if (MethMD.CC <> ccSafeCall) and
     (MethMD.ResultInfo <> nil) and
     (MethMD.ResultInfo.Kind = tkFloat) then
    LoadFloatReturn(RetP, GetTypeData(MethMD.ResultInfo).FloatType);

  if (MethMD.ResultInfo <> nil) and (MethMD.ResultInfo.Kind = tkInt64) then
  begin
    asm
       PUSH   ECX
       MOV    ECX, DWORD PTR [RetP]
       MOV    EAX, DWORD PTR [ECX]
       MOV    EDX, DWORD PTR [ECX + 4]
       POP    ECX
    end;
  end;

  if MethMD.CC = ccSafeCall then
  asm
    XOR EAX, EAX  { TODO: handle safecall exceptions... }
    MOV DWORD PTR Result, EAX
  end;
  asm CLD end;
end;

procedure TRIO.ErrorEntry;
begin
  raise Exception.Create(SMethNoRTTI);
end;

function TRIO.GetResponseStream(BindingType: TWebServiceBindingType): TStream;
begin
  if (BindingType in [btMime, btDime]) and
     (soCacheMimeResponse in FConverter.Options) then
    Result := TTempFileStream.Create
  else
    Result := TMemoryStream.Create;
end;

procedure TRIO.DoBeforeExecute(const MethodName: string; Request: TStream);
var
  StrStrm: TStringStream;
  SavedRequest: WideString;
  ReqWideStr: WideString;
begin
  if Assigned(FOnBeforeExecute) then
  begin
    { Ideally we would change the signature of this event to take a Stream.
      The change to stream was necessary for attachment and encoding support.
      And it makes the event consistent.... However, for the sake of
      backward compatibility.... }
    StrStrm := TStringStream.Create('');
    try
      StrStrm.CopyFrom(Request, 0);
      Request.Position := 0;
      ReqWideStr := UTF8Decode(StrStrm.DataString);
      SavedRequest := ReqWideStr;
      FOnBeforeExecute(MethodName, ReqWideStr);
    finally
      StrStrm.Free;
    end;
    if (Length(SavedRequest) <> Length(ReqWideStr)) or (SavedRequest <> ReqWideStr) then
    begin
      // Copy changes made to ReqWideStr in the event back to the Request stream
      StrStrm := TStringStream.Create(string(ReqWideStr));
      try
        StrStrm.Position := 0;
        Request.Size := 0;
        Request.CopyFrom(StrStrm, 0);
        Request.Position := 0;
      finally
        StrStrm.Free;
      end;
    end;
  end;
end;

procedure TRIO.DoAfterExecute(const MethodName: string; Response: TStream);
begin
  if Assigned(FOnAfterExecute) then
  begin
    FOnAfterExecute(MethodName, Response);
    Response.Position := 0;
  end;
end;

end.