Реализовать стек указателей на функции в Delphi

Question

Мы объявили тип, который может быть использован в качестве ходе обратного вызова (например, загрузка каждые 10000 строк из гигантского файла журнала):

// Declared in some base unit 
TProcedureCallback = procedure() of object; 

// Declared in the class that loads the events 
procedure ReadEvents(callback: TProcedureCallback); 

// Implementation of above method 
procedure TEvents.ReadEvents(callback: TProcedureCallback); 
var 
    nEvents: Integer; 
begin 
    nEvents := 0; 

    // Read some events... 
    Inc(nEvents); 
    // ...and repeat until end of log file 

    // Every 10,000 events, let the caller know (so they update 
    // something like a progress bar) 
    if ((nEvents mod 10000) = 0) then 
     callback(); 
end; 

// And the caller uses it like this 
public 
    procedure EventsLoadCallBack(); 

// Implementation of callback 
procedure TfrmLoadEvents.EventsLoadCallBack(); 
begin 
    // Update some GUI control... 
end; 

// And the events are loaded like this 
events.ReadEvents(EventsLoadCallBack); 

Это все работает очень хорошо. .. но я хотел бы расширить это до контейнера TObjectStack, чтобы мы могли реализовать функцию автоматического выхода из системы. Идея состоит в том, что по мере создания каждой формы она регистрирует обратный вызов (т. Е. Толкает его на какой-то системный стек). И когда форма уничтожается, она выталкивает обратный вызов из стека. Если происходит автоматический выход из системы, вы просто разматываете стек и возвращаете пользователя в основную форму, а затем выполняете остальную работу, связанную с автоматическим отключением.

Но я не могу заставить его работать ... когда я пытаюсь нажать на объект TProcedureCallback в стек я получаю ошибки компилятора:

// Using generic containers unit from Delphi 7 
uses 
    Contnrs; 

// Declare stack 
stackAutoLogOff: TObjectStack; 

// Initialise stack 
stackAutoLogOff := TObjectStack.Create(); 

// Attempt to use stack 
stackAutoLogOff.Push(callback); 
stackAutoLogOff.Push(TObject(callback)); 

// Clean up... 
stackstackAutoLogOff.Free(); 

1-ые возвращается Incompatible types и 2-й Invalid typecast. Каков правильный способ реализации стека указателей на функции?

Answer 1

Проблема заключается в том, что TObjectStack предполагает содержать объекты типа TObject, а ваш обратный вызов - это тип TMethod, который представляет собой запись, содержащую два указателя.

Если вы используете современную версию Delphi, простым решением является использование дженериков. Например:

TObjectProc = procedure of object; 
TMyCallbackStack = TStack<TObjectProc>; 

Без дженериков, вам нужно будет создать свой собственный класс стека для управления хранением обратных вызовов. Это достаточно простой класс для создания и, в своей основе, может выглядеть примерно так:

program Project1; 
{$APPTYPE CONSOLE} 

uses 
    SysUtils; 
type 
    TMyClass = class 
    procedure foo; 
    end; 

    TObjProc = procedure of object; 
    TObjProcStack = class(TObject) 
    private 
     FList: array of TObjProc; 
    public 
     function Count: Integer; 
     procedure Push(AItem: TObjProc); 
     function Pop: TObjProc; inline; 
     function Peek: TObjProc; inline; 
    end; 


function TObjProcStack.Peek: TObjProc; 
begin 
    Result := FList[Length(FList)-1]; 
end; 

function TObjProcStack.Pop: TObjProc; 
begin 
    Result := Peek(); 
    SetLength(FList, Length(FList) - 1); 
end; 

procedure TObjProcStack.Push(AItem: TObjProc); 
begin 
    SetLength(FList, Length(FList) + 1); 
    FList[Length(FList)-1] := AItem; 
end; 

function TObjProcStack.Count: Integer; 
begin 
    Result := Length(FList); 
end; 


{TMyClass} 
procedure TMyClass.Foo; 
begin 
    WriteLn('foo'); 
end; 

var 
    LMyClass : TMyClass; 
    LStack : TObjProcStack; 
begin 
    LStack := TObjProcStack.Create; 
    LMyClass := TMyClass.Create; 
    try 
    LStack.Push(LMyClass.foo); 
    LStack.Pop; {executes TMyClass.Foo - outputs 'foo' to console} 
    finally 
    LStack.Free; 
    LMyClass.Free; 
    end; 
    ReadLn; 
end. 

Answer 2

Вы можете обернуть обратный вызов в объекте, а затем использовать стандартные параметры стека. По оберточной , что в своем собственном классе, у вас есть полное решение, как это:

unit UnitCallbackStack; 

interface 

uses 
    Contnrs; 

type 
    TProcedureCallback = procedure() of object; 


type 
    TMyCallbackObject = class // wrapper for callback 
    private 
    FCallBack : TProcedureCallback; 
    protected 
    public 
    constructor Create(ACallback : TProcedureCallback); reintroduce; 
    property CallBack : TProcedureCallback 
      read FCallBack; 
    end; 

type 
    TCallBackStack = class(TObjectStack) 
    private 
    public 
    function Push(ACallback: TProcedureCallback): TProcedureCallback; reintroduce; 
    function Pop: TProcedureCallback; reintroduce; 
    function Peek: TProcedureCallback; reintroduce; 

    end; 

implementation 

{ TCallBackStack } 

function TCallBackStack.Peek: TProcedureCallback; 
var 
    iObject : TMyCallbackObject; 
begin 
    iObject := inherited Peek as TMyCallbackObject; 
    if assigned(iObject) then 
    begin 
    Result := iObject.CallBack; // no delete here as reference not removed 
    end 
    else 
    begin 
    Result := nil; 
    end; 
end; 

function TCallBackStack.Pop: TProcedureCallback; 
var 
    iObject : TMyCallbackObject; 
begin 
    iObject := inherited Pop as TMyCallbackObject; 
    if assigned(iObject) then 
    begin 
    Result := iObject.CallBack; 
    iObject.Free; // popped, so no longer needed 
    end 
    else 
    begin 
    Result := nil; 
    end; 
end; 

function TCallBackStack.Push(ACallback: TProcedureCallback): TProcedureCallback; 
begin 
    inherited Push(TMyCallbackObject.Create(ACallBack)); 
end; 


{ TMyCallbackObject } 

constructor TMyCallbackObject.Create(ACallback: TProcedureCallback); 
begin 
    inherited Create; 
    fCallBack := ACallBack; 
end; 

end. 

Вы можете использовать TCallBackStack, как вы пытаетесь использовать TStack.