webservexp.pas

delphi7 webservice soap 补丁

        end;
      end;
    finally
      Methods.Free;
    end;
  end;
end;

function TWebServExp.GetMessageName(const MethName: WideString; MethIndex: Integer;
                                    MsgType: MessageType; const ASuffix: WideString): WideString;
var
  Prefix: WideString;
begin
  Prefix := IntToStr(MethIndex);
  case MsgType of
    mtInput:        Result := MethName + Prefix + SRequest;
    mtOutput:       Result := MethName + Prefix + SResponse;
    mtHeaderInput:  Result := MethName + Prefix + SHeader + SRequest;
    mtHeaderOutput: Result := MethName + Prefix + SHeader + SResponse;
    mtFault:        Result := MethName + Prefix + SFault;
  end;
  { Use suffix for Operations with multiple faults since
    the fault message can have only a single part. }
  Result := Result + ASuffix;
end;

function TWebServExp.AddMessage(const Messages: IMessages; const Name: WideString): IMessage;
begin
  Result := Messages.Add(Name);
end;

procedure TWebServExp.AddFaultMessages(const IntfMD: TIntfMetaData; MethIndex: Integer;
                                       const Messages: IMessages; const MethodExtName: WideString;
                                       WSDLDoc: IWSDLDocument);
var
  I: Integer;
  TnsPre: WideString;
  ExceptItems: TExceptionItemArray;
  NewMessage: IMessage;
  Parts: IParts;
  MessageName: WideString;
begin
  TnsPre := GetPrefixForURI(WSDLDoc.Definition, TargetNameSpace);
  ExceptItems := InvRegistry.GetExceptionInfoForInterface(IntfMD.Info);

  { Publish fault messages }
  for I := 0 to Length(ExceptItems) -1 do
  begin
    if ExceptionUsedWithMethod(ExceptItems[I], MethodExtName) then
    begin
      MessageName := GetMessageName(MethodExtName, MethIndex, mtFault, IntToStr(I));
      NewMessage := AddMessage(Messages, MessageName);
      Parts := NewMessage.Parts;
      Parts.Add(ExceptItems[I].ClassType.ClassName,  '',
                           GetXMLSchemaType(ExceptItems[I].ClassType.ClassInfo));
    end;
  end;
end;

procedure TWebServExp.AddHeaders(const IntfMD: TIntfMetaData; MethIndex: Integer;
                                 const Messages: IMessages; const MethodExtName: WideString);
var
  NewMessage: IMessage;
  Parts: IParts;
  HeaderItems: THeaderItemArray;
  I: Integer;
  HeaderName, TypeName: WideString;
  AClass: TClass;
begin
  HeaderItems := InvRegistry.GetRequestHeaderInfoForInterface(IntfMD.Info);
  NewMessage := nil;
  for I := 0 to Length(HeaderItems)-1 do
  begin
    if HeaderUsedWithMethod(HeaderItems[I], MethodExtName, hmtRequest) then
    begin
      if not Assigned(NewMessage) then
        NewMessage := AddMessage(Messages, GetMessageName(MethodExtName, MethIndex, mtHeaderInput));
      AClass := HeaderItems[I].ClassType;
      HeaderName := InvRegistry.GetHeaderName(IntfMD.Info, AClass);
      TypeName := GetXMLSchemaType(AClass.ClassInfo);
      Parts := NewMessage.Parts;
      Parts.Add(HeaderName, '', TypeName);
    end;
  end;
  HeaderItems := InvRegistry.GetResponseHeaderInfoForInterface(IntfMD.Info);
  NewMessage := nil;
  for I := 0 to Length(HeaderItems) -1 do
  begin
    if HeaderUsedWithMethod(HeaderItems[I], MethodExtName, hmtResponse) then
    begin
      if not Assigned(NewMessage) then
        NewMessage := AddMessage(Messages, GetMessageName(MethodExtName, MethIndex, mtHeaderOutput));
      AClass := HeaderItems[I].ClassType;
      HeaderName := InvRegistry.GetHeaderName(IntfMD.Info, AClass);
      TypeName := GetXMLSchemaType(AClass.ClassInfo);
      Parts := NewMessage.Parts;
      Parts.Add(HeaderName, '', TypeName);
    end;
  end;
end;

procedure TWebServExp.AddMessages(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);
var
  IntfMethArray: TIntfMethEntryArray;
  ParamArray: TIntfParamEntryArray;
  Methods, Params, NoOfMethods, NoOfParams: Integer;
  ParamType: string;
  Messages: IMessages;
  NewMessage: IMessage;
  Parts: IParts;
  MethodExtName, ParamExtName: WideString;
begin
  IntfMethArray := nil;
  ParamArray    := nil;
  IntfMethArray := IntfMD.MDA;
  NoOfMethods   := Length(IntfMethArray);

  { Add WSDL Message and its parts }
  Messages := WSDLDoc.Definition.Messages;

  for Methods := 0 to NoOfMethods -1 do
  begin
    ParamArray := IntfMD.MDA[Methods].Params;
    NoOfParams := Length(ParamArray);

    { Add InOut parts }
    { Note: We always have a Message for the request - irrespective of in parameters }
    MethodExtName := InvRegistry.GetMethExternalName(IntfMD.Info, IntfMD.MDA[Methods].Name);
    NewMessage := AddMessage(Messages, GetMessageName(MethodExtName, Methods, mtInput));
    Parts := NewMessage.Parts;
    for Params := 0 to NoOfParams-2 do  { Skip Self/this }
    begin
      { Note: No pfOut implies [in] parameter }
      if not (pfOut in ParamArray[Params].Flags) then
      begin
        ParamType := GetXMLSchemaType(ParamArray[Params].Info);
        ParamExtName := InvRegistry.GetParamExternalName(IntfMD.Info, MethodExtName, ParamArray[Params].Name);
        Parts.Add(ParamExtName,'',ParamType);
      end;
    end;

    { Add Out parts }
    { Note: We always have a Message for the response - irrespective of return|out }
    NewMessage := AddMessage(Messages, GetMessageName(MethodExtName, Methods, mtOutput));
    Parts := NewMessage.Parts;
    for Params := 0 to NoOfParams-2 do  { Skip Self/this }
    begin
      { pfOut or pfVar implies [out] parameter }
      if ( (pfOut in ParamArray[Params].Flags) or (pfVar in ParamArray[Params].Flags) ) then
      begin
        ParamType := GetXMLSchemaType(ParamArray[Params].Info);
        ParamExtName := InvRegistry.GetParamExternalName(IntfMD.Info, MethodExtName, ParamArray[Params].Name);
        Parts.Add(ParamExtName,'',ParamType);
      end;
    end;

    { For Functions create a response }
    if IntfMD.MDA[Methods].ResultInfo <> nil then
    begin
      ParamType := GetXMLSchemaType(IntfMD.MDA[Methods].ResultInfo);
      Parts.Add(SReturn, '', ParamType);
    end;

    { Add headers - if any have been registered }
    AddHeaders(IntfMD, Methods, Messages, MethodExtName);
    { And faults }
    AddFaultMessages(IntfMD, Methods, Messages, MethodExtName, WSDLDoc);
  end;
end;

procedure TWebServExp.AddPortTypes(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);

  function AddOperation(const Operations: IOperations; const MethName, Request, Response: WideString): IOperation;
  begin
    Result := Operations.Add(MethName, Request, '', Response);
  end;

var
  IntfMethArray: TIntfMethEntryArray;
  Methods, I, NoOfMethods: Integer;
  PortTypes: IPortTypes;
  PortType: IPortType;
  Operations: IOperations;
  Operation: IOperation;
  PortExtName, MethodExtName: WideString;
  TnsPre: WideString;
  ExceptItems: TExceptionItemArray;
  MessageName: WideString;
begin
  { Add WSDL PortType and its Operations }
  IntfMethArray := nil;
  IntfMethArray := IntfMD.MDA;
  NoOfMethods   := Length(IntfMethArray);

  PortTypes := WSDLDoc.Definition.PortTypes;
  PortExtName := InvRegistry.GetInterfaceExternalName(IntfMD.Info,'',IntfMD.Name);
  PortType := PortTypes.Add(PortExtName);
  TnsPre := GetPrefixForURI(WSDLDoc.Definition, TargetNameSpace);
  ExceptItems := InvRegistry.GetExceptionInfoForInterface(IntfMD.Info);

  { Operations }
  for Methods := 0 to NoOfMethods -1 do
  begin
    Operations := PortType.Operations;
    MethodExtName := InvRegistry.GetMethExternalName(IntfMD.Info, IntfMD.MDA[Methods].Name);
    Operation := AddOperation(Operations, MethodExtName,
                              TnsPre+':'+GetMessageName(MethodExtName, Methods, mtInput),
                              TnsPre+':'+GetMessageName(MethodExtName, Methods, mtOutput));

    { Add operation <fault> node }
    for I := 0 to Length(ExceptItems) -1 do
    begin
      if ExceptionUsedWithMethod(ExceptItems[I], MethodExtName) then
      begin
        MessageName := GetMessageName(MethodExtName, Methods, mtFault, IntToStr(I));
        Operation.Faults.Add(ExceptItems[I].ClassType.ClassName,
                             TnsPre+ ':' + MessageName);
      end;
    end;
  end;
end;

function IsInputParam(const Param: TIntfParamEntry): Boolean;
begin
  { To be consistent with AddMessages we'll assume no 'pfOut' makes
    it an in parameter.
    NOTE: This function does *NOT* mean it's not an Out parameter }
  Result := not (pfOut in Param.Flags);
end;

function IsOutputParam(const Param: TIntfParamEntry): Boolean;
begin
  Result := (pfOut in Param.Flags) or (pfVar in Param.Flags);
end;

function GetBindingType(const ParamInfo: PTypeInfo): TWebServiceBindingType; overload;
var
  ClsType: TClass;
begin
  { Default to btSOAP }
  Result := btSoap;

  if ParamInfo = nil then
    Exit;

  { Here we attempt to detect if it's an attachment. Attachments parameters
    can be TSOAPAttachment or TSOAPAttachment-derived.
    Arrays of the latter or classes that contain members of type
    TSOAPAttachment(derived) are *NOT* considered attachment. The latter
    because WSDL does not provide for a way to describe a part that's
    non-Multipart and yet contains Multipart members. The former because
    every SOAP implementation seems to ignore the array portion and maps
    the parameter to a plain attachment }
  if ParamInfo.Kind = tkClass then
  begin
    ClsType := GetTypeData(ParamInfo).ClassType;
    if ClsType.InheritsFrom(TSOAPAttachment) then
    begin
      Result := btMIME;
      Exit;
    end;
  end;
end;

function GetBindingType(const Param: TIntfParamEntry): TWebServiceBindingType; overload;
begin
  Result := GetBindingType(Param.Info);
end;

function GetBindingType(const MethEntry: TIntfMethEntry;
                        Input: Boolean): TWebServiceBindingType; overload;
var
  I: Integer;
  ParamArray: TIntfParamEntryArray;
begin
  { Default to SOAP }
  Result := btSoap;
  ParamArray := MethEntry.Params;

  if (Input) then
  begin
    { Skip this/Self }
    for I := 0 to Length(ParamArray)-2 do
    begin
      if (IsInputParam(ParamArray[I])) then
      begin
        Result := GetBindingType(ParamArray[I]);
        { End as soon as we get anything other than SOAP binding }
        if Result <> btSoap then
          Exit;
      end;
    end;
  end else
  begin
    { Skip this/Self }
    for I := 0 to Length(ParamArray)-2 do
    begin
      if (IsOutputParam(ParamArray[I])) then
      begin
        Result := GetBindingType(ParamArray[I]);
        { End as soon as we get anything other than SOAP binding }
        if Result <> btSoap then
          Exit;
      end;
    end;
    { For output, we also check the return type, if any }
    Result := GetBindingType(MethEntry.ResultInfo);
  end;
end;

procedure TWebServExp.AddBinding(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);

var
  NewNode, SoapBodyNode, SoapHeaderNode, PartNode, ContentNode: IXMLNode;
  HeaderItems: THeaderItemArray;
  TnsPre: WideString;

  function GetOverloadDigit( const MethNames: TWideStrings; Name: WideString): string;
  var
    I, Count: Integer;
  begin
    Result := '';
    Count := 0;
    for I := 0 to MethNames.Count -1 do
      if SameText(MethNames[I], Name) then
        Inc(Count);
    MethNames.Add(Name);
    if Count > 0 then
      Result := IntToStr(Count);
  end;

  procedure SetupSoapBodyNode(const SBodyNode: IXMLNode);
  begin
    { SBodyNode.Attributes[SParts] := ''; }
    SBodyNode.Attributes[SUse] := SSoapBodyUseEncoded;
    SBodyNode.Attributes[SEncodingStyle] := SSoap11EncodingS5;
    SBodyNode.Attributes[SNameSpace] := InvRegistry.GetNamespaceByGUID(IntfMD.IID);
  end;

  procedure SetupSoapHeaderNode(const HeaderNode: IXMLNode;
                                const MsgName, PartName, Namespace: WideString;
                                Required: Boolean);
  const
    Prefix = 'n1';
  begin
    if Required then
    begin
      HeaderNode.DeclareNameSpace(Prefix, Wsdlns);
      HeaderNode.SetAttribute(MakeNodeName(Prefix, SRequired), STrue);
    end;
    HeaderNode.Attributes[SUse] := SSoapBodyUseEncoded;
    HeaderNode.Attributes[SMessage] := MsgName;
    HeaderNode.Attributes[SPart] := PartName;
    HeaderNode.Attributes[SEncodingStyle] := SSoap11EncodingS5;
    HeaderNode.Attributes[SNameSpace] := Namespace;
  end;

  function HeaderRequired(const MethName: WideString; Item: IntfHeaderItem): Boolean;
  var
    Meths: TStringList;