From 5bcdee9a4e9d0d62d70e03133649e6b6c5d7bbe5 Mon Sep 17 00:00:00 2001 From: beNative Date: Mon, 9 Nov 2015 18:19:55 +0100 Subject: [PATCH] - Removed AsyncCalls demo project as it is not supported anymore by the author (Andreas Hausladen). --- Concepts.Registration.pas | 4 - Concepts.dpr | 2 - Concepts.dproj | 30 +- Concepts.inc | 2 - Forms/Concepts.AsyncCalls.Form.dfm | 80 - Forms/Concepts.AsyncCalls.Form.pas | 121 - Libraries/AsyncCalls/AsyncCalls.html | 661 ----- Libraries/AsyncCalls/AsyncCalls.pas | 3525 -------------------------- 8 files changed, 19 insertions(+), 4406 deletions(-) delete mode 100644 Forms/Concepts.AsyncCalls.Form.dfm delete mode 100644 Forms/Concepts.AsyncCalls.Form.pas delete mode 100644 Libraries/AsyncCalls/AsyncCalls.html delete mode 100644 Libraries/AsyncCalls/AsyncCalls.pas diff --git a/Concepts.Registration.pas b/Concepts.Registration.pas index d4b91792..13dc95d8 100644 --- a/Concepts.Registration.pas +++ b/Concepts.Registration.pas @@ -65,10 +65,6 @@ implementation Concepts.Spring.Utils.Form, {$ENDIF} - {$IFDEF ASYNCCALLS} - Concepts.AsyncCalls.Form, - {$ENDIF} - {$IFDEF BTMEMORYMODULE} Concepts.BTMemoryModule.Form, {$ENDIF} diff --git a/Concepts.dpr b/Concepts.dpr index 5febfc0f..97754ece 100644 --- a/Concepts.dpr +++ b/Concepts.dpr @@ -6,7 +6,6 @@ uses Forms, Vcl.Themes, Vcl.Styles, - AsyncCalls in 'Libraries\AsyncCalls\AsyncCalls.pas', BTMemoryModule in 'Libraries\BTMemoryModule\BTMemoryModule.pas', ChromeTabs in 'Libraries\TChromeTabs\Lib\ChromeTabs.pas', ChromeTabsClasses in 'Libraries\TChromeTabs\Lib\ChromeTabsClasses.pas', @@ -16,7 +15,6 @@ uses ChromeTabsThreadTimer in 'Libraries\TChromeTabs\Lib\ChromeTabsThreadTimer.pas', ChromeTabsTypes in 'Libraries\TChromeTabs\Lib\ChromeTabsTypes.pas', ChromeTabsUtils in 'Libraries\TChromeTabs\Lib\ChromeTabsUtils.pas', - Concepts.AsyncCalls.Form in 'Forms\Concepts.AsyncCalls.Form.pas' {frmAsyncCalls}, Concepts.BTMemoryModule.Form in 'Forms\Concepts.BTMemoryModule.Form.pas' {frmBTMemoryModule}, Concepts.ChromeTabs.Form in 'Forms\Concepts.ChromeTabs.Form.pas' {frmChromeTabs}, Concepts.ComponentInspectorTemplate.Form in 'Forms\Concepts.ComponentInspectorTemplate.Form.pas' {frmPropertyInspector}, diff --git a/Concepts.dproj b/Concepts.dproj index 11b0e5ba..2fc68d70 100644 --- a/Concepts.dproj +++ b/Concepts.dproj @@ -133,7 +133,6 @@ MainSource - @@ -143,9 +142,6 @@ - -
frmAsyncCalls
-
frmBTMemoryModule
 @@ -578,30 +574,42 @@ True - + - Concepts.exe + .\ true - - + + Concepts.exe true - + - Concepts.exe + .\ true - + .\ true + + + Concepts.exe + true + + + + + Concepts.exe + true + + .\ diff --git a/Concepts.inc b/Concepts.inc index d4fc22ff..5ecc064c 100644 --- a/Concepts.inc +++ b/Concepts.inc @@ -37,8 +37,6 @@ {$DEFINE DDUCE} { DevExpress - http://www.devexpress.com/Products/VCL/ } {$DEFINE DEVEXPRESS} -{ AsyncCalls.pas } -{.$DEFINE ASYNCCALLS} { RTTEye } {$DEFINE RTTEYE} { BTMemoryModule.pas } diff --git a/Forms/Concepts.AsyncCalls.Form.dfm b/Forms/Concepts.AsyncCalls.Form.dfm deleted file mode 100644 index d94c4de5..00000000 --- a/Forms/Concepts.AsyncCalls.Form.dfm +++ /dev/null @@ -1,80 +0,0 @@ -object frmAsyncCalls: TfrmAsyncCalls - Left = 0 - Top = 0 - ClientHeight = 293 - ClientWidth = 516 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - OldCreateOrder = False - DesignSize = ( - 516 - 293) - PixelsPerInch = 96 - TextHeight = 13 - object sbrMain: TStatusBar - Left = 0 - Top = 274 - Width = 516 - Height = 19 - Panels = < - item - Width = 50 - end - item - Width = 50 - end - item - Width = 50 - end> - end - object mmoFiles: TMemo - Left = 8 - Top = 8 - Width = 130 - Height = 260 - Anchors = [akLeft, akTop, akBottom] - TabOrder = 1 - end - object btnGetFiles: TButton - Left = 442 - Top = 8 - Width = 74 - Height = 25 - Action = actGetFiles - Anchors = [akTop, akRight] - TabOrder = 2 - end - object mmoFiles2: TMemo - Left = 144 - Top = 8 - Width = 145 - Height = 260 - Anchors = [akLeft, akTop, akBottom] - TabOrder = 3 - end - object mmoFiles3: TMemo - Left = 295 - Top = 8 - Width = 141 - Height = 260 - Anchors = [akLeft, akTop, akBottom] - TabOrder = 4 - end - object aclMain: TActionList - Images = imlMain - Left = 240 - Top = 72 - object actGetFiles: TAction - Caption = 'actGetFiles' - OnExecute = actGetFilesExecute - end - end - object imlMain: TImageList - Left = 288 - Top = 144 - end -end diff --git a/Forms/Concepts.AsyncCalls.Form.pas b/Forms/Concepts.AsyncCalls.Form.pas deleted file mode 100644 index edec8dfd..00000000 --- a/Forms/Concepts.AsyncCalls.Form.pas +++ /dev/null @@ -1,121 +0,0 @@ -{ - Copyright (C) 2013-2015 Tim Sinaeve tim.sinaeve@gmail.com - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -} - -{$I Concepts.inc} - -unit Concepts.AsyncCalls.Form; - -interface - -uses - System.Actions, System.Classes, System.ImageList, - Vcl.Forms, Vcl.ImgList, Vcl.Controls, Vcl.ActnList, Vcl.StdCtrls, - Vcl.ComCtrls, - - AsyncCalls; - -{ Remark: The AsyncCalls library is not supported on x64 and is not - maintained anymore. } - -type - TfrmAsyncCalls = class(TForm) - sbrMain : TStatusBar; - aclMain : TActionList; - imlMain : TImageList; - actGetFiles : TAction; - mmoFiles : TMemo; - btnGetFiles : TButton; - mmoFiles2 : TMemo; - mmoFiles3 : TMemo; - - procedure actGetFilesExecute(Sender: TObject); - end; - -implementation - -{$R *.dfm} - -uses - WinApi.Windows, - System.SysUtils; - -{$REGION 'non-interfaced routines'} -{ The cdecl function GetFiles() has two arguments, a string and an object which - are declared like normal arguments. } -procedure GetFiles(const Directory: string; Filenames: TStrings); cdecl; -var - h: THandle; - FindData: TWin32FindData; -begin - h := FindFirstFile(PChar(Directory + '\*.*'), FindData); - if h <> INVALID_HANDLE_VALUE then - begin - repeat - if (StrComp(FindData.cFileName, '.') <> 0) - and (StrComp(FindData.cFileName, '..') <> 0) then - begin - Filenames.Add(Directory + '\' + FindData.cFileName); - if FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then - GetFiles(Filenames[Filenames.Count - 1], Filenames); - end; - until not FindNextFile(h, FindData); - WinApi.Windows.FindClose(h); - end; -end; -{$ENDREGION} - -{$REGION 'action handlers'} -procedure TfrmAsyncCalls.actGetFilesExecute(Sender: TObject); - var - Dir1, Dir2, Dir3: IAsyncCall; - Dir1Files, Dir2Files, Dir3Files: TStrings; -begin - Dir1Files := TStringList.Create; - Dir2Files := TStringList.Create; - Dir3Files := TStringList.Create; - try - { Call the cdecl function GetFiles() with two arguments, a string and an object. } - Dir1 := AsyncCall(@GetFiles, ['C:\Windows', Dir1Files]); - { Call the cdecl function GetFiles() with two arguments, a string and an object. } - Dir2 := AsyncCall(@GetFiles, ['c:\Tools', Dir2Files]); - { Call the cdecl function GetFiles() with two arguments, a string and an object. } - Dir3 := AsyncCall(@GetFiles, ['C:\Program Files', Dir3Files]); - - { Wait until all async functions have finished their work. While waiting make the UI reacting on user interaction. } - while AsyncMultiSync([Dir1, Dir2, Dir3], True, 10) = WAIT_TIMEOUT do - begin - sbrMain.Panels[0].Text := IntToStr(Dir1Files.Count); - sbrMain.Panels[1].Text := IntToStr(Dir2Files.Count); - sbrMain.Panels[2].Text := IntToStr(Dir3Files.Count); - Application.ProcessMessages; - end; - //Dir1.Sync; // Force the Dir3 function to finish here - - mmoFiles.Lines.Add(Dir1Files[0]); - mmoFiles2.Lines.Add(Dir2Files[0]); - mmoFiles3.Lines.Add(Dir3Files[0]); - sbrMain.Panels[0].Text := IntToStr(Dir1Files.Count); - sbrMain.Panels[1].Text := IntToStr(Dir2Files.Count); - sbrMain.Panels[2].Text := IntToStr(Dir3Files.Count); - finally - Dir3Files.Free; - Dir2Files.Free; - Dir1Files.Free; - end; -end; -{$ENDREGION} - -end. diff --git a/Libraries/AsyncCalls/AsyncCalls.html b/Libraries/AsyncCalls/AsyncCalls.html deleted file mode 100644 index 3161d363..00000000 --- a/Libraries/AsyncCalls/AsyncCalls.html +++ /dev/null @@ -1,661 +0,0 @@ - - -AsyncCalls - asynchronous function calls - - - -

AsyncCalls - asynchronous function calls

-

With AsyncCalls you can execute multiple functions at the same time and synchronize them at every point in -the function or method that started them. This allows you to execute time consuming code whos result is needed -at a later time in a different thread. While the asynchronous function is executed the caller function can do -other tasks.

-

The AsyncCalls unit offers a variety of function prototypes to call asynchronous functions. There are functions -that can call asynchron functions with one single parameter of the type: TObject, Integer, AnsiString, WideString, -IInterface, Extended and Variant. Another function allows you to transfer a user defined value type (record) to the asynchron -function where it can be modify. And there are functions that can call asynchron functions with a variable number of -arguments. The arguments are specified in an const array of const and are automatically -mapped to normal function arguments.

-

Inlined VCL/main thread synchronization is supported starting with version 2.0. With this you can implement -the code that calls a VCL function directly in your thread method without having to use a helper method and -TThread.Synchronize. You have full access to all local variables.
-Version 2.9 introduces the TAsyncCalls class that utilizes generics and anonymous methods (Delphi 2009 or newer).

- - -

Download

-

AsyncCalls.zip Version 2.99 (34 KB)

- -

License

-

The AsyncCalls unit is licensed under the Mozilla Public Licence ("MPL") version 1.1. - -

Installation

-

Extract the AsyncCalls.zip to a directory of your choice. Add the AnyncCalls.pas unit to your project and uses statements.

- -

Requirements

-

Works with Delphi 5, 6, 7, 2005, BDS/Turbo 2006 and RAD Studio 2007, 2009, 2010, XE, XE2

- -

Changelog

-

-

    -
  • Version: 2.99 (2011-12-14):
    - Added: IAsyncCall.CancelInvocation method
    - Added: IAsyncCall.Forget method
    -  
    • - -
  • Version: 2.98 (2011-10-22):
    - Added: Support for RAD Studio XE 64 bit
    -  
    • - -
  • Version: 2.97 (2011-05-21):
    - Fixed: Replaced Suspend/Resume code to prevent a race condition where all threads are suspended but their FSuspended flag is false.
    - Fixed: Exception handling in TAsyncCall.InternExecuteSyncCall. Quit wasn't called after an exception was raised.
    -  
    • - -
  • Version: 2.96 (2010-09-12):
    - Fixed: CoInitialize call was missing
    -  
    • - -
  • Version: 2.95 (2010-09-12):
    - Added: Support for RAD Studio XE
    - Added: Support for UnicodeString
    -  
    • - -
  • Version: 2.92 (2009-08-30):
    - Added: Support for RAD Studio 2010
    - Restored: Delphi 2009 Update 1 fixed the compiler bug. All generic methods are now available.
    -  
    • - -
  • Version 2.91 (2008-09-29):
    - Fixed: All generic methods are now disabled due to an internal compiler error in Delphi 2009
    -  
    • - -
  • Version 2.9 (2008-09-27):
    - Fixed: Window message handling
    - Added: Delphi 2009 support with generics and anonymous methods
    - Added: AsyncCall(Runnable: IAsyncRunnable)
    -  
    • - -
  • Version 2.21 (2008-05-14):
    - Fixed: Bug in AsyncMultiSync
    -  
    • -
  • Version 2.2 (2008-05-12):
    - Fixed: Bugs in main thread AsyncMultiSync implementation
    - Added: Delphi 5 support
    -  
    • -
  • Version 2.1 (2008-05-06):
    - Added: Delphi 6 support
    - Added: Support for "Exit;" in the MainThread block
    - Fixed: Exception handling for Delphi 6, 7 and 2005
    - Fixed: EBX, ESI and ESI are now copied into the synchronized block (Self-Pointer)
    -  
    • -
  • Version 2.0 (2008-05-04):
    - Added: EnterMainThread/LeaveMainThread
    - Added: LocalVclCall, LocalAsyncVclCall, MsgAsyncMultiSync
    - Added: LocalAsyncExec, AsyncExec
    - Added: IAsyncCall.ForceDifferentThread
    - Fixed: Exception handling
    - Removed: Delphi 5 and 6 support
    -   -
  • Version 1.2 (2008-02-10):
    - Added CoInitialize for the threads
    - LocalAsyncCall function
    - Exception handling
    -  
    • -
  • Version 1.1 (2007-08-14):
    - Workaround for TThread.Resume bug
    -  
    • -
  • Version 1.0 (2006-12-23):
    - Fixed: Exception where Thread was destroyed while the finalization code accessed it.
    • -
-

- - -

Example

-
-procedure TForm1.Button3Click(Sender: TObject); -
var -
  Value: Integer; -
begin - -
  TAsyncCalls.Invoke(procedure -
  begin -
    Value := 10; -
    TAsyncCalls.VCLInvoke(procedure -
    begin -
      ShowMessage('The value may not equal 10: ' + IntToStr(Value)); -
    end); -
    Value := 20; -
    TAsyncCalls.VCLSync(procedure -
    begin -
      ShowMessage('The value equals 20: ' + IntToStr(Value)); -
    end); -
    Value := 30; -
  end); -
-
  Sleep(1000); -
end; -
-
-
-{ The cdecl function GetFiles() has two arguments, a string and an object which are declared like normal arguments. } -
procedure GetFiles(const Directory: string; Filenames: TStrings); cdecl; -
var -
  h: THandle; -
  FindData: TWin32FindData; -
begin -
  h := FindFirstFile(PChar(Directory + '\*.*'), FindData); -
  if h <> INVALID_HANDLE_VALUE then -
  begin -
    repeat -
      if (StrComp(FindData.cFileName, '.') <> 0) and (StrComp(FindData.cFileName, '..') <> 0) then -
      begin -
        Filenames.Add(Directory + '\' + FindData.cFileName); -
        if FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then -
          GetFiles(Filenames[Filenames.Count - 1], Filenames); -
      end; -
    until not FindNextFile(h, FindData); -
    Windows.FindClose(h); -
  end; -
end; -
-
procedure TFormMain.ButtonGetFilesClick(Sender: TObject); -
var -
  Dir1, Dir2, Dir3: IAsyncCall; -
  Dir1Files, Dir2Files, Dir3Files: TStrings; -
begin -
  Dir1Files := TStringList.Create; -
  Dir2Files := TStringList.Create; -
  Dir3Files := TStringList.Create; -
  ButtonGetFiles.Enabled := False; -
  try -
    { Call the cdecl function GetFiles() with two arguments, a string and an object. } -
    Dir1 := AsyncCall(@GetFiles, ['C:\Windows', Dir1Files]); -
    { Call the cdecl function GetFiles() with two arguments, a string and an object. } -
    Dir2 := AsyncCall(@GetFiles, ['D:\Html', Dir2Files]); -
    { Call the cdecl function GetFiles() with two arguments, a string and an object. } -
    Dir3 := AsyncCall(@GetFiles, ['E:', Dir3Files]); -
-
    { Wait until both async functions have finished their work. While waiting make the UI reacting on user interaction. } -
    while AsyncMultiSync([Dir1, Dir2], True, 10) = WAIT_TIMEOUT do -
      Application.ProcessMessages; -
    Dir3.Sync; // Force the Dir3 function to finish here -
-
    MemoFiles.Lines.Assign(Dir1Files); -
    MemoFiles.Lines.AddStrings(Dir2Files); -
    MemoFiles.Lines.AddStrings(Dir3Files); -
  finally -
    ButtonGetFiles.Enabled := True; -
    Dir3Files.Free; -
    Dir2Files.Free; -
    Dir1Files.Free; -
  end; -
end; -
- -

 

-
- -

IAsyncCall interface

-

All AsyncCall functions return an IAsyncCall interface that allows to synchronize the functions. -

-  IAsyncCall = interface -
    function Sync: Integer; -
    function Finished: Boolean; -
    function ReturnValue: Integer; -
    function Canceled: Boolean; -
    procedure ForceDifferentThread; -
    procedure CancelInvocation; -
    procedure Forget; -
  end; -
-
    -
  • The Sync method waits until the function is finished and returns the return value of the function which is -undefined for procedures. -
  • The Finished method returns True when the asynchron function is finished. Otherwise it returns False. -
  • The ReturnValue method returns the asynchron function's return value which is undefined for procedures. If -the asynchron function is still executed ReturnValue raises an EAsyncCallError exception. -
  • The Canceled method returns True if the AsyncCall was canceled by CancelInvocation. -
  • The ForceDifferentThread method tells AsyncCalls that the assigned function must -not be executed in the current thread.
    • -
  • The CancelInvocation method stopps the AsyncCall from being invoked. If the AsyncCall is already -processed, a call to CancelInvocation has no effect and the Canceled function will -return False as the AsyncCall wasn't canceled.
    • -
  • The Forget method unlinks the IAsyncCall interface from the internal AsyncCall. This means that -if the last reference to the IAsyncCall interface is gone, the asynchronous call will -be still executed. The interface's methods will throw an exception if called after calling -Forget. The async function must not call into the main thread because it could be executed -after the TThread.Synchronize/Queue mechanism was shut down by the RTL what can cause a -dead lock.
    • -
- - -

 

-

LocalAsyncCall function

-

LocalAsyncCall() executes the given local function/procedure in a separate thread. - The result value of the asynchronous function is returned by IAsyncCall.Sync() and - IAsyncCall.ReturnValue().
- The LocalAsyncExec() function calls the IdleMsgMethod while the local procedure is - executed.

-
-function LocalAsyncCall(LocalProc: TLocalAsyncProc): IAsyncCall; -
function LocalAsyncCallEx(LocalProc: TLocalAsyncProcEx; Param: INT_PTR): IAsyncCall; -
procedure LocalAsyncExec(Proc: TLocalAsyncProc; IdleMsgMethod: TAsyncIdleMsgMethod); -
-
    -
  • LocalProc: A local function that should be executed asynchron. -
-

Example

-
-procedure MainProc(const S: string); -
var -
  Value: Integer; -
  a: IAsyncCall; -
-
  function DoSomething: Integer; -
  begin -
    if S = 'Abc' then -
      Value := 1; -
    Result := 0; -
  end; -
-
begin -
  a := LocalAsyncCall(@DoSomething); -
  // do something -
  a.Sync; -
  LocalAsyncExec(@DoSomething, Application.ProcessMessages); -
end; -
- - - - - -

 

-

VCL synchronization

-

LocalVclCall() executes the given local function/procedure in the main thread. It - uses the TThread.Synchronize function which blocks the current thread. - LocalAsyncVclCall() execute the given local function/procedure in the main thread. - It does not wait for the main thread to execute the function unless the current - thread is the main thread. In that case it executes and waits for the specified - function in the current thread like LocalVclCall().
-
- The result value of the asynchronous function is returned by IAsyncCall.Sync() and - IAsyncCall.ReturnValue().

- -
-procedure LocalVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0); -
function LocalAsyncVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0): IAsyncCall; -
- -

Example

-
-procedure TForm1.MainProc; -
-
  procedure DoSomething; -
-
    procedure UpdateProgressBar(Percentage: Integer); -
    begin -
      ProgressBar.Position := Percentage; -
      Sleep(20); // This delay does not affect the time for the 0..100 loop -
                 // because UpdateProgressBar is non-blocking. -
    end; -
-
    procedure Finished; -
    begin -
      ShowMessage('Finished'); -
    end; -
-
  var -
    I: Integer; -
  begin -
    for I := 0 to 100 do -
    begin -
      // Do some time consuming stuff -
      Sleep(30); -
      LocalAsyncVclCall(@UpdateProgressBar, I); // non-blocking -
    end; -
    LocalVclCall(@Finished); // blocking -
  end; -
-
var -
  a: IAsyncCall; -
begin -
  a := LocalAsyncCall(@DoSomething); -
  a.ForceDifferentThread; // Do not execute in the main thread because this will -
                          // change LocalAyncVclCall into a blocking LocalVclCall -
  // do something -
  //a.Sync; The Compiler will call this for us in the Interface._Release method -
end; -
- - -

 

-

EnterMainThread/LeaveMainThread

-

EnterMainThread/LeaveMainThread can be used to temporary switch to the - main thread. The code that should be synchonized (blocking) has to be put - into a try/finally block and the LeaveMainThread() function must be called - from the finally block. A missing try/finally will lead to an access violation.

-
-procedure EnterMainThread; -
procedure LeaveMainThread; -
-
    -
  • All local variables can be used. (EBP points to the thread's stack while - ESP points the the main thread's stack)
    • -
  • Unhandled exceptions are passed to the surrounding thread.
    • -
  • The integrated Debugger is not able to follow the execution flow. You have - to use break points instead of "Step over/in".
    • -
  • Nested calls to EnterMainThread/LeaveMainThread are ignored. But they must - strictly follow the try/finally structure.
    • -
-

Example

-
-procedure MyThreadProc; -
var -
 S: string; -
begin -
 Assert(GetCurrentThreadId <> MainThreadId); -
 S := 'Hallo, I''m executed in the main thread'; -
-
 EnterMainThread; -
 try -
   Assert(GetCurrentThreadId = MainThreadId); -
   ShowMessage(S); -
 finally -
   LeaveMainThread; -
 end; -
-
 Assert(GetCurrentThreadId <> MainThreadId); -
end; -
- - - - - - -

 

-

AsyncCall functions

-

The AsyncCall() functions start a specified asynchronous function.
-The AsyncExec() function calls the IdleMsgMethod in a loop, while the async. -method is executed.

-
-function AsyncCall(Proc: TAsyncCallArgObjectProc; Arg: TObject): IAsyncCall; overload; -
function AsyncCall(Proc: TAsyncCallArgIntegerProc; Arg: Integer): IAsyncCall; overload; -
function AsyncCall(Proc: TAsyncCallArgStringProc; const Arg: string): IAsyncCall; overload; -
function AsyncCall(Proc: TAsyncCallArgWideStringProc; const Arg: WideString): IAsyncCall; overload; -
function AsyncCall(Proc: TAsyncCallArgInterfaceProc; const Arg: IInterface): IAsyncCall; overload; -
function AsyncCall(Proc: TAsyncCallArgExtendedProc; const Arg: Extended): IAsyncCall; overload; -
function AsyncCallVar(Proc: TAsyncCallArgVariantProc; const Arg: Variant): IAsyncCall; overload; -
-
function AsyncCall(Method: TAsyncCallArgObjectMethod; Arg: TObject): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgIntegerMethod; Arg: Integer): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgStringMethod; const Arg: string): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgWideStringMethod; const Arg: WideString): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgInterfaceMethod; const Arg: IInterface): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgExtendedMethod; const Arg: Extended): IAsyncCall; overload; -
function AsyncCallVar(Method: TAsyncCallArgVariantMethod; const Arg: Variant): IAsyncCall; overload; -
-
function AsyncCall(Method: TAsyncCallArgObjectEvent; Arg: TObject): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgIntegerEvent; Arg: Integer): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgStringEvent; const Arg: string): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgWideStringEvent; const Arg: WideString): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgInterfaceEvent; const Arg: IInterface): IAsyncCall; overload; -
function AsyncCall(Method: TAsyncCallArgExtendedEvent; const Arg: Extended): IAsyncCall; overload; -
function AsyncCallVar(Method: TAsyncCallArgVariantEvent; const Arg: Variant): IAsyncCall; overload; -
-
procedure AsyncExec(Method: TNotifyEvent; Arg: TObject; IdleMsgMethod: TAsyncIdleMsgMethod); -
-
    -
  • Proc/Method: Function that should be executed asynchron. -
  • Arg: User defined argument that is copied to the asynchron function argument. -
-

Example

-
function TestFunc(const Text: string): Integer; -
begin -
  Result := TimeConsumingFuncion(Text); -
end; -
-
a := AsyncCall(TestFunc, 'A Text'); -
- - - -

 

-

AsyncCallEx functions

-

The AsyncCallEx() functions start a specified asynchronous function with a referenced value type (record) that can -be manipulated in the asynchron function.

-
-function AsyncCallEx(Proc: TAsyncCallArgRecordProc; var Arg{: TRecordType}): IAsyncCall; overload; -
function AsyncCallEx(Method: TAsyncCallArgRecordMethod; var Arg{: TRecordType}): IAsyncCall; overload; -
function AsyncCallEx(Method: TAsyncCallArgRecordEvent; var Arg{: TRecordType}): IAsyncCall; overload; -
-
    -
  • Proc/Method: Function that should be executed asynchron. -
  • Arg: User defined value type (record). -
-

Example

-
type -
  TData = record -
    Value: Integer; -
  end; -
-
procedure TestRec(var Data: TData); -
begin -
  Data.Value := 70; -
end; -
-
a := AsyncCallEx(@TestRec, MyData); -
{ Don't access "MyData" here until the async. function has finished. } -
a.Sync; // MyData.Value is now 70 -
- - - -

 

-

AsyncCall functions with a variable number of arguments

-

This AsyncCall() functions start a specified asynchronous function with a variable number of argument. The asynchron function must be declared as -cdecl and the argument's modifier must be const for Variants. All other types can have the -const modified but it is not necessary.

-
-function AsyncCall(Proc: TCdeclFunc; const Args: array of const): IAsyncCall; overload; -
function AsyncCall(Proc: TCdeclMethod; const Args: array of const): IAsyncCall; overload; -
-
    -
  • Proc/Method: Function that should be executed asynchron. -
  • Args: An open array that specifies the asynchron function arguments. The values are either copied or the reference counter - is increased during the execution of the asynchron function. -
- - - -

 

-

AsyncMultiSync

-

AsyncMultiSync() waits for the async calls and other handles to finish. - MsgAsyncMultiSync() waits for the async calls, other handles and the message queue.

-
-function AsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean = True; -
  Milliseconds: Cardinal = INFINITE): Cardinal; -
function AsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle; -
  WaitAll: Boolean = True; Milliseconds: Cardinal = INFINITE): Cardinal; -
function MsgAsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean; -
  Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal; -
function MsgAsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle; -
  WaitAll: Boolean; Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal; -
-
-

Arguments

-
- - - - - - - - - - - - - - - - - - - - - - - - - -
ListAn array of IAsyncCall interfaces for which the function should wait.
HandlesAn array of THandle for which the function should wait.
WaitAll = TrueThe function returns when all listed async calls have - finished. If Milliseconds is INFINITE the async calls - meight be executed in the current thread. - The return value is zero when all async calls have finished. - Otherwise it is WAIT_FAILED.
WaitAll = FalseThe function returns when at least one of the async calls - has finished. The return value is the list index of the - first finished async call. If there was a timeout, the - return value is WAIT_FAILED.
MillisecondsSpecifies the number of milliseconds to wait until a - timeout happens. The value INFINITE lets the function wait - until all async calls have finished.
dwWakeMasksee Windows.MsgWaitForMultipleObjects()
-

Limitations

-

Length(List)+Length(Handles) must not exceed MAXIMUM_ASYNC_WAIT_OBJECTS   (61 elements).

-

Return value

-
-
    -
  • WAIT_TIMEOUT
    - The function timed out
     
    • - -
  • WAIT_OBJECT_0+index
    - The first finished async call
    • -
  • WAIT_OBJECT_0+Length(List)+index
    - The first signaled handle
    • -
  • WAIT_OBJECT_0+Length(List)+Length(Handles)
    - A message was signaled
     
    • - -
  • WAIT_ABANDONED_0+index
    - The abandoned async call
    • -
  • WAIT_ABANDONED_0+Length(List)+index
    - The abandoned handle
     
    • - -
  • WAIT_FAILED
    - The function failed
    • -
-
-
- - - - - - - - -

 

-
-

 

-

AsyncCalls Internals - Thread pool and waiting-queue

-

An execution request is added to the waiting-queue when an async. function is started. This request forces the thread pool to -check if there is an idle/suspended thread that could do the job. If such a thread exists, it is reactivated/resumed. If no thread -is available then it depends on the number of threads in the pool what happens. If the maximum thread number is already reached the -request remains in the waiting-queue. Otherwise a new thread is added to the thread pool.

-

Threads that aren't idle/suspended take the oldest request from the waiting-queue an execute the associated async. function. If the -waiting queue is empty the threads becomes idle/suspended.

- -

 

-

- -

- - - \ No newline at end of file diff --git a/Libraries/AsyncCalls/AsyncCalls.pas b/Libraries/AsyncCalls/AsyncCalls.pas deleted file mode 100644 index 2b5b6f0f..00000000 --- a/Libraries/AsyncCalls/AsyncCalls.pas +++ /dev/null @@ -1,3525 +0,0 @@ -{**************************************************************************************************} -{ } -{ Asynchronous function calls utilizing multiple threads. } -{ } -{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } -{ you may not use this file except in compliance with the License. You may obtain a copy of the } -{ License at http://www.mozilla.org/MPL/ } -{ } -{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } -{ ANY KIND, either express or implied. See the License for the specific language governing rights } -{ and limitations under the License. } -{ } -{ The Original Code is AsyncCalls.pas. } -{ } -{ The Initial Developer of the Original Code is Andreas Hausladen. } -{ Portions created by Andreas Hausladen are Copyright (C) 2006-2011 Andreas Hausladen. } -{ All Rights Reserved. } -{ } -{ Contributor(s): } -{ } -{**************************************************************************************************} -{ } -{ Version: 2.99 (2011-12-14) } -{ Added: IAsyncCall.CancelInvocation method } -{ Added: IAsyncCall.Forget method } -{ } -{ Version: 2.98 (2011-10-22) } -{ Added: Support for Delphi XE2 64bit } -{ } -{ Version: 2.97 (2011-05-21) } -{ Fixed: The thread priority wasn't reset to Normal for new AsyncCall tasks. } -{ Fixed: Replaced Suspend/Resume code to prevent a race condition where all threads are } -{ suspended but their FSuspended flag is false. } -{ Fixed: Exception handling in TAsyncCall.InternExecuteSyncCall. Quit() wasn't called after an } -{ exception was raised. } -{ } -{ Version: 2.96 (2010-09-12) } -{ Fixed: CoInitialize call was missing } -{ } -{ Version: 2.95 (2010-09-12) } -{ Added: Support for RAD Studio XE } -{ Added: Support for UnicodeString } -{ } -{ Version: 2.92 (2009-08-30) } -{ Added: Support for RAD Studio 2010 } -{ Restored: Delphi 2009 Update 1 fixed the compiler bug. All generic methods are now available. } -{ } -{ Version: 2.91 (2008-09-29) } -{ Fixed: All generic methods are now disabled due to an internal compiler error in Delphi 2009 } -{ } -{ Version: 2.9 (2008-09-27) } -{ Fixed: Window message handling } -{ Added: Delphi 2009 support with generics and anonymous methods } -{ Added: AsyncCall(Runnable: IAsyncRunnable) } -{ } -{ Version: 2.21 (2008-05-14) } -{ Fixed: Fixed bug in AsyncMultiSync } -{ } -{ Version: 2.2 (2008-05-12) } -{ Fixed: Bugs in main thread AsyncMultiSync implementation } -{ Added: Delphi 5 support } -{ } -{ Version: 2.1 (2008-05-06) } -{ Added: Delphi 6 support } -{ Added: Support for "Exit;" in the MainThread block } -{ Fixed: Exception handling for Delphi 6, 7 and 2005 } -{ Fixed: EBX, ESI and EDI weren't copied into the synchronized block (e.g. used for Self-Pointer)} -{ } -{ Version: 2.0 (2008-05-04) } -{ Added: EnterMainThread/LeaveMainThread } -{ Added: LocalVclCall, LocalAsyncVclCall, MsgAsyncMultiSync } -{ Added: LocalAsyncExec, AsyncExec } -{ Added: IAsyncCall.ForceDifferentThread } -{ Fixed: Exception handling } -{ Removed: Delphi 5 and 6 support } -{ } -{ Version: 1.2 (2008-02-10) } -{ Added: CoInitialize } -{ Added: LocalAsynCall() function } -{ } -{ Version: 1.1 (2007-08-14) } -{ Fixed: Workaround for TThread.Resume bug } -{ } -{ Version: 1.0 (2006-12-23) } -{ Initial release } -{**************************************************************************************************} -{$A+,B-,C-,D-,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W+,X+,Y+,Z1} - -unit AsyncCalls; - -{.$DEFINE DEBUG_ASYNCCALLS} -{.$DEFINE DEBUG_ASYNCCALLS_ODS} -{.$DEFINE DEBUG_THREADSTATS} - -{$IFDEF MSWINDOWS} - {$IFNDEF CPUX64} - {$DEFINE SUPPORT_LOCAL_FUNCTIONS} - {$ENDIF ~CPUX64} -{$ENDIF MSWINDOWS} - -interface - -{$IFNDEF CONDITIONALEXPRESSIONS} - {$IFDEF VER130} - {$DEFINE DELPHI5} - {$ELSE} - 'Your compiler version is not supported' - {$ENDIF} -{$ELSE} - {$IFDEF VER140} - {$DEFINE DELPHI6} - {.$MESSAGE ERROR 'Your compiler version is not supported'} - {$ELSE} - {$DEFINE DELPHI7_UP} - {$ENDIF} - - {$WARN SYMBOL_PLATFORM OFF} - {$WARN UNIT_PLATFORM OFF} - {$IF CompilerVersion >= 15.0} - {$WARN UNSAFE_TYPE OFF} - {$WARN UNSAFE_CODE OFF} - {$WARN UNSAFE_CAST OFF} - {$IFEND} - - {$IF CompilerVersion >= 18.0} - {$DEFINE SUPPORTS_INLINE} - {$IFEND} - - {$IF CompilerVersion >= 20.0} - {$DEFINE DELPHI2009_UP} - {$IFEND} - - {$IF CompilerVersion >= 21.0} - {$DEFINE DELPHI2010_UP} - {$IFEND} -{$ENDIF} - -{$IFDEF DEBUG_ASYNCCALLS} - {$D+,C+} -{$ENDIF DEBUG_ASYNCCALLS} - -uses - Windows, Messages, SysUtils, Classes, Contnrs, ActiveX, SyncObjs; - -type - {$IFNDEF CONDITIONALEXPRESSIONS} - INT_PTR = Integer; - IInterface = IUnknown; - {$ELSE} - {$IF not declared(INT_PTR)} - INT_PTR = Integer; - {$IFEND} - {$ENDIF} - - TAsyncIdleMsgMethod = procedure of object; - - {$IFDEF SUPPORT_LOCAL_FUNCTIONS} - TCdeclFunc = Pointer; // function(Arg1: Type1; Arg2: Type2; ...); cdecl; - TCdeclMethod = TMethod; // function(Arg1: Type1; Arg2: Type2; ...) of object; cdecl; - TLocalAsyncProc = function: Integer; - TLocalVclProc = function(Param: INT_PTR): INT_PTR; - TLocalAsyncProcEx = function(Param: INT_PTR): INT_PTR; - //TLocalAsyncForLoopProc = function(Index: Integer; SyncLock: TCriticalSection): Boolean; - {$ENDIF SUPPORT_LOCAL_FUNCTIONS} - - TAsyncCallArgObjectProc = function(Arg: TObject): Integer; - TAsyncCallArgIntegerProc = function(Arg: Integer): Integer; - TAsyncCallArgStringProc = function(const Arg: string): Integer; - TAsyncCallArgWideStringProc = function(const Arg: WideString): Integer; - TAsyncCallArgInterfaceProc = function(const Arg: IInterface): Integer; - TAsyncCallArgExtendedProc = function(const Arg: Extended): Integer; - TAsyncCallArgVariantProc = function(const Arg: Variant): Integer; - - TAsyncCallArgObjectMethod = function(Arg: TObject): Integer of object; - TAsyncCallArgIntegerMethod = function(Arg: Integer): Integer of object; - TAsyncCallArgStringMethod = function(const Arg: string): Integer of object; - TAsyncCallArgWideStringMethod = function(const Arg: WideString): Integer of object; - TAsyncCallArgInterfaceMethod = function(const Arg: IInterface): Integer of object; - TAsyncCallArgExtendedMethod = function(const Arg: Extended): Integer of object; - TAsyncCallArgVariantMethod = function(const Arg: Variant): Integer of object; - - TAsyncCallArgObjectEvent = procedure(Arg: TObject) of object; - TAsyncCallArgIntegerEvent = procedure(Arg: Integer) of object; - TAsyncCallArgStringEvent = procedure(const Arg: string) of object; - TAsyncCallArgWideStringEvent = procedure(const Arg: WideString) of object; - TAsyncCallArgInterfaceEvent = procedure(const Arg: IInterface) of object; - TAsyncCallArgExtendedEvent = procedure(const Arg: Extended) of object; - TAsyncCallArgVariantEvent = procedure(const Arg: Variant) of object; - - TAsyncCallArgRecordProc = function(var Arg{: TRecordType}): Integer; - TAsyncCallArgRecordMethod = function(var Arg{: TRecordType}): Integer of object; - TAsyncCallArgRecordEvent = procedure(var Arg{: TRecordType}) of object; - - EAsyncCallError = class(Exception); - - IAsyncCall = interface - { Sync() waits until the asynchronous call has finished and returns the - result value of the called function if that exists. } - function Sync: Integer; - - { Finished() returns True if the asynchronous call has finished. } - function Finished: Boolean; - - { ReturnValue() returns the result of the asynchronous call. It raises an - exception if called before the function has finished. It returns 0 if the - AsyncCall invocation was canceled. } - function ReturnValue: Integer; - - { Canceled() returns True if the AsyncCall was canceled by CancelInvocation(). } - function Canceled: Boolean; - - { ForceDifferentThread() tells AsyncCalls that the assigned function must - not be executed in the current thread. } - procedure ForceDifferentThread; - - { CancelInvocation() stopps the AsyncCall from being invoked. If the AsyncCall is already - processed, a call to CancelInvocation() has no effect and the Canceled() function will - return False as the AsyncCall wasn't canceled. } - procedure CancelInvocation; - - { Forget() unlinks the IAsyncCall interface from the internal AsyncCall. This means that - if the last reference to the IAsyncCall interface is gone, the asynchronous call will - be still executed. The interface's methods will throw an exception if called after calling - Forget(). The async function must not call into the main thread because it could be executed - after the TThread.Synchronize/Queue mechanism was shut down by the RTL what can cause a - dead lock. } - procedure Forget; - end; - - { *** Internal interface. Do not use it *** } - IAsyncCallEx = interface - ['{A31D8EE4-17B6-4FC7-AC94-77887201EE56}'] - function GetEvent: THandle; - function SyncInThisThreadIfPossible: Boolean; - end; - - IAsyncRunnable = interface - ['{1A313BBD-0F89-43AD-8B57-BBA3205F4888}'] - procedure AsyncRun; - end; - - -{ SetMaxAsyncCallThreads() controls how many threads can be used by the - async call thread pool. The thread pool creates threads when they are needed. - Allocated threads are not destroyed until the application has terminated, but - they are suspended if not used. } -procedure SetMaxAsyncCallThreads(MaxThreads: Integer); -{ GetMaxAsyncCallThreads() returns the maximum number of threads that can - exist in the thread pool. } -function GetMaxAsyncCallThreads: Integer; - -{ AsyncCall() executes the given function/procedure in a separate thread. The - result value of the asynchronous function is returned by IAsyncCall.Sync() and - IAsyncCall.ReturnValue(). - The AsyncExec() function calls the IdleMsgMethod in a loop, while the async. - method is executed. - -Example: - function FileAgeAsync(const Filename: string): Integer; - begin - Result := FileAge(Filename); - end; - - var - a: IAsyncCall; - begin - a := AsyncCall(FileAgeAsync, 'C:\Windows\notepad.exe'); - // do something - Age := a.Sync; - end; -} -function AsyncCall(Proc: TAsyncCallArgObjectProc; Arg: TObject): IAsyncCall; overload; -function AsyncCall(Proc: TAsyncCallArgIntegerProc; Arg: Integer): IAsyncCall; overload; -function AsyncCall(Proc: TAsyncCallArgStringProc; const Arg: string): IAsyncCall; overload; -function AsyncCall(Proc: TAsyncCallArgWideStringProc; const Arg: WideString): IAsyncCall; overload; -function AsyncCall(Proc: TAsyncCallArgInterfaceProc; const Arg: IInterface): IAsyncCall; overload; -function AsyncCall(Proc: TAsyncCallArgExtendedProc; const Arg: Extended): IAsyncCall; overload; -function AsyncCallVar(Proc: TAsyncCallArgVariantProc; const Arg: Variant): IAsyncCall; overload; - -function AsyncCall(Method: TAsyncCallArgObjectMethod; Arg: TObject): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgIntegerMethod; Arg: Integer): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgStringMethod; const Arg: string): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgWideStringMethod; const Arg: WideString): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgInterfaceMethod; const Arg: IInterface): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgExtendedMethod; const Arg: Extended): IAsyncCall; overload; -function AsyncCallVar(Method: TAsyncCallArgVariantMethod; const Arg: Variant): IAsyncCall; overload; - -function AsyncCall(Method: TAsyncCallArgObjectEvent; Arg: TObject): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgIntegerEvent; Arg: Integer): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgStringEvent; const Arg: string): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgWideStringEvent; const Arg: WideString): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgInterfaceEvent; const Arg: IInterface): IAsyncCall; overload; -function AsyncCall(Method: TAsyncCallArgExtendedEvent; const Arg: Extended): IAsyncCall; overload; -function AsyncCallVar(Method: TAsyncCallArgVariantEvent; const Arg: Variant): IAsyncCall; overload; - -function AsyncCall(Runnable: IAsyncRunnable): IAsyncCall; overload; - -procedure AsyncExec(Method: TNotifyEvent; Arg: TObject; IdleMsgMethod: TAsyncIdleMsgMethod); - -{$IFDEF SUPPORT_LOCAL_FUNCTIONS} -{ LocalAsyncCall() executes the given local function/procedure in a separate thread. - The result value of the asynchronous function is returned by IAsyncCall.Sync() and - IAsyncCall.ReturnValue(). - The LocalAsyncExec() function calls the IdleMsgMethod while the local procedure is - executed. - -Example: - procedure MainProc(const S: string); - var - Value: Integer; - a: IAsyncCall; - - function DoSomething: Integer; - begin - if S = 'Abc' then - Value := 1; - Result := 0; - end; - - begin - a := LocalAsyncCall(@DoSomething); - // do something - a.Sync; - - LocalAsyncExec(@DoSomething, Application.ProcessMessages); - end; -} -function LocalAsyncCall(LocalProc: TLocalAsyncProc): IAsyncCall; -function LocalAsyncCallEx(LocalProc: TLocalAsyncProcEx; Param: INT_PTR): IAsyncCall; -procedure LocalAsyncExec(Proc: TLocalAsyncProc; IdleMsgMethod: TAsyncIdleMsgMethod); - - - -{ LocalVclCall() executes the given local function/procedure in the main thread. It - uses the TThread.Synchronize function which blocks the current thread. - LocalAsyncVclCall() execute the given local function/procedure in the main thread. - It does not wait for the main thread to execute the function unless the current - thread is the main thread. In that case it executes and waits for the specified - function in the current thread like LocalVclCall(). - - The result value of the asynchronous function is returned by IAsyncCall.Sync() and - IAsyncCall.ReturnValue(). - -Example: - procedure TForm1.MainProc; - - procedure DoSomething; - - procedure UpdateProgressBar(Percentage: Integer); - begin - ProgressBar.Position := Percentage; - Sleep(20); // This delay does not affect the time for the 0..100 loop - // because UpdateProgressBar is non-blocking. - end; - - procedure Finished; - begin - ShowMessage('Finished'); - end; - - var - I: Integer; - begin - for I := 0 to 100 do - begin - // Do some time consuming stuff - Sleep(30); - LocalAsyncVclCall(@UpdateProgressBar, I); // non-blocking - end; - LocalVclCall(@Finished); // blocking - end; - - var - a: IAsyncCall; - begin - a := LocalAsyncCall(@DoSomething); - a.ForceDifferentThread; // Do not execute in the main thread because this will - // change LocalAyncVclCall into a blocking LocalVclCall - // do something - //a.Sync; The Compiler will call this for us in the Interface._Release method - end; -} - -procedure LocalVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0); -function LocalAsyncVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0): IAsyncCall; -{$ENDIF SUPPORT_LOCAL_FUNCTIONS} - - -{ AsyncCallEx() executes the given function/procedure in a separate thread. The - Arg parameter can be a record type. The fields of the record can be modified - in the asynchon function. - -Example: - type - TData = record - Value: Integer; - end; - - procedure TestRec(var Data: TData); - begin - Data.Value := 70; - end; - - a := AsyncCallEx(@TestRec, MyData); - a.Sync; // MyData.Value is now 70 -} -function AsyncCallEx(Proc: TAsyncCallArgRecordProc; var Arg{: TRecordType}): IAsyncCall; overload; -function AsyncCallEx(Method: TAsyncCallArgRecordMethod; var Arg{: TRecordType}): IAsyncCall; overload; -function AsyncCallEx(Method: TAsyncCallArgRecordEvent; var Arg{: TRecordType}): IAsyncCall; overload; - - -{$IFDEF SUPPORT_LOCAL_FUNCTIONS} -{ The following AsyncCall() functions support variable parameters. All reference - counted types are protected by an AddRef and later Release. The ShortString, - Extended, Currency and Int64 types are internally copied to a temporary location. - -Supported types: - Integer : Arg: Integer - Boolean : Arg: Boolean - Char : Arg: AnsiChar - WideChar : Arg: WideChar - Int64 : [const] Arg: Int64 - Extended : [const] Arg: Extended - Currency : [const] Arg: Currency - String : [const] Arg: ShortString - Pointer : [const] Arg: Pointer - PChar : [const] Arg: PChar - Object : [const] Arg: TObject - Class : [const] Arg: TClass - AnsiString : [const] Arg: AnsiString - UnicodeString: [const] Arg: UnicodeString - PWideChar : [const] Arg: PWideChar - WideString : [const] Arg: WideString - Interface : [const] Arg: IInterface - Variant : const Arg: Variant - -Example: - procedure Test(const S: string; I: Integer; E: Extended; Obj: TObject); cdecl; - begin - end; - - AsyncCall(@Test, ['Hallo', 10, 3.5, MyObject]); -} -function AsyncCall(Proc: TCdeclFunc; const Args: array of const): IAsyncCall; overload; -function AsyncCall(Proc: TCdeclMethod; const Args: array of const): IAsyncCall; overload; -{$ENDIF SUPPORT_LOCAL_FUNCTIONS} - - - -{ AsyncMultiSync() waits for the async calls and other handles to finish. - MsgAsyncMultiSync() waits for the async calls, other handles and the message queue. - - Arguments: - List : An array of IAsyncCall interfaces for which the function - should wait. - - Handles : An array of THandle for which the function should wait. - - WaitAll = True : The function returns when all listed async calls have - finished. If Milliseconds is INFINITE the async calls - meight be executed in the current thread. - The return value is zero when all async calls have finished. - Otherwise it is -1. - - WaitAll = False : The function returns when at least one of the async calls - has finished. The return value is the list index of the - first finished async call. If there was a timeout, the - return value is -1. - - Milliseconds : Specifies the number of milliseconds to wait until a - timeout happens. The value INFINITE lets the function wait - until all async calls have finished. - - dwWakeMask : see Windows.MsgWaitForMultipleObjects() - - Limitations: - Length(List)+Length(Handles) must not exceed MAXIMUM_ASYNC_WAIT_OBJECTS. - - Return value: - WAIT_TIMEOUT - The function timed out - - WAIT_OBJECT_0+index - The first finished async call - WAIT_OBJECT_0+Length(List)+index - The first signaled handle - WAIT_OBJECT_0+Length(List)+Length(Handles) - A message was signaled - - WAIT_ABANDONED_0+index - The abandoned async call - WAIT_ABANDONED_0+Length(List)+index - The abandoned handle - - WAIT_FAILED - The function failed -} - -const - MAXIMUM_ASYNC_WAIT_OBJECTS = MAXIMUM_WAIT_OBJECTS - 3; - -function AsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean = True; - Milliseconds: Cardinal = INFINITE): Cardinal; -function AsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle; - WaitAll: Boolean = True; Milliseconds: Cardinal = INFINITE): Cardinal; -function MsgAsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean; - Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal; -function MsgAsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle; - WaitAll: Boolean; Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal; - -{$IFDEF SUPPORT_LOCAL_FUNCTIONS} -{ - EnterMainThread/LeaveMainThread can be used to temporary switch to the - main thread. The code that should be synchonized (blocking) has to be put - into a try/finally block and the LeaveMainThread() function must be called - from the finally block. A missing try/finally will lead to an access violation. - - * All local variables can be used. (EBP points to the thread's stack while - ESP points the the main thread's stack) - * Unhandled exceptions are passed to the surrounding thread. - * The integrated Debugger is not able to follow the execution flow. You have - to use break points instead of "Step over/in". - * Nested calls to EnterMainThread/LeaveMainThread are ignored. But they must - strictly follow the try/finally structure. - - Example: - - procedure MyThreadProc; - var - S: string; - begin - Assert(GetCurrentThreadId <> MainThreadId); - S := 'Hallo, I''m executed in the main thread'; - - EnterMainThread; - try - Assert(GetCurrentThreadId = MainThreadId); - ShowMessage(S); - finally - LeaveMainThread; - end; - - Assert(GetCurrentThreadId <> MainThreadId); - end; -} -procedure EnterMainThread; -procedure LeaveMainThread; -{$ENDIF SUPPORT_LOCAL_FUNCTIONS} - - -type - TAsyncCall = class; - - { *** Internal class. Do not use it *** } - { TAsyncCall is the base class for all parameter based async call types } - TInternalAsyncCall = class(TObject) - private - FNext: TInternalAsyncCall; - - FEvent: THandle; - FReturnValue: Integer; - FFinished: Boolean; - FFatalException: Exception; - FFatalErrorAddr: Pointer; - FForceDifferentThread: Boolean; - FCancelInvocation: Boolean; - FCanceled: Boolean; - FExecuted: Boolean; - FAutoDelete: Boolean; - - procedure InternExecuteAsyncCall; - procedure InternExecuteSyncCall; - procedure Quit(AReturnValue: Integer); - protected - { Decendants must implement this method. It is called when the async call - should be executed. } - function ExecuteAsyncCall: Integer; virtual; abstract; - private - constructor Create; - function ExecuteAsync: TAsyncCall; - - function GetEvent: THandle; - function SyncInThisThreadIfPossible: Boolean; - - function Sync: Integer; - function Finished: Boolean; - function ReturnValue: Integer; - function Canceled: Boolean; - procedure ForceDifferentThread; - procedure CancelInvocation; - procedure Forget; - public - destructor Destroy; override; - end; - - { *** Internal class. Do not use it *** } - TAsyncCall = class(TInterfacedObject, IAsyncCall, IAsyncCallEx) - private - FCall: TInternalAsyncCall; - procedure CheckForget; - - { IAsyncCallEx } - function GetEvent: THandle; - function SyncInThisThreadIfPossible: Boolean; - private - constructor Create(ACall: TInternalAsyncCall); - { IAsyncCall } - function Sync: Integer; - function Finished: Boolean; - function ReturnValue: Integer; - function Canceled: Boolean; - procedure ForceDifferentThread; - procedure CancelInvocation; - procedure Forget; - public - destructor Destroy; override; - end; - - { *** Internal class. Do not use it *** } - { TSyncCall is a fake IAsyncCall implementor. The async call was already - executed when the interface is returned. } - TSyncCall = class(TInterfacedObject, IAsyncCall) - private - FReturnValue: Integer; - private - constructor Create(AReturnValue: Integer); - function Sync: Integer; - function Finished: Boolean; - function ReturnValue: Integer; - function Canceled: Boolean; - procedure ForceDifferentThread; - procedure CancelInvocation; - procedure Forget; - end; - -{$IFDEF DELPHI2009_UP} -type - { *** Helper class *** } - TMultiArgProcCall = class(TInternalAsyncCall) - private - FProc: TProc; - FArg1: T1; - public - constructor Create(AProc: TProc; const AArg1: T1); - end; - - TMultiArgProcCall = class(TMultiArgProcCall) - private - FArg2: T2; - public - constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2); - end; - - TMultiArgProcCall = class(TMultiArgProcCall) - private - FArg3: T3; - public - constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3); - end; - - TMultiArgProcCall = class(TMultiArgProcCall) - private - FArg4: T4; - public - constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3; const AArg4: T4); - end; - - TAsyncCalls = class(TObject) - private - type - TAsyncCallArgGenericProc = function(Arg: T): Integer; - TAsyncCallArgGenericProc = function(Arg1: T1; Arg2: T2): Integer; - TAsyncCallArgGenericProc = function(Arg1: T1; Arg2: T2; Arg3: T3): Integer; - TAsyncCallArgGenericProc = function(Arg1: T1; Arg2: T2; Arg3: T3; Arg4: T4): Integer; - TAsyncCallArgGenericMethod = function(Arg: T): Integer of object; - TAsyncCallArgGenericMethod = function(Arg1: T1; Arg2: T2): Integer of object; - TAsyncCallArgGenericMethod = function(Arg1: T1; Arg2: T2; Arg3: T3): Integer of object; - TAsyncCallArgGenericMethod = function(Arg1: T1; Arg2: T2; Arg3: T3; Arg4: T4): Integer of object; - TIntFunc = reference to function: Integer; - - TAsyncCallArg = class(TMultiArgProcCall, T>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallArg = class(TMultiArgProcCall, T1, T2>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallArg = class(TMultiArgProcCall, T1, T2, T3>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallArg = class(TMultiArgProcCall, T1, T2, T3, T4>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallArgMethod = class(TMultiArgProcCall, T>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallArgMethod = class(TMultiArgProcCall, T1, T2>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallArgMethod = class(TMultiArgProcCall, T1, T2, T3>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallArgMethod = class(TMultiArgProcCall, T1, T2, T3, T4>) - protected - function ExecuteAsyncCall: Integer; override; - end; - - TAsyncCallAnonymProc = class(TInternalAsyncCall) - private - FProc: TProc; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TProc); - end; - - TAsyncCallAnonymFunc = class(TInternalAsyncCall) - private - FProc: TIntFunc; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TIntFunc); - end; - - TAsyncVclCallAnonymProc = class(TInternalAsyncCall) - private - FProc: TProc; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TProc); - end; - - public - { Invoke an asynchronous function call } - class function Invoke(Proc: TAsyncCallArgGenericProc; const Arg: T): IAsyncCall; overload; static; - class function Invoke(Event: TAsyncCallArgGenericMethod; const Arg: T): IAsyncCall; overload; static; - class function Invoke(Proc: TAsyncCallArgGenericProc; const Arg1: T1; const Arg2: T2): IAsyncCall; overload; static; - class function Invoke(Event: TAsyncCallArgGenericMethod; const Arg1: T1; const Arg2: T2): IAsyncCall; overload; static; - class function Invoke(Proc: TAsyncCallArgGenericProc; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; overload; static; - class function Invoke(Event: TAsyncCallArgGenericMethod; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; overload; static; - class function Invoke(Proc: TAsyncCallArgGenericProc; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; overload; static; - class function Invoke(Event: TAsyncCallArgGenericMethod; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; overload; static; - - { Invoke an asynchronous anonymous method call } - class function Invoke(Func: TIntFunc): IAsyncCall; overload; static; - class function Invoke(Proc: TProc): IAsyncCall; overload; static; - - { MsgExec waits for the @AsyncCall to finish. If there are any messages in - the message queue and the function was called from the main thread, it will - call @IdleMsgMethod. "Application.ProcessMessages" can be specified for - @IdleMsgMethod. } - class procedure MsgExec(AsyncCall: IAsyncCall; IdleMsgMethod: TAsyncIdleMsgMethod); static; - - { Synchronize with the VCL } - - { VCLSync returns when the anonymous method was called in the main thread } - class procedure VCLSync(Proc: TProc); static; - { VCLInvoke returns immediately. The anonymous method will be executed in - the main thread. } - class function VCLInvoke(Proc: TProc): IAsyncCall; static; - end; -{$ENDIF DELPHI2009_UP} - -implementation - -{$IFDEF DELPHI5} -uses - Forms; // AllocateHWnd -{$ENDIF DELPHI5} - -resourcestring - RsAsyncCallNotFinished = 'The asynchronous call is not finished yet'; - RsAsyncCallUnknownVarRecType = 'Unknown TVarRec type %d'; - RsLeaveMainThreadNestedError = 'Unpaired call to AsyncCalls.LeaveMainThread()'; - RsLeaveMainThreadThreadError = 'AsyncCalls.LeaveMainThread() was called outside of the main thread'; - RsForgetWasCalled = 'IAsyncCall.Forget was called. The interface isn''t connected to the asynchronous call anymore'; - RsNoVclSyncPossible = 'Cannot synchronize with the main thread anymore. Don''t call IAsyncCall.Forget for functions that access the VCL'; - -const - WM_VCLSYNC = WM_USER + 12; - -{$IFNDEF DELPHI7_UP} -var - SyncEvent: THandle; - -type - TThread = class(Classes.TThread) - {$IFDEF DELPHI6} - private - class procedure WakeMainThread(Sender: TObject); - {$ENDIF DELPHI6} - public - class procedure StaticSynchronize(AThread: TThread; AMethod: TThreadMethod); - end; - -class procedure TThread.StaticSynchronize(AThread: TThread; AMethod: TThreadMethod); -var - Obj: TThread; -begin - if GetCurrentThreadId = MainThreadId then - AMethod - else if AThread <> nil then - AThread.Synchronize(AMethod) - else - begin - {$WARNINGS OFF} // suppress abstract class warning - Obj := TThread.Create(True); - {$WARNINGS ON} - try - Obj.Synchronize(AMethod); - finally - Obj.Free; - end; - end; -end; -{$ENDIF ~DELPHI7_UP} - -procedure StaticSynchronize(AMethod: TThreadMethod); -begin - {$IFDEF DELPHI2010_UP} - TThread.Synchronize(nil, AMethod); - {$ELSE} - TThread.StaticSynchronize(nil, AMethod); - {$ENDIF DELPHI2010_UP} -end; - -{$IFDEF DELPHI5} -function CheckSynchronize(Timeout: Integer = 0): Boolean; -begin - Result := False; -end; - -function AcquireExceptionObject: Pointer; -type - PRaiseFrame = ^TRaiseFrame; - TRaiseFrame = record - NextRaise: PRaiseFrame; - ExceptAddr: Pointer; - ExceptObject: TObject; - ExceptionRecord: PExceptionRecord; - end; -begin - if RaiseList <> nil then - begin - Result := PRaiseFrame(RaiseList)^.ExceptObject; - PRaiseFrame(RaiseList)^.ExceptObject := nil; - end - else - Result := nil; -end; -{$ENDIF DELPHI5} - -{$IFDEF DELPHI6} -var - OrgWakeMainThread: TNotifyEvent; - -class procedure TThread.WakeMainThread(Sender: TObject); -begin - if Assigned(OrgWakeMainThread) then - OrgWakeMainThread(Sender); - SetEvent(SyncEvent); -end; - -procedure HookWakeMainThread; -begin - OrgWakeMainThread := Classes.WakeMainThread; - Classes.WakeMainThread := TThread.WakeMainThread; -end; - -procedure UnhookWakeMainThread; -begin - Classes.WakeMainThread := OrgWakeMainThread; -end; -{$ENDIF DELPHI6} - -{$IFNDEF DELPHI2009_UP} -// Needed for older Delphi versions -function InterlockedCompareExchange(var Destination: Integer; Exchange: Integer; Comparand: Integer): Integer; -asm - XCHG EAX, ECX - LOCK CMPXCHG [ECX], EDX -end; -{$ENDIF ~DELPHI2009_UP} - -type - { TAsyncCallThread is a pooled thread. It looks itself for work. } - TAsyncCallThread = class(TThread) - {$IFDEF DEBUG_THREADSTATS} - private - FTaskCount: Integer; - FTaskTime: Int64; - {$ENDIF DEBUG_THREADSTATS} - protected - procedure Execute; override; - public - constructor Create(ACreateSuspended: Boolean); - end; - - { TThreadPool contains a pool of threads that are either suspended or busy. } - TThreadPool = class(TObject) - private - FWakeUpEvent: THandle; - FThreadTerminateEvent: THandle; - FSleepingThreadCount: Integer; - FMaxThreads: Integer; - FDestroying: Boolean; - - FThreadCount: Integer; - FThreads: array[0..255] of TAsyncCallThread; - - FAsyncCallsCritSect: TRTLCriticalSection; - FAsyncCallHead, FAsyncCallTail: TInternalAsyncCall; - FAutoDeleteAsyncCalls: TInternalAsyncCall; - - FNumberOfProcessors: Cardinal; - {$IFDEF DEBUG_THREADSTATS} - FSyncExecutedCount, FAsyncExecutedCount: Integer; - {$ENDIF DEBUG_THREADSTATS} - - FMainThreadSyncEvent: THandle; - FMainThreadVclHandle: HWND; - procedure MainThreadWndProc(var Msg: TMessage); - procedure ProcessMainThreadSync; - - procedure AllocThread; - function GetNextAsyncCall: TInternalAsyncCall; // called from the threads - - procedure WakeUpThread; - procedure Sleep; - procedure ReleaseAutoDeleteAsyncCalls; - procedure CheckAutoDelete(Call: TInternalAsyncCall); - public - constructor Create; - destructor Destroy; override; - - procedure CheckDestroying; - procedure SendVclSync(Call: TInternalAsyncCall); - - procedure AddAsyncCall(Call: TInternalAsyncCall); - function RemoveAsyncCall(Call: TInternalAsyncCall): Boolean; - procedure ForgetAsyncCall(Call: TInternalAsyncCall); - - property MaxThreads: Integer read FMaxThreads; - property NumberOfProcessors: Cardinal read FNumberOfProcessors; - property MainThreadSyncEvent: THandle read FMainThreadSyncEvent; - end; - -{ ---------------------------------------------------------------------------- } - - TAsyncCallArgObject = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgObjectProc; - FArg: TObject; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgObjectProc; AArg: TObject); - end; - - TAsyncCallArgString = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgStringProc; - FArg: string; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgStringProc; const AArg: string); - end; - - TAsyncCallArgWideString = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgWideStringProc; - FArg: WideString; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgWideStringProc; const AArg: WideString); - end; - - TAsyncCallArgInterface = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgInterfaceProc; - FArg: IInterface; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgInterfaceProc; const AArg: IInterface); - end; - - TAsyncCallArgExtended = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgExtendedProc; - FArg: Extended; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgExtendedProc; const AArg: Extended); - end; - - TAsyncCallArgVariant = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgVariantProc; - FArg: Variant; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgVariantProc; const AArg: Variant); - end; - -{ ---------------------------------------------------------------------------- } - - {$IFDEF SUPPORT_LOCAL_FUNCTIONS} - TAsyncCallLocalProc = class(TInternalAsyncCall) - private - FProc: TLocalAsyncProc; - FBasePointer: Pointer; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TLocalAsyncProc; ABasePointer: Pointer); - end; - - TAsyncCallLocalProcEx = class(TInternalAsyncCall) - private - FProc: TLocalAsyncProc; - FBasePointer: Pointer; - FParam: INT_PTR; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TLocalAsyncProc; AParam: INT_PTR; ABasePointer: Pointer); - end; - - TAsyncVclCallLocalProc = class(TInternalAsyncCall) - private - FProc: TLocalVclProc; - FBasePointer: Pointer; - FParam: INT_PTR; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TLocalVclProc; AParam: INT_PTR; ABasePointer: Pointer); - end; - {$ENDIF SUPPORT_LOCAL_FUNCTIONS} - -{ ---------------------------------------------------------------------------- } - - TAsyncCallMethodArgObject = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgObjectMethod; - FArg: TObject; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgObjectMethod; AArg: TObject); - end; - - TAsyncCallMethodArgString = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgStringMethod; - FArg: string; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgStringMethod; const AArg: string); - end; - - TAsyncCallMethodArgWideString = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgWideStringMethod; - FArg: WideString; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgWideStringMethod; const AArg: WideString); - end; - - TAsyncCallMethodArgInterface = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgInterfaceMethod; - FArg: IInterface; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgInterfaceMethod; const AArg: IInterface); - end; - - TAsyncCallMethodArgExtended = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgExtendedMethod; - FArg: Extended; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgExtendedMethod; const AArg: Extended); - end; - - TAsyncCallMethodArgVariant = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgVariantMethod; - FArg: Variant; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgVariantMethod; const AArg: Variant); - end; - -{ ---------------------------------------------------------------------------- } - - TAsyncCallArgRecord = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgRecordProc; - FArg: Pointer; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgRecordProc; AArg: Pointer); - end; - - TAsyncCallMethodArgRecord = class(TInternalAsyncCall) - private - FProc: TAsyncCallArgRecordMethod; - FArg: Pointer; - protected - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: TAsyncCallArgRecordMethod; AArg: Pointer); - end; - - {$IFDEF SUPPORT_LOCAL_FUNCTIONS} - TAsyncCallArrayOfConst = class(TInternalAsyncCall) - private - FProc: function: Integer register; - FArgs: array of TVarRec; - protected - procedure CopyVarRec(const Data: TVarRec; var Result: TVarRec); - function ExecuteAsyncCall: Integer; override; - public - constructor Create(AProc: Pointer; const AArgs: array of const); overload; - constructor Create(AProc: Pointer; MethodData: TObject; const AArgs: array of const); overload; - destructor Destroy; override; - end; - {$ENDIF SUPPORT_LOCAL_FUNCTIONS} - -{ ---------------------------------------------------------------------------- } -var - ThreadPool: TThreadPool; - -procedure SetMaxAsyncCallThreads(MaxThreads: Integer); -begin - if MaxThreads >= Length(ThreadPool.FThreads) then - MaxThreads := Length(ThreadPool.FThreads); - if MaxThreads >= 0 then - ThreadPool.FMaxThreads := MaxThreads; -end; - -function GetMaxAsyncCallThreads: Integer; -begin - Result := ThreadPool.FMaxThreads; -end; - -{ ---------------------------------------------------------------------------- } - -function AsyncCall(Proc: TAsyncCallArgObjectProc; Arg: TObject): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArgObject.Create(Proc, Arg).ExecuteAsync; -end; - -function AsyncCall(Proc: TAsyncCallArgIntegerProc; Arg: Integer): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgObjectProc(Proc), TObject(Arg)); -end; - -function AsyncCall(Proc: TAsyncCallArgStringProc; const Arg: string): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArgString.Create(Proc, Arg).ExecuteAsync; -end; - -function AsyncCall(Proc: TAsyncCallArgWideStringProc; const Arg: WideString): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArgWideString.Create(Proc, Arg).ExecuteAsync; -end; - -function AsyncCall(Proc: TAsyncCallArgInterfaceProc; const Arg: IInterface): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArgInterface.Create(Proc, Arg).ExecuteAsync; -end; - -function AsyncCall(Proc: TAsyncCallArgExtendedProc; const Arg: Extended): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArgExtended.Create(Proc, Arg).ExecuteAsync; -end; - -function AsyncCallVar(Proc: TAsyncCallArgVariantProc; const Arg: Variant): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArgVariant.Create(Proc, Arg).ExecuteAsync; -end; - -{ ---------------------------------------------------------------------------- } - -function AsyncCall(Method: TAsyncCallArgObjectMethod; Arg: TObject): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Method(Arg)) - else - Result := TAsyncCallMethodArgObject.Create(Method, Arg).ExecuteAsync; -end; - -function AsyncCall(Method: TAsyncCallArgIntegerMethod; Arg: Integer): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgObjectMethod(Method), TObject(Arg)); -end; - -function AsyncCall(Method: TAsyncCallArgStringMethod; const Arg: string): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Method(Arg)) - else - Result := TAsyncCallMethodArgString.Create(Method, Arg).ExecuteAsync; -end; - -function AsyncCall(Method: TAsyncCallArgWideStringMethod; const Arg: WideString): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Method(Arg)) - else - Result := TAsyncCallMethodArgWideString.Create(Method, Arg).ExecuteAsync; -end; - -function AsyncCall(Method: TAsyncCallArgInterfaceMethod; const Arg: IInterface): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Method(Arg)) - else - Result := TAsyncCallMethodArgInterface.Create(Method, Arg).ExecuteAsync; -end; - -function AsyncCall(Method: TAsyncCallArgExtendedMethod; const Arg: Extended): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Method(Arg)) - else - Result := TAsyncCallMethodArgExtended.Create(Method, Arg).ExecuteAsync; -end; - -function AsyncCallVar(Method: TAsyncCallArgVariantMethod; const Arg: Variant): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Method(Arg)) - else - Result := TAsyncCallMethodArgVariant.Create(Method, Arg).ExecuteAsync; -end; - -{ ---------------------------------------------------------------------------- } - -function AsyncCall(Method: TAsyncCallArgObjectEvent; Arg: TObject): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgObjectMethod(Method), Arg); -end; - -function AsyncCall(Method: TAsyncCallArgIntegerEvent; Arg: Integer): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgIntegerMethod(Method), Arg); -end; - -function AsyncCall(Method: TAsyncCallArgStringEvent; const Arg: string): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgStringMethod(Method), Arg); -end; - -function AsyncCall(Method: TAsyncCallArgWideStringEvent; const Arg: WideString): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgWideStringMethod(Method), Arg); -end; - -function AsyncCall(Method: TAsyncCallArgInterfaceEvent; const Arg: IInterface): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgInterfaceMethod(Method), Arg); -end; - -function AsyncCall(Method: TAsyncCallArgExtendedEvent; const Arg: Extended): IAsyncCall; -begin - Result := AsyncCall(TAsyncCallArgExtendedMethod(Method), Arg); -end; - -function AsyncCallVar(Method: TAsyncCallArgVariantEvent; const Arg: Variant): IAsyncCall; -begin - Result := AsyncCallVar(TAsyncCallArgVariantMethod(Method), Arg); -end; - -function AsyncCallRunnable(const Arg: IInterface): Integer; -begin - IAsyncRunnable(Arg).AsyncRun; - Result := 0; -end; - -function AsyncCall(Runnable: IAsyncRunnable): IAsyncCall; -begin - Result := AsyncCall(AsyncCallRunnable, IInterface(Runnable)); -end; - -{ ---------------------------------------------------------------------------- } - -procedure AsyncExec(Method: TNotifyEvent; Arg: TObject; IdleMsgMethod: TAsyncIdleMsgMethod); -var - Handle: IAsyncCall; -begin - Handle := AsyncCall(Method, Arg); - if Assigned(IdleMsgMethod) then - begin - Handle.ForceDifferentThread; - IdleMsgMethod; - while MsgAsyncMultiSync([Handle], False, INFINITE, QS_ALLINPUT or QS_ALLPOSTMESSAGE) = 1 do - IdleMsgMethod; - end; -end; - -{ ---------------------------------------------------------------------------- } -{$IFDEF SUPPORT_LOCAL_FUNCTIONS} -function InternLocalAsyncCall(LocalProc: TLocalAsyncProc; BasePointer: Pointer): IAsyncCall; -begin - Result := TAsyncCallLocalProc.Create(LocalProc, BasePointer).ExecuteAsync; -end; - -function LocalAsyncCall(LocalProc: TLocalAsyncProc): IAsyncCall; -asm - mov ecx, edx // interface return address - mov edx, ebp - jmp InternLocalAsyncCall -end; - -function InternLocalAsyncCallEx(LocalProc: TLocalAsyncProc; Param: INT_PTR; BasePointer: Pointer): IAsyncCall; -begin - Result := TAsyncCallLocalProcEx.Create(LocalProc, Param, BasePointer).ExecuteAsync; -end; - -function LocalAsyncCallEx(LocalProc: TLocalAsyncProcEx; Param: INT_PTR): IAsyncCall; -asm - push ecx // interface return address - mov ecx, ebp - call InternLocalAsyncCallEx -end; - -procedure InternLocalAsyncExec(LocalProc: TLocalAsyncProc; IdleMsgMethod: TAsyncIdleMsgMethod; BasePointer: Pointer); -var - Handle: IAsyncCall; -begin - Handle := TAsyncCallLocalProc.Create(LocalProc, BasePointer).ExecuteAsync; - if Assigned(IdleMsgMethod) then - begin - Handle.ForceDifferentThread; - IdleMsgMethod; - while MsgAsyncMultiSync([Handle], False, INFINITE, QS_ALLINPUT or QS_ALLPOSTMESSAGE) = 1 do - IdleMsgMethod; - end; -end; - -{$STACKFRAMES ON} -procedure LocalAsyncExec(Proc: TLocalAsyncProc; IdleMsgMethod: TAsyncIdleMsgMethod); -asm // TMethod causes the compiler to generate a stackframe - pop ebp // remove stackframe - mov edx, ebp - jmp InternLocalAsyncExec -end; -{$STACKFRAMES OFF} - -{$ENDIF SUPPORT_LOCAL_FUNCTIONS} - -{ ---------------------------------------------------------------------------- } - -function AsyncCallEx(Proc: TAsyncCallArgRecordProc; var Arg{: TRecordType}): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArgRecord.Create(Proc, @Arg).ExecuteAsync; -end; - -function AsyncCallEx(Method: TAsyncCallArgRecordMethod; var Arg{: TRecordType}): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if ThreadPool.MaxThreads = 0 then - Result := TSyncCall.Create(Method(Arg)) - else - Result := TAsyncCallMethodArgRecord.Create(Method, @Arg).ExecuteAsync; -end; - -function AsyncCallEx(Method: TAsyncCallArgRecordEvent; var Arg{: TRecordType}): IAsyncCall; -begin - Result := AsyncCallEx(TAsyncCallArgRecordMethod(Method), Arg); -end; - -{ ---------------------------------------------------------------------------- } - -{$IFDEF SUPPORT_LOCAL_FUNCTIONS} -function AsyncCall(Proc: TCdeclFunc; const Args: array of const): IAsyncCall; overload; -var - Call: TInternalAsyncCall; -begin - Call := TAsyncCallArrayOfConst.Create(Proc, Args); - if ThreadPool.MaxThreads = 0 then - begin - Call.InternExecuteSyncCall; - Result := TAsyncCall.Create(Call); - end - else - Result := Call.ExecuteAsync; -end; - -function AsyncCall(Proc: TCdeclMethod; const Args: array of const): IAsyncCall; overload; -var - Call: TInternalAsyncCall; -begin - Call := TAsyncCallArrayOfConst.Create(Proc.Code, TObject(Proc.Data), Args); - if ThreadPool.MaxThreads = 0 then - begin - Call.InternExecuteSyncCall; - Result := TAsyncCall.Create(Call); - end - else - Result := Call.ExecuteAsync; -end; -{$ENDIF SUPPORT_LOCAL_FUNCTIONS} - -{ ---------------------------------------------------------------------------- } - -function WaitForSingleObjectMainThread(AHandle: THandle; Timeout: Cardinal): Cardinal; -var - Handles: array[0..2] of THandle; -begin - Handles[0] := AHandle; - Handles[1] := SyncEvent; - Handles[2] := ThreadPool.MainThreadSyncEvent; - {$IFDEF DELPHI6} - HookWakeMainThread; - try - {$ENDIF DELPHI6} - repeat - Result := WaitForMultipleObjects(3, @Handles[0], False, Timeout); - if Result = WAIT_OBJECT_0 + 1 then - CheckSynchronize - else if Result = WAIT_OBJECT_0 + 2 then - ThreadPool.ProcessMainThreadSync; - until (Result <> WAIT_OBJECT_0 + 1) and (Result <> WAIT_OBJECT_0 + 2); - {$IFDEF DELPHI6} - finally - UnhookWakeMainThread; - end; - {$ENDIF DELPHI6} -end; - -function WaitForMultipleObjectsMainThread(Count: Cardinal; - const AHandles: array of THandle; WaitAll: Boolean; Timeout: Cardinal; - MsgWait: Boolean; dwWakeMask: DWORD): Cardinal; -var - Handles: array of THandle; - Index: Cardinal; - FirstFinished, OriginalCount: Cardinal; -begin - { Wait for the specified events, for the VCL SyncEvent and for the MainThreadSync event } - OriginalCount := Count; - SetLength(Handles, Count + 2); - Move(AHandles[0], Handles[0], Count * SizeOf(THandle)); - Handles[Count] := SyncEvent; - Handles[Count + 1] := ThreadPool.MainThreadSyncEvent; - {$IFDEF DELPHI6} - HookWakeMainThread; - try - {$ENDIF DELPHI6} - if not WaitAll then - begin - repeat - if MsgWait then - begin - Result := MsgWaitForMultipleObjects(Count + 2, Handles[0], WaitAll, Timeout, dwWakeMask); - if Result = WAIT_OBJECT_0 + Count + 2 then - begin - ThreadPool.ProcessMainThreadSync; // also uses the message queue - Result := WAIT_OBJECT_0 + OriginalCount; // caller doesn't know about the 2 synchronization events - Exit; - end; - end - else - Result := WaitForMultipleObjects(Count + 2, @Handles[0], WaitAll, Timeout); - - if Result = WAIT_OBJECT_0 + Count then - CheckSynchronize - else if Result = WAIT_OBJECT_0 + Count + 1 then - ThreadPool.ProcessMainThreadSync; - until (Result <> WAIT_OBJECT_0 + Count) and (Result <> WAIT_OBJECT_0 + Count + 1); - end - else - begin - FirstFinished := WAIT_TIMEOUT; - repeat - if MsgWait then - begin - Result := MsgWaitForMultipleObjects(Count + 2, Handles[0], False, Timeout, dwWakeMask); - if Result = WAIT_OBJECT_0 + Count + 2 then - begin - ThreadPool.ProcessMainThreadSync; // also uses the message queue - Result := WAIT_OBJECT_0 + OriginalCount; // caller doesn't know about the 2 synchronization events - Exit; - end; - end - else - Result := WaitForMultipleObjects(Count + 2, @Handles[0], False, Timeout); - - if Result = WAIT_OBJECT_0 + Count then - CheckSynchronize - else if Result = WAIT_OBJECT_0 + Count + 1 then - ThreadPool.ProcessMainThreadSync - else - if {(Result >= WAIT_OBJECT_0) and} (Result <= WAIT_OBJECT_0 + Count) then - begin - if FirstFinished = WAIT_TIMEOUT then - FirstFinished := Result; - Dec(Count); - if Count > 0 then - begin - Index := Result - WAIT_OBJECT_0; - Move(Handles[Index + 1], Handles[Index], ((Count + 2) - Index) * SizeOf(THandle)); - end; - end - else - Break; - until Count = 0; - if Count = 0 then - Result := FirstFinished; - end; - {$IFDEF DELPHI6} - finally - UnhookWakeMainThread; - end; - {$ENDIF DELPHI6} -end; - -{ ---------------------------------------------------------------------------- } - -function InternalAsyncMultiSync(const List: array of IAsyncCall; const Handles: array of THandle; - WaitAll: Boolean; Milliseconds: Cardinal; MsgWait: Boolean; dwWakeMask: DWORD): Cardinal; - - function InternalWait(const List: array of IAsyncCall; const Handles: array of THandle; - WaitAll: Boolean; Milliseconds: Cardinal; MsgWait: Boolean; dwWakeMask: DWORD): Cardinal; - var - WaitHandles: array of THandle; - Mapping: array of Integer; - I: Integer; - Count: Cardinal; - EventIntf: IAsyncCallEx; - SignalState: Cardinal; - begin - SetLength(WaitHandles, Length(List) + Length(Handles)); - SetLength(Mapping, Length(WaitHandles)); - Count := 0; - { Get the TInternalAsyncCall events } - for I := 0 to High(List) do - begin - if (List[I] <> nil) and Supports(List[I], IAsyncCallEx, EventIntf) then - begin - WaitHandles[Count] := EventIntf.GetEvent; - if WaitHandles[Count] <> 0 then - begin - Mapping[Count] := I; - Inc(Count); - end; - end - else - if not WaitAll then - begin - { There are synchron calls in List[] and the caller does not want to - wait for all handles. } - Result := I; - Exit; - end; - end; - - { Append other handles } - for I := 0 to High(Handles) do - begin - WaitHandles[Count] := Handles[I]; - Mapping[Count] := Length(List) + I; - Inc(Count); - end; - - { Wait for the async calls } - if Count > 0 then - begin - if GetCurrentThreadId = MainThreadID then - begin - SignalState := WaitForMultipleObjectsMainThread(Count, WaitHandles, WaitAll, Milliseconds, MsgWait, dwWakeMask); - if SignalState = Count then // "message" was signaled - begin - Result := SignalState; - Exit; - end; - end - else - begin - if MsgWait then - begin - SignalState := MsgWaitForMultipleObjects(Count, WaitHandles[0], WaitAll, Milliseconds, dwWakeMask); - if SignalState = Count then // "message" was signaled - begin - Result := SignalState; - Exit; - end; - end - else - SignalState := WaitForMultipleObjects(Count, @WaitHandles[0], WaitAll, Milliseconds); - end; - if {(SignalState >= WAIT_OBJECT_0) and} (SignalState < WAIT_OBJECT_0 + Count) then - Result := WAIT_OBJECT_0 + Mapping[SignalState - WAIT_OBJECT_0] - else if (SignalState >= WAIT_ABANDONED_0) and (SignalState < WAIT_ABANDONED_0 + Count) then - Result := WAIT_ABANDONED_0 + Mapping[SignalState - WAIT_ABANDONED_0] - else - Result := SignalState; - end - else - Result := WAIT_OBJECT_0; // all AsyncCalls are already synchronized - end; - - function InternalWaitAllInfinite(const List: array of IAsyncCall; const Handles: array of THandle): Cardinal; - var - I: Integer; - begin - { Wait for the async calls that aren't finished yet. } - for I := 0 to High(List) do - if List[I] <> nil then - List[I].Sync; - - if Length(Handles) > 0 then - begin - if GetCurrentThreadId = MainThreadID then - WaitForMultipleObjectsMainThread(Length(Handles), Handles, True, INFINITE, False, 0) - else - WaitForMultipleObjects(Length(Handles), @Handles[0], True, INFINITE); - end; - Result := WAIT_OBJECT_0; - end; - -var - Count: Integer; -begin - Count := Length(List) + Length(Handles); - if (Count > 0) and (Count <= MAXIMUM_ASYNC_WAIT_OBJECTS) then - begin - if WaitAll and (Milliseconds = INFINITE) and not MsgWait and (GetCurrentThreadId <> MainThreadId) then - Result := InternalWaitAllInfinite(List, Handles) - else - Result := InternalWait(List, Handles, WaitAll, Milliseconds, MsgWait, dwWakeMask); - end - else - Result := WAIT_FAILED; -end; - -function AsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean; - Milliseconds: Cardinal): Cardinal; -begin - Result := InternalAsyncMultiSync(List, [], WaitAll, Milliseconds, False, 0); -end; - -function AsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle; - WaitAll: Boolean = True; Milliseconds: Cardinal = INFINITE): Cardinal; -begin - Result := InternalAsyncMultiSync(List, Handles, WaitAll, Milliseconds, False, 0); -end; - -function MsgAsyncMultiSync(const List: array of IAsyncCall; WaitAll: Boolean; - Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal; -begin - Result := InternalAsyncMultiSync(List, [], WaitAll, Milliseconds, True, dwWakeMask); -end; - -function MsgAsyncMultiSyncEx(const List: array of IAsyncCall; const Handles: array of THandle; - WaitAll: Boolean; Milliseconds: Cardinal; dwWakeMask: DWORD): Cardinal; -begin - Result := InternalAsyncMultiSync(List, Handles, WaitAll, Milliseconds, True, dwWakeMask); -end; - -procedure NotFinishedError(const FunctionName: string); -begin - {$IFDEF DEBUG_ASYNCCALLS_ODS} - if FunctionName <> '' then - OutputDebugString(PChar(FunctionName)); - {$ENDIF DEBUG_ASYNCCALLS_ODS} - raise EAsyncCallError.Create(RsAsyncCallNotFinished); -end; - -procedure UnknownVarRecType(VType: Byte); -begin - raise EAsyncCallError.CreateFmt(RsAsyncCallUnknownVarRecType, [VType]); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallThread } - -function GetMainWnd(wnd: THandle; var MainWnd: THandle): LongBool; stdcall; -begin - Result := False; - MainWnd := wnd; -end; - -constructor TAsyncCallThread.Create(ACreateSuspended: Boolean); -begin - inherited Create(ACreateSuspended); - Priority := tpHigher; // faster initial start of the thread. Is revoked after getting an IAsyncCall request -end; - -procedure TAsyncCallThread.Execute; -var - FAsyncCall: TInternalAsyncCall; - CoInitialized: Boolean; - {$IFDEF DEBUG_THREADSTATS} - Start, Stop: Int64; - {$ENDIF DEBUG_THREADSTATS} -begin - CoInitialized := False; - case CoInitialize(nil) of - S_OK, S_FALSE: - CoInitialized := True; - end; - try - while True do - begin - FAsyncCall := ThreadPool.GetNextAsyncCall; // calls Sleep if nothing has to be done - Priority := tpNormal; - if FAsyncCall <> nil then - begin - {$IFDEF DEBUG_THREADSTATS} - Inc(FTaskCount); - QueryPerformanceCounter(Start); - {$ENDIF DEBUG_THREADSTATS} - try - FAsyncCall.InternExecuteAsyncCall; - except - {$IFDEF DEBUG_ASYNCCALLS_ODS} - on E: Exception do - OutputDebugString(PChar('[' + E.ClassName + '] ' + E.Message)); - {$ENDIF DEBUG_ASYNCCALLS_ODS} - end; - {$IFDEF DEBUG_THREADSTATS} - QueryPerformanceCounter(Stop); - Inc(FTaskTime, Stop - Start); - {$ENDIF DEBUG_THREADSTATS} - end - else if Terminated then - begin - { Thread will quit if the application terminates and no further task is in the queue. } - FAsyncCall := ThreadPool.GetNextAsyncCall; // Doesn't go to sleep due to signaled ThreadPool.FThreadTerminateEvent - if FAsyncCall = nil then - Break; - end; - - if FAsyncCall <> nil then - ThreadPool.CheckAutoDelete(FAsyncCall); - end; - finally - if CoInitialized then - CoUninitialize; - end; -end; - -{ ---------------------------------------------------------------------------- } -{ TThreadPool } - -constructor TThreadPool.Create; -var - SysInfo: TSystemInfo; -begin - inherited Create; - FMainThreadVclHandle := AllocateHWnd(MainThreadWndProc); - FMainThreadSyncEvent := CreateEvent(nil, False, False, nil); - FWakeUpEvent := CreateEvent(nil, False, False, nil); - FThreadTerminateEvent := CreateEvent(nil, True, False, nil); - InitializeCriticalSectionAndSpinCount(FAsyncCallsCritSect, 4000); - - GetSystemInfo(SysInfo); - FNumberOfProcessors := SysInfo.dwNumberOfProcessors; - FMaxThreads := SysInfo.dwNumberOfProcessors * 4 - 2 {main thread}; - if FMaxThreads > Length(FThreads) then - FMaxThreads := Length(FThreads); -end; - -destructor TThreadPool.Destroy; -var - I: Integer; - Call: TInternalAsyncCall; -begin - FMaxThreads := FThreadCount; // Do not allocation new threads - FDestroying := True; // => Sync in this thread because there is no other thread (required for FAsnycCallHead.Free) - - // Allow the threads to terminate if there is no task - for I := FThreadCount - 1 downto 0 do - FThreads[I].Terminate; - // Wake up all sleeping threads and keep them awake so they can terminate - SetEvent(FThreadTerminateEvent); - // Wait and destroy the threads - for I := FThreadCount - 1 downto 0 do - FThreads[I].Free; - ReleaseAutoDeleteAsyncCalls; - - // Clean up not yet released AutoDelete InternalAsyncCalls. - while FAsyncCallHead <> nil do - begin - Call := FAsyncCallHead.FNext; - CheckAutoDelete(FAsyncCallHead); - FAsyncCallHead := Call; - end; - - CloseHandle(FThreadTerminateEvent); - CloseHandle(FWakeUpEvent); - CloseHandle(FMainThreadSyncEvent); - DeallocateHWnd(FMainThreadVclHandle); - DeleteCriticalSection(FAsyncCallsCritSect); - - inherited Destroy; -end; - - -procedure TThreadPool.CheckDestroying; -begin - if FDestroying then - raise EAsyncCallError.CreateRes(@RsNoVclSyncPossible); -end; - -procedure TThreadPool.CheckAutoDelete(Call: TInternalAsyncCall); -var - AutoDelete: Boolean; -begin - EnterCriticalSection(FAsyncCallsCritSect); // spinning - try - AutoDelete := Call.FAutoDelete; - finally - LeaveCriticalSection(FAsyncCallsCritSect); - end; - if AutoDelete then - begin - try - Call.Sync; // throw exception if one is to throw - except - if Assigned(ApplicationHandleException) then - ApplicationHandleException(Self); - end; - Call.Free; - end; -end; - -procedure TThreadPool.ReleaseAutoDeleteAsyncCalls; -var - ItemP: ^TInternalAsyncCall; - Next: TInternalAsyncCall; -begin - EnterCriticalSection(FAsyncCallsCritSect); // spinning - try - ItemP := @FAutoDeleteAsyncCalls; - while ItemP^ <> nil do - begin - Next := ItemP^.FNext; - try - ItemP^.Sync; // throw raised exceptions here - finally - ItemP^.Free; - ItemP^ := Next; - end; - end; - finally - LeaveCriticalSection(FAsyncCallsCritSect); - end; -end; - -function TThreadPool.GetNextAsyncCall: TInternalAsyncCall; -begin - { Dequeue } - EnterCriticalSection(FAsyncCallsCritSect); // spinning - try - ReleaseAutoDeleteAsyncCalls; - { Get the "oldest" async call } - Result := FAsyncCallHead; - if FAsyncCallHead <> nil then - FAsyncCallHead := FAsyncCallHead.FNext; - if Result = FAsyncCallTail then - FAsyncCallTail := nil; - finally - LeaveCriticalSection(FAsyncCallsCritSect); - end; - { If there are further tasks in the queue, other threads may be able to process them. - Without this, one thread could end up doing all the tasks if no new task is added. } - if FAsyncCallHead <> nil then // unsafe access, but WakeUpThread would only wake up a thread that will immediately go to sleep - WakeUpThread; - - { Nothing to do, go sleeping... } - if Result = nil then - Sleep; -end; - -function TThreadPool.RemoveAsyncCall(Call: TInternalAsyncCall): Boolean; -var - Item: TInternalAsyncCall; -begin - Result := False; - EnterCriticalSection(FAsyncCallsCritSect); // spinning, but we may take too much time - try - Item := FAsyncCallHead; - if Item = Call then - begin - FAsyncCallHead := Call.FNext; - if FAsyncCallHead = nil then - FAsyncCallTail := nil; - Result := True; - end - else - begin - while (Item <> nil) and (Item.FNext <> Call) do - Item := Item.FNext; - if Item <> nil then - begin - Item.FNext := Call.FNext; - if Call = FAsyncCallTail then - FAsyncCallTail := Item; - Result := True; - end; - end; - finally - LeaveCriticalSection(FAsyncCallsCritSect); - end; -end; - -procedure TThreadPool.AddAsyncCall(Call: TInternalAsyncCall); -begin - { Enqueue } - EnterCriticalSection(FAsyncCallsCritSect); // spinning - if FAsyncCallTail = nil then - begin - FAsyncCallHead := Call; - FAsyncCallTail := Call; - end - else - begin - FAsyncCallTail.FNext := Call; - FAsyncCallTail := Call; - end; - LeaveCriticalSection(FAsyncCallsCritSect); - - { All threads are busy, we need to allocate another thread if possible. } - if FSleepingThreadCount = 0 then - begin - { Do an unsafe ThreadCount check. AllocThread will do a safe check if we were wrong here. } - if FThreadCount < MaxThreads then - AllocThread; - end; - - { Wake up one of the sleeping threads. } - WakeUpThread; -end; - -procedure TThreadPool.ForgetAsyncCall(Call: TInternalAsyncCall); -var - Item: TInternalAsyncCall; -begin - // Assert(Call.FRefCount > 0); - EnterCriticalSection(FAsyncCallsCritSect); // spinning, but we may take too much time - try - Item := FAsyncCallHead; - while (Item <> nil) and (Item <> Call) do - Item := Item.FNext; - if Item <> nil then - Call.FAutoDelete := True // it is still safe to set FAutoDelete - else - begin - { There is no way to find out if the FAutoDelete code in TAsyncCallThread.Execute was - already executed or not, so release the the calls the next time GetNextAsyncCall is - called. } - Call.FNext := FAutoDeleteAsyncCalls; - FAutoDeleteAsyncCalls := Call; - end - finally - LeaveCriticalSection(FAsyncCallsCritSect); - end; -end; - -procedure TThreadPool.AllocThread; -var - Index: Integer; -begin - { Increment FThreadCount if less than FMaxThreads } - repeat - Index := FThreadCount; - until (Index = FMaxThreads) or (InterlockedCompareExchange(FThreadCount, Index + 1, Index) = Index); - - if Index < FMaxThreads then - FThreads[Index] := TAsyncCallThread.Create(False); -end; - -procedure TThreadPool.SendVclSync(Call: TInternalAsyncCall); -begin - CheckDestroying; - - if not PostMessage(FMainThreadVclHandle, WM_VCLSYNC, 0, LPARAM(Call)) then - Call.Quit(0) - else - SetEvent(FMainThreadSyncEvent); -end; - -procedure TThreadPool.WakeUpThread; -begin - // Wake up one of the sleeping threads - SetEvent(FWakeUpEvent); -end; - -procedure TThreadPool.Sleep; -// Wait for the wake up call from WakeUpThread -var - Handles: array[0..1] of THandle; -begin - Handles[0] := FWakeUpEvent; - Handles[1] := FThreadTerminateEvent; - - InterlockedIncrement(FSleepingThreadCount); - - SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_ABOVE_NORMAL); // wake up faster - WaitForMultipleObjects(2, @Handles, False, INFINITE); - //SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_NORMAL); done in TAsyncThread.Execute - - InterlockedDecrement(FSleepingThreadCount); -end; - -procedure TThreadPool.MainThreadWndProc(var Msg: TMessage); -begin - case Msg.Msg of - WM_VCLSYNC: - TInternalAsyncCall(Msg.LParam).InternExecuteSyncCall; - else - Msg.Result := DefWindowProc(FMainThreadVclHandle, Msg.Msg, Msg.WParam, Msg.LParam); - end; -end; - -procedure TThreadPool.ProcessMainThreadSync; -var - Msg: TMsg; -begin - Assert(GetCurrentThreadId = MainThreadId); - while PeekMessage(Msg, FMainThreadVclHandle, 0, 0, PM_REMOVE) do - begin - TranslateMessage(Msg); - DispatchMessage(Msg); - end; -end; - -{ ---------------------------------------------------------------------------- } -{ TSyncCall } - -function TSyncCall.Canceled: Boolean; -begin - Result := False; -end; - -procedure TSyncCall.CancelInvocation; -begin -end; - -constructor TSyncCall.Create(AReturnValue: Integer); -begin - inherited Create; - FReturnValue := AReturnValue; -end; - -function TSyncCall.Finished: Boolean; -begin - Result := True; -end; - -procedure TSyncCall.ForceDifferentThread; -begin -end; - -procedure TSyncCall.Forget; -begin -end; - -function TSyncCall.ReturnValue: Integer; -begin - Result := FReturnValue; -end; - -function TSyncCall.Sync: Integer; -begin - Result := FReturnValue; -end; - -{ ---------------------------------------------------------------------------- } -{ TInternalAsyncCall } - -constructor TInternalAsyncCall.Create; -begin - inherited Create; - FEvent := CreateEvent(nil, True, False, nil); -end; - -destructor TInternalAsyncCall.Destroy; -begin - if FEvent <> 0 then - begin - try - Sync; - finally - CloseHandle(FEvent); - FEvent := 0; - end; - end; - inherited Destroy; -end; - -function TInternalAsyncCall.Finished: Boolean; -begin - if FCanceled or (FCancelInvocation and not FExecuted) then - Result := True - else - Result := (FEvent = 0) or FFinished or (WaitForSingleObject(FEvent, 0) = WAIT_OBJECT_0); -end; - -procedure TInternalAsyncCall.ForceDifferentThread; -begin - FForceDifferentThread := True; -end; - -procedure TInternalAsyncCall.Forget; -begin - ForceDifferentThread; - ThreadPool.ForgetAsyncCall(Self); -end; - -function TInternalAsyncCall.Canceled: Boolean; -begin - Result := FCanceled; -end; - -procedure TInternalAsyncCall.CancelInvocation; -begin - FCancelInvocation := True; -end; - -function TInternalAsyncCall.GetEvent: THandle; -begin - Result := FEvent; -end; - -procedure TInternalAsyncCall.InternExecuteAsyncCall; -var - Value: Integer; -begin - {$IFDEF DEBUG_THREADSTATS} - InterlockedIncrement(ThreadPool.FAsyncExecutedCount); - {$ENDIF DEBUG_THREADSTATS} - Value := 0; - try - if not FCancelInvocation then - begin - FExecuted := True; - Value := ExecuteAsyncCall; - end - else - FCanceled := True; - except - FFatalErrorAddr := ExceptAddr; - FFatalException := AcquireExceptionObject; - end; - Quit(Value); -end; - -procedure TInternalAsyncCall.InternExecuteSyncCall; -var - Value: Integer; -begin - {$IFDEF DEBUG_THREADSTATS} - InterlockedIncrement(ThreadPool.FSyncExecutedCount); - {$ENDIF DEBUG_THREADSTATS} - Value := 0; - try - if not FCancelInvocation then - begin - FExecuted := True; - Value := ExecuteAsyncCall(); - end - else - FCanceled := True; - finally - // Let the exception be handled by the caller because we are in sync with it - Quit(Value); - end; -end; - -procedure TInternalAsyncCall.Quit(AReturnValue: Integer); -begin - FReturnValue := AReturnValue; - FFinished := True; - SetEvent(FEvent); -end; - -function TInternalAsyncCall.ReturnValue: Integer; -var - E: Exception; -begin - if not Finished then - NotFinishedError('IAsyncCall.ReturnValue'); - Result := FReturnValue; - - if FFatalException <> nil then - begin - E := FFatalException; - FFatalException := nil; - raise E at FFatalErrorAddr; - end; -end; - -function TInternalAsyncCall.Sync: Integer; -var - E: Exception; -begin - if not Finished then - begin - if not SyncInThisThreadIfPossible then - begin - if GetCurrentThreadId = MainThreadID then - begin - if WaitForSingleObjectMainThread(FEvent, INFINITE) <> WAIT_OBJECT_0 then - NotFinishedError('IAsyncCall.Sync'); - end - else - if WaitForSingleObject(FEvent, INFINITE) <> WAIT_OBJECT_0 then - NotFinishedError('IAsyncCall.Sync'); - end; - end; - Result := FReturnValue; - - if FFatalException <> nil then - begin - E := FFatalException; - FFatalException := nil; - raise E at FFatalErrorAddr; - end; -end; - -function TInternalAsyncCall.SyncInThisThreadIfPossible: Boolean; -begin - if not Finished then - begin - Result := False; - if not FForceDifferentThread or ThreadPool.FDestroying then - begin - { If no thread was assigned to this async call, remove it form the waiting - queue and execute it in the current thread. } - if ThreadPool.RemoveAsyncCall(Self) then - begin - InternExecuteSyncCall; - Result := True; - end; - end; - end - else - Result := True; -end; - -function TInternalAsyncCall.ExecuteAsync: TAsyncCall; -begin - ThreadPool.AddAsyncCall(Self); - Result := TAsyncCall.Create(Self); -end; - -{ ---------------------------------------------------------------------------- } -{$IFDEF SUPPORT_LOCAL_FUNCTIONS} -{ TAsyncCallArrayOfConst } - -constructor TAsyncCallArrayOfConst.Create(AProc: Pointer; const AArgs: array of const); -var - I: Integer; -begin - inherited Create; - FProc := AProc; - SetLength(FArgs, Length(AArgs)); - for I := 0 to High(AArgs) do - CopyVarRec(AArgs[I], FArgs[I]); -end; - -constructor TAsyncCallArrayOfConst.Create(AProc: Pointer; MethodData: TObject; const AArgs: array of const); -var - I: Integer; -begin - inherited Create; - FProc := AProc; - SetLength(FArgs, 1 + Length(AArgs)); - - // insert "Self" - FArgs[0].VType := vtObject; - FArgs[0].VObject := MethodData; - - for I := 0 to High(AArgs) do - CopyVarRec(AArgs[I], FArgs[I + 1]); -end; - -destructor TAsyncCallArrayOfConst.Destroy; -var - I: Integer; - V: PVarRec; -begin - for I := 0 to High(FArgs) do - begin - V := @FArgs[I]; - case V.VType of - vtAnsiString: AnsiString(V.VAnsiString) := ''; - vtWideString: WideString(V.VWideString) := ''; - {$IFDEF UNICODE} - vtUnicodeString: UnicodeString(V.VUnicodeString) := ''; - {$ENDIF UNICODE} - vtInterface : IInterface(V.VInterface) := nil; - - vtString : Dispose(V.VString); - vtExtended : Dispose(V.VExtended); - vtCurrency : Dispose(V.VCurrency); - vtInt64 : Dispose(V.VInt64); - vtVariant : Dispose(V.VVariant); - end; - end; - inherited Destroy; -end; - -procedure TAsyncCallArrayOfConst.CopyVarRec(const Data: TVarRec; var Result: TVarRec); -begin - if (Data.VPointer <> nil) and - (Data.VType in [vtString, vtAnsiString, vtWideString, - {$IFDEF UNICODE}vtUnicodeString,{$ENDIF} vtExtended, - vtCurrency, vtInt64, vtVariant, vtInterface]) then - begin - Result.VType := Data.VType; - Result.VPointer := nil; - { Copy and redirect TVarRec data to prevent conflicts with other threads, - especially the calling thread. Otherwise reference counted types could - be freed while this asynchron function is still executed. } - case Result.VType of - vtAnsiString: AnsiString(Result.VAnsiString) := AnsiString(Data.VAnsiString); - vtWideString: WideString(Result.VWideString) := WideString(Data.VWideString); - {$IFDEF UNICODE} - vtUnicodeString: UnicodeString(Result.VUnicodeString) := UnicodeString(data.VUnicodeString); - {$ENDIF UNICODE} - vtInterface : IInterface(Result.VInterface) := IInterface(Data.VInterface); - - vtString : begin New(Result.VString); Result.VString^ := Data.VString^; end; - vtExtended : begin New(Result.VExtended); Result.VExtended^ := Data.VExtended^; end; - vtCurrency : begin New(Result.VCurrency); Result.VCurrency^ := Data.VCurrency^; end; - vtInt64 : begin New(Result.VInt64); Result.VInt64^ := Data.VInt64^; end; - vtVariant : begin New(Result.VVariant); Result.VVariant^ := Data.VVariant^; end; - end; - end - else - Result := Data; -end; - -function TAsyncCallArrayOfConst.ExecuteAsyncCall: Integer; -var - I: Integer; - V: ^TVarRec; - ByteCount: Integer; -begin - ByteCount := Length(FArgs) * SizeOf(Integer) + $40; - { Create a zero filled buffer for functions that want more arguments than - specified. } - asm - xor eax, eax - mov ecx, $40 / 8 -@@FillBuf: - push eax - push eax - dec ecx - jnz @@FillBuf - end; - - for I := High(FArgs) downto 0 do // cdecl => right to left - begin - V := @FArgs[I]; - case V.VType of - vtInteger: // [const] Arg: Integer - asm - mov eax, V - push [eax].TVarRec.VInteger - end; - - vtBoolean, // [const] Arg: Boolean - vtChar: // [const] Arg: AnsiChar - asm - mov eax, V - xor edx, edx - mov dl, [eax].TVarRec.VBoolean - push edx - end; - - vtWideChar: // [const] Arg: WideChar - asm - mov eax, V - xor edx, edx - mov dx, [eax].TVarRec.VWideChar - push edx - end; - - vtExtended: // [const] Arg: Extended - asm - add [ByteCount], 8 // two additional DWORDs - mov eax, V - mov edx, [eax].TVarRec.VExtended - movzx eax, WORD PTR [edx + 8] - push eax - push DWORD PTR [edx + 4] - push DWORD PTR [edx] - end; - - vtCurrency, // [const] Arg: Currency - vtInt64: // [const] Arg: Int64 - asm - add [ByteCount], 4 // an additional DWORD - mov eax, V - mov edx, [eax].TVarRec.VCurrency - push DWORD PTR [edx + 4] - push DWORD PTR [edx] - end; - - vtString, // [const] Arg: ShortString - vtPointer, // [const] Arg: Pointer - vtPChar, // [const] Arg: PChar - vtObject, // [const] Arg: TObject - vtClass, // [const] Arg: TClass - vtAnsiString, // [const] Arg: AnsiString - {$IFDEF UNICODE} - vtUnicodeString, // [const] Arg: UnicodeString - {$ENDIF UNICODE} - vtPWideChar, // [const] Arg: PWideChar - vtVariant, // const Arg: Variant - vtInterface, // [const]: IInterface - vtWideString: // [const] Arg: WideString - asm - mov eax, V - push [eax].TVarRec.VPointer - end; - else - UnknownVarRecType(V.VType); - end; - end; - - Result := FProc; - - asm // cdecl => we must clean up - add esp, [ByteCount] - end; -end; -{$ENDIF SUPPORT_LOCAL_FUNCTIONS} - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallArgRecord } - -constructor TAsyncCallArgRecord.Create(AProc: TAsyncCallArgRecordProc; AArg: Pointer); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallArgRecord.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg^); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallMethodArgRecord } - -constructor TAsyncCallMethodArgRecord.Create(AProc: TAsyncCallArgRecordMethod; AArg: Pointer); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallMethodArgRecord.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg^); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallArgObject } - -constructor TAsyncCallArgObject.Create(AProc: TAsyncCallArgObjectProc; AArg: TObject); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallArgObject.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallMethodArgObject } - -constructor TAsyncCallMethodArgObject.Create(AProc: TAsyncCallArgObjectMethod; AArg: TObject); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallMethodArgObject.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallArgString } - -constructor TAsyncCallArgString.Create(AProc: TAsyncCallArgStringProc; - const AArg: string); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallArgString.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallMethodArgString } - -constructor TAsyncCallMethodArgString.Create(AProc: TAsyncCallArgStringMethod; const AArg: string); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallMethodArgString.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallArgWideString } - -constructor TAsyncCallArgWideString.Create(AProc: TAsyncCallArgWideStringProc; const AArg: WideString); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallArgWideString.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallMethodArgWideString } - -constructor TAsyncCallMethodArgWideString.Create(AProc: TAsyncCallArgWideStringMethod; const AArg: WideString); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallMethodArgWideString.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallArgInterface } - -constructor TAsyncCallArgInterface.Create(AProc: TAsyncCallArgInterfaceProc; const AArg: IInterface); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallArgInterface.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallMethodArgInterface } - -constructor TAsyncCallMethodArgInterface.Create(AProc: TAsyncCallArgInterfaceMethod; const AArg: IInterface); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallMethodArgInterface.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallArgExtended } - -constructor TAsyncCallArgExtended.Create(AProc: TAsyncCallArgExtendedProc; const AArg: Extended); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallArgExtended.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallMethodArgExtended } - -constructor TAsyncCallMethodArgExtended.Create(AProc: TAsyncCallArgExtendedMethod; const AArg: Extended); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallMethodArgExtended.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallArgVariant } - -constructor TAsyncCallArgVariant.Create(AProc: TAsyncCallArgVariantProc; const AArg: Variant); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallArgVariant.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } -{ TAsyncCallMethodArgVariant } - -constructor TAsyncCallMethodArgVariant.Create(AProc: TAsyncCallArgVariantMethod; const AArg: Variant); -begin - inherited Create; - FProc := AProc; - FArg := AArg; -end; - -function TAsyncCallMethodArgVariant.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg); -end; - -{ ---------------------------------------------------------------------------- } - -{$IFDEF SUPPORT_LOCAL_FUNCTIONS} -{ TAsyncCallLocalProc } - -constructor TAsyncCallLocalProc.Create(AProc: TLocalAsyncProc; ABasePointer: Pointer); -begin - inherited Create; - @FProc := @AProc; - FBasePointer := ABasePointer; -end; - -function TAsyncCallLocalProc.ExecuteAsyncCall: Integer; -asm - mov edx, [eax].TAsyncCallLocalProc.FBasePointer - mov ecx, [eax].TAsyncCallLocalProc.FProc - xor eax, eax // paramater - push edx - call ecx - pop ecx -end; - -{ TAsyncCallLocalProcEx } - -constructor TAsyncCallLocalProcEx.Create(AProc: TLocalAsyncProc; AParam: INT_PTR; ABasePointer: Pointer); -begin - inherited Create; - @FProc := @AProc; - FBasePointer := ABasePointer; - FParam := AParam; -end; - -function TAsyncCallLocalProcEx.ExecuteAsyncCall: Integer; -asm - mov edx, [eax].TAsyncCallLocalProcEx.FBasePointer - mov ecx, [eax].TAsyncCallLocalProcEx.FProc - mov eax, [eax].TAsyncCallLocalProcEx.FParam - push edx - call ecx - pop ecx -end; - -{ ---------------------------------------------------------------------------- } - -{ TAsyncVclCallLocalProc } - -constructor TAsyncVclCallLocalProc.Create(AProc: TLocalVclProc; AParam: INT_PTR; ABasePointer: Pointer); -begin - inherited Create; - @FProc := @AProc; - FBasePointer := ABasePointer; - FParam := AParam; -end; - -function TAsyncVclCallLocalProc.ExecuteAsyncCall: Integer; -asm - mov edx, [eax].TAsyncCallLocalProcEx.FBasePointer - mov ecx, [eax].TAsyncCallLocalProcEx.FProc - mov eax, [eax].TAsyncCallLocalProcEx.FParam - push edx - call ecx - pop ecx -end; - -{ ---------------------------------------------------------------------------- } - -type - PLocalVclCallRec = ^TLocalVclCallRec; - TLocalVclCallRec = record - BasePointer: Pointer; - Proc: TLocalVclProc; - Param: INT_PTR; - end; - -function LocalVclCallProc(Data: PLocalVclCallRec): Integer; -asm - mov edx, [eax].TLocalVclCallRec.BasePointer - mov ecx, [eax].TLocalVclCallRec.Proc - mov eax, [eax].TLocalVclCallRec.Param - push edx - call ecx - pop ecx -end; - -procedure InternLocalVclCall(LocalProc: TLocalVclProc; Param: INT_PTR; BasePointer: Pointer); -var - M: TMethod; - Data: TLocalVclCallRec; -begin - ThreadPool.CheckDestroying; - Data.BasePointer := BasePointer; - Data.Proc := LocalProc; - Data.Param := Param; - if GetCurrentThreadId = MainThreadID then - LocalVclCallProc(@Data) - else - begin - M.Code := @LocalVclCallProc; - M.Data := @Data; - StaticSynchronize(TThreadMethod(M)); - end; -end; - -procedure LocalVclCall(LocalProc: TLocalVclProc; Param: INT_PTR); -asm - mov ecx, ebp - jmp InternLocalVclCall -end; - -function InternLocalAsyncVclCall(LocalProc: TLocalVclProc; Param: INT_PTR; BasePointer: Pointer): IAsyncCall; -var - Data: TLocalVclCallRec; - Call: TAsyncVclCallLocalProc; -begin - if GetCurrentThreadId = MainThreadID then - begin - Data.BasePointer := BasePointer; - Data.Proc := LocalProc; - Data.Param := Param; - Result := TSyncCall.Create( LocalVclCallProc(@Data) ); - end - else - begin - ThreadPool.CheckDestroying; - Call := TAsyncVclCallLocalProc.Create(LocalProc, Param, BasePointer); - ThreadPool.SendVclSync(Call); - Result := TAsyncCall.Create(Call); - end; -end; - -function LocalAsyncVclCall(LocalProc: TLocalVclProc; Param: INT_PTR = 0): IAsyncCall; -asm - push ecx // interface return address - mov ecx, ebp - call InternLocalAsyncVclCall -end; - -{----------------------------------------------------------------------------} - -type - TMainThreadContext = record - MainThreadEntered: Longint; - MainThreadOpenBlockCount: Longint; - - IntructionPointer: Pointer; - BasePointer: Pointer; - RetAddr: Pointer; - - MainBasePointer: Pointer; - MainStackPointerStart: Pointer; - ContextRetAddr: Pointer; - - MainRegEBX, MainRegEDI, MainRegESI: Pointer; - ThreadRegEBX, ThreadRegEDI, ThreadRegESI: Pointer; - - StackBufferCount: Longint; - StackBuffer: array of Pointer; - end; - -var - MainThreadContext: TMainThreadContext; - MainThreadContextCritSect: TRTLCriticalSection; - -procedure ExecuteInMainThread(Data: TObject); -asm - push ebp - - mov eax, OFFSET MainThreadContext - - { Backup main thread state } - mov edx, OFFSET @@Leave - mov [eax].TMainThreadContext.ContextRetAddr, edx - mov [eax].TMainThreadContext.MainBasePointer, ebp - mov [eax].TMainThreadContext.MainStackPointerStart, esp - - { Backup main thread registers } - mov [eax].TMainThreadContext.MainRegEBX, ebx - mov [eax].TMainThreadContext.MainRegEDI, edi - mov [eax].TMainThreadContext.MainRegESI, esi - - { Set "nested call" control } - mov ecx, [eax].TMainThreadContext.MainThreadOpenBlockCount - mov [eax].TMainThreadContext.MainThreadEntered, ecx - inc ecx - mov [eax].TMainThreadContext.MainThreadOpenBlockCount, ecx - - { Switch to the thread state } - mov ebp, [eax].TMainThreadContext.BasePointer - mov edx, [eax].TMainThreadContext.IntructionPointer - - { Swicth to the thread registers } - mov ebx, [eax].TMainThreadContext.ThreadRegEBX - mov edi, [eax].TMainThreadContext.ThreadRegEDI - mov esi, [eax].TMainThreadContext.ThreadRegESI - - { Jump to the user's synchronized code } - jmp edx - - { LeaveMainThread() will jump to this address after it has restored the main - thread state. } -@@Leave: - pop ebp -end; - -procedure LeaveMainThreadError(ErrorMode: Integer); -begin - case ErrorMode of - 0: raise Exception.CreateRes(@RsLeaveMainThreadNestedError); - 1: raise Exception.CreateRes(@RsLeaveMainThreadThreadError); - end; -end; - -function InitStackBuffer(Count: Integer): Pointer; -begin - MainThreadContext.StackBufferCount := Count; - SetLength(MainThreadContext.StackBuffer, Count); - if Count > 0 then - Result := @MainThreadContext.StackBuffer[0] - else - Result := nil; -end; - -function GetMainThreadId: LongWord; -begin - Result := MainThreadId; -end; - -procedure LeaveMainThread; -asm - { Check if we are in the main thread } - call GetCurrentThreadId - mov ecx, eax - call GetMainThreadId - cmp eax, ecx - jne @@ThreadError - - { "nested call" control } - mov eax, OFFSET MainThreadContext - mov ecx, [eax].TMainThreadContext.MainThreadOpenBlockCount - dec ecx - js @@NestedError - mov [eax].TMainThreadContext.MainThreadOpenBlockCount, ecx - cmp ecx, [eax].TMainThreadContext.MainThreadEntered - jne @@Leave - { Release "nested call" control } - mov [eax].TMainThreadContext.MainThreadEntered, -1 - - { Save the current registers for the return, the compiler might have - generated code that changed the registers in the synchronized code. } - mov [eax].TMainThreadContext.ThreadRegEBX, ebx - mov [eax].TMainThreadContext.ThreadRegEDI, edi - mov [eax].TMainThreadContext.ThreadRegESI, esi - { Restore main thread registers } - mov ebx, [eax].TMainThreadContext.MainRegEBX - mov edi, [eax].TMainThreadContext.MainRegEDI - mov esi, [eax].TMainThreadContext.MainRegESI - - { Detect if the finally block is called by System._HandleFinally. - In that case an exception was raised in the MainThread-Block. The - Classes.CheckSynchronize function will handle the exception and the - thread switch for us. This will also restore the EBP regíster. } - mov eax, [esp + $04] // finally return address - mov edx, OFFSET System.@HandleFinally - cmp eax, edx - jl @@NoException - mov edx, OFFSET System.@HandleAutoException - cmp eax, edx - jl @@InException -@@NoException: - - { Backup the return addresses } - pop edx // procedure return address - - mov eax, OFFSET MainThreadContext - mov [eax].TMainThreadContext.RetAddr, edx - - { Pop all items from the stack that are between ESP and MainStackPointerStart - to an internal buffer that is pushed back on the stack in the - "EnterMainThread" leave-code. } - mov edx, [eax].TMainThreadContext.MainStackPointerStart - mov eax, edx - sub eax, esp - shr eax, 2 // todo: adjust for 64Bit - push edx // MainStackPointerStart => Stack - push eax // Stack item count => Stack - - call InitStackBuffer // returns EAX=Pointer to first item - - pop ecx // Stack item count <= Stack - pop edx // MainStackPointerStart <= Stack - // copy stack - or ecx, ecx - jz @@IgnoreCopyStackLoop - mov edx, eax -@@CopyStackLoop: - pop eax - mov [edx], eax - add edx, 4 - dec ecx - jnz @@CopyStackLoop -@@IgnoreCopyStackLoop: - - { Restore the main thread state } - mov eax, OFFSET MainThreadContext - mov ebp, [eax].TMainThreadContext.MainBasePointer - mov edx, [eax].TMainThreadContext.ContextRetAddr - //mov esp, [eax].TMainThreadContext.MainStackPointerStart // fixes stack pointer - jmp edx - -@@NestedError: - xor eax, eax - call LeaveMainThreadError -@@ThreadError: - mov eax, 1 - call LeaveMainThreadError - -@@InException: -@@Leave: -end; - -procedure EnterMainThread; -asm - { There is nothing to do if we are already in the main thread } - call GetCurrentThreadId - mov ecx, eax - call GetMainThreadId - cmp eax, ecx - je @@InMainThread - - mov eax, ThreadPool - call TThreadPool.CheckDestroying; - - { Enter critical section => implicit waiting queue } - mov eax, OFFSET MainThreadContextCritSect - push eax - call EnterCriticalSection - - { Take the return address from the stack to "clean" the stack } - pop edx - - { Backup the current thread state } - mov eax, OFFSET MainThreadContext - mov [eax].TMainThreadContext.MainThreadEntered, ecx - mov [eax].TMainThreadContext.IntructionPointer, edx - mov [eax].TMainThreadContext.BasePointer, ebp - { Backup the current thread registers } - mov [eax].TMainThreadContext.ThreadRegEBX, ebx - mov [eax].TMainThreadContext.ThreadRegEDI, edi - mov [eax].TMainThreadContext.ThreadRegESI, esi - - { Begin try/finally } -@@Try: - xor eax, eax - push ebp - push OFFSET @@HandleFinally - push dword ptr fs:[eax] - mov fs:[eax], esp - - { Call Synchronize(TMethod(ExecuteInMainThread)) } - xor edx, edx - push edx - mov ecx, OFFSET ExecuteInMainThread - push ecx - call StaticSynchronize - - { Clean up try/finally } - xor eax,eax - pop edx - pop ecx - pop ecx - mov fs:[eax], edx - - { Restore thread state } - mov eax, OFFSET MainThreadContext - mov ebp, [eax].TMainThreadContext.BasePointer - - { Push the backuped stack items back to the stack } - mov ecx, [eax].TMainThreadContext.StackBufferCount - dec ecx - js @@IgnoreRestoreStack - mov eax, [eax].TMainThreadContext.StackBuffer - mov edx, ecx - shl edx, 2 // todo: Adjust for 64 bit - add eax, edx // move to buffer end -@@RestoreStack: - mov edx, [eax] - add eax, -4 - push edx - dec ecx - jns @@RestoreStack -@@IgnoreRestoreStack: - - { Put return address back to the stack } - mov eax, OFFSET MainThreadContext - mov edx, [eax].TMainThreadContext.RetAddr - push edx - - { End try/finally } -@@Finally: - { Restore thread registers } - mov eax, OFFSET MainThreadContext - mov ebx, [eax].TMainThreadContext.ThreadRegEBX - mov edi, [eax].TMainThreadContext.ThreadRegEDI - mov esi, [eax].TMainThreadContext.ThreadRegESI - - { Leave critical section } - mov eax, OFFSET MainThreadContextCritSect - push eax - call LeaveCriticalSection - ret -@@HandleFinally: - jmp System.@HandleFinally - jmp @@Finally -@@LeaveFinally: - ret - -@@InMainThread: - { Adjust "nested call" control. - Threadsafe because we are in the main thread and only the main thread - manipulates MainThreadOpenBlockCount } - inc [MainThreadContext].TMainThreadContext.MainThreadOpenBlockCount -end; -{$ENDIF SUPPORT_LOCAL_FUNCTIONS} - -{----------------------------------------------------------------------------} - -{$IFDEF DELPHI2009_UP} -{ TMultiArgProcCall } -constructor TMultiArgProcCall.Create(AProc: TProc; const AArg1: T1); -begin - inherited Create; - FProc := AProc; - FArg1 := AArg1; -end; - -{ TMultiArgProcCall } -constructor TMultiArgProcCall.Create(AProc: TProc; const AArg1: T1; const AArg2: T2); -begin - inherited Create(AProc, AArg1); - FArg2 := AArg2; -end; - -{ TMultiArgProcCall } -constructor TMultiArgProcCall.Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3); -begin - inherited Create(AProc, AArg1, AArg2); - FArg3 := AArg3; -end; - -{ TMultiArgProcCall } -constructor TMultiArgProcCall.Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3; const AArg4: T4); -begin - inherited Create(AProc, AArg1, AArg2, AArg3); - FArg4 := AArg4; -end; - -{ TAsyncVclCallAnonymProc } - -constructor TAsyncCalls.TAsyncVclCallAnonymProc.Create(AProc: TProc); -begin - inherited Create; - FProc := AProc; -end; - -function TAsyncCalls.TAsyncVclCallAnonymProc.ExecuteAsyncCall: Integer; -begin - FProc(); - Result := 0; -end; - -{ TAsyncCalls.TAsyncCallArg } - -function TAsyncCalls.TAsyncCallArg.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1); -end; - -{ TAsyncCalls.TAsyncCallArg } - -function TAsyncCalls.TAsyncCallArg.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1, FArg2); -end; - -{ TAsyncCalls.TAsyncCallArg } - -function TAsyncCalls.TAsyncCallArg.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1, FArg2, FArg3); -end; - -{ TAsyncCalls.TAsyncCallArg } - -function TAsyncCalls.TAsyncCallArg.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1, FArg2, FArg3, FArg4); -end; - -{ TAsyncCalls.TAsyncCallArgMethod } - -function TAsyncCalls.TAsyncCallArgMethod.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1); -end; - -{ TAsyncCalls.TAsyncCallArgMethod } - -function TAsyncCalls.TAsyncCallArgMethod.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1, FArg2); -end; - -{ TAsyncCalls.TAsyncCallArgMethod } - -function TAsyncCalls.TAsyncCallArgMethod.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1, FArg2, FArg3); -end; - -{ TAsyncCalls.TAsyncCallArgMethod } - -function TAsyncCalls.TAsyncCallArgMethod.ExecuteAsyncCall: Integer; -begin - Result := FProc(FArg1, FArg2, FArg3, FArg4); -end; - -{ TAsyncCalls.TAsyncCallAnonymProc } - -constructor TAsyncCalls.TAsyncCallAnonymProc.Create(AProc: TProc); -begin - inherited Create; - FProc := AProc; -end; - -function TAsyncCalls.TAsyncCallAnonymProc.ExecuteAsyncCall: Integer; -begin - FProc; - Result := 0; -end; - -{ TAsyncCalls.TAsyncCallAnonymFunc } - -constructor TAsyncCalls.TAsyncCallAnonymFunc.Create(AProc: TIntFunc); -begin - inherited Create; - FProc := AProc; -end; - -function TAsyncCalls.TAsyncCallAnonymFunc.ExecuteAsyncCall: Integer; -begin - Result := FProc(); -end; - -{ TAsyncCalls } - -class function TAsyncCalls.Invoke(Proc: TAsyncCallArgGenericProc; const Arg: T): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Proc(Arg)) - else - Result := TAsyncCallArg.Create(Proc, Arg).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Event: TAsyncCallArgGenericMethod; const Arg: T): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Event(Arg)) - else - Result := TAsyncCallArgMethod.Create(Event, Arg).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Proc: TAsyncCallArgGenericProc; const Arg1: T1; const Arg2: T2): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Proc(Arg1, Arg2)) - else - Result := TAsyncCallArg.Create(Proc, Arg1, Arg2).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Event: TAsyncCallArgGenericMethod; const Arg1: T1; const Arg2: T2): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Event(Arg1, Arg2)) - else - Result := TAsyncCallArgMethod.Create(Event, Arg1, Arg2).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Proc: TAsyncCallArgGenericProc; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Proc(Arg1, Arg2, Arg3)) - else - Result := TAsyncCallArg.Create(Proc, Arg1, Arg2, Arg3).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Event: TAsyncCallArgGenericMethod; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Event(Arg1, Arg2, Arg3)) - else - Result := TAsyncCallArgMethod.Create(Event, Arg1, Arg2, Arg3).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Proc: TAsyncCallArgGenericProc; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Proc(Arg1, Arg2, Arg3, Arg4)) - else - Result := TAsyncCallArg.Create(Proc, Arg1, Arg2, Arg3, Arg4).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Event: TAsyncCallArgGenericMethod; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Event(Arg1, Arg2, Arg3, Arg4)) - else - Result := TAsyncCallArgMethod.Create(Event, Arg1, Arg2, Arg3, Arg4).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Func: TIntFunc): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - Result := TSyncCall.Create(Func()) - else - Result := TAsyncCallAnonymFunc.Create(Func).ExecuteAsync; -end; - -class function TAsyncCalls.Invoke(Proc: TProc): IAsyncCall; -begin - { Execute the function synchron if no thread pool exists } - if GetMaxAsyncCallThreads = 0 then - begin - Proc(); - Result := TSyncCall.Create(0); - end - else - Result := TAsyncCallAnonymProc.Create(Proc).ExecuteAsync; -end; - -class procedure TAsyncCalls.VCLSync(Proc: TProc); - - procedure Exec(var P: TProc); - begin - P(); - end; - -var - M: TMethod; -begin - if GetCurrentThreadId = MainThreadID then - Proc() - else - begin - ThreadPool.CheckDestroying; - M.Code := @Exec; - M.Data := @Proc; - StaticSynchronize(TThreadMethod(M)); - end; -end; - -class function TAsyncCalls.VCLInvoke(Proc: TProc): IAsyncCall; -var - Call: TAsyncVclCallAnonymProc; -begin - if GetCurrentThreadId = MainThreadID then - begin - Proc(); - Result := TSyncCall.Create(0); - end - else - begin - ThreadPool.CheckDestroying; - Call := TAsyncVclCallAnonymProc.Create(Proc); - ThreadPool.SendVclSync(Call); - Result := TAsyncCall.Create(Call); - end; -end; - -class procedure TAsyncCalls.MsgExec(AsyncCall: IAsyncCall; IdleMsgMethod: TAsyncIdleMsgMethod); -begin - if GetCurrentThreadId = MainThreadID then - begin - if Assigned(IdleMsgMethod) then - begin - AsyncCall.ForceDifferentThread; - IdleMsgMethod; - while MsgAsyncMultiSync([AsyncCall], False, INFINITE, QS_ALLINPUT or QS_ALLPOSTMESSAGE) = 1 do - IdleMsgMethod; - end; - end - else - AsyncCall.Sync; -end; - -{$ENDIF DELPHI2009_UP} - -{----------------------------------------------------------------------------} - -{ TAsyncCall } - -constructor TAsyncCall.Create(ACall: TInternalAsyncCall); -begin - inherited Create; - FCall := ACall; -end; - -destructor TAsyncCall.Destroy; -begin - if FCall <> nil then - begin - try - FCall.Sync; // throw raised exceptions here - finally - FCall.Free; - end; - end; - inherited Destroy; -end; - -function TAsyncCall.Finished: Boolean; -begin - CheckForget; - Result := FCall.Finished; -end; - -procedure TAsyncCall.ForceDifferentThread; -begin - CheckForget; - FCall.ForceDifferentThread; -end; - -procedure TAsyncCall.Forget; -var - C: TInternalAsyncCall; -begin - CheckForget; - C := FCall; - FCall := nil; - C.Forget; -end; - -function TAsyncCall.ReturnValue: Integer; -begin - CheckForget; - Result := FCall.ReturnValue; -end; - -function TAsyncCall.Sync: Integer; -begin - CheckForget; - Result := FCall.Sync; -end; - -function TAsyncCall.GetEvent: THandle; -begin - CheckForget; - Result := FCall.GetEvent; -end; - -function TAsyncCall.SyncInThisThreadIfPossible: Boolean; -begin - CheckForget; - Result := FCall.SyncInThisThreadIfPossible; -end; - -function TAsyncCall.Canceled: Boolean; -begin - CheckForget; - Result := FCall.Canceled; -end; - -procedure TAsyncCall.CancelInvocation; -begin - CheckForget; - FCall.CancelInvocation; -end; - -procedure TAsyncCall.CheckForget; -begin - if FCall = nil then - raise EAsyncCallError.CreateRes(@RsForgetWasCalled); -end; - -initialization - ThreadPool := TThreadPool.Create; - {$IFDEF SUPPORT_LOCAL_FUNCTIONS} - MainThreadContext.MainThreadEntered := -1; - InitializeCriticalSection(MainThreadContextCritSect); - {$ENDIF SUPPORT_LOCAL_FUNCTIONS} - {$IFNDEF DELPHi7_UP} - SyncEvent := CreateEvent(nil, False, False, nil); - {$ENDIF ~DELPHi7_UP} - -finalization - ThreadPool.Free; - ThreadPool := nil; - {$IFDEF SUPPORT_LOCAL_FUNCTIONS} - DeleteCriticalSection(MainThreadContextCritSect); - {$ENDIF SUPPORT_LOCAL_FUNCTIONS} - {$IFNDEF DELPHi7_UP} - CloseHandle(SyncEvent); - SyncEvent := 0; - {$ENDIF ~DELPHi7_UP} - -end.