asynccalls.pas

Asyncronous call of delphi functions and procedures.

  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;



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

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


type
  { *** Internal class. Do not use it *** }
  { TAsyncCall is the base class for all parameter based async call types }
  TAsyncCall = class(TInterfacedObject, IAsyncCall, IAsyncCallEx)
  private
    FEvent: THandle;
    FReturnValue: Integer;
    FFinished: Boolean;
    FFatalException: Exception;
    FFatalErrorAddr: Pointer;
    FForceDifferentThread: 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;
  public
    constructor Create;
    destructor Destroy; override;
    function _Release: Integer; stdcall;
    function ExecuteAsync: TAsyncCall;
    function SyncInThisThreadIfPossible: Boolean;

    function GetEvent: Cardinal;

    function Sync: Integer;
    function Finished: Boolean;
    function ReturnValue: Integer;
    procedure ForceDifferentThread;
  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;
  public
    constructor Create(AReturnValue: Integer);
    function Sync: Integer;
    function Finished: Boolean;
    function ReturnValue: Integer;
    procedure ForceDifferentThread;
  end;

{$IFDEF DELPHI2009_UP}
(*
type
  { *** Helpher class *** }
  TMultiArgProcCall<TProc, T1> = class(TAsyncCall)
  private
    FProc: TProc;
    FArg1: T1;
  public
    constructor Create(AProc: TProc; const AArg1: T1);
  end;

  TMultiArgProcCall<TProc, T1, T2> = class(TMultiArgProcCall<TProc, T1>)
  private
    FArg2: T2;
  public
    constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2);
  end;

  TMultiArgProcCall<TProc, T1, T2, T3> = class(TMultiArgProcCall<TProc, T1, T2>)
  private
    FArg3: T3;
  public
    constructor Create(AProc: TProc; const AArg1: T1; const AArg2: T2; const AArg3: T3);
  end;

  TMultiArgProcCall<TProc, T1, T2, T3, T4> = class(TMultiArgProcCall<TProc, T1, T2, T3>)
  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<T> = function(Arg: T): Integer;
      TAsyncCallArgGenericProc<T1, T2> = function(Arg1: T1; Arg2: T2): Integer;
      TAsyncCallArgGenericProc<T1, T2, T3> = function(Arg1: T1; Arg2: T2; Arg3: T3): Integer;
      TAsyncCallArgGenericProc<T1, T2, T3, T4> = function(Arg1: T1; Arg2: T2; Arg3: T3; Arg4: T4): Integer;
      TAsyncCallArgGenericMethod<T> = function(Arg: T): Integer of object;
      TAsyncCallArgGenericMethod<T1, T2> = function(Arg1: T1; Arg2: T2): Integer of object;
      TAsyncCallArgGenericMethod<T1, T2, T3> = function(Arg1: T1; Arg2: T2; Arg3: T3): Integer of object;
      TAsyncCallArgGenericMethod<T1, T2, T3, T4> = function(Arg1: T1; Arg2: T2; Arg3: T3; Arg4: T4): Integer of object;
      TIntFunc = reference to function: Integer;

      TAsyncCallArg<T> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T>, T>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArg<T1, T2> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T1, T2>, T1, T2>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArg<T1, T2, T3> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T1, T2, T3>, T1, T2, T3>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArg<T1, T2, T3, T4> = class(TMultiArgProcCall<TAsyncCallArgGenericProc<T1, T2, T3, T4>, T1, T2, T3, T4>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T>, T>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T1, T2> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T1, T2>, T1, T2>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T1, T2, T3> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T1, T2, T3>, T1, T2, T3>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;

      TAsyncCallArgMethod<T1, T2, T3, T4> = class(TMultiArgProcCall<TAsyncCallArgGenericMethod<T1, T2, T3, T4>, T1, T2, T3, T4>)
      protected
        function ExecuteAsyncCall: Integer; override;
      end;*)
      TIntFunc = reference to function: Integer;

      TAsyncCallAnonymProc = class(TAsyncCall)
      private
        FProc: TProc;
      protected
        function ExecuteAsyncCall: Integer; override;
      public
        constructor Create(AProc: TProc);
      end;

      TAsyncCallAnonymFunc = class(TAsyncCall)
      private
        FProc: TIntFunc;
      protected
        function ExecuteAsyncCall: Integer; override;
      public
        constructor Create(AProc: TIntFunc);
      end;

      TAsyncVclCallAnonymProc = class(TAsyncCall)
      private
        FProc: TProc;
      protected
        function ExecuteAsyncCall: Integer; override;
      public
        constructor Create(AProc: TProc);
      end;

  public
    { Invoke an asynchronous function call }
(*    class function Invoke<T>(Proc: TAsyncCallArgGenericProc<T>; const Arg: T): IAsyncCall; overload; static;
    class function Invoke<T>(Event: TAsyncCallArgGenericMethod<T>; const Arg: T): IAsyncCall; overload; static;
    class function Invoke<T1, T2>(Proc: TAsyncCallArgGenericProc<T1, T2>; const Arg1: T1; const Arg2: T2): IAsyncCall; overload; static;
    class function Invoke<T1, T2>(Event: TAsyncCallArgGenericMethod<T1, T2>; const Arg1: T1; const Arg2: T2): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3>(Proc: TAsyncCallArgGenericProc<T1, T2, T3>; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3>(Event: TAsyncCallArgGenericMethod<T1, T2, T3>; const Arg1: T1; const Arg2: T2; const Arg3: T3): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3, T4>(Proc: TAsyncCallArgGenericProc<T1, T2, T3, T4>; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; overload; static;
    class function Invoke<T1, T2, T3, T4>(Event: TAsyncCallArgGenericMethod<T1, T2, T3, T4>; const Arg1: T1; const Arg2: T2; const Arg3: T3; const Arg4: T4): IAsyncCall; overload; static;*)

    { Invoke an asynchronouse 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 return 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';

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

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