clrtti.pas

用Delphi实现的数据库持久化

  rtSource, rtDest: TrtWrapper;
  nSrcProp: Integer;
  pSrcProp, pDestProp: TrtProperty;
begin
  rtSource := nil;
  rtDest := nil;
  try
    rtSource := TrtWrapper.Create( Src, PropKinds, StopNames );
    rtDest := TrtWrapper.Create( Dest, PropKinds, StopNames );
    for nSrcProp := 0 to rtSource.Count - 1 do
    begin
      pSrcProp := rtSource.PropertyObjects[nSrcProp];
      pDestProp := rtDest.GetItemByName( pSrcProp.Name );
      if pDestProp <> nil then
      begin
        pDestProp.AsVariant := pSrcProp.AsVariant;
      end;
    end;
  finally
    rtSource.Free;
    rtDest.Free;
  end;
end;

{
rtGlobalComponentList
  Access a singleton TList of all the components in the scope of all forms and
  data modules.
}

function rtGlobalComponentList: TList;
var
  nContainer, nComp: Integer;
  Comp: TComponent;
  List: TList;
  procedure AddComp( AComp: TComponent );
  begin
    if List.IndexOf( AComp ) < 0 then
      List.Add( AComp );
  end;
begin
  if not Assigned( FrtGlobalComponentList ) then
  begin
    FrtGlobalComponentList := TList.Create;
  end;
  List := FrtGlobalComponentList;
  List.Clear;
  for nContainer := 0 to Screen.FormCount - 1 do
  begin
    Comp := Screen.Forms[nContainer];
    AddComp( Comp );
    for nComp := 0 to Comp.ComponentCount - 1 do
    begin
      AddComp( Comp.Components[nComp] );
    end;
  end;
  for nContainer := 0 to Screen.DataModuleCount - 1 do
  begin
    Comp := Screen.DataModules[nContainer];
    AddComp( Comp );
    for nComp := 0 to Comp.ComponentCount - 1 do
    begin
      AddComp( Comp.Components[nComp] );
    end;
  end;
  Result := List;
end;

{
TypeKindToStr
  Convert a type kind into its string representation.
}

function TypeKindToStr( Kind: TTypeKind ): string;
begin
  case Kind of
    tkUnknown: Result := 'tkUnknown';
    tkInteger: Result := 'tkInteger';
    tkChar: Result := 'tkChar';
    tkEnumeration: Result := 'tkEnumeration';
    tkFloat: Result := 'tkFloat';
    tkString: Result := 'tkString';
    tkSet: Result := 'tkSet';
    tkClass: Result := 'tkClass';
    tkMethod: Result := 'tkMethod';
    tkWChar: Result := 'tkWChar';
    tkLString: Result := 'tkLString';
    tkWString: Result := 'tkWString';
    tkVariant: Result := 'tkVariant';
    tkArray: Result := 'tkArray';
    tkRecord: Result := 'tkRecord';
    tkInterface: Result := 'tkInterface';
    tkInt64: Result := 'tkInt64';
    tkDynArray: Result := 'tkDynArray';
  end;
end;

//  Get a list of published methods for a given class or object

procedure GetMethodList( AObject: TObject; MethodList: TStrings ); overload;
begin
  GetMethodList( AObject.ClassType, MethodList );
end;

procedure GetMethodList( FromClass: TClass; MethodList: TStrings ); overload;
type
  PPointer = ^Pointer;
  PMethodRec = ^TMethodRec;
  TMethodRec = packed record
    wSize: Word;
    pCode: Pointer;
    sName: ShortString;
  end;
var
  MethodTable: PChar;
  AClass: TClass;
  MethodRec: PMethodRec;
  wCount: Word;
  nMethod: integer;
begin
  MethodList.Clear;
  AClass := FromClass;

  while AClass <> nil do
  begin
    //Get a pointer to the class's published method table
    MethodTable := PChar( Pointer( PChar( AClass ) + vmtMethodTable )^ );

    if MethodTable <> nil then
    begin
      //Get the count of the methods in the table
      Move( MethodTable^, wCount, 2 );

      //Position the MethodRec pointer at the first method in the table
        //(skip over the 2-byte method count)
      MethodRec := PMethodRec( MethodTable + 2 );

      //Iterate through all the published methods of this class
      for nMethod := 0 to wCount - 1 do
      begin
        //Add the method name and address to the MethodList TStrings
        MethodList.AddObject( MethodRec.sName, MethodRec.pCode );
        //Skip to the next method
        MethodRec := PMethodRec( PChar( MethodRec ) + MethodRec.wSize );
      end;
    end;
    //Get the ancestor (parent) class
    // The easy way:
    AClass := AClass.ClassParent;
  end;
end;

function GetPropertyString( Obj: TObject; sPropName: string ): string;
var
  Prop: TrtProperty;
begin
  Prop := nil;
  try
    Prop := TrtProperty.Create( Obj, sPropName );

    Result := Prop.AsString;
  finally
    Prop.Free;
  end;
end;

procedure SetPropertyString( Obj: TObject; sPropName: string; Value: string );
var
  Prop: TrtProperty;
begin
  Prop := nil;
  try
    Prop := TrtProperty.Create( Obj, sPropName );

    Prop.AsString := Value;
  finally
    Prop.Free;
  end;
end;

{ TrtProperty }

constructor TrtProperty.Create( AObject: TObject; propName: string );
var
  APropInfo: PPropInfo;
begin
  Instance := AObject;
  ObjClassType := AObject.ClassType;
  APropInfo := GetPropInfo( AObject, propName );
  Create( APropInfo );
end;

constructor TrtProperty.Create( APropInfo: PPropInfo );
begin
  PropInfo := APropInfo;
  TypeInfo := APropInfo^.PropType^;
  TypeData := GetTypeData( TypeInfo );
  FEnumNames := nil;
  FSetNames := nil;
end;

function TrtProperty.MaxStringLen: integer;
  function TotalLenWithCommas( sl: TStrings ): integer;
  var
    nStr: integer;
  begin
    Result := 0;
    for nStr := 0 to sl.Count - 1 do
      Result := Result + length( sl[nStr] ) + 1;
  end;
  function MaxStrLen( sl: TStrings ): integer;
  var
    nStr: integer;
  begin
    Result := 0;
    for nStr := 0 to sl.Count - 1 do
      if length( sl[nStr] ) > Result then
        Result := length( sl[nStr] );
  end;
begin
  Result := -1;
  case Kind of
    tkSet: Result := TotalLenWithCommas( SetNames );
    tkEnumeration: Result := MaxStrLen( EnumNames ) + 1;
  end;
end;

constructor TrtProperty.Create( AClass: TClass; propName: string );
var
  APropInfo: PPropInfo;
begin
  APropInfo := GetPropInfo( AClass, propName );
  ObjClassType := AClass;
  Create( APropInfo );
end;

destructor TrtProperty.Destroy;
begin
  if Assigned( FEnumNames ) then FEnumNames.Free;
  if Assigned( FSetNames ) then FSetNames.Free;
  inherited;
end;

function TrtProperty.GetAsFloat: extended;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  Result := GetFloatProp( Instance, PropInfo );
end;

function TrtProperty.GetAsInt64: int64;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  Result := GetInt64Prop( Instance, PropInfo );
end;

function TrtProperty.GetAsInteger: integer;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  case Kind of
    tkEnumeration: Result := GetEnumValue( TypeInfo, GetEnumProp( Instance, PropInfo ) );
  else
    Result := GetOrdProp( Instance, PropInfo );
  end;
end;

function TrtProperty.GetAsMethod: TMethod;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  Result := GetMethodProp( Instance, PropInfo );
end;

function TrtProperty.GetAsObject: TObject;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  Result := GetObjectProp( Instance, PropInfo );
end;

function TrtProperty.GetAsString: string;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  case Kind of
    tkEnumeration: Result := GetEnumProp( Instance, PropInfo );
    tkSet: Result := GetSetString( Instance, PropInfo, true );
  else
    Result := GetStrProp( Instance, PropInfo );
  end;
end;

function TrtProperty.GetAsVariant: Variant;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );

  // Don't use GetVariantProp; it doesn't do type checking - it assumes it's a variant
  Result := GetPropValue( Instance, Name );
end;

function TrtProperty.GetEnumNames: TStrings;
var
  nValue: integer;
begin
  if not Assigned( FEnumNames ) then
  begin
    FEnumNames := TStringList.Create;
    for nValue := TypeData.MinValue to TypeData.MaxValue do
    begin
      FEnumNames.Add( GetEnumName( TypeInfo, nValue ) );
    end;
  end;
  Result := FEnumNames;
end;

function TrtProperty.GetIsDelegate: boolean;
begin
  Result := PropClassType.InheritsFrom( TPersistent ) and
    ( not PropClassType.InheritsFrom( TComponent ) );
end;

function TrtProperty.GetIsStored: boolean;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  Result := IsStoredProp( Instance, PropInfo );
end;

function TrtProperty.GetName: string;
begin
  Result := PropInfo^.Name;
end;

function TrtProperty.GetPropClassType: TClass;
resourcestring
  ERR_MUSTBETKCLASS = 'PropClassType property is only valid for tkClass properties';
begin
  Assert( Kind = tkClass, ERR_MUSTBETKCLASS );
  Result := TypeData.ClassType;
end;

function TrtProperty.MethodData: TrtMethodData;
type
  PParamFlags = ^TParamFlags;
var
  nParam: integer;

  ParamBuf: PChar;
  function ReadNextStr: string;
  begin
    Result := PShortString( ParamBuf )^;
    Inc( ParamBuf, length( Result ) + 1 );
  end;
begin
  Result.MethodKind := TypeData.MethodKind;
  Result.ParamCount := TypeData.ParamCount;

  SetLength( Result.ParamList, Result.ParamCount );

  ParamBuf := @TypeData.ParamList[0];
  for nParam := 0 to Result.ParamCount - 1 do
  begin
    Result.ParamList[nParam].Flags := PParamFlags( ParamBuf )^;
    Inc( ParamBuf, sizeof( TParamFlags ) );

    Result.ParamList[nParam].ParamName := ReadNextStr;

    Result.ParamList[nParam].TypeName := ReadNextStr;
  end;

  if Result.MethodKind in [mkFunction, mkClassFunction] then
  begin
    Result.ResultType := ReadNextStr;
  end
  else
    Result.ResultType := '';
end;

function TrtProperty.SetHasMember( MemberStr: string ): boolean;
resourcestring
  ERR_MUSTBETKSET = 'SetHasMember property is only valid for tkSet properties';
var
  nMemberIdx: integer;
  slSetValue: TStringList;
begin
  Assert( Instance <> nil, ERR_NOINSTANCE );
  Assert( Kind = tkSet, ERR_MUSTBETKSET );

  Result := false;
  slSetValue := nil;
  try
    slSetValue := TStringList.Create;

    nMemberIdx := SetNames.IndexOf( MemberStr );
    if nMemberIdx < 0 then
      raise Exception.CreateFmt( 'SetHasMember: Unknown Member String (%s)', [MemberStr] );

    slSetValue.CommaText := Copy( AsString, 2, length( AsString ) - 2 );

    Result := ( slSetValue.IndexOf( MemberStr ) > -1 );
  finally
    slSetValue.Free;
  end;
end;

function TrtProperty.GetSetNames: TStrings;
var
  enumTypeInfo: PTypeInfo;
begin