invokeregistry.pas

Delphi的Soap一些使用功能控件

  InvRegistryV: TInvokableClassRegistry;
  RemClassRegistryV: TRemotableClassRegistry;
  RemTypeRegistryV: TRemotableTypeRegistry;

threadvar
  RemotableDataContext: Pointer;

function SubstituteStrings(const InputString: WideString; const SubString: WideString;
                           const Replacement: WideString): WideString;
var
  I: Integer;
begin
  Result := InputString;
  I := Pos(SubString, InputString);
  if I = 0 then
    Exit
  else
  begin
    Delete(Result, I, Length(SubString));
    Insert(Replacement, Result, I);
  end;
end;

function GetRemotableDataContext: Pointer;
begin
  Result := RemotableDataContext;
end;

procedure SetRemotableDataContext(Value: Pointer);
begin
  RemotableDataContext := Value;
end;

function TInvokableClassRegistry.GetInterfaceCount: Integer;
begin
  Result := 0;
  if FRegIntfs <> nil then
    Result := Length(FRegIntfs);
end;

function TInvokableClassRegistry.GetRegInterfaceEntry(Index: Integer): InvRegIntfEntry;
begin
  if Index < Length(FRegIntfs) then
    Result := FRegIntfs[Index];
end;

function TInvokableClassRegistry.HasRegInterfaceImpl(Index: Integer): Boolean;
begin
  if Index < Length(FRegIntfs) then
    Result := FRegIntfs[Index].DefImpl <> nil
  else
    Result := False;
end;


constructor TInvokableClassRegistry.Create;
begin
  inherited Create;
  InitializeCriticalSection(FLock);
end;

destructor TInvokableClassRegistry.Destroy;
begin
  DeleteCriticalSection(FLock);
  inherited Destroy;
end;

procedure TInvokableClassRegistry.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure TInvokableClassRegistry.UnLock;
begin
  LeaveCriticalSection(FLock);
end;

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

procedure TInvokableClassRegistry.RegisterInvokableClass(AClass: TClass; CreateProc: TCreateInstanceProc);
var
  Index, I, J: Integer;
  Table: PInterfaceTable;

begin
  Lock;
  try
    Table := AClass.GetInterfaceTable;
    { If a class does not implement interfaces, we'll try it's parent }
    if Table = nil then
    begin
      if (AClass.ClassParent <> nil) then
      begin
        Table := AClass.ClassParent.GetInterfaceTable;
        {
        if Table <> nil then
          AClass := AClass.ClassParent;
        }
      end;
    end;
    if Table = nil then
      raise ETypeRegistryException.CreateFmt(SNoInterfacesInClass, [AClass.ClassName]);
    Index := Length(FRegClasses);
    SetLength(FRegClasses, Index + 1);
    FRegClasses[Index].ClassType := AClass;
    FRegClasses[Index].Proc := CreateProc;

    { Find out what Registered invokable interface this class implements }
    for I := 0 to Table.EntryCount - 1 do
    begin
      for J := 0 to Length(FRegIntfs) - 1 do
        if IsEqualGUID(FRegIntfs[J].GUID, Table.Entries[I].IID) then
          { NOTE: Don't replace an existing implementation           }
          {       This approach allows for better control over what  }
          {       class implements a particular interface            }
          if FRegIntfs[J].DefImpl = nil then
            FRegIntfs[J].DefImpl := AClass;
    end;
  finally
    UnLock;
  end;
end;

procedure TInvokableClassRegistry.RegisterHeaderClass(Info: PTypeInfo; AClass: TClass;
              DefaultMethodType: eHeaderMethodType = hmtAll; Required: Boolean = False);
begin
  RegisterHeaderClass(Info, AClass, '', '', DefaultMethodType, Required);
end;

procedure TInvokableClassRegistry.RegisterHeaderClass(Info: PTypeInfo; AClass: TClass;
              const HeaderName: WideString; const HeaderNamespace: WideString;
              DefaultMethodType: eHeaderMethodType = hmtAll; Required: Boolean = False);
begin
  InternalRegisterHeaderClass(Info, AClass, HeaderName, HeaderNamespace, DefaultMethodType, '', hmtAll, Required);
end;

procedure TInvokableClassRegistry.RegisterHeaderMethod(Info: PTypeInfo; AClass: TClass;
              const MethodName: string; MethodType: eHeaderMethodType = hmtAll;
              Required: Boolean = False);
begin
  InternalRegisterHeaderClass(Info, AClass, '', '', hmtAll, MethodName, MethodType, Required);
end;

procedure TInvokableClassRegistry.InternalRegisterHeaderClass(Info: PTypeInfo; AClass: TClass;
              const HeaderName: WideString; const HeaderNamespace: WideString;
              DefaultMethodType: eHeaderMethodType; const MethodName: string = '';
              MethodType: eHeaderMethodType = hmtAll; Required: Boolean = False);

   { adding MethodName info to interface }
   procedure SetMethodInfo(var HeaderItem: IntfHeaderItem);
   var
     Headers: TStrings;
   begin
     Headers := TStringList.Create;
     try
       Headers.CommaText := HeaderItem.MethodNames;
       if Headers.IndexOf(MethodName) = -1 then
       begin
         Headers.Add(MethodName);
         SetLength(HeaderItem.MethodTypes, Headers.Count);
         SetLength(HeaderItem.HeaderRequired, Headers.Count);
         HeaderItem.MethodTypes[Headers.Count-1] := MethodType;
         HeaderItem.HeaderRequired[Headers.Count-1] := Required;
         HeaderItem.MethodNames := Headers.CommaText;
       end;
     finally
       Headers.Free;
     end;
   end;

var
  I, J, HeaderIndex: Integer;
begin
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      HeaderIndex := Length(FRegIntfs[I].IntfHeaders);
      for J := 0 to Length(FRegIntfs[I].IntfHeaders) - 1 do
        if FRegIntfs[I].IntfHeaders[J].ClassType = AClass then
        begin
          HeaderIndex := J;
          break;
        end;
      if HeaderIndex = Length(FRegIntfs[I].IntfHeaders) then
      begin
        { registering new Header Class for Interface }
        SetLength(FRegIntfs[I].IntfHeaders, 1 + Length(FRegIntfs[I].IntfHeaders));
        FRegIntfs[I].IntfHeaders[HeaderIndex].ClassType := AClass;
        FRegIntfs[I].IntfHeaders[HeaderIndex].Info := AClass.ClassInfo;
        FRegIntfs[I].IntfHeaders[HeaderIndex].Name := HeaderName;
        FRegIntfs[I].IntfHeaders[HeaderIndex].Namespace := HeaderNamespace;
        FRegIntfs[I].IntfHeaders[HeaderIndex].DefaultRequired := Required;
        FRegIntfs[I].IntfHeaders[HeaderIndex].DefaultMethodType := DefaultMethodType;
      end;
      if MethodName <> '' then
        SetMethodInfo(FRegIntfs[I].IntfHeaders[HeaderIndex]);
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetExceptionInfoForInterface(Info: PTypeInfo): TExceptionItemArray;
var
  I, J, Current: Integer;
begin
  SetLength(Result, 0);
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      for J := 0 to Length(FRegIntfs[I].IntfExceptions) -1 do
      begin
        Current := Length(Result);
        SetLength(Result, Current + 1);
        Result[Current] := FRegIntfs[I].IntfExceptions[J];
      end;
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetHeaderInfoForInterface(Info: PTypeInfo;
         MethodType: eHeaderMethodType = hmtAll): THeaderItemArray;

  function CheckHeaderType(HeaderItem: IntfHeaderItem): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    if (not Assigned(HeaderItem.MethodTypes)) then
      Result := HeaderItem.DefaultMethodType in [hmtAll, MethodType]
    else
    begin
      for I := 0 to Length(HeaderItem.MethodTypes) do
        if HeaderItem.MethodTypes[I] in [hmtAll, MethodType] then
        begin
          Result := True;
          break;
        end;
    end;
  end;
var
  I, J, Current: Integer;
begin
  SetLength(Result, 0);
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      for J := 0 to Length(FRegIntfs[I].IntfHeaders) - 1 do
      begin
        if (MethodType = hmtAll) or (CheckHeaderType(FRegIntfs[I].IntfHeaders[J])) then
        begin
          Current := Length(Result);
          SetLength(Result, Current + 1);
          Result[Current] := FRegIntfs[I].IntfHeaders[J];
        end;
      end;
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.InternalGetHeaderName(const Item:IntfHeaderItem): WideString;
var
  URI: WideString;
begin
  Result := Item.Name;
  if Result = '' then
  begin
    RemClassRegistry.ClassToURI(Item.ClassType, URI, Result);
  end;
end;

function TInvokableClassRegistry.InternalGetHeaderNamespace(const Item: IntfHeaderItem): WideString;
var
  Name: WideString;
begin
  Result := Item.Namespace;
  if Result = '' then
  begin
    RemClassRegistry.ClassToURI(Item.ClassType, Result, Name);
  end;
end;

function TInvokableClassRegistry.GetHeaderName(Info: PTypeInfo; AClass: TClass): WideString;
var
  I, J: Integer;
begin
  Result := '';
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      for J := 0 to Length(FRegIntfs[I].IntfHeaders)-1 do
      begin
        if FRegIntfs[I].IntfHeaders[J].ClassType = AClass then
        begin
          Result := InternalGetHeaderName(FRegIntfs[I].IntfHeaders[J]);
          Exit;
        end;
      end;
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetHeaderNamespace(Info: PTypeInfo; AClass: TClass): WideString;
var
  I, J: Integer;
begin
  Result := '';
  Lock;
  try
    I := GetIntfIndex(Info);
    if I >= 0 then
    begin
      for J := 0 to Length(FRegIntfs[I].IntfHeaders)-1 do
      begin
        if FRegIntfs[I].IntfHeaders[J].ClassType = AClass then
        begin
          Result := InternalGetHeaderNamespace(FRegIntfs[I].IntfHeaders[J]);
          Exit;
        end;
      end;
    end;
  finally
    Unlock;
  end;
end;

function TInvokableClassRegistry.GetHeaderNamespace(AClass: TClass): WideString;
var
  I, J: Integer;
  Name: WideString;
begin
  Result := '';
  for I := 0 to Length(FRegIntfs)-1 do
  begin
    for J := 0 to Length(FRegIntfs[I].IntfHeaders)-1 do
    begin
      if FRegIntfs[I].IntfHeaders[J].ClassType = AClass then
      begin
        Result := InternalGetHeaderNamespace(FRegIntfs[I].IntfHeaders[J]);
        Exit;
      end;
    end;
  end;
  RemClassRegistry.ClassToURI(AClass, Result, Name);
end;

function TInvokableClassRegistry.GetHeaderClass(Name, Namespace: WideString): TClass;
var