├── .gitattributes ├── demo ├── D2009 - 8 core.png ├── lib │ ├── WinMemMgr.pas │ ├── CorrectLocale.pas │ ├── CompilerOptions.inc │ ├── LibOptions.inc │ ├── StopWatch.pas │ ├── MsgBox.pas │ ├── Windows │ │ └── WinSlimLock.pas │ ├── TimeoutUtil.pas │ ├── AdditionalSymbols.inc │ ├── StdLib.pas │ └── WindowsSynchronization.pas ├── source │ ├── TaskDemo.res │ ├── TaskDemo.dpr │ ├── MainForm.dfm │ ├── TaskDemo.dproj │ ├── TaskUtils.pas │ └── MainForm.pas ├── readme.txt ├── D2009 - 24 cores - AMD Ryzen 9 3900X.png ├── D2009 - 12 cores - Intel Core i7-9850H.png └── TaskDemo.groupproj ├── LICENSE ├── source ├── LibOptions.inc ├── Windows │ └── WinSlimLock.pas ├── TimeoutUtil.pas ├── AdditionalSymbols.inc ├── StdLib.pas ├── GuiTasks.pas └── WindowsSynchronization.pas └── README.md /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /demo/D2009 - 8 core.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-Tasks/HEAD/demo/D2009 - 8 core.png -------------------------------------------------------------------------------- /demo/lib/WinMemMgr.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-Tasks/HEAD/demo/lib/WinMemMgr.pas -------------------------------------------------------------------------------- /demo/source/TaskDemo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-Tasks/HEAD/demo/source/TaskDemo.res -------------------------------------------------------------------------------- /demo/readme.txt: -------------------------------------------------------------------------------- 1 | - This is a Delphi 2009 project. 2 | - You need to adjust the unit search path for your directory structure. 3 | -------------------------------------------------------------------------------- /demo/D2009 - 24 cores - AMD Ryzen 9 3900X.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-Tasks/HEAD/demo/D2009 - 24 cores - AMD Ryzen 9 3900X.png -------------------------------------------------------------------------------- /demo/D2009 - 12 cores - Intel Core i7-9850H.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-Tasks/HEAD/demo/D2009 - 12 cores - Intel Core i7-9850H.png -------------------------------------------------------------------------------- /demo/source/TaskDemo.dpr: -------------------------------------------------------------------------------- 1 | program TaskDemo; 2 | 3 | {$include CompilerOptions.inc} 4 | 5 | uses 6 | WinMemMgr, 7 | MemTest, 8 | //VclFixPack, 9 | CorrectLocale, 10 | //StackTrace, 11 | Windows, 12 | Forms, 13 | MainForm in 'MainForm.pas' {fMainForm}, 14 | TaskUtils in 'TaskUtils.pas'; 15 | 16 | {$R *.res} 17 | 18 | // IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE = $8000: Terminal server aware 19 | // IMAGE_DLLCHARACTERISTICS_DYNAMIC_BASE = $40: Address Space Layout Randomization (ASLR) enabled 20 | // IMAGE_DLLCHARACTERISTICS_NX_COMPAT = $100: Data Execution Prevention (DEP) enabled 21 | {$SetPeOptFlags $8140} 22 | 23 | // IMAGE_FILE_LARGE_ADDRESS_AWARE: may use heap/code above 2GB 24 | {$SetPeFlags IMAGE_FILE_LARGE_ADDRESS_AWARE} 25 | 26 | begin 27 | Application.Initialize; 28 | Application.CreateForm(TfMainForm, fMainForm); 29 | Application.Run; 30 | end. 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /demo/TaskDemo.groupproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {882DB14E-71D3-449E-A72F-869726A1CE8D} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Default.Personality.12 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /demo/lib/CorrectLocale.pas: -------------------------------------------------------------------------------- 1 | unit CorrectLocale; 2 | 3 | { 4 | This unit must be listed in the uses list of the dpr file before SysUtils so that SysUtils always uses the correct 5 | value for the initialization of the NLS settings via GetThreadLocale() under Windows 7. 6 | 7 | A bug in Windows 7 can lead to conflicting values for "LocaleName" and "Locale" in 8 | HKEY_CURRENT_USER\Control Panel\International (http://blogs.msdn.com/b/michkap/archive/2010/03/19/9980203.aspx). 9 | } 10 | 11 | {$include LibOptions.inc} 12 | 13 | interface 14 | 15 | 16 | {############################################################################} 17 | implementation 18 | {############################################################################} 19 | 20 | uses Windows; 21 | 22 | initialization 23 | // The initialization of the regional variables in D6/D2009/D2011 may provide American values for Windows 7 despite 24 | // other regional settings being active: 25 | // (a) GetThreadLocale in SysUtils.InitSysLocale returns 1033 (USA), despite other regional settings. 26 | // (b) TFormatSettings.Create() contains IsValidLocale(), which strangely returns false for LOCALE_USER_DEFAULT 27 | // if SetThreadLocale() was not called beforehand. 28 | // Both calls do not have to be used at all, since the constant LOCALE_USER_DEFAULT could be used directly for LCID. 29 | 30 | Windows.SetThreadLocale(LOCALE_USER_DEFAULT); 31 | end. 32 | -------------------------------------------------------------------------------- /demo/lib/CompilerOptions.inc: -------------------------------------------------------------------------------- 1 | // 2 | // Include file for stable compiler options 3 | // 4 | // Supposed Build Configurations in each project with the respective conditional defines: 5 | // - Debug: DEBUG;MEMTEST_ACTIVE 6 | // - LibDebug: LIB_DEBUG 7 | // - Release: RELEASE;NOASSERT 8 | // 9 | 10 | {$ifdef DEBUG} 11 | {$OverflowChecks on} 12 | {$RangeChecks on} 13 | {$else} 14 | {$OverflowChecks off} 15 | {$RangeChecks off} 16 | {$endif} 17 | 18 | {$ifdef NOASSERT} 19 | {$Assertions off} 20 | {$else} 21 | {$Assertions on} 22 | {$endif} 23 | 24 | {$Align on} 25 | {$BoolEval off} 26 | {$DebugInfo on} 27 | {$ExtendedSyntax on} 28 | {$Hints on} 29 | {$IoChecks on} 30 | {$LocalSymbols on} 31 | {$LongStrings on} 32 | {$MinEnumSize 1} 33 | {$OpenStrings on} 34 | {$Optimization on} 35 | {$ReferenceInfo on} 36 | {$SafeDivide off} 37 | {$StackFrames on} 38 | {$TypedAddress on} 39 | {$TypeInfo off} 40 | {$VarStringChecks on} 41 | {$Warnings on} 42 | {$WriteableConst off} 43 | 44 | {$warn SYMBOL_PLATFORM off} 45 | {$warn UNIT_PLATFORM off} 46 | 47 | {$include AdditionalSymbols.inc} 48 | 49 | {$ifndef UNICODE} {$message error 'Unicode required'} {$endif} 50 | {$ifndef D2009} {$message error 'D2009 required'} {$endif} 51 | 52 | {$Inline on} 53 | {$MethodInfo off} 54 | {$PointerMath on} 55 | {$ScopedEnums off} 56 | {$StringChecks off} 57 | 58 | {$ifdef D2011} 59 | {$StrongLinkTypes off} // Because this directive defeats the smart linker to a large degree, it can cause inflation of the executable size. 60 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} // Extended RTTI => off => smaller EXE 61 | {$WeakLinkRTTI ON} // enables more Smart Linking => smaller EXE 62 | {$endif} 63 | -------------------------------------------------------------------------------- /demo/lib/LibOptions.inc: -------------------------------------------------------------------------------- 1 | // 2 | // Include file for stable compiler options 3 | // 4 | // Supposed Build Configurations in each project with the respective conditional defines: 5 | // - Debug: DEBUG;MEMTEST_ACTIVE 6 | // - LibDebug: LIB_DEBUG 7 | // - Release: RELEASE;NOASSERT 8 | // 9 | 10 | {$ifdef LIB_DEBUG} 11 | {$DebugInfo on} 12 | {$OverflowChecks on} 13 | {$RangeChecks on} 14 | {$else} 15 | {$DebugInfo off} 16 | {$OverflowChecks off} 17 | {$RangeChecks off} 18 | {$endif} 19 | 20 | {$ifdef NOASSERT} 21 | {$Assertions off} 22 | {$else} 23 | {$Assertions on} 24 | {$endif} 25 | 26 | {$Align on} 27 | {$BoolEval off} 28 | {$ExtendedSyntax on} 29 | {$Hints on} 30 | {$IoChecks on} 31 | {$LocalSymbols on} 32 | {$LongStrings on} 33 | {$MinEnumSize 1} 34 | {$OpenStrings on} 35 | {$Optimization on} 36 | {$ReferenceInfo on} 37 | {$SafeDivide off} 38 | {$StackFrames on} 39 | {$TypedAddress on} 40 | {$TypeInfo off} 41 | {$VarStringChecks on} 42 | {$Warnings on} 43 | {$WriteableConst off} 44 | 45 | {$warn SYMBOL_PLATFORM off} 46 | {$warn UNIT_PLATFORM off} 47 | 48 | {$include AdditionalSymbols.inc} 49 | 50 | {$ifndef UNICODE} {$message error 'Unicode required'} {$endif} 51 | {$ifndef D2009} {$message error 'D2009 required'} {$endif} 52 | 53 | {$Inline on} 54 | {$MethodInfo off} 55 | {$PointerMath on} 56 | {$ScopedEnums off} 57 | {$StringChecks off} 58 | 59 | {$ifdef D2011} 60 | {$StrongLinkTypes off} // Because this directive defeats the smart linker to a large degree, it can cause inflation of the executable size. 61 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} // Extended RTTI => off => smaller EXE 62 | {$WeakLinkRTTI ON} // enables more Smart Linking => smaller EXE 63 | {$endif} 64 | -------------------------------------------------------------------------------- /source/LibOptions.inc: -------------------------------------------------------------------------------- 1 | // 2 | // Include file for stable compiler options 3 | // 4 | // Supposed Build Configurations in each project with the respective conditional defines: 5 | // - Debug: DEBUG;MEMTEST_ACTIVE 6 | // - LibDebug: LIB_DEBUG 7 | // - Release: RELEASE;NOASSERT 8 | // 9 | 10 | {$ifdef LIB_DEBUG} 11 | {$DebugInfo on} 12 | {$OverflowChecks on} 13 | {$RangeChecks on} 14 | {$else} 15 | {$DebugInfo off} 16 | {$OverflowChecks off} 17 | {$RangeChecks off} 18 | {$endif} 19 | 20 | {$ifdef NOASSERT} 21 | {$Assertions off} 22 | {$else} 23 | {$Assertions on} 24 | {$endif} 25 | 26 | {$Align on} 27 | {$BoolEval off} 28 | {$ExtendedSyntax on} 29 | {$Hints on} 30 | {$IoChecks on} 31 | {$LocalSymbols on} 32 | {$LongStrings on} 33 | {$MinEnumSize 1} 34 | {$OpenStrings on} 35 | {$Optimization on} 36 | {$ReferenceInfo on} 37 | {$SafeDivide off} 38 | {$StackFrames on} 39 | {$TypedAddress on} 40 | {$TypeInfo off} 41 | {$VarStringChecks on} 42 | {$Warnings on} 43 | {$WriteableConst off} 44 | 45 | {$warn SYMBOL_PLATFORM off} 46 | {$warn UNIT_PLATFORM off} 47 | 48 | {$include AdditionalSymbols.inc} 49 | 50 | {$ifndef UNICODE} {$message error 'Unicode required'} {$endif} 51 | {$ifndef D2009} {$message error 'D2009 required'} {$endif} 52 | 53 | {$Inline on} 54 | {$MethodInfo off} 55 | {$PointerMath on} 56 | {$ScopedEnums off} 57 | {$StringChecks off} 58 | 59 | {$ifdef D2011} 60 | {$StrongLinkTypes off} // Because this directive defeats the smart linker to a large degree, it can cause inflation of the executable size. 61 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} // Extended RTTI => off => smaller EXE 62 | {$WeakLinkRTTI ON} // enables more Smart Linking => smaller EXE 63 | {$endif} 64 | -------------------------------------------------------------------------------- /demo/lib/StopWatch.pas: -------------------------------------------------------------------------------- 1 | unit StopWatch; 2 | 3 | { 4 | - TStopWatch: Supports accurate time measurements 5 | 6 | } 7 | 8 | {$include LibOptions.inc} 9 | 10 | interface 11 | 12 | type 13 | //============================================================================= 14 | // High resolution stopwatch (approximately 1 microsecond). 15 | //============================================================================= 16 | TStopWatch = record 17 | strict private 18 | class var 19 | FCountsPerSecond: int64; 20 | var 21 | FStartCounts: int64; 22 | public 23 | procedure Start; 24 | function ElapsedSecs: double; 25 | end; 26 | 27 | 28 | {############################################################################} 29 | implementation 30 | {############################################################################} 31 | 32 | uses Windows; 33 | 34 | 35 | { TStopWatch } 36 | 37 | //============================================================================= 38 | // Starts the measurement, by capturing the current point-in-time. 39 | //============================================================================= 40 | procedure TStopWatch.Start; 41 | begin 42 | // On systems that run Windows XP or later, the function will always succeed: 43 | if FCountsPerSecond = 0 then Windows.QueryPerformanceFrequency(FCountsPerSecond); 44 | // On systems that run Windows XP or later, the function will always succeed: 45 | Windows.QueryPerformanceCounter(FStartCounts); 46 | end; 47 | 48 | 49 | //============================================================================= 50 | // Returns the time elapsed since Start() was called. Can be called repeatly. 51 | //============================================================================= 52 | function TStopWatch.ElapsedSecs: double; 53 | var 54 | EndCounts: int64; 55 | begin 56 | Windows.QueryPerformanceCounter(EndCounts); 57 | Result := (EndCounts - FStartCounts) / FCountsPerSecond; 58 | end; 59 | 60 | end. 61 | -------------------------------------------------------------------------------- /demo/source/MainForm.dfm: -------------------------------------------------------------------------------- 1 | object fMainForm: TfMainForm 2 | Left = 458 3 | Top = 508 4 | Caption = 'GUI Task Demo' 5 | ClientHeight = 161 6 | ClientWidth = 411 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Menu = TMainMenu 14 | OldCreateOrder = False 15 | OnActivate = FormActivate 16 | OnClose = FormClose 17 | PixelsPerInch = 96 18 | TextHeight = 13 19 | object btCountPrimeNumbers: TButton 20 | Left = 16 21 | Top = 44 22 | Width = 181 23 | Height = 33 24 | Caption = 'Count Prime numbers' 25 | TabOrder = 0 26 | OnClick = btCountPrimeNumbersClick 27 | end 28 | object btOpenMsgBox: TButton 29 | Left = 216 30 | Top = 44 31 | Width = 181 32 | Height = 33 33 | Caption = 'Open MessageBox' 34 | TabOrder = 1 35 | OnClick = btOpenMsgBoxClick 36 | end 37 | object Panel1: TPanel 38 | Left = 16 39 | Top = 96 40 | Width = 377 41 | Height = 49 42 | BevelOuter = bvLowered 43 | DoubleBuffered = True 44 | ParentBackground = False 45 | ParentDoubleBuffered = False 46 | TabOrder = 2 47 | object lblPrimeResult: TLabel 48 | Left = 1 49 | Top = 1 50 | Width = 375 51 | Height = 47 52 | Align = alClient 53 | AutoSize = False 54 | Caption = 'lblPrimeResult' 55 | Color = clBtnFace 56 | ParentColor = False 57 | Transparent = False 58 | WordWrap = True 59 | ExplicitWidth = 66 60 | ExplicitHeight = 13 61 | end 62 | end 63 | object Panel2: TPanel 64 | Left = 16 65 | Top = 8 66 | Width = 137 67 | Height = 18 68 | BevelOuter = bvLowered 69 | DoubleBuffered = True 70 | ParentBackground = False 71 | ParentDoubleBuffered = False 72 | TabOrder = 3 73 | object lblRGB: TLabel 74 | Left = 1 75 | Top = 1 76 | Width = 135 77 | Height = 16 78 | Align = alClient 79 | AutoSize = False 80 | Caption = 'lblRGB' 81 | Color = clBtnFace 82 | ParentColor = False 83 | Transparent = False 84 | Layout = tlCenter 85 | ExplicitLeft = 8 86 | ExplicitTop = 8 87 | ExplicitWidth = 30 88 | ExplicitHeight = 13 89 | end 90 | end 91 | object TMainMenu: TMainMenu 92 | object TMenu: TMenuItem 93 | Caption = 'Menu' 94 | object TMemuItem: TMenuItem 95 | Caption = 'MenuItem' 96 | end 97 | end 98 | end 99 | end 100 | -------------------------------------------------------------------------------- /demo/lib/MsgBox.pas: -------------------------------------------------------------------------------- 1 | unit MsgBox; 2 | 3 | { 4 | Reduced example of a better message box wrapper (compared with TApplication.MessageBox): 5 | - Buttons are labeled according to the current UI language of the GUI thread. 6 | - The display position is centered to the current active window, not to the monitor. 7 | 8 | Notes: 9 | - Controlling the button captions in the message box is needed when your application can be switched between different 10 | languages, by the user, at runtime. Part of such switch is calling SetProcessPreferredUILanguages(), so that system 11 | message boxes (like File selection, Printer setup) are also using the language of your application's GUI. 12 | - This statement in https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-messageboxexw is not true: 13 | "If this parameter is MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL), the current language associated with the calling thread is used." 14 | You need to use the result of GetThreadUILanguage() to have the correct captions on the buttons. 15 | 16 | In this demo, this is an example of an external Windows component that uses its own modal message loop. 17 | } 18 | 19 | {$include CompilerOptions.inc} 20 | 21 | interface 22 | 23 | uses Windows; 24 | 25 | type 26 | TMsgBox = record 27 | strict private 28 | class var FHook: HHOOK; 29 | class function HookProc(Code: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; static; 30 | public 31 | class function Show(const Msg: string; Buttons: integer = MB_ICONINFORMATION or MB_OK; const Caption: string = 'Native modal message box'): integer; static; 32 | class procedure ShowInfo(const Msg: string); static; 33 | end; 34 | 35 | 36 | {############################################################################} 37 | implementation 38 | {############################################################################} 39 | 40 | uses Forms; 41 | 42 | 43 | {$if not declared(GetThreadUILanguage)} 44 | function GetThreadUILanguage: LANGID; stdcall; external Windows.kernel32 name 'GetThreadUILanguage'; 45 | {$ifend} 46 | 47 | 48 | { TMsgBox } 49 | 50 | //============================================================================= 51 | // Callback for a WH_CBT hook, to center the message box with regards to its parent window. 52 | //============================================================================= 53 | class function TMsgBox.HookProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; 54 | 55 | procedure _CenterOnParent(CreateData: PCreateStruct); inline; 56 | var 57 | ParentRect: TRect; 58 | begin 59 | if Windows.GetWindowRect(CreateData.hwndParent, ParentRect) then begin 60 | CreateData.X := ParentRect.Left + ((ParentRect.Right - ParentRect.Left) - CreateData.cx) div 2; 61 | CreateData.Y := ParentRect.Top + ((ParentRect.Bottom - ParentRect.Top) - CreateData.cy) div 2; 62 | end; 63 | end; 64 | 65 | begin 66 | // first call other hooks in the chain: 67 | Result := Windows.CallNextHookEx(0, Code, wParam, lParam); 68 | 69 | if Code = HCBT_CREATEWND then begin 70 | // deregister as soon as possible, to only handle the first window created after the hook is installed: 71 | Assert(FHook <> 0); 72 | Windows.UnhookWindowsHookEx(FHook); 73 | FHook := 0; 74 | // now center the message box: 75 | _CenterOnParent(PCBTCreateWnd(lParam).lpcs); 76 | end; 77 | end; 78 | 79 | 80 | //=================================================================================================================== 81 | // Shows using the standard Windows message box. 82 | //=================================================================================================================== 83 | class function TMsgBox.Show(const Msg: string; Buttons: integer; const Caption: string): integer; 84 | var 85 | Wnd: HWND; 86 | WindowList: Forms.TTaskWindowList; 87 | FocusState: Forms.TFocusState; 88 | begin 89 | Assert(Windows.GetCurrentThreadId = System.MainThreadID); 90 | 91 | Buttons := Buttons and (Windows.MB_TYPEMASK or Windows.MB_ICONMASK or Windows.MB_DEFMASK) or MB_TASKMODAL; 92 | 93 | if Application.UseRightToLeftReading then Buttons := Buttons or Windows.MB_RTLREADING; 94 | 95 | // Disable all other top-level windows, like TApplication.MessageBox() or TCommonDialog.TaskModalDialog(). 96 | // (Strange things: Both do not call "ReleaseCapture" and "Application.ModalStarted", as done in TCustomForm.ShowModal. 97 | // So why is ShowModal doing this?) 98 | 99 | Wnd := Application.ActiveFormHandle; 100 | WindowList := Forms.DisableTaskWindows(Wnd); 101 | FocusState := Forms.SaveFocusState; 102 | try 103 | 104 | Assert(FHook = 0); 105 | FHook := Windows.SetWindowsHookEx(WH_CBT, TMsgBox.HookProc, 0, System.MainThreadID); 106 | 107 | Result := Windows.MessageBoxEx(Wnd, PChar(Msg), PChar(Caption), Buttons, GetThreadUILanguage); 108 | 109 | // normally already done within the hook: 110 | if FHook <> 0 then begin 111 | Windows.UnhookWindowsHookEx(FHook); 112 | FHook := 0; 113 | end; 114 | 115 | finally 116 | Forms.EnableTaskWindows(WindowList); 117 | Windows.SetActiveWindow(Wnd); 118 | Forms.RestoreFocusState(FocusState); 119 | end; 120 | end; 121 | 122 | 123 | //=================================================================================================================== 124 | //=================================================================================================================== 125 | class procedure TMsgBox.ShowInfo(const Msg: string); 126 | begin 127 | TMsgBox.Show(Msg, MB_ICONINFORMATION or MB_OK); 128 | end; 129 | 130 | end. 131 | -------------------------------------------------------------------------------- /demo/source/TaskDemo.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {5A7BA398-A484-4BEB-8E37-B32E2ED434FF} 4 | 12.0 5 | TaskDemo.dpr 6 | Release 7 | DCC32 8 | 9 | 10 | true 11 | 12 | 13 | true 14 | Base 15 | true 16 | 17 | 18 | true 19 | Base 20 | true 21 | 22 | 23 | true 24 | Cfg_2 25 | true 26 | true 27 | 28 | 29 | error 30 | true 31 | error 32 | error 33 | error 34 | error 35 | error 36 | error 37 | false 38 | error 39 | error 40 | ..\lib;..\lib\Windows;$(DCC_UnitSearchPath) 41 | ..\bin 42 | 3 43 | ..\dcu 44 | ..\bin\TaskDemo.exe 45 | 46 | 47 | RELEASE;NOASSERT;$(DCC_Define) 48 | 49 | 50 | DEBUG;MEMTEST_ACTIVE;$(DCC_Define) 51 | 52 | 53 | LIB_DEBUG;$(DCC_Define) 54 | 55 | 56 | 57 | MainSource 58 | 59 | 60 |
fMainForm
61 | 62 | 63 | 64 | Base 65 | 66 | 67 | Cfg_3 68 | Cfg_2 69 | 70 | 71 | Cfg_1 72 | Base 73 | 74 | 75 | Cfg_2 76 | Base 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | Delphi.Personality.12 85 | 86 | 87 | 88 | 89 | TaskDemo.dpr 90 | 91 | 92 | False 93 | True 94 | False 95 | 96 | 97 | True 98 | False 99 | 1 100 | 0 101 | 0 102 | 0 103 | False 104 | False 105 | False 106 | False 107 | False 108 | 1031 109 | 1252 110 | 111 | 112 | 113 | 114 | 1.0.0.0 115 | 116 | 117 | 118 | 119 | 120 | 1.0.0.0 121 | 122 | 123 | 124 | Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automation Server 125 | Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server 126 | 127 | 128 | 129 | 12 130 | 131 | 132 | -------------------------------------------------------------------------------- /demo/lib/Windows/WinSlimLock.pas: -------------------------------------------------------------------------------- 1 | unit WinSlimLock; 2 | 3 | { 4 | Unit only contains definitions that could also be used by MemTest.pas. 5 | 6 | - TSlimRWLock: Structure that wraps Windows' built-in Slim Reader/Writer Lock. 7 | } 8 | 9 | 10 | {$include LibOptions.inc} 11 | 12 | {$ifdef MEMTEST_DEBUG} 13 | {$DebugInfo on} 14 | {$else} 15 | {$DebugInfo off} 16 | {$endif} 17 | 18 | interface 19 | 20 | uses Windows; 21 | 22 | type 23 | TConditionVariable = Windows.CONDITION_VARIABLE; 24 | 25 | // Wraps Windows' built-in Slim Reader/Writer Lock (needs Windows Vista): 26 | // An initialization is not necessary if the corresponding variable is zero-initialized. 27 | TSlimRWLock = record 28 | strict private 29 | 30 | {WinNt.h + WinBase.h} 31 | type 32 | SRWLOCK = type pointer; 33 | const 34 | SRWLOCK_INIT = SRWLOCK(nil); 35 | 36 | class procedure _AcquireSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; static; 37 | class procedure _AcquireSRWLockShared(var SRWLock: SRWLOCK); stdcall; static; 38 | class procedure _ReleaseSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; static; 39 | class procedure _ReleaseSRWLockShared(var SRWLock: SRWLOCK); stdcall; static; 40 | class function _SleepConditionVariableSRW(var ConditionVariable: TConditionVariable; var SRWLock: SRWLOCK; dwMilliseconds: DWORD; Flags: ULONG): BOOL; stdcall; static; 41 | class function _TryAcquireSRWLockExclusive(var SRWLock: SRWLOCK): BOOL; stdcall; static; 42 | class function _TryAcquireSRWLockShared(var SRWLock: SRWLOCK): BOOL; stdcall; static; 43 | 44 | var 45 | FLock: SRWLOCK; 46 | public 47 | procedure Init; inline; // not needed if zero-initialized 48 | 49 | procedure AcquireExclusive; inline; 50 | function TryAcquireExclusive: boolean; inline; 51 | procedure ReleaseExclusive; inline; 52 | 53 | procedure AcquireShared; inline; 54 | function TryAcquireShared: boolean; inline; 55 | procedure ReleaseShared; inline; 56 | 57 | function SleepConditionVariable(var ConditionVariable: TConditionVariable; Milliseconds: DWORD; Flags: ULONG): boolean; inline; 58 | 59 | class procedure WakeAllConditionVariable(var ConditionVariable: TConditionVariable); stdcall; static; 60 | class procedure WakeConditionVariable(var ConditionVariable: TConditionVariable); stdcall; static; 61 | end; 62 | 63 | 64 | {############################################################################} 65 | implementation 66 | {############################################################################} 67 | 68 | { TSlimRWLock } 69 | 70 | class procedure TSlimRWLock._AcquireSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'AcquireSRWLockExclusive'; 71 | class procedure TSlimRWLock._AcquireSRWLockShared(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'AcquireSRWLockShared'; 72 | class procedure TSlimRWLock._ReleaseSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'ReleaseSRWLockExclusive'; 73 | class procedure TSlimRWLock._ReleaseSRWLockShared(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'ReleaseSRWLockShared'; 74 | class function TSlimRWLock._SleepConditionVariableSRW(var ConditionVariable: TConditionVariable; var SRWLock: SRWLOCK; dwMilliseconds: DWORD; Flags: ULONG): BOOL; stdcall; external Windows.kernel32 name 'SleepConditionVariableSRW'; 75 | class function TSlimRWLock._TryAcquireSRWLockExclusive(var SRWLock: SRWLOCK): BOOL; stdcall; external Windows.kernel32 name 'TryAcquireSRWLockExclusive'; 76 | class function TSlimRWLock._TryAcquireSRWLockShared(var SRWLock: SRWLOCK): BOOL; stdcall; external Windows.kernel32 name 'TryAcquireSRWLockShared'; 77 | 78 | // D2009: this functions are also in Windows.pas: 79 | class procedure TSlimRWLock.WakeAllConditionVariable(var ConditionVariable: TConditionVariable); stdcall; external Windows.kernel32 name 'WakeAllConditionVariable'; 80 | class procedure TSlimRWLock.WakeConditionVariable(var ConditionVariable: TConditionVariable); stdcall; external Windows.kernel32 name 'WakeConditionVariable'; 81 | 82 | 83 | //============================================================================= 84 | //============================================================================= 85 | procedure TSlimRWLock.Init; 86 | begin 87 | FLock := SRWLOCK_INIT; 88 | end; 89 | 90 | //============================================================================= 91 | // Acquires the lock in exclusive mode: 92 | //============================================================================= 93 | procedure TSlimRWLock.AcquireExclusive; 94 | begin 95 | _AcquireSRWLockExclusive(FLock); 96 | end; 97 | 98 | //============================================================================= 99 | // Acquires the lock in shared mode: 100 | //============================================================================= 101 | procedure TSlimRWLock.AcquireShared; 102 | begin 103 | _AcquireSRWLockShared(FLock); 104 | end; 105 | 106 | //============================================================================= 107 | // Attempts to acquire the lock in exclusive mode. If the lock could be acquired, 108 | // it returns true. 109 | //============================================================================= 110 | function TSlimRWLock.TryAcquireExclusive: boolean; 111 | begin 112 | Result := _TryAcquireSRWLockExclusive(FLock); 113 | end; 114 | 115 | //============================================================================= 116 | // Attempts to acquire the lock in shared mode. If the lock could be acquired, 117 | // it returns true. 118 | //============================================================================= 119 | function TSlimRWLock.TryAcquireShared: boolean; 120 | begin 121 | Result := _TryAcquireSRWLockShared(FLock); 122 | end; 123 | 124 | //============================================================================= 125 | // Releases an lock that was opened in exclusive mode. 126 | //============================================================================= 127 | procedure TSlimRWLock.ReleaseExclusive; 128 | begin 129 | _ReleaseSRWLockExclusive(FLock); 130 | end; 131 | 132 | //============================================================================= 133 | // Releases an SRW lock that was opened in shared mode. 134 | //============================================================================= 135 | procedure TSlimRWLock.ReleaseShared; 136 | begin 137 | _ReleaseSRWLockShared(FLock); 138 | end; 139 | 140 | //============================================================================= 141 | // Sleeps on the condition variable and releases the specified lock as an atomic operation. 142 | //============================================================================= 143 | function TSlimRWLock.SleepConditionVariable(var ConditionVariable: TConditionVariable; Milliseconds: DWORD; Flags: ULONG): boolean; 144 | begin 145 | Result := _SleepConditionVariableSRW(ConditionVariable, FLock, Milliseconds, Flags); 146 | end; 147 | 148 | end. -------------------------------------------------------------------------------- /source/Windows/WinSlimLock.pas: -------------------------------------------------------------------------------- 1 | unit WinSlimLock; 2 | 3 | 4 | { 5 | Unit only contains definitions that could also be used by MemTest.pas. 6 | - TSlimRWLock: Structure that wraps Windows' built-in Slim Reader/Writer Lock. 7 | } 8 | 9 | 10 | {$include LibOptions.inc} 11 | 12 | {$ifdef MEMTEST_DEBUG} 13 | {$DebugInfo on} 14 | {$else} 15 | {$DebugInfo off} 16 | {$endif} 17 | 18 | interface 19 | 20 | uses Windows; 21 | 22 | type 23 | TConditionVariable = Windows.CONDITION_VARIABLE; 24 | 25 | // Wraps Windows' built-in Slim Reader/Writer Lock (needs Windows Vista): 26 | // An initialization is not necessary if the corresponding variable is zero-initialized. 27 | TSlimRWLock = record 28 | strict private 29 | 30 | {WinNt.h + WinBase.h} 31 | type 32 | SRWLOCK = type pointer; 33 | const 34 | SRWLOCK_INIT = SRWLOCK(nil); 35 | 36 | class procedure _AcquireSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; static; 37 | class procedure _AcquireSRWLockShared(var SRWLock: SRWLOCK); stdcall; static; 38 | class procedure _ReleaseSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; static; 39 | class procedure _ReleaseSRWLockShared(var SRWLock: SRWLOCK); stdcall; static; 40 | class function _SleepConditionVariableSRW(var ConditionVariable: TConditionVariable; var SRWLock: SRWLOCK; dwMilliseconds: DWORD; Flags: ULONG): BOOL; stdcall; static; 41 | class function _TryAcquireSRWLockExclusive(var SRWLock: SRWLOCK): BOOL; stdcall; static; 42 | class function _TryAcquireSRWLockShared(var SRWLock: SRWLOCK): BOOL; stdcall; static; 43 | 44 | var 45 | FLock: SRWLOCK; 46 | public 47 | procedure Init; inline; // not needed if zero-initialized 48 | 49 | procedure AcquireExclusive; inline; 50 | function TryAcquireExclusive: boolean; inline; 51 | procedure ReleaseExclusive; inline; 52 | 53 | procedure AcquireShared; inline; 54 | function TryAcquireShared: boolean; inline; 55 | procedure ReleaseShared; inline; 56 | 57 | function SleepConditionVariable(var ConditionVariable: TConditionVariable; Milliseconds: DWORD; Flags: ULONG): boolean; inline; 58 | 59 | class procedure WakeAllConditionVariable(var ConditionVariable: TConditionVariable); stdcall; static; 60 | class procedure WakeConditionVariable(var ConditionVariable: TConditionVariable); stdcall; static; 61 | end; 62 | 63 | 64 | {############################################################################} 65 | implementation 66 | {############################################################################} 67 | 68 | { TSlimRWLock } 69 | 70 | class procedure TSlimRWLock._AcquireSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'AcquireSRWLockExclusive'; 71 | class procedure TSlimRWLock._AcquireSRWLockShared(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'AcquireSRWLockShared'; 72 | class procedure TSlimRWLock._ReleaseSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'ReleaseSRWLockExclusive'; 73 | class procedure TSlimRWLock._ReleaseSRWLockShared(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'ReleaseSRWLockShared'; 74 | class function TSlimRWLock._SleepConditionVariableSRW(var ConditionVariable: TConditionVariable; var SRWLock: SRWLOCK; dwMilliseconds: DWORD; Flags: ULONG): BOOL; stdcall; external Windows.kernel32 name 'SleepConditionVariableSRW'; 75 | class function TSlimRWLock._TryAcquireSRWLockExclusive(var SRWLock: SRWLOCK): BOOL; stdcall; external Windows.kernel32 name 'TryAcquireSRWLockExclusive'; 76 | class function TSlimRWLock._TryAcquireSRWLockShared(var SRWLock: SRWLOCK): BOOL; stdcall; external Windows.kernel32 name 'TryAcquireSRWLockShared'; 77 | 78 | // D2009: this functions are also in Windows.pas: 79 | class procedure TSlimRWLock.WakeAllConditionVariable(var ConditionVariable: TConditionVariable); stdcall; external Windows.kernel32 name 'WakeAllConditionVariable'; 80 | class procedure TSlimRWLock.WakeConditionVariable(var ConditionVariable: TConditionVariable); stdcall; external Windows.kernel32 name 'WakeConditionVariable'; 81 | 82 | 83 | //============================================================================= 84 | //============================================================================= 85 | procedure TSlimRWLock.Init; 86 | begin 87 | FLock := SRWLOCK_INIT; 88 | end; 89 | 90 | //============================================================================= 91 | // Acquires the lock in exclusive mode: 92 | //============================================================================= 93 | procedure TSlimRWLock.AcquireExclusive; 94 | begin 95 | _AcquireSRWLockExclusive(FLock); 96 | end; 97 | 98 | //============================================================================= 99 | // Acquires the lock in shared mode: 100 | //============================================================================= 101 | procedure TSlimRWLock.AcquireShared; 102 | begin 103 | _AcquireSRWLockShared(FLock); 104 | end; 105 | 106 | //============================================================================= 107 | // Attempts to acquire the lock in exclusive mode. If the lock could be acquired, 108 | // it returns true. 109 | //============================================================================= 110 | function TSlimRWLock.TryAcquireExclusive: boolean; 111 | begin 112 | Result := _TryAcquireSRWLockExclusive(FLock); 113 | end; 114 | 115 | //============================================================================= 116 | // Attempts to acquire the lock in shared mode. If the lock could be acquired, 117 | // it returns true. 118 | //============================================================================= 119 | function TSlimRWLock.TryAcquireShared: boolean; 120 | begin 121 | Result := _TryAcquireSRWLockShared(FLock); 122 | end; 123 | 124 | //============================================================================= 125 | // Releases an lock that was opened in exclusive mode. 126 | //============================================================================= 127 | procedure TSlimRWLock.ReleaseExclusive; 128 | begin 129 | _ReleaseSRWLockExclusive(FLock); 130 | end; 131 | 132 | //============================================================================= 133 | // Releases an SRW lock that was opened in shared mode. 134 | //============================================================================= 135 | procedure TSlimRWLock.ReleaseShared; 136 | begin 137 | _ReleaseSRWLockShared(FLock); 138 | end; 139 | 140 | //============================================================================= 141 | // Sleeps on the condition variable and releases the specified lock as an atomic operation. 142 | //============================================================================= 143 | function TSlimRWLock.SleepConditionVariable(var ConditionVariable: TConditionVariable; Milliseconds: DWORD; Flags: ULONG): boolean; 144 | begin 145 | Result := _SleepConditionVariableSRW(ConditionVariable, FLock, Milliseconds, Flags); 146 | end; 147 | 148 | end. -------------------------------------------------------------------------------- /demo/source/TaskUtils.pas: -------------------------------------------------------------------------------- 1 | unit TaskUtils; 2 | 3 | {$include CompilerOptions.inc} 4 | 5 | interface 6 | 7 | uses 8 | SysUtils, 9 | TimeoutUtil, 10 | Tasks; 11 | 12 | type 13 | //=================================================================================================================== 14 | // Represents an action that eventually produces an result of some given type. 15 | //=================================================================================================================== 16 | ITask = interface(ITask) 17 | // Waits infinitely for the task to complete and than returns its result, or throws the task's exception. 18 | function Value: TResult; 19 | end; 20 | 21 | 22 | //=================================================================================================================== 23 | // Collection of methods to implement more or less useful functionality on top of threadpools and tasks. 24 | //=================================================================================================================== 25 | TParallel = record 26 | public 27 | // Uses maximum threads to execute as often as indicates. 28 | // is called with values according to the following pseudo-code: 29 | // 30 | // while LoopRuns > 0 do begin 31 | // InteratorProc(StartValue); 32 | // inc(StartValue, Increment); 33 | // dec(LoopRuns); 34 | // end; 35 | // 36 | // Returns after all IteratorProc calls have been completed. 37 | class procedure ForEachInt(StartValue, Increment: int32; LoopRuns, ParallelThreads: uint32; const CancelObj: ICancel; const IteratorProc: TProc); static; 38 | 39 | // Creates a task to execute "Func" and queues it to the default thread pool. The result (once produced) is 40 | // accessible by the ITask.Value method. 41 | class function QueueFunc(const Func: TFunc): ITask; overload; static; 42 | 43 | // Creates a task to execute "Func(Arg)" and queues it to the default thread pool. The result (once produced) is 44 | // accessible by the ITask.Value method. 45 | class function QueueFunc(const Func: TFunc; Arg: T): ITask; overload; static; 46 | 47 | strict private 48 | type 49 | // Basis for generic TFuture classes with arbitrary result types: 50 | TFutureBase = class abstract (TInterfacedObject, ITask) 51 | strict protected 52 | FTask: ITask; 53 | protected 54 | // >> ITask 55 | function State: TTaskState; 56 | function CompleteWH: TWaitHandle; 57 | function UnhandledException: Exception; 58 | function CancelObj: ICancel; 59 | function Wait(ThrowOnError: boolean; TimeoutMillisecs: uint32): boolean; overload; 60 | function Wait(ThrowOnError: boolean; const Timeout: TTimeoutTime): boolean; overload; 61 | // << ITask 62 | end; 63 | 64 | // implements ITask (this code is instanciated by the compiler for each indiviual type): 65 | TFuture = class sealed (TFutureBase, ITask) 66 | strict private 67 | FResult: TResult; 68 | protected 69 | // >> ITask 70 | function Value: TResult; 71 | // << ITask 72 | public 73 | constructor Create(const Func: TFunc); 74 | end; 75 | end; 76 | 77 | 78 | {############################################################################} 79 | implementation 80 | {############################################################################} 81 | 82 | 83 | { TParallel.TFutureBase } 84 | 85 | //=================================================================================================================== 86 | //=================================================================================================================== 87 | function TParallel.TFutureBase.State: TTaskState; 88 | begin 89 | Result := FTask.State; 90 | end; 91 | function TParallel.TFutureBase.CompleteWH: TWaitHandle; 92 | begin 93 | Result := FTask.CompleteWH; 94 | end; 95 | function TParallel.TFutureBase.UnhandledException: Exception; 96 | begin 97 | Result := FTask.UnhandledException; 98 | end; 99 | function TParallel.TFutureBase.CancelObj: ICancel; 100 | begin 101 | Result := FTask.CancelObj; 102 | end; 103 | function TParallel.TFutureBase.Wait(ThrowOnError: boolean; TimeoutMillisecs: uint32): boolean; 104 | begin 105 | Result := FTask.Wait(ThrowOnError, TimeoutMillisecs); 106 | end; 107 | function TParallel.TFutureBase.Wait(ThrowOnError: boolean; const Timeout: TTimeoutTime): boolean; 108 | begin 109 | Result := FTask.Wait(ThrowOnError, Timeout); 110 | end; 111 | 112 | 113 | { TParallel.TFuture } 114 | 115 | //=================================================================================================================== 116 | // Creates a task to execute and queues it to the default thread pool. 117 | //=================================================================================================================== 118 | constructor TParallel.TFuture.Create(const Func: TFunc); 119 | begin 120 | inherited Create; 121 | 122 | FTask := TThreadPool.Run( 123 | procedure (const CancelObj: ICancel) 124 | begin 125 | FResult := Func(); 126 | end 127 | ); 128 | end; 129 | 130 | 131 | //=================================================================================================================== 132 | // Implementes ITask.Value 133 | //=================================================================================================================== 134 | function TParallel.TFuture.Value: TResult; 135 | begin 136 | FTask.Wait(true); 137 | Result := FResult; 138 | end; 139 | 140 | 141 | { TParallel } 142 | 143 | //=================================================================================================================== 144 | //=================================================================================================================== 145 | class function TParallel.QueueFunc(const Func: TFunc): ITask; 146 | begin 147 | Result := TFuture.Create( 148 | function (): TResult 149 | begin 150 | Result := Func(); 151 | end 152 | ); 153 | end; 154 | 155 | 156 | //=================================================================================================================== 157 | //=================================================================================================================== 158 | class function TParallel.QueueFunc(const Func: TFunc; Arg: T): ITask; 159 | begin 160 | Result := TFuture.Create( 161 | function (): TResult 162 | begin 163 | Result := Func(Arg); 164 | end 165 | ); 166 | end; 167 | 168 | 169 | //=================================================================================================================== 170 | //=================================================================================================================== 171 | class procedure TParallel.ForEachInt(StartValue, Increment: int32; LoopRuns, ParallelThreads: uint32; const CancelObj: ICancel; const IteratorProc: TProc); 172 | 173 | function _Capture(Value: int32): ITaskProcRef; 174 | begin 175 | Result := procedure (const CancelObj: ICancel) begin IteratorProc(Value); end; 176 | end; 177 | 178 | var 179 | Pool: TThreadPool; 180 | begin 181 | // Use a separate pool to easily wait for the completion of all tasks: 182 | Pool := TThreadPool.Create(ParallelThreads, 16 * ParallelThreads, 10000, 0); 183 | try 184 | while (LoopRuns > 0) and not CancelObj.IsCancelled do begin 185 | Pool.Queue(_Capture(StartValue), CancelObj); 186 | inc(StartValue, Increment); 187 | dec(LoopRuns); 188 | end; 189 | Pool.Wait; 190 | finally 191 | Pool.Free; 192 | end; 193 | end; 194 | 195 | end. 196 | 197 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Delphi-Tasks 2 | Small and simple: Thread Pools with Tasks 3 | 4 | I needed some better constructs than what was available in Delphi 2009, to be more productive with one of my major programs (this runs as a critical service 7x24, with hundreds of threads, but also short-living parallel activities to manage timeouts and some monitoring). 5 | I felt that I needed somthing better than Delphi's TThread class, that is, a better way of handling threads by a built-in and safe way to start tasks, wait for completion of tasks, as also to cancel a task. 6 | As for keeping the implementation as small and fast as possible, this is relying on pre-existing Windows constructs all the way (Slim RW Locks, Condition Variables, Events). 7 | 8 | ## Available objects (see Tasks.pas): 9 | 10 | * ITask: Reference to an action passed to a thread pool for asynchronous execution. 11 | 12 | * ICancel: Reference to an object that serves as an cancellation flag. 13 | 14 | * TThreadPool: Implements a configurable thread pool and provides a default thread pool. You can create any number of thread pools. 15 | 16 | * TGuiThread: Allows any thread to inject calls into the GUI thread. 17 | 18 | 19 | ## Implementation concept: 20 | 21 | The heart of each thread pool is a thread-safe queue for task objects. The application adds tasks to the queue. Threads are created automatically to drain the queue. Idle threads terminate after a configurable timeout. There are parameters to control the three main aspects of this model: 22 | - Maximum number of threads allowd to be started by the specific thread pool 23 | - Maximum idle time per thread 24 | - Maximum number of tasks waiting to be served 25 | 26 | To enable non-GUI threads to delegate calls to the GUI thread, a Windows messaage hook is used. This has the advantage that the processing is not blocked by non-Delphi modal message loops, neither by the standard Windows message box nor by moving or resizing a window. 27 | 28 | There is *no* heuristic to "tune" the thread pool(s): It is up to the application to perform "correct" threading for its use-case. If your tasks are CPU-bound, then put them all in a specfic thread pool, sized to run only as much threads in parallel as desired. If your tasks are I/O-bound (like print spooling or network communication, for example), just use the default thread pool. 29 | 30 | Also note that Windows only schedules threads within a single, static group of CPU cores, assigned to the process at process startup. (https://docs.microsoft.com/en-us/windows/win32/procthread/processor-groups) 31 | 32 | ## Notes: 33 | 34 | ### Shutdown behavior 35 | 36 | When TThreadPool.Destroy is invoked, the teardown is done as follows: 37 | 38 | First, the thread pool is immediately locked against queuing of new tasks. This is crucial because tasks already 39 | executing within the pool might attempt to enqueue follow-up tasks. While TThreadPool.Queue() calls will still 40 | succeed, any task created is immediately terminated with the status TTaskStatus.Discarded. 41 | 42 | Second, Destroy() waits —without timeout— for all tasks associated with the thread pool to finish. This includes 43 | both queued and currently executing tasks. Importantly, it does not cancel any tasks; it simply blocks until all are done. 44 | 45 | Third, as there are now no outstanding tasks and no active threads, the actual destruction is executed. 46 | 47 | Important Considerations: 48 | 49 | The application must ensure that all outstanding tasks will complete in a timely manner. Typically, this involves 50 | sending cancellation signals and designing the task functions to respond to them appropriately. 51 | 52 | Shared variables holding a TThreadPool reference must not be set to nil too soon. As noted above, tasks may rely on such a 53 | shared variable to enqueue additional work to the same thread pool. In such case, FreeAndNil() cannot be used because it sets 54 | the variable to nil *before* calling Destroy(), potentially breaking the tasks that still depend on it. 55 | 56 | (In general, instead of FreaAndNil you should use an alternative procedure which first calls destroy and then set the variable 57 | to nil, as this is also more correct in other scenarios.) 58 | 59 | ### Unit finalization 60 | 61 | As always with methods that are used as callbacks (in this case: as task methods), you have to pay attention to the details of unit finalization in Delphi. 62 | For example, if you have a task that is performing a method from Unit B, and then code in the finalization section of Unit A is stopping that task, it is very possible 63 | that the finalization of unit B was carried out before the task reacts to the cancellation and finally ends. 64 | 65 | If this task assigns values to managed global variables (or "class variables") in unit B, these values (most commonly: strings) may never be cleaned up, 66 | since the cleanup of B's global variables is part of the unit finalization, which may have already been completed. 67 | Such errors lead to mysterious memory leaks. 68 | 69 | ### Thread-Safety: General considerations 70 | 71 | The main concept to write thread-safe code is "ownership": In general, accessing variables or accessing properties or calling methods of Delphi objects not owned by the current thread is not safe (when not explicitly documented otherwise). 72 | 73 | At all times, you must make sure that a thread (a) only interacts with data (variables, objects, ...) that this thread is owning exclusively; or (b) uses serialization to access data shared between multiple threads. This serialization must be done by using explicit locks, like critical sections or reader-writer locks. 74 | Of course, there is no need for serialization when the variable is guaranteed to be stable at all times other threads may read it. 75 | 76 | Reads and writes of variables with a size greater than 32 bit in a 32 bit process (respective 64 bit in a 64 bit process) are not atomic and therefore need also locks. (Otherwise, a mix of the old and the new bytes may be read if the value is written by another thread at the very same time.) 77 | 78 | Shared access to variables of reference-counted Delphi types (strings, interfaces, dynamic arrays) must be serialized with locks, even thought the ref-counting itself *is* thread-safe and multiple threads can safely use references to the very same string, interfaced object or dynamic array. This also applies to variables of type Variant/OleVariant, as such a variable can contain ref-counted values, or even custom Variant types. 79 | 80 | ### Thread-Safety: Delphi RTL 81 | 82 | Many stand-alone functions and procedures in the Delphi Runtime Library are thread-safe, as they do not access global variables. But as this not described in the documentation, it is always better to check the RTL source code to verify this assumption. 83 | 84 | Some functions do read global variables, but it depends on the application, if this is a problem or not. For example, SysUtils.Format() without the explicit FormatSettings parameter uses the global variable SysUtils.FormatSettings. If the global regional settings never change, or if changes of this settings are not influencing the background processing, then this is not a problem. But to play it safe, the best aproach in this example is to always pass an explicit TFormatSettings variable with the expected content to functions that accept such argument. 85 | 86 | ### Thread-Safety: Delphi VCL 87 | 88 | As the VCL is not thread-safe, tasks must not access VCL components directly, not even properties or methods of the global variables Application, Screen, Clipboard or Printer. 89 | 90 | All reads and writes of VCL properties, as also calls of VCL methods must be done inside a procedure that is passed to TGuiThread.Perform(). Perform() then posts a special message to the GUI thread and waits for its processing. When the GUI thread some time later retrieves this message from its message queue, it will execute the procedure passed to Perform(). After the GUI thread has finished executing the procedure (normally or per exception), it wakes up the task waiting inside Perform(). This mechanism enables tasks to safely interact with all the VCL objects and therefore to update the GUI. 91 | 92 | ### Interaction of tasks with the GUI 93 | 94 | Please read: Code vs. UI modality: https://devblogs.microsoft.com/oldnewthing/tag/modality (especially part 2 & 4) 95 | 96 | When TGuiThread.Perform() is called to execute an action on the GUI thread, that action could display modal dialogs. A (code) modal dialog naturally executes a message loop that is supposed to terminate when the dialog is closed. Such a message loop allows all kinds of window messages to be dispatched, including messages for the modal dialog's parent window or for other non-modal dialogs that the appliation may display. 97 | 98 | To avoid reentrancy problems, a modal dialog must disable *all* other dialogs. Otherwise the application might run code for already destroyed GUI objects (see the explanation in the Old New Thing posts). 99 | 100 | However, this must *always* be taken into account when displaying a modal dialog, not just in the context of tasks. 101 | 102 | ## Open issues: 103 | 104 | Some sensible demo code. 105 | 106 | ## Tested with: 107 | 108 | - Delphi 2009 109 | - Delphi XE 110 | - Delphi 10.1.2 Berlin: 32bit and 64bit 111 | - Delphi 12.1 Athens: 32bit and 64bit 112 | -------------------------------------------------------------------------------- /demo/lib/TimeoutUtil.pas: -------------------------------------------------------------------------------- 1 | unit TimeoutUtil; 2 | 3 | { 4 | Types for efficient handling of timeouts. 5 | 6 | - TTimeoutTime: Represents the expiration time of a timeout. 7 | } 8 | 9 | 10 | {$include LibOptions.inc} 11 | 12 | interface 13 | 14 | type 15 | //=================================================================================================================== 16 | // Represents the expiration time of a timeout. This is *not* a timespan, but a absolute point in time! 17 | // Time spent in sleep or hibernation counts towards the timeout. 18 | // 19 | // This is a very thin wrapper around the API function GetTickCount64, which provides the number of milliseconds 20 | // since the last Windows system start, regardless of time changes, time zone changes and daylight saving time 21 | // switches. 22 | //=================================================================================================================== 23 | TTimeoutTime = record 24 | strict private 25 | const 26 | FInfinite = uint64(High(int64)); // not cause overflow in the signed subtraction in RemainingMilliSecs (roughly 292m years) 27 | var 28 | FTimeoutTime: uint64; // time when the timeout expires (in terms of GetTickCount64) 29 | 30 | function RemainingMilliSecs: uint64; 31 | class function ClampTo32(Value: uint64): uint32; static; {$ifdef CPU64BITS}inline;{$endif} 32 | public 33 | constructor FromMilliSecs(Value: uint32); 34 | constructor FromSecs(Value: uint32); 35 | class function Elapsed: TTimeoutTime; inline; static; 36 | class function Infinite: TTimeoutTime; inline; static; 37 | class function Undefined: TTimeoutTime; static; deprecated 'use "Infinite"'; 38 | 39 | function AsSeconds: uint32; 40 | function AsMilliSecs: uint32; 41 | function IsElapsed: boolean; 42 | function IsInfinite: boolean; {$ifdef CPU64BITS}inline;{$endif} 43 | function IsDefined: boolean; deprecated 'use "not .IsInfinite"'; 44 | end; 45 | 46 | 47 | {############################################################################} 48 | implementation 49 | {############################################################################} 50 | 51 | uses Windows; 52 | 53 | {$if not declared(GetTickCount64)} 54 | // since Vista: 55 | function GetTickCount64: uint64; stdcall; external Windows.kernel32 name 'GetTickCount64'; 56 | {$ifend} 57 | 58 | type 59 | TInt64Rec = record 60 | case byte of 61 | 0: (Value: uint64); 62 | 1: (Lo, Hi: uint32); 63 | end; 64 | 65 | 66 | { TTimeoutTime } 67 | 68 | //=================================================================================================================== 69 | // Returns a timeout is already expired. 70 | //=================================================================================================================== 71 | class function TTimeoutTime.Elapsed: TTimeoutTime; 72 | begin 73 | Result.FTimeoutTime := 0; 74 | end; 75 | 76 | 77 | //=================================================================================================================== 78 | // Returns a timeout that never expires. 79 | //=================================================================================================================== 80 | class function TTimeoutTime.Infinite: TTimeoutTime; 81 | begin 82 | Result.FTimeoutTime := FInfinite; 83 | end; 84 | 85 | 86 | //=================================================================================================================== 87 | // Obsolete. 88 | //=================================================================================================================== 89 | class function TTimeoutTime.Undefined: TTimeoutTime; 90 | begin 91 | Result := TTimeoutTime.Infinite; 92 | end; 93 | 94 | 95 | //=================================================================================================================== 96 | // Returns true if the timeout is "Infinite". 97 | //=================================================================================================================== 98 | function TTimeoutTime.IsInfinite: boolean; 99 | begin 100 | Result := FTimeoutTime = FInfinite; 101 | end; 102 | 103 | 104 | //=================================================================================================================== 105 | // Obsolete. 106 | //=================================================================================================================== 107 | function TTimeoutTime.IsDefined: boolean; 108 | begin 109 | Result := not self.IsInfinite; 110 | end; 111 | 112 | 113 | //=================================================================================================================== 114 | // Returns true if the timeout has expired. 115 | //=================================================================================================================== 116 | function TTimeoutTime.IsElapsed: boolean; 117 | begin 118 | Result := GetTickCount64 >= FTimeoutTime; 119 | end; 120 | 121 | 122 | //=================================================================================================================== 123 | // Initializes the timeout with the specified number of milliseconds. 124 | // The constant System.INFINITE (identical to Windows.INFINITE) is supported. 125 | // Due to the argument type, the maximum timeout is limited to 49.7 days. 126 | //=================================================================================================================== 127 | constructor TTimeoutTime.FromMilliSecs(Value: uint32); 128 | begin 129 | if Value = System.INFINITE then 130 | FTimeoutTime := FInfinite 131 | else 132 | FTimeoutTime := GetTickCount64 + Value; 133 | end; 134 | 135 | 136 | //=================================================================================================================== 137 | // Initializes the timeout with the specified number of of seconds. 138 | // The constant System.INFINITE (identical to Windows.INFINITE) is not supported. 139 | // Due to the argument type, the maximum timeout is limited to 49700 days. 140 | //=================================================================================================================== 141 | constructor TTimeoutTime.FromSecs(Value: uint32); 142 | begin 143 | FTimeoutTime := GetTickCount64 + Value * uint64(1000); 144 | end; 145 | 146 | 147 | //=================================================================================================================== 148 | // Returns the number of milliseconds until the timeout as a 64-bit value. 149 | //=================================================================================================================== 150 | function TTimeoutTime.RemainingMilliSecs: uint64; 151 | var 152 | res: int64 absolute Result; 153 | begin 154 | res := int64(FTimeoutTime) - int64(GetTickCount64); 155 | if res < 0 then res := 0; 156 | end; 157 | 158 | 159 | //=================================================================================================================== 160 | // Returns as uint32, or High(uint32) if exceeds the uint32 range. 161 | //=================================================================================================================== 162 | class function TTimeoutTime.ClampTo32(Value: uint64): uint32; 163 | begin 164 | {$if High(Result) <> System.INFINITE} {$message error 'Wrong result type'} {$ifend} 165 | 166 | if TInt64Rec(Value).Hi <> 0 then 167 | Result := High(Result) 168 | else 169 | Result := TInt64Rec(Value).Lo; 170 | end; 171 | 172 | 173 | //=================================================================================================================== 174 | // Returns the number of milliseconds until the timeout. 175 | // The result type limits the maximum time that can be delivered to 49.7 days. For higher values, or if the value 176 | // in Infinite, System.INFINITE is returned. 177 | //=================================================================================================================== 178 | function TTimeoutTime.AsMilliSecs: uint32; 179 | begin 180 | Result := self.ClampTo32(self.RemainingMilliSecs); 181 | end; 182 | 183 | 184 | //=================================================================================================================== 185 | // Returns the number of seconds until the timeout. 186 | // The result type limits the maximum time that can be delivered to 49700 days. For higher values, or if the value 187 | // is Infinite, the highest possible value is returned. 188 | //=================================================================================================================== 189 | function TTimeoutTime.AsSeconds: uint32; 190 | begin 191 | Result := self.ClampTo32(self.RemainingMilliSecs div 1000); 192 | end; 193 | 194 | 195 | //=================================================================================================================== 196 | // Exists only in Debug builds. 197 | //=================================================================================================================== 198 | function UnitTest: boolean; 199 | var 200 | t: TTimeoutTime; 201 | begin 202 | t := TTimeoutTime.Infinite; 203 | Assert(t.IsInfinite); 204 | Assert(not t.IsElapsed); 205 | Assert(t.AsMilliSecs = System.INFINITE); 206 | Assert(t.AsMilliSecs = High(t.AsMilliSecs)); 207 | Assert(t.AsSeconds = High(t.AsSeconds)); 208 | 209 | t := TTimeoutTime.FromMilliSecs(System.INFINITE); 210 | Assert(t.IsInfinite); 211 | Assert(not t.IsElapsed); 212 | Assert(t.AsMilliSecs = System.INFINITE); 213 | 214 | t := TTimeoutTime.Elapsed; 215 | Assert(not t.IsInfinite); 216 | Assert(t.IsElapsed); 217 | Assert(t.AsMilliSecs = 0); 218 | Assert(t.AsSeconds = 0); 219 | 220 | t := TTimeoutTime.FromMilliSecs(0); 221 | Assert(not t.IsInfinite); 222 | Assert(t.IsElapsed); 223 | Assert(t.AsMilliSecs = 0); 224 | 225 | t := TTimeoutTime.FromMilliSecs($FFFFFFFE); 226 | Assert(not t.IsInfinite); 227 | Assert(not t.IsElapsed); 228 | Assert(t.AsMilliSecs <= $FFFFFFFE); 229 | 230 | t := TTimeoutTime.FromSecs(123); 231 | // can only fail on an extremly slow system, or if halted in the debugger in between: 232 | Assert(t.AsSeconds in [122, 123]); 233 | 234 | Result := true; 235 | end; 236 | 237 | 238 | initialization 239 | Assert(UnitTest); 240 | end. 241 | 242 | -------------------------------------------------------------------------------- /source/TimeoutUtil.pas: -------------------------------------------------------------------------------- 1 | unit TimeoutUtil; 2 | 3 | { 4 | Types for efficient handling of timeouts. 5 | 6 | - TTimeoutTime: Represents the expiration time of a timeout. 7 | } 8 | 9 | 10 | {$include LibOptions.inc} 11 | 12 | interface 13 | 14 | type 15 | //=================================================================================================================== 16 | // Represents the expiration time of a timeout. This is *not* a timespan, but a absolute point in time! 17 | // Time spent in sleep or hibernation counts towards the timeout. 18 | // 19 | // This is a very thin wrapper around the API function GetTickCount64, which provides the number of milliseconds 20 | // since the last Windows system start, regardless of time changes, time zone changes and daylight saving time 21 | // switches. 22 | //=================================================================================================================== 23 | TTimeoutTime = record 24 | strict private 25 | const 26 | FInfinite = uint64(High(int64)); // not cause overflow in the signed subtraction in RemainingMilliSecs (roughly 292m years) 27 | var 28 | FTimeoutTime: uint64; // time when the timeout expires (in terms of GetTickCount64) 29 | 30 | function RemainingMilliSecs: uint64; 31 | class function ClampTo32(Value: uint64): uint32; static; {$ifdef CPU64BITS}inline;{$endif} 32 | public 33 | constructor FromMilliSecs(Value: uint32); 34 | constructor FromSecs(Value: uint32); 35 | class function Elapsed: TTimeoutTime; inline; static; 36 | class function Infinite: TTimeoutTime; inline; static; 37 | class function Undefined: TTimeoutTime; static; deprecated 'use "Infinite"'; 38 | 39 | function AsSeconds: uint32; 40 | function AsMilliSecs: uint32; 41 | function IsElapsed: boolean; 42 | function IsInfinite: boolean; {$ifdef CPU64BITS}inline;{$endif} 43 | function IsDefined: boolean; deprecated 'use "not .IsInfinite"'; 44 | end; 45 | 46 | 47 | {############################################################################} 48 | implementation 49 | {############################################################################} 50 | 51 | uses Windows; 52 | 53 | {$if not declared(GetTickCount64)} 54 | // since Vista: 55 | function GetTickCount64: uint64; stdcall; external Windows.kernel32 name 'GetTickCount64'; 56 | {$ifend} 57 | 58 | type 59 | TInt64Rec = record 60 | case byte of 61 | 0: (Value: uint64); 62 | 1: (Lo, Hi: uint32); 63 | end; 64 | 65 | 66 | { TTimeoutTime } 67 | 68 | //=================================================================================================================== 69 | // Returns a timeout is already expired. 70 | //=================================================================================================================== 71 | class function TTimeoutTime.Elapsed: TTimeoutTime; 72 | begin 73 | Result.FTimeoutTime := 0; 74 | end; 75 | 76 | 77 | //=================================================================================================================== 78 | // Returns a timeout that never expires. 79 | //=================================================================================================================== 80 | class function TTimeoutTime.Infinite: TTimeoutTime; 81 | begin 82 | Result.FTimeoutTime := FInfinite; 83 | end; 84 | 85 | 86 | //=================================================================================================================== 87 | // Obsolete. 88 | //=================================================================================================================== 89 | class function TTimeoutTime.Undefined: TTimeoutTime; 90 | begin 91 | Result := TTimeoutTime.Infinite; 92 | end; 93 | 94 | 95 | //=================================================================================================================== 96 | // Returns true if the timeout is "Infinite". 97 | //=================================================================================================================== 98 | function TTimeoutTime.IsInfinite: boolean; 99 | begin 100 | Result := FTimeoutTime = FInfinite; 101 | end; 102 | 103 | 104 | //=================================================================================================================== 105 | // Obsolete. 106 | //=================================================================================================================== 107 | function TTimeoutTime.IsDefined: boolean; 108 | begin 109 | Result := not self.IsInfinite; 110 | end; 111 | 112 | 113 | //=================================================================================================================== 114 | // Returns true if the timeout has expired. 115 | //=================================================================================================================== 116 | function TTimeoutTime.IsElapsed: boolean; 117 | begin 118 | Result := GetTickCount64 >= FTimeoutTime; 119 | end; 120 | 121 | 122 | //=================================================================================================================== 123 | // Initializes the timeout with the specified number of milliseconds. 124 | // The constant System.INFINITE (identical to Windows.INFINITE) is supported. 125 | // Due to the argument type, the maximum timeout is limited to 49.7 days. 126 | //=================================================================================================================== 127 | constructor TTimeoutTime.FromMilliSecs(Value: uint32); 128 | begin 129 | if Value = System.INFINITE then 130 | FTimeoutTime := FInfinite 131 | else 132 | FTimeoutTime := GetTickCount64 + Value; 133 | end; 134 | 135 | 136 | //=================================================================================================================== 137 | // Initializes the timeout with the specified number of of seconds. 138 | // The constant System.INFINITE (identical to Windows.INFINITE) is not supported. 139 | // Due to the argument type, the maximum timeout is limited to 49700 days. 140 | //=================================================================================================================== 141 | constructor TTimeoutTime.FromSecs(Value: uint32); 142 | begin 143 | FTimeoutTime := GetTickCount64 + Value * uint64(1000); 144 | end; 145 | 146 | 147 | //=================================================================================================================== 148 | // Returns the number of milliseconds until the timeout as a 64-bit value. 149 | //=================================================================================================================== 150 | function TTimeoutTime.RemainingMilliSecs: uint64; 151 | var 152 | res: int64 absolute Result; 153 | begin 154 | res := int64(FTimeoutTime) - int64(GetTickCount64); 155 | if res < 0 then res := 0; 156 | end; 157 | 158 | 159 | //=================================================================================================================== 160 | // Returns as uint32, or High(uint32) if exceeds the uint32 range. 161 | //=================================================================================================================== 162 | class function TTimeoutTime.ClampTo32(Value: uint64): uint32; 163 | begin 164 | {$if High(Result) <> System.INFINITE} {$message error 'Wrong result type'} {$ifend} 165 | 166 | if TInt64Rec(Value).Hi <> 0 then 167 | Result := High(Result) 168 | else 169 | Result := TInt64Rec(Value).Lo; 170 | end; 171 | 172 | 173 | //=================================================================================================================== 174 | // Returns the number of milliseconds until the timeout. 175 | // The result type limits the maximum time that can be delivered to 49.7 days. For higher values, or if the value 176 | // in Infinite, System.INFINITE is returned. 177 | //=================================================================================================================== 178 | function TTimeoutTime.AsMilliSecs: uint32; 179 | begin 180 | Result := self.ClampTo32(self.RemainingMilliSecs); 181 | end; 182 | 183 | 184 | //=================================================================================================================== 185 | // Returns the number of seconds until the timeout. 186 | // The result type limits the maximum time that can be delivered to 49700 days. For higher values, or if the value 187 | // is Infinite, the highest possible value is returned. 188 | //=================================================================================================================== 189 | function TTimeoutTime.AsSeconds: uint32; 190 | begin 191 | Result := self.ClampTo32(self.RemainingMilliSecs div 1000); 192 | end; 193 | 194 | 195 | //=================================================================================================================== 196 | // Exists only in Debug builds. 197 | //=================================================================================================================== 198 | function UnitTest: boolean; 199 | var 200 | t: TTimeoutTime; 201 | begin 202 | t := TTimeoutTime.Infinite; 203 | Assert(t.IsInfinite); 204 | Assert(not t.IsElapsed); 205 | Assert(t.AsMilliSecs = System.INFINITE); 206 | Assert(t.AsMilliSecs = High(t.AsMilliSecs)); 207 | Assert(t.AsSeconds = High(t.AsSeconds)); 208 | 209 | t := TTimeoutTime.FromMilliSecs(System.INFINITE); 210 | Assert(t.IsInfinite); 211 | Assert(not t.IsElapsed); 212 | Assert(t.AsMilliSecs = System.INFINITE); 213 | 214 | t := TTimeoutTime.Elapsed; 215 | Assert(not t.IsInfinite); 216 | Assert(t.IsElapsed); 217 | Assert(t.AsMilliSecs = 0); 218 | Assert(t.AsSeconds = 0); 219 | 220 | t := TTimeoutTime.FromMilliSecs(0); 221 | Assert(not t.IsInfinite); 222 | Assert(t.IsElapsed); 223 | Assert(t.AsMilliSecs = 0); 224 | 225 | t := TTimeoutTime.FromMilliSecs($FFFFFFFE); 226 | Assert(not t.IsInfinite); 227 | Assert(not t.IsElapsed); 228 | Assert(t.AsMilliSecs <= $FFFFFFFE); 229 | 230 | t := TTimeoutTime.FromSecs(123); 231 | // can only fail on an extremly slow system, or if halted in the debugger in between: 232 | Assert(t.AsSeconds in [122, 123]); 233 | 234 | Result := true; 235 | end; 236 | 237 | 238 | initialization 239 | Assert(UnitTest); 240 | end. 241 | 242 | -------------------------------------------------------------------------------- /source/AdditionalSymbols.inc: -------------------------------------------------------------------------------- 1 | // 2 | // see: http://docwiki.embarcadero.com/RADStudio/en/Compiler_Versions 3 | // 4 | // https://docwiki.embarcadero.com/RADStudio/Alexandria/en/Compiler_Versions 5 | 6 | {$undef Delphi2} 7 | {$undef Delphi3} 8 | {$undef Delphi4} 9 | {$undef Delphi5} 10 | {$undef Delphi6} 11 | {$undef Delphi7} 12 | {$undef Delphi8} 13 | {$undef D2005} 14 | {$undef D2006} 15 | {$undef D2007} 16 | {$undef D2009} 17 | {$undef D2010} 18 | {$undef D2011} 19 | {$undef DelphiXE} 20 | {$undef DelphiXE2} 21 | {$undef DelphiXE3} 22 | {$undef DelphiXE4} 23 | {$undef DelphiXE5} 24 | {$undef DelphiXE6} 25 | {$undef DelphiXE7} 26 | {$undef DelphiXE8} 27 | {$undef Delphi10} 28 | {$undef Delphi101} 29 | {$undef Delphi102} 30 | {$undef Delphi103} 31 | {$undef Delphi104} 32 | {$undef Delphi11} 33 | {$undef Delphi12} 34 | 35 | // D2: VER90 36 | // D3: VER100 37 | // D4: VER120 38 | // D5: VER130 39 | // D6: VER140 40 | // D7: VER150 41 | // D8: VER160 42 | // D2005: VER170 43 | // D2006: VER180 44 | // D2007: VER190 45 | 46 | // D2009: 47 | {$ifdef VER200} 48 | {$define Delphi2} 49 | {$define Delphi3} 50 | {$define Delphi4} 51 | {$define Delphi5} 52 | {$define Delphi6} 53 | {$define Delphi7} 54 | {$define Delphi8} 55 | {$define D2005} 56 | {$define D2006} 57 | {$define D2007} 58 | {$define D2009} 59 | {$endif} 60 | 61 | // D2010: 62 | {$ifdef VER210} 63 | {$define Delphi2} 64 | {$define Delphi3} 65 | {$define Delphi4} 66 | {$define Delphi5} 67 | {$define Delphi6} 68 | {$define Delphi7} 69 | {$define Delphi8} 70 | {$define D2005} 71 | {$define D2006} 72 | {$define D2007} 73 | {$define D2009} 74 | {$define D2010} 75 | {$endif} 76 | 77 | // D2011/XE: 78 | {$ifdef VER220} 79 | {$define Delphi2} 80 | {$define Delphi3} 81 | {$define Delphi4} 82 | {$define Delphi5} 83 | {$define Delphi6} 84 | {$define Delphi7} 85 | {$define Delphi8} 86 | {$define D2005} 87 | {$define D2006} 88 | {$define D2007} 89 | {$define D2009} 90 | {$define D2010} 91 | {$define D2011} 92 | {$define DelphiXE} 93 | {$endif} 94 | 95 | // XE2: 96 | {$ifdef VER230} 97 | {$define Delphi2} 98 | {$define Delphi3} 99 | {$define Delphi4} 100 | {$define Delphi5} 101 | {$define Delphi6} 102 | {$define Delphi7} 103 | {$define Delphi8} 104 | {$define D2005} 105 | {$define D2006} 106 | {$define D2007} 107 | {$define D2009} 108 | {$define D2010} 109 | {$define D2011} 110 | {$define DelphiXE} 111 | {$define DelphiXE2} 112 | {$endif} 113 | 114 | // XE3: 115 | {$ifdef VER240} 116 | {$define Delphi2} 117 | {$define Delphi3} 118 | {$define Delphi4} 119 | {$define Delphi5} 120 | {$define Delphi6} 121 | {$define Delphi7} 122 | {$define Delphi8} 123 | {$define D2005} 124 | {$define D2006} 125 | {$define D2007} 126 | {$define D2009} 127 | {$define D2010} 128 | {$define D2011} 129 | {$define DelphiXE} 130 | {$define DelphiXE2} 131 | {$define DelphiXE3} 132 | {$endif} 133 | 134 | // XE4: 135 | {$ifdef VER250} 136 | {$define Delphi2} 137 | {$define Delphi3} 138 | {$define Delphi4} 139 | {$define Delphi5} 140 | {$define Delphi6} 141 | {$define Delphi7} 142 | {$define Delphi8} 143 | {$define D2005} 144 | {$define D2006} 145 | {$define D2007} 146 | {$define D2009} 147 | {$define D2010} 148 | {$define D2011} 149 | {$define DelphiXE} 150 | {$define DelphiXE2} 151 | {$define DelphiXE3} 152 | {$define DelphiXE4} 153 | {$endif} 154 | 155 | // XE5: 156 | {$ifdef VER260} 157 | {$define Delphi2} 158 | {$define Delphi3} 159 | {$define Delphi4} 160 | {$define Delphi5} 161 | {$define Delphi6} 162 | {$define Delphi7} 163 | {$define Delphi8} 164 | {$define D2005} 165 | {$define D2006} 166 | {$define D2007} 167 | {$define D2009} 168 | {$define D2010} 169 | {$define D2011} 170 | {$define DelphiXE} 171 | {$define DelphiXE2} 172 | {$define DelphiXE3} 173 | {$define DelphiXE4} 174 | {$define DelphiXE5} 175 | {$endif} 176 | 177 | // XE6: 178 | {$ifdef VER270} 179 | {$define Delphi2} 180 | {$define Delphi3} 181 | {$define Delphi4} 182 | {$define Delphi5} 183 | {$define Delphi6} 184 | {$define Delphi7} 185 | {$define Delphi8} 186 | {$define D2005} 187 | {$define D2006} 188 | {$define D2007} 189 | {$define D2009} 190 | {$define D2010} 191 | {$define D2011} 192 | {$define DelphiXE} 193 | {$define DelphiXE2} 194 | {$define DelphiXE3} 195 | {$define DelphiXE4} 196 | {$define DelphiXE5} 197 | {$define DelphiXE6} 198 | {$endif} 199 | 200 | // XE7: 201 | {$ifdef VER280} 202 | {$define Delphi2} 203 | {$define Delphi3} 204 | {$define Delphi4} 205 | {$define Delphi5} 206 | {$define Delphi6} 207 | {$define Delphi7} 208 | {$define Delphi8} 209 | {$define D2005} 210 | {$define D2006} 211 | {$define D2007} 212 | {$define D2009} 213 | {$define D2010} 214 | {$define D2011} 215 | {$define DelphiXE} 216 | {$define DelphiXE2} 217 | {$define DelphiXE3} 218 | {$define DelphiXE4} 219 | {$define DelphiXE5} 220 | {$define DelphiXE6} 221 | {$define DelphiXE7} 222 | {$endif} 223 | 224 | // XE8: 225 | {$ifdef VER290} 226 | {$define Delphi2} 227 | {$define Delphi3} 228 | {$define Delphi4} 229 | {$define Delphi5} 230 | {$define Delphi6} 231 | {$define Delphi7} 232 | {$define Delphi8} 233 | {$define D2005} 234 | {$define D2006} 235 | {$define D2007} 236 | {$define D2009} 237 | {$define D2010} 238 | {$define D2011} 239 | {$define DelphiXE} 240 | {$define DelphiXE2} 241 | {$define DelphiXE3} 242 | {$define DelphiXE4} 243 | {$define DelphiXE5} 244 | {$define DelphiXE6} 245 | {$define DelphiXE7} 246 | {$define DelphiXE8} 247 | {$endif} 248 | 249 | // D10 Seattle: 250 | {$ifdef VER300} 251 | {$define Delphi2} 252 | {$define Delphi3} 253 | {$define Delphi4} 254 | {$define Delphi5} 255 | {$define Delphi6} 256 | {$define Delphi7} 257 | {$define Delphi8} 258 | {$define D2005} 259 | {$define D2006} 260 | {$define D2007} 261 | {$define D2009} 262 | {$define D2010} 263 | {$define D2011} 264 | {$define DelphiXE} 265 | {$define DelphiXE2} 266 | {$define DelphiXE3} 267 | {$define DelphiXE4} 268 | {$define DelphiXE5} 269 | {$define DelphiXE6} 270 | {$define DelphiXE7} 271 | {$define DelphiXE8} 272 | {$define Delphi10} 273 | {$endif} 274 | 275 | // D10.1 Berlin: 276 | {$ifdef VER310} 277 | {$define Delphi2} 278 | {$define Delphi3} 279 | {$define Delphi4} 280 | {$define Delphi5} 281 | {$define Delphi6} 282 | {$define Delphi7} 283 | {$define Delphi8} 284 | {$define D2005} 285 | {$define D2006} 286 | {$define D2007} 287 | {$define D2009} 288 | {$define D2010} 289 | {$define D2011} 290 | {$define DelphiXE} 291 | {$define DelphiXE2} 292 | {$define DelphiXE3} 293 | {$define DelphiXE4} 294 | {$define DelphiXE5} 295 | {$define DelphiXE6} 296 | {$define DelphiXE7} 297 | {$define DelphiXE8} 298 | {$define Delphi10} 299 | {$define Delphi101} 300 | {$endif} 301 | 302 | // D10.2 Tokyo: 303 | {$ifdef VER320} 304 | {$define Delphi2} 305 | {$define Delphi3} 306 | {$define Delphi4} 307 | {$define Delphi5} 308 | {$define Delphi6} 309 | {$define Delphi7} 310 | {$define Delphi8} 311 | {$define D2005} 312 | {$define D2006} 313 | {$define D2007} 314 | {$define D2009} 315 | {$define D2010} 316 | {$define D2011} 317 | {$define DelphiXE} 318 | {$define DelphiXE2} 319 | {$define DelphiXE3} 320 | {$define DelphiXE4} 321 | {$define DelphiXE5} 322 | {$define DelphiXE6} 323 | {$define DelphiXE7} 324 | {$define DelphiXE8} 325 | {$define Delphi10} 326 | {$define Delphi101} 327 | {$define Delphi102} 328 | {$endif} 329 | 330 | // D10.3 Rio: 331 | {$ifdef VER330} 332 | {$define Delphi2} 333 | {$define Delphi3} 334 | {$define Delphi4} 335 | {$define Delphi5} 336 | {$define Delphi6} 337 | {$define Delphi7} 338 | {$define Delphi8} 339 | {$define D2005} 340 | {$define D2006} 341 | {$define D2007} 342 | {$define D2009} 343 | {$define D2010} 344 | {$define D2011} 345 | {$define DelphiXE} 346 | {$define DelphiXE2} 347 | {$define DelphiXE3} 348 | {$define DelphiXE4} 349 | {$define DelphiXE5} 350 | {$define DelphiXE6} 351 | {$define DelphiXE7} 352 | {$define DelphiXE8} 353 | {$define Delphi10} 354 | {$define Delphi101} 355 | {$define Delphi102} 356 | {$define Delphi103} 357 | {$endif} 358 | 359 | // D10.4 Sydney: 360 | {$ifdef VER340} 361 | {$define Delphi2} 362 | {$define Delphi3} 363 | {$define Delphi4} 364 | {$define Delphi5} 365 | {$define Delphi6} 366 | {$define Delphi7} 367 | {$define Delphi8} 368 | {$define D2005} 369 | {$define D2006} 370 | {$define D2007} 371 | {$define D2009} 372 | {$define D2010} 373 | {$define D2011} 374 | {$define DelphiXE} 375 | {$define DelphiXE2} 376 | {$define DelphiXE3} 377 | {$define DelphiXE4} 378 | {$define DelphiXE5} 379 | {$define DelphiXE6} 380 | {$define DelphiXE7} 381 | {$define DelphiXE8} 382 | {$define Delphi10} 383 | {$define Delphi101} 384 | {$define Delphi102} 385 | {$define Delphi103} 386 | {$define Delphi104} 387 | {$endif} 388 | 389 | // D11.0 Alexandria 390 | {$ifdef VER350} 391 | {$define Delphi2} 392 | {$define Delphi3} 393 | {$define Delphi4} 394 | {$define Delphi5} 395 | {$define Delphi6} 396 | {$define Delphi7} 397 | {$define Delphi8} 398 | {$define D2005} 399 | {$define D2006} 400 | {$define D2007} 401 | {$define D2009} 402 | {$define D2010} 403 | {$define D2011} 404 | {$define DelphiXE} 405 | {$define DelphiXE2} 406 | {$define DelphiXE3} 407 | {$define DelphiXE4} 408 | {$define DelphiXE5} 409 | {$define DelphiXE6} 410 | {$define DelphiXE7} 411 | {$define DelphiXE8} 412 | {$define Delphi10} 413 | {$define Delphi101} 414 | {$define Delphi102} 415 | {$define Delphi103} 416 | {$define Delphi104} 417 | {$define Delphi11} 418 | {$endif} 419 | 420 | // D12.0 Athens 421 | {$ifdef VER360} 422 | {$define Delphi2} 423 | {$define Delphi3} 424 | {$define Delphi4} 425 | {$define Delphi5} 426 | {$define Delphi6} 427 | {$define Delphi7} 428 | {$define Delphi8} 429 | {$define D2005} 430 | {$define D2006} 431 | {$define D2007} 432 | {$define D2009} 433 | {$define D2010} 434 | {$define D2011} 435 | {$define DelphiXE} 436 | {$define DelphiXE2} 437 | {$define DelphiXE3} 438 | {$define DelphiXE4} 439 | {$define DelphiXE5} 440 | {$define DelphiXE6} 441 | {$define DelphiXE7} 442 | {$define DelphiXE8} 443 | {$define Delphi10} 444 | {$define Delphi101} 445 | {$define Delphi102} 446 | {$define Delphi103} 447 | {$define Delphi104} 448 | {$define Delphi11} 449 | {$define Delphi12} 450 | {$endif} 451 | -------------------------------------------------------------------------------- /demo/lib/AdditionalSymbols.inc: -------------------------------------------------------------------------------- 1 | // 2 | // see: http://docwiki.embarcadero.com/RADStudio/en/Compiler_Versions 3 | // 4 | // https://docwiki.embarcadero.com/RADStudio/Alexandria/en/Compiler_Versions 5 | 6 | {$undef Delphi2} 7 | {$undef Delphi3} 8 | {$undef Delphi4} 9 | {$undef Delphi5} 10 | {$undef Delphi6} 11 | {$undef Delphi7} 12 | {$undef Delphi8} 13 | {$undef D2005} 14 | {$undef D2006} 15 | {$undef D2007} 16 | {$undef D2009} 17 | {$undef D2010} 18 | {$undef D2011} 19 | {$undef DelphiXE} 20 | {$undef DelphiXE2} 21 | {$undef DelphiXE3} 22 | {$undef DelphiXE4} 23 | {$undef DelphiXE5} 24 | {$undef DelphiXE6} 25 | {$undef DelphiXE7} 26 | {$undef DelphiXE8} 27 | {$undef Delphi10} 28 | {$undef Delphi101} 29 | {$undef Delphi102} 30 | {$undef Delphi103} 31 | {$undef Delphi104} 32 | {$undef Delphi11} 33 | {$undef Delphi12} 34 | 35 | // D2: VER90 36 | // D3: VER100 37 | // D4: VER120 38 | // D5: VER130 39 | // D6: VER140 40 | // D7: VER150 41 | // D8: VER160 42 | // D2005: VER170 43 | // D2006: VER180 44 | // D2007: VER190 45 | 46 | // D2009: 47 | {$ifdef VER200} 48 | {$define Delphi2} 49 | {$define Delphi3} 50 | {$define Delphi4} 51 | {$define Delphi5} 52 | {$define Delphi6} 53 | {$define Delphi7} 54 | {$define Delphi8} 55 | {$define D2005} 56 | {$define D2006} 57 | {$define D2007} 58 | {$define D2009} 59 | {$endif} 60 | 61 | // D2010: 62 | {$ifdef VER210} 63 | {$define Delphi2} 64 | {$define Delphi3} 65 | {$define Delphi4} 66 | {$define Delphi5} 67 | {$define Delphi6} 68 | {$define Delphi7} 69 | {$define Delphi8} 70 | {$define D2005} 71 | {$define D2006} 72 | {$define D2007} 73 | {$define D2009} 74 | {$define D2010} 75 | {$endif} 76 | 77 | // D2011/XE: 78 | {$ifdef VER220} 79 | {$define Delphi2} 80 | {$define Delphi3} 81 | {$define Delphi4} 82 | {$define Delphi5} 83 | {$define Delphi6} 84 | {$define Delphi7} 85 | {$define Delphi8} 86 | {$define D2005} 87 | {$define D2006} 88 | {$define D2007} 89 | {$define D2009} 90 | {$define D2010} 91 | {$define D2011} 92 | {$define DelphiXE} 93 | {$endif} 94 | 95 | // XE2: 96 | {$ifdef VER230} 97 | {$define Delphi2} 98 | {$define Delphi3} 99 | {$define Delphi4} 100 | {$define Delphi5} 101 | {$define Delphi6} 102 | {$define Delphi7} 103 | {$define Delphi8} 104 | {$define D2005} 105 | {$define D2006} 106 | {$define D2007} 107 | {$define D2009} 108 | {$define D2010} 109 | {$define D2011} 110 | {$define DelphiXE} 111 | {$define DelphiXE2} 112 | {$endif} 113 | 114 | // XE3: 115 | {$ifdef VER240} 116 | {$define Delphi2} 117 | {$define Delphi3} 118 | {$define Delphi4} 119 | {$define Delphi5} 120 | {$define Delphi6} 121 | {$define Delphi7} 122 | {$define Delphi8} 123 | {$define D2005} 124 | {$define D2006} 125 | {$define D2007} 126 | {$define D2009} 127 | {$define D2010} 128 | {$define D2011} 129 | {$define DelphiXE} 130 | {$define DelphiXE2} 131 | {$define DelphiXE3} 132 | {$endif} 133 | 134 | // XE4: 135 | {$ifdef VER250} 136 | {$define Delphi2} 137 | {$define Delphi3} 138 | {$define Delphi4} 139 | {$define Delphi5} 140 | {$define Delphi6} 141 | {$define Delphi7} 142 | {$define Delphi8} 143 | {$define D2005} 144 | {$define D2006} 145 | {$define D2007} 146 | {$define D2009} 147 | {$define D2010} 148 | {$define D2011} 149 | {$define DelphiXE} 150 | {$define DelphiXE2} 151 | {$define DelphiXE3} 152 | {$define DelphiXE4} 153 | {$endif} 154 | 155 | // XE5: 156 | {$ifdef VER260} 157 | {$define Delphi2} 158 | {$define Delphi3} 159 | {$define Delphi4} 160 | {$define Delphi5} 161 | {$define Delphi6} 162 | {$define Delphi7} 163 | {$define Delphi8} 164 | {$define D2005} 165 | {$define D2006} 166 | {$define D2007} 167 | {$define D2009} 168 | {$define D2010} 169 | {$define D2011} 170 | {$define DelphiXE} 171 | {$define DelphiXE2} 172 | {$define DelphiXE3} 173 | {$define DelphiXE4} 174 | {$define DelphiXE5} 175 | {$endif} 176 | 177 | // XE6: 178 | {$ifdef VER270} 179 | {$define Delphi2} 180 | {$define Delphi3} 181 | {$define Delphi4} 182 | {$define Delphi5} 183 | {$define Delphi6} 184 | {$define Delphi7} 185 | {$define Delphi8} 186 | {$define D2005} 187 | {$define D2006} 188 | {$define D2007} 189 | {$define D2009} 190 | {$define D2010} 191 | {$define D2011} 192 | {$define DelphiXE} 193 | {$define DelphiXE2} 194 | {$define DelphiXE3} 195 | {$define DelphiXE4} 196 | {$define DelphiXE5} 197 | {$define DelphiXE6} 198 | {$endif} 199 | 200 | // XE7: 201 | {$ifdef VER280} 202 | {$define Delphi2} 203 | {$define Delphi3} 204 | {$define Delphi4} 205 | {$define Delphi5} 206 | {$define Delphi6} 207 | {$define Delphi7} 208 | {$define Delphi8} 209 | {$define D2005} 210 | {$define D2006} 211 | {$define D2007} 212 | {$define D2009} 213 | {$define D2010} 214 | {$define D2011} 215 | {$define DelphiXE} 216 | {$define DelphiXE2} 217 | {$define DelphiXE3} 218 | {$define DelphiXE4} 219 | {$define DelphiXE5} 220 | {$define DelphiXE6} 221 | {$define DelphiXE7} 222 | {$endif} 223 | 224 | // XE8: 225 | {$ifdef VER290} 226 | {$define Delphi2} 227 | {$define Delphi3} 228 | {$define Delphi4} 229 | {$define Delphi5} 230 | {$define Delphi6} 231 | {$define Delphi7} 232 | {$define Delphi8} 233 | {$define D2005} 234 | {$define D2006} 235 | {$define D2007} 236 | {$define D2009} 237 | {$define D2010} 238 | {$define D2011} 239 | {$define DelphiXE} 240 | {$define DelphiXE2} 241 | {$define DelphiXE3} 242 | {$define DelphiXE4} 243 | {$define DelphiXE5} 244 | {$define DelphiXE6} 245 | {$define DelphiXE7} 246 | {$define DelphiXE8} 247 | {$endif} 248 | 249 | // D10 Seattle: 250 | {$ifdef VER300} 251 | {$define Delphi2} 252 | {$define Delphi3} 253 | {$define Delphi4} 254 | {$define Delphi5} 255 | {$define Delphi6} 256 | {$define Delphi7} 257 | {$define Delphi8} 258 | {$define D2005} 259 | {$define D2006} 260 | {$define D2007} 261 | {$define D2009} 262 | {$define D2010} 263 | {$define D2011} 264 | {$define DelphiXE} 265 | {$define DelphiXE2} 266 | {$define DelphiXE3} 267 | {$define DelphiXE4} 268 | {$define DelphiXE5} 269 | {$define DelphiXE6} 270 | {$define DelphiXE7} 271 | {$define DelphiXE8} 272 | {$define Delphi10} 273 | {$endif} 274 | 275 | // D10.1 Berlin: 276 | {$ifdef VER310} 277 | {$define Delphi2} 278 | {$define Delphi3} 279 | {$define Delphi4} 280 | {$define Delphi5} 281 | {$define Delphi6} 282 | {$define Delphi7} 283 | {$define Delphi8} 284 | {$define D2005} 285 | {$define D2006} 286 | {$define D2007} 287 | {$define D2009} 288 | {$define D2010} 289 | {$define D2011} 290 | {$define DelphiXE} 291 | {$define DelphiXE2} 292 | {$define DelphiXE3} 293 | {$define DelphiXE4} 294 | {$define DelphiXE5} 295 | {$define DelphiXE6} 296 | {$define DelphiXE7} 297 | {$define DelphiXE8} 298 | {$define Delphi10} 299 | {$define Delphi101} 300 | {$endif} 301 | 302 | // D10.2 Tokyo: 303 | {$ifdef VER320} 304 | {$define Delphi2} 305 | {$define Delphi3} 306 | {$define Delphi4} 307 | {$define Delphi5} 308 | {$define Delphi6} 309 | {$define Delphi7} 310 | {$define Delphi8} 311 | {$define D2005} 312 | {$define D2006} 313 | {$define D2007} 314 | {$define D2009} 315 | {$define D2010} 316 | {$define D2011} 317 | {$define DelphiXE} 318 | {$define DelphiXE2} 319 | {$define DelphiXE3} 320 | {$define DelphiXE4} 321 | {$define DelphiXE5} 322 | {$define DelphiXE6} 323 | {$define DelphiXE7} 324 | {$define DelphiXE8} 325 | {$define Delphi10} 326 | {$define Delphi101} 327 | {$define Delphi102} 328 | {$endif} 329 | 330 | // D10.3 Rio: 331 | {$ifdef VER330} 332 | {$define Delphi2} 333 | {$define Delphi3} 334 | {$define Delphi4} 335 | {$define Delphi5} 336 | {$define Delphi6} 337 | {$define Delphi7} 338 | {$define Delphi8} 339 | {$define D2005} 340 | {$define D2006} 341 | {$define D2007} 342 | {$define D2009} 343 | {$define D2010} 344 | {$define D2011} 345 | {$define DelphiXE} 346 | {$define DelphiXE2} 347 | {$define DelphiXE3} 348 | {$define DelphiXE4} 349 | {$define DelphiXE5} 350 | {$define DelphiXE6} 351 | {$define DelphiXE7} 352 | {$define DelphiXE8} 353 | {$define Delphi10} 354 | {$define Delphi101} 355 | {$define Delphi102} 356 | {$define Delphi103} 357 | {$endif} 358 | 359 | // D10.4 Sydney: 360 | {$ifdef VER340} 361 | {$define Delphi2} 362 | {$define Delphi3} 363 | {$define Delphi4} 364 | {$define Delphi5} 365 | {$define Delphi6} 366 | {$define Delphi7} 367 | {$define Delphi8} 368 | {$define D2005} 369 | {$define D2006} 370 | {$define D2007} 371 | {$define D2009} 372 | {$define D2010} 373 | {$define D2011} 374 | {$define DelphiXE} 375 | {$define DelphiXE2} 376 | {$define DelphiXE3} 377 | {$define DelphiXE4} 378 | {$define DelphiXE5} 379 | {$define DelphiXE6} 380 | {$define DelphiXE7} 381 | {$define DelphiXE8} 382 | {$define Delphi10} 383 | {$define Delphi101} 384 | {$define Delphi102} 385 | {$define Delphi103} 386 | {$define Delphi104} 387 | {$endif} 388 | 389 | // D11.0 Alexandria 390 | {$ifdef VER350} 391 | {$define Delphi2} 392 | {$define Delphi3} 393 | {$define Delphi4} 394 | {$define Delphi5} 395 | {$define Delphi6} 396 | {$define Delphi7} 397 | {$define Delphi8} 398 | {$define D2005} 399 | {$define D2006} 400 | {$define D2007} 401 | {$define D2009} 402 | {$define D2010} 403 | {$define D2011} 404 | {$define DelphiXE} 405 | {$define DelphiXE2} 406 | {$define DelphiXE3} 407 | {$define DelphiXE4} 408 | {$define DelphiXE5} 409 | {$define DelphiXE6} 410 | {$define DelphiXE7} 411 | {$define DelphiXE8} 412 | {$define Delphi10} 413 | {$define Delphi101} 414 | {$define Delphi102} 415 | {$define Delphi103} 416 | {$define Delphi104} 417 | {$define Delphi11} 418 | {$endif} 419 | 420 | // D12.0 Athens 421 | {$ifdef VER360} 422 | {$define Delphi2} 423 | {$define Delphi3} 424 | {$define Delphi4} 425 | {$define Delphi5} 426 | {$define Delphi6} 427 | {$define Delphi7} 428 | {$define Delphi8} 429 | {$define D2005} 430 | {$define D2006} 431 | {$define D2007} 432 | {$define D2009} 433 | {$define D2010} 434 | {$define D2011} 435 | {$define DelphiXE} 436 | {$define DelphiXE2} 437 | {$define DelphiXE3} 438 | {$define DelphiXE4} 439 | {$define DelphiXE5} 440 | {$define DelphiXE6} 441 | {$define DelphiXE7} 442 | {$define DelphiXE8} 443 | {$define Delphi10} 444 | {$define Delphi101} 445 | {$define Delphi102} 446 | {$define Delphi103} 447 | {$define Delphi104} 448 | {$define Delphi11} 449 | {$define Delphi12} 450 | {$endif} 451 | -------------------------------------------------------------------------------- /demo/source/MainForm.pas: -------------------------------------------------------------------------------- 1 | unit MainForm; 2 | 3 | { 4 | Highly theoretical example to demonstrate the usage of tasks with a Delphi form. 5 | 6 | *** Important note: 7 | 8 | If you start this program from the Delphi 2009 IDE and press the "Count Prime numbers" button, you will probably be 9 | disappointed, as the application and the IDE become slow and stuttering. This is due to the Delphi debugger reacting 10 | extremly slow to creation and destruction of threads. You can open the "Event Log" window to watch this. 11 | If the ThreadIdleMillisecs parameter is too low, and the debugger is extremly slowing down everyhing, it will cause 12 | all pool threads to timeout all the time, causing constant creating and finishing of the threads. 13 | } 14 | 15 | {$include CompilerOptions.inc} 16 | 17 | interface 18 | 19 | uses 20 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Menus, 21 | Tasks, GuiTasks; 22 | 23 | type 24 | TfMainForm = class(TForm) 25 | TMainMenu: TMainMenu; 26 | TMenu: TMenuItem; 27 | TMemuItem: TMenuItem; 28 | btCountPrimeNumbers: TButton; 29 | btOpenMsgBox: TButton; 30 | Panel1: TPanel; 31 | lblPrimeResult: TLabel; 32 | Panel2: TPanel; 33 | lblRGB: TLabel; 34 | procedure FormActivate(Sender: TObject); 35 | procedure FormClose(Sender: TObject; var Action: TCloseAction); 36 | procedure btCountPrimeNumbersClick(Sender: TObject); 37 | procedure btOpenMsgBoxClick(Sender: TObject); 38 | private 39 | FPool: TThreadPool; 40 | FTask: ITask; 41 | FCancel: ICancel; 42 | procedure UpdateGui(const CancelObj: ICancel; ThreadNum: integer); 43 | procedure PrimeTest(const CancelObj: ICancel); 44 | 45 | class function IsPrime(N: Integer): boolean; 46 | end; 47 | 48 | var 49 | fMainForm: TfMainForm; 50 | 51 | {############################################################################} 52 | implementation 53 | {############################################################################} 54 | 55 | uses 56 | AppEvnts, 57 | StdLib, 58 | MsgBox, 59 | StopWatch, 60 | TaskUtils, 61 | TimeoutUtil; 62 | 63 | {$R *.dfm} 64 | 65 | //=================================================================================================================== 66 | //=================================================================================================================== 67 | procedure TfMainForm.FormActivate(Sender: TObject); 68 | { 69 | var 70 | Task: ITask; 71 | } 72 | begin 73 | self.Constraints.MinWidth := self.Width; 74 | self.Constraints.MinHeight := self.Height; 75 | 76 | { 77 | Task := TThreadPool.Run(procedure (const C: ICancel) begin Abort; end); 78 | Task.Wait; 79 | Assert(Task.State = TTaskState.Completed); 80 | Assert(Task.UnhandledException = nil); 81 | 82 | Task := TThreadPool.Run(procedure (const C: ICancel) begin raise Exception.Create('test'); end); 83 | Task.Wait(false); 84 | Assert(Task.State = TTaskState.Failed); 85 | Assert(Task.UnhandledException <> nil); 86 | 87 | TMsgBox.Show(Task.UnhandledException.StackTrace); 88 | } 89 | 90 | // create one single cancellation object for all tasks created by this form: 91 | FCancel := TCancelFlag.Create; 92 | 93 | // create a thread pool with two tasks: 94 | 95 | FPool := TThreadPool.Create(3, 10000, 1000, 64); 96 | 97 | FPool.Queue( 98 | procedure (const CancelObj: ICancel) 99 | begin 100 | UpdateGui(CancelObj, 1); 101 | end, 102 | FCancel 103 | ); 104 | 105 | FPool.Queue( 106 | procedure (const CancelObj: ICancel) 107 | begin 108 | UpdateGui(CancelObj, 2); 109 | end, 110 | FCancel 111 | ); 112 | 113 | // create another task in the default thread pool: 114 | 115 | FTask := TThreadPool.Run( 116 | procedure (const CancelObj: ICancel) 117 | begin 118 | UpdateGui(CancelObj, 3); 119 | end, 120 | FCancel 121 | ); 122 | 123 | // must report true, as there is no timeout: 124 | Assert(TTasks.WaitAll([], TTimeoutTime.Infinite)); 125 | 126 | // must report Timeout, as FTask is not cancelled: 127 | Assert(not TTasks.WaitAll([FTask], TTimeoutTime.Elapsed)); 128 | 129 | // must report Timeout, as FTask is not cancelled: 130 | Assert(TTasks.WaitAny([FTask], TTimeoutTime.Elapsed) = -1); 131 | end; 132 | 133 | 134 | //=================================================================================================================== 135 | //=================================================================================================================== 136 | procedure TfMainForm.FormClose(Sender: TObject; var Action: TCloseAction); 137 | var 138 | b: boolean; 139 | i: integer; 140 | begin 141 | // terminate all tasks running in the context of this form: 142 | FCancel.Cancel; 143 | 144 | // wait for this task with limited message-processing: 145 | FTask.Wait; 146 | 147 | // must return true immediatly, as FTask is already cancelled: 148 | b := TTasks.WaitAll([FTask], TTimeoutTime.Infinite); 149 | Assert(b); 150 | 151 | // must return true immediatly, as FTask is already cancelled: 152 | b := TTasks.WaitAll([FTask], TTimeoutTime.Elapsed); 153 | Assert(b); 154 | 155 | // must return 0 immediatly, as FTask is already cancelled: 156 | i := TTasks.WaitAny([FTask], TTimeoutTime.Infinite); 157 | Assert(i = 0); 158 | 159 | // must return 0 immediatly, as FTask is already cancelled: 160 | i := TTasks.WaitAny([FTask], TTimeoutTime.Elapsed); 161 | Assert(i = 0); 162 | 163 | // just test: queue a large number of tasks, then destroy the thread pool: 164 | for i := 1 to 5000 do begin 165 | FPool.Queue(procedure (const Cancel: ICancel) begin end, nil); 166 | end; 167 | 168 | // The thread pool destructor waits for all its tasks to finish. To prevent a deadlock here, it is mandatory that all 169 | // this tasks use FCancel, and FCancel is set at this point. (This would not apply if the tasks in question do not 170 | // call TGuiThread.Perform().) 171 | FreeObj(FPool); 172 | 173 | self.ModalResult := mrCancel; 174 | end; 175 | 176 | 177 | //=================================================================================================================== 178 | // Executed in a task of the thread pool. 179 | // Manipulates one of the RGB channels of the form's background color. 180 | //=================================================================================================================== 181 | procedure TfMainForm.UpdateGui(const CancelObj: ICancel; ThreadNum: integer); 182 | var 183 | Color: byte; 184 | Up: boolean; 185 | begin 186 | Up := true; 187 | Color := 0; 188 | repeat 189 | Windows.Sleep(15 + 5 * ThreadNum); 190 | 191 | // make Color to count up and down between 0 and 255: 192 | if Up then inc(Color) else dec(Color); 193 | if Color = 0 then Up := true 194 | else if Color = 255 then Up := false; 195 | 196 | TGuiThread.Perform( 197 | procedure () 198 | var 199 | TmpCol: DWORD; 200 | r, g, b: byte; 201 | begin 202 | TmpCol := DWORD(Graphics.ColorToRGB(self.Color)); 203 | r := Windows.GetRValue(TmpCol); 204 | g := Windows.GetGValue(TmpCol); 205 | b := Windows.GetBValue(TmpCol); 206 | case ThreadNum of 207 | 1: r := Color; 208 | 2: g := Color; 209 | 3: b := Color; 210 | end; 211 | self.Color := TColor(Windows.RGB(r,g,b)); 212 | self.lblRGB.Caption := Format('R=%u G=%u B=%u', [r, g, b]); 213 | end, 214 | CancelObj 215 | ); 216 | 217 | until CancelObj.IsCancelled; 218 | end; 219 | 220 | 221 | //=================================================================================================================== 222 | // CPU-burning function: Returns true, if N is a prime number (2, 3, 5, 7, ...) 223 | //=================================================================================================================== 224 | class function TfMainForm.IsPrime(N: int32): boolean; 225 | var 226 | Test: int32; 227 | begin 228 | for Test := 2 to N div 2 do begin 229 | if N mod Test = 0 then exit(false); 230 | end; 231 | exit(true); 232 | end; 233 | 234 | 235 | //=================================================================================================================== 236 | // Executed in a task of the default thread pool. 237 | // https://en.wikipedia.org/wiki/Prime-counting_function 238 | //=================================================================================================================== 239 | procedure TfMainForm.PrimeTest(const CancelObj: ICancel); 240 | const 241 | LowerBound = 2; 242 | //UpperBound = 10; // => 4 243 | //UpperBound = 100; // => 25 244 | //UpperBound = 1000; // => 168 245 | //UpperBound = 100 * 1000; // => 9592 246 | UpperBound = 1000 * 1000; // => 78498 247 | //UpperBound = 10 * 1000 * 1000; // => 664579 248 | var 249 | total: int32; 250 | Watch: TStopWatch; 251 | Seconds: double; 252 | begin 253 | Watch.Start; 254 | 255 | total := 0; 256 | 257 | // count from to and create one task for each value: 258 | 259 | // Under the hoods, this employs a temporary thread pool which only allows the given number of threads to run in 260 | // parallel. 261 | // Personally, I don't think that things like that are a good programming practice, as the overhead is still too 262 | // high for real "high-performance computing". One should not create a high number of some tasks (by using a 263 | // generic ForEach method) without taking the nature of the tasks into account. At the very least, when something is 264 | // supposed to use all available CPU power, the priority of all participating threads should probably be the lowest 265 | // possible. On the other hand, if the tasks are long-running and yield often (for example, database operations), 266 | // such tasks should be queued to the default pool, and this default pool should *not* be limited to the number of 267 | // available CPU cores. 268 | 269 | TParallel.ForEachInt( 270 | LowerBound, // first value 271 | 1, // increment 272 | UpperBound - LowerBound + 1, // number of iterations 273 | System.CPUCount, // number of threads 274 | CancelObj, // to stop when the form is closed 275 | procedure (i: Integer) 276 | begin 277 | if IsPrime(i) then Windows.InterlockedIncrement(total); 278 | end 279 | ); 280 | 281 | Seconds := Watch.ElapsedSecs; 282 | 283 | // displaying the result must be delegated to the GUI thread: 284 | TGuiThread.Perform( 285 | procedure () 286 | begin 287 | lblPrimeResult.Caption := Format('CPU cores used: %d' + CrLf + 'Number of prime numbers between %d and %d: %d' + CrLf + 'Duration: %.3f seconds', [ 288 | System.CPUCount, 289 | LowerBound, 290 | UpperBound, 291 | Total, 292 | Seconds 293 | ]); 294 | TMsgBox.Show('Displayed through TGuiThread.Perform(), blocking the respective task.'); 295 | btCountPrimeNumbers.Enabled := true; 296 | end, 297 | CancelObj 298 | ); 299 | end; 300 | 301 | 302 | //=================================================================================================================== 303 | //=================================================================================================================== 304 | procedure TfMainForm.btCountPrimeNumbersClick(Sender: TObject); 305 | begin 306 | btCountPrimeNumbers.Enabled := false; 307 | lblPrimeResult.Caption := 'Counting...'; 308 | 309 | TThreadPool.Run(self.PrimeTest, FCancel); 310 | end; 311 | 312 | 313 | //=================================================================================================================== 314 | //=================================================================================================================== 315 | procedure TfMainForm.btOpenMsgBoxClick(Sender: TObject); 316 | begin 317 | TMsgBox.Show('Displayed by a regular click event.'); 318 | end; 319 | 320 | end. 321 | -------------------------------------------------------------------------------- /demo/lib/StdLib.pas: -------------------------------------------------------------------------------- 1 | unit StdLib; 2 | 3 | { 4 | Collection of various utility types and helper functions, for any type of application (GUI, command-line, service), 5 | therefore without any VCL dependency. 6 | 7 | It is a very small subset of content of the original unit. 8 | } 9 | 10 | {$include LibOptions.inc} 11 | {$ScopedEnums on} 12 | 13 | interface 14 | 15 | uses Windows, SysUtils; 16 | 17 | const 18 | // char constants: 19 | LF = #10; 20 | CR = #13; 21 | ESC = #27; 22 | // Windows end-of-line constant: 23 | CrLf = #13#10; 24 | 25 | 26 | type 27 | // Exception for Windows API errors (instead of SysUtils.EOSError, for better error messages and better usability): 28 | EOSSysError = class(SysUtils.EOSError) 29 | public 30 | constructor Create(Error: DWORD); 31 | constructor CreateWithMsg(Error: DWORD; const Msg: string); overload; 32 | constructor CreateWithCtx(Error: DWORD; const Ctx: string); overload; 33 | constructor CreateWithCtxFmt(Error: DWORD; const Ctx: string; const Args: array of const); 34 | 35 | class function CreateWithMsg(const Msg: string): EOSSysError; overload; 36 | class function CreateWithCtx(const Ctx: string): EOSSysError; overload; 37 | 38 | class function ErrorMsg(ErrorCode: DWORD; LanguageID: LANGID = 0): string; static; 39 | end; 40 | 41 | 42 | // Hosts methods to update the global format settings when the regional settings of this user session are changed. 43 | TDummy = class 44 | public 45 | class procedure UpdateFormatSettings; static; 46 | class procedure OnSettingChange(Sender: TObject; Flag: Integer; const Section: string; var Result: Longint); 47 | end; 48 | 49 | 50 | // Order of day-month-year in a timestamp string: 51 | TDateOrder = (MDY, DMY, YMD); 52 | 53 | 54 | var 55 | {$ifndef D2010} 56 | FormatSettings: TFormatSettings; // D2009: missing from SysUtils 57 | {$endif} 58 | DateOrder: TDateOrder; // is kept synchronous with or SysUtils.FormatSettings 59 | 60 | // 61 | // Replacements for SysUtils routines (to use EOSSysError): 62 | // 63 | 64 | procedure Win32Check(RetVal: BOOL); overload; 65 | procedure Win32Check(RetVal: BOOL; const Ctx: string); overload; 66 | 67 | 68 | // 69 | // Replacements for SysUtils FreeAndNil ("inline" gives too much code, can be miscompiled by D2009 due to improper 70 | // usage of the "var" argument): 71 | // 72 | 73 | {$ifdef Delphi104} 74 | procedure FreeObj(const [ref] ObjVar: TObject); 75 | {$else} 76 | procedure FreeObj(var ObjVar {: TObject}); 77 | {$endif} 78 | 79 | 80 | {############################################################################} 81 | implementation 82 | {############################################################################} 83 | 84 | 85 | { TDummy } 86 | 87 | //=================================================================================================================== 88 | // During initialization of a GUI application, use this method as global event handler, as shown here 89 | // TApplicationEvents.Create(Application).OnSettingChange := StdLib.TDummy.OnSettingChange; 90 | //=================================================================================================================== 91 | class procedure TDummy.OnSettingChange(Sender: TObject; Flag: Integer; const Section: string; var Result: Longint); 92 | begin 93 | if Section = 'intl' then self.UpdateFormatSettings; 94 | end; 95 | 96 | 97 | //=================================================================================================================== 98 | // Updates the FormatSettings and DateOrder variables. Must be called when the regional settings of the user session have changed. 99 | //=================================================================================================================== 100 | class procedure TDummy.UpdateFormatSettings; 101 | var 102 | buffer: array [0..1] of char; 103 | begin 104 | {$ifndef D2010} 105 | // update global settings: 106 | SysUtils.GetLocaleFormatSettings(Windows.GetThreadLocale, StdLib.FormatSettings); 107 | StdLib.FormatSettings.TwoDigitYearCenturyWindow := SysUtils.TwoDigitYearCenturyWindow; 108 | {$endif} 109 | 110 | // returns '0', '1' or '2': 111 | Windows.GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IDATE, buffer, System.Length(buffer)); 112 | 113 | case buffer[0] of 114 | //'0': DateOrder := TDateOrder.MDY; 115 | '1': DateOrder := TDateOrder.DMY; 116 | '2': DateOrder := TDateOrder.YMD; 117 | else DateOrder := TDateOrder.MDY; 118 | end; 119 | end; 120 | 121 | 122 | { EOSSysError } 123 | 124 | //=================================================================================================================== 125 | // Creates the exception objects with the given error code. 126 | // It generates a better error text then SysUtils.EOSError. 127 | //=================================================================================================================== 128 | constructor EOSSysError.Create(Error: DWORD); 129 | begin 130 | inherited Create(self.ErrorMsg(Error, 0)); 131 | self.ErrorCode := Error; 132 | end; 133 | 134 | 135 | //=================================================================================================================== 136 | // Creates the exception objects with the current Windows error code and the given messsage. 137 | // For special cases in which should be used instead of the original Windows message. 138 | // To be able get correct GetLastError results, this is *not* a constructor! 139 | //=================================================================================================================== 140 | class function EOSSysError.CreateWithMsg(const Msg: string): EOSSysError; 141 | begin 142 | Result := self.CreateWithMsg(Windows.GetLastError, Msg); 143 | end; 144 | 145 | 146 | //=================================================================================================================== 147 | // Creates the exception objects with the given Windows error code and the given messsage. 148 | // For special cases in which should be used instead of the original Windows message. 149 | //=================================================================================================================== 150 | constructor EOSSysError.CreateWithMsg(Error: DWORD; const Msg: string); 151 | begin 152 | inherited Create(Msg); 153 | self.ErrorCode := Error; 154 | end; 155 | 156 | 157 | //=================================================================================================================== 158 | // Creates the exception objects with the current Windows error code, and places in front of the error message. 159 | // To be able get correct GetLastError results, this is *not* a constructor! 160 | //=================================================================================================================== 161 | class function EOSSysError.CreateWithCtx(const Ctx: string): EOSSysError; 162 | begin 163 | Result := self.CreateWithCtx(Windows.GetLastError, Ctx); 164 | end; 165 | 166 | 167 | //=================================================================================================================== 168 | // Creates the exception objects with the given Windows error code, and places in front of the error message. 169 | //=================================================================================================================== 170 | constructor EOSSysError.CreateWithCtx(Error: DWORD; const Ctx: string); 171 | begin 172 | self.Create(Error); 173 | self.Message := Ctx + ': ' + self.Message; 174 | end; 175 | 176 | 177 | //=================================================================================================================== 178 | // Creates the exception objects with the given Windows error code, and places Format(, ) in front of the 179 | // error message. 180 | //=================================================================================================================== 181 | constructor EOSSysError.CreateWithCtxFmt(Error: DWORD; const Ctx: string; const Args: array of const); 182 | begin 183 | self.Create(Error); 184 | self.Message := Format(Ctx, Args) + ': ' + self.Message; 185 | end; 186 | 187 | 188 | //=================================================================================================================== 189 | // Returns the system error message in the language for the given Windows error code. 190 | // SysUtils.SysErrorMessage () uses buffers that are too small and then returns an empty string, for example, for error 191 | // 0x8004D02A (431 chars) or 0x80310092 (495 chars). 192 | // 193 | // LanguageID: If zero, then the GUI language of the calling thread is used, otherwise the specified language. For 194 | // example, the value can be MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US). 195 | //=================================================================================================================== 196 | class function EOSSysError.ErrorMsg(ErrorCode: DWORD; LanguageID: LANGID = 0): string; 197 | 198 | // replace line breaks by a single space: 199 | function _ReplaceCrLf(Buffer: PChar; Len: DWORD): DWORD; 200 | var 201 | idx: DWORD; 202 | c: char; 203 | begin 204 | idx := 0; 205 | Result := 0; 206 | while idx < Len do begin 207 | c := Buffer[idx]; 208 | inc(idx); 209 | if c = CR then continue; 210 | if c = LF then c := ' '; 211 | Buffer[Result] := c; 212 | inc(Result); 213 | end; 214 | end; 215 | 216 | var 217 | Buffer: array [0..1023] of char; 218 | Len: DWORD; 219 | NumStr: string; 220 | begin 221 | repeat 222 | Len := Windows.FormatMessage( 223 | FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY, 224 | nil, ErrorCode, LanguageID, Buffer, System.Length(Buffer), nil 225 | ); 226 | if (Len <> 0) or (LanguageID = 0) then break; 227 | // try again with LanguageID = 0: 228 | LanguageID := 0; 229 | until false; 230 | 231 | if Len = 0 then begin 232 | Result := 'Unknown error'; 233 | end 234 | else begin 235 | 236 | // remove white-space and '.' from the end: 237 | while (Len > 0) and CharInSet(Buffer[Len - 1], [#0..#32, '.']) do Dec(Len); 238 | 239 | System.SetString(Result, Buffer, _ReplaceCrLf(Buffer, Len)); 240 | end; 241 | 242 | if int32(ErrorCode) < 0 then 243 | // HRESULT value: 244 | NumStr := '0x%.8x' 245 | else 246 | NumStr := '%u'; 247 | 248 | Result := Result + ' (Windows Error ' + Format(NumStr, [ErrorCode]) + ')'; 249 | end; 250 | 251 | 252 | //=================================================================================================================== 253 | // If is false, then an EOSSysError exception with the current Windows error is raised. 254 | //=================================================================================================================== 255 | procedure Win32Check(RetVal: BOOL); 256 | begin 257 | if not RetVal then raise EOSSysError.Create(Windows.GetLastError); 258 | end; 259 | 260 | 261 | //=================================================================================================================== 262 | // If is false, then an EOSSysError exception with the current Windows error is raised, that has in 263 | // front of the error message. 264 | //=================================================================================================================== 265 | procedure Win32Check(RetVal: BOOL; const Ctx: string); 266 | begin 267 | if not RetVal then raise EOSSysError.CreateWithCtx(Windows.GetLastError, Ctx); 268 | end; 269 | 270 | 271 | //=================================================================================================================== 272 | // Releases and then set it to nil. 273 | // Like FreeAndNil(), but with key differences: 274 | // (a) The original FreeAndNil() is defined inline, which results in excessive code generation. 275 | // (b) When used inside another inlined procedure, it can produce incorrect code due to a compiler bug in Delphi 2009. 276 | // (c) FreeAndNil() first sets the variable to nil before calling Destroy. This sequence can cause issues if the object 277 | // is still needed during its destruction - for instance, through self-deregistration mechanisms or if the destructor 278 | // waits on other objects which may still refer to the one being destroyed. 279 | //=================================================================================================================== 280 | {$ifdef Delphi104} 281 | procedure FreeObj(const [ref] ObjVar: TObject); 282 | {$else} 283 | procedure FreeObj(var ObjVar {: TObject}); 284 | {$endif} 285 | var 286 | Obj: TObject absolute ObjVar; 287 | tmp: TObject; 288 | begin 289 | if Obj <> nil then begin 290 | tmp := Obj; 291 | PPointer(@Obj)^ := nil; 292 | tmp.Destroy; 293 | end; 294 | end; 295 | 296 | 297 | initialization 298 | TDummy.UpdateFormatSettings; 299 | end. 300 | -------------------------------------------------------------------------------- /source/StdLib.pas: -------------------------------------------------------------------------------- 1 | unit StdLib; 2 | 3 | { 4 | Collection of various utility types and helper functions, for any type of application (GUI, command-line, service), 5 | therefore without any VCL dependency. 6 | 7 | It is a very small subset of content of the original unit. 8 | } 9 | 10 | {$include LibOptions.inc} 11 | {$ScopedEnums on} 12 | 13 | interface 14 | 15 | uses Windows, SysUtils; 16 | 17 | const 18 | // char constants: 19 | LF = #10; 20 | CR = #13; 21 | ESC = #27; 22 | // Windows end-of-line constant: 23 | CrLf = #13#10; 24 | 25 | 26 | type 27 | // Exception for Windows API errors (instead of SysUtils.EOSError, for better error messages and better usability): 28 | EOSSysError = class(SysUtils.EOSError) 29 | public 30 | constructor Create(Error: DWORD); 31 | constructor CreateWithMsg(Error: DWORD; const Msg: string); overload; 32 | constructor CreateWithCtx(Error: DWORD; const Ctx: string); overload; 33 | constructor CreateWithCtxFmt(Error: DWORD; const Ctx: string; const Args: array of const); 34 | 35 | class function CreateWithMsg(const Msg: string): EOSSysError; overload; 36 | class function CreateWithCtx(const Ctx: string): EOSSysError; overload; 37 | 38 | class function ErrorMsg(ErrorCode: DWORD; LanguageID: LANGID = 0): string; static; 39 | end; 40 | 41 | 42 | // Hosts methods to update the global format settings when the regional settings of this user session are changed. 43 | TDummy = class 44 | public 45 | class procedure UpdateFormatSettings; static; 46 | class procedure OnSettingChange(Sender: TObject; Flag: Integer; const Section: string; var Result: Longint); 47 | end; 48 | 49 | 50 | // Order of day-month-year in a timestamp string: 51 | TDateOrder = (MDY, DMY, YMD); 52 | 53 | 54 | var 55 | {$ifndef D2010} 56 | FormatSettings: TFormatSettings; // D2009: missing from SysUtils 57 | {$endif} 58 | DateOrder: TDateOrder; // is kept synchronous with or SysUtils.FormatSettings 59 | 60 | // 61 | // Replacements for SysUtils routines (to use EOSSysError): 62 | // 63 | 64 | procedure Win32Check(RetVal: BOOL); overload; 65 | procedure Win32Check(RetVal: BOOL; const Ctx: string); overload; 66 | 67 | 68 | // 69 | // Replacements for SysUtils FreeAndNil ("inline" gives too much code, can be miscompiled by D2009 due to improper 70 | // usage of the "var" argument): 71 | // 72 | 73 | {$ifdef Delphi104} 74 | procedure FreeObj(const [ref] ObjVar: TObject); 75 | {$else} 76 | procedure FreeObj(var ObjVar {: TObject}); 77 | {$endif} 78 | 79 | 80 | {############################################################################} 81 | implementation 82 | {############################################################################} 83 | 84 | 85 | { TDummy } 86 | 87 | //=================================================================================================================== 88 | // During initialization of a GUI application, use this method as global event handler, as shown here 89 | // TApplicationEvents.Create(Application).OnSettingChange := StdLib.TDummy.OnSettingChange; 90 | //=================================================================================================================== 91 | class procedure TDummy.OnSettingChange(Sender: TObject; Flag: Integer; const Section: string; var Result: Longint); 92 | begin 93 | if Section = 'intl' then self.UpdateFormatSettings; 94 | end; 95 | 96 | 97 | //=================================================================================================================== 98 | // Updates the FormatSettings and DateOrder variables. Must be called when the regional settings of the user session have changed. 99 | //=================================================================================================================== 100 | class procedure TDummy.UpdateFormatSettings; 101 | var 102 | buffer: array [0..1] of char; 103 | begin 104 | {$ifndef D2010} 105 | // update global settings: 106 | SysUtils.GetLocaleFormatSettings(Windows.GetThreadLocale, StdLib.FormatSettings); 107 | StdLib.FormatSettings.TwoDigitYearCenturyWindow := SysUtils.TwoDigitYearCenturyWindow; 108 | {$endif} 109 | 110 | // returns '0', '1' or '2': 111 | Windows.GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IDATE, buffer, System.Length(buffer)); 112 | 113 | case buffer[0] of 114 | //'0': DateOrder := TDateOrder.MDY; 115 | '1': DateOrder := TDateOrder.DMY; 116 | '2': DateOrder := TDateOrder.YMD; 117 | else DateOrder := TDateOrder.MDY; 118 | end; 119 | end; 120 | 121 | 122 | { EOSSysError } 123 | 124 | //=================================================================================================================== 125 | // Creates the exception objects with the given error code. 126 | // It generates a better error text then SysUtils.EOSError. 127 | //=================================================================================================================== 128 | constructor EOSSysError.Create(Error: DWORD); 129 | begin 130 | inherited Create(self.ErrorMsg(Error, 0)); 131 | self.ErrorCode := Error; 132 | end; 133 | 134 | 135 | //=================================================================================================================== 136 | // Creates the exception objects with the current Windows error code and the given messsage. 137 | // For special cases in which should be used instead of the original Windows message. 138 | // To be able get correct GetLastError results, this is *not* a constructor! 139 | //=================================================================================================================== 140 | class function EOSSysError.CreateWithMsg(const Msg: string): EOSSysError; 141 | begin 142 | Result := self.CreateWithMsg(Windows.GetLastError, Msg); 143 | end; 144 | 145 | 146 | //=================================================================================================================== 147 | // Creates the exception objects with the given Windows error code and the given messsage. 148 | // For special cases in which should be used instead of the original Windows message. 149 | //=================================================================================================================== 150 | constructor EOSSysError.CreateWithMsg(Error: DWORD; const Msg: string); 151 | begin 152 | inherited Create(Msg); 153 | self.ErrorCode := Error; 154 | end; 155 | 156 | 157 | //=================================================================================================================== 158 | // Creates the exception objects with the current Windows error code, and places in front of the error message. 159 | // To be able get correct GetLastError results, this is *not* a constructor! 160 | //=================================================================================================================== 161 | class function EOSSysError.CreateWithCtx(const Ctx: string): EOSSysError; 162 | begin 163 | Result := self.CreateWithCtx(Windows.GetLastError, Ctx); 164 | end; 165 | 166 | 167 | //=================================================================================================================== 168 | // Creates the exception objects with the given Windows error code, and places in front of the error message. 169 | //=================================================================================================================== 170 | constructor EOSSysError.CreateWithCtx(Error: DWORD; const Ctx: string); 171 | begin 172 | self.Create(Error); 173 | self.Message := Ctx + ': ' + self.Message; 174 | end; 175 | 176 | 177 | //=================================================================================================================== 178 | // Creates the exception objects with the given Windows error code, and places Format(, ) in front of the 179 | // error message. 180 | //=================================================================================================================== 181 | constructor EOSSysError.CreateWithCtxFmt(Error: DWORD; const Ctx: string; const Args: array of const); 182 | begin 183 | self.Create(Error); 184 | self.Message := Format(Ctx, Args) + ': ' + self.Message; 185 | end; 186 | 187 | 188 | //=================================================================================================================== 189 | // Returns the system error message in the language for the given Windows error code. 190 | // SysUtils.SysErrorMessage () uses buffers that are too small and then returns an empty string, for example, for error 191 | // 0x8004D02A (431 chars) or 0x80310092 (495 chars). 192 | // 193 | // LanguageID: If zero, then the GUI language of the calling thread is used, otherwise the specified language. For 194 | // example, the value can be MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US). 195 | //=================================================================================================================== 196 | class function EOSSysError.ErrorMsg(ErrorCode: DWORD; LanguageID: LANGID = 0): string; 197 | 198 | // replace line breaks by a single space: 199 | function _ReplaceCrLf(Buffer: PChar; Len: DWORD): DWORD; 200 | var 201 | idx: DWORD; 202 | c: char; 203 | begin 204 | idx := 0; 205 | Result := 0; 206 | while idx < Len do begin 207 | c := Buffer[idx]; 208 | inc(idx); 209 | if c = CR then continue; 210 | if c = LF then c := ' '; 211 | Buffer[Result] := c; 212 | inc(Result); 213 | end; 214 | end; 215 | 216 | var 217 | Buffer: array [0..1023] of char; 218 | Len: DWORD; 219 | NumStr: string; 220 | begin 221 | repeat 222 | Len := Windows.FormatMessage( 223 | FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY, 224 | nil, ErrorCode, LanguageID, Buffer, System.Length(Buffer), nil 225 | ); 226 | if (Len <> 0) or (LanguageID = 0) then break; 227 | // try again with LanguageID = 0: 228 | LanguageID := 0; 229 | until false; 230 | 231 | if Len = 0 then begin 232 | Result := 'Unknown error'; 233 | end 234 | else begin 235 | 236 | // remove white-space and '.' from the end: 237 | while (Len > 0) and CharInSet(Buffer[Len - 1], [#0..#32, '.']) do Dec(Len); 238 | 239 | System.SetString(Result, Buffer, _ReplaceCrLf(Buffer, Len)); 240 | end; 241 | 242 | if int32(ErrorCode) < 0 then 243 | // HRESULT value: 244 | NumStr := '0x%.8x' 245 | else 246 | NumStr := '%u'; 247 | 248 | Result := Result + ' (Windows Error ' + Format(NumStr, [ErrorCode]) + ')'; 249 | end; 250 | 251 | 252 | //=================================================================================================================== 253 | // If is false, then an EOSSysError exception with the current Windows error is raised. 254 | //=================================================================================================================== 255 | procedure Win32Check(RetVal: BOOL); 256 | begin 257 | if not RetVal then raise EOSSysError.Create(Windows.GetLastError); 258 | end; 259 | 260 | 261 | //=================================================================================================================== 262 | // If is false, then an EOSSysError exception with the current Windows error is raised, that has in 263 | // front of the error message. 264 | //=================================================================================================================== 265 | procedure Win32Check(RetVal: BOOL; const Ctx: string); 266 | begin 267 | if not RetVal then raise EOSSysError.CreateWithCtx(Windows.GetLastError, Ctx); 268 | end; 269 | 270 | 271 | //=================================================================================================================== 272 | // Releases and then set it to nil. 273 | // Like FreeAndNil(), but with key differences: 274 | // (a) The original FreeAndNil() is defined inline, which results in excessive code generation. 275 | // (b) When used inside another inlined procedure, it can produce incorrect code due to a compiler bug in Delphi 2009. 276 | // (c) FreeAndNil() first sets the variable to nil before calling Destroy. This sequence can cause issues if the object 277 | // is still needed during its destruction - for instance, through self-deregistration mechanisms or if the destructor 278 | // waits on other objects which may still refer to the one being destroyed. 279 | //=================================================================================================================== 280 | {$ifdef Delphi104} 281 | procedure FreeObj(const [ref] ObjVar: TObject); 282 | {$else} 283 | procedure FreeObj(var ObjVar {: TObject}); 284 | {$endif} 285 | var 286 | Obj: TObject absolute ObjVar; 287 | tmp: TObject; 288 | begin 289 | if Obj <> nil then begin 290 | tmp := Obj; 291 | PPointer(@Obj)^ := nil; 292 | tmp.Destroy; 293 | end; 294 | end; 295 | 296 | 297 | initialization 298 | TDummy.UpdateFormatSettings; 299 | end. 300 | -------------------------------------------------------------------------------- /source/GuiTasks.pas: -------------------------------------------------------------------------------- 1 | unit GuiTasks; 2 | 3 | { 4 | Add-on for the "Tasks" unit: 5 | 6 | - TGuiThread: Provides methods that can be used by any thread to inject calls into the GUI thread. 7 | 8 | This unit enables ITask.Wait to operate differently when called from the GUI thread: If not included in the 9 | project, ITask.Wait just blocks the GUI thread which may lead to a dead-lock if the task uses TGuiThread.Perform. 10 | With this unit included, certain Windows messages are still processed during the wait (WM_PAINT, WM_TIMER, posted 11 | messages). This allows windows to be repainted and it allows tasks to perform GUI operations via TGuiThread.Perform. 12 | 13 | See also: https://devblogs.microsoft.com/oldnewthing/tag/modality 14 | } 15 | 16 | {$include LibOptions.inc} 17 | {$ScopedEnums on} 18 | 19 | interface 20 | 21 | uses Windows, WinSlimLock, WindowsSynchronization, TimeoutUtil, Tasks; 22 | 23 | type 24 | //=================================================================================================================== 25 | // References a named or anonymous method/function/procedure suitable for execution by TGuiThread.Perform(). 26 | //=================================================================================================================== 27 | IGuiProcRef = reference to procedure; 28 | 29 | //=================================================================================================================== 30 | // Same as IGuiProcRef, but avoids the lengthy compiler-generated code at the call site when using a named method. 31 | //=================================================================================================================== 32 | TGuiProc = procedure of object; 33 | 34 | 35 | //=================================================================================================================== 36 | // Represents the GUI thread (or the main thread of the program according to System.MainThreadID). 37 | // All public methods are thread-safe. 38 | //=================================================================================================================== 39 | TGuiThread = record 40 | strict private 41 | type 42 | self = TGuiThread; 43 | 44 | // type of a local variable inside Perform(): forms a queue of waiting calls 45 | PActionCtx = ^TActionCtx; 46 | TActionCtx = record 47 | FAction: IGuiProcRef; 48 | FNext: PActionCtx; 49 | FDone: TEvent; 50 | end; 51 | 52 | TQueue = record 53 | strict private 54 | FFirst: PActionCtx; 55 | FLast: PActionCtx; 56 | public 57 | procedure Append(Item: PActionCtx); inline; 58 | function Extract: PActionCtx; inline; 59 | function Dequeue(Item: PActionCtx): boolean; 60 | end; 61 | 62 | class var 63 | FMsgHook: HHOOK; 64 | FCbtHook: HHOOK; 65 | FWaiting: uint32; 66 | FQueue: TQueue; // queue for transferring calls from Perform() to MsgHook() 67 | FQueueLock: TSlimRWLock; // serializes access to FQueue 68 | class function MsgHook(Code: int32; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; static; 69 | class function CbtHook(Code: int32; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; static; 70 | private 71 | class procedure InstallHook; static; 72 | class procedure UninstallHook; static; 73 | public 74 | // This method causes the GUI thread to execute . To do this, Perform waits until the GUI thread wants to 75 | // extract a Windows message from its message queue and lets it execute at this point. 76 | // should be the cancel object of the Perform-calling task (see the following note on avoiding 77 | // deadlocks). 78 | // If is set already before the actual start of , the GUI thread will not be waited for and 79 | // Perform returns without being executed. 80 | // If is set after the actual start of , this has no effect on Perform. 81 | // The return value is false if was not executed due to , otherwise true. 82 | // It is guaranteed that will no longer run after Perform() has returned. 83 | // 84 | // Deadlock avoidance: 85 | // If the GUI thread uses ITask.Wait, TThreadPool.Wait or TThreadPool.Destroy to wait for a task that calls Perform, 86 | // a deadlock occurs because both threads are waiting crosswise for each other. The GUI thread can only safely wait 87 | // for tasks if it has already called ITask.CancelObj.Cancel for the respective tasks: This causes the Perform 88 | // method (called by one such task) to return immediately, which in turn gives the task a chance to exit, which 89 | // ultimately allows the GUI thread to get out of the wait call. 90 | // Note: If this method is called by the GUI thread itself, is just called, without cross-thread 91 | // synchronization, and true is returned. 92 | class function Perform(Action: TGuiProc; CancelObj: ICancel): boolean; overload; static; 93 | class function Perform(const Action: IGuiProcRef; CancelObj: ICancel): boolean; overload; static; 94 | 95 | // This method waits for one of to be signaled, but is simultaneously dispatching a limited range 96 | // of Windows messages (timer, paint, posted messages). 97 | // It returns the index of the first handle in that is signaled, or -1 for timeout. 98 | // This method is used by ITask.Wait() for the GUI thread, but could also be used by other application code. 99 | class function Wait(const Handles: array of THandle; const Timeout: TTimeoutTime): integer; static; 100 | end; 101 | 102 | 103 | {############################################################################} 104 | implementation 105 | {############################################################################} 106 | 107 | uses Messages, SysUtils, StdLib, Classes; 108 | 109 | 110 | { TGuiThread.TQueue } 111 | 112 | //=================================================================================================================== 113 | // Append the item the the end of the queue. 114 | //=================================================================================================================== 115 | procedure TGuiThread.TQueue.Append(Item: PActionCtx); 116 | begin 117 | if FFirst = nil then FFirst := Item 118 | else FLast.FNext := Item; 119 | FLast := Item; 120 | end; 121 | 122 | 123 | //=================================================================================================================== 124 | // Extract the first item from the queue. Returns nil is the queue is empty. 125 | //=================================================================================================================== 126 | function TGuiThread.TQueue.Extract: PActionCtx; 127 | begin 128 | Result := FFirst; 129 | if Result <> nil then begin 130 | FFirst := Result.FNext; 131 | end; 132 | end; 133 | 134 | 135 | //=================================================================================================================== 136 | // Extract the given item from the queue. Returns true if the item is found and extracted, else false. 137 | //=================================================================================================================== 138 | function TGuiThread.TQueue.Dequeue(Item: PActionCtx): boolean; 139 | var 140 | tmp: ^PActionCtx; 141 | begin 142 | tmp := @FFirst; 143 | while tmp^ <> nil do begin 144 | if tmp^ = Item then begin 145 | // found => dequeue: 146 | tmp^ := tmp^^.FNext; 147 | exit(true); 148 | end; 149 | tmp := @tmp^^.FNext; 150 | end; 151 | exit(false) 152 | end; 153 | 154 | 155 | { TGuiThread } 156 | 157 | //=================================================================================================================== 158 | // See description in interface section. 159 | //=================================================================================================================== 160 | class function TGuiThread.Perform(Action: TGuiProc; CancelObj: ICancel): boolean; 161 | var 162 | tmp: IGuiProcRef; 163 | begin 164 | tmp := Action; 165 | Result := self.Perform(tmp, CancelObj); 166 | end; 167 | 168 | 169 | //=================================================================================================================== 170 | // See description in interface section. 171 | //=================================================================================================================== 172 | class function TGuiThread.Perform(const Action: IGuiProcRef; CancelObj: ICancel): boolean; 173 | var 174 | ActionCtx: TActionCtx; 175 | begin 176 | Assert(not System.IsConsole); 177 | Assert(FMsgHook <> 0); 178 | Assert(Assigned(Action)); 179 | 180 | if Windows.GetCurrentThreadId = System.MainThreadID then begin 181 | // called from the GUI thread => no synchronisation needed: 182 | Action(); 183 | exit(true); 184 | end; 185 | 186 | Assert(Assigned(CancelObj)); 187 | 188 | ActionCtx.FAction := Action; 189 | ActionCtx.FDone := TEvent.Create(true); 190 | ActionCtx.FNext := nil; 191 | 192 | try 193 | 194 | // append to work queue: 195 | FQueueLock.AcquireExclusive; 196 | try 197 | FQueue.Append(@ActionCtx); 198 | finally 199 | FQueueLock.ReleaseExclusive; 200 | end; 201 | 202 | // trigger the hook in the GUI thread: 203 | Windows.PostThreadMessage(System.MainThreadID, WM_NULL, 0, 0); 204 | 205 | // Waiting only for ActionCtx.FDone would cause a deadlock if the GUI thread is calling TThreadPool.Destroy or 206 | // TThreadPool.Wait, since both do not execute the message hook! 207 | 208 | if TWaitHandle.WaitAny([ActionCtx.FDone.Handle, CancelObj.CancelWH.Handle], System.INFINITE) = 0 then 209 | exit(true); 210 | 211 | // if the action is still in the queue then remove it and return false: 212 | FQueueLock.AcquireExclusive; 213 | try 214 | if FQueue.Dequeue(@ActionCtx) then exit(false); 215 | finally 216 | FQueueLock.ReleaseExclusive; 217 | end; 218 | 219 | // GUI thread is already executing the action => just wait: 220 | ActionCtx.FDone.Wait(System.INFINITE); 221 | Result := true; 222 | 223 | finally 224 | ActionCtx.FDone.Free; 225 | end; 226 | end; 227 | 228 | 229 | //=================================================================================================================== 230 | // Is executed in the thread for which this message hook was registered (System.MainThreadID) and reacts specifically 231 | // to the WM_NULL message generated by Perform(). 232 | //=================================================================================================================== 233 | class function TGuiThread.MsgHook(Code: int32; wParam: WPARAM; lParam: LPARAM): LRESULT; 234 | var 235 | ActionCtx: PActionCtx; 236 | begin 237 | Assert(Windows.GetCurrentThreadId = System.MainThreadID); 238 | 239 | // values other than HC_ACTION are only possible with WH_JOURNALPLAYBACK and WH_JOURNALRECORD hooks. 240 | 241 | // only react to WM_NULL messages sent via PostThreadMessage() (not to every message): 242 | if (Code = HC_ACTION) and (wParam = PM_REMOVE) and (PMsg(lParam).hwnd = 0) and (PMsg(lParam).message = WM_NULL) then begin 243 | 244 | FQueueLock.AcquireExclusive; 245 | try 246 | ActionCtx := FQueue.Extract; 247 | finally 248 | FQueueLock.ReleaseExclusive; 249 | end; 250 | 251 | if ActionCtx <> nil then begin 252 | 253 | try 254 | 255 | try 256 | ActionCtx.FAction(); 257 | finally 258 | ActionCtx.FDone.SetEvent; 259 | end; 260 | 261 | except 262 | if Assigned(Classes.ApplicationHandleException) then 263 | // this ultimately calls TApplication.HandleException() in GUI applications: 264 | Classes.ApplicationHandleException(nil) 265 | else 266 | // like what SysUtils assigns to System.ExceptProc (i.e. SysUtils.ExceptHandler), but without Halt(1): 267 | SysUtils.ShowException(System.ExceptObject, System.ExceptAddr); 268 | end; 269 | 270 | end; 271 | end; 272 | 273 | Result := Windows.CallNextHookEx(0, Code, wParam, lParam); 274 | end; 275 | 276 | 277 | //=================================================================================================================== 278 | // Is executed in the thread for which this message hook was registered (System.MainThreadID) and suppresses the 279 | // WM_SYSCOMMAND messages while waiting, because the app code certainly doesn't expect the program to be closed while 280 | // waiting, at least when WM_SYSCOMMAND comes from the Windows taskbar (or any other process). 281 | //=================================================================================================================== 282 | class function TGuiThread.CbtHook(Code: int32; wParam: WPARAM; lParam: LPARAM): LRESULT; 283 | begin 284 | Assert(Windows.GetCurrentThreadId = System.MainThreadID); 285 | 286 | if (FWaiting <> 0) and (Code = HCBT_SYSCOMMAND) and (wParam = SC_CLOSE) then 287 | Result := 1 288 | else 289 | Result := Windows.CallNextHookEx(0, Code, wParam, lParam); 290 | end; 291 | 292 | 293 | //=================================================================================================================== 294 | // Registering the Windows hook. Must be done by the GUI thread. 295 | //=================================================================================================================== 296 | class procedure TGuiThread.InstallHook; 297 | begin 298 | // Hooks are automatically unregistered when the thread that *called* SetWindowsHookEx exits. This ownership is not 299 | // mentioned anywhere in the Windows documentation. As the hook procedure runs on the thread specified by the last 300 | // argument (and *not* on the thread that installed the hook), there is no reason for Windows to behave in this 301 | // way. 302 | // https://stackoverflow.com/questions/8564987/list-of-installed-windows-hooks 303 | Assert(Windows.GetCurrentThreadId = System.MainThreadID); 304 | 305 | FMsgHook := Windows.SetWindowsHookEx(WH_GETMESSAGE, self.MsgHook, 0, System.MainThreadID); 306 | FCbtHook := Windows.SetWindowsHookEx(WH_CBT, self.CbtHook, 0, System.MainThreadID); 307 | end; 308 | 309 | 310 | //=================================================================================================================== 311 | // Deregistering the Windows hook. 312 | //=================================================================================================================== 313 | class procedure TGuiThread.UninstallHook; 314 | begin 315 | if FCbtHook <> 0 then begin 316 | Windows.UnhookWindowsHookEx(FCbtHook); 317 | FCbtHook := 0; 318 | end; 319 | if FMsgHook <> 0 then begin 320 | Windows.UnhookWindowsHookEx(FMsgHook); 321 | FMsgHook := 0; 322 | end; 323 | end; 324 | 325 | 326 | //=================================================================================================================== 327 | // See description in interface section. 328 | // https://devblogs.microsoft.com/oldnewthing/20050217-00/?p=36423 "MsgWaitForMultipleObjects and the queue state" 329 | // https://devblogs.microsoft.com/oldnewthing/20060127-17/?p=32493 "Waiting for all handles with MsgWaitForMultipleObjects is a bug waiting to happen" 330 | // https://devblogs.microsoft.com/oldnewthing/20050222-00/?p=36393 "Modality, part 3: The WM_QUIT message" 331 | // https://learn.microsoft.com/en-us/windows/win32/winmsg/about-messages-and-message-queues 332 | // 333 | // Observations: 334 | // - The Windows procedure of windows shown on the Windows taskbar is called with WM_SYSCOMMAND from inside PeekMessage, when 335 | // the close button in the taskbar's mini window is clicked. That is, TApplication.WndProc (or TCustomForm.WndProc) 336 | // may be called with WM_SYSCOMMAND + SC_CLOSE, which in turn generates WM_CLOSE for TApplication.WndProc, which 337 | // calls TApplication.MainForm.Close, all from inside PeekMessage (so, this WM_SYSCOMMAND message is probably sent by 338 | // Explorer via SendNotifyMessage). 339 | // The same happens when trying to terminate the app via Task Manager's first page. 340 | // - Despite what is being said in the PeekMessage() documentation and in the linked articles, WM_QUIT is never 341 | // retrieved if TGuiThread.Wait() is called during the creation of the main form (e.g. during OnActivate). 342 | //=================================================================================================================== 343 | class function TGuiThread.Wait(const Handles: array of THandle; const Timeout: TTimeoutTime): integer; 344 | var 345 | Msg: TMsg; 346 | PostQuitMsg: boolean; 347 | begin 348 | Assert(Windows.GetCurrentThreadId = System.MainThreadID); 349 | 350 | PostQuitMsg := false; 351 | inc(FWaiting); 352 | try 353 | 354 | repeat 355 | 356 | // dispatch all waiting WM_PAINT, WM_TIMER and posted messages (including our WM_NULL); may throw exceptions during 357 | // this processing: 358 | repeat 359 | 360 | // if a timer handler takes longer than its timer interval, it could prevent MsgWaitForMultipleObjects to ever 361 | // return WAIT_TIMEOUT, as there is always some new message => explicit timeout check: 362 | if Timeout.IsElapsed then exit(-1); 363 | 364 | if not Windows.PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_REMOVE) 365 | and not Windows.PeekMessage(Msg, 0, WM_TIMER, WM_TIMER, PM_REMOVE) 366 | and not Windows.PeekMessage(Msg, HWND(-1), 0, 0, PM_REMOVE) 367 | then break; 368 | 369 | Assert(Msg.message <> WM_SYSCOMMAND); 370 | 371 | // deferring WM_QUIT processing until after the wait: 372 | if Msg.message = WM_QUIT then 373 | PostQuitMsg := true 374 | else 375 | Windows.DispatchMessage(Msg); 376 | 377 | until false; 378 | 379 | // returns if a message caused the call to return: 380 | DWORD(Result) := Windows.MsgWaitForMultipleObjects(System.Length(Handles), Addr(Handles)^, false, Timeout.AsMilliSecs, QS_PAINT or QS_TIMER or QS_POSTMESSAGE); 381 | 382 | // signaled or error'd? 383 | until Result <> System.Length(Handles); 384 | 385 | case Result of 386 | WAIT_OBJECT_0 .. WAIT_OBJECT_0 + MAXIMUM_WAIT_OBJECTS - 1: dec(Result, WAIT_OBJECT_0); 387 | WAIT_ABANDONED_0 .. WAIT_ABANDONED_0 + MAXIMUM_WAIT_OBJECTS - 1: dec(Result, WAIT_ABANDONED_0); 388 | WAIT_TIMEOUT: Result := -1; 389 | else raise EOSSysError.Create(Windows.GetLastError); 390 | end; 391 | 392 | finally 393 | dec(FWaiting); 394 | if PostQuitMsg then Windows.PostQuitMessage(0); 395 | end; 396 | end; 397 | 398 | 399 | initialization 400 | TGuiThread.InstallHook; 401 | Tasks.TThreadPool.GuiWaitFor := TGuiThread.Wait; 402 | finalization 403 | Tasks.TThreadPool.GuiWaitFor := nil; 404 | TGuiThread.UninstallHook; 405 | end. 406 | 407 | -------------------------------------------------------------------------------- /source/WindowsSynchronization.pas: -------------------------------------------------------------------------------- 1 | unit WindowsSynchronization; 2 | 3 | { 4 | Implements classes that wrap Windows synchronization objects such as timers, events, mutexes, files, threads and 5 | processes: 6 | 7 | - TWaitHandle: (abstract) represents a Windows synchronization handle. 8 | - TNonFileHandle: represents a handle for which the value 0 is invalid. 9 | - TFileHandle: represents a handle for which the value INVALID_HANDLE_VALUE is invalid. 10 | - TEvent: represents a Windows event (https://docs.microsoft.com/en-us/windows/win32/sync/using-event-objects) 11 | - TWaitableTimer: represents a Timer (https://docs.microsoft.com/en-us/windows/win32/sync/using-waitable-timer-objects). 12 | - TMutex: represents a Mutex (https://docs.microsoft.com/en-us/windows/win32/sync/using-mutex-objects). 13 | } 14 | 15 | 16 | {$include LibOptions.inc} 17 | 18 | interface 19 | 20 | uses 21 | Windows, 22 | TimeoutUtil; 23 | 24 | 25 | type 26 | //=================================================================================================================== 27 | // Base class for encapsulation of Windows kernel objects that have a 'signaled' state. 28 | //=================================================================================================================== 29 | TWaitHandle = class abstract 30 | strict protected 31 | FHandle: THandle; 32 | 33 | public 34 | class function WaitMultiple(Count: uint32; HandleArr: PWOHandleArray; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; overload; static; 35 | class function WaitMultiple(const ObjectArr: array of TWaitHandle; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; overload; static; 36 | 37 | // Waits until either the timeout has expired or the Windows object has been set to 'signaled'. 38 | // For {MilliSecondsTimeout} = 0 the state of the synchronization object is tested without waiting. 39 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 40 | // Returns false for timeout, else true. 41 | function Wait(MilliSecondsTimeout: uint32): boolean; overload; 42 | function Wait(const Timeout: TTimeoutTime): boolean; overload; 43 | 44 | // Waits until either the timeout has expired or one of the TWaitHandle objects has been set to 'signaled'. 45 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 46 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 47 | // Returns -1 on return due to timeout, else the index of the 'signaled' handle. If multiple handles are 48 | // signaled at the same time, the handle with the smallest index is processed and its index is returned. 49 | class function WaitAny(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): integer; overload; 50 | class function WaitAny(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): integer; overload; 51 | 52 | // Waits until either the timeout has expired or one of the Windows objects has been set to 'signaled'. 53 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 54 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 55 | // Returns -1 on return due to timeout, else the index of the 'signaled' handle. If multiple handles are 56 | // signaled at the same time, the handle with the smallest index is processed and its index is returned. 57 | class function WaitAny(const Handles: array of THandle; MilliSecondsTimeout: uint32): integer; overload; 58 | class function WaitAny(const Handles: array of THandle; const Timeout: TTimeoutTime): integer; overload; 59 | 60 | // Waits until either the timeout has expired or all of the TWaitHandle objects has been set to 'signaled'. 61 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 62 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 63 | // Returns false for timeout, else true. 64 | class function WaitAll(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): boolean; overload; 65 | class function WaitAll(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): boolean; overload; 66 | 67 | // Waits until either the timeout has expired or all of the Windows objects has been set to 'signaled'. 68 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 69 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 70 | // Returns false for timeout, else true. 71 | class function WaitAll(const Handles: array of THandle; MilliSecondsTimeout: uint32): boolean; overload; 72 | class function WaitAll(const Handles: array of THandle; const Timeout: TTimeoutTime): boolean; overload; 73 | 74 | // Returns true if the handle is currently 'signaled'. Equivalent to Wait(0), in particular it also resets 75 | // auto-reset objects and requests ownership of a mutex. 76 | function IsSignaled: boolean; 77 | 78 | // Makes the Windows handle available for use in Windows functions. The handle must not be released. 79 | property Handle: THandle read FHandle; 80 | end; 81 | 82 | 83 | //=================================================================================================================== 84 | // Encapsulates Windows kernel objects that have a 'signaled' state and whose invalid value is 0, which applies 85 | // to thread and process handles as well as to handles of synchronization objects. 86 | //=================================================================================================================== 87 | TNonFileHandle = class(TWaitHandle) 88 | public 89 | // Stores the given handle in a private field. 90 | // If the given handle is 0, an EOSSysError exception is thrown for the Windows error code . 91 | constructor Create(Handle: THandle; ErrorCode: DWORD); 92 | 93 | // Closes the handle. 94 | destructor Destroy; override; 95 | end; 96 | 97 | 98 | //=================================================================================================================== 99 | // Encapsulates Windows kernel objects that have a 'signaled' state and whose handle invalid value is INVALID_HANDLE_VALUE, 100 | // which applies to file handle, directory handles and directory-change-notification handles. 101 | //=================================================================================================================== 102 | TFileHandle = class(TWaitHandle) 103 | public 104 | // Stores the given handle in a private field. 105 | // If the given handle is INVALID_HANDLE_VALUE, an EOSSysError exception is thrown for the Windows error code . 106 | constructor Create(Handle: THandle; ErrorCode: DWORD); 107 | 108 | // Closes the handle. 109 | destructor Destroy; override; 110 | end; 111 | 112 | 113 | // How CreateNamed constructors work regarding named synchronization objects: 114 | THandleOpenMode = ( 115 | homOpen, // the Windows object must already exist, otherwise an exception is thrown 116 | homCreateNew, // the Windows object must not yet exist, otherwise an exception is thrown 117 | homCreateOrOpen // if the Windows object exists it will be opened, otherwise it will be created 118 | ); 119 | 120 | 121 | //=================================================================================================================== 122 | // Implements an event. The 'signaled' state can explicitly be set and reset by the application. 123 | //=================================================================================================================== 124 | TEvent = class(TNonFileHandle) 125 | public 126 | // Createas an anonymous Windows Event object. 127 | // If {ManualReset} is false, the signaled state is automatically reset by the operating system when a wait call 128 | // has reacted to the signaled state of the event object. 129 | // If {ManualReset} is true, the signaled state is retained until it is explicitly reset by the application. 130 | constructor Create(ManualReset: boolean); 131 | 132 | // Createas a named Windows Event object. 133 | // If an existing event is openend, {ManualReset} is ignored. 134 | constructor CreateNamed(OpenMode: THandleOpenMode; const Name: string; ManualReset: boolean); 135 | 136 | // Sets the event to the 'signaled' state. 137 | procedure SetEvent; 138 | 139 | // Sets the event to the 'not signaled' state. 140 | procedure ResetEvent; 141 | end; 142 | 143 | 144 | //=================================================================================================================== 145 | // Implements a mutex. The state of a mutex object is signaled when it is not owned by any thread. 146 | // A thread must use one of the wait functions to request ownership. Note, that calling IsSignaled() *also* requests 147 | // ownership! 148 | // 149 | // If an owned Windows Mutex object is closed without being explicitly released, the act of closing will *not* change 150 | // its state (the owning thread still owns it). Only when the owning thread ends, the status of the mutex changes to 151 | // "abandoned". This special status is not returned by this wrapper, as it does not come into play when mutex objects 152 | // are used within the same process and by using this wrapper class. 153 | //=================================================================================================================== 154 | TMutex = class(TNonFileHandle) 155 | public 156 | // Creates an anonymous unowned Windows Mutex object. 157 | constructor Create; 158 | 159 | // Createas a named unowned Windows Mutex object. 160 | constructor CreateNamed(OpenMode: THandleOpenMode; const Name: string); 161 | 162 | // Releases the mutex and closes the handle. 163 | destructor Destroy; override; 164 | 165 | // Releases ownership, which sets the object to 'signaled'. 166 | // If the calling thread does not own the mutex, an exception is thrown. 167 | procedure Release; 168 | end; 169 | 170 | 171 | //=================================================================================================================== 172 | // Implements a timer that is 'signaled' once after a given time or at periodic intervals. 173 | // If the timer expires, although it is still 'signaled' from the last expiration, nothing happens and the timer 174 | // object remains 'signaled'. 175 | //=================================================================================================================== 176 | TWaitableTimer = class(TNonFileHandle) 177 | public 178 | // Creates a Windows Waitable Timer object that is not initially signaled. 179 | // If {ManualReset} is false, the signaled state is automatically reset by the operating system when a wait call 180 | // has reacted to the signaled state of the timer object. 181 | // If {ManualReset} is true, the signaled state is retained until it is explicitly reset by the application. 182 | constructor Create(ManualReset: boolean); 183 | 184 | // Starts or restarts the timer with the given parameters. 185 | // FirstTimeMilliSeconds: If non-zero, the timer is set to 'not signaled' and it will become 'signaled' after this 186 | // time has elapsed; if zero, the timer is immediately set to 'signaled'. 187 | // RepeatTimeMilliSeconds: If not zero, the timer is restarted automatically after each expiration. 188 | // (this restart does not reset the signaled state). 189 | procedure Start(FirstTimeMilliSeconds: uint32; RepeatTimeMilliSeconds: uint32 = 0); 190 | 191 | // Stops the timer. The signaled state of the timer object is *not* changed. 192 | // If the timer is not started, nothing happens. 193 | procedure Stop; 194 | 195 | // Stops the timer and resets the signaled state of the timer object. 196 | // If the timer is not started, nothing happens. 197 | procedure Reset; 198 | end; 199 | 200 | 201 | {############################################################################} 202 | implementation 203 | {############################################################################} 204 | 205 | uses 206 | StdLib; 207 | 208 | const 209 | TicksPerMillisec = int64(10 * 1000); // 100ns intervals per ms 210 | 211 | 212 | { TWaitHandle } 213 | 214 | //=================================================================================================================== 215 | // Returns -1 for timeout, otherwise the index of the signaled handle. If multiple handles are signaled, then the 216 | // index of the first one in is returned. 217 | // The wait is not "alertable". Abandoned mutexes are considered 'signaled'. 218 | // must contain between 1 and 64 elements, otherwise EOSSysError with ERROR_INVALID_PARAMETER is raised. 219 | //=================================================================================================================== 220 | class function TWaitHandle.WaitMultiple(Count: uint32; HandleArr: PWOHandleArray; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; 221 | begin 222 | // up to MAXIMUM_WAIT_OBJECTS handles: 223 | DWORD(Result) := Windows.WaitForMultipleObjects(Count, HandleArr, WaitAll, MilliSecondsTimeout); 224 | case Result of 225 | WAIT_OBJECT_0 .. WAIT_OBJECT_0 + MAXIMUM_WAIT_OBJECTS - 1: dec(Result, WAIT_OBJECT_0); 226 | WAIT_ABANDONED_0 .. WAIT_ABANDONED_0 + MAXIMUM_WAIT_OBJECTS - 1: dec(Result, WAIT_ABANDONED_0); 227 | WAIT_TIMEOUT: Result := -1; 228 | else raise EOSSysError.Create(Windows.GetLastError); 229 | end; 230 | end; 231 | 232 | 233 | //=================================================================================================================== 234 | // Returns -1 for timeout, otherwise the index of the signaled object. If multiple objects are signaled, then the 235 | // index of the first one in is returned. 236 | // The wait is not "alertable". Abandoned mutexes are considered 'signaled'. 237 | // must contain between 1 and 64 elements, otherwise EOSSysError with ERROR_INVALID_PARAMETER is raised. 238 | //=================================================================================================================== 239 | class function TWaitHandle.WaitMultiple(const ObjectArr: array of TWaitHandle; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; 240 | var 241 | Handles: Windows.TWOHandleArray; 242 | i: integer; 243 | begin 244 | if System.Length(ObjectArr) > System.Length(Handles) then 245 | raise EOSSysError.Create(ERROR_INVALID_PARAMETER); 246 | 247 | for i := System.Length(ObjectArr) - 1 downto 0 do begin 248 | Handles[i] := ObjectArr[i].FHandle; 249 | end; 250 | 251 | Result := TWaitHandle.WaitMultiple(System.Length(ObjectArr), @Handles, MilliSecondsTimeout, WaitAll); 252 | end; 253 | 254 | 255 | //=================================================================================================================== 256 | //=================================================================================================================== 257 | function TWaitHandle.Wait(MilliSecondsTimeout: uint32): boolean; 258 | begin 259 | case Windows.WaitForSingleObject(FHandle, MilliSecondsTimeout) of 260 | WAIT_OBJECT_0, WAIT_ABANDONED_0: Result := true; 261 | WAIT_TIMEOUT: Result := false; 262 | else raise EOSSysError.Create(Windows.GetLastError); 263 | end; 264 | end; 265 | 266 | 267 | //=================================================================================================================== 268 | //=================================================================================================================== 269 | function TWaitHandle.IsSignaled: boolean; 270 | begin 271 | Result := self.Wait(0); 272 | end; 273 | 274 | 275 | //=================================================================================================================== 276 | //=================================================================================================================== 277 | function TWaitHandle.Wait(const Timeout: TTimeoutTime): boolean; 278 | begin 279 | Result := self.Wait(Timeout.AsMilliSecs); 280 | end; 281 | 282 | 283 | //=================================================================================================================== 284 | //=================================================================================================================== 285 | class function TWaitHandle.WaitAny(const Handles: array of THandle; MilliSecondsTimeout: uint32): integer; 286 | begin 287 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), MilliSecondsTimeout, false); 288 | end; 289 | 290 | 291 | //=================================================================================================================== 292 | //=================================================================================================================== 293 | class function TWaitHandle.WaitAny(const Handles: array of THandle; const Timeout: TTimeoutTime): integer; 294 | begin 295 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), Timeout.AsMilliSecs, false); 296 | end; 297 | 298 | 299 | //=================================================================================================================== 300 | //=================================================================================================================== 301 | class function TWaitHandle.WaitAll(const Handles: array of THandle; MilliSecondsTimeout: uint32): boolean; 302 | begin 303 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), MilliSecondsTimeout, true) >= 0; 304 | end; 305 | 306 | 307 | //=================================================================================================================== 308 | //=================================================================================================================== 309 | class function TWaitHandle.WaitAll(const Handles: array of THandle; const Timeout: TTimeoutTime): boolean; 310 | begin 311 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), Timeout.AsMilliSecs, true) >= 0; 312 | end; 313 | 314 | 315 | //=================================================================================================================== 316 | //=================================================================================================================== 317 | class function TWaitHandle.WaitAny(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): integer; 318 | begin 319 | Result := self.WaitMultiple(Objects, MilliSecondsTimeout, false); 320 | end; 321 | 322 | 323 | //=================================================================================================================== 324 | //=================================================================================================================== 325 | class function TWaitHandle.WaitAny(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): integer; 326 | begin 327 | Result := self.WaitMultiple(Objects, Timeout.AsMilliSecs, false); 328 | end; 329 | 330 | 331 | //=================================================================================================================== 332 | //=================================================================================================================== 333 | class function TWaitHandle.WaitAll(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): boolean; 334 | begin 335 | Result := self.WaitMultiple(Objects, MilliSecondsTimeout, true) >= 0; 336 | end; 337 | 338 | 339 | //=================================================================================================================== 340 | //=================================================================================================================== 341 | class function TWaitHandle.WaitAll(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): boolean; 342 | begin 343 | Result := self.WaitMultiple(Objects, Timeout.AsMilliSecs, true) >= 0; 344 | end; 345 | 346 | 347 | { TNonFileHandle } 348 | 349 | //=================================================================================================================== 350 | //=================================================================================================================== 351 | constructor TNonFileHandle.Create(Handle: THandle; ErrorCode: DWORD); 352 | begin 353 | FHandle := Handle; 354 | if Handle = 0 then raise EOSSysError.Create(ErrorCode); 355 | 356 | inherited Create; 357 | end; 358 | 359 | 360 | //=================================================================================================================== 361 | //=================================================================================================================== 362 | destructor TNonFileHandle.Destroy; 363 | begin 364 | if FHandle <> 0 then begin 365 | Windows.CloseHandle(FHandle); 366 | FHandle := 0; 367 | end; 368 | 369 | inherited; 370 | end; 371 | 372 | 373 | { TFileHandle } 374 | 375 | //=================================================================================================================== 376 | //=================================================================================================================== 377 | constructor TFileHandle.Create(Handle: THandle; ErrorCode: DWORD); 378 | begin 379 | FHandle := Handle; 380 | if Handle = INVALID_HANDLE_VALUE then raise EOSSysError.Create(ErrorCode); 381 | 382 | inherited Create; 383 | end; 384 | 385 | 386 | //=================================================================================================================== 387 | //=================================================================================================================== 388 | destructor TFileHandle.Destroy; 389 | begin 390 | if FHandle <> INVALID_HANDLE_VALUE then begin 391 | Windows.CloseHandle(FHandle); 392 | FHandle := INVALID_HANDLE_VALUE; 393 | end; 394 | 395 | inherited; 396 | end; 397 | 398 | 399 | { TWaitableTimer } 400 | 401 | {$if not declared(CreateWaitableTimerEx)} 402 | function CreateWaitableTimerEx( 403 | lpTimerAttributes: PSecurityAttributes; 404 | lpTimerName: PChar; 405 | dwFlags: DWORD; 406 | dwDesiredAccess: DWORD 407 | ): THandle; stdcall; external Windows.kernel32 name {$ifdef UNICODE}'CreateWaitableTimerExW'{$else}'CreateWaitableTimerExA'{$endif}; 408 | {$ifend} 409 | 410 | const 411 | TIMER_MODIFY_STATE = $0002; 412 | CREATE_WAITABLE_TIMER_MANUAL_RESET = $00000001; 413 | 414 | //=================================================================================================================== 415 | //=================================================================================================================== 416 | constructor TWaitableTimer.Create(ManualReset: boolean); 417 | var 418 | Flags: DWORD; 419 | Handle: THandle; 420 | begin 421 | Flags := 0; 422 | if ManualReset then Flags := Flags or CREATE_WAITABLE_TIMER_MANUAL_RESET; 423 | Handle := CreateWaitableTimerEx(nil, nil, Flags, SYNCHRONIZE or TIMER_MODIFY_STATE); 424 | inherited Create(Handle, Windows.GetLastError); 425 | end; 426 | 427 | 428 | //=================================================================================================================== 429 | //=================================================================================================================== 430 | procedure TWaitableTimer.Start(FirstTimeMilliSeconds: uint32; RepeatTimeMilliSeconds: uint32 = 0); 431 | var 432 | DueTimeArg: int64; 433 | begin 434 | DueTimeArg := int64(FirstTimeMilliSeconds) * -TicksPerMillisec; 435 | 436 | Win32Check( Windows.SetWaitableTimer(FHandle, DueTimeArg, RepeatTimeMilliSeconds, nil, nil, false) ); 437 | end; 438 | 439 | 440 | //=================================================================================================================== 441 | //=================================================================================================================== 442 | procedure TWaitableTimer.Stop; 443 | begin 444 | Win32Check( Windows.CancelWaitableTimer(FHandle) ); 445 | end; 446 | 447 | 448 | //=================================================================================================================== 449 | //=================================================================================================================== 450 | procedure TWaitableTimer.Reset; 451 | const 452 | TicksPerDay = 24 * 60 * 60 * 1000 * TicksPerMillisec; 453 | var 454 | DueTimeArg: int64; 455 | begin 456 | DueTimeArg := -TicksPerDay; 457 | 458 | // to reset the signaled state (without signaling it when currently non-signaled!), a non-null dummy period must be set briefly: 459 | Win32Check( 460 | Windows.SetWaitableTimer(FHandle, DueTimeArg, 0, nil, nil, false) 461 | and Windows.CancelWaitableTimer(FHandle) 462 | ); 463 | end; 464 | 465 | 466 | { TEvent } 467 | 468 | {$if not declared(CreateEventEx)} 469 | function CreateEventEx( 470 | lpMutexAttributes: PSecurityAttributes; 471 | lpName: PChar; 472 | dwFlags: DWORD; 473 | dwDesiredAccess: DWORD 474 | ): THandle; stdcall; external Windows.kernel32 name {$ifdef UNICODE}'CreateEventExW'{$else}'CreateEventExA'{$endif}; 475 | {$ifend} 476 | 477 | const 478 | CREATE_EVENT_MANUAL_RESET = $00000001; 479 | 480 | //=================================================================================================================== 481 | //=================================================================================================================== 482 | constructor TEvent.Create(ManualReset: boolean); 483 | var 484 | Flags: DWORD; 485 | Handle: THandle; 486 | begin 487 | Flags := 0; 488 | if ManualReset then Flags := Flags or CREATE_EVENT_MANUAL_RESET; 489 | Handle := CreateEventEx(nil, nil, Flags, SYNCHRONIZE or EVENT_MODIFY_STATE); 490 | inherited Create(Handle, Windows.GetLastError); 491 | end; 492 | 493 | 494 | //=================================================================================================================== 495 | //=================================================================================================================== 496 | constructor TEvent.CreateNamed(OpenMode: THandleOpenMode; const Name: string; ManualReset: boolean); 497 | var 498 | Flags: DWORD; 499 | Handle: THandle; 500 | begin 501 | if OpenMode = homOpen then begin 502 | // open an existing Windows event: 503 | Handle := Windows.OpenEvent(SYNCHRONIZE or EVENT_MODIFY_STATE, false, PChar(Name)); 504 | end 505 | else begin 506 | // create an new Windows event (but it will be opened, if it already exists and the permissions are right): 507 | Flags := 0; 508 | if ManualReset then Flags := Flags or CREATE_EVENT_MANUAL_RESET; 509 | 510 | Handle := CreateEventEx(nil, PChar(Name), Flags, SYNCHRONIZE or EVENT_MODIFY_STATE); 511 | 512 | if (Handle <> 0) and (OpenMode = homCreateNew) and (Windows.GetLastError = ERROR_ALREADY_EXISTS) then begin 513 | // already exists, but a new one is demanded: 514 | Windows.CloseHandle(Handle); 515 | raise EOSSysError.Create(ERROR_ALREADY_EXISTS); 516 | end; 517 | end; 518 | 519 | inherited Create(Handle, Windows.GetLastError); 520 | end; 521 | 522 | 523 | //=================================================================================================================== 524 | //=================================================================================================================== 525 | procedure TEvent.SetEvent; 526 | begin 527 | Win32Check( Windows.SetEvent(FHandle) ); 528 | end; 529 | 530 | 531 | //=================================================================================================================== 532 | //=================================================================================================================== 533 | procedure TEvent.ResetEvent; 534 | begin 535 | Win32Check( Windows.ResetEvent(FHandle) ); 536 | end; 537 | 538 | 539 | { TMutex } 540 | 541 | // better prototype than in WinApi.Windows: 542 | function CreateMutexEx( 543 | lpMutexAttributes: PSecurityAttributes; 544 | lpName: PChar; 545 | dwFlags: DWORD; 546 | dwDesiredAccess: DWORD 547 | ): THandle; stdcall; external Windows.kernel32 name {$ifdef UNICODE}'CreateMutexExW'{$else}'CreateMutexExA'{$endif}; 548 | 549 | 550 | //=================================================================================================================== 551 | //=================================================================================================================== 552 | constructor TMutex.Create; 553 | var 554 | Handle: THandle; 555 | begin 556 | Handle := CreateMutexEx(nil, nil, 0, SYNCHRONIZE or MUTEX_MODIFY_STATE); 557 | inherited Create(Handle, Windows.GetLastError); 558 | end; 559 | 560 | 561 | //=================================================================================================================== 562 | //=================================================================================================================== 563 | constructor TMutex.CreateNamed(OpenMode: THandleOpenMode; const Name: string); 564 | var 565 | Handle: THandle; 566 | begin 567 | if OpenMode = homOpen then begin 568 | // open an existing Windows mutex: 569 | Handle := Windows.OpenMutex(SYNCHRONIZE or MUTEX_MODIFY_STATE, false, PChar(Name)); 570 | end 571 | else begin 572 | // create an new Windows mutex (but it will be opened, if it already exists and the permissions are right): 573 | Handle := CreateMutexEx(nil, PChar(Name), 0, SYNCHRONIZE or MUTEX_MODIFY_STATE); 574 | 575 | if (Handle <> 0) and (OpenMode = homCreateNew) and (Windows.GetLastError = ERROR_ALREADY_EXISTS) then begin 576 | // already exists, but a new one is demanded: 577 | Windows.CloseHandle(Handle); 578 | raise EOSSysError.Create(ERROR_ALREADY_EXISTS); 579 | end; 580 | end; 581 | 582 | inherited Create(Handle, Windows.GetLastError); 583 | end; 584 | 585 | 586 | //=================================================================================================================== 587 | //=================================================================================================================== 588 | destructor TMutex.Destroy; 589 | begin 590 | // always try to release ownership before closing the handle: 591 | if FHandle <> 0 then Windows.ReleaseMutex(FHandle); 592 | inherited; 593 | end; 594 | 595 | 596 | //=================================================================================================================== 597 | //=================================================================================================================== 598 | procedure TMutex.Release; 599 | begin 600 | Win32Check( Windows.ReleaseMutex(FHandle) ); 601 | end; 602 | 603 | end. 604 | -------------------------------------------------------------------------------- /demo/lib/WindowsSynchronization.pas: -------------------------------------------------------------------------------- 1 | unit WindowsSynchronization; 2 | 3 | { 4 | Implements classes that wrap Windows synchronization objects such as timers, events, mutexes, files, threads and 5 | processes: 6 | 7 | - TWaitHandle: (abstract) represents a Windows synchronization handle. 8 | - TNonFileHandle: represents a handle for which the value 0 is invalid. 9 | - TFileHandle: represents a handle for which the value INVALID_HANDLE_VALUE is invalid. 10 | - TEvent: represents a Windows event (https://docs.microsoft.com/en-us/windows/win32/sync/using-event-objects) 11 | - TWaitableTimer: represents a Timer (https://docs.microsoft.com/en-us/windows/win32/sync/using-waitable-timer-objects). 12 | - TMutex: represents a Mutex (https://docs.microsoft.com/en-us/windows/win32/sync/using-mutex-objects). 13 | } 14 | 15 | 16 | {$include LibOptions.inc} 17 | 18 | interface 19 | 20 | uses 21 | Windows, 22 | TimeoutUtil; 23 | 24 | 25 | type 26 | //=================================================================================================================== 27 | // Base class for encapsulation of Windows kernel objects that have a 'signaled' state. 28 | //=================================================================================================================== 29 | TWaitHandle = class abstract 30 | strict protected 31 | FHandle: THandle; 32 | 33 | public 34 | class function WaitMultiple(Count: uint32; HandleArr: PWOHandleArray; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; overload; static; 35 | class function WaitMultiple(const ObjectArr: array of TWaitHandle; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; overload; static; 36 | 37 | // Waits until either the timeout has expired or the Windows object has been set to 'signaled'. 38 | // For {MilliSecondsTimeout} = 0 the state of the synchronization object is tested without waiting. 39 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 40 | // Returns false for timeout, else true. 41 | function Wait(MilliSecondsTimeout: uint32): boolean; overload; 42 | function Wait(const Timeout: TTimeoutTime): boolean; overload; 43 | 44 | // Waits until either the timeout has expired or one of the TWaitHandle objects has been set to 'signaled'. 45 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 46 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 47 | // Returns -1 on return due to timeout, else the index of the 'signaled' handle. If multiple handles are 48 | // signaled at the same time, the handle with the smallest index is processed and its index is returned. 49 | class function WaitAny(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): integer; overload; 50 | class function WaitAny(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): integer; overload; 51 | 52 | // Waits until either the timeout has expired or one of the Windows objects has been set to 'signaled'. 53 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 54 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 55 | // Returns -1 on return due to timeout, else the index of the 'signaled' handle. If multiple handles are 56 | // signaled at the same time, the handle with the smallest index is processed and its index is returned. 57 | class function WaitAny(const Handles: array of THandle; MilliSecondsTimeout: uint32): integer; overload; 58 | class function WaitAny(const Handles: array of THandle; const Timeout: TTimeoutTime): integer; overload; 59 | 60 | // Waits until either the timeout has expired or all of the TWaitHandle objects has been set to 'signaled'. 61 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 62 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 63 | // Returns false for timeout, else true. 64 | class function WaitAll(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): boolean; overload; 65 | class function WaitAll(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): boolean; overload; 66 | 67 | // Waits until either the timeout has expired or all of the Windows objects has been set to 'signaled'. 68 | // For {MilliSecondsTimeout} = 0 the state of the synchronization objects is tested without waiting. 69 | // For {MilliSecondsTimeout} = INFINITE there is no timeout. 70 | // Returns false for timeout, else true. 71 | class function WaitAll(const Handles: array of THandle; MilliSecondsTimeout: uint32): boolean; overload; 72 | class function WaitAll(const Handles: array of THandle; const Timeout: TTimeoutTime): boolean; overload; 73 | 74 | // Returns true if the handle is currently 'signaled'. Equivalent to Wait(0), in particular it also resets 75 | // auto-reset objects and requests ownership of a mutex. 76 | function IsSignaled: boolean; 77 | 78 | // Makes the Windows handle available for use in Windows functions. The handle must not be released. 79 | property Handle: THandle read FHandle; 80 | end; 81 | 82 | 83 | //=================================================================================================================== 84 | // Encapsulates Windows kernel objects that have a 'signaled' state and whose invalid value is 0, which applies 85 | // to thread and process handles as well as to handles of synchronization objects. 86 | //=================================================================================================================== 87 | TNonFileHandle = class(TWaitHandle) 88 | public 89 | // Stores the given handle in a private field. 90 | // If the given handle is 0, an EOSSysError exception is thrown for the Windows error code . 91 | constructor Create(Handle: THandle; ErrorCode: DWORD); 92 | 93 | // Closes the handle. 94 | destructor Destroy; override; 95 | end; 96 | 97 | 98 | //=================================================================================================================== 99 | // Encapsulates Windows kernel objects that have a 'signaled' state and whose handle invalid value is INVALID_HANDLE_VALUE, 100 | // which applies to file handle, directory handles and directory-change-notification handles. 101 | //=================================================================================================================== 102 | TFileHandle = class(TWaitHandle) 103 | public 104 | // Stores the given handle in a private field. 105 | // If the given handle is INVALID_HANDLE_VALUE, an EOSSysError exception is thrown for the Windows error code . 106 | constructor Create(Handle: THandle; ErrorCode: DWORD); 107 | 108 | // Closes the handle. 109 | destructor Destroy; override; 110 | end; 111 | 112 | 113 | // How CreateNamed constructors work regarding named synchronization objects: 114 | THandleOpenMode = ( 115 | homOpen, // the Windows object must already exist, otherwise an exception is thrown 116 | homCreateNew, // the Windows object must not yet exist, otherwise an exception is thrown 117 | homCreateOrOpen // if the Windows object exists it will be opened, otherwise it will be created 118 | ); 119 | 120 | 121 | //=================================================================================================================== 122 | // Implements an event. The 'signaled' state can explicitly be set and reset by the application. 123 | //=================================================================================================================== 124 | TEvent = class(TNonFileHandle) 125 | public 126 | // Createas an anonymous Windows Event object. 127 | // If {ManualReset} is false, the signaled state is automatically reset by the operating system when a wait call 128 | // has reacted to the signaled state of the event object. 129 | // If {ManualReset} is true, the signaled state is retained until it is explicitly reset by the application. 130 | constructor Create(ManualReset: boolean); 131 | 132 | // Createas a named Windows Event object. 133 | // If an existing event is openend, {ManualReset} is ignored. 134 | constructor CreateNamed(OpenMode: THandleOpenMode; const Name: string; ManualReset: boolean); 135 | 136 | // Sets the event to the 'signaled' state. 137 | procedure SetEvent; 138 | 139 | // Sets the event to the 'not signaled' state. 140 | procedure ResetEvent; 141 | end; 142 | 143 | 144 | //=================================================================================================================== 145 | // Implements a mutex. The state of a mutex object is signaled when it is not owned by any thread. 146 | // A thread must use one of the wait functions to request ownership. Note, that calling IsSignaled() *also* requests 147 | // ownership! 148 | // 149 | // If an owned Windows Mutex object is closed without being explicitly released, the act of closing will *not* change 150 | // its state (the owning thread still owns it). Only when the owning thread ends, the status of the mutex changes to 151 | // "abandoned". This special status is not returned by this wrapper, as it does not come into play when mutex objects 152 | // are used within the same process and by using this wrapper class. 153 | //=================================================================================================================== 154 | TMutex = class(TNonFileHandle) 155 | public 156 | // Creates an anonymous unowned Windows Mutex object. 157 | constructor Create; 158 | 159 | // Createas a named unowned Windows Mutex object. 160 | constructor CreateNamed(OpenMode: THandleOpenMode; const Name: string); 161 | 162 | // Releases the mutex and closes the handle. 163 | destructor Destroy; override; 164 | 165 | // Releases ownership, which sets the object to 'signaled'. 166 | // If the calling thread does not own the mutex, an exception is thrown. 167 | procedure Release; 168 | end; 169 | 170 | 171 | //=================================================================================================================== 172 | // Implements a timer that is 'signaled' once after a given time or at periodic intervals. 173 | // If the timer expires, although it is still 'signaled' from the last expiration, nothing happens and the timer 174 | // object remains 'signaled'. 175 | //=================================================================================================================== 176 | TWaitableTimer = class(TNonFileHandle) 177 | public 178 | // Creates a Windows Waitable Timer object that is not initially signaled. 179 | // If {ManualReset} is false, the signaled state is automatically reset by the operating system when a wait call 180 | // has reacted to the signaled state of the timer object. 181 | // If {ManualReset} is true, the signaled state is retained until it is explicitly reset by the application. 182 | constructor Create(ManualReset: boolean); 183 | 184 | // Starts or restarts the timer with the given parameters. 185 | // FirstTimeMilliSeconds: If non-zero, the timer is set to 'not signaled' and it will become 'signaled' after this 186 | // time has elapsed; if zero, the timer is immediately set to 'signaled'. 187 | // RepeatTimeMilliSeconds: If not zero, the timer is restarted automatically after each expiration. 188 | // (this restart does not reset the signaled state). 189 | procedure Start(FirstTimeMilliSeconds: uint32; RepeatTimeMilliSeconds: uint32 = 0); 190 | 191 | // Stops the timer. The signaled state of the timer object is *not* changed. 192 | // If the timer is not started, nothing happens. 193 | procedure Stop; 194 | 195 | // Stops the timer and resets the signaled state of the timer object. 196 | // If the timer is not started, nothing happens. 197 | procedure Reset; 198 | end; 199 | 200 | 201 | {############################################################################} 202 | implementation 203 | {############################################################################} 204 | 205 | uses 206 | StdLib; 207 | 208 | const 209 | TicksPerMillisec = int64(10 * 1000); // 100ns intervals per ms 210 | 211 | 212 | { TWaitHandle } 213 | 214 | //=================================================================================================================== 215 | // Returns -1 for timeout, otherwise the index of the signaled handle. If multiple handles are signaled, then the 216 | // index of the first one in is returned. 217 | // The wait is not "alertable". Abandoned mutexes are considered 'signaled'. 218 | // must contain between 1 and 64 elements, otherwise EOSSysError with ERROR_INVALID_PARAMETER is raised. 219 | //=================================================================================================================== 220 | class function TWaitHandle.WaitMultiple(Count: uint32; HandleArr: PWOHandleArray; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; 221 | begin 222 | // up to MAXIMUM_WAIT_OBJECTS handles: 223 | DWORD(Result) := Windows.WaitForMultipleObjects(Count, HandleArr, WaitAll, MilliSecondsTimeout); 224 | case Result of 225 | WAIT_OBJECT_0 .. WAIT_OBJECT_0 + MAXIMUM_WAIT_OBJECTS - 1: dec(Result, WAIT_OBJECT_0); 226 | WAIT_ABANDONED_0 .. WAIT_ABANDONED_0 + MAXIMUM_WAIT_OBJECTS - 1: dec(Result, WAIT_ABANDONED_0); 227 | WAIT_TIMEOUT: Result := -1; 228 | else raise EOSSysError.Create(Windows.GetLastError); 229 | end; 230 | end; 231 | 232 | 233 | //=================================================================================================================== 234 | // Returns -1 for timeout, otherwise the index of the signaled object. If multiple objects are signaled, then the 235 | // index of the first one in is returned. 236 | // The wait is not "alertable". Abandoned mutexes are considered 'signaled'. 237 | // must contain between 1 and 64 elements, otherwise EOSSysError with ERROR_INVALID_PARAMETER is raised. 238 | //=================================================================================================================== 239 | class function TWaitHandle.WaitMultiple(const ObjectArr: array of TWaitHandle; MilliSecondsTimeout: uint32; WaitAll: BOOL): integer; 240 | var 241 | Handles: Windows.TWOHandleArray; 242 | i: integer; 243 | begin 244 | if System.Length(ObjectArr) > System.Length(Handles) then 245 | raise EOSSysError.Create(ERROR_INVALID_PARAMETER); 246 | 247 | for i := System.Length(ObjectArr) - 1 downto 0 do begin 248 | Handles[i] := ObjectArr[i].FHandle; 249 | end; 250 | 251 | Result := TWaitHandle.WaitMultiple(System.Length(ObjectArr), @Handles, MilliSecondsTimeout, WaitAll); 252 | end; 253 | 254 | 255 | //=================================================================================================================== 256 | //=================================================================================================================== 257 | function TWaitHandle.Wait(MilliSecondsTimeout: uint32): boolean; 258 | begin 259 | case Windows.WaitForSingleObject(FHandle, MilliSecondsTimeout) of 260 | WAIT_OBJECT_0, WAIT_ABANDONED_0: Result := true; 261 | WAIT_TIMEOUT: Result := false; 262 | else raise EOSSysError.Create(Windows.GetLastError); 263 | end; 264 | end; 265 | 266 | 267 | //=================================================================================================================== 268 | //=================================================================================================================== 269 | function TWaitHandle.IsSignaled: boolean; 270 | begin 271 | Result := self.Wait(0); 272 | end; 273 | 274 | 275 | //=================================================================================================================== 276 | //=================================================================================================================== 277 | function TWaitHandle.Wait(const Timeout: TTimeoutTime): boolean; 278 | begin 279 | Result := self.Wait(Timeout.AsMilliSecs); 280 | end; 281 | 282 | 283 | //=================================================================================================================== 284 | //=================================================================================================================== 285 | class function TWaitHandle.WaitAny(const Handles: array of THandle; MilliSecondsTimeout: uint32): integer; 286 | begin 287 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), MilliSecondsTimeout, false); 288 | end; 289 | 290 | 291 | //=================================================================================================================== 292 | //=================================================================================================================== 293 | class function TWaitHandle.WaitAny(const Handles: array of THandle; const Timeout: TTimeoutTime): integer; 294 | begin 295 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), Timeout.AsMilliSecs, false); 296 | end; 297 | 298 | 299 | //=================================================================================================================== 300 | //=================================================================================================================== 301 | class function TWaitHandle.WaitAll(const Handles: array of THandle; MilliSecondsTimeout: uint32): boolean; 302 | begin 303 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), MilliSecondsTimeout, true) >= 0; 304 | end; 305 | 306 | 307 | //=================================================================================================================== 308 | //=================================================================================================================== 309 | class function TWaitHandle.WaitAll(const Handles: array of THandle; const Timeout: TTimeoutTime): boolean; 310 | begin 311 | Result := self.WaitMultiple(System.Length(Handles), Addr(Handles), Timeout.AsMilliSecs, true) >= 0; 312 | end; 313 | 314 | 315 | //=================================================================================================================== 316 | //=================================================================================================================== 317 | class function TWaitHandle.WaitAny(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): integer; 318 | begin 319 | Result := self.WaitMultiple(Objects, MilliSecondsTimeout, false); 320 | end; 321 | 322 | 323 | //=================================================================================================================== 324 | //=================================================================================================================== 325 | class function TWaitHandle.WaitAny(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): integer; 326 | begin 327 | Result := self.WaitMultiple(Objects, Timeout.AsMilliSecs, false); 328 | end; 329 | 330 | 331 | //=================================================================================================================== 332 | //=================================================================================================================== 333 | class function TWaitHandle.WaitAll(const Objects: array of TWaitHandle; MilliSecondsTimeout: uint32): boolean; 334 | begin 335 | Result := self.WaitMultiple(Objects, MilliSecondsTimeout, true) >= 0; 336 | end; 337 | 338 | 339 | //=================================================================================================================== 340 | //=================================================================================================================== 341 | class function TWaitHandle.WaitAll(const Objects: array of TWaitHandle; const Timeout: TTimeoutTime): boolean; 342 | begin 343 | Result := self.WaitMultiple(Objects, Timeout.AsMilliSecs, true) >= 0; 344 | end; 345 | 346 | 347 | { TNonFileHandle } 348 | 349 | //=================================================================================================================== 350 | //=================================================================================================================== 351 | constructor TNonFileHandle.Create(Handle: THandle; ErrorCode: DWORD); 352 | begin 353 | FHandle := Handle; 354 | if Handle = 0 then raise EOSSysError.Create(ErrorCode); 355 | 356 | inherited Create; 357 | end; 358 | 359 | 360 | //=================================================================================================================== 361 | //=================================================================================================================== 362 | destructor TNonFileHandle.Destroy; 363 | begin 364 | if FHandle <> 0 then begin 365 | Windows.CloseHandle(FHandle); 366 | FHandle := 0; 367 | end; 368 | 369 | inherited; 370 | end; 371 | 372 | 373 | { TFileHandle } 374 | 375 | //=================================================================================================================== 376 | //=================================================================================================================== 377 | constructor TFileHandle.Create(Handle: THandle; ErrorCode: DWORD); 378 | begin 379 | FHandle := Handle; 380 | if Handle = INVALID_HANDLE_VALUE then raise EOSSysError.Create(ErrorCode); 381 | 382 | inherited Create; 383 | end; 384 | 385 | 386 | //=================================================================================================================== 387 | //=================================================================================================================== 388 | destructor TFileHandle.Destroy; 389 | begin 390 | if FHandle <> INVALID_HANDLE_VALUE then begin 391 | Windows.CloseHandle(FHandle); 392 | FHandle := INVALID_HANDLE_VALUE; 393 | end; 394 | 395 | inherited; 396 | end; 397 | 398 | 399 | { TWaitableTimer } 400 | 401 | {$if not declared(CreateWaitableTimerEx)} 402 | function CreateWaitableTimerEx( 403 | lpTimerAttributes: PSecurityAttributes; 404 | lpTimerName: PChar; 405 | dwFlags: DWORD; 406 | dwDesiredAccess: DWORD 407 | ): THandle; stdcall; external Windows.kernel32 name {$ifdef UNICODE}'CreateWaitableTimerExW'{$else}'CreateWaitableTimerExA'{$endif}; 408 | {$ifend} 409 | 410 | const 411 | TIMER_MODIFY_STATE = $0002; 412 | CREATE_WAITABLE_TIMER_MANUAL_RESET = $00000001; 413 | 414 | //=================================================================================================================== 415 | //=================================================================================================================== 416 | constructor TWaitableTimer.Create(ManualReset: boolean); 417 | var 418 | Flags: DWORD; 419 | Handle: THandle; 420 | begin 421 | Flags := 0; 422 | if ManualReset then Flags := Flags or CREATE_WAITABLE_TIMER_MANUAL_RESET; 423 | Handle := CreateWaitableTimerEx(nil, nil, Flags, SYNCHRONIZE or TIMER_MODIFY_STATE); 424 | inherited Create(Handle, Windows.GetLastError); 425 | end; 426 | 427 | 428 | //=================================================================================================================== 429 | //=================================================================================================================== 430 | procedure TWaitableTimer.Start(FirstTimeMilliSeconds: uint32; RepeatTimeMilliSeconds: uint32 = 0); 431 | var 432 | DueTimeArg: int64; 433 | begin 434 | DueTimeArg := int64(FirstTimeMilliSeconds) * -TicksPerMillisec; 435 | 436 | Win32Check( Windows.SetWaitableTimer(FHandle, DueTimeArg, RepeatTimeMilliSeconds, nil, nil, false) ); 437 | end; 438 | 439 | 440 | //=================================================================================================================== 441 | //=================================================================================================================== 442 | procedure TWaitableTimer.Stop; 443 | begin 444 | Win32Check( Windows.CancelWaitableTimer(FHandle) ); 445 | end; 446 | 447 | 448 | //=================================================================================================================== 449 | //=================================================================================================================== 450 | procedure TWaitableTimer.Reset; 451 | const 452 | TicksPerDay = 24 * 60 * 60 * 1000 * TicksPerMillisec; 453 | var 454 | DueTimeArg: int64; 455 | begin 456 | DueTimeArg := -TicksPerDay; 457 | 458 | // to reset the signaled state (without signaling it when currently non-signaled!), a non-null dummy period must be set briefly: 459 | Win32Check( 460 | Windows.SetWaitableTimer(FHandle, DueTimeArg, 0, nil, nil, false) 461 | and Windows.CancelWaitableTimer(FHandle) 462 | ); 463 | end; 464 | 465 | 466 | { TEvent } 467 | 468 | {$if not declared(CreateEventEx)} 469 | function CreateEventEx( 470 | lpMutexAttributes: PSecurityAttributes; 471 | lpName: PChar; 472 | dwFlags: DWORD; 473 | dwDesiredAccess: DWORD 474 | ): THandle; stdcall; external Windows.kernel32 name {$ifdef UNICODE}'CreateEventExW'{$else}'CreateEventExA'{$endif}; 475 | {$ifend} 476 | 477 | const 478 | CREATE_EVENT_MANUAL_RESET = $00000001; 479 | 480 | //=================================================================================================================== 481 | //=================================================================================================================== 482 | constructor TEvent.Create(ManualReset: boolean); 483 | var 484 | Flags: DWORD; 485 | Handle: THandle; 486 | begin 487 | Flags := 0; 488 | if ManualReset then Flags := Flags or CREATE_EVENT_MANUAL_RESET; 489 | Handle := CreateEventEx(nil, nil, Flags, SYNCHRONIZE or EVENT_MODIFY_STATE); 490 | inherited Create(Handle, Windows.GetLastError); 491 | end; 492 | 493 | 494 | //=================================================================================================================== 495 | //=================================================================================================================== 496 | constructor TEvent.CreateNamed(OpenMode: THandleOpenMode; const Name: string; ManualReset: boolean); 497 | var 498 | Flags: DWORD; 499 | Handle: THandle; 500 | begin 501 | if OpenMode = homOpen then begin 502 | // open an existing Windows event: 503 | Handle := Windows.OpenEvent(SYNCHRONIZE or EVENT_MODIFY_STATE, false, PChar(Name)); 504 | end 505 | else begin 506 | // create an new Windows event (but it will be opened, if it already exists and the permissions are right): 507 | Flags := 0; 508 | if ManualReset then Flags := Flags or CREATE_EVENT_MANUAL_RESET; 509 | 510 | Handle := CreateEventEx(nil, PChar(Name), Flags, SYNCHRONIZE or EVENT_MODIFY_STATE); 511 | 512 | if (Handle <> 0) and (OpenMode = homCreateNew) and (Windows.GetLastError = ERROR_ALREADY_EXISTS) then begin 513 | // already exists, but a new one is demanded: 514 | Windows.CloseHandle(Handle); 515 | raise EOSSysError.Create(ERROR_ALREADY_EXISTS); 516 | end; 517 | end; 518 | 519 | inherited Create(Handle, Windows.GetLastError); 520 | end; 521 | 522 | 523 | //=================================================================================================================== 524 | //=================================================================================================================== 525 | procedure TEvent.SetEvent; 526 | begin 527 | Win32Check( Windows.SetEvent(FHandle) ); 528 | end; 529 | 530 | 531 | //=================================================================================================================== 532 | //=================================================================================================================== 533 | procedure TEvent.ResetEvent; 534 | begin 535 | Win32Check( Windows.ResetEvent(FHandle) ); 536 | end; 537 | 538 | 539 | { TMutex } 540 | 541 | // better prototype than in WinApi.Windows: 542 | function CreateMutexEx( 543 | lpMutexAttributes: PSecurityAttributes; 544 | lpName: PChar; 545 | dwFlags: DWORD; 546 | dwDesiredAccess: DWORD 547 | ): THandle; stdcall; external Windows.kernel32 name {$ifdef UNICODE}'CreateMutexExW'{$else}'CreateMutexExA'{$endif}; 548 | 549 | 550 | //=================================================================================================================== 551 | //=================================================================================================================== 552 | constructor TMutex.Create; 553 | var 554 | Handle: THandle; 555 | begin 556 | Handle := CreateMutexEx(nil, nil, 0, SYNCHRONIZE or MUTEX_MODIFY_STATE); 557 | inherited Create(Handle, Windows.GetLastError); 558 | end; 559 | 560 | 561 | //=================================================================================================================== 562 | //=================================================================================================================== 563 | constructor TMutex.CreateNamed(OpenMode: THandleOpenMode; const Name: string); 564 | var 565 | Handle: THandle; 566 | begin 567 | if OpenMode = homOpen then begin 568 | // open an existing Windows mutex: 569 | Handle := Windows.OpenMutex(SYNCHRONIZE or MUTEX_MODIFY_STATE, false, PChar(Name)); 570 | end 571 | else begin 572 | // create an new Windows mutex (but it will be opened, if it already exists and the permissions are right): 573 | Handle := CreateMutexEx(nil, PChar(Name), 0, SYNCHRONIZE or MUTEX_MODIFY_STATE); 574 | 575 | if (Handle <> 0) and (OpenMode = homCreateNew) and (Windows.GetLastError = ERROR_ALREADY_EXISTS) then begin 576 | // already exists, but a new one is demanded: 577 | Windows.CloseHandle(Handle); 578 | raise EOSSysError.Create(ERROR_ALREADY_EXISTS); 579 | end; 580 | end; 581 | 582 | inherited Create(Handle, Windows.GetLastError); 583 | end; 584 | 585 | 586 | //=================================================================================================================== 587 | //=================================================================================================================== 588 | destructor TMutex.Destroy; 589 | begin 590 | // always try to release ownership before closing the handle: 591 | if FHandle <> 0 then Windows.ReleaseMutex(FHandle); 592 | inherited; 593 | end; 594 | 595 | 596 | //=================================================================================================================== 597 | //=================================================================================================================== 598 | procedure TMutex.Release; 599 | begin 600 | Win32Check( Windows.ReleaseMutex(FHandle) ); 601 | end; 602 | 603 | end. 604 | --------------------------------------------------------------------------------