invokeregistry.pas

Delphi开发webservice的一套例子

  inherited Destroy;
end;

procedure TRemotable.SetDataContext(Value: TDataContext);
begin
  if (RemotableDataContext <> nil) and (RemotableDataContext = Self.DataContext) then
  begin
    TDataContext(RemotableDataContext).RemoveObjectToDestroy(Self);
  end;
  FDataContext := Value;
end;


{ TRemotableXS }

function TRemotableXS.NativeToXS: WideString;
begin

end;

procedure TRemotableXS.XSToNative(Data: WideString);
begin

end;

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

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

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

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

function TPascalRemotableTypeRegistry.GetURICount: Integer;
begin
  Lock;
  try
    Result := Length(URIMap);
  finally
    UnLock;
  end;
end;

function TPascalRemotableTypeRegistry.GetURIMap(Index: Integer): TRemRegEntry;
begin
  Lock;
  Try
  if Index < Length(URIMap) then
    Result := URIMap[Index];
  finally
    UnLock;
  end;
end;

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


procedure TPascalRemotableTypeRegistry.RegisterXSClass(AClass: TClass; URI: WideString = ''; Name: WideString = ''; ExtName: WideString = ''; IsScalar: Boolean = False; MultiRefOpt: TObjMultiOptions = ocDefault);
var
  Index: Integer;
  Found: Boolean;
  AppURI: WideString;
begin
  Lock;
  Try
    Index := GetEntry(AClass.ClassInfo, Found);
    if not Found then
    begin
      if AppNameSpacePrefix <> '' then
        AppURI := AppNameSpacePrefix + '-';
      if URI = '' then
        URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(AClass.ClassInfo).UnitName { do not localize }
      else
        URIMap[Index].URI := URI;
      if Name <> '' then
        URIMap[Index].Name := Name
      else
      begin
        URIMap[Index].Name := AClass.ClassName;
      end;
      URIMap[Index].ExtName := ExtName;
      URIMap[Index].ClassType := AClass;
      URIMap[Index].Info := AClass.ClassInfo;
      URIMap[Index].IsScalar := IsScalar;
      URIMap[Index].MultiRefOpt := MultiRefOpt;
    end;
  finally
    UnLock;
  end;
end;

procedure TPascalRemotableTypeRegistry.RegisterXSInfo(Info: PTypeInfo;
  URI: WideString = ''; Name: WideString = ''; ExtName: WideString = '');
var
  Index: Integer;
  Found: Boolean;
  AppURI: WideString;
  UnitName: string;

  function GetEnumUnitName(Info: PTypeInfo): string;
  var
    P: ^ShortString;
    T: PTypeData;
    Size: Integer;
  begin
    T := GetTypeData(GetTypeData(Info)^.BaseType^);
    P := @T^.NameList;
    Size := T.MaxValue - T.MinValue;
    while Size >= 0  do
    begin
      Inc(Integer(P), Length(P^) + 1);
      Dec(Size);
    end;
    Result := P^;
  end;

begin
  Lock;
  Try
    Index := GetEntry(Info, Found);
    if Found then
      Exit;
    if AppNameSpacePrefix <> '' then
      AppURI := AppNameSpacePrefix + '-';
    if URI = '' then
    begin
      if Info.Kind = tkDynArray then
      begin
        UnitName := GetTypeData(Info).DynUnitName;
        URIMap[Index].URI := 'urn:' + AppURI +  UnitName;
      end
      else if Info.Kind = tkEnumeration then
      begin
        UnitName := GetEnumUnitName(Info);
        URIMap[Index].URI := 'urn:' + AppURI +  UnitName;
      end
      else if Info.Kind = tkClass then
        URIMap[Index].URI := 'urn:' + AppURI + GetTypeData(Info).UnitName
      else
        URIMap[Index].URI := 'urn:' + AppURI;
    end
    else
      URIMap[Index].URI := URI;
    if Name <> '' then
      URIMap[Index].Name := Name
    else
    begin
      URIMap[Index].Name := Info.Name;
    end;
    URIMap[Index].ExtName := ExtName;
    URIMap[Index].Info := Info;
    if Info.Kind = tkClass then
      URIMap[Index].ClassType := GetTypeData(Info).ClassType;
  finally
    UnLock;
  end;
end;

procedure TPascalRemotableTypeRegistry.DeleteEntryFromURIMap(Info: PTypeInfo);
var
  I, Index: Integer;
  Found: Boolean;
begin
  Lock;
  try
    Index := GetEntry(Info, Found);
    if Found then
    begin
      for I := Index to Length(URIMap) -2 do
        URIMap[I] := URIMap[I+1];
    end;
    SetLength(URIMap, Length(URIMap) -1);
  finally
    UnLock;
  end;
end;

procedure TPascalRemotableTypeRegistry.UnRegisterXSClass(AClass: TClass);
begin
  DeleteEntryFromURIMap(AClass.ClassInfo);
end;

procedure TPascalRemotableTypeRegistry.UnRegisterXSInfo(Info: PTypeInfo);
begin
  DeleteEntryFromURIMap(Info);
end;

function TPascalRemotableTypeRegistry.IsClassScalar(AClass: TClass): Boolean;
var
  I: Integer;
begin
  Result := False;
  Lock;
  Try
    for I := 0 to Length(URIMap) - 1 do
    begin
      if URIMap[I].ClassType = AClass then
      begin
        Result := URIMap[I].IsScalar;
        break;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TPascalRemotableTypeRegistry.ClassOptions(AClass: TClass): TObjMultiOptions;
var
  I: Integer;
begin
  Result := ocDefault;
  Lock;
  Try
    for I := 0 to Length(URIMap) - 1 do
    begin
      if URIMap[I].ClassType = AClass then
      begin
        Result := URIMap[I].MultiRefOpt;
        break;
      end;
    end;
  finally
    UnLock;
  end;
end;

procedure TPascalRemotableTypeRegistry.RegisterExternalPropName(Info: PTypeInfo; InternalName: string; const ExternalName: InvString);
begin

end;

function TPascalRemotableTypeRegistry.GetExternalPropName(Info: PTypeInfo; InternalName: string): InvString;
begin
  Result := InternalName;
end;

function TPascalRemotableTypeRegistry.GetInternalPropName(Info: PTypeInfo; ExternalName: InvString): string;
begin
  Result := ExternalName;
end;

function TPascalRemotableTypeRegistry.URIToInfo(const URI,
  Name: WideString): PTypeInfo;
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].Info;
        break;
      end;
    end;
  finally
    UnLock;
  end;
end;

procedure TPascalRemotableTypeRegistry.GetXSDInfoForClass(Info: PTypeInfo; var URI, TypeName: WideString);
var
  AClass: TClass;
  IsScalar: Boolean;
begin
  AClass := GetTypeData(Info).ClassType;
  ClassToURI(AClass, URI, TypeName, IsScalar);
end;

function TPascalRemotableTypeRegistry.GetRegisteredClassForBuiltInXSD(const TypeName: WideString): TClass;
var
  IsScalar: BOolean;
begin
  Result := RemClassRegistry.URIToClass(XMLSchemaNameSpace, TypeName, IsScalar);
end;

function  TPascalRemotableTypeRegistry.GetSimpleBuiltInXSDType(const URI, TypeName: WideString): PTypeInfo;
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 = TypeName) then
      begin
        Result := URIMap[I].Info;
        break;
      end;
    end;
  finally
    UnLock;
  end;
end;

function TPascalRemotableTypeRegistry.XSDToTypeInfo(URI, TypeName: WideString): PTypeInfo;
var
  AClass, BuiltinClass: TClass;
  IsScalar: Boolean;
  I: Integer;

  function IsBase64TypeName(TypeName: InvString): Boolean;
  var
    J: Integer;
  begin
    Result := False;
    for J := Low(XMLBase64Types) to High(XMLBase64Types) do
      if TypeName = XMLBase64Types[J] then
      begin
        Result := True;
        break;
      end;
  end;
begin
  Result := nil;
  if URI = XMLSchemaNameSpace then
  begin
    // First check if a registered class overrides default mapping
    BuiltinClass := GetRegisteredClassForBuiltInXSD(TypeName);
    if BuiltinClass <> nil then
      Result := BuiltinClass.ClassInfo;
    if Result = nil then // if not, check default mapping
      Result := GetSimpleBuiltInXSDType(URI, TypeName);
      if (Result = nil) and IsBase64TypeName(TypeName) then
        for I := Low(XMLBase64Types) to High(XMLBase64Types) do
        begin
          Result := GetSimpleBuiltInXSDType(URI, XMLBase64Types[I]);
          if Result <> nil then
            break;
        end;
  end else
  begin
    AClass := RemClassRegistry.URIToClass(URI, TypeName, IsScalar);
    if AClass <> nil then
    begin
      Result := AClass.ClassInfo;
      Exit;
    end;
    if AClass = nil then
    begin
      Result := RemClassRegistry.URIToInfo(URI, TypeName);
    end;
  end;
end;

function TPascalRemotableTypeRegistry.VariantToInfo(V: Variant; TryAllSchema: Boolean): PTypeInfo;
var
 I: Integer;
begin
  Result := nil;
  case VarType(V) and VarTypeMask of
    varEmpty,
    varNull:
      raise ETypeRegistryException.Create(SUnsupportedVariant);
    varSmallint:
      Result := TypeInfo(System.SmallInt);
    varInteger:
      Result := TypeInfo(System.Integer);
    varSingle:
      Result := TypeInfo(System.Single);
    varDouble,
    varCurrency:
      Result := TypeInfo(System.Double);
    varDate:
      begin
        Result := RemClassRegistry.URIToInfo(XMLSchemaNameSpace, 'dateTime'); { do not localize }
        if Result = nil then
        begin
          for I := Low(XMLSchemaNamepspaces) to High(XMLSchemaNamepspaces) do
          begin
            Result := RemClassRegistry.URIToInfo(XMLSchemaNamepspaces[I], 'dateTime');
            if Result <> nil then
              break;
          end;
        end;
      end;
    varOleStr:
      Result := TypeInfo(System.WideString);
    varDispatch:
      raise ETypeRegistryException.Create(SNoVarDispatch);
    varError:
      raise ETypeRegistryException.Create(SNoErrorDispatch);
    varBoolean:
      Result := TypeInfo(System.Boolean);
    varVariant:
      Result := TypeInfo(System.Variant);
    varUnknown:
      raise ETypeRegistryException.Create(SUnsupportedVariant);
    varShortInt:
      Result := TypeInfo(System.ShortInt);