webservexp.pas

delphi7 webservice soap 补丁

{*******************************************************}
{                                                       }
{       CodeGear Delphi Visual Component Library        }
{       Web services description language (WSDL)        }
{       generation from RTTI                            }
{                                                       }
{  	    Copyright (c) 1995-2007 CodeGear	        }
{                                                       }
{*******************************************************}

unit WebServExp;

interface

uses
  SysUtils, Classes, {Variants, ActiveX,} IntfInfo, TypInfo, XMLIntf, XMLDoc, xmldom, XmlSchema,
  WSDLIntf, WSDLBind, XMLSchemaTags;

type

  ArgumentType = (argIn, argOut, argInOut, argReturn);
  MessageType  = (mtInput, mtOutput, mtHeaderInput, mtHeaderOutput,
                  mtFault);

  TSchemaType = record
    TypeName: WideString;
    NameSpace: WideString;
    TypeInfo: PTypeinfo;
    NSPrefix: WideString;
    XSGenerated: Boolean;
  end;

  TSchemaTypeArray = array of TSchemaType;

  IWebServExp = interface
  ['{77099743-C063-4174-BA64-53847693FB1A}']
    function  FindOrAddSchema(const ATypeInfo: PTypeinfo; const TnsURI: string): Boolean;
    procedure GenerateXMLSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo, ParentInfo: PTypeinfo; Namespace: WideString);
  end;

  TBeforePublishingTypesEvent = procedure(const WebServ: IWebServExp) of object;
  TPublishingTypeEvent = procedure(const WebServ: IWebServExp; const SchemaDef: IXMLSchemaDef;
                                   const ATypeInfo: PTypeinfo; Namespace: WideString) of object;
  TAfterPublishingWSDLEvent = procedure(const WSDLDoc: IWSDLDocument) of object;

  TWebServExp = class;

  IWebServExpAccess = interface
  ['{1BB5EB76-AC77-47EE-BCF2-99C7B54386C3}']
    function GetWebServExp: TWebServExp;
  end;

  TWebServExp = class(TInterfacedObject, IWebServExp, IWebServExpAccess)
  private
    Definition: IDefinition;
    ComplexTypeList: TStringList;
    bHasComplexTypes: Boolean;
    FServiceAddress: WideString;
    FBindingType: TWebServiceBindingType;
    FWSDLElements: TWSDLElements;
    FImportNames: TWideStrings;
    FImportLocation: TWideStrings;
    FArrayAsComplexContent: Boolean;
    SchemaArray: TSchemaTypeArray;
    FTargetNameSpace: WideString;

    FOnBeforePublishingTypes: TBeforePublishingTypesEvent;
    FOnPublishingType: TPublishingTypeEvent;
    FOnAfterPublishingWSDL: TAfterPublishingWSDLEvent;

    procedure GenerateWSDL(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument;  PortNames, Locations: array of WideString);
    procedure GenerateNestedArraySchema(SchemaDef: IXMLSchemaDef; ComplexType: IXMLComplexTypeDef; const ATypeInfo: PTypeinfo; var Dimension: Integer; Namespace: WideString);
    procedure AddImports(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);
    procedure AddTypes(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);
    function  GetMessageName(const MethName: WideString; MethIndex: Integer; MsgType: MessageType; const ASuffix: WideString = ''): WideString;
    function  AddMessage(const Messages: IMessages; const Name: WideString): IMessage;
    procedure AddMessages(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);
    procedure AddHeaders(const IntfMD: TIntfMetaData; MethIndex: Integer;
                         const Messages: IMessages; const MethodExtName: WideString);
    procedure AddFaultMessages(const IntfMD: TIntfMetaData; MethIndex: Integer;
                         const Messages: IMessages; const MethodExtName: WideString;
                         WSDLDoc: IWSDLDocument);
    procedure AddPortTypes(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);
    procedure AddBinding(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);
    procedure AddServices(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument; PortNames: array of WideString; Locations: array of WideString);
    function  GetXMLSchemaType(const ParamTypeInfo: PTypeInfo): string;
    function  GetXMLSchemaTypeName(const ParamTypeInfo: PTypeInfo): WideString;
    function  IsComplexType(const ParamType: TTypeKind ):Boolean; overload;
    function  IsComplexType(const ParamTypeInfo: PTypeInfo): Boolean; overload;
    procedure SetBindingType(const Value: TWebServiceBindingType);
    procedure SetServiceAddress(const Value: WideString);
    function  GetImportNamespace(const Index: Integer): WideString;
    procedure SetImportNamespace(const Index: Integer; const Value: WideString);
    function  GetImportLocation(const Index: Integer): WideString;
    procedure SetImportLocation(const Index: Integer; const Value: WideString);
    procedure SetArrayType(const Value: Boolean);
    function  GetPrefixForURI(SchemaDef: IXMLSchemaDef; const URI: WideString): WideString; overload;
    function  GetPrefixForURI(Def: IDefinition; const URI: WideString): WideString; overload;
    function  GetPrefixForTypeInfo(const ATypeInfo: PTypeinfo): WideString; overload;
    function  AddNamespaceURI(RootNode: IXMLNode; const URI: WideString): WideString;
    function  GetNodeNameForURI(SchemaDef: IXMLSchemaDef; const URI: WideString): WideString;
    procedure GenerateArraySchema(SchemaDef: IXMLSchemaDef; const ATypeInfo: PTypeinfo; const Namespace: WideString);
    procedure GenerateEnumSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo: PTypeinfo; const Namespace: WideString);
    procedure GenerateAliasSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo: PTypeinfo; const Namespace: WideString;
                                  const ABaseTypeInfo: PTypeInfo = nil);
    procedure GenerateClassSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo, ParentInfo: PTypeinfo; const Namespace: WideString);
    procedure GenerateDerivedClassSchema(SchemaDef: IXMLSchemaDef; const ParentTypeInfo: PTypeinfo; const Namespace: WideString);
    procedure GetAllSchemaTypes(const IntfMD: TIntfMetaData);
    procedure GetSchemaTypes(const ATypeInfo, ParentInfo: PTypeinfo);
    function  FindOrAddSchema(const ATypeInfo: PTypeinfo; const TnsURI: string): Boolean;
    procedure GetClassSchema(const ATypeInfo, ParentInfo: PTypeinfo);
    procedure GetDerivedClassSchema(const ParentTypeInfo: PTypeinfo);
    function  IsSchemaGenerated(const ATypeInfo: PTypeinfo; const TnsURI: WideString): Boolean;
    procedure GetArraySchema(const ATypeInfo: PTypeinfo);

  public
    constructor Create;
    destructor Destroy; override;
    procedure  GetWSDLForInterface(const IntfTypeInfo: Pointer; WSDLDoc: IWSDLDocument; PortNames, Locations: array of WideString);
    procedure  GenerateXMLSchema(SchemaDef: IXMLSchemaDef; const ATypeInfo, ParentInfo: PTypeinfo; Namespace: WideString);

    function GetWebServExp: TWebServExp;

    property ImportNames [const Index: Integer]: WideString read GetImportNamespace write SetImportNamespace;
    property ImportLocations[const Index: Integer]: WideString read GetImportLocation write SetImportLocation;
    property TargetNameSpace: WideString read FTargetNameSpace write FTargetNameSpace;

  published
    property ArrayAsComplexContent: Boolean read FArrayAsComplexContent write SetArrayType;
    property BindingType: TWebServiceBindingType read FBindingType write SetBindingType;
    property ServiceAddress: WideString read FServiceAddress write SetServiceAddress;
    property WSDLElements: TWSDLElements read FWSDLElements write FWSDLElements default [weServiceIntf];

    property OnBeforePublishingTypes: TBeforePublishingTypesEvent read FOnBeforePublishingTypes write FOnBeforePublishingTypes;
    property OnPublishingType: TPublishingTypeEvent read FOnPublishingType write FOnPublishingType;
    property OnAfterPublishingWSDL: TAfterPublishingWSDLEvent read FOnAfterPublishingWSDL write FOnAfterPublishingWSDL;
  end;

{ Returns the BindingType of a particular Method. Input species whether the
  request/call or response/return since a method may have one input binding
  and another binding for output }
function GetBindingType(const MethEntry: TIntfMethEntry; Input: Boolean): TWebServiceBindingType; overload;

{ Returns the underlying of an alias of the specified TypeKind, if any }
function GetAliasBaseTypeInfo(const ParamType: TTypeKind): PTypeInfo;

function IsBaseClassTypeInfo(const ATypeInfo: PTypeInfo): Boolean;

implementation

uses InvokeRegistry, SOAPConst, XSBuiltIns;

{$IFDEF LINUX}
{$IFNDEF OPENDOM}
{$DEFINE OPENDOM}
{$ENDIF}
{$ENDIF}
{$IFDEF MSWINDOWS}
//{$DEFINE OPENDOM}
{$ENDIF}

function IsBaseClassTypeInfo(const ATypeInfo: PTypeInfo): Boolean;
begin
  Result := (ATypeInfo = TypeInfo(TObject)) or
            (ATypeInfo = TypeInfo(TRemotable)) or
            (ATypeInfo = TypeInfo(TSOAPHeader)) or
            (ATypeInfo = TypeInfo(ERemotableException));
end;

{ WebServExp Implementation }
constructor TWebServExp.Create;
begin
  ComplexTypeList := TStringList.Create;
  FWSDLElements := [weServiceIntf];
  FImportNames := TWideStrings.Create;
  FImportLocation := TWideStrings.Create;
  FArrayAsComplexContent := True;
end;

destructor TWebServExp.Destroy;
begin
  ComplexTypeList.Free;
  FImportNames.Free;
  FImportLocation.Free;
  inherited Destroy;
end;

procedure TWebServExp.SetArrayType(const Value: Boolean);
begin
  FArrayAsComplexContent := Value;
end;

{ Set default binding type }
procedure TWebServExp.SetBindingType(const Value: TWebServiceBindingType);
begin
  FBindingType := Value;
end;

procedure TWebServExp.SetServiceAddress(const Value: WideString);
begin
  FServiceAddress := Value;
end;

function  TWebServExp.GetImportNamespace(const Index: Integer): WideString;
begin
  if FImportNames.Count > Index  then
    Result := FImportNames.Strings[Index]
  else
    Result := '';
end;

function  TWebServExp.GetImportLocation(const Index: Integer): WideString;
begin
  if FImportLocation.Count > Index  then
    Result := FImportLocation.Strings[Index]
  else
    Result := '';
end;

procedure TWebServExp.SetImportNamespace(const Index: Integer; const Value: WideString);
begin
  FImportNames.Insert(Index, Value);
end;

procedure TWebServExp.SetImportLocation(const Index: Integer; const Value: WideString);
begin
  FImportLocation.Insert(Index, Value);
end;

procedure TWebServExp.GetWSDLForInterface(const IntfTypeInfo: Pointer; WSDLDoc: IWSDLDocument; PortNames,  Locations: array of WideString);
var
  IntfMD: TIntfMetaData;
begin
  bHasComplexTypes := False;
  GetIntfMetaData(IntfTypeInfo, IntfMD);
  GenerateWSDL(IntfMD, WSDLDoc, PortNames,  Locations);
end;


procedure TWebServExp.GenerateWSDL(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument; PortNames, Locations: array of WideString);
var
  Encoding: WideString;
begin
  if IntfMD.Name <> '' then
  begin
    { Add WSDL:Definitions and its attributes }
    Definition := WSDLDoc.Definition;
    Definition.Attributes[Sname] := IntfMD.Name+SService;
    if (TargetNamespace <> '') then
    begin
      Definition.Attributes[Stns]  := TargetNamespace;
{$IFDEF OPENDOM}
      Definition.DeclareNameSpace('tns', TargetNameSpace);
{$ELSE}
      Definition.Attributes['xmlns:tns'] := TargetNamespace;
{$ENDIF}
    end;
{$IFDEF OPENDOM}
    Definition.DeclareNameSpace('soap', Soapns);                { do not localize }
    Definition.DeclareNameSpace('soapenc', SSoap11EncodingS5);  { do not localize }
    Definition.DeclareNamespace('mime', SWSDLMIMENamespace);    { do not localize }
{$ELSE}
    Definition.Attributes['xmlns:soap'] := Soapns;
    Definition.Attributes['xmlns:soapenc'] := SSoap11EncodingS5;
    Definition.Attributes['xmlns:mime'] := SWSDLMIMENamespace;
{$ENDIF}

    { Add Encoding }
    if WSDLDoc.Encoding = '' then
    begin
      Encoding := InvRegistry.GetWSDLEncoding(IntfMD.Info, '', IntfMD.Name);
      if Encoding <> '' then
        WSDLDoc.Encoding := Encoding
      else
        WSDLDoc.Encoding := 'utf-8';
    end;

     { Set the Namespace prefix }
    (WSDLDoc as IXMLDocumentAccess).DocumentObject.NSPrefixBase := SNsPrefix;

     { Add WSDL Types }
    if (WeTypes in FWSDLElements) or (WeServiceIntf in FWSDLElements) then
      AddTypes(IntfMD, WSDLDoc);
     { Add Imports }
    if (WeImport in FWSDLElements) or (WeServiceImpl in FWSDLElements) then
      if (FImportNames.Count = FImportLocation.Count) then
        AddImports(IntfMD, WSDLDoc);
    { Add WSDL Message and its parts }
    if ((weMessage in FWSDLElements) or (weServiceIntf in FWSDLElements) ) then
      AddMessages(IntfMD, WSDLDoc);
    { Add WSDL PortType and its Operations }
    if ((wePortType in FWSDLElements) or (weServiceIntf in FWSDLElements) ) then
      AddPortTypes(IntfMD, WSDLDoc);
    { Add WSDL Binding for operations }
    if (WeBinding in FWSDLElements) or (weServiceIntf in FWSDLElements) then
      AddBinding(IntfMD, WSDLDoc);
    { Add WSDL Service and its port }
    if (WeService in FWSDLElements) or (WeServiceImpl in FWSDLElements) then
      AddServices(IntfMD, WSDLDoc, PortNames, Locations);
    { Give user a chance to customize WSDL }
    if Assigned(FOnAfterPublishingWSDL) then
      FOnAfterPublishingWSDL(WSDLDoc);
  end;
end;

procedure TWebServExp.AddImports(const IntfMD: TIntfMetaData; WSDLDoc: IWSDLDocument);
var
  Imports: IImports;
  Index: Integer;
begin
  Imports := WSDLDoc.Definition.Imports;
  for Index := 0 to FImportNames.Count -1 do
    Imports.Add(FImportNames.Strings[Index], FImportLocation.Strings[Index]);
end;

function HeaderUsedWithMethod(HeaderItem: IntfHeaderItem;
         MethodExtName: WideString; MType: EHeaderMethodType): Boolean;
var
  Methods: TStrings;
  I: Integer;
begin
  Result := HeaderItem.MethodNames = '';
  if not Result then
  begin
    Methods := TStringList.Create;
    try
      Methods.CommaText := HeaderItem.MethodNames;
      for I := 0 to Methods.Count -1 do
      begin
        if SameText(Methods[I], MethodExtName) then
        begin
          if (not Assigned(HeaderItem.MethodTypes)) or
             (HeaderItem.MethodTypes[I] in [hmtAll, MType]) then
            Result := True;
          break;
        end;
      end;
    finally
      Methods.Free;
    end;
  end;  
end;

function ExceptionUsedWithMethod(ExceptItem: IntfExceptionItem; MethodExtName: WideString): Boolean;
var
  Methods: TStrings;
  I: Integer;
begin
  Result := ExceptItem.MethodNames = '';
  if not Result then
  begin
    Methods := TStringList.Create;
    try
      Methods.CommaText := ExceptItem.MethodNames;
      for I := 0 to Methods.Count -1 do
      begin
        if SameText(Methods[I], MethodExtName) then
        begin
          Result := True;
          break;