invokeregistry.pas

Delphi开发webservice的一套例子

      end;
    end;
  finally
    Unlock;
  end;
end;


function TInvokableClassRegistry.GetInterfaceExternalName(Info: PTypeInfo; Namespace: string  = ''; 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; //for all interfaces registered
  finally
    Unlock;
  end;

end;


function TInvokableClassRegistry.GetWSDLEncoding(Info: PTypeInfo; Namespace: string  = ''; 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; //for all interfaces registered
  finally
    Unlock;
  end;

end;


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


procedure TInvokableClassRegistry.RegisterExternalMethName(Info: PTypeInfo; 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; 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;  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;  MethodName: string; 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;  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;  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
        Result := FRegIntfs[I].Info;
    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  (CompareText(IntfName, FRegIntfs[I].Name) = 0)
          and ( (UnitName = '') or (CompareText(UnitName, FRegIntfs[I].UnitName) = 0))
      then
      begin
        Info := FRegIntfs[I].Info;
        IID := FRegIntfs[I].GUID;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TInvokableClassRegistry.GetInfoForURI(const PathURI, ActionURI: string; var AClass: TClass; var IntfInfo: PTypeInfo; var AMeth: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  Lock;
  Try
    if ActionURI <> '' then
    begin
    // presumes that an action is of the form
    // <namespace>#<method>
    // or simply <namespace><some other stuff that can be ignored>
    // and that an interface is registered with a <namespace>
    // so we simply find the first registered interface with a namespace that
    // is an initial substring of the action
      for I := 0 to Length(FRegIntfs) - 1 do
      begin
        if (ActionURI <> '') and (ActionURI[1] = '"') and (Pos(FRegIntfs[I].Namespace, ActionURI) = 2) then
        begin
          IntfInfo := FRegIntfs[I].Info;
          AClass := FRegIntfs[I].DefImpl;
          Result := True;
          break;
        end;
       end;
      if not Result then
      begin
        for I := 0 to Length(FRegIntfs) - 1 do
        begin
          if Pos(FRegIntfs[I].Namespace, ActionURI) = 1 then
          begin
            IntfInfo := FRegIntfs[I].Info;
            AClass := FRegIntfs[I].DefImpl;
            Result := True;
            break;
          end;
         end;
       end;
    end
    else if PathURI <> '' then
    begin
      // if a URL is used for defining which interface to use
      // then find the first interface whose name is a terminal substring of the
      // path, doesn't consider interfaces with the same name but in different units
      for I := 0 to Length(FRegIntfs) - 1 do
      begin
        if  CompareText(Copy(PathURI, LastDelimiter('/', PathURI) + 1, High(Integer)),FRegIntfs[I].Name) = 0  then
        begin
          IntfInfo := FRegIntfs[I].Info;
          AClass := FRegIntfs[I].DefImpl;
          Result := True;
          break;
        end;
      end
    end;
  finally
    UnLock;
  end;
end;

function TInvokableClassRegistry.GetNamespaceByGUID(const AGUID: TGUID): string;
var
  I: Integer;
begin
  Result := '';
  Lock;
  try
    for I := 0 to Length(FRegIntfs) - 1 do
    begin
      if IsEqualGUID(FRegIntfs[I].GUID, AGUID) then
      begin
        Result := FRegIntfs[I].Namespace;
        break;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TInvokableClassRegistry.GetInvokableObjectFromClass(
  AClass: TClass): TObject;
var
  I: Integer;
  Found: Boolean;
begin
  Result := nil;
  Lock;
  Found := False;
  Try
    for I := 0 to Length(FRegClasses) - 1 do
      if FRegClasses[I].ClassType = AClass then
        if Assigned(FRegClasses[I].Proc) then
        begin
          FRegClasses[I].Proc(Result);
          Found := True;
        end;
    if not Found and  AClass.InheritsFrom(TInvokableClass) then
      Result := TInvokableClassClass(AClass).Create;
  finally
    UnLock;
  end;
end;


procedure TInvokableClassRegistry.GetClassFromIntfInfo(Info: PTypeInfo;
  var AClass: TClass);
var
  I: Integer;
begin
  AClass := nil;
  Lock;
  Try
    for I := 0 to Length(FRegIntfs) - 1 do
      if FRegIntfs[I].Info = Info then
      begin
        AClass := FRegIntfs[I].DefImpl;
        break;
      end;
  finally
    UnLock;
  end;
end;

{ TInvokableClass }

constructor TInvokableClass.Create;
begin
  inherited Create;
end;

{ TRemotable }

constructor TRemotable.Create;
begin
  inherited;
  if RemotableDataContext <> nil then
  begin
    TDataContext(RemotableDataContext).AddObjectToDestroy(Self);
    Self.DataContext := TDataContext(RemotableDataContext);
  end;
end;

destructor TRemotable.Destroy;
begin
  if RemotableDataContext <> nil then
  begin
    TDataContext(RemotableDataContext).RemoveObjectToDestroy(Self);
    Self.DataContext := nil;
  end;