Delphi技术积累

     今天遇到个难题，安装AlphaControls后，CxGrid并没有跟着必变，网上找了很久也没有结果，最好发现AlphaControls本身是支持DEV组件的，只是默认是不改变，不过在inc文件中已经预定义了。有一个关键性文件sDefs.inc:

   

{ ---- Definitions by Serge V. Goncharov ---- }

// -- 3rdparty support start -- //
{.$DEFINE DEVEX} // DevExpress, LookAndFeel.NativeStyle property must be False
{.$DEFINE USEPNG} // Support of TPngImageList from PngComponents
{.$DEFINE TNTUNICODE} // Enable Unicode support by TntControls
// -- 3rdparty support finish -- //

// -- Experimental features -- //
{.$DEFINE USEAERO} // Use system shadows in Aero
{.$DEFINE NOSLOWDETAILS} // Simplified output without slow effects

{ ------------------------------------ }

{.$DEFINE DISABLEPREVIEWMODE} // If key is enabled then preview code is excluded
{.$DEFINE NOWNDANIMATION} // Disable animation effects for dialogs and forms
{.$DEFINE CHANGEFORMSINDESIGN} // Changing the forms colors in design-time
{.$DEFINE SKININDESIGN} // Skin control in frames in design-time
{.NOACPNG} // Do not use AlphaControls Png loader
{.$DEFINE ALITE} // Free Lite Edition

{ ---- End defs by Serge V. Goncharov ---- }

 

=------------这是文件的部分内容，以下是改过的内容：

 

{ ---- Definitions by Serge V. Goncharov ---- }

// -- 3rdparty support start -- //
{$DEFINE DEVEX} // 《==============将前面的一个小点"."删除就OK
{.$DEFINE TNTUNICODE} // Enable Unicode support by TntControls
// -- 3rdparty support finish -- //

// -- Experimental features -- //
{.$DEFINE USEAERO} // Use system shadows in Aero
{.$DEFINE NOSLOWDETAILS} // Simplified output without slow effects

{ ------------------------------------ }

{.$DEFINE DISABLEPREVIEWMODE} // If key is enabled then preview code is excluded
{.$DEFINE NOWNDANIMATION} // Disable animation effects for dialogs and forms
{.$DEFINE CHANGEFORMSINDESIGN} // Changing the forms colors in design-time
{.$DEFINE SKININDESIGN} // Skin control in frames in design-time
{.NOACPNG} // Do not use AlphaControls Png loader
{.$DEFINE ALITE} // Free Lite Edition

{ ---- End defs by Serge V. Goncharov ---- }

 

     AlphaControls在acLFPainter单元中已经对DEV皮肤进行了覆盖。

    

unit acLFPainter;
{$I sDefs.inc}  //这里将预定义字符编译进单元

// WARNING! This unit is compatible with Devexpress version 2011
// for older versions the acLFPainter6 unit should be used

{$DEFINE VER653}
{$DEFINE VER650}  
{$DEFINE VER645}  
{$DEFINE VER640}

{$IFDEF VER653}
  {$DEFINE VER650}
{$ENDIF}

{$IFDEF VER650}
  {$DEFINE VER645}
{$ENDIF}

{$IFDEF VER645}
  {$DEFINE VER640}
{$ENDIF}

{$IFNDEF VER645}
  {$UNDEF VER650}
{$ENDIF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs{$IFNDEF DELPHI5}, Types{$ENDIF},
  sSkinManager, sStyleSimply, sMaskData, cxLookAndFeelPainters, cxGraphics, cxClasses, ImgList, dxCore;

type

  TsDevExProvider = class(TComponent)
  end;

  TcxACLookAndFeelPainter = class(TcxStandardLookAndFeelPainter)
  public
    function LookAndFeelName: string; override;
    // colors
    function DefaultContentColor: TColor; override;
    function DefaultContentEvenColor: TColor; override;
    function DefaultContentOddColor: TColor; override;
    function DefaultContentTextColor: TColor; override;
    function DefaultEditorBackgroundColor(AIsDisabled: Boolean): TColor; override;
    function DefaultEditorBackgroundColorEx(AKind: TcxEditStateColorKind): TColor; override;
    function DefaultEditorTextColor(AIsDisabled: Boolean): TColor; override;
    function DefaultEditorTextColorEx(AKind: TcxEditStateColorKind): TColor; override;
    function DefaultFilterBoxColor: TColor; override;
    function DefaultFilterBoxTextColor: TColor; override;
    function DefaultFixedSeparatorColor: TColor; override;
    function DefaultFooterColor: TColor; override;
    function DefaultFooterTextColor: TColor; override;
    function DefaultGridDetailsSiteColor: TColor; override;
    function DefaultGridLineColor: TColor; override;
    function DefaultGroupByBoxColor: TColor; override;
    function DefaultGroupByBoxTextColor: TColor; override;
    function DefaultGroupColor: TColor; override;
    function DefaultGroupTextColor: TColor; override;
    function DefaultHeaderBackgroundColor: TColor; override;
    function DefaultHeaderBackgroundTextColor: TColor; override;
    function DefaultHeaderColor: TColor; override;
    function DefaultHeaderTextColor: TColor; override;
    function DefaultHyperlinkTextColor: TColor; override;
    function DefaultInactiveColor: TColor; override;
    function DefaultInactiveTextColor: TColor; override;
    function DefaultPreviewTextColor: TColor; override;
    function DefaultRecordSeparatorColor: TColor; override;
    function DefaultSizeGripAreaColor: TColor; override;

    function DefaultVGridCategoryColor: TColor; override;
    function DefaultVGridCategoryTextColor: TColor; override;
    function DefaultVGridLineColor: TColor; override;
    function DefaultVGridBandLineColor: TColor; override;

    function DefaultDateNavigatorHeaderColor: TColor; override;
    function DefaultDateNavigatorSelectionColor: TColor; override;
    function DefaultDateNavigatorSelectionTextColor: TColor; override;

    function DefaultSchedulerBackgroundColor: TColor; override;
    function DefaultSchedulerTextColor: TColor; override;
    function DefaultSchedulerBorderColor: TColor; override;
    function DefaultSchedulerControlColor: TColor; override;
    function DefaultSchedulerNavigatorColor: TColor; override;
    function DefaultSchedulerViewContentColor: TColor; override;
    function DefaultSchedulerViewSelectedTextColor: TColor; override;
    function DefaultSchedulerViewTextColor: TColor; override;
    function DefaultSelectionColor: TColor; override;
    function DefaultSelectionTextColor: TColor; override;
    function DefaultSeparatorColor: TColor; override;
    function DefaultTabColor: TColor; override;
    function DefaultTabTextColor: TColor; override;
    function DefaultTabsBackgroundColor: TColor; override;

    ........................................

 

 

         效果非常漂亮！

 

现今所有的软件中都应用了设计模式，模式除了可以解决很多实际问题外，还给开发者带来非常顺畅的心情，本人是Delphi Fans现在关于这门语言的资料越来越少了。在这里给大家推荐两本书，一本是《敏捷软件开发》和《Delphi模式编程.刘艺》。我的笔记来自这两本书.

1.单一职责原则（SRP）.一个类而言，应该公仅有一个引起它变化的原因，所为“职责”就是变化的原因，如果能够想到多于一个的动机去改变一个类，那个这  个类就具有多一个职责。

2.   开放-封闭原则（OCP)  软件实体（类.模块.函数等）应该是可以扩展的，但是不可修改的。对于扩展是开发的，对于更改是封闭的。要点：关键是抽象，模块可以操作一个抽像体，其依赖于一个固定的抽象体，所以它对于更改可以是关闭的，同时通过从这个抽像体派生，也可以扩展此模块的行为。例：

        type

          IServer = interface //抽像接口
             ['{3E91264F-BBC0-44DF-8272-BD8EA9B5846C}']
           procedure View(o: TObject);
         end;

        TServerDB=Class(IServer) //具体实现类

          procedure View(o:TObject);

        end;

       TClientUser=class //客户类

         private

           FSDB:IServer;

         public

           procedure SetDB;

      end;

       在TClientUser中，只是依赖IServer，IServer是一个固定不变的抽像体，其它模块或函数升级或优化都对引用些接口的类或过程等没有影响，反之也可以

      从此接口继承，重新定义亲的类或进行扩展！这种设计方法是遵守了OCP原则，OCP的核心是“抽象”,这个原则可以带来面向对对对象技术的灵活性，可重用性及维护性，同样这种原则也不能泛用，正确做法是对程序中呈现出频繁变化的部分做出抽像。拒绝不成熟的抽像和抽像本身一样重要。

                     .......下待续

   

 

 

Delphi 的RTTI机制浅探

作者：Savetime:savetime2k@yahoo.com 转贴自：Delphibbs.com
目录
===========================================================
⊙ RTTI 简介
⊙ 类(class) 和 VMT 的关系
⊙ 类(class)、类的类(class of class)、类变量(class variable) 的关系
⊙ TObject.ClassType 和 TObject.ClassInfo
⊙ is 和 as 运算符的原理
⊙ TTypeInfo – RTTI 信息的结构
⊙ 获取类(class)的属性(property)信息
⊙ 获取方法(method)的类型信息
⊙ 获取有序类型(ordinal)、集合(set)类型的 RTTI 信息
⊙ 获取其它数据类型的 RTTI 信息
===========================================================
本文排版格式为：
正文由窗口自动换行；所有代码以 80 字符为边界；中英文字符以空格符分隔。

(作者保留对本文的所有权利，未经作者同意请勿在在任何公共媒体转载。)


正文
===========================================================
⊙ RTTI 简介
===========================================================

RTTI(Run-Time Type Information) 翻译过来的名称是“运行期类型信息”，也就是说可以在运行期获得数据类型或类(class)的信息。这个 RTTI 到底有什么用处，我现在也说不清楚。我是在阅读 Delphi 持续机制的代码中发现了很多 RTTI 的运用，只好先把 RTTI 学习一遍。下面是我的学习笔记。如果你发现了错误请告诉我。谢谢！

Delphi 的 RTTI 主要分为类(class)的 RTTI 和一般数据类型的 RTTI，下面从类(class)开始。

===========================================================
⊙ 类(class) 和 VMT 的关系
===========================================================

一个类(class)，从编译器的角度来看就是一个指向 VMT 的指针(在后文用 VMTptr 表示)。在类的 VMTptr 的负地址方向存储了一些类信息的指针，这些指针的值和指针所指的内容在编译后就确定了。比如 VMTptr - 44 的内容是指向类名称(ClassName)的指针。不过一般不使用数值来访问这些类信息，而是通过 System.pas 中定义的以 vmt 开头的常量，如 vtmClassName、vmtParent 等来访问。

类的方法有两种：对象级别的方法和类级别的方法。两者的 Self 指针意义是不同的。在对象级别的方法中 Self 指向对象地址空间，因此可以用它来访问对象的成员函数；在类级别的方法中 Self 指向类的 VMT，因此只能用它来访问 VMT 信息，而不能访问对象的成员字段。

===========================================================
⊙ 类(class)、类的类(class of class)、类变量(class variable) 的关系
===========================================================

上面说到类(class) 就是 VMTptr。在 Delphi 中还可以用 class of 关键字定义类的类，并且可以使用类的类定义类变量。从语法上理解这三者的关键并不难，把类当成普通的数据类型来考虑就可以了。在编译器级别上表现如何呢？

为了简化讨论，我们使用 TObject、TClass 和 TMyClass 来代表上面说的三种类型：

type
TClass = class of TObject;
var
TMyClass: TClass;
MyObject: TObject;
begin
TMyClass := TObject;
MyObject := TObject.Create;
MyObject := TClass.Create;
MyObject := TMyClass.Create;
end;

在上面的例子中，三个 TObject 对象都被成功地创建了。编译器的实现是：TObject 是一个 VMTPtr 常量。TClass 也是一个 VMTptr 常量，它的值就是 TObject。TMyClass 是一个 VMTptr 变量，它被赋值为 TObject。TObject.Create 与 TClass.Create 的汇编代码完全相同。但 TClass 不仅缺省代表一个类，而且还(主要)代表了类的类型，可以用它来定义类变量，实现一些类级别的操作。

===========================================================
⊙ TObject.ClassType 和 TObject.ClassInfo
===========================================================

function TObject.ClassType: TClass;
begin
Pointer(Result) := PPointer(Self)^;
end;

TObject.ClassType 是对象级别的方法，Self 的值是指向对象内存空间的指针，对象内存空间的前 4 个字节是类的 VMTptr。因此这个函数的返回值就是类的 VMTptr。

class function TObject.ClassInfo: Pointer;
begin
Result := PPointer(Integer(Self) + vmtTypeInfo)^;
end;

TObject.ClassInfo 使用 class 关键字定义，因此是一个类级别的方法。该方法中的 Self 指针就是 VMTptr。所以这个函数的返回值是 VMTptr 负方向的 vmtTypeInfo 的内容。

TObject.ClassInfo 返回的 Pointer 指针，实际上是指向类的 RTTI 结构的指针。但是不能访问 TObject.ClassInfo 指向的内容(TObject.ClassInfo 返回值是 0)，因为 Delphi 只在 TPersistent 类及 TPersistent 的后继类中产生 RTTI 信息。(从编译器的角度来看，这是在 TPersistent 类的声明之前使用 {$M+} 指示字的结果。)

TObject 还定义了一些获取类 RTTI 信息的函数，列举在下，就不一一分析了：

TObject.ClassName: ShortString; 类的名称
TObject.ClassParent: TClass; 对象的父类
TObject.InheritsFrom: Boolean; 是否继承自某类
TObject.InstanceSize: Longint; 对象实例的大小

===========================================================
⊙ is 和 as 运算符的原理
===========================================================

我们知道可以在运行期使用 is 关键字判断一个对象是否属于某个类，可以使用 as 关键字把某个对象安全地转换为某个类。在编译器的层次上，is 和 as 的操作是由 System.pas 中两个函数完成的。

{ System.pas }
function _IsClass(Child: TObject; Parent: TClass): Boolean;
begin
Result := (Child <> nil) and Child.InheritsFrom(Parent);
end;

_IsClass 很简单，它使用 TObject 的 InheritsForm 函数判断该对象是否是从某个类或它的父类中继承下来的。每个类的 VMT 中都有一项 vmtParent 指针，指向该类的父类的 VMT。TObject.InheritsFrom 实际上是通过[递归]判断父类 VMT 指针是否等于自己的 VMT 指针来判断是否是从该类继承的。

{ System.pas }
class function TObject.InheritsFrom(AClass: TClass): Boolean;
var
ClassPtr: TClass;
begin
ClassPtr := Self;
while (ClassPtr <> nil) and (ClassPtr <> AClass) do
ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^;
Result := ClassPtr = AClass;
end;

as 操作符实际上是由 System.pas 中的 _AsClass 函数完成的。它简单地调用 is 操作符判断对象是否属于某个类，如果不是就触发异常。虽然 _AsClass 返回值为 TObject 类型，但编译器会自动把返回的对象改变为 Parent 类，否则返回的对象没有办法使用 TObject 之外的方法和数据。

{ System.pas }
function _AsClass(Child: TObject; Parent: TClass): TObject;
begin
Result := Child;
if not (Child is Parent) then
Error(reInvalidCast); // loses return address
end;

===========================================================
⊙ TTypeInfo – RTTI 信息的结构
===========================================================

RTTI 信息的结构定义在 TypInfo.pas 中：

TTypeInfo = record // TTypeInfo 是 RTTI 信息的结构
Kind: TTypeKind; // RTTI 信息的数据类型
Name: ShortString; // 数据类型的名称
{TypeData: TTypeData} // RTTI 的内容
end;

TTypeInfo 就是 RTTI 信息的结构。TObject.ClassInfo 返回指向存放 class TTypeInfo 信息的指针。Kind 是枚举类型，它表示 RTTI 结构中所包含数据类型。Name 是数据类型的名称。注意，最后一个字段 TypeData 被注释掉了，这说明该处的结构内容根据不同的数据类型有所不同。

TTypeKind 枚举定义了可以使用 RTTI 信息的数据类型，它几乎包含了所有的 Delphi 数据类型，其中包括 tkClass。

TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray);

TTypeData 是个巨大的记录类型，在此不再列出，后文会根据需要列出该记录的内容。

===========================================================
⊙ 获取类(class)的属性(property)信息
===========================================================

这一段是 RTTI 中最复杂的部分，努力把本段吃透，后面的内容都是非常简单的。

下面是一个获取类的属性的例子：

procedure GetClassProperties(AClass: TClass; AStrings: TStrings);
var
PropCount, I: SmallInt;
PropList: PPropList;
PropStr: string;
begin
PropCount := GetTypeData(AClass.ClassInfo).PropCount;
GetPropList(AClass.ClassInfo, PropList);
for I := 0 to PropCount - 1 do
begin
case PropList^.PropType^.Kind of
tkClass : PropStr := '[Class] ';
tkMethod : PropStr := '[Method]';
tkSet : PropStr := '[Set] ';
tkEnumeration: PropStr := '[Enum] ';
else
PropStr := '[Field] ';
end;
PropStr := PropStr + PropList^.Name;
PropStr := PropStr + ': ' + PropList^.PropType^.Name;
AStrings.Add(PropStr);
end;
FreeMem(PropList);
end;

你可以在表单上放置一个 TListBox ，然后执行以下语句观察执行结果：

GetClassProperties(TForm1, ListBox1.Items);

该函数先使用 GetTypeData 函数获得类的属性数量。GetTypeData 是 TypInfo.pas 中的一个函数，它的功能是返回 TTypeInfo 的 TypeData 数据的指针：

{ TypInfo.pas }
function GetTypeData(TypeInfo: PTypeInfo): PTypeData; assembler;

class 的 TTypeData 结构如下：

TTypeData = packed record
case TTypeKind of
tkClass: (
ClassType: TClass; // 类 (VMTptr)
ParentInfo: PPTypeInfo; // 父类的 RTTI 指针
PropCount: SmallInt; // 属性数量
UnitName: ShortStringBase; // 单元的名称
{PropData: TPropData}); // 属性的详细信息
end;

其中的 PropData 又是一个大小可变的字段。TPropData 的定义如下：

TPropData = packed record
PropCount: Word; // 属性数量
PropList: record end; // 占位符，真正的意义在下一行
{PropList: array[1..PropCount] of TPropInfo}
end;

每个属性信息在内存中的结构就是 TPropInfo，它的定义如下：

PPropInfo = ^TPropInfo;
TPropInfo = packed record
PropType: PPTypeInfo; // 属性类型信息指针的指针
GetProc: Pointer; // 属性的 Get 方法指针
SetProc: Pointer; // 属性的 Set 方法指针
StoredProc: Pointer; // 属性的 StoredProc 指针
Index: Integer; // 属性的 Index 值
Default: Longint; // 属性的 Default 值
NameIndex: SmallInt; // 属性的名称索引(以 0 开始计数)
Name: ShortString; // 属性的名称
end;

为了方便访问属性信息，TypInfo.pas 中还定义了指向 TPropInfo 数组的指针：

PPropList = ^TPropList;
TPropList = array[0..16379] of PPropInfo;

我们可以使用 GetPropList 获得所有属性信息的指针数组，数组用完以后要记得用 FreeMem 把数组的内存清除。

{ TypInfo.pas }
function GetPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer;

GetPropList 传入类的 TTypeInfo 指针和 TPropList 的指针，它为 PropList 分配一块内存后把该内存填充为指向 TPropInfo 的指针数组，最后返回属性的数量。

上面的例子演示了如何获得类的所有属性信息，也可以根据属性的名称单独获得属性信息：

{ TypInfo.pas }
function GetPropInfo(TypeInfo: PTypeInfo; const PropName: string): PPropInfo;

GetPropInfo 根据类的 RTTI 指针和属性的名称字符串，返回属性的信息 TPropInfo 的指针。如果没有找到该属性，则返回 nil。GetPropInfo 很容易使用，举个例子：

ShowMessage(GetPropInfo(TForm, 'Name')^.PropType^.Name);

这句调用显示了 TForm 类的 Name 属性的类型名称：TComponentName。

===========================================================
⊙ 获取方法(method)的类型信息
===========================================================

所谓方法就是以 of object 关键字声明的函数指针，下面的函数可以显示一个方法的类型信息：

procedure GetMethodTypeInfo(ATypeInfo: PTypeInfo; AStrings: TStrings);
type
PParamData = ^TParamData;
TParamData = record // 函数参数的数据结构
Flags: TParamFlags; // 参数传递规则
ParamName: ShortString; // 参数的名称
TypeName: ShortString; // 参数的类型名称
end;
function GetParamFlagsName(AParamFlags: TParamFlags): string;
var
I: Integer;
begin
Result := '';
for I := Integer(pfVar) to Integer(pfOut) do begin
if I = Integer(pfAddress) then Continue;
if TParamFlag(I) in AParamFlags then
Result := Result + ' ' + GetEnumName(TypeInfo(TParamFlag), I);
end;
end;
var
MethodTypeData: PTypeData;
ParamData: PParamData;
TypeStr: PShortString;
I: Integer;
begin
MethodTypeData := GetTypeData(ATypeInfo);
AStrings.Add('---------------------------------');
AStrings.Add('Method Name: ' + ATypeInfo^.Name);
AStrings.Add('Method Kind: ' + GetEnumName(TypeInfo(TMethodKind),
Integer(MethodTypeData^.MethodKind)));
AStrings.Add('Params Count: '+ IntToStr(MethodTypeData^.ParamCount));
AStrings.Add('Params List:');
ParamData := PParamData(@MethodTypeData^.ParamList);
for I := 1 to MethodTypeData^.ParamCount do
begin
TypeStr := Pointer(Integer(@ParamData^.ParamName) +
Length(ParamData^.ParamName) + 1);
AStrings.Add(Format(' [%s] %s: %s',[GetParamFlagsName(ParamData^.Flags),
ParamData^.ParamName, TypeStr^]));
ParamData := PParamData(Integer(ParamData) + SizeOf(TParamFlags) +
Length(ParamData^.ParamName) + Length(TypeStr^) + 2);
end;
if MethodTypeData^.MethodKind = mkFunction then
AStrings.Add('Result Value: ' + PShortString(ParamData)^);
end;

作为实验，在表单上放置一个 TListBox，然后执行以下代码，观察执行结果：

type
TMyMethod = function(A: array of Char; var B: TObject): Integer of object;
procedure TForm1.FormCreate(Sender: TObject);
begin
GetMethodTypeInfo(TypeInfo(TMyMethod), ListBox1.Items);
GetMethodTypeInfo(TypeInfo(TMouseEvent), ListBox1.Items);
GetMethodTypeInfo(TypeInfo(TKeyPressEvent), ListBox1.Items);
GetMethodTypeInfo(TypeInfo(TMouseWheelEvent), ListBox1.Items);
end;

由于获取方法的类型信息比较复杂，我尽量压缩代码也还是有这么长，让我们看看它的实现原理。GetMethodTypeInfo 的第一个参数是 PTypeInfo 类型，表示方法的类型信息地址。第二个参数是一个字符串列表，可以使用任何实现 TStrings 操作的对象。我们可以使用 System.pas 中的 TypeInfo 函数获得任何类型的 RTTI 信息指针。TypeInfo 函数像 SizeOf 一样，是内置于编译器中的。

GetMethodTypeInfo 还用到了 TypInfo.pas 中的 GetEnumName 函数。这个函数通过枚举类型的整数值得到枚举类型的名称。

function GetEnumName(TypeInfo: PTypeInfo; Value: Integer): string;

与获取类(class)的属性信息类似，方法的类型信息也在 TTypeData 结构中

TTypeData = packed record
case TTypeKind of
tkMethod: (
MethodKind: TMethodKind; // 方法指针的类型
ParamCount: Byte; // 参数数量
ParamList: array[0..1023] of Char // 参数详细信息，见下行注释
{ParamList: array[1..ParamCount] of
record
Flags: TParamFlags; // 参数传递规则
ParamName: ShortString; // 参数的名称
TypeName: ShortString; // 参数的类型
end;
ResultType: ShortString}); // 返回值的名称
end;

TMethodKind 是方法的类型，定义如下：

TMethodKind = (mkProcedure, mkFunction, mkConstructor, mkDestructor,
mkClassProcedure, mkClassFunction,
{ Obsolete }
mkSafeProcedure, mkSafeFunction);

TParamsFlags 是参数传递的规则，定义如下：

TParamFlag = (pfVar, pfConst, pfArray, pfAddress, pfReference, pfOut);
TParamFlags = set of TParamFlag;

由于 ParamName 和 TypeName 是变长字符串，不能直接取用该字段的值，而应该使用指针步进的方法，取出参数信息，所以上面的代码显得比较长。

===========================================================
⊙ 获取有序类型(ordinal)、集合(set)类型的 RTTI 信息
===========================================================

讨论完了属性和方法的 RTTI 信息之后再来看其它数据类型的 RTTI 就简单多了。所有获取 RTTI 的原理都是通过 GetTypeData 函数得到 TTypeData 的指针，再通过 TTypeInfo.TypeKind 来解析 TTypeData。任何数据类型的 TTypeInfo 指针可以通过 TypeInfo 函数获得。

有序类型的 TTypeData 定义如下：

TTypeData = packed record
tkInteger, tkChar, tkEnumeration, tkSet, tkWChar: (
OrdType: TOrdType; // 有序数值类型
case TTypeKind of
case TTypeKind of
tkInteger, tkChar, tkEnumeration, tkWChar: (
MinValue: Longint; // 类型的最小值
MaxValue: Longint; // 类型的最大值
case TTypeKind of
tkInteger, tkChar, tkWChar: ();
tkEnumeration: (
BaseType: PPTypeInfo; // 指针的指针，它指向枚举的 PTypeInfo
NameList: ShortStringBase; // 枚举的名称字符串(不能直接取用)
EnumUnitName: ShortStringBase)); // 所在的单元名称(不能直接取用)
tkSet: (
CompType: PPTypeInfo)); // 指向集合基类 RTTI 指针的指针
end;

下面是一个获取有序类型和集合类型的 RTTI 信息的函数：

procedure GetOrdTypeInfo(ATypeInfo: PTypeInfo; AStrings: TStrings);
var
OrdTypeData: PTypeData;
I: Integer;
begin
OrdTypeData := GetTypeData(ATypeInfo);
AStrings.Add('------------------------------------');
AStrings.Add('Type Name: ' + ATypeInfo^.Name);
AStrings.Add('Type Kind: ' + GetEnumName(TypeInfo(TTypeKind),
Integer(ATypeInfo^.Kind)));
AStrings.Add('Data Type: ' + GetEnumName(TypeInfo(TOrdType),
Integer(OrdTypeData^.OrdType)));
if ATypeInfo^.Kind <> tkSet then begin
AStrings.Add('Min Value: ' + IntToStr(OrdTypeData^.MinValue));
AStrings.Add('Max Value: ' + IntToStr(OrdTypeData^.MaxValue));
end;
if ATypeInfo^.Kind = tkSet then
GetOrdTypeInfo(OrdTypeData^.CompType^, AStrings);
if ATypeInfo^.Kind = tkEnumeration then
for I := OrdTypeData^.MinValue to OrdTypeData^.MaxValue do
AStrings.Add(Format(' Value %d: %s', [I, GetEnumName(ATypeInfo, I)]));
end;

在表单上放置一个 TListBox，运行以下代码查看结果：

type TMyEnum = (EnumA, EnumB, EnumC);
procedure TForm1.FormCreate(Sender: TObject);
begin
GetOrdTypeInfo(TypeInfo(Char), ListBox1.Items);
GetOrdTypeInfo(TypeInfo(Integer), ListBox1.Items);
GetOrdTypeInfo(TypeInfo(TFormBorderStyle), ListBox1.Items);
GetOrdTypeInfo(TypeInfo(TBorderIcons), ListBox1.Items);
GetOrdTypeInfo(TypeInfo(TMyEnum), ListBox1.Items);
end;

(如果枚举元素没有按缺省的 0 基准定义，那么将不能产生 RTTI 信息，为什么？)

===========================================================
⊙ 获取其它数据类型的 RTTI 信息
===========================================================

上面讨论了几个典型的 RTTI 信息的运行，其它的数据类型的 RTTI 信息的获取方法与上面类似。由于这些操作更加简单，就不一一讨论。下面概述其它类型的 RTTI 信息的情况：

LongString、WideString 和 Variant 没有 RTTI 信息；
ShortString 只有 MaxLength 信息；
浮点数类型只有 FloatType: TFloatType 信息；
TFloatType = (ftSingle, ftDouble, ftExtended, ftComp, ftCurr);
Int64 只有最大值和最小值信息(也是 64 位整数表示)；
Interface 和动态数组不太熟悉，就不作介绍了。

===========================================================
⊙ 结束
===========================================================

Delphi中的容器类
作者 陈省
  从Delphi 5开始VCL中增加了一个新的Contnrs单元，单元中定义了８个新的类，全部都是基于标准的TList 类。
 

   TList 类
    TList 类实际上就是一个可以存储指针的容器类，提供了一系列的方法和属性来添加，删除，重排，定位，存取和排序容器中的类，它是基于数组的机制来实现的容器，比较类似于C++中的Vector和Java中的ArrayList，TList 经常用来保存一组对象列表，基于数组实现的机制使得用下标存取容器中的对象非常快，但是随着容器中的对象的增多，插入和删除对象速度会直线下降，因此不适合频繁添加和删除对象的应用场景。下面是TList类的属性和方法说明：

    属性描述
      Count: Integer; //返回列表中的项目数
      Items[Index: Integer]: Pointer; default 通过以０为底的索引下标直接存取列表中的项目
    方法类型描述
      Add(Item: Pointer): Integer;//函数用来向列表中添加指针
      Clear;//过程清空列表中的项目
      Delete(Index: Integer);//过程删除列表中对应索引的项目
      IndexOf(Item: Pointer): Integer;//函数返回指针在列表中的索引
      Insert(Index: Integer; Item: Pointer);//过程将一个项目插入到列表中的指定位置
      Remove(Item: Pointer): Integer;//函数从列表中删除指针
   名称类型描述
      property Capacity: Integer;//可以用来获取或设定列表可以容纳的指针数目
      function Extract(Item: Pointer): Pointer;//Extract 类似于Remove 可以将指针从列表中删除，不同的是返回被删除的指针。　 
      procedure Exchange(Index1, Index2: Integer); //交换列表中两个指针

      function First: Pointer;;//返回链表中的第一个指针
      function Last: Pointer;// 返回链表中最后一个指针
      function Move(CurIndex NewIndex: Integer);// 将指针从当前位置移动到新的位置

      procedure Pack;// 从列表中删除所有nil指针
      procedure  Sort(Compare: TListSortCompare);//用来对链表中的项目进行排序，可以设定Compare参数为用户定制的排序函数 

  TObjectList 类
    TObjectList 类直接从TList 类继承，可以作为对象的容器。TObjectList类定义如下：  
       TObjectList = class(TList) 
         ...
    public
     constructor Create; overload;
     constructor Create(AOwnsObjects: Boolean); overload;
     function Add(AObject: TObject): Integer; 
     function Remove(AObject: TObject): Integer; 
     function IndexOf(AObject: TObject): Integer; 
     function FindInstanceOf(AClass: TClass; AExact: Boolean = True; AStartAt: Integer = 0):Integer; 
     procedure Insert(Index: Integer; AObject: TObject); 
     property OwnsObjects: Boolean; 
     property Items[Index: Integer]: TObject; default;
 end;

不同于TList类，TObjectList类的Add, Remove, IndexOf, Insert等方法都需要传递TObject对象作为参数，由于有了编译期的强类型检查，使得TObjectList比TList更适合保存对象。此外TObjectList对象有OwnsObjects属性。当设定为True (默认值)，同TList类不同，TObjectList对象将销毁任何从列表中删除的对象。无论是调用Delete, Remove, Clear 方法，还是释放TObjectList对象，都将销毁列表中的对象。有了TObjectList类，我们就再也不用使用循环来释放了对象。这就避免了释放链表对象时，由于忘记释放链表中的对象而导致的内存泄漏。 另外要注意的是OwnsObjects属性不会影响到Extract方法，TObjectList的Extract方法行为类似于TList，只是从列表中移除对象引用，而不会销毁对象。

  

TObjectList 对象还提供了一个FindInstanceOf 函数，可以返回只有指定对象类型的对象实例在列表中的索引。如果AExact 参数为True，只有指定对象类型的对象实例会被定位，如果AExact 对象为False，AClass 的子类实例也将被定位。AStartAt 参数可以用来找到列表中的多个实例，只要每次调用FindInstanceOf 函数时，将起始索引加１，就可以定位到下一个对象，直到FindInstanceOf 返回-1。下面是代码示意：

  

var

    idx: Integer;

begin

    idx := -1;

     repeat

      idx := ObjList.FindInstanceOf(TMyObject, True, idx+1);

       if idx >= 0 then

        ...

     until(idx < 0);

end;

  

TComponentList 类

Contnrs单元中还定义了TComponentList 类，类定义如下：



TComponentList = class(TObjectList)

    ...

public

     function Add(AComponent: TComponent): Integer;

     function Remove(AComponent: TComponent): Integer;

     function IndexOf(AComponent: TComponent): Integer;

     procedure Insert(Index: Integer; AComponent: TComponent);

     property Items[Index: Integer]: TComponent; default;

end;

注意TComponentList 是从TObjectList类继承出来的，它的Add, Remove, IndexOf, Insert和 Items 方法调用都使用TComponent 类型的参数而不再是TObject类型，因此适合作为TComponent对象的容器。TComponentList 类还有一个特殊的特性，就是如果链表中的一个组件被释放的话，它将被自动的从TComponentList 链表中删除。这是利用TComponent的FreeNotification方法可以在组件被销毁时通知链表，这样链表就可以将对象引用从链表中删除的。   

TClassList 类

Contnrs单元中还定义了TClassList类，类定义如下：



TClassList = class(TList)

protected

     function GetItems(Index: Integer): TClass;

     procedure SetItems(Index: Integer; AClass: TClass);

public

     function Add(aClass: TClass): Integer;

     function Remove(aClass: TClass): Integer;

     function IndexOf(aClass: TClass): Integer;

     procedure Insert(Index: Integer; aClass: TClass);

     property Items[Index: Integer]: TClass

       read GetItems write SetItems; default;

end;

不同于前面两个类，这个类继承于TList的类只是将Add, Remove, IndexOf, Insert和Items 调用的参数从指针换成了TClass元类类型。  

TOrderedList, TStack和TQueue 类

Contnrs单元还定义了其它三个类：TOrderedList, TStack和TQueue，类型定义如下：



TOrderedList = class(TObject)

private

    FList: TList;

protected

     procedure PushItem(AItem: Pointer); virtual; abstract;

    ...

public

     function Count: Integer;

     function AtLeast(ACount: Integer): Boolean;

     procedure Push(AItem: Pointer);

     function Pop: Pointer;

     function Peek: Pointer;

end;

  

TStack = class(TOrderedList)

protected

     procedure PushItem(AItem: Pointer); override;

end;

  

TQueue = class(TOrderedList)

protected

     procedure PushItem(AItem: Pointer); override;

end;

要注意虽然TOrderedList 并不是从TList继承的，但是它在内部的实现时，使用了TList来储存指针。另外注意TOrderedList类的PushItem 过程是一个抽象过程，所以我们无法实例化 TOrderedList 类，而应该从TOrderedList继承新的类，并实现抽象的PushItem方法。TStack 和 TQueue 正是实现了PushItem抽象方法的类， 我们可以实例化TStack 和TQueue类作为后进先出的堆栈 (LIFO)和先进先出的队列(FIFO)。下面是这两个的的方法使用说明：　

·                       Count 返回列表中的项目数。

·                       AtLeast 可以用来检查链表的大小，判断当前列表中的指针数目是否大于传递的参数值，如果为True表示列表中的项目数大于传来的参数。　

·                       对于TStack类Push 方法将指针添加到链表的最后，对于TQueue类Push 方法则将指针插入到链表的开始。

·                       Pop返回链表的末端指针，并将其从链表中删除。　

·                       Peek返回链表的末端指针，但是不将其从链表中删除。　

  

TObjectStack和TObjectQueue类

Contnrs单元中最后两个类是TObjectStack和TObjectQueue类，类的定义如下：

TObjectStack = class(TStack)

public

     procedure Push(AObject: TObject);

     function Pop: TObject;

     function Peek: TObject;

end;

  

TObjectQueue = class(TQueue)

public

     procedure Push(AObject: TObject);

     function Pop: TObject;

     function Peek: TObject;

end;

这两个类只是TStack和TQueue 类的简单扩展，在链表中保存的是TObject的对象引用，而不是简单的指针。



TIntList 类

到目前为止，我们看到的容器类中保存的都是指针或者对象引用（对象引用其实也是一种指针）。

那么我们能不能在链表中保存原生类型，如Integer，Boolean或者Double等呢。下面的我们定义的类TIntList 类就可以在链表中保存整数，这里我们利用了整数和指针都占用４个字节的存储空间，所以我们可以直接将指针映射为整数。



unit IntList;

  

interface

  

uses

    Classes;

  

type

    TIntList = class(TList)

     protected

       function GetItem(Index: Integer): Integer;

       procedure SetItem(Index: Integer;

         const Value: Integer);

     public                               

       function Add(Item: Integer): Integer;

       function Extract(Item: Integer): Integer;

       function First: Integer;

       function IndexOf(Item: Integer): Integer;

       procedure Insert(Index, Item: Integer);

       function Last: Integer;

       function Remove(Item: Integer): Integer;

       procedure Sort;

       property Items[Index: Integer]: Integer

         read GetItem write SetItem; default;

     end;

  

implementation

  

{ TIntList }

function TIntList.Add(Item: Integer): Integer;

begin

    Result := inherited Add(Pointer(Item));

end;

  

function TIntList.Extract(Item: Integer): Integer;

begin

    Result := Integer(inherited Extract(Pointer(Item)));

end;

  

function TIntList.First: Integer;

begin

    Result := Integer(inherited First);

end;

  

function TIntList.GetItem(Index: Integer): Integer;

begin

    Result := Integer(inherited Items[Index]);

end;

  

function TIntList.IndexOf(Item: Integer): Integer;

begin

    Result := inherited IndexOf(Pointer(Item));

end;

  

procedure TIntList.Insert(Index, Item: Integer);

begin

     inherited Insert(Index, Pointer(Item));

end;

  

function TIntList.Last: Integer;

begin

    Result := Integer(inherited Last);

end;

  

function TIntList.Remove(Item: Integer): Integer;

begin

    Result := inherited Remove(Pointer(Item));

end;

  

procedure TIntList.SetItem(Index: Integer;

     const Value: Integer);

begin

     inherited Items[Index] := Pointer(Value);

end;

  

function IntListCompare(Item1, Item2: Pointer): Integer;

begin

     if Integer(Item1) < Integer(Item2) then

      Result := -1

     else if Integer(Item1) > Integer(Item2) then

      Result := 1

     else

      Result := 0;

end;                         

  

procedure TIntList.Sort;

begin

     inherited Sort(IntListCompare);

end;

  

end.



扩展TList，限制类型的对象列表  

Begin Listing Two - TMyObjectList

TMyObject = class(TObject)

public

     procedure DoSomething;

end;

  

TMyObjectList = class(TObjectList)

protected

     function GetItems(Index: Integer): TMyObject;

     procedure SetItems(Index: Integer; AMyObject: TMyObject);

public

     function Add(aMyObject: TMyObject): Integer;

     procedure DoSomething;

     function Remove(aMyObject: TMyObject): Integer;

     function IndexOf(aMyObject: TMyObject): Integer;

     procedure Insert(Index: Integer; aMyObject: TMyObject);

     property Items[Index: Integer]: TMyObject

       read GetItems write SetItems; default;

end;

...

{ TMyObjectList }

function TMyObjectList.Add(AMyObject: TMyObject): Integer;

begin

    Result := inherited Add(AMyObject);

end;

  

procedure TMyObjectList.DoSomething;

var

    i: Integer;

begin

     for i := 0 to Count-1 do

      Items[i].DoSomething;

end;

  

function TMyObjectList.GetItems(Index: Integer): TMyObject;

begin

    Result := TMyObject(inherited Items[Index]);

end;

  

function TMyObjectList.IndexOf(AMyObject: TMyObject):

    Integer;

begin

    Result := inherited IndexOf(AMyObject);

end;

  

procedure TMyObjectList.Insert(Index: Integer;

    AMyObject: TMyObject);

begin

     inherited Insert(Index, AMyObject);

end;

  

function TMyObjectList.Remove(AMyObject: TMyObject):

    Integer;

begin

    Result := inherited Remove(AMyObject);

end;

  

procedure TMyObjectList.SetItems(Index: Integer;

    AMyObject: TMyObject);

begin

     inherited Items[Index] := AMyObject;

end;

End Listing Two