invokeregistry.pas

Delphi的Soap一些使用功能控件

function TInvokableClassRegistry.GetInterfaceExternalName(Info: PTypeInfo; const Namespace: string; const InternalIntfName: string): InvString;
var
  Index: Integer;
begin
  Result := InternalIntfName;
  Lock;
  try
    for Index := 0 to Length(FRegIntfs) - 1 do
    begin
      if FRegIntfs[Index].Info = Info then
        if FRegIntfs[Index].Name = InternalIntfName then
        begin
          if FRegIntfs[Index].ExtName <> '' then
            Result := FRegIntfs[Index].ExtName;
          break;
        end;
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetWSDLEncoding(Info: PTypeInfo): InvString;
begin
  Result := GetWSDLEncoding(Info, '');
end;

function TInvokableClassRegistry.GetWSDLEncoding(Info: PTypeInfo; const Namespace: string): InvString;
begin
  Result := GetWSDLEncoding(Info, Namespace, '');
end;

function TInvokableClassRegistry.GetWSDLEncoding(Info: PTypeInfo; const Namespace: string; const InternalIntfName: string): InvString;
var
  Index: Integer;
begin
  Result := '';
  Lock;
  try
    for Index := 0 to Length(FRegIntfs) - 1 do
    begin
      if FRegIntfs[Index].Info = Info then
        if FRegIntfs[Index].Name = InternalIntfName then
        begin
          Result := FRegIntfs[Index].WSDLEncoding;
          break;
        end;
    end;
  finally
    Unlock;
  end;
end;

procedure TInvokableClassRegistry.UnRegisterInterface(Info: PTypeInfo);
begin
  DeleteFromReg(nil, Info);
end;

procedure TInvokableClassRegistry.RegisterExternalMethName(Info: PTypeInfo; const InternalName: string; const ExternalName: InvString);
var
  I, J: Integer;
begin
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
      begin
        J := Length(FRegIntfs[I].MethNameMap);
        SetLength(FRegIntfs[I].MethNameMap, J + 1);
        FRegIntfs[I].MethNameMap[J].Name := InternalName;
        FRegIntfs[I].MethNameMap[J].ExtName := ExternalName;
      end;
  finally
    Unlock;
  end;
end;

procedure TInvokableClassRegistry.RegisterExternalParamName(Info: PTypeInfo; const MethodName, InternalName: string; const ExternalName: InvString);
var
  I, J, K: Integer;
begin
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
      begin
        J := 0;
        while J <= Length(FRegIntfs[I].MethParamNameMap) -1 do
        begin
          if SameText(FRegIntfs[I].MethParamNameMap[J].MethName, MethodName) then
            break;
          J := J + 1;
        end;

        if J = Length(FRegIntfs[I].MethParamNameMap) then
        begin
          SetLength(FRegIntfs[I].MethParamNameMap, J + 1);
          FRegIntfs[I].MethParamNameMap[J].MethName := MethodName;
        end;
        K := Length(FRegIntfs[I].MethParamNameMap[J].ParamNameMap);
        SetLength(FRegIntfs[I].MethParamNameMap[J].ParamNameMap, K + 1);
        FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].Name := InternalName;
        FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].ExtName := ExternalName;
        break;
      end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetParamExternalName(Info: PTypeInfo; const MethodName, InternalParamName: string): InvString;
var
  I, J, K: Integer;
begin
  Result := InternalParamName;
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
      begin
        for J := 0 to Length(FRegIntfs[I].MethParamNameMap) -1 do
          if SameText(FRegIntfs[I].MethParamNameMap[J].MethName, MethodName) then
          begin
            for K := 0 to Length(FRegIntfs[I].MethParamNameMap[J].ParamNameMap) -1 do
              if SameText(FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].Name, InternalParamName) then
              begin
                if FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].ExtName <> '' then
                  Result := FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].ExtName;
                Exit;
              end;
          end;
      end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetParamInternalName(Info: PTypeInfo; const MethodName: string; const ExternalParamName: InvString): string;
var
  I, J, K: Integer;
begin
  Result := ExternalParamName;
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
      begin
        for J := 0 to Length(FRegIntfs[I].MethParamNameMap) -1 do
          if SameText(FRegIntfs[I].MethParamNameMap[J].MethName, MethodName) then
          begin
            for K := 0 to Length(FRegIntfs[I].MethParamNameMap[J].ParamNameMap) -1 do
              if SameText(FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].ExtName, ExternalParamName) then
              begin
                if FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].Name <> '' then
                  Result := FRegIntfs[I].MethParamNameMap[J].ParamNameMap[K].Name;
                Exit;
              end;
          end;
      end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetMethExternalName(Info: PTypeInfo; const MethodIntName: string): InvString;
var
  I, J: Integer;
begin
  Result := MethodIntName;
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if FRegIntfs[I].Info = Info then
      begin
        for J := 0 to Length(FRegIntfs[I].MethNameMap) -1 do
          if SameText(FRegIntfs[I].MethNameMap[J].Name, MethodIntName) then
          begin
            if FRegIntfs[I].MethNameMap[J].ExtName <> '' then
              Result := FRegIntfs[I].MethNameMap[J].ExtName;
            Exit;
          end;
      end;
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetMethInternalName(Info: PTypeInfo; const MethodExtName: InvString): string;
var
  I, J: Integer;
begin
  Result := MethodExtName;
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if FRegIntfs[I].Info = Info then
      begin
        for J := 0 to Length(FRegIntfs[I].MethNameMap) -1 do
          if SameText(FRegIntfs[I].MethNameMap[J].ExtName, MethodExtName) then
          begin
            if FRegIntfs[I].MethNameMap[J].Name <> '' then
              Result := FRegIntfs[I].MethNameMap[J].Name;
            Exit;
          end;
      end;
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetInterfaceTypeInfo(const AGUID: TGUID): Pointer;
var
  I: Integer;
begin
  Result := nil;
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if IsEqualGUID(AGUID, FRegIntfs[I].GUID) then
      begin
        Result := FRegIntfs[I].Info;
        Exit;
      end;
    end;
  finally
    UnLock;
  end;
end;

procedure TInvokableClassRegistry.GetInterfaceInfoFromName(
  const UnitName, IntfName: string; var Info: PTypeInfo; var IID: TGUID);
var
  I: Integer;
begin
  Info := nil;
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if SameText(IntfName, FRegIntfs[I].Name)
          and ((UnitName = '') or (SameText(UnitName, FRegIntfs[I].UnitName)))
      then
      begin
        Info := FRegIntfs[I].Info;
        IID := FRegIntfs[I].GUID;
      end;
    end;
  finally
    UnLock;
  end;
end;

function  TInvokableClassRegistry.GetActionURIOfIID(const AGUID: TGUID): string;
begin
  Result := GetActionURIOfInfo(GetInterfaceTypeInfo(AGUID), '', -1);
end;

function TInvokableClassRegistry.GetActionURIOfInfo(const IntfInfo: PTypeInfo; const MethodName: WideString; MethodIndex: Integer): string;
var
  I: Integer;
  SOAPActions: TStringDynArray;
begin
  SetLength(SOAPActions, 0);
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if IntfInfo = FRegIntfs[I].Info then
      begin
        { NOTE: Method name is ignored when an explicit SOAPAction is set unless it
                contains the Operation format specifier }
        if (ioHasDefaultSOAPAction in FRegIntfs[I].InvokeOptions) then
        begin
          Result := FRegIntfs[I].SOAPAction;
          if MethodName <> '' then
            Result := SubstituteStrings(Result, SOperationNameSpecifier, MethodName);
        end
        else if (ioHasAllSOAPActions in FRegIntfs[I].InvokeOptions) then
        begin
          SOAPActions := StringToStringArray(FRegIntfs[I].SOAPAction, FRegIntfs[I].SOAPAction[1]);
          if (MethodIndex >= 0) and (MethodIndex < Length(SOAPActions)) then
            Result := SOAPActions[MethodIndex]
          else
            Result := '';
        end else
        begin
          { NOTE: For backward compatibility reasons, we use the Namespace#MethodName
                  as the default SOAPAction. If you need to customize the SOAPAction,
                  or if you can't use that logic (like when more than one interface
                  uses the same namespace), use RegisterDefaultSOAPAction or
                  RegisterAllSOAPActions to specify another SOAPAction }
          Result := FRegIntfs[I].Namespace + '#' + MethodName;
        end;
        Exit;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TInvokableClassRegistry.GetUDDIInfo(const IntfInfo: PTypeInfo; var Operator, BindingKey: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  Lock;
  try
    I := GetIntfIndex(IntfInfo);
    if I >= 0 then
    begin
      if (ioHasUDDIInfo in FRegIntfs[I].InvokeOptions) then
      begin
        Operator := FRegIntfs[I].UDDIOperator;
        BindingKey := FRegIntfs[I].UDDIBindingKey;
        Result := True;
      end;	
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetUDDIInfo(const AGUID: TGUID; var Operator, BindingKey: string): Boolean;
begin
  Result := GetUDDIInfo(GetInterfaceTypeInfo(AGUID), Operator, BindingKey);
end;

{$IFDEF WIDE_RETURN_PARAM_NAMES}
function TInvokableClassRegistry.GetReturnParamNames(const IntfInfo: PTypeInfo): InvString;
{$ELSE}
function TInvokableClassRegistry.GetReturnParamNames(const IntfInfo: PTypeInfo): string;
{$ENDIF}
var
  I: Integer;
begin
  Result := SDefaultReturnParamNames;
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if IntfInfo = FRegIntfs[I].Info then
      begin
        if (ioHasReturnParamNames in FRegIntfs[I].InvokeOptions) then
          Result := FRegIntfs[I].ReturnParamNames;
        Exit;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TInvokableClassRegistry.GetInfoForURI(const PathURI, ActionURI: string; var AClass: TClass; var IntfInfo: PTypeInfo; var AMeth: string): Boolean;

  function FindViaSOAPAction: Boolean;
  var
    I: