Callbacks for Delphi, updated

In-place callbacks. Not really something very popular in classical Delphi programming, but wildly efficient and handy! In fact, I use them so much in Smart Mobile Studio that I missed them in Delphi — and as such I decided to implement them.

Oh and this is the second version, with some minor alteration from a previous post I did a while back.

So, what is it?

Setup code to execute later the easy way

Right. Ever found yourself adding a TTimer to your main form because you want something to happen just after the form is shown and everything is ready? Or perhaps when a user clicks something there should be a small delay and then another thing should happen? I know I have. Especially when I want to setup something without taking to much of the OnFormShow() event. But the full onslaught of TComponent seems like overkill for such a tiny function doesnt it?

Either way, under Smart Mobile Studio I have a function initially called W3_Callback to deals with this. It simply creates a time object and keeps track of a procedure reference, and since it’s a one-liner you can use it to delay code execution and essentially allow for a breath of fresh air between calls. The method(s) takes two parameters: the first is the amount of time you want to wait, and the second a procedure you want to execute. So after calling w3_callback it starts a timer, counts down to zero, and then calls the function you provided.

Well, this unit does the same thing as it’s Smart Mobile counterpart. And it does wonders with anonymous procedures, allowing you to setup code to be executed “just after this”.

Note: This is for WinAPI only. If you port it for OS X please let me know, as I’m sure there are equivalent functions. So it shouldn’t be hard to make it portable (have a peek at TTimer under FMX perhaps?).

unit qtx.utils.callback;

//#############################################################################
//
// Unit:      Windows callback mechanism
// Author:    Jon Lennart Aasenden
// Copyright: Jon Lennart Aasenden [LTD]
// Org. Id:   913494741
//            http://w2.brreg.no/enhet/sok/detalj.jsp?orgnr=913494741
//#############################################################################
//
//  Purpose:
//    This unit provides methods for blocking delay of program execution,
//    and also a non-blocking callback function for anonymous methods.
//
//  The TQTXCallback.Delay() method is blocking, meaning that it will halt
//  program execution for the duration of the MS parameter.
//
//  The TQTXCallback.Callback() method is NON-blocking, meaning that it will
//  create a winAPI time object that, when the duration of MS is expired,
//  will execute the inline anonymous function.
//
//  NOTE: There are two overloaded versions: One for anonymous methods,
//        and another for object methods (when used within a class).
//
//  Example:
//     TQTXCallback.callback(
//        procedure (
//          begin
//            showmessage('2 seconds have gone by');
//          end,
//     2000);
//
//
//     TQTXCallback.delay(nil,4000);
//     showmessage('4 seconds have gone by');
//
//
//#############################################################################

interface

uses  System.SysUtils, System.Classes,
      Winapi.Windows, System.Generics.Collections;

type
TQTXObjectProc = procedure of Object;

TQTXCallback = Class
public
  (* Anonymous method implementation *)
  class procedure Callback(const aCallback:TProc;const ms:Cardinal);overload;
  class procedure Callback(const aCallback:TQTXObjectProc;
        const ms:Cardinal);Overload;

  class function  CallbackEx(const aCallBack:TProc;
        const ms:Cardinal):THandle;
  class procedure AbortCallback(const aHandle:THandle);

  (* Object method implementation *)
  class procedure Delay(const aCallback:TProc;const ms:Cardinal);overload;
  class Procedure Delay(const aCallback:TQTXObjectProc;
        const ms:Cardinal);overload;
end;

implementation

uses Vcl.Forms;

var
_LUT: TDictionary<UINT,TProc>;

{ TQTXCallback }

class procedure TQTXCallback.Callback(const aCallback: TProc;
      const ms: Cardinal);
  procedure w3_invoke(hwnd: HWND; uMsg: UINT;
            idEvent: UINT_PTR;dwTime: DWORD);stdcall;
  var
    mProc:  TProc;
  begin
    KillTimer(0,idEvent);
    try
      if assigned(_LUT) then
      begin
        mproc:=_lut.Items[idEvent];
        _lut.Remove(idEvent);
        if assigned(mProc) then
        mproc;
      end;
    except
      on exception do;
    end;
  end;
begin
  if Assigned(_LUT) then
  _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback);
end;

class function TQTXCallback.CallbackEx(const aCallBack: TProc;
  const ms: Cardinal): THandle;

  procedure w3_invoke(hwnd: HWND; uMsg: UINT;
            idEvent: UINT_PTR;dwTime: DWORD);stdcall;
  var
    mProc:  TProc;
  begin
    KillTimer(0,idEvent);
    try
      if assigned(_LUT) then
      begin
        mproc:=_lut.Items[idEvent];
        _lut.Remove(idEvent);
        if assigned(mProc) then
        mproc;
      end;
    except
      on exception do;
    end;
  end;

begin
  result:=0;
  if Assigned(_LUT) then
  Begin
    result:=SetTimer(0,0,ms,@w3_invoke);
    _LUT.Add(result,aCallback);
  end;
end;

class procedure TQTXCallback.AbortCallback(const aHandle: THandle);
begin
  if assigned(_LUT)
  and _LUT.ContainsKey(aHandle) then
  begin
    _lut.Remove(aHandle);
    KillTimer(0,aHandle);
  end;
end;

class procedure TQTXCallback.Callback(const aCallback: TQTXObjectProc;
  const ms: cardinal);
  procedure w3_invoke(hwnd: HWND; uMsg: UINT;
            idEvent: UINT_PTR;dwTime: DWORD);stdcall;
  var
    mProc:  TProc;
  begin
    KillTimer(0,idEvent);
    try
      if assigned(_LUT) then
      begin
        mproc:=_lut.Items[idEvent];
        _lut.Remove(idEvent);
        if assigned(mProc) then
        mproc;
      end;
    except
      on exception do;
    end;
  end;
begin
  if Assigned(_LUT) then
  _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback);
end;

class procedure TQTXCallback.Delay(const aCallback: TProc;
      const ms: cardinal);
var
  mThen:  DWord;
begin
  if assigned(application)
  and not application.Terminated
  and (ms>0) then
  Begin
    try
      mThen:=getTickCount + ms;
      repeat
        Sleep(1);
        if assigned(application)
        and application.Terminated then
        break;
      until getTickCount>=mThen;
      if assigned(aCallback)
      and Assigned(Application)
      and not (application.Terminated) then
      aCallback;
    except
      on exception do;
    end;
  end;
end;

class procedure TQTXCallback.Delay(const aCallback: TQTXObjectProc;
      const ms:Cardinal);
var
  mThen:  DWord;
begin
  if assigned(application)
  and not application.Terminated
  and (ms>0) then
  Begin
    try
      mThen:=getTickCount + ms;
      repeat
        Sleep(1);
        if assigned(application)
        and application.Terminated then
        break;
      until getTickCount>=mThen;
      if assigned(aCallback)
      and Assigned(Application)
      and not (application.Terminated) then
      aCallback;
    except
      on exception do;
    end;
  end;
end;

initialization
_LUT:=TDictionary<UINT,TProc>.Create;

finalization
if Assigned(_LUT) then
FreeAndNil(_LUT);

end.

Advertisements