当然某些东西可能在XE2之前，甚至2010之前就有了，不过因为我之前没有接触到，所以也一并在这里记录一下。
扩展属性
Delphi提供了一个TCustomAttribute类，该类可以为对象的属性、方法、成员等进行扩展描述，语法格式：[TCustomAttribute()]。
下面举一个例子：
先定一个扩展属性类TInterceptorAttribute：
View Code
1 type
2 TInterceptorAttribute = class sealed(TCustomAttribute)
3 private type
4 TInterceptInfo = class
5 private
6 FImpl: TMethodImplementation;
7 FOriginalCode: Pointer;
8 FProxyCode: Pointer;
9 FMethod: TRttiMethod;
10 public
11 constructor Create(AOriginalCode: Pointer; AMethod: TRttiMethod;
12 const ACallback: TMethodImplementationCallback);
13 destructor Destroy; override;
14 property OriginalCode: Pointer read FOriginalCode;
15 property ProxyCode: Pointer read FProxyCode;
16 property Method: TRttiMethod read FMethod;
17 end;
18
19 private
20 // 业务对象
21 FRoleObject : TBaseRole;
22 // 规则对象，Create的时候，通过构造函数的参数，自动创建。
23 FRuleComponent : TBaseRule;
24 FMehordList : TDictionary<Integer,TBaseRule>;
25 // 如果拦截的方法是针对某一个属性的Set方法，则可以通过属性来绑定。
26 FPropertyName : string;
27 // 名称为FPropertyName的属性
28 FRProperty:TRttiProperty;
29 // -------------- 以下来自TVirtualMethodInterceptor类的代码Copy ------------
30 FContext: TRttiContext;
31 FOriginalClass: TClass;
32 FProxyClass: TClass;
33 FProxyClassData: Pointer;
34 FIntercepts: TObjectList<TInterceptInfo>;
35 FImplementationCallback: TMethodImplementationCallback;
36 procedure CreateProxyClass;
37 procedure RawCallback(UserData: Pointer; const Args: TArray<TValue>;
38 out Result: TValue);
39 public
40 procedure DoBefore(Instance: TObject; Method: TRttiMethod;
41 const Args: TArray<TValue>; out DoInvoke: Boolean; out Result: TValue);virtual;
42 procedure DoAfter(Instance: TObject; Method: TRttiMethod; const Args: TArray<TValue>;
43 var Result: TValue);virtual;
44 procedure DoException(Instance: TObject; Method: TRttiMethod;
45 const Args: TArray<TValue>; out RaiseException: Boolean;
46 TheException: Exception; out Result: TValue);virtual;
47 public
48 // 构造函数，ARuleClass参数是指定处理该方法的规则对象类
49 constructor Create(ARuleClass : TClass; APropertyName : string = '');
50 destructor Destroy; override;
51 // 代理一个业务角色对象，传入一个对象，返回被拦截的对象。
52 procedure ProxyObject(ARoleObject: TObject; AMethodHashCode : integer);
53 property OriginalClass: TClass read FOriginalClass;
54 property ProxyClass: TClass read FProxyClass;
55 end;
这个类参考了XE2里面的虚方法拦截技术进行处理，可以拦截绑定的类的虚方法，进行业务规则的动态统一处理。其关键代码在CreateProxyClass和RawCallback两个方法。然后通过ProxyObject方法进行绑定。
View Code
1 procedure TInterceptorAttribute.CreateProxyClass;
2 {$POINTERMATH ON}
3 type
4 PVtable = ^Pointer;
5 {$POINTERMATH OFF}
6 var
7 t: TRttiType;
8 m: TRttiMethod;
9 maxIndex: Integer;
10 size, classOfs: Integer;
11 ii: TInterceptInfo;
12 ARuleComponent : TBaseRule;
13 begin
14 t := FContext.GetType(FOriginalClass);
15 maxIndex := -1;
16 for m in t.GetMethods do
17 begin
18 if m.DispatchKind <> dkVtable then
19 Continue;
20 if m.VirtualIndex > maxIndex then
21 maxIndex := m.VirtualIndex;
22 end;
23 // maxIndex is the index of the latest entry, but that's not the count - that's +1.
24 size := SizeOf(Pointer) * (1 + maxIndex - (vmtSelfPtr div SizeOf(Pointer)));
25 classOfs := -vmtSelfPtr;
26 FProxyClassData := AllocMem(size);
27 FProxyClass := TClass(PByte(FProxyClassData) + classOfs);
28 Move((PByte(FOriginalClass) - classOfs)^, FProxyClassData^, size);
29 PProxyClassData(FProxyClassData)^.Parent := @FOriginalClass;
30 PProxyClassData(FProxyClassData)^.SelfPtr := FProxyClass;
31
32 for m in t.GetMethods do
33 begin
34 if m.DispatchKind <> dkVtable then
35 Continue;
36 if not (m.MethodKind in [mkFunction, mkProcedure]) then
37 Continue;
38 if not m.HasExtendedInfo then
39 Continue;
40 // 过滤？？行不行？？ 貌似行 :)
41 if FMehordList.TryGetValue(m.GetHashCode, ARuleComponent) then
42 begin
43 if not Assigned(ARuleComponent) then
44 begin
45 Continue;
46 end;
47 end
48 else
49 Continue;
50 //
51 ii := TInterceptInfo.Create(PVtable(FOriginalClass)[m.VirtualIndex],
52 m, FImplementationCallback);
53 FIntercepts.Add(ii);
54 PVtable(FProxyClass)[m.VirtualIndex] := ii.ProxyCode;
55 end;
56 end;
View Code
1 procedure TInterceptorAttribute.RawCallback(UserData: Pointer;
2 const Args: TArray<TValue>; out Result: TValue);
3
4 procedure PascalShiftSelfLast;
5 var
6 receiver: array[1..SizeOf(TValue)] of Byte;
7 begin
8 Move(Args[0], receiver, SizeOf(TValue));
9 Move(Args[1], Args[0], SizeOf(TValue) * (Length(Args) - 1));
10 Move(receiver, Args[Length(Args) - 1], SizeOf(TValue));
11 end;
12
13 procedure PascalShiftSelfFirst;
14 var
15 receiver: array[1..SizeOf(TValue)] of Byte;
16 begin
17 Move(Args[Length(Args) - 1], receiver, SizeOf(TValue));
18 Move(Args[0], Args[1], SizeOf(TValue) * (Length(Args) - 1));
19 Move(receiver, Args[0], SizeOf(TValue));
20 end;
21
22 var
23 inst: TObject;
24 ii: TInterceptInfo;
25 argList: TArray<TValue>;
26 parList: TArray<TRttiParameter>;
27 i: Integer;
28 go: Boolean;
29 begin
30 ii := UserData;
31
32 inst := Args[0].AsObject;
33
34 SetLength(argList, Length(Args) - 1);
35 for i := 1 to Length(Args) - 1 do
36 argList[i - 1] := Args[i];
37 try
38 go := True;
39 DoBefore(inst, ii.Method, argList, go, Result);
40 if go then
41 begin
42 try
43 parList := ii.Method.GetParameters;
44 for i := 1 to Length(Args) - 1 do
45 begin
46 if ((pfConst in parList[i - 1].Flags) and (parList[i - 1].ParamType.TypeSize > SizeOf(Pointer)))
47 or ([pfVar, pfOut] * parList[i - 1].Flags <> []) then
48 Args[i] := argList[i - 1].GetReferenceToRawData
49 else
50 Args[i] := argList[i - 1];
51 end;
52
53 if ii.Method.CallingConvention = ccPascal then
54 PascalShiftSelfLast;
55 try
56 if ii.Method.ReturnType <> nil then
57 Result := Invoke(ii.OriginalCode, Args, ii.Method.CallingConvention, ii.Method.ReturnType.Handle)
58 else
59 Result := Invoke(ii.OriginalCode, Args, ii.Method.CallingConvention, nil);
60 finally
61 if ii.Method.CallingConvention = ccPascal then
62 PascalShiftSelfFirst;
63 end;
64 except
65 on e: Exception do
66 begin
67 DoException(inst, ii.Method, argList, go, e, Result);
68 if go then
69 raise;
70 end;
71 end;
72 DoAfter(inst, ii.Method, argList, Result);
73 end;
74 finally
75 // Set modified by-ref arguments
76 for i := 1 to Length(Args) - 1 do
77 Args[i] := argList[i - 1];
78 end;
79 end;
之所以使用TCustomAttribute这个基类，主要是就是利用TCustomAttribute的描述作用。
View Code
1 [TInterceptorAttribute(TMyTestRule, 'Age2')]
2 procedure SetAge2(const Value: integer); virtual;
3
4 [TInterceptorAttribute(TMyTestRule2, 'Age')]
5 procedure SetAge(const Value: integer); virtual;
6
7 [TInterceptorAttribute(TMyTestRule2, 'Name')]
8 procedure SetName(const Value: string); virtual;
9
10 [TInterceptorAttribute(TMyTestRule2, 'Sex')]
11 procedure SetSex(const Value: String); virtual;
12
13 [TInterceptorAttribute(TMyTestRule2, 'Activity')]
14 procedure SetActivity(const Value: Boolean); virtual;
15
16 [TInterceptorAttribute(TMyTestRule2, 'Status')]
17 procedure SetStatus(const Value: string); virtual;
18
19 [TInterceptorAttribute(TMySalaryRule, 'Salary')]
20 procedure SetSalary(Value: Currency);virtual;
21
22 [TInterceptorAttribute(TMyTestRule2, 'Profession')]
23 procedure SetProfession(const Value: integer); virtual;
24
25 [TInterceptorAttribute(TMyTestRule2, 'Profession2')]
26 procedure SetProfession2(const Value: string); virtual;
这样，就可以利用反射机制，统一处理每一个方法的业务规则处理。比如通过类工厂创建类的时候，既可以处理规则的绑定：
View Code
1 procedure TRoleObjectRactory.Registintercept(ARole: TBaseRole);
2 var
3 RType:TRTTIType;
4 RMethod:TRTTIMethod;
5 Attr:TCustomAttribute;
6 szFormName : string;
7 ABingings : TSuperArray;
8 i : Integer;
9 roleproperty : string;
10 component : string;
11 compproperty : string;
12 begin
13 RType:=TRTTIContext.Create.GetType(ARole.ClassType);
14
15 for Attr in RType.GetAttributes do
16 begin
17 if Attr is TRolePropertyDSAttribute then
18 begin
19 TRolePropertyDSAttribute(Attr).BindRole := ARole;
20 end;
21 end;
22
23 for RMethod in RType.GetMethods do
24 begin
25 if RMethod.DispatchKind<>dkVtable then
26 Continue;
27 for Attr in RMethod.GetAttributes do
28 begin
29 if Attr is TInterceptorAttribute then
30 begin
31 // 拦截业务对象ARole的虚方法RMethod。
32 TInterceptorAttribute(Attr).ProxyObject(ARole, RMethod.GetHashCode);
33 end;
34 end;
35 end;
36 end;
虚方法拦截
Delphi在RTTI单元提供了一个TVirtualMethodInterceptor类，该类可以用于对象的虚方法拦截。下面是其Public成员列表：
View Code
1 public
2 constructor Create(AClass: TClass);
3 destructor Destroy; override;
4 procedure Proxify(AInstance: TObject);
5 procedure Unproxify(AInstance: TObject);
6 property OriginalClass: TClass read FOriginalClass;
7 property ProxyClass: TClass read FProxyClass;
8 property OnBefore: TInterceptBeforeNotify read FOnBefore write FOnBefore;
9 property OnAfter: TInterceptAfterNotify read FOnAfter write FOnAfter;
10 property OnException: TInterceptExceptionNotify read FOnException write FOnException;
Create方法的参数指定要拦截的类；
Proxify方法用于开始拦截，其参数需要传入AClass的一个实例；
OnBefore、OnAfter、OnException三个事件用于处理拦截，分别对应方法执行前、执行后、执行出错的处理。下面是一段自己编写的Demo代码：
View Code
1 procedure TInterceptorAttribute.DoAfter(Instance: TObject;
2 Method: TRttiMethod; const Args: TArray<TValue>; var Result: TValue);
3 var
4 ARuleComponent : TBaseRule;
5 begin
6 if FMehordList.TryGetValue(Method.GetHashCode, ARuleComponent) then
7 begin
8 if Assigned(ARuleComponent) then
9 begin
10 if itAfter in ARuleComponent.InterceptTypes then
11 ARuleComponent.DoAfter(Instance, Method, Args, Result);
12 // 调用业务对象Role的事件分发方法进行处理，使界面与Role的数据保持一致。
13 if FRProperty <> nil then
14 FRoleObject.OnPropertyChanged(FRProperty);
15 //FRoleObject.DispatchMonitor(FRProperty);
16 end;
17 end;
18 end;
OnBefore和OnException处理方式类似。这样在被拦截的虚方法执行时，会依次执行拦截对象的DoBefore、DoAfter和DoException处理。
Helper类
Helper类可以为已存在的对象增加若干新的方法，且不会改变其继承关系和现有结构，其语法如下：
View Code
1 Txxx = class helper for T... {T... 表示已存在的类}
2 {可以替换已存在的方法}
3 {也可以有新的方法、成员}
4 end;
这之后再使用 T... 类及其子孙类时, 都会优先使用 Txxx 的修改.
文档管理工具
Delphi XE开始提供了一个代码文档描述的功能，XE中还只能通过类似XML风格的语法来描述，在XE2中已经提供了插件工具。
在这里设计好之后，在IDE环境编码的时候，使用到Bind方法时，鼠标放到Bind方法上，就会给出详细的提示信息：
