invokeregistry.pas

Delphi的Soap一些使用功能控件

  I, J: Integer;
begin
  Result := nil;
  for I := 0 to Length(FRegIntfs)-1 do
  begin
    for J := 0 to Length(FRegIntfs[I].IntfHeaders)-1 do
    begin
      if (InternalGetHeaderName(FRegIntfs[I].IntfHeaders[J]) = Name) and
         (InternalGetHeaderNamespace(FRegIntfs[I].IntfHeaders[J]) = Namespace) then
      begin
        Result := FRegIntfs[I].IntfHeaders[J].ClassType;
        Exit;
      end;
    end;
  end;
end;

function TInvokableClassRegistry.GetRequestHeaderInfoForInterface(Info: PTypeInfo): THeaderItemArray;
begin
  Result := GetHeaderInfoForInterface(Info, hmtRequest);
end;

function TInvokableClassRegistry.GetResponseHeaderInfoForInterface(Info: PTypeInfo): THeaderItemArray;
begin
  Result := GetHeaderInfoForInterface(Info, hmtResponse);
end;

procedure TInvokableClassRegistry.RegisterException(Info: PTypeInfo; AClass: TClass);
begin
  InternalRegisterException(Info, AClass, '');
end;

procedure TInvokableClassRegistry.RegisterExceptionMethod(Info: PTypeInfo;
          AClass: TClass; const MethodName: string);
begin
  InternalRegisterException(Info, AClass, MethodName);
end;

procedure TInvokableClassRegistry.InternalRegisterException(Info: PTypeInfo; AClass: TClass; const MethodName: string);

  procedure AddExceptionMethod(var ExceptItem: IntfExceptionItem);
  var
    Methods: TStrings;
  begin
    Methods := TStringList.Create;
    try
      Methods.CommaText := ExceptItem.MethodNames;
      { don't add duplicate method names }
      if Methods.IndexOf(MethodName) = -1 then
      begin
        Methods.Add(MethodName);
        ExceptItem.MethodNames := Methods.CommaText;
      end;
    finally
      Methods.Free;
    end;
  end;

var
  I, J, ExceptionIndex: Integer;
begin
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      ExceptionIndex := Length(FRegIntfs[I].IntfExceptions);
      for J := 0 to Length(FRegIntfs[I].IntfExceptions) - 1 do
      if FRegIntfs[I].IntfExceptions[J].ClassType = AClass then
      begin
        ExceptionIndex := J;
        break;
      end;
      { add new Exception class }
      if ExceptionIndex = Length(FRegIntfs[I].IntfExceptions) then
      begin
        SetLength(FRegIntfs[I].IntfExceptions, 1 + Length(FRegIntfs[I].IntfExceptions));
        FRegIntfs[I].IntfExceptions[ExceptionIndex].ClassType := AClass;
      end;
      { add Method Information }
      if MethodName <> '' then
        AddExceptionMethod(FRegIntfs[I].IntfExceptions[ExceptionIndex]);
    end;
  finally
    Unlock;
  end;
end;

procedure TInvokableClassRegistry.DeleteFromReg(AClass: TClass; Info: PTypeInfo);
var
  I, Index, ArrayLen: Integer;
begin
  Lock;
  try
    Index := -1;
    if Assigned(Info) then
      ArrayLen := Length(FRegIntfs)
    else
      ArrayLen := Length(FRegClasses);
    for I := 0 to ArrayLen - 1 do
    begin
      if (Assigned(Info) and (FRegIntfs[I].Info = Info)) or
        (Assigned(AClass) and (FRegClasses[I].ClassType = AClass)) then
      begin
        Index := I;
        break;
      end;
    end;
    if Index <> -1 then
    begin
      if Assigned(Info) then
      begin
        for I := Index to ArrayLen - 2 do
          FRegIntfs[I] := FRegIntfs[I+1];
        SetLength(FRegIntfs, Length(FRegIntfs) -1);
      end else
      begin
        for I := Index to ArrayLen - 2 do
          FRegClasses[I] := FRegClasses[I+1];
        SetLength(FRegClasses, Length(FRegClasses) -1);
      end;
    end;
  finally
    UnLock;
  end;
end;

procedure TInvokableClassRegistry.UnRegisterInvokableClass(AClass: TClass);
begin
  DeleteFromReg(AClass, nil);
end;

{
procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo);
begin
  RegisterInterface(Info, '');
end;

procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo; const Namespace: InvString);
begin
  RegisterInterface(Info, Namespace, '');
end;

procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo; const Namespace: InvString;
                    const WSDLEncoding: InvString);
begin
  RegisterInterface(Info, Namespace, WSDLEncoding, '');
end;

procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo; const Namespace: InvString;
                    const WSDLEncoding: InvString; const Doc: string);
begin
  RegisterInterface(Info, Namespace, WSDLEncoding, Doc, '');
end;
}

procedure TInvokableClassRegistry.RegisterInterface(Info: PTypeInfo; const Namespace: InvString;
                    const WSDLEncoding: InvString; const Doc: string; const ExtName: InvString);
var
  Index: Integer;
  IntfMD: TIntfMetaData;
  I, J: Integer;
  Table: PInterfaceTable;
  URIApp: string;
begin
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
        Exit;
    Index := Length(FRegIntfs);
    SetLength(FRegIntfs, Index + 1);
    GetIntfMetaData(Info, IntfMD, True);
    FRegIntfs[Index].GUID := IntfMD.IID;
    FRegIntfs[Index].Info := Info;
    FRegIntfs[Index].Name := IntfMD.Name;
    FRegIntfs[Index].UnitName := IntfMD.UnitName;
    FRegIntfs[Index].Documentation := Doc;
    FRegIntfs[Index].ExtName := ExtName;
    FRegIntfs[Index].WSDLEncoding := WSDLEncoding;

    if AppNameSpacePrefix <> '' then
      URIApp := AppNameSpacePrefix +  '-';

    { Auto-generate a namespace from the filename in which the interface was declared and
      the AppNameSpacePrefix }
    if Namespace = '' then
      FRegIntfs[Index].Namespace :=  'urn:' + URIApp + IntfMD.UnitName + '-' + IntfMD.Name
    else
    begin
      FRegIntfs[Index].Namespace := Namespace;
      FRegIntfs[Index].InvokeOptions := FRegIntfs[Index].InvokeOptions + [ioHasNamespace];
    end;

    if FRegIntfs[Index].DefImpl = nil then
    begin
      { NOTE: First class that implements this interface wins!! }
      for I := 0 to Length(FRegClasses) - 1 do
      begin
        { NOTE: We'll allow for a class whose parent implements interfaces }
        Table :=  FRegClasses[I].ClassType.GetInterfaceTable;
        if (Table = nil) then
        begin
          Table := FRegClasses[I].ClassType.ClassParent.GetInterfaceTable;
        end;
        for J := 0 to Table.EntryCount - 1 do
        begin
          if IsEqualGUID(IntfMD.IID, Table.Entries[J].IID) then
          begin
            FRegIntfs[Index].DefImpl := FRegClasses[I].ClassType;
            Exit;
          end;
        end;
      end;
    end;
  finally
    Unlock;
  end;
end;

procedure TInvokableClassRegistry.RegisterDefaultSOAPAction(Info: PTypeInfo; const DefSOAPAction: InvString);
var
  I: Integer;
begin
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      FRegIntfs[I].SOAPAction := DefSOAPAction;
      FRegIntfs[I].InvokeOptions := FRegIntfs[I].InvokeOptions + [ioHasDefaultSOAPAction];
      Exit;
    end;
  finally
    Unlock;
  end;
end;

procedure TInvokableClassRegistry.RegisterAllSOAPActions(Info: PTypeInfo; const AllSOAPActions: InvString);
var
  I: Integer;
begin
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      FRegIntfs[I].SOAPAction := AllSOAPActions;
      FRegIntfs[I].InvokeOptions := FRegIntfs[I].InvokeOptions + [ioHasAllSOAPActions];
      Exit;
    end;
  finally
    Unlock;
  end;
end;

procedure TInvokableClassRegistry.RegisterUDDIInfo(Info: PTypeInfo; const Operator: String; const BindingKey: string);
var
  I: Integer;
begin
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      FRegIntfs[I].UDDIOperator := Operator;
      FRegIntfs[I].UDDIBindingKey := BindingKey;
      FRegIntfs[I].InvokeOptions := FRegIntfs[I].InvokeOptions + [ioHasUDDIInfo];
      Exit;
    end;
  finally
    Unlock;
  end;
end;

{$IFDEF WIDE_RETURN_PARAM_NAMES}
procedure TInvokableClassRegistry.RegisterReturnParamNames(Info: PTypeInfo; const RetParamNames: InvString);
{$ELSE}
procedure TInvokableClassRegistry.RegisterReturnParamNames(Info: PTypeInfo; const RetParamNames: string);
{$ENDIF}
var
  I: Integer;
begin
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      FRegIntfs[I].ReturnParamNames := RetParamNames;
      FRegIntfs[I].InvokeOptions := FRegIntfs[I].InvokeOptions + [ioHasReturnParamNames];
    end;
  finally
    Unlock;
  end;
end;

procedure TInvokableClassRegistry.RegisterInvokeOptions(Info: PTypeInfo; const InvokeOption: TIntfInvokeOption);
var
  Options: TIntfInvokeOptions;
begin
  Options := GetIntfInvokeOptions(Info);
  Options := Options + [InvokeOption];
  RegisterInvokeOptions(info, Options);
end;

procedure TInvokableClassRegistry.RegisterInvokeOptions(Info: PTypeInfo; const InvokeOptions: TIntfInvokeOptions);
var
  I: Integer;
begin
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
      FRegIntfs[I].InvokeOptions := InvokeOptions;
  finally
    Unlock;
  end;
end;

{ calls to this method need to be within a Lock/try <here> finally/unlock block }
function TInvokableClassRegistry.GetIntfIndex(const IntfInfo: PTypeInfo): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to Length(FRegIntfs)-1 do
  begin
    if IntfInfo = FRegIntfs[I].Info then
    begin
      Result := I;
      Exit;
    end;
  end;
end;

function TInvokableClassRegistry.GetIntfInvokeOptions(const IntfInfo: PTypeInfo): TIntfInvokeOptions;
var
  I: Integer;
begin
  Result := [];
  Lock;
  try
    I := GetIntfIndex(IntfInfo);
    if I >= 0 then
      Result := FRegIntfs[I].InvokeOptions;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetIntfInvokeOptions(const AGUID: TGUID): TIntfInvokeOptions;
begin
  Result := GetIntfInvokeOptions(GetInterfaceTypeInfo(AGUID));
end;

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

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