proplist.pas

类似Delphi Ide的对象查看器 可以在RUNTIME时使用

unit PropList;

{$IFDEF VER100}
  {$DEFINE VERSION3}
{$ENDIF}
{$IFDEF VER110}
  {$DEFINE VERSION3}
{$ENDIF}
{$IFDEF VER120}
  {$DEFINE VERSION4}
{$ENDIF}
{$IFDEF VER125}
  {$DEFINE VERSION4}
{$ENDIF}
{$IFDEF VER140}
  {$DEFINE VARIANTS}
{$ENDIF}
{$IFDEF VER150}
  {$DEFINE VARIANTS}
{$ENDIF}
{$IFDEF VER170}
  {$DEFINE VARIANTS}
{$ENDIF}

interface

uses Windows, Classes, SysUtils,
  {$IFDEF VARIANTS}
  Variants,
  {$ENDIF}
  TypInfo, Graphics, Controls, Forms, Menus;

resourcestring
  strPropListInvalidValue = 'Invalid property value.';

const

  tkOrdinals = [tkInteger,tkChar,tkEnumeration,tkSet,tkClass,tkWChar];
  tkChars = [tkChar,tkWChar];
  tkStrings = [tkString,tkLString,tkWString];

type

  EPropertyException = class(Exception);

  TPropertyList = class;
  TProperty = class;

  TGetPropertyValue = function(AInstance: TPersistent; Prop: TProperty): string;
  TSetPropertyValue = procedure(AInstance: TPersistent; Prop: TProperty; Value: string);

  TCustomPropData = class
  public
    InstanceType: TClass;
    PropName: string;
    PropType: PTypeInfo;
    Descendants: Boolean;
    GetProc: TGetPropertyValue;
    SetProc: TSetPropertyValue;
  constructor Create(AInstanceType: TClass; APropName: string; APropType: PTypeInfo; ADescendants: Boolean; AGetProc: TGetPropertyValue; ASetProc: TSetPropertyValue);
  end;

  TProperty = class
  private
    FOwner: TPropertyList;
    FRoot: TComponent;
    FInstance: TPersistent;
    FPropInfo: PPropInfo;
    FTypeData: PTypeData;
    FProperties: TPropertyList;
    FPropData: TCustomPropData;
    // internal property access methods
    function GetEmulated: Boolean;
    function GetCustom: Boolean;
    function GetOwnerProperty: TProperty;
    function GetLevel: Integer;
    // propinfo properties access methods
    function GetPropType: PTypeInfo;
    function GetGetProc: Pointer;
    function GetSetProc: Pointer;
    function GetIsStored: Boolean;
    function GetIndex: SmallInt;
    function GetDefault: LongInt;
    function GetNameIndex: SmallInt;
    function GetName: ShortString;
    function GetFullName: string;
    function GetTypeName: string;
    function GetTypeKind: TTypeKind;
    // properties for ordinal and set types
    function GetOrdType: TOrdType;
    function GetMinValue: Longint;
    function GetMaxValue: Longint;
    // property for set types
    function GetCompType: PTypeInfo;
    // properties for enumeration types
    function GetBaseType: PTypeInfo;
    function GetEnumCount: Integer;
    function GetEName(Value: Integer): string;
    function GetEValue(Value: string): Integer;
    // property for float types
    function GetFloatType: TFloatType;
    // property for short string types
    function GetMaxLength: Byte;
    // properties for class types
    function GetClassType: TClass;
    function GetParentInfo: PTypeInfo;
    function GetUnitName: ShortString;
    // properties for method types
    function GetMethodKind: TMethodKind;
    function GetParamCount: Integer;
    function GetParamFlags(Index: Integer): TParamFlags;
    function GetParamName(Index: Integer): ShortString;
    function GetParamType(Index: Integer): ShortString;
    function GetParameter(Index: Integer): ShortString;
    function GetResultType: ShortString;
    function GetMethodDeclaration: string;
    // properties for interface type
    function GetIntfParent: PTypeInfo;
    function GetIntfFlags: TIntfFlags;
    function GetGUID: TGUID;
    function GetIntfUnit: ShortString;
    {$IFNDEF VERSION3}
    // properties for Int64 type
    function GetMinInt64Value: Int64;
    function GetMaxInt64Value: Int64;
    {$ENDIF}
    // value access methods
    function GetAsFloat: Extended;
    procedure SetAsFloat(const Value: Extended);
    function GetAsMethod: TMethod;
    procedure SetAsMethod(const Value: TMethod);
    function GetAsInteger: Longint;
    procedure SetAsInteger(const Value: Longint);
    function GetAsChar: Char;
    procedure SetAsChar(const Value: Char);
    function GetAsBoolean: Boolean;
    procedure SetAsBoolean(const Value: Boolean);
    function GetAsObject: TObject;
    procedure SetAsObject(const Value: TObject);
    function GetAsDateTime: TDateTime;
    procedure SetAsDateTime(const Value: TDateTime);
    function GetAsDate: TDate;
    procedure SetAsDate(const Value: TDate);
    function GetAsTime: TTime;
    procedure SetAsTime(const Value: TTime);
    function GetAsString: string;
    procedure SetAsString(const Value: string);
    function GetAsVariant: Variant;
    procedure SetAsVariant(const Value: Variant);
    {$IFNDEF VERSION3}
    function GetAsInterface: IUnknown;
    procedure SetAsInterface(const Value: IUnknown);
    {$ENDIF}
  public
    constructor Create(AOwner: TPropertyList; ARoot,AInstance: TComponent; APropInfo: PPropInfo; APropData: TCustomPropData); virtual;
    destructor Destroy; override;
    procedure Assign(Source: TProperty);
    function CreatePropertyList: TPropertyList; virtual;
    function DisplayValue: string; virtual;
    function GetStringValue: string; virtual;
    procedure SetStringValue(const Value: string); virtual;
    procedure ValuesList(const Values: TStrings); virtual;
    function IsCompatibleObject(AObject: TObject): Boolean;
    function IsCompatibleType(ATypeInfo: PTypeInfo): Boolean;
    function IsType(ATypeInfo: PTypeInfo): Boolean;
    function IsCompatible(P: TProperty): Boolean;
    // internal properties
    property Emulated: Boolean read GetEmulated;
    property Custom: Boolean read GetCustom;
    property Owner: TPropertyList read FOwner;
    property OwnerProperty: TProperty read GetOwnerProperty;
    property Level: Integer read GetLevel;
    // main properties
    property Root: TComponent read FRoot write FRoot;
    property Instance: TPersistent read FInstance write FInstance;
    // propinfo properties
    property TypeData: PTypeData read FTypeData;
    property PropType: PTypeInfo read GetPropType;
    property GetProc: Pointer read GetGetProc;
    property SetProc: Pointer read GetSetProc;
    property IsStored: Boolean read GetIsStored;
    property Index: SmallInt read GetIndex;
    property Default: Integer read GetDefault;
    property NameIndex: SmallInt read GetNameIndex;
    property Name: ShortString read GetName;
    property FullName: string read GetFullName;
    property TypeName: string read GetTypeName;
    property TypeKind: TTypeKind read GetTypeKind;
    // properties for ordinal types
    property OrdType: TOrdType read GetOrdType;
    property MinValue: Longint read GetMinValue;
    property MaxValue: Longint read GetMaxValue;
    // properties for enumeration types
    property BaseType: PTypeInfo read GetBaseType;
    property EnumCount: Integer read GetEnumCount;
    property Names[Index: Integer]: string read GetEName;
    property Values[Index: string]: Integer read GetEValue;
    // properties for set types
    property CompType: PTypeInfo read GetCompType;
    // property for float types
    property FloatType: TFloatType read GetFloatType;
    // property for short string types
    property MaxLength: Byte read GetMaxLength;
    // properties for class types
    property PropClassType: TClass read GetClassType;
    property ParentInfo: PTypeInfo read GetParentInfo;
    property UnitName: ShortString read GetUnitName;
    property Properties: TPropertyList read FProperties;
    // properties for method types
    property MethodKind: TMethodKind read GetMethodKind;
    property ParamCount: Integer read GetParamCount;
    property ParamFlags[Index: Integer]: TParamFlags read GetParamFlags;
    property ParamNames[Index: Integer]: ShortString read GetParamName;
    property ParamTypes[Index: Integer]: ShortString read GetParamType;
    property Parameters[Index: Integer]: ShortString read GetParameter;
    property ResultType: ShortString read GetResultType;
    property MethodDeclaration: string read GetMethodDeclaration;
    // properties for interface type
    property IntfParent: PTypeInfo read GetIntfParent;
    property IntfFlags: TIntfFlags read GetIntfFlags;
    property GUID: TGUID read GetGUID;
    property IntfUnit: ShortString read GetIntfUnit;
    {$IFNDEF VERSION3}
    // properties for Int64 type
    property MinInt64Value: Int64 read GetMinInt64Value;
    property MaxInt64Value: Int64 read GetMaxInt64Value;
    {$ENDIF}
    // value access properties
    property AsFloat: Extended read GetAsFloat write SetAsFloat;
    property AsMethod: TMethod read GetAsMethod write SetAsMethod;
    property AsInteger: Longint read GetAsInteger write SetAsInteger;
    property AsChar: Char read GetAsChar write SetAsChar;
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
    property AsObject: TObject read GetAsObject write SetAsObject;
    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
    property AsDate: TDate read GetAsDate write SetAsDate;
    property AsTime: TTime read GetAsTime write SetAsTime;
    property AsString: string read GetAsString write SetAsString;
    property AsVariant: Variant read GetAsVariant write SetAsVariant;
    {$IFNDEF VERSION3}
    property AsInterface: IUnknown read GetAsInterface write SetAsInterface;
    {$ENDIF}
//-------
    property PropInfo: PPropInfo Read FPropInfo;
//----------
  end;

  TCompareMethod = function (P1,P2: TProperty): Integer of object;

  TPropertyList = class
  private
    FOwner: TProperty;
    FProperties: TList;
    FRoot: TComponent;
    FInstance: TComponent;
    function GetOwnerList: TPropertyList;
    function GetLevel: Integer;
    function GetCount: Integer;
    function GetProperty(AIndex: Integer): TProperty;
    procedure SetRoot(const Value: TComponent);
    procedure SetInstance(const Value: TComponent);
    procedure Clear;
    procedure Sort;
  public
    constructor Create(AOwner: TProperty); virtual;
    destructor Destroy; override;
    function CreateProperty(APropInfo: PPropInfo; APropData: TCustomPropData): TProperty; virtual;
    procedure AddEmulated(P: TProperty); virtual;
    procedure Update; virtual;
    function Compare(P1,P2: TProperty): Integer; virtual;
    function Filter(P: TProperty): Boolean; virtual;
    function IndexOf(const Item: TProperty): Integer;
    function IndexOfName(const Name: string): Integer;
    function FindProperty(const Name: string): TProperty;
    property OwnerList: TPropertyList read GetOwnerList;
    property Level: Integer read GetLevel;
    property Properties[Index: Integer]: TProperty read GetProperty; default;
    property Count: Integer read GetCount;
    property Owner: TProperty read FOwner;
    property Root: TComponent read FRoot write SetRoot;
    property Instance: TComponent read FInstance write SetInstance;
  end;

procedure RegisterCustomProperty(AInstanceType: TClass; APropName: string; APropType: PTypeInfo; ADescendants: Boolean; AGetProc: TGetPropertyValue; ASetProc: TSetPropertyValue);
function RegisteredProperty(AInstanceType: TClass; APropName: string): Boolean;
procedure UnregisterCustomProperty(AInstanceType: TClass; APropName: string);
procedure UnregisterCustomProperties;

implementation

// variant internal functions

type
  TVariantRec = record
    Val: Integer;
    Name: string;
  end;

const
  VariantNames: array[0..12] of TVariantRec = (
    (Val: varEmpty; Name: 'Unassigned'),
    (Val: varNull; Name: 'Null'),
    (Val: varSmallint; Name: 'Smallint'),
    (Val: varInteger; Name: 'Integer'),
    (Val: varSingle; Name: 'Single'),
    (Val: varDouble; Name: 'Double'),
    (Val: varCurrency;  Name: 'Currency'),
    (Val: varDate; Name: 'Date'),
    (Val: varOleStr; Name: 'OleStr'),
    (Val: varBoolean; Name: 'Boolean'),
    (Val: varUnknown; Name: 'Unknown'),
    (Val: varByte; Name: 'Byte'),
    (Val: varString; Name: 'String'));

function VariantName(AType: Integer): string;
var
  i: Integer;
begin
  Result:='';
  for i:=0 to High(VariantNames) do
    with VariantNames[i] do
      if AType=Val then
      begin
        Result:=Name;
        Break;
      end;
end;

function VariantType(AName: string): Integer;
var
  i: Integer;
begin
  Result:=varUnknown;
  for i:=0 to High(VariantNames) do
    with VariantNames[i] do
      if AName=Name then
      begin
        Result:=Val;
        Break;
      end;
end;

constructor TCustomPropData.Create(AInstanceType: TClass; APropName: string; APropType: PTypeInfo; ADescendants: Boolean; AGetProc: TGetPropertyValue; ASetProc: TSetPropertyValue);
begin
  inherited Create;
  InstanceType:=AInstanceType;
  PropName:=APropName;
  PropType:=APropType;
  Descendants:=ADescendants;
  GetProc:=AGetProc;
  SetProc:=ASetProc;
end;

type
  TCustomPropertiesList = class(TList)
    function GetPropertyData(AInstanceType: TClass; APropName: string): TCustomPropData;
    function FindProperty(AInstanceType: TClass; APropName: string): TCustomPropData;
  end;

function TCustomPropertiesList.GetPropertyData(AInstanceType: TClass; APropName: string): TCustomPropData;
var
  i: Integer;
  AType: TClass;
begin
  Result:=nil;
  APropName:=AnsiUpperCase(APropName);
  AType:=AInstanceType;
  while Assigned(AType) do
  begin
    for i:=0 to Pred(Count) do
      with TCustomPropData(Items[i]) do
        if (AType=InstanceType) and
          (APropName=AnsiUpperCase(PropName)) and
          ((AType=AInstanceType) or Descendants) then
        begin
          Result:=Items[i];
          Exit;
        end;
    AType:=AType.ClassParent;
  end;
end;

function TCustomPropertiesList.FindProperty(AInstanceType: TClass; APropName: string): TCustomPropData;
var
  i: Integer;
begin
  Result:=nil;
  APropName:=AnsiUpperCase(APropName);
  for i:=0 to Pred(Count) do
    with TCustomPropData(Items[i]) do
      if (AInstanceType=InstanceType) and (APropName=AnsiUpperCase(PropName)) then
      begin
        Result:=Items[i];
        Break;
      end;
end;

var
  CustomProperties: TCustomPropertiesList;

procedure RegisterCustomProperty(AInstanceType: TClass; APropName: string; APropType: PTypeInfo; ADescendants: Boolean; AGetProc: TGetPropertyValue; ASetProc: TSetPropertyValue);
begin
  with CustomProperties do
    if not Assigned(FindProperty(AInstanceType,APropName)) then
      Add(TCustomPropData.Create(AInstanceType,APropName,APropType,ADescendants,AGetProc,ASetProc));
end;

function RegisteredProperty(AInstanceType: TClass; APropName: string): Boolean;
begin
  Result:=Assigned(CustomProperties.GetPropertyData(AInstanceType,APropName));
end;

procedure UnregisterCustomProperty(AInstanceType: TClass; APropName: string);
var
  P: TCustomPropData;
begin
  with CustomProperties do
  begin
    P:=FindProperty(AInstanceType,APropName);
    if Assigned(P) then
    begin
      Delete(IndexOf(P));
      P.Free;
    end;
  end;
end;

procedure UnregisterCustomProperties;
var
  i: Integer;
begin
  with CustomProperties do
  begin
    for i:=0 to Pred(Count) do TObject(Items[i]).Free;
    Clear;
  end;
end;

function TProperty.GetEmulated: Boolean;
begin
  Result:=not Assigned(FPropInfo);