Rttiを試してみるその３

文字列で指定したクラスのインスタンスを作成する例を作ってみました。
(Button3Click）
試行錯誤のうえで作成したソースなので、とりあえず動きましたが
正しいソースかどうかは、分かりません。もっと良い方法が
あれば教えて下さい。

この手の処理はActivatorクラスのある.Netのほうが簡単だと
思います。

view plainprint?

1. unit Unit1;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls, ExtCtrls,Unit2;  
8.   
9. type  
10.   TForm2 = class(TForm)  
11.     Button3: TButton;  
12.     LabeledEdit1: TLabeledEdit;  
13.     ListBox1: TListBox;  
14.     Button1: TButton;  
15.     Label1: TLabel;  
16.     procedure Button3Click(Sender: TObject);  
17.     procedure Button1Click(Sender: TObject);  
18.   private  
19.     { Private 宣言 }  
20.   protected  
21.   public  
22.     { Public 宣言 }  
23.   
24.   end;  
25.   
26. var  
27.   Form1: TForm2;  
28. implementation  
29. uses  
30.   Rtti,TypInfo;  
31.   
32. {$R *.dfm}  
33.   
34.   
35. procedure TForm2.Button1Click(Sender: TObject);  
36. var  
37.   LContext: TRttiContext;  
38.   LType: TRttiType;  
39.   LTypes:TArray<trttitype>;  
40.   
41. begin  
42.   
43.  LoadPackage('SakaPack.bpl');  
44.   
45.   { Obtain the RTTI context }  
46.   LContext := TRttiContext.Create;  
47.   
48.   { Obtain the second package (rtl140) }  
49.   LTypes := LContext.GetTypes();  
50.   
51.   { Enumerate all types in the rtl140 package }  
52.   
53.    //for LPackage in LPackages do  
54.  //begin  
55.       for LType in LTypes do  
56.       begin  
57.          ListBox1.Items.Add(LType.QualifiedName);  
58.       end;  
59.    //end;  
60.    ListBox1.Items.SaveToFile('P.Txt');  
61.   
62. end;  
63.   
64. procedure TForm2.Button3Click(Sender: TObject);  
65. var  
66.  ctx : TRttiContext;  
67.  rtm : TRttiMethod;  
68.  rst : TValue;  
69.  SakaInf : ISakaTest;  
70.    rtt : TRttiType;  
71.    Args : Array of TValue;  
72.   
73.   
74. begin  
75.   
76.    //とりあえず別パッケージで動的ロード化とする  
77.    LoadPackage('SakaPack.bpl');  
78.   
79.  ctx := TRttiContext.Create;  
80.   
81.    //文字列で型情報を探す場合は、FindTypeを使う  
82.    //完全一致なのでユニット名を含めて指定  
83.    rtt := ctx.FindType('Unit2.' + LabeledEdit1.Text);  
84.   
85.    //コンストラクタはとりあえずCreateであることが前提  
86.    rtm := rtt.GetMethod('Create');  
87.   
88.  if rtm <> nil then  
89.  begin  
90.       if rtm.IsConstructor then  
91.       begin  
92.          //1. クラスの場合は、TRttiInstanceTypeで戻ってくるのでキャスト  
93.          //2. MetaaclassTypeプロパティで実際のクラスがとれるみたい。  
94.          rst := rtm.Invoke(TRttiInstanceType(rtt).MetaclassType,Args);  
95.          if rst.IsObject Then  
96.          begin  
97.             SakaInf := TSakaTest(rst.AsObject) As ISakaTest;  
98.             Label1.Caption := SakaInf.SayMessage();  
99.          end;  
100.             //Label1.Caption := obj.ClassName;  
101.       end;  
102.    end;  
103.   
104.   
105. end;  
106.   
107. end.  
108. </trttitype>  

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls,Unit2;

type
  TForm2 = class(TForm)
    Button3: TButton;
    LabeledEdit1: TLabeledEdit;
    ListBox1: TListBox;
    Button1: TButton;
    Label1: TLabel;
    procedure Button3Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  protected
  public
    { Public 宣言 }

  end;

var
  Form1: TForm2;
implementation
uses
  Rtti,TypInfo;

{$R *.dfm}


procedure TForm2.Button1Click(Sender: TObject);
var
  LContext: TRttiContext;
  LType: TRttiType;
  LTypes:TArray;

begin

 LoadPackage('SakaPack.bpl');

  { Obtain the RTTI context }
  LContext := TRttiContext.Create;

  { Obtain the second package (rtl140) }
  LTypes := LContext.GetTypes();

  { Enumerate all types in the rtl140 package }

   //for LPackage in LPackages do
 //begin
      for LType in LTypes do
      begin
         ListBox1.Items.Add(LType.QualifiedName);
      end;
   //end;
   ListBox1.Items.SaveToFile('P.Txt');

end;

procedure TForm2.Button3Click(Sender: TObject);
var
 ctx : TRttiContext;
 rtm : TRttiMethod;
 rst : TValue;
 SakaInf : ISakaTest;
   rtt : TRttiType;
   Args : Array of TValue;


begin

   //とりあえず別パッケージで動的ロード化とする
   LoadPackage('SakaPack.bpl');

 ctx := TRttiContext.Create;

   //文字列で型情報を探す場合は、FindTypeを使う
   //完全一致なのでユニット名を含めて指定
   rtt := ctx.FindType('Unit2.' + LabeledEdit1.Text);

   //コンストラクタはとりあえずCreateであることが前提
   rtm := rtt.GetMethod('Create');

 if rtm <> nil then
 begin
      if rtm.IsConstructor then
      begin
         //1. クラスの場合は、TRttiInstanceTypeで戻ってくるのでキャスト
         //2. MetaaclassTypeプロパティで実際のクラスがとれるみたい。
         rst := rtm.Invoke(TRttiInstanceType(rtt).MetaclassType,Args);
         if rst.IsObject Then
         begin
            SakaInf := TSakaTest(rst.AsObject) As ISakaTest;
            Label1.Caption := SakaInf.SayMessage();
         end;
            //Label1.Caption := obj.ClassName;
      end;
   end;


end;

end.

でUnit2で使ったソースがこちら

view plainprint?

1. unit Unit2;  
2.   
3. interface  
4.  uses classes;  
5.   
6.    {$RTTI EXPLICIT METHODS([vcPublic])}  
7.  Type ISakaTest = interface(IInterface)  
8.   ['{FAAA20A5-E078-4E22-96C2-139E7E57CBFB}']  
9.   function SayMessage : String;  
10.  end;  
11.   
12.    {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}  
13.    Type TSakaTest = Class(TInterfacedPersistent, ISakaTest)  
14.     function SayMessage : String; virtual;  
15.    End;  
16.   
17.    {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}  
18.  Type TSakaTest1 = Class(TSakaTest)  
19.       Public  
20.        function  SayMessage : String; override;  
21.    End;  
22.   
23.    {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}  
24.  Type TSakaTest2 = Class(TSakaTest)  
25.     Public  
26.       function  SayMessage : String; override;  
27.    End;  
28.   
29. var  
30.   SakaTest : ISakaTest;  
31.   
32. implementation  
33.   
34. //uses  
35.  //Classes;  
36.   
37.   
38.   
39. { TSakaTest1 }  
40.   
41. function TSakaTest1.SayMessage: String;  
42. begin  
43.  Result := 'Hello Delphi First';  
44. end;  
45.   
46. { TSakaTest2 }  
47.   
48. function TSakaTest2.SayMessage: String;  
49. begin  
50.  Result := 'Hello Delphi Second';  
51. end;  
52.   
53. { TSakaTset }  
54.   
55. function TSakaTest.SayMessage: String;  
56. begin  
57.  Result := '';  
58. end;  
59.   
60. initialization  
61.    RegisterClass(TSakaTest);  
62.    RegisterClass(TSakaTest1);  
63.    RegisterClass(TSakaTest2);  
64.   
65. end.  

unit Unit2;

interface
 uses classes;

   {$RTTI EXPLICIT METHODS([vcPublic])}
 Type ISakaTest = interface(IInterface)
  ['{FAAA20A5-E078-4E22-96C2-139E7E57CBFB}']
  function SayMessage : String;
 end;

   {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}
   Type TSakaTest = Class(TInterfacedPersistent, ISakaTest)
    function SayMessage : String; virtual;
   End;

   {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}
 Type TSakaTest1 = Class(TSakaTest)
      Public
       function  SayMessage : String; override;
   End;

   {$RTTI EXPLICIT METHODS([vcPublished,vcPublic])}
 Type TSakaTest2 = Class(TSakaTest)
    Public
      function  SayMessage : String; override;
   End;

var
  SakaTest : ISakaTest;

implementation

//uses
 //Classes;



{ TSakaTest1 }

function TSakaTest1.SayMessage: String;
begin
 Result := 'Hello Delphi First';
end;

{ TSakaTest2 }

function TSakaTest2.SayMessage: String;
begin
 Result := 'Hello Delphi Second';
end;

{ TSakaTset }

function TSakaTest.SayMessage: String;
begin
 Result := '';
end;

initialization
   RegisterClass(TSakaTest);
   RegisterClass(TSakaTest1);
   RegisterClass(TSakaTest2);

end.