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.
Thanks Jon for sharing the unit. Just what I wanted to get rid of the timers.
Two quick Qs, please:
1. When you say “toggle” the $DEFINE, you mean to comment it if one wants to use the unit in Win/VCL, right?
2. Any reasons to use FreeAndNil? Free would be enough, wouldn’t?
Point is, should a thread call back just when an application is shutting down – its easier to track an access-violation on a null pointer – hence freeandnil ๐
I see what you mean about the FreeAndNil.
I guess it is safe to alter the UI using the methods above, right?
Should be synchronized yes ๐
Just be aware than line 165 is nerfed. You need to reformat it to make the code work .It took me a while to figure out why it wasn’t compiling.
thank you