clrtti.pas

用Delphi实现的数据库持久化

unit clRTTI;
{
Author: Chris Lichti
Email:  [e-mail]
February 2, 2001

clRTTI is a utility unit that wraps Delphi's Run-Time Type Information in
a set of easy-to-use classes:

TrtWrapper
This class takes a class or object in its constructor and provides access to
properties in a manner similar to TTable.  For example, here is the code to
make every control on a form that can support a Popup menu use PopupMenu1:

  var
    RTObj: TrtWrapper;
    i: integer;
  begin
    for i := 0 to ComponentCount - 1 do
    begin
      RTObj := TrtWrapper.Create(Components[i]);

      if RTObj.HasProperty('PopupMenu') then
        RTObj['PopupMenu'].AsObject := PopupMenu1;

      RTObj.Free;
    end;
  end;

And here is the code to get strings for the enumeration values of the Align
property of any TControl.  Notice that no created instance is required for this:

  var
    Prop: TrtProperty;
    i: integer;
  begin
    Prop := TrtProperty.Create( TControl, 'Align' );

    for i := 0 to Prop.EnumNames.Count - 1 do
    begin
      ShowMessage( Prop.EnumNames[i] );
    end;
  end;

TrtProperty
This class represents an individual published property of a class or object.
It provides a simple interface for checking attributes of the property, and it
provides convenient and familiar 'AsSomething' properties to get and set the
Property's value.  Here's an extension of the previous example, this time with
TrtProperty:

  var
    RTObj: TrtWrapper;
    Prop: TrtProperty;
    i, j: integer;
  begin
    for i := 0 to ComponentCount - 1 do
    begin
      RTObj := TrtWrapper.Create(Components[i]);

      for j := 0 to RTObj.Count - 1 do
      begin
        Prop := RTObj.Items[j];

        //set all fonts to match the form font, regardless of property name
        if Prop.Kind = tkClass then
        begin
          if Prop.PropClassType.InheritsFrom( TFont ) then
            Prop.AsObject := Font;
        end;
      end;

      RTObj.Free;
    end;
  end;
}

interface

uses typinfo, Classes, SysUtils, contnrs;

type
  TStringArray = array of string;

  {
  Record types used by TrtProperty to wrap TypeData
  }
  PrtParamData = ^TrtParamData;
  TrtParamData = record
    Flags: TParamFlags;
    ParamName: ShortString;
    TypeName: ShortString;
  end;
  TrtMethodData = record
    MethodKind: TMethodKind;
    ParamCount: Byte;
    ParamList: array of TrtParamData;
    ResultType: ShortString;
  end;

  {
  TrtProperty is a class the represents a single property's RTTI.
  }
  TrtProperty = class
  private
    function GetReadOnly: boolean;
  protected
    FEnumNames: TStringList;
    FSetNames: TStringList;
    procedure VerifyWritable;

    function GetAsString: string;
    function GetAsFloat: extended;
    function GetAsInt64: int64;
    function GetAsInteger: integer;
    function GetAsMethod: TMethod;
    function GetAsObject: TObject;
    function GetAsVariant: Variant;
    function GetName: string;
    function GetValue: Variant;
    procedure SetAsFloat( const Value: extended );
    procedure SetAsInt64( const Value: int64 );
    procedure SetAsInteger( const Value: integer );
    procedure SetAsMethod( const Value: TMethod );
    procedure SetAsObject( const Value: TObject );
    procedure SetAsString( const Value: string );
    procedure SetAsVariant( const Value: Variant );
    procedure SetValue( const Value: Variant );

    function GetTypeKind: TTypeKind;
    function GetEnumNames: TStrings;
    function GetSetNames: TStrings;
    function GetPropClassType: TClass;
    function GetIsDelegate: boolean;
    function GetIsStored: boolean;
  public
    Instance: TObject;
    ObjClassType: TClass;
    TypeData: PTypeData;
    TypeInfo: PTypeInfo;
    PropInfo: PPropInfo;
    constructor Create( APropInfo: PPropInfo ); overload; virtual;
    constructor Create( AObject: TObject; propName: string ); overload; virtual;
    constructor Create( AClass: TClass; propName: string ); overload; virtual;
    destructor Destroy; override;

    //Getting and Setting the Property's Value
    property AsString: string read GetAsString write SetAsString;
    property AsInteger: integer read GetAsInteger write SetAsInteger;
    property AsInt64: int64 read GetAsInt64 write SetAsInt64;
    property AsFloat: extended read GetAsFloat write SetAsFloat;
    property AsMethod: TMethod read GetAsMethod write SetAsMethod;
    property AsObject: TObject read GetAsObject write SetAsObject;
    property AsVariant: Variant read GetAsVariant write SetAsVariant;
    property Value: Variant read GetValue write SetValue;

    //Direct access to commonly used type information
    //The name of the property
    property Name: string read GetName;
    //The type kind of the property
    property Kind: TTypeKind read GetTypeKind;
    //If the property is an enumerated type, this string list contains string
    //  representations of the possible enumerator values.
    property EnumNames: TStrings read GetEnumNames;
    //If the property is a set type, this string list contains string
    //  representations of the possible set member values.
    property SetNames: TStrings read GetSetNames;
    //If the property is a set type, returns true if the set includes a member
    //  of the given type.
    function SetHasMember( MemberStr: string ): boolean;
    //If the property is a class type, returns the class type.
    property PropClassType: TClass read GetPropClassType;
    //If the property is a class type, it could be a reference or a delegate.
    //  This property returns true if the property is a delegate.
    property IsDelegate: boolean read GetIsDelegate;
    //Returns true if the property is going to be stored (isn't the default
    //  value)
    property IsStored: boolean read GetIsStored;
    //Returns true if the property is read-only.
    property ReadOnly: boolean read GetReadOnly;
    //Returns a TrtMethodData record, my own record for encapsulating method
    //  information.
    function MethodData: TrtMethodData;
    //A helper function to help determine how many characters would be
    //  needed to store all possible values of the property.  This is
    //  only works for Enumeration and Set types.
    function MaxStringLen: integer;
  end;

  {
  TrtPropertyList is a container class for TrtProperty instances.  It helps
  TrtWrapper (below) keep track of and clean up after instances of
  TrtPropertyList.
  }
  TrtPropertyList = class( TObjectList )
  private
    function GetItem( Index: Integer ): TrtProperty;
    procedure SetItem( Index: Integer; const Value: TrtProperty );
  public
    constructor Create; virtual;
    function Add( ArtPropObj: TrtProperty ): Integer;
    function Remove( ArtPropObj: TrtProperty ): Integer;
    property Items[Index: Integer]: TrtProperty read GetItem write SetItem; default;
  end;

  {
  TrtWrapper

  TrtWrapper is an object that is meant to parallel any object instance or class,
  providing random access to any of the published property type information
  of that instance or class.

  This class uses RTTI to navigate the published
  properties of an instance or class.  I encapsulates the logic of
  navigating specific property kinds (VisiblePropKinds), while avoiding
  properties of specific names (StopNames)
  }
  TrtWrapper = class
  protected
    nAllCount, nCount: integer;
    FVisiblePropKinds: TTypeKinds;
    FStopNames: TStringList;
    FMethods: TStringList;
    bInternalStopNameChange: boolean;

    FPropObjects: TrtPropertyList;

    FObjInstance: TObject;

    procedure SetStopNames( const Value: TStrings );
    procedure SetVisiblePropKinds( const Value: TTypeKinds );
    function GetStopNames: TStrings;
    procedure SetObjInstance( const Value: TObject );
    function GetMethods: TStringList;

    function NextAllIndexFromAllIndex( AllIndex: integer ): integer; virtual;
    function CreatePropertyObject( Index: integer ): TrtProperty;
    function GetPropertyObject( Index: integer ): TrtProperty;

    function GetItemByName( Name: string ): TrtProperty;
    function GetItemByIndex( index: integer ): TrtProperty;

    procedure StopNamesChanged( Sender: TObject );

    procedure Initialize; virtual;

    property PropertyObjects[index: integer]: TrtProperty read GetPropertyObject;
  public
    ObjClass: TClass;
    ObjTypeData: PTypeData;
    ObjTypeInfo: PTypeInfo;
    ObjPropList: PPropList;
    VisiblePropInfos: array of PPropInfo;

    constructor Create; overload; virtual;
    constructor Create( AClass: TClass; PropKinds: TTypeKinds = [] ); overload; virtual;
    constructor Create( AObject: TObject; PropKinds: TTypeKinds = [] ); overload; virtual;
    constructor Create( AClass: TClass; PropKinds: TTypeKinds; StopNames: array of string ); overload; virtual;
    constructor Create( AObject: TObject; PropKinds: TTypeKinds; StopNames: array of string ); overload; virtual;
    destructor Destroy; override;

    //Returns the number of properties that the wrapper is exposing with the
    // Items property, after filtering based on visible PropKinds and StopNames.
    function Count: integer;

    //Returns the total number of properties in the class or object being
    // wrapper <b>before</b> any filtering is done.
    function AllCount: integer;

    //Returns true if the wrapped class or object has a property of the given
    //  name. (includes all properties, not just the filtered properties)
    function HasProperty( PropertyName: string ): boolean;

    //The property kinds exposed by the wrapper. This is the value passed as
    //  the "PropKinds" parameter to the constructor. It can be changed at any time.
    property VisiblePropKinds: TTypeKinds read FVisiblePropKinds write SetVisiblePropKinds;

    //The names of properties to be removed from the list of properties exposed
    //  by the wrapper. This list can be modified at any time.
    property StopNames: TStrings read GetStopNames write SetStopNames;

    //Returns an instance of TrtProperty wrapping the property specified by
    //  name. This is the default property of the wrapper, to allow easy access.
    property ItemsByName[Name: string]: TrtProperty read GetItemByName; default;

    //Returns an instance of TrtProperty wrapping the property specified by
    //  index into the list of exposed properties. Use the Count method to
    //  iterate through this property.
    property Items[index: integer]: TrtProperty read GetItemByIndex;

    //The object instance being wrapped. This can be nil if the wrapper is
    //  wrapping a class. This property can be modified at any time, so a
    //  single wrapper can be re-used to work on multiple objects.
    property ObjInstance: TObject read FObjInstance write SetObjInstance;

    //Returns a TStringList populated with the published method names and
    //  pointers to the actual methods (stored in the "Objects" property of
    //  TStringList).
    property Methods: TStringList read GetMethods;
  end;

//Global Utility Functions
//Copies the values or published properties from one TPersistent to another
//  TPersistent. This is similar to the default cloning behavior in java.
procedure AssignSomePublishedProps( Src, Dest: TPersistent; PropKinds: TTypeKinds;
  StopNames: array of string ); // Don't overload due to Delphi 5 bug
procedure AssignPublishedProps( Src, Dest: TPersistent; PropKinds: TTypeKinds = [] );
//Find a component in the scope of all forms and data modules.
//  (Adapted from Borland's hidden version)
function rtFindGlobalComponent( const Name: string ): TComponent;
//Access a singleton TList of all the components in the scope of all forms and data modules.
function rtGlobalComponentList: TList;
//Convert a type kind into its string representation.
function TypeKindToStr( Kind: TTypeKind ): string;
//Get a list of published methods for a given class or object
procedure GetMethodList( FromClass: TClass; MethodList: TStrings ); overload;
procedure GetMethodList( AObject: TObject; MethodList: TStrings ); overload;
//Get/Set the string value of a property for an object
function GetPropertyString( Obj: TObject; sPropName: string ): string;
procedure SetPropertyString( Obj: TObject; sPropName: string; Value: string );

resourcestring
  ERR_NOINSTANCE = 'This method cannot be called without an object instance.  ' +
    'Construct the RTTI object by passing an object instance to the constructor.';
  ERR_READONLY = 'Cannot set a read-only property.';

implementation

uses Forms;

var
  FrtGlobalComponentList: TList; //Singleton accessed by rtGlobalComponentList

//---------- Internal Utility Functions ------------

{
GetSetString
  Since GetSetProp does not initialize Result to an empty string, I must do so
  for it.  silly bug...
}

function GetSetString( Obj: TObject; pInfo: PPropInfo; Brackets: boolean ): string;
begin
  SetLength( Result, 0 );
  Result := GetSetProp( Obj, pInfo, Brackets );
end;

{
GetEnumNamesFromTypeInfo
  Fill the TStrings with the enumeration names described in TypeInfo's TypeData
}

procedure GetEnumNamesFromTypeInfo( TypeInfo: PTypeInfo; sl: TStrings );
var
  TypeData: PTypeData;
  nValue: integer;
begin
  sl.Clear;
  TypeData := GetTypeData( TypeInfo );
  for nValue := TypeData.MinValue to TypeData.MaxValue do
  begin
    sl.AddObject( GetEnumName( TypeInfo, nValue ), TObject( nValue ) );
  end;
end;

//---------- Global Utility Functions ------------

{
rtFindGlobalComponent
  Find a component in the scope of all forms and data modules.
    (Adapted from Borland's hidden version)
}

function rtFindGlobalComponent( const Name: string ): TComponent;
var
  I: Integer;
begin
  for I := 0 to Screen.FormCount - 1 do
  begin
    Result := Screen.Forms[I];
    if not ( csInline in Result.ComponentState ) and
      ( CompareText( Name, Result.Name ) = 0 ) then Exit;
    Result := Result.FindComponent( Name );
    if Assigned( Result ) then Exit;
  end;
  for I := 0 to Screen.DataModuleCount - 1 do
  begin
    Result := Screen.DataModules[I];
    if CompareText( Name, Result.Name ) = 0 then Exit;
    Result := Result.FindComponent( Name );
    if Assigned( Result ) then Exit;
  end;
  Result := nil;
end;

procedure AssignPublishedProps( Src, Dest: TPersistent; PropKinds: TTypeKinds = [] );
begin
  AssignSomePublishedProps( Src, Dest, PropKinds, [] );
end;


procedure AssignSomePublishedProps( Src, Dest: TPersistent; PropKinds: TTypeKinds;
  StopNames: array of string );
var