.\
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
-
-
-
- | 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 WAIT_FAILED. |
-
-
- | 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 WAIT_FAILED. |
-
-
- | 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 (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.