Delphi RTTI的使用例子

Question

最近在用C#，觉得它的反射真是不错，在也不用将数据库反回的值一行行，一个属性一个属性的给对象进行赋值了。让代码看着少了很多。
Delphi 也有RTTI 一直没有用过，将大家的代码归纳了一下。给看看能不能更精减和合理一些。
uses TypInfotype
  TXRTTI=class  public
    //给定一个数据集合将值设置给对象    //得到一个对象的属性的数据类型
    class function GetObjAttTypeInfo(obj:TPersistent;const AAtt:String;var ATypeInfo:TTypeInfo):Boolean;
    //给定一个属性名和值，给对象设置
    class function SetObjValue(obj:TPersistent;const AAtt:String;AValue:Variant;ATypeInfo:TTypeInfo):Boolean;overload;
    class function SetObjValue(obj:TPersistent;const AAtt:String;AValue:Variant):Boolean;overload;
    class function SetObjValueStr(obj:TPersistent;const AAtt:String;AValue:String):Boolean;overload;
    //根据一个属性名，得到对象的值
    class function GetObjValue(obj:TPersistent;const AAtt:String):Variant;
    class function GetObjValueToStr(obj:TPersistent;const AAtt:String):String;  end;  TXDB=class
    //将数据集转换为对象列表
    class function DataSetToList(ADOQ:TADOQuery;AClass:TPersistentClass;AList:TList):Integer;
    class function DataSetToObj(ADOQ:TADOQuery;obj:TPersistent;ARow:Integer=1):Boolean;
  end;implementation{ TXDB }class function TXDB.DataSetToList(ADOQ:TADOQuery;AClass: TPersistentClass; AList: TList): Integer;
var
  obj:TPersistent;
  i,f:Integer;  PropList: PPropList;
  ClassTypeInfo: PTypeInfo;
  ClassTypeData: PTypeData;
begin
//先取对象属性信息
  ClassTypeInfo := AClass.ClassInfo;
  ClassTypeData := GetTypeData(ClassTypeInfo);
  GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
  GetPropInfos(AClass.ClassInfo, PropList);  for f:=0 to ADOQ.FieldCount-1 do
  begin
    ADOQ.Fields[f].Tag:=-1;
    for i := 0 to ClassTypeData.PropCount - 1 do
      if (PropList[i]^.PropType^.Kind <> tkMethod) then
        if SameText(ADOQ.Fields[f].FieldName,PropList[i]^.Name) then
        begin
          ADOQ.Fields[f].Tag:=i;
          Break;
        end;
  end;
//数据集合转换成对象列表
  while Not ADOQ.Eof do
  begin
    obj:=AClass.Create;
    for i:=0 to ADOQ.FieldList.Count-1 do
    begin
      if (ADOQ.Fields[i].Tag>=0)and(ADOQ.Fields[i].Value<>Null) then
        TXRTTI.SetObjValue(obj,ADOQ.Fields[i].FieldName,ADOQ.Fields[i].Value,PropList[ADOQ.Fields[i].Tag]^.PropType^^);
    end;
    AList.Add(obj);
    ADOQ.Next;
  end;  FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
  Result:=AList.Count;
end;class function TXDB.DataSetToObj(ADOQ: TADOQuery;
  obj:TPersistent;ARow:Integer=1): Boolean;
var
  i,f:Integer;  PropList: PPropList;
  ClassTypeInfo: PTypeInfo;
  ClassTypeData: PTypeData;
begin
//先取对象属性信息
  ClassTypeInfo := obj.ClassInfo;
  ClassTypeData := GetTypeData(ClassTypeInfo);
  GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
  GetPropInfos(obj.ClassInfo, PropList);  for f:=0 to ADOQ.FieldCount-1 do
  begin
    ADOQ.Fields[f].Tag:=-1;
    for i := 0 to ClassTypeData.PropCount - 1 do
      if (PropList[i]^.PropType^.Kind <> tkMethod) then
        if SameText(ADOQ.Fields[f].FieldName,PropList[i]^.Name) then
        begin
          ADOQ.Fields[f].Tag:=i;
          Break;
        end;
  end;
//数据集合转换成对象列表
  ADOQ.RecNo:=ARow;
  for i:=0 to ADOQ.FieldList.Count-1 do
  begin
    if (ADOQ.Fields[i].Tag>=0)and(ADOQ.Fields[i].Value<>Null) then
      TXRTTI.SetObjValue(obj,ADOQ.Fields[i].FieldName,ADOQ.Fields[i].Value,PropList[ADOQ.Fields[i].Tag]^.PropType^^);
  end;  FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
  Result:=True;
end;{ TXRTTI }class function TXRTTI.GetObjAttTypeInfo(obj: TPersistent;
  const AAtt: String;var ATypeInfo:TTypeInfo): Boolean;
var
  i:Integer;  PropList: PPropList;
  ClassTypeInfo: PTypeInfo;
  ClassTypeData: PTypeData;
begin
  Result:=False;
  ClassTypeInfo := obj.ClassType.ClassInfo;
  ClassTypeData := GetTypeData(ClassTypeInfo);
  GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
  GetPropInfos(obj.ClassInfo, PropList);  for i := 0 to ClassTypeData.PropCount - 1 do
    if (PropList[i]^.PropType^.Kind <> tkMethod) then
      if SameText(AAtt,PropList[i]^.Name) then
      begin
       // AAtt:=PropList[i]^.Name; 属性名不区分大小写，所以不用反正正确的属性值
        ATypeInfo:=PropList[i]^.PropType^^;
        Result:=True;
        Break;
      end;
  FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
end;class function TXRTTI.GetObjValue(obj: TPersistent;
  const AAtt: String): Variant;
var
  AKind:TTypeKind;
  ATypeInfo:TTypeInfo;
begin
//给定一个属性名称和值，给对应设置
  Result:=True;
  GetObjAttTypeInfo(obj,AAtt,ATypeInfo);  case ATypeInfo.Kind of
    tkInteger :Result:=GetInt64Prop(obj,AAtt);
    tkFloat   :Result:=GetFloatProp(obj,AAtt);
    tkInt64   :Result:=GetInt64Prop(obj,AAtt);
    tkString  :Result:=GetStrProp(obj,AAtt);
    tkLString :Result:=GetStrProp(obj,AAtt);
    tkWString :Result:=GetStrProp(obj,AAtt);
    tkVariant :Result:=GetVariantProp(obj,AAtt);
    else
      Result:=null;
  end;
end;class function TXRTTI.GetObjValueToStr(obj: TPersistent;
  const AAtt: String): String;
var
  AKind:TTypeKind;
  ATypeInfo:TTypeInfo;
begin
//给定一个属性名称和值，给对应设置
  GetObjAttTypeInfo(obj,AAtt,ATypeInfo);
  case ATypeInfo.Kind of
    tkInteger :Result:=IntToStr(GetInt64Prop(obj,AAtt));
    tkFloat   :Result:=FloatToStr(GetFloatProp(obj,AAtt));
    tkInt64   :Result:=IntToStr(GetInt64Prop(obj,AAtt));
    tkString  :Result:=GetStrProp(obj,AAtt);
    tkLString :Result:=GetStrProp(obj,AAtt);
    tkWString :Result:=GetStrProp(obj,AAtt);
    tkVariant :Result:=VarToStrDef(GetVariantProp(obj,AAtt),'');
    else
      Result:='';
  end;
end;class function TXRTTI.SetObjValue(obj: TPersistent; const AAtt: String;
  AValue: Variant):Boolean;
var
  ATypeInfo:TTypeInfo;
begin
//给定一个属性名称和值，给对应设置
  GetObjAttTypeInfo(obj,AAtt,ATypeInfo);
  Result:=SetObjValue(obj,AAtt,AValue,ATypeInfo);
end;class function TXRTTI.SetObjValue(obj: TPersistent; const AAtt: String;
  AValue: Variant; ATypeInfo: TTypeInfo): Boolean;
var
  i:Integer;
  f:Double;
  t:Int64;
begin
//给定一个属性名称和值，给对应设置
  Result:=True;
  case ATypeInfo.Kind of
    tkInteger:
      begin
        i:=AValue;
        SetInt64Prop(obj,AAtt,i);
      end;
    tkFloat  :
      begin
        f:=AValue;
        SetFloatProp(obj,AAtt,f);
      end;
    tkInt64:
      begin
        t:=AValue;
        SetInt64Prop(obj,AAtt,t);
      end;
    tkString:SetStrProp(obj,AAtt,AValue);
    tkLString:SetStrProp(obj,AAtt,AValue);
    tkWString:SetStrProp(obj,AAtt,AValue);
    tkVariant:SetVariantProp(obj,AAtt,AValue);
    else
      Result:=False;
  end;end;class function TXRTTI.SetObjValueStr(obj: TPersistent; const AAtt: String;
  AValue: String): Boolean;
var
  AKind:TTypeKind;
  i:Integer;
  f:Double;
  t:Int64;
  ATypeInfo:TTypeInfo;
begin
//给定一个属性名称和值，给对应设置
  Result:=True;
  GetObjAttTypeInfo(obj,AAtt,ATypeInfo);  case ATypeInfo.Kind of
    tkInteger:
      begin
        i:=StrToIntDef(AValue,0);
        SetInt64Prop(obj,AAtt,i);
      end;
    tkFloat  :
      begin
        f:=StrToFloatDef(AValue,0);
        SetFloatProp(obj,AAtt,f);
      end;
    tkInt64:
      begin
        t:=StrToInt64Def(AValue,0);
        SetInt64Prop(obj,AAtt,t);
      end;
    tkString:SetStrProp(obj,AAtt,AValue);
    tkLString:SetStrProp(obj,AAtt,AValue);
    tkWString:SetStrProp(obj,AAtt,AValue);
    tkVariant:SetVariantProp(obj,AAtt,AValue);
    else
      Result:=False;
  end;end;

Answer 1

不知道为啥，定义一个 TGUID 类型的属性，通过RTTI 得不到它的数据类型和属性名称

Answer 2

  TGUID = packed record
    D1: Longword;
    D2: Word;
    D3: Word;
    D4: array[0..7] of Byte;
  end;TGUID是record,不是TObject

Answer 3

SQL 2005的varchar(Max)也得不到相类的类型和属性

Answer 4

那用TGUID 定义了属性，在RTTI中总应该有个什么信息吧？？D难道不有将它写入到RTTI中吗？或用其它什么办法可以得到？

Answer 5

http://alex.ciobanu.org/?p=55
Forcing RTTI on record types

Answer 6

因为在d2010之前（手头没2009，测不了，但估计和以前版本一样）TGUID没有rtti，也就是说 TypeInfo(TGUID) 会得到一个编译期错误。现在记不清以前的研究结果了，印象中如果一个record中不包括任何由rtl管理生存期的类型（如string、动态数组）时，是不会生成TypeInfo的（在编译时，如果没有TypeInfo的话，自动管理中的System._Finalize将会忽略不编译）。而没有TypeInfo的属性类型，也就没法生成rtti，因为rtti属性表中第一个就是指向该属性类型的TypeInfo的。
而d2010增强了rtti，TGUID也会生成TypeInfo，所以再用它做类型的属性就可以通过rtti获取了。这也是d2010编译出来的文件大了许多的原因

Answer 7

对,同意Seamour的
RTTI will be emitted if a record contains a “managed type” like dynamic arrays, strings, interfaces or reference to functions在高版本中好像出了strict private 语法,Seamour对这个有研究吗

Answer 8

那就将PGUID:String 这样使用了，反正数据库中保存的也是一个字符串。给这个代码提点意见啊！或有什么更好的建议？

Answer 9

那用TGUID 定义了属性，在RTTI中总应该有个什么信息吧？？D难道不有将它写入到RTTI中吗？或用其它什么办法可以得到？
-------------------------不是任何类型在published下都有类型信息的。

Answer 10

ps. Seamour请问可以给点2010对RTTI新增强部份的资料看看吗？关注中

Answer 11

Delphi  现在还有多少公司在用呢???  有没有学习的意义啦??

Answer 12

一个新的系统中 数据库交互部分用 RTTI 的技术实现，大大减少了这一部分的代码量。
简单的针对表的增，删，改功能，代码量有90%的减少。只要给定表名和表中一行数据所对应的类名就可以完成。定义了基类
TRowObjectClass=class of TRowObject;
TRowObject=class
  GUID:String; //
  ItemID:Integer;//唯一递增标识
end;TRowObjectList=class //保存TRowObject数据集
  private 
    FList:TList;end;TNodeObjectList=class(TRowObjectList)//保存TNodeObject数据集end;TNodeObject=class(TRowObject)
  PGUID:String;//上级节点的标识
  FChildList:TNodeObjectList;
end;表中都有 ItemID,GUID ,PGUID(树表中) 这几个字段TXDB.GetRowList(AClass:TRowObjectClass,ATableName:String)
begin
  //返回表中的所有数据
end;软件完成后在整理一下，搞个可用的例子出来。大家给点意见，怎么能做的更好。

Answer 13

主要是解决了表字段和类属性定义是一一对应的情况，
保存主要两种方式class function TXDB.SaveObject(ADOQ:TADOQuery;ATableName:String;obj:TRowObject):Boolean;
根据 obj.ItemID>0 则是添加 obj.ItemID=0 则是修改。
用SQLServer 数据库则在Inster 后直接返回新增加行的 ItemID
用Access 数据库则在Insert后用GUID 反查出 ItemID修改的时候用 Where ItemID=obj.ItemID 条件，保存除去 GUID 外的其它属性
如用户列表对象
TUserList=class
  function SaveUser(obj:TUserInfo):Boolean; 
end;function TUserList.SaveUser(obj:TUserInfo):Boolean; 
begin
  Result:=TXDB.SaveObject(GetADOQ,'UserList',obj);
end;
界面上数据集显示到 TVirtualStringTree 中，直接在 格式中修改时调用
function SaveObjectCell(obj:TRowObject;const Att,Value:String):Boolean; 来完成对一个属性的修改。一下步想参考 Hibermate 的方式，实现 One-To-One ,one-to-many,one-to-many 这些模式的数据的显示。
能达到不用为每个类写实现SQL就可以完成持久化保存，读取，删除的工作。其它人也有实现的，但学习别的代码的时候不如自己去实现一下用起来更顺手一些。

Answer 14

根据 obj.ItemID>0 则是添加 obj.ItemID=0 则是修改。 
----------------------
写错了。应该是
-------------------
根据 obj.ItemID>0 则是修改 obj.ItemID=0 则是添加。 

Answer 15

我觉得query.fieldbyname('fname').asstring与对象的用法obj[i].fname好像没什么差别
而且，对象里的很多属性也只是运行时临时使用的，并不希望保存的
数据库记录里的一些字段也是不希望给对象直接使用的RTTI只是给 运行时按字符串的属性名找属性 提供实现手段。
如果用数据库记录或xml、ini来保存一个对象的主要属性，也是可以 运行时按字符串的属性名找属性 的。

Answer 16

我05年也研究过类似的东东，不过后来用了python就懒得再整这个了。动态语言更方便。C#算个鸟屎。哈哈哈。

Answer 17

python？ 学习一下。54楼，你的代码和文章我收集了不少，今天终算是遇到原版真人了...