asynccalls.pas

Asyncronous call of delphi functions and procedures.

{**************************************************************************************************}
{                                                                                                  }
{ 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-2008 Andreas Hausladen.             }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ 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}

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

  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;

  TAsyncCallArgObjectProc = function(Arg: TObject): Integer;
  TAsyncCallArgIntegerProc = function(Arg: Integer): Integer;
  TAsyncCallArgStringProc = function(const Arg: AnsiString): 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: AnsiString): 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: AnsiString) 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. }
    function ReturnValue: Integer;

    { ForceDifferentThread() tells AsyncCalls that the assigned function must
      not be executed in the current thread. }
    procedure ForceDifferentThread;
  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: AnsiString): 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: AnsiString): 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: AnsiString): 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);

{ 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;



{ 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;


{ 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
  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;