Delayed execution for Delphi

The Dispatch class is made to mimic the behavior of TW3Dispatch in the Smart Pascal RTL, which is based on WC3 DOM behavior

One of the features I really miss when using Delphi, is TW3Dispatch from Smart Mobile Studio. It makes it so easy to schedule code to execute. In Delphi you either have to call the Windows API directly, use a TTimer or spawn a thread to achieve the same. Well now there is one for Delphi as well!

Now I did make a version of this library earlier which was VCL only (using the Windows API) but lately I decided to upgrade it to use threads – and thus the library is now platform independent and FMX compatible.

Delayed execution?

Ok let’s take a practical example. Let’s say you want to display a welcome form when your application starts; or actually – a few milliseconds after the main form has appeared on screen. How would you solve that?

Most people slap a TTimer on the main form, set a suitable delay and define Active as true. Then in the OnTimer() event they just disable the timer and do their thing.

Another practical example is ordinary button clicks. For most normal tasks the ordinary OnClick event works fine. But there are times where you may want to delay execution of “something” until after the OnClick event has finished. Especially if you are doing asynchronous calls to a server (for instance).

If you are going to use TTimer for stuff like that, even if you isolate it in functions, you are going to go insane sooner rather than later.

With my library it’s a one-liner:

TQTXDispatch.Execute( procedure ()
  begin
    StartDownload();
  end, 200);

Or, if you want to run through some steps you can use a repeater:

TQTXDispatch.RepeatExecute( function (): boolean
  begin
    result := DoNextStep;
  end, 200, 64); // repeat 64 times with 200ms interval

There is also a ExecuteEx() method that returns a handle, which you can then use to cancel a pending execution with AbortExecute().

Porting code between Smart and Delphi

While I can think of 100 uses alone for the library in Delphi, my primary motivation is making it easier to port code between Delphi and Smart. And TW3Dispatch can be tricky to “slap together” or “quickly adjust” to make code compile on both platforms. So hopefully this will help!

unit qtx.utils.callback;

//#############################################################################
//
// Unit:      Windows callback mechanism
// Author:    Jon Lennart Aasenden
// Copyright: Jon Lennart Aasenden, Quartex Components
// Website:   http://www.quartexcomponents.com
//#############################################################################
//
//  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;

// Toggle this to use WinAPI only, VCL restricted (!)
{$DEFINE USE_THREADS}

type
[weak]
TQTXObjectProc = procedure of object;
TQTXRepeatFunc = function (): boolean;

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

  class function  ExecuteEx(const aCallBack:TProc; const ms: Cardinal):THandle;
  class procedure AbortExecute(const aHandle: THandle);

  class procedure RepeatExecute(const Entrypoint: TQTXRepeatFunc; const ms: cardinal; Rounds: integer);

  class function GetTickCount: Cardinal;

  (* 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

{$IFNDEF FMX}
uses Vcl.Forms;
{$ELSE}
uses Fmx.Forms;
{$ENDIF}

type

TQTXDispatchThread = class(TThread)
strict private
  FCBAnon:  TThreadProcedure;
  FCBObj:   TQTXObjectProc;
  FDelay:   integer;
  FObjCall: boolean;
  fid: integer;
protected
  procedure ObjCallback;
  procedure Execute; override;
public
  property Id: integer read FId write FId;
  constructor Create(ms: integer; Callback: TThreadProcedure); overload;
  constructor Create(ms: integer; Callback: TQTXObjectProc); overload;
end;

TThreadDictionary = class(TDictionary<integer, TQTXDispatchThread>)
public
  procedure ThreadFinished(Sender: TObject);
end;

procedure TThreadDictionary.ThreadFinished(Sender: TObject);
var
  LId: integer;
begin
  if assigned(sender) then
  begin
    if assigned(self) then
    begin
      LId := TQTXDispatchThread(sender).Id;
      self.Remove(LId);
    end;
  end;
end;

var
{$IFDEF USE_THREADS}
_LUT: TThreadDictionary;
{$ELSE}
_LUT: TDictionary<UINT, TProc>;
{$ENDIF}
_TED: integer;

function QTXProgramEnded: boolean;
begin
  result := not assigned(application);
  if not result then
  result := application.terminated;
end;

//#############################################################################
// TQTXDispatchThread
//#############################################################################

constructor TQTXDispatchThread.Create(ms: integer; Callback: TQTXObjectProc);
begin
  inherited Create(true);
  FCBObj := Callback;
  FObjCall := true;
  FDelay := ms;
end;

constructor TQTXDispatchThread.Create(ms: integer; Callback: TThreadProcedure);
begin
  inherited Create(true);
  FCBAnon := Callback;
  FObjCall := false;
  FDelay := ms;
end;

procedure TQTXDispatchThread.ObjCallback;
begin
  if not QTXProgramEnded then
  FCBObj();
end;

procedure TQTXDispatchThread.Execute;
begin

  repeat
    sleep(1);
    dec(FDelay);
    if FDelay<1 then     begin       break;     end;   until terminated;   if not terminated then   begin     try       case FObjCall of       false:         begin           try             if assigned(FCBAnon) then             TThread.Queue(nil, FCBAnon);           except             on exception do;           end;         end;       true:         begin           try             Synchronize(ObjCallback);           except             on exception do;           end;         end;       end;     finally       terminate;     end;   end; end; //############################################################################# // TQTXDispatch //############################################################################# class function TQTXDispatch.GetTickCount: Cardinal; begin   result := TThread.GetTickCount; end; class procedure TQTXDispatch.RepeatExecute(const Entrypoint: TQTXRepeatFunc;   const ms: cardinal; Rounds: integer); begin   if assigned(Entrypoint) then   begin     if (ms >0) and (Rounds >0) then
    begin
      if not QTXProgramEnded then
      begin
        Execute(procedure ()
        begin
          if Entrypoint() then
          begin
            RepeatExecute(Entrypoint, ms, Rounds -1);
          end;
        end, ms);
      end;
    end;
  end;
end;

class procedure TQTXDispatch.Execute(const aCallback: TProc; const ms: Cardinal);
  {$IFNDEF USE_THREADS}
  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;
  {$ENDIF}

{$IFDEF USE_THREADS}
var
  LThread: TQTXDispatchThread;
{$ENDIF}
begin
  if Assigned(_LUT) then
  {$IFDEF USE_THREADS}
  begin
    inc(_TED);
    LThread := TQTXDispatchThread.Create(ms,TThreadProcedure(aCallback));
    LThread.FreeOnTerminate := true;
    LThread.Id := _TED;
    LThread.OnTerminate := _LUT.ThreadFinished;
    _LUT.Add(_TED, LThread);
    LThread.Start;
  end;
  {$ELSE}
  _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback);
  {$ENDIF}
end;

class function TQTXDispatch.ExecuteEx(const aCallBack: TProc;
  const ms: Cardinal): THandle;

 {$IFNDEF USE_THREADS}
  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;
  {$ENDIF}

{$IFDEF USE_THREADS}
var
  LThread: TQTXDispatchThread;
{$ENDIF}
begin
  result := 0;
  if Assigned(_LUT) then
  begin
    {$IFDEF USE_THREADS}
    inc(_TED);
    result := _TED;

    LThread := TQTXDispatchThread.Create(ms, TThreadProcedure(aCallback));
    LThread.FreeOnTerminate := true;
    LThread.Id := result;
    LThread.OnTerminate := _LUT.ThreadFinished;
    _LUT.Add(result, LThread);
    LThread.Start;
    {$ELSE}
    result := SetTimer(0,0,ms,@w3_invoke);
    _LUT.Add(result,aCallback);
    {$ENDIF}
  end;
end;

class procedure TQTXDispatch.AbortExecute(const aHandle: THandle);
var
  LInstance: TQTXDispatchThread;
begin
  if assigned(_LUT)
  and _LUT.ContainsKey(aHandle) then
  begin
  {$IFDEF USE_THREADS}
    if _lut.TryGetValue(aHandle, LInstance) then
    begin
      if not LInstance.Terminated then
      LInstance.Terminate;
    end;
  {$ELSE}
    _lut.Remove(aHandle);
    KillTimer(0,aHandle);
  {$ENDIF}
  end;
end;

class procedure TQTXDispatch.Execute(const aCallback: TQTXObjectProc;
  const ms: cardinal);

  {$IFNDEF USE_THREADS}
  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;
  {$ENDIF}

{$IFDEF USE_THREADS}
var
LThread: TQTXDispatchThread;
{$endif}
begin
  if Assigned(_LUT) then
  {$IFDEF USE_THREADS}
  begin
    LThread := TQTXDispatchThread.Create(ms, aCallback);
    LThread.FreeOnTerminate := true;
    LThread.OnTerminate := _LUT.ThreadFinished;
    inc(_TED);
    LThread.Id := _TED;
    _LUT.Add(LThread.Id, LThread);
    LThread.Start;
  end;
  {$ELSE}
  _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback);
  {$ENDIF}
end;

class procedure TQTXDispatch.Delay(const aCallback: TProc;
      const ms: cardinal);
var
  LThen:  DWord;
begin
  if (not QTXProgramEnded) and (ms > 0) then
  begin
    try
      LThen := self.GetTickCount + ms;

      repeat
        Sleep(1);
        if QTXProgramEnded then
        break;
      until ( self.GetTickCount >= LThen );

      if assigned(aCallback) and (not QTXProgramEnded) then
      begin
        try
          aCallback;
        except
          on exception do;
        end;
      end;
    except
      on exception do;
    end;
  end;
end;

class procedure TQTXDispatch.Delay(const aCallback: TQTXObjectProc;
      const ms:Cardinal);
var
  LThen:  DWord;
begin
  if (not QTXProgramEnded) and (ms > 0) then
  begin
    try
      LThen := self.GetTickCount + ms;
      repeat
        Sleep(1);
        if QTXProgramEnded then
        break;
      until ( self.GetTickCount >= LThen );

      if assigned(aCallback) and (not QTXProgramEnded) then
      begin
        try
          aCallback;
        except
          on exception do;
        end;
      end;
    except
      on exception do;
    end;
  end;
end;

initialization
begin
{$IFDEF USE_THREADS}
  _LUT := TThreadDictionary.Create;
{$ELSE}
  _LUT := TDictionary<UINT,TProc>.Create;
{$ENDIF}
end;

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

end.