TVirtualMethodInterceptorを試す。 - 全力わはー
Entropy Overload: Virtual method interception
ぐらいしか参考になる情報がありません。ということで実際に試してみましょう。
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ActnList, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; ActionList1: TActionList; Action1: TAction; Action2: TAction; Action3: TAction; procedure Action1Execute(Sender: TObject); procedure Action2Execute(Sender: TObject); procedure Action3Execute(Sender: TObject); private public end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.Action1Execute(Sender: TObject); begin MessageDlg('Action1Execute',mtInformation,[mbOk],0) end; procedure TForm1.Action2Execute(Sender: TObject); begin MessageDlg('Action2Execute',mtInformation,[mbOk],0) end; procedure TForm1.Action3Execute(Sender: TObject); begin MessageDlg('Action3Execute',mtInformation,[mbOk],0) end; end.
画面上にボタンがあり、これらのボタンにはActionが割り当てられていてOnClickではこれらのActionが呼び出される、というサンプルプログラムです。ここでボタンをクリックしたときにフォーカスを残したくない、という新たな要求があり、それぞれのActionのOnExecuteの最後に"ActiveControl := nil;"という処理をを追加したいのですが、Actionが多数だと大変です。そこでTVirtualMethodInterceptorを使ってTAction.OnExecuteの呼出後に"ActiveControl := nil;"を実行するようにしてみましょう。まずusesにRTTIユニットを追加し、FormのOnCreateイベントでTVirtualMethodInterceptorを生成してprivate部に用意した変数に格納します。
procedure TForm1.FormCreate(Sender: TObject); begin FVMI := TVirtualMethodInterceptor.Create(TAction); end; procedure TForm1.FormDestroy(Sender: TObject); begin FVMI.Free; end;
TVirtualMethodInterceptorのコンストラクタのパラメータは対象となるクラスです。次に生成したTVirtualMethodInterceptorのインスタンスのOnAfterイベントを設定します。
FVMI.OnAfter := procedure(Instance: TObject; Method: TRttiMethod; const Args: TArray<TValue>; var Result: TValue) begin if Method.Name = 'Execute' then begin ActiveControl := nil; end; end;
メソッドを実行したあとで、そのメソッドの名前が"Execute"であれば"ActiveControl := nil;"を実行する、という処理になります(OnAfterに割り当てているのは無名メソッドなので、Form1のActiveControlをキャプチャして使用することができます)。さらにそれぞれのアクション(TActionのインスタンス)をProxifyします。
for I := 0 to ComponentCount - 1 do begin if Components[I] is TAction then begin FVMI.Proxify(TAction(Components[I])); end; end;
では実行してみましょう…うまくいきませんね。Method.Nameが'Execute'になった状態でOnAfterに入ってこないようです(おまけに終了時にエラーになります)。TAction.OnExecuteはTBasicAction.Executeから呼び出されているはずです。ClassesユニットにあるTBasicAction.Executeの定義を見てみましょう。
function Execute: Boolean; dynamic;
ん?dynamicですと?ヘルプには
特定のクラス型の指定されたインスタンスに対する仮想メソッド呼び出しを ユーザーが動的にインターセプトできるようにします。とあります。そもそもTVirtualMethodInterceptorなので、動的(dynamic)メソッドはインターセプトできないのはあたりまえですね。どうしましょう…TAction.OnExecuteの呼出経路を探ってみると、TControlにはprotectedなActionLinkというプロパティがあり、割り当てられたActionはこのActionLinkのExecuteメソッド経由で呼び出されるようになっています。そしてこのTBasicActionLink.Executeはvirtualです。ということでここに介入することにします。とはいってもTControl.ActionLinkはprotectedですので、強引にclass helperでアクセスできるようにします。
type TButtonHelper = class helper for TButton public function GetActionLink: TActionLink; end; function TButtonHelper.GetActionLink: TActionLink; begin Result := Self.ActionLink; end;
これでActionLink.Executeに介入できるようになります。
procedure TForm1.FormCreate(Sender: TObject); var I: Integer; begin FVMI := TVirtualMethodInterceptor.Create(TActionLink); FVMI.OnAfter := procedure(Instance: TObject; Method: TRttiMethod; const Args: TArray<TValue>; var Result: TValue) begin if Method.Name = 'Execute' then begin ActiveControl := nil; end; end; for I := 0 to ControlCount - 1 do begin if Controls[I] is TButton then begin FVMI.Proxify(TButton(Controls[I]).GetActionLink); end; end; end;
実行してみましょう。…実行時にエラーになりますね。Proxifyで型が一致していないようです。調べてみるとTButtonのActionLinkのインスタンスの型はTActionLinkではなく派生したTPushButtonActionLinkになっています。
FVMI := TVirtualMethodInterceptor.Create(TPushButtonActionLink);
こんどはうまく動作したようです。ところで終了時は?やはりEPrivilege例外が発生してエラーになります。Talesさんが指摘していますが、インターセプト対象のインスタンスが解放されるときには仮想メソッドであるdestructor Destroyが呼び出されるわけで、この時点までTVirtualMethodInterceptorのインスタンスを解放してはいけないということになります。ここではこの問題をclass destructorで解決します。
type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; ActionList1: TActionList; Action1: TAction; Action2: TAction; Action3: TAction; procedure Action1Execute(Sender: TObject); procedure Action2Execute(Sender: TObject); procedure Action3Execute(Sender: TObject); procedure FormCreate(Sender: TObject); private class var FVMI: TVirtualMethodInterceptor; public class constructor Create; class destructor Destroy; end;
TVirtualMethodInterceptorをclass varとして、class constructorで初期化し、class destructorで解放するようにします(TForm1のOnDestroyイベントの"FVMI.Free;"を削除するのを忘れないように)。
class constructor TForm1.Create; begin FVMI := nil; end; class destructor TForm1.Destroy; begin FVMI.Free; end; procedure TForm1.FormCreate(Sender: TObject); var I: Integer; begin if FVMI = nil then begin FVMI := TVirtualMethodInterceptor.Create(TPushButtonActionLink); FVMI.OnAfter := procedure(Instance: TObject; Method: TRttiMethod; const Args: TArray<TValue>; var Result: TValue) begin if Method.Name = 'Execute' then begin ActiveControl := nil; end; end; end; for I := 0 to ControlCount - 1 do begin if Controls[I] is TButton then begin FVMI.Proxify(TButton(Controls[I]).GetActionLink); end; end; end;
これですべてうまく動作しました。終了時もエラーになりません。
TVirtualMethodInterceptorがやっていることは基本的にはtalesさんが指摘しているとおりVMTの差し替えです。従って処理に介入できるのはインスタンスの仮想(virtual)メソッドのみで、動的(dynamic)メソッドや静的メソッド、クラスメソッドは対象になりません。またProxifyしたインスタンスが全て解放されるまではTVirtualMethodInterceptorのインスタンスを解放してはいけません(デストラクタはvirtualなのでVMTを参照する)。もうひとつ気をつけなければならないのはTVirtualMethodInterceptorのコンストラクタで指定しているクラス型が実際にProxifyするクラス型と完全に一致していなければならない(代入互換性があるというのではだめ)という点です。
2012/02/29追記: TVirtualMethodInterceptor.OriginalClassプロパティを使ってVMTを書き戻すか、同じことをしてくれるUnproxify(XE2で追加)で終了時の問題をクリアすることができる、という指摘がLynaさんからありました。ということでこちらも試してみます。まずOriginalClassプロパティに格納されているもともとのVMTを書き戻す方法から。
type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; ActionList1: TActionList; Action1: TAction; Action2: TAction; Action3: TAction; procedure Action1Execute(Sender: TObject); procedure Action2Execute(Sender: TObject); procedure Action3Execute(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private FVMI: TVirtualMethodInterceptor; end;
フォームのクラスコンストラクタ/クラスデストラクタを削除し、TVirtualMethodInterceptorを通常のprivateなフィールドに戻します。またフォームのOnDestroyイベントを用意します。
procedure TForm1.FormCreate(Sender: TObject); var I: Integer; begin FVMI := TVirtualMethodInterceptor.Create(TPushButtonActionLink); FVMI.OnAfter := procedure(Instance: TObject; Method: TRttiMethod; const Args: TArray<TValue>; var Result: TValue) begin if Method.Name = 'Execute' then begin ActiveControl := nil; end; end; for I := 0 to ControlCount - 1 do begin if Controls[I] is TButton then begin FVMI.Proxify(TButton(Controls[I]).GetActionLink); end; end; end; procedure TForm1.FormDestroy(Sender: TObject); var I: Integer; begin for I := 0 to ControlCount - 1 do begin if Controls[I] is TButton then begin PPointer(TButton(Controls[I]).GetActionLink)^ := FVMI.OriginalClass; end; end; FVMI.Free; end;
フォームのOnDestroyイベントでProxifyしたVMT(OriginalClass)を元に戻しています。うまくいきましたね。
それではDelphi XE2で追加されたUnproxifyを使う方法を。
procedure TForm1.FormDestroy(Sender: TObject); var I: Integer; begin for I := 0 to ControlCount - 1 do begin if Controls[I] is TButton then begin FVMI.Unproxify(TButton(Controls[I]).GetActionLink); end; end; FVMI.Free; end;
フォームのOnDestroyイベントでUnproxifyするだけで基本的に同じです。こちらも問題なく動作しました。
2 件のコメント:
ちょっとした補足情報ですが、
PPointer(Instance)^ := FVMI.OriginalClass;
とすることで元のVMTに戻せるので、TVirtualMethodInterceptorの解放のタイミングについては任意にできます。
また、XE2ではこれと同等の働きをするUnproxifyというメソッドが追加されています。
Lynaさん、補足ありがとうございます。
週明けくらいに本文に追記する予定です。
コメントを投稿