在 Delphi 中实现函数指针堆栈

Question

我们声明了一种可以用作进度回调的类型（例如从一个巨大的日志文件中每 10,000 行加载一次）：

// 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();

第一个返回Incompatible types，第二个返回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

您可以将回调包装在一个对象中，然后使用标准堆栈选项。通过将 that 包装在您自己的类中，您就有了一个完整的解决方案，如下所示：

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.

然后，您可以按照尝试使用 TStack 的方式使用 TCallBackStack。