invokeregistry.pas

Delphi开发webservice的一套例子

    varByte:
      Result := TypeInfo(System.Byte);
    varWord:
      Result := TypeInfo(System.Word);
    varLongWord:
      Result := TypeInfo(System.LongWord);
    varInt64:
      Result := TypeInfo(System.Int64);
    varString:
      Result := TypeInfo(System.WideString);
  end;

end;

function TPascalRemotableTypeRegistry.GetVarTypeFromXSD(URI,
  TypeName: InvString): TVarType;
var
  Info: PTypeInfo;
begin
  Result := varUnknown;
  Info := XSDToTypeInfo(URI, TypeName);
  case Info.Kind of
    tkInteger:
      Result := varInteger;
    tkFloat:
      Result := varDouble;
    tkInt64:
      Result := varInt64;
    tkChar,
    tkWChar,
    tkWString,
    tkString,
    tkLString:
      Result := varOleStr;
  end;
end;

function TPascalRemotableClassRegistry.GetEntry(Info: PTypeInfo; var Found: Boolean): Integer;
begin
  Result := 0;
  Found := False;
  while Result < Length(URIMap) do
  begin
    if (Info <> nil) and (URIMap[Result].Info = Info) then
    begin
      Found := True;
      Exit;
    end;
    Inc(Result);
  end;
  SetLength(URIMap, Result + 1);
end;

function TPascalRemotableTypeRegistry.URIToClass(URI, Name: WideString; var IsScalar: Boolean): TClass;
var
  I: Integer;
begin
  Result := nil;
  Lock;
  Try
    for I := 0 to Length(URIMap) - 1 do
    begin
      if (URIMap[I].URI = URI) and (URIMap[I].Name = Name) then
      begin
        Result := URIMap[I].ClassType;
        IsScalar := URIMap[I].IsScalar;
        break;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TPascalRemotableClassRegistry.InfoToURI(Info: PTypeInfo; var URI,
  Name: WideString; var IsScalar: Boolean): Boolean;
var
  I: Integer;
begin
  Result := False;
  Lock;
  Try
    if Info <> nil then
    begin
      for I := 0 to Length(URIMap) - 1 do
      begin
        if URIMap[I].Info = Info then
        begin
          URI := URIMap[I].URI;
          Name :=  URIMap[I].Name;
          IsScalar := URIMap[I].IsScalar;
          Result := True;
          break;
        end;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TPascalRemotableClassRegistry.TypeInfoToXSD(Info: PTypeInfo; var URI,
  TypeName: WideString): Boolean;
var
  IsScalar: Boolean;
begin
  if Info.Kind = tkClass then
    Result := ClassToURI(GetTypeData(Info).ClassType, URI, TypeName, IsScalar)
  else
    Result := InfoToURI(Info, URI, TypeName, IsScalar);
end;

{ ERemotableException }

constructor ERemotableException.CreateRem;
begin

end;

{ TDataContext }

procedure TDataContext.SetDataPointer(Index: Integer; P: Pointer);
begin
  DataP[Index] := P;
end;

function TDataContext.GetDataPointer(Index: Integer): Pointer;
begin
  Result := DataP[Index];
end;

procedure TDataContext.AddVariantToClear(P: PVarData);
var
  I: Integer;
begin
  for I := 0 to Length(VarToClear) -1 do
    if VarToClear[I] = P then
      Exit;
  I := Length(VarToClear);
  SetLength(VarToClear, I + 1);
  VarToClear[I] := P;
end;

procedure TDataContext.AddStrToClear(P: Pointer);
var
  I: Integer;
begin
   for I := 0 to Length(StrToClear) -1 do
    if StrToClear[I] = P then
      Exit;
  I := Length(StrToClear);
  SetLength(StrToClear, I + 1);
  StrToClear[I] := P;
end;

constructor TDataContext.Create;
begin
  inherited;
end;

destructor TDataContext.Destroy;
var
  I: Integer;
  P: Pointer;
begin
  for I := 0 to Length(FObjsToDestroy) - 1 do
  begin
     if (FObjsToDestroy[I] <> nil) and (FObjsToDestroy[I].InheritsFrom(TRemotable)) then
     begin
       TRemotable(FObjsToDestroy[I]).Free;
     end;
  end;
  SetLength(FObjsToDestroy, 0);
  for I := 0 to Length(VarToClear) - 1 do
  begin
    if Assigned(VarToClear[I]) then
      Variant( PVarData(VarToClear[I])^) := NULL;
  end;
  for I := 0 to Length(DynArrayToClear) - 1 do
  begin
    if Assigned(DynArrayToClear[I].P) then
    begin
      P := Pointer( PInteger(DynArrayToClear[I].P)^);
      DynArrayClear(P, DynArrayToClear[I].Info)
    end;
  end;
  for I := 0 to Length(StrToClear) - 1 do
  begin
    if Assigned(StrToClear[I]) then
      PString(StrToClear[I])^ := '';
  end;
  inherited;
end;

procedure TDataContext.AddDynArrayToClear(P: Pointer; Info: PTypeInfo);
var
  I: Integer;
begin
  for I := 0 to Length(DynArrayToClear) -1 do
    if DynArrayToClear[I].P = P then
      Exit;
  I := Length(DynArrayToClear);
  SetLength(DynArrayToClear, I + 1);
  DynArrayToClear[I].P := P;
  DynArrayToClear[I].Info := Info;
end;

procedure TDataContext.AddObjectToDestroy(Obj: TObject);
var
  Index, EmptySlot: Integer;
begin
  EmptySlot := -1;
  for Index := 0 to Length(FObjsToDestroy) -1 do
  begin
    if FObjsToDestroy[Index] = Obj then
      Exit;
    if FObjsToDestroy[Index] = nil then
      EmptySlot := Index;
  end;
  if EmptySlot <> -1 then
  begin
    FObjsToDestroy[EmptySlot] := Obj;
    Exit;
  end;
  Index := Length(FObjsToDestroy);
  SetLength(FObjsToDestroy, Index + 1 );
  FObjsToDestroy[Index] := Obj;
end;

procedure TDataContext.RemoveObjectToDestroy(Obj: TObject);
var
  I: Integer;
begin
  I := 0;
  while I < Length(FObjsToDestroy) do
  begin
    if FObjsToDestroy[I] = Obj then
    begin
      FObjsToDestroy[I] := nil;
      break;
    end;
    Inc(I);
  end;
end;

function TDataContext.AllocData(Size: Integer): Pointer;
begin
  Result := @Data[DataOffset];
  Inc(DataOffset, Size);
end;

{ TInvContext }

const
  MAXINLINESIZE = sizeof(TVarData) + 4;

procedure TInvContext.SetMethodInfo(const MD: TIntfMethEntry);
begin
  SetLength(DataP, MD.ParamCount + 1);
  SetLength(Data, (MD.ParamCount + 1) * MAXINLINESIZE);
end;

procedure TInvContext.SetParamPointer(Param: Integer; P: Pointer);
begin
   SetDataPointer(Param,  P);
end;

function TInvContext.GetParamPointer(Param: Integer): Pointer;
begin
  Result := GetDataPointer(Param);
end;

function TInvContext.GetResultPointer: Pointer;
begin
  Result := ResultP;
end;

procedure TInvContext.SetResultPointer(P: Pointer);
begin
  ResultP := P;
end;

procedure TInvContext.AllocServerData(const MD: TIntfMethEntry);
var
  I: Integer;
  Info: PTypeInfo;
  P: Pointer;
begin
  for I := 0 to MD.ParamCount - 1 do
  begin
    P := AllocData(GetTypeSize(MD.Params[I].Info));
    SetParamPointer(I, P);
    if MD.Params[I].Info.Kind = tkVariant then
    begin
      Variant(PVarData(P)^) := NULL;
      AddVariantToClear(PVarData(P));
    end else if MD.Params[I].Info.Kind = tkDynArray then
    begin
      AddDynArrayToClear(P, MD.Params[I].Info);
    end;
  end;
  if MD.ResultInfo <> nil then
  begin
    Info := MD.ResultInfo;
    case Info^.Kind of
      tkLString:
        begin
           P := AllocData(sizeof(PString));
           PString(P)^ := '';
           AddStrToClear(P);
        end;
      tkInt64:
        P := AllocData(sizeof(Int64));
      tkVariant:
        begin
          P := AllocData(sizeof(TVarData));
          Variant( PVarData(P)^ ) := NULL;
          AddVariantToClear(PVarData(P));
        end;
      tkDynArray:
        begin
          P := AllocData(GetTypeSize(Info));
          AddDynArrayToClear(P, MD.ResultInfo);
        end;
      else
        P := AllocData(GetTypeSize(Info));
    end;
    SetResultPointer(P);
  end;
end;


procedure InitBuiltIns;
begin
  { DO NOT LOCALIZE }
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Boolean), XMLSchemaNameSpace, 'boolean');

  RemClassRegistry.RegisterXSInfo(TypeInfo(System.ShortInt), XMLSchemaNameSpace, 'byte');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Byte), XMLSchemaNameSpace, 'unsignedByte');

  RemClassRegistry.RegisterXSInfo(TypeInfo(System.SmallInt), XMLSchemaNameSpace, 'short');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Word), XMLSchemaNameSpace, 'unsignedShort');

  RemClassRegistry.RegisterXSInfo(TypeInfo(System.LongWord), XMLSchemaNameSpace, 'unsignedInt');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Cardinal), XMLSchemaNameSpace, 'unsignedInt');

  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Integer), XMLSchemaNameSpace, 'int');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.LongInt), XMLSchemaNameSpace, 'int');

  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Int64), XMLSchemaNameSpace, 'long');

  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Single), XMLSchemaNameSpace, 'float');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Double), XMLSchemaNameSpace, 'double');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Extended), XMLSchemaNameSpace, 'double');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Currency), XMLSchemaNameSpace, 'double');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Comp), XMLSchemaNameSpace, 'double');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Real), XMLSchemaNameSpace, 'double');

  RemClassRegistry.RegisterXSInfo(TypeInfo(System.AnsiString), XMLSchemaNameSpace, 'string');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.WideString), XMLSchemaNameSpace, 'string');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.ShortString), XMLSchemaNameSpace, 'string');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.AnsiChar), XMLSchemaNameSpace, 'string');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.WideChar), XMLSchemaNameSpace, 'string');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Char), XMLSchemaNameSpace, 'string');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.WideChar), XMLSchemaNameSpace, 'string');

  RemClassRegistry.RegisterXSInfo(TypeInfo(Types.TByteDynArray), XMLSchemaNameSpace, 'base64Binary');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Variant), XMLSchemaNameSpace, 'anyType');
  RemClassRegistry.RegisterXSInfo(TypeInfo(System.Variant), XMLSchemaNameSpace, 'anySimpleType');

  RemClassRegistry.RegisterXSInfo(TypeInfo(TIntegerDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TCardinalDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TWordDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TSmallIntDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TByteDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TShortIntDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TInt64DynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TLongWordDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TSingleDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TDoubleDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TBooleanDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TStringDynArray));
  RemClassRegistry.RegisterXSInfo(TypeInfo(TWideStringDynArray));


end;

procedure UnInitBuiltIns;
begin
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Boolean));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Integer));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.ShortInt));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Single));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Int64));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Double));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Extended));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Currency));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.AnsiString));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.WideString));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.ShortString));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.AnsiChar));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.WideChar));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Byte));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.SmallInt));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.LongInt));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Cardinal));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Char));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.WideChar));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Word));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.LongWord));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(System.Comp));
  RemClassRegistry.UnRegisterXSInfo(TypeInfo(Types.TByteDynArray));

end;

initialization
  InvRegistryV := TInvokableClassRegistry.Create;
  RemTypeRegistryV := TPascalRemotableClassRegistry.Create;
  RemClassRegistryV:= RemTypeRegistry;
  InitBuiltIns;
finalization
  InvRegistryV.Free;
  RemClassRegistryV.Free;
end.