wsdlpub.pas

delphi7 webservice soap 补丁

  MethBeg2= '<table>'                                                                  + sLineBreak;
  MethEnt2= '<tr><td width="10%%" class="MethName">&nbsp;</td>' +
            '<td class="ParmName">%s</td><td>%s</td></tr>'                             + sLineBreak;
  MethEnt3= '<span class="MethName">%s(</span>%s<span class="MethName">)</span>';
  MethEnd2= '</table>'                                                                 + sLineBreak;

  IntfEnd=  '</li>' +
            '</ul>' +
            '</td>' +
            '</tr>';
  IntfFtr=  '</table>';

  RegHdr =  '<a name="types"></a><center><h3>Registered Types</h3>' +
            '<table cellpadding=2 cellspacing=1 border=0><tr>' +
            '<td class="TblHdr">Type</td>' +
            '<td class="TblHdr">XML Name</td>' +
            '<td class="TblHdr">Namespace</td>' +
            '<td class="TblHdr">Class</td>' +
            '<td class="TblHdr">Address</td>' +
            '<td class="TblHdr">ExtName</td></tr>';
  RegRow =  '%0:s<tr>' +
            '<td class="%1:s">%2:s</td>' +
            '<td class="%1:s">%3:s</td>' +
            '<td class="%1:s">%4:s</td>' +
            '<td class="%1:s">%5:s %6:s</td>' +
            '<td class="%1:s">%7:d</td>' +
            '<td class="%1:s">%8:s</td></tr>';
  RegFtr =  '</table></center>';
  TTypeKindStrings: array[TTypeKind] of string =  ('(tkUnknown)', '(tkInteger)', '(tkChar)',
                                                   '(tkEnumeration)', '(tkFloat)',
                                                   '(tkString)', '(tkSet)', '',
                                                   '(tkMethod)', '(tkWChar)', '(tkLString)',
                                                   '(tkWString)', '(tkVariant)', '(tkArray)',
                                                   '(tkRecord)', '(tkInterface)', '(tkInt64)',
                                                   '(tkDynArray)');
  sWSILPath = '/inspection.wsil';
var
  Path: string;
  HostScriptBaseURL: String;

  function ValidIntfName(const Entries: TInvRegIntfEntryArray;  const name: string): Boolean;
  var
    Entry: InvRegIntfEntry;
    I: Integer;
  begin
    Result := False;
    if Length(Entries) > 0 then
    begin
      for I := 0 to Length(Entries)-1 do
      begin
        Entry := Entries[I];
        if Entry.Name = name then
        begin
          Result := True;
          Exit;
        end;
      end;
    end;
  end;

  function GetReturnStr(const RInfo: PTypeInfo): string;
  var
    IsScalar: Boolean;
    URI, Name: WideString;
  begin
    Result := 'void ';          { Do not localize }
    if RInfo <> nil then
    begin
      if RemClassRegistry.InfoToURI(RInfo, URI, Name, IsScalar) then
        Result := Name + ' '
      else
        Name := '????';         { Do not localize }
    end;
  end;

  function GetParams(const Params: TIntfParamEntryArray): string;
  const
    Commas : array[Boolean] of string = ('', ', ');
  var
    I: Integer;
    Param: TIntfParamEntry;
    PName, TName: string;
    IsScalar: Boolean;
    URI, Name: WideString;
  begin
    Result := '';
    if Length(Params) > 0 then
    begin
      for I := 0 to Length(Params)-1 do
      begin
        Param := Params[I];
        if Param.Info = nil then
          continue;
        if RemClassRegistry.InfoToURI(Param.Info, URI, Name, IsScalar) then
          TName := Name
        else
          TName := '????';    { Do not localize }
        PName := Param.Name;
        Result:= Format('%s' +                                    { Do not localize }
                        '<span class="MethName">%s</span>'+       { Do not localize }
                        '<span class="ParmName">%s</span>'+       { Do not localize }
                        '<span class="MethName">&nbsp;%s</span>', { Do not localize }
                        [Result, Commas[Length(Result)>0], TName, PName]);
      end;
    end;
  end;

  function GetInterfaceInfo(const name: string): string;
  var
    Entries: TInvRegIntfEntryArray;
    Entry: InvRegIntfEntry;
    I, J: Integer;
    IntfInfo: PTypeInfo;
    IntfMD: TIntfMetaData;
    MethEntry: TIntfMethEntry;
    Namespace: string;
    IntfName : string;
    FuncSig, RetStr: string;
  begin;
    Result := '';
    Pub.GetPortTypeEntries(Entries);

    { Check if it's for a special interface }
    if name <> '' then
    begin
      if ValidIntfName(Entries, name) then
        IntfName := name
      else
        IntfName := '';
    end;

    if Length(Entries) > 0 then
    begin
      Result := IntfHdr;
      if IntfName = '' then
        Result := Result + IntfSectBig + Format(sServiceInfo, [ServiceName]) + IntfSectEnd
      else
      begin
        Result := Result + IntfSectBig + Format(sInterfaceInfo, [HostScriptBaseURL, ServiceName, IntfName]) + IntfSectEnd;
      end;

      for I := 0 to Length(Entries)-1 do
      begin
        Entry := Entries[I];
        if (IntfName <> '') and (Entry.Name <> IntfName) then
          continue;

        IntfInfo := InvRegistry.GetInterfaceTypeInfo(Entry.GUID);
        GetIntfMetaData(IntfInfo, IntfMD);
        Result := Result + IntfBeg;
        { Display linked or plain version of interface name }
        if (IntfName <> '') then
          Result := Result + Format(IntfEntP, [IntfMD.Name])
        else
          Result := Result + Format(IntfEntL, [IntfMD.Name, HostScriptBaseURL]);
        { Add link to WSDL }
        Result := Result + Format(IntfWSDL, [HostScriptBaseURL + '/wsdl/'+IntfMD.Name]);
        if IntfName <> '' then
        begin
          Namespace:= InvRegistry.GetNamespaceByGUID(Entry.GUID);
          Result := Result + Format(IntfNS, [Namespace]);
        end;
        if Entry.Documentation <> '' then
        begin
          Result := Result + IntDoc1;
          Result := Result + Format(IntDoc2, [Entry.Documentation]);
        end;
        if Length(IntfMD.MDA) > 0 then
        begin
          if IntfName <> '' then
            Result := Result + MethBeg2;
          for J := 0 to Length(IntfMD.MDA)-1 do
          begin
            MethEntry := IntfMD.MDA[J];
            if IntfName <> '' then
            begin
              FuncSig:= Format(MethEnt3, [IntfMD.MDA[J].Name, GetParams(MethEntry.Params)]);
              RetStr := GetReturnStr(MethEntry.ResultInfo);
              Result := Result + Format(MethEnt2, [RetStr, FuncSig]);
            end
            else
            begin
              Result := Result + MethBeg + Format(MethEnt, [IntfMD.MDA[J].Name]) + MethEnd;
            end;
          end;
          if IntfName <> '' then
            Result := Result + MethEnd2;
        end;
        Result := Result + IntfEnd;
      end;

      { WSIL Link }
      if IntfName = '' then
      begin
        Result := Result + IntfSectBig + sWSILInfo +
                  Format(sWSILLink, [HostScriptBaseUrl+sWSILPath]) + IntfSectEnd;
      end;

      Result := Result + IntfFtr;
    end;
  end;

  function GetRegisteredTypes: string;
  var
    I: Integer;
    Entry: TRemRegEntry;
    ObjName: string;
    InfoName: string;
    Style: string;
  begin
    Result := '';
    if RemClassRegistry.GetURICount > 0 then
    begin
      Result := RegHdr;
      for I := 0 to RemClassRegistry.GetURICount-1 do
      begin
        RemClassRegistry.GetURIMap(I, Entry);
        if Assigned(Entry.ClassType) then
          ObjName := Entry.ClassType.ClassName
        else
          ObjName := '';
        InfoName := Entry.Info.Name;
        Style := TblCls[I and 1 = 0];
        Result := Format(RegRow, [Result, Style, InfoName,
                                  Entry.Name, Entry.URI,
                                  ObjName, TTypeKindStrings[Entry.Info.Kind],
                                  Integer(Entry.Info), Entry.ExtName]);
      end;
      Result := Result + RegFtr;
    end;
  end;
var
  RegTypes: string;
  IntfInfo: string;
  IntfName: string;
begin
  HostScriptBaseURL := GetHostScriptBaseURL(Request);
  Path := Request.InternalPathInfo;

  { WSIL }
  if SameText(Path, sWSILPath) then
  begin
    WSILInfo(HostScriptBaseURL, Request, Response, Handled);
    Exit;
  end;

  try
    if (Request.QueryFields.Values[sQueryStringTypes] = '1' ) then
      RegTypes := GetRegisteredTypes;
  except
    { Don't let retrieval of bad types bring us down - IOW, since there's no way to enforce
      registration or registration of valid types, for that matter, let's be safe }
  end;

  { See if request was for a special interface }
  IntfName := Request.QueryFields.Values[sQueryStringIntf];
  IntfInfo := GetInterfaceInfo(IntfName);

  Response.Content := Format(HTMLTopTitleNoMarginWSIL, [ServiceName]) +
                      InfoTitle1 +
                      Format(InfoTitle2, [ServiceName, sServiceInfoPage]) +
                      IntfInfo + RegTypes +
                      HTMLEnd;
  Handled := True;
end;

procedure TWSDLHTMLPublish.WSILInfo(const HostScriptBaseURL: string; Request: TWebRequest;
            Response: TWebResponse; var Handled: Boolean);

  procedure GenerateWSIL;
  var
    Entries: TInvRegIntfEntryArray;
    Entry: InvRegIntfEntry;
    I: Integer;
    Inspection: IXMLInspection;
    Service: IXMLServiceType;
    Abstrct: IXMLTypeOfAbstract;
    Name: IXMLNameType;
    Description: IXMLDescriptionType;
    ServiceName: WideString;
  begin
    Inspection := Newinspection;

    Pub.GetPortTypeEntries(Entries);
    if Length(Entries) > 0 then
    begin
      for I := 0 to Length(Entries)-1 do
      begin
        Entry := Entries[I];
        { Service Name }
        if Entry.ExtName <> '' then
          ServiceName := Entry.ExtName
        else
          ServiceName := Entry.Name;

        Service := Inspection.Service.Add;
        { Abstract }
        Abstrct := Service.Add;
        Abstrct.Text := Entry.Documentation;
        { Name }
        Name := Service.Name.Add;
        Name.Text := ServiceName;
        { WSDL Description }
        Description := Service.Description.Add;
        Description.ReferencedNamespace := Wsdlns;
        Description.Location := HostScriptBaseURL + '/wsdl/' + Entry.Name;
      end;
    end;

    Response.Content := Inspection.OwnerDocument.XML.Text;
    Response.ContentType := sTextXML;
    Handled := True;
  end;

begin
  CoInitialize(nil);
  try
    GenerateWSIL;
  finally
    CoUninitialize;
  end;
end;

function TWSDLHTMLPublish.GetTargetNamespace: WideString;
begin
  if (FTargetNamespace <> '') then
    Result := FTargetNamespace
  else
    Result := WSDLIntf.tns;
end;

procedure TWSDLHTMLPublish.SetWebDispatch(const Value: TWebDispatch);
begin
 FWebDispatch.Assign(Value);
end;

{$IFDEF DIAMONDBACK_UP}
function TWSDLHTMLPublish.GetNameSpaceIsStored: Boolean;
begin
  Result := FTargetNameSpace <> 'http://tempuri.org/';
end;
{$ENDIF}

initialization
  { IWSDLPublish registration }
  InvRegistry.RegisterInterface(TypeInfo(IWSDLPublish), SBorlandTypeNamespace,
                                '', IWSDLPublishDoc);
  InvRegistry.RegisterDefaultSOAPAction(TypeInfo(IWSDLPublish),
                                        SBorlandTypeNamespace + '-IWSDLPublish');
  InvRegistry.RegisterInvokableClass(TWSDLPublish);

  { Admin Ini File }
  GetModuleFileName(HInstance, ModuleName, SizeOf(ModuleName));
  ServicePath := Copy(ModuleName, 1, StrLen(ModuleName) - Cardinal(Length(ExtractFileExt(ModuleName))));
  ServiceName := ExtractFileName(ServicePath);
  AdminIniFile:= ServicePath + '_WSDLADMIN.INI';  { do not localize } 
end.