Динамически назначая анонимные общие функции в паскаль

Question

У меня есть следующие иерархии классов

Я хотел бы иметь возможность динамически назначать анонимные методы, которые работают на объектах обоих типов TB и TC.

Так вот простой надуманный пример:

unit Unit1; 

interface 

uses 
    Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 
    Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls; 

type 
    TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    private 
    { Private declarations } 
    public 
    { Public declarations } 
    end; 

    TNotifyEventWrapper = class 
    private 
     FProc: TProc<TObject>; 
    public 
     constructor Create(Proc: TProc<TObject>); 
    published 
     procedure Event(Sender: TObject); 
    end; 

    IA = interface 
    procedure Foo; 
    end; 

    TA = class(TInterfacedObject) 
    procedure Foo; 
    end; 

    TB = class(TA, IA) 
    procedure Foo; 
    end; 

    TC = class(TA, IA) 
    procedure Foo; 
    end; 

    TControl = class 
    strict private 
    public 
    class var NEW : TNotifyEventWrapper; 
    class var Foo : TNotifyEvent; 
    class function GetWrapper<T:TA, IA, constructor>(D: T): TNotifyEventWrapper; 
    class procedure AssignFooHandler<T:TA, IA, constructor>; 
    end; 

var 
    Form1: TForm1; 

implementation 

{$R *.dfm} 

procedure TC.Foo; 
begin 
    ShowMessage('TC.Foo'); 
end; 

class function TControl.GetWrapper<T>(D: T): TNotifyEventWrapper; 
begin 
    Result := 
    TNotifyEventWrapper.Create 
    (
     procedure (S : TObject) 
     begin 
      T(D).Foo; 
     end 
    ); 
end; 

class procedure TControl.AssignFooHandler<T>; 
var 
    X : T; 
begin 
    X := T.Create; 
    try 
     TControl.NEW := TControl.GetWrapper<T>(X); 

     TControl.Foo := TControl.NEW.Event; 

    finally 
     FreeAndNil(X); 
    end; 
end; 

procedure TA.Foo; 
begin 
    ShowMessage('TA.Foo'); 
end; 

procedure TB.Foo; 
begin 
    ShowMessage('TB.Foo'); 
end; 

constructor TNotifyEventWrapper.Create(Proc: TProc<TObject>); 
begin 
    inherited Create; 
    FProc := Proc; 
end; 

procedure TNotifyEventWrapper.Event(Sender: TObject); 
begin 
    FProc(Sender); 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
    TControl.Foo(Sender); 
end; 

procedure TForm1.Button2Click(Sender: TObject); 
begin 
    TControl.AssignFooHandler<TC>; //TB 
end; 

end. 

Я хотел бы быть в состоянии назвать

TControl.AssignFooHandler<TC>;

И есть метод TControl.Foo(Sender); вызова TC.Foo

Также я хочу TControl.AssignFooHandler<TB>;, чтобы вызвать TControl.Foo(Sender);, ссылаясь на TB.Foo

К сожалению, когда я запускаю это, он всегда вызывает метод базового класса TA.Foo.

Я не уверен, как это обойти.

Answer 1

Ваш Generic ограничен потомками TA и IA. TA.Foo не объявлен как virtual, и T(B|C).Foo() не объявлены override. Именно поэтому TA.Foo() вызывается каждый раз. Вам нужно сделать TA.Foo() виртуальным и T(B|C).Foo переопределить его, тогда T(B/C).Foo будет вызван как ожидалось.

Кроме того, вы освободив T(A/B/C) объект, который вы передаете в TControl.GetWrapper() прежде, чем когда-либо TControl.Foo() получает возможность ссылаться на Foo() метод этого объекта. В этом конкретном примере это нормально, так как ни один из методов Foo() не получает доступ к полям любого объекта-члена, но как только вы начнете делать это в фактическом производственном коде, это может привести к сбою. Вам нужно сохранить объект T(A/B/C) живым до тех пор, пока вы не закончите с использованием объекта TNotifyEventWrapper.