//////////////////////////////////////////////////
//  DB Access Components
//  Copyright © 1998-2007 Core Lab. All right reserved.
//////////////////////////////////////////////////

{$IFNDEF CLR}

{$I Dac.inc}

unit CRThread;
{$ENDIF}
interface
uses
  Classes, SysUtils, SyncObjs,
{$IFDEF LINUX}
{$ELSE}
  Windows,
{$ENDIF}
{$IFDEF CLR}
  System.Runtime.InteropServices;
{$ELSE}
  CLRClasses;
{$ENDIF}

type
  TCRThread = class;
  TCRThreadWrapper = class;

  TCRThreadTerminateEvent = procedure(Sender: TObject) of object;
  TCRThreadExceptionEvent = procedure(Sender: TObject; E: Exception; var Fail: boolean) of object;
  TCRThreadEvent = procedure(Sender: TObject; Event: TObject) of object;
  TCRThreadClass = class of TCRThread;

  TCRThread = class(TThread)
  protected
    FOwner: TCRThreadWrapper;
    FStartEvent: TEvent;

    procedure InternalExecute; virtual;
    procedure Execute; override;
  public
    procedure PostEvent(Event: TObject);
    procedure SendEvent(Event: TObject);

    constructor Create(Owner: TCRThreadWrapper); virtual;
    destructor Destroy; override;
  end;

  TCRThreadWrapper = class
  protected
    FTimerID: UInt;
    FThread: TCRThread;

    FOnPostEvent: TCRThreadEvent;
    FOnSendEvent: TCRThreadEvent;
    FOnException: TCRThreadExceptionEvent;
    FOnTerminate: TCRThreadTerminateEvent;

    FEvents: TThreadList;
    FException: Exception;
    FTerminated: boolean;
    FFreeOnTerminate: boolean;
    FDoTimerProcessing, FLockDestroy: boolean;
    FDestroyAfterTimer: boolean;
    FSendEvent: TObject;
    FSendEventProcessed: TEvent;

    procedure SetTimer;
    procedure KillTimer;
    procedure DoTimer;

    procedure DoPostEvent(Event: TObject); virtual; // In FThread context
    procedure DoSendEvent(Event: TObject); virtual; // In FThread context

    procedure DoException(E: Exception); virtual; // In FThread context
    procedure DoTerminate; // In FThread context

  public
    constructor Create(ThreadClass: TCRThreadClass; CreateSuspended: Boolean);
    destructor Destroy; override;

    procedure Resume;
    procedure Suspend;
    procedure Terminate;

    property Thread: TCRThread read FThread;
    property FreeOnTerminate: boolean read FFreeOnTerminate write FFreeOnTerminate;
    property Terminated: boolean read FTerminated;

    property OnPostEvent: TCRThreadEvent read FOnPostEvent write FOnPostEvent;
    property OnSendEvent: TCRThreadEvent read FOnSendEvent write FOnSendEvent;
    property OnException: TCRThreadExceptionEvent read FOnException write FOnException;
    property OnTerminate: TCRThreadTerminateEvent read FOnTerminate write FOnTerminate;
  end;

implementation

uses
  MemData{$IFDEF VER6P}, StrUtils{$ENDIF};

var
  ThreadList: TThreadList;

{ TCRThread }

constructor TCRThread.Create(Owner: TCRThreadWrapper);
begin
  inherited Create(True);
  Assert(Owner <> nil);
  FOwner := Owner;
  FStartEvent := TEvent.Create(nil, True, False, '');
end;

destructor TCRThread.Destroy;
begin
  inherited;
  FStartEvent.Free;
end;

procedure TCRThread.InternalExecute;
begin
  // Empty
end;

procedure TCRThread.Execute;
begin
  try
    FStartEvent.SetEvent;
    InternalExecute;
  except
    on E: Exception do
      if not (E is EAbort) then
        FOwner.DoException(E);
  end;
  FOwner.DoTerminate;
end;

procedure TCRThread.PostEvent(Event: TObject);
begin
  FOwner.DoPostEvent(Event);
end;

procedure TCRThread.SendEvent(Event: TObject);
begin
  if not Terminated then
    FOwner.DoSendEvent(Event);
end;

{ TCRThreadWrapper }

procedure TimerCallBack(hWnd: HWND; Message: UInt;
{$IFDEF CLR}
  {$IFDEF VER11P}
    TimerID: UINT_PTR;
  {$ELSE}
    TimerID: UInt;
  {$ENDIF}
{$ELSE}
  TimerID: UInt;
{$ENDIF}
  SysTime: DWORD); {$IFNDEF CLR} stdcall; {$ENDIF}
var
  List: TList;
  p: TCRThreadWrapper;
  ThreadWrapper: TCRThreadWrapper;
  i: integer;
begin
  List := ThreadList.LockList;
  try
    ThreadWrapper := nil;
    for i := 0 to List.Count - 1 do begin
      p := TCRThreadWrapper(List[i]);
      if TCRThreadWrapper(p).FTimerID = TimerID then begin
        ThreadWrapper := TCRThreadWrapper(p);
        Break;
      end;
    end;
  finally
    ThreadList.UnlockList;
  end;

  if ThreadWrapper <> nil then
    ThreadWrapper.DoTimer;
 end;

constructor TCRThreadWrapper.Create(ThreadClass: TCRThreadClass; CreateSuspended: Boolean);
begin
  inherited Create;
  
  FEvents := TThreadList.Create;
  FSendEventProcessed := TEvent.Create(nil, True, False, '');

  SetTimer;
  ThreadList.Add(Self);

  FThread := ThreadClass.Create(Self);
  if not CreateSuspended then
    FThread.Resume;
end;

destructor TCRThreadWrapper.Destroy;
begin
  if FLockDestroy then
    Exit;

  if FDoTimerProcessing then begin
    FDestroyAfterTimer := True;
    Exit;
  end;

  if not FFreeOnTerminate then begin
    FLockDestroy := True;
    Terminate;
  end;
  FThread.Free;
  FEvents.Free;

  if FTimerID <> 0 then
    KillTimer;
  ThreadList.Remove(Self);

  inherited;
  FSendEventProcessed.Free;
end;

procedure TCRThreadWrapper.Resume;
begin
  Thread.Resume;
end;

procedure TCRThreadWrapper.Suspend;
begin
  Thread.Suspend;
end;

procedure TCRThreadWrapper.Terminate;
begin
  WaitForSingleObject(Thread.FStartEvent.Handle, INFINITE);
  Thread.Terminate;
  FSendEventProcessed.SetEvent;
{$IFNDEF CLR}
  WaitForSingleObject(Thread.Handle, INFINITE);
{$ELSE}
  Thread.WaitFor;
{$ENDIF}
  DoTimer;
end;

procedure TCRThreadWrapper.DoPostEvent(Event: TObject); // In FThread context
begin
  Assert(FEvents <> nil);
  FEvents.Add(Event);
end;

procedure TCRThreadWrapper.DoSendEvent(Event: TObject); // In FThread context
begin
  FSendEvent := Event;
  WaitForSingleObject(FSendEventProcessed.Handle, INFINITE);
  FSendEventProcessed.ResetEvent;
end;

procedure TCRThreadWrapper.DoException(E: Exception); // In FThread context
begin
  Assert(FException = nil);
  FException := Exception.Create(E.Message);
end;

procedure TCRThreadWrapper.DoTerminate; // In FThread context
begin
  Assert(not FTerminated);
  FTerminated := True;
end;

procedure TCRThreadWrapper.SetTimer;
const
  USER_TIMER_MINIMUM = $A;
var
  TimerFunc: TFNTimerProc;
begin
  Assert(FTimerID = 0);
  TimerFunc := {$IFNDEF CLR}@{$ENDIF}TimerCallBack;
  FTimerID := Windows.SetTimer(0, 0, USER_TIMER_MINIMUM, TimerFunc);
  Win32Check(FTimerID <> 0);
end;

procedure TCRThreadWrapper.KillTimer;
begin
  Assert(FTimerID <> 0);
  Windows.KillTimer(0, FTimerID);
  FTimerID := 0;
end;

procedure TCRThreadWrapper.DoTimer; // In main thread context
var
  Fail: boolean;
  List: TList;
  FreeThread: boolean;
begin
  if FDoTimerProcessing then
    Exit; // For example - on showing error message
  FDoTimerProcessing := True;

  KillTimer; // To prevent multiple calls to DoTimer if any event handler call ProcessMessage
  try
    if (FSendEvent <> nil) then begin
      if Assigned(FOnSendEvent) then
        FOnSendEvent(Self, FSendEvent);
      FSendEvent := nil;
      FSendEventProcessed.SetEvent;
    end;

    if FEvents <> nil then begin
      List := FEvents.LockList;
      try
        while List.Count > 0 do begin
          try
            if Assigned(FOnPostEvent) then
              FOnPostEvent(Self, TObject(List[0]));
          finally
            List.Delete(0);
          end;
        end;
      finally
        FEvents.UnlockList;
      end;
    end;

    if FException <> nil then begin
      try
        Fail := True;
        if Assigned(FOnException) then
          FOnException(Self, FException, Fail);
        if Fail then begin
          try
            raise FException;
          except
            if Assigned(ApplicationHandleException) then
              ApplicationHandleException(FException)
            else
              ShowException(FException, ExceptAddr);
          end;
        end
        else
          FException.Free;
      finally
        FException := nil;
      end;
    end;

    if FTerminated and Assigned(FOnTerminate) then
      FOnTerminate(Self);
  finally
    FDoTimerProcessing := False;
    FreeThread := (FTerminated and FFreeOnTerminate) or FDestroyAfterTimer;
    if FreeThread then
      Free
    else begin
      FTerminated := False;
      SetTimer;
    end;
  end;
end;

initialization
  ThreadList := TThreadList.Create;

finalization
  ThreadList.Free;

end.