rttihelp.pas

Delphi高级开发指南是开发程序的好帮手

unit RttiHelp;

interface

uses
  TypInfo, Classes;

// *** RTTI ***

// show RTTI info in a dialog box
procedure ShowRttiDetail (pti: PTypeInfo);
// show RTTI info (generic)
procedure ShowRTTI (pti: PTypeInfo; sList: TStrings);
// show RTTI information for method pointers (from Chapter 4)
procedure ShowMethod (pti: PTypeInfo; sList: TStrings);
// show RTTI information for class type (from Chapter 4)
procedure ShowClass (pti: PTypeInfo; sList: TStrings);
// show RTTI information for ordinal types (from Chapter 4)
procedure ShowOrdinal (pti: PTypeInfo; sList: TStrings);
// list enumerated values (from Chapter 4)
procedure ListEnum (pti: PTypeInfo; sList: TStrings; ShowIndex: Boolean);

// *** property values ***

// return the property value as a string
function GetPropValAsString (Obj: TObject; PropInfo: PPropInfo): string;
// turn the value of a set into a string
function SetToString (Value: Cardinal; pti: PTypeInfo): string;
// sort properties: extracted from TypInfo.pas
procedure SortPropList(PropList: PPropList; PropCount: Integer); assembler;

// *** other ***

// test bit: extracted from Chapter 1 of DDH
function IsBitOn (Value: Integer; Bit: Byte): Boolean;

implementation

uses
  SysUtils, Graphics, Controls, Forms, StdCtrls, Buttons;

// redeclaration of RTTI type
type
  TParamData = record
    Flags: TParamFlags;
    ParamName: ShortString;
    TypeName: ShortString;
    // beware: string length varies!!!
  end;
  PParamData = ^TParamData;

// show RTTI information for method pointers
procedure ShowMethod (pti: PTypeInfo; sList: TStrings);
var
  ptd: PTypeData;
  pParam: PParamData;
  nParam: Integer;
  Line: string;
  pTypeString, pReturnString: ^ShortString;
begin
  // protect against misuse
  if pti^.Kind <> tkMethod then
    raise Exception.Create ('Invalid type information');

  // get a pointer to the TTypeData structure
  ptd := GetTypeData (pti);

  // 1: access the TTypeInfo structure
  sList.Add ('Type Name: ' + pti^.Name);
  sList.Add ('Type Kind: ' + GetEnumName (
    TypeInfo (TTypeKind),
    Integer (pti^.Kind)));

  // 2: access the TTypeData structure
  sList.Add ('Method Kind: ' + GetEnumName (
    TypeInfo (TMethodKind),
    Integer (ptd^.MethodKind)));
  sList.Add ('Number of parameter: ' +
    IntToStr (ptd^.ParamCount));

  // 3: access to the ParamList
  // get the initial pointer and
  // reset the parameters counter
  pParam := PParamData (@(ptd^.ParamList));
  nParam := 1;
  // loop until all parameters are done
  while nParam <= ptd^.ParamCount do
  begin
    // read the information
    Line := 'Param ' + IntToStr (nParam) + ' > ';
    // add type of parameter
    if pfVar in pParam^.Flags then
      Line := Line + 'var ';
    if pfConst in pParam^.Flags then
      Line := Line + 'const ';
    if pfOut in pParam^.Flags then
      Line := Line + 'out ';
    // get the parameter name
    Line := Line + pParam^.ParamName + ': ';
    // one more type of parameter
    if pfArray in pParam^.Flags then
      Line := Line + ' array of ';
    // the type name string must be located...
    // moving a pointer past the params and
    // the string (including its size byte)
    pTypeString := Pointer (Integer (pParam) +
      sizeof (TParamFlags) +
      Length (pParam^.ParamName) + 1);
    // add the type name
    Line := Line + pTypeString^;
    // finally, output the string
    sList.Add (Line);
    // move the pointer to the next structure,
    // past the two strings (including size byte)
    pParam := PParamData (Integer (pParam) +
      sizeof (TParamFlags) +
      Length (pParam^.ParamName) + 1 +
      Length (pTypeString^) + 1);
    // increase the parameters counter
    Inc (nParam);
  end;
  // show the return type if a function
  if ptd^.MethodKind = mkFunction then
  begin
    // at the end, instead of a param data,
    // there is the return string
    pReturnString := Pointer (pParam);
    sList.Add ('Returns > ' + pReturnString^);
  end;
end;

// show RTTI information for class type
procedure ShowClass (pti: PTypeInfo; sList: TStrings);
var
  ptd: PTypeData;
  ppi: PPropInfo;
  pProps: PPropList;
  nProps, I: Integer;
  ParentClass: TClass;
begin
  // protect against misuse
  if pti.Kind <> tkClass then
    raise Exception.Create ('Invalid type information');

  // get a pointer to the TTypeData structure
  ptd := GetTypeData (pti);

  // access the TTypeInfo structure
  sList.Add ('Type Name: ' + pti.Name);
  sList.Add ('Type Kind: ' + GetEnumName (
    TypeInfo (TTypeKind),
    Integer (pti.Kind)));

  // access the TTypeData structure
  {omitted: the same information of pti^.Name...
  sList.Add ('ClassType: ' + ptd^.ClassType.ClassName);}
  sList.Add ('Size: ' + IntToStr (
    ptd.ClassType.InstanceSize) + ' bytes');
  sList.Add ('Defined in: ' + ptd.UnitName + '.pas');

  // add the list of parent classes (if any)
  ParentClass := ptd.ClassType.ClassParent;
  if ParentClass <> nil then
  begin
    sList.Add ('');
    sList.Add ('=== Parent classes ===');
    while ParentClass <> nil do
    begin
      sList.Add (ParentClass.ClassName);
      ParentClass := ParentClass.ClassParent;
    end;
  end;

  // add the list of properties (if any)
  nProps := ptd.PropCount;
  if nProps > 0 then
  begin
    // format the initial output
    sList.Add ('');
    sList.Add ('=== Properties (' +
      IntToStr (nProps) + ') ===');
    // allocate the required memory
    GetMem (pProps, sizeof (PPropInfo) * nProps);
    // protect the memory allocation
    try
      // fill the TPropList structure
      // pointed to by pProps
      GetPropInfos(pti, pProps);
      // sort the properties
      SortPropList(pProps, nProps);
      // show name and data type of each property
      for I := 0 to nProps - 1 do
      begin
        ppi := pProps [I];
        sList.Add (ppi.Name + ': ' +
          ppi.PropType^.Name);
      end;
    finally
      // free the allocated memmory
      FreeMem (pProps, sizeof (PPropInfo) * nProps);
    end;
  end;
end;

// show RTTI information for ordinal types
procedure ShowOrdinal (pti: PTypeInfo; sList: TStrings);
var
  ptd: PTypeData;
begin
  // protect against misuse
  if not (pti^.Kind in [tkInteger, tkChar,
      tkEnumeration, tkSet, tkWChar]) then
    raise Exception.Create ('Invalid type information');

  // get a pointer to the TTypeData structure
  ptd := GetTypeData (pti);

  // access the TTypeInfo structure
  sList.Add ('Type Name: ' + pti^.Name);
  sList.Add ('Type Kind: ' + GetEnumName (
    TypeInfo (TTypeKind),
    Integer (pti^.Kind)));

  // access the TTypeData structure
  sList.Add ('Implement: ' + GetEnumName (
    TypeInfo (TOrdType),
    Integer (ptd^.OrdType)));

  // a set has no min and max
  if pti^.Kind <> tkSet then
  begin
    sList.Add ('Min Value: ' + IntToStr (ptd^.MinValue));
    sList.Add ('Max Value: ' + IntToStr (ptd^.MaxValue));
  end;

  // add the enumeration base type
  // and the list of the values
  if pti^.Kind = tkEnumeration then
  begin
    sList.Add ('Base Type: ' + (ptd^.BaseType)^.Name);
    sList.Add ('');
    sList.Add ('Values...');
    ListEnum (pti, sList, True);
  end;

  // show RRTI info about set base type
  if  pti^.Kind = tkSet then
  begin
    sList.Add ('');
    sList.Add ('Set base type information...');
    ShowOrdinal (ptd^.CompType^, sList);
  end;
end;

// list enumerated values
procedure ListEnum (pti: PTypeInfo;
  sList: TStrings; ShowIndex: Boolean);
var
  I: Integer;
begin
  with GetTypeData(pti)^ do
    for I := MinValue to MaxValue do
      if ShowIndex then
        sList.Add ('  ' + IntToStr (I) + '. ' +
         GetEnumName (pti, I))
      else
        sList.Add (GetEnumName (pti, I));
end;

// generic procedure, calling the other ones
procedure ShowRTTI (pti: PTypeInfo; sList: TStrings);
begin
  case pti^.Kind of
    tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
      ShowOrdinal (pti, sList);
    tkMethod:
      ShowMethod (pti, sList);
    tkClass:
      Showclass (pti, sList);
    tkString, tkLString:
    begin
      sList.Add ('Type Name: ' + pti^.Name);
      sList.Add ('Type Kind: ' + GetEnumName (
        TypeInfo (TTypeKind), Integer (pti^.Kind)));
    end
    else
      sList.Add ('Undefined type information');
  end;
end;

// show the RTTI information inside a modal dialog box
procedure ShowRttiDetail (pti: PTypeInfo);
var
  Form: TForm;