unit ThreadAbort;

interface

uses
  Windows, SysUtils, Classes;

{ These functions raise the given exception inside the given thread.
  The underscore variant simply returns False/True to indicate the success or
  failure of the action, while the other two raise an EOSError on that.
}
function _RaiseInThread(Which: THandle; E: Exception): Boolean;
procedure RaiseInThread(Which: THandle; E: Exception); overload;
procedure RaiseInThread(Which: TThread; E: Exception); overload;

{ These functions raise an EThreadAbort exception inside the given thread.
}
type
  EThreadAbort = class(Exception);

procedure AbortThread(Which: THandle; const Message: string = ''); overload;
procedure AbortThread(Which: TThread; const Message: string = ''); overload;

implementation

{ Raise an exception in the given thread.
}
function _RaiseInThread(Which: THandle; E: Exception): Boolean;
var
  Context: TContext;

  procedure Push(c: DWORD);
  begin
    Dec(Context.Esp, SizeOf(DWORD));
    PCardinal(Context.Esp)^ := c;
  end;

begin
  if Which = GetCurrentThread then
    raise E;

  Result := False;
  if SuspendThread(Which) = DWORD(-1) then
    Exit;
  try
    Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER;
    if not GetThreadContext(Which, Context) then
      Exit;

    { The following lines are copied from System.pas / _RaiseExcept,
      which (sadly) cannot be called directly. It uses the same calling
      convention since Delphi 3 (Delphi 2 uses a different signature).
    }
    Push(Context.Esp);
    Push(Context.Ebp);
    Push(Context.Edi);
    Push(Context.Esi);
    Push(Context.Ebx);
    Push(DWORD(E)); { pass class argument         }
    Push(Context.Eip); { pass address argument       }

    Push(Context.Esp); { pass pointer to arguments   }
    Push(7); { there are seven arguments   }
    Push(1); { cNonContinuable:  we can't continue execution }
    Push($0EEDFADE); { cDelphiException: our magic exception code    }
    Push(Context.Eip); { pass the return address     }

    {$IFDEF CONDITIONALEXPRESSIONS} // Delphi 6+
    Context.Eip := DWORD(RaiseExceptionProc);
    {$ELSE}
    Context.Eip := DWORD(@RaiseException);
    {$ENDIF}

    if SetThreadContext(Which, Context) then
      Result := True;
  finally
    if ResumeThread(Which) = DWORD(-1) then
      Result := False;
  end;
end;

procedure RaiseInThread(Which: THandle; E: Exception);
begin
  if not _RaiseInThread(Which, E) then
    RaiseLastOSError;
end;

procedure RaiseInThread(Which: TThread; E: Exception);
begin
  RaiseInThread(Which.Handle, E);
end;

procedure AbortThread(Which: THandle; const Message: string);
begin
  RaiseInThread(Which, EThreadAbort.Create(Message));
end;

procedure AbortThread(Which: TThread; const Message: string);
begin
  AbortThread(Which.Handle, Message);
end;

end.