Componentes.Terceros.UserControl/internal/2.20/1/Source/IdThread.pas

{
  $Project$
  $Workfile$
  $Revision$
  $DateUTC$
  $Id$

  This file is part of the Indy (Internet Direct) project, and is offered
  under the dual-licensing agreement described on the Indy website.
  (http://www.indyproject.org/)

  Copyright:
   (c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
}
{
  $Log$
}
{
{   Rev 1.34    03/16/05 10:29:40 AM  JSouthwell
{ Added a default thread name to ease debugging of IdThreads.
}
{
{   Rev 1.33    1/15/05 1:52:36 PM  RLebeau
{ Extra cleanup handling for the FYarn member
}
{
{   Rev 1.32    1/6/2005 10:02:58 PM  JPMugaas
{ This should compile.
}
{
{   Rev 1.31    1/6/05 2:33:04 PM  RLebeau
{ one more try...finally block, for Before/AfterExecute()
}
{
{   Rev 1.29    1/5/05 5:31:08 PM  RLebeau
{ Added extra try..finally block to Execute() to free the FYarn member.
}
{
    Rev 1.28    6/9/2004 10:38:46 PM  DSiders
  Fixed case for TIdNotifyThreadEvent.
}
{
{   Rev 1.27    3/12/2004 7:11:02 PM  BGooijen
{ Changed order of commands for dotnet
}
{
{   Rev 1.26    2004.03.01 5:12:44 PM  czhower
{ -Bug fix for shutdown of servers when connections still existed (AV)
{ -Implicit HELP support in CMDserver
{ -Several command handler bugs
{ -Additional command handler functionality.
}
{
{   Rev 1.25    2004.02.03 4:17:00 PM  czhower
{ For unit name changes.
}
{
{   Rev 1.24    2004.01.22 5:59:12 PM  czhower
{ IdCriticalSection
}
{
{   Rev 1.23    2003.12.28 2:33:16 PM  czhower
{ .Net finalization fix.
}
{
{   Rev 1.22    2003.12.28 1:27:46 PM  czhower
{ .Net compatibility
}
{
{   Rev 1.21    2003.10.24 12:59:20 PM  czhower
{ Name change
}
{
{   Rev 1.20    2003.10.21 12:19:04 AM  czhower
{ TIdTask support and fiber bug fixes.
}
{
    Rev 1.19    10/15/2003 8:40:48 PM  DSiders
  Added locaization comments.
}
{
{   Rev 1.18    10/5/2003 3:19:58 PM  BGooijen
{ disabled some stuff for DotNet
}
{
{   Rev 1.17    2003.09.19 10:11:22 PM  czhower
{ Next stage of fiber support in servers.
}
{
{   Rev 1.14    2003.09.19 11:54:36 AM  czhower
{ -Completed more features necessary for servers
{ -Fixed some bugs
}
{
{   Rev 1.13    2003.09.18 4:43:18 PM  czhower
{ -Removed IdBaseThread
{ -Threads now have default names
}
{
{   Rev 1.12    12.9.2003 <EFBFBD>. 16:42:08  DBondzhev
{ Fixed AV when exception is raised in BeforeRun and thread is terminated
{ before Start is compleated
}
{
{   Rev 1.11    2003.07.08 2:41:52 PM  czhower
{ Avoid calling SetThreadName if we do not need to
}
{
{   Rev 1.10    08.07.2003 13:16:18  ARybin
{ tiny opt fix
}
{
    Rev 1.9    7/1/2003 7:11:30 PM  BGooijen
  Added comment
}
{
{   Rev 1.8    2003.07.01 4:14:58 PM  czhower
{ Consolidation.
{ Added Name, Loop
}
{
{   Rev 1.7    04.06.2003 14:06:20  ARybin
{ bug fix & limited waiting
}
{
{   Rev 1.6    28.05.2003 14:16:16  ARybin
{ WaitAllThreadsTerminated class method
}
{
{   Rev 1.5    08.05.2003 12:45:10  ARybin
{ "be sure" fix
}
{
    Rev 1.4    4/30/2003 4:53:26 PM  BGooijen
  Fixed bug in Kylix where GThreadCount was not decremented
}
{
    Rev 1.3    4/22/2003 4:44:06 PM  BGooijen
  changed Handle to ThreadID
}
{
    Rev 1.2    3/22/2003 12:53:26 PM  BGooijen
  - Exceptions in the constructor are now handled better.
  - GThreadCount can't become negative anymore
}
{
{   Rev 1.1    06.03.2003 11:54:24  ARybin
{ TIdThreadOptions: is thread Data owner, smart Cleanup
}
{
{   Rev 1.0    11/13/2002 09:01:14 AM  JPMugaas
}
unit IdThread;

{
2002-03-12 -Andrew P.Rybin
  -TerminatingExceptionClass, etc.
2002-06-20 -Andrew P.Rybin
  -"Terminated Start" bug fix (FLock.Leave AV)
  -Wait All threads termination in FINALIZATION (prevent AV in WinSock)
  -HandleRunException
2003-01-27 -Andrew P.Rybin
  -TIdThreadOptions
}
{$I IdCompilerDefines.inc}
{$DEFINE IDFREEONFINAL}

interface

uses
  IdGlobal, IdException, IdSys, IdYarn, IdTask, IdThreadSafe, IdObjs;

const
  IdWaitAllThreadsTerminatedCount = 1 * 60 * 1000;
  IdWaitAllThreadsTerminatedStep  = 250;

type
  EIdThreadException = class(EIdException);
  EIdThreadTerminateAndWaitFor = class(EIdThreadException);

  TIdThreadStopMode = (smTerminate, smSuspend);
  TIdThread = class;
  TIdExceptionThreadEvent = procedure(AThread: TIdThread; AException: Exception) of object;
  TIdNotifyThreadEvent = procedure(AThread: TIdThread) of object;
  TIdSynchronizeThreadEvent = procedure(AThread: TIdThread; AData: Pointer) of object;

  TIdThreadOptions = set of (itoStopped, itoReqCleanup, itoDataOwner, itoTag);

  TIdThread = class(TIdNativeThread)
  protected
    FData: TObject;
    FLock: TIdCriticalSection;
    FLoop: Boolean;
    FName: string;
    FStopMode: TIdThreadStopMode;
    FOptions: TIdThreadOptions;
    FTerminatingException: String;
    FTerminatingExceptionClass: TClass;
    FYarn: TIdYarn;
    //
    FOnException: TIdExceptionThreadEvent;
    FOnStopped: TIdNotifyThreadEvent;
    //
    procedure AfterRun; virtual; //3* not abstract - otherwise it is required
    procedure AfterExecute; virtual;//5 not abstract - otherwise it is required
    procedure BeforeExecute; virtual;//1 not abstract - otherwise it is required
    procedure BeforeRun; virtual; //2* not abstract - otherwise it is required
    procedure Cleanup; virtual;//4*
    procedure DoException (AException: Exception); virtual;
    procedure DoStopped; virtual;
    procedure Execute; override;
    function GetStopped: Boolean;
    function HandleRunException(AException: Exception): Boolean; virtual;
    procedure Run; virtual; abstract;
    class procedure WaitAllThreadsTerminated(
     AMSec: Integer = IdWaitAllThreadsTerminatedCount);
  public
    constructor Create(ACreateSuspended: Boolean = True;
     ALoop: Boolean = True; AName: string = ''); virtual;
    destructor Destroy; override;
    procedure Start; virtual;
    procedure Stop; virtual;
    procedure Synchronize(Method: TIdThreadMethod); overload;
//BGO:TODO    procedure Synchronize(Method: TMethod); overload;
    // Here to make virtual
    procedure Terminate; virtual;
    procedure TerminateAndWaitFor; virtual;
    //
    property Data: TObject read FData write FData;
    property Loop: Boolean read FLoop write FLoop;
    property Name: string read FName write FName;
    property ReturnValue;
    property StopMode: TIdThreadStopMode read FStopMode write FStopMode;
    property Stopped: Boolean read GetStopped;
    property Terminated;
    // TODO: Change this to be like TIdFiber. D6 implementation is not as good
    // as what is done in TIdFiber.
    property TerminatingException: string read FTerminatingException;
    property TerminatingExceptionClass: TClass read FTerminatingExceptionClass;
    //Represents the thread or fiber for the scheduler of the thread.
    property Yarn: TIdYarn read FYarn write FYarn;
    //
    property OnException: TIdExceptionThreadEvent read FOnException write FOnException;
    property OnStopped: TIdNotifyThreadEvent read FOnStopped write FOnStopped;
  end;

  TIdThreadWithTask = class(TIdThread)
  protected
    FTask: TIdTask;
    //
    procedure AfterRun; override;
    procedure BeforeRun; override;
    procedure Run; override;
  public
    // Defaults because
    // Must always create suspended so task can be set
    // And a bit crazy to create a non looped task
    constructor Create(
      ATask: TIdTask = nil;
      AName: string = ''
      ); reintroduce; virtual;
    destructor Destroy;
      override;
    //
    // Must be writeable because tasks are often created after thread or
    // thread is pooled
    property Task: TIdTask read FTask write FTask;
  end;

  TIdThreadClass = class of TIdThread;
  TIdThreadWithTaskClass = class of TIdThreadWithTask;

var
  // GThreadCount shoudl be in implementation as it is not needed outside of
  // this unit. However with D8, GThreadCount will be deallocated before the
  // finalization can run and thus when the finalizaiton accesses GThreadCount
  // in TerminateAll an error occurs. Moving this declaration to the interface
  // "fixes" it.
  GThreadCount: TIdThreadSafeInteger = nil;

implementation

uses
  IdResourceStringsCore;

class procedure TIdThread.WaitAllThreadsTerminated(
 AMSec: Integer = IdWaitAllThreadsTerminatedCount);
begin
  while AMSec > 0 do begin
    if GThreadCount.Value = 0 then begin
      Break;
    end;
    Sleep(IdWaitAllThreadsTerminatedStep);
    AMSec := AMSec - IdWaitAllThreadsTerminatedStep;
  end;
end;

procedure TIdThread.TerminateAndWaitFor;
begin
  if FreeOnTerminate then begin
    raise EIdThreadTerminateAndWaitFor.Create(RSThreadTerminateAndWaitFor);
  end;
  Terminate;
  Start; //resume
  WaitFor;
end;

procedure TIdThread.BeforeRun;
begin
end;

procedure TIdThread.AfterRun;
begin
end;

procedure TIdThread.BeforeExecute;
begin
end;

procedure TIdThread.AfterExecute;
begin
end;

procedure TIdThread.Execute;
begin
  // Must make this call from INSIDE the thread. The call in Create
  // was naming the thread that was creating this thread. :(
  //
  // RLebeau - no need to put this inside the try blocks below as it
  // already uses its own try..except block internally
  if Name = '' then begin
    Name := 'IdThread (unknown)';
  end;
  SetThreadName(Name);

  try
    BeforeExecute;
    try
      while not Terminated do begin
        if Stopped then begin
          DoStopped;
          // It is possible that either in the DoStopped or from another thread,
          // the thread is restarted, in which case we dont want to restop it.
          if Stopped then begin // DONE: if terminated?
            if Terminated then begin
              Break;
            end;
            Suspend; // Thread manager will revive us
            if Terminated then begin
              Break;
            end;
          end;
        end;

        Include(FOptions, itoReqCleanup);
        try
          try
            BeforeRun;
            try
              if Loop then begin
                while not Stopped do begin
                  try
                    Run;
                  except
                    on E: Exception do begin
                      if not HandleRunException(E) then begin
                        Terminate;
                        raise;
                      end;
                    end;
                  end;
                end;
              end else begin
                try
                  Run;
                except
                  on E: Exception do begin
                    if not HandleRunException(E) then begin
                      Terminate;
                      raise;
                    end;
                  end;
                end;
              end;
            finally
              AfterRun;
            end;
          except
            Terminate;
            raise;
          end;
        finally
          Cleanup;
        end;
      end;
    finally
      AfterExecute;
    end;
  except
    on E: Exception do begin
      FTerminatingExceptionClass := E.ClassType;
      FTerminatingException := E.Message;
      DoException(E);
      Terminate;
    end;
  end;
end;

constructor TIdThread.Create(ACreateSuspended: Boolean; ALoop: Boolean;
 AName: string);
begin
{$IFDEF DOTNET}
  inherited Create(true);
{$ENDIF}
  FOptions := [itoDataOwner];
  if ACreateSuspended then begin
    Include(FOptions, itoStopped);
  end;
  FLock := TIdCriticalSection.Create;
  Loop := ALoop;
  Name := AName;
  //
{$IFDEF DOTNET}
  if not ACreateSuspended then begin
    Resume;
  end;
{$ELSE}
  //
  // Most things BEFORE inherited - inherited creates the actual thread and if
  // not suspended will start before we initialize
  inherited Create(ACreateSuspended);
{$ENDIF}
  {$IFNDEF VCL6ORABOVE}
  // Delphi 6 and above raise an exception when an error occures
  // while creating a thread (eg. not enough address space to allocate a stack)
  // Delphi 5 and below don't do that, which results in a TIdThread instance
  // with an invalid handle in it.
  // Therefore we raise the exceptions manually on D5 and below
  {$IFNDEF DOTNET}
  if (ThreadID = 0) then begin
    Sys.RaiseLastOSError;
  end;
  {$ENDIF}
  {$ENDIF}
  // Last, so we only do this if successful
  GThreadCount.Increment;
end;

destructor TIdThread.Destroy;
begin
  FreeOnTerminate := False; //prevent destroy between Terminate & WaitFor
  Terminate;
  try
    if itoReqCleanup in FOptions then begin
      Cleanup;
    end;
  finally
    // RLebeau- clean up the Yarn one more time, in case the thread was
    // terminated after the Yarn was assigned but the thread was not
    // re-started, so the Yarn would not be freed in Cleanup()
    try
      Sys.FreeAndNil(FYarn);
    finally
      // Protect FLock if thread was resumed by Start Method and we are still there.
      // This usually happens if Exception was raised in BeforeRun for some reason
      // And thread was terminated there before Start method is completed.
      FLock.Enter; try
      finally FLock.Leave; end;

      Sys.FreeAndNil(FLock);
      GThreadCount.Decrement;
    end;
  end;
  inherited Destroy; //+WaitFor!
end;

procedure TIdThread.Start;
begin
  FLock.Enter; try
    if Stopped then begin
      // Resume is also called for smTerminate as .Start can be used to initially start a
      // thread that is created suspended
      if Terminated then begin
        Include(FOptions,itoStopped);
      end else begin
        Exclude(FOptions,itoStopped);
      end;
      Resume;
      {APR: [in past] thread can be destroyed here! now Destroy wait FLock}
    end;
  finally FLock.Leave; end;
end;

procedure TIdThread.Stop;
begin
  FLock.Enter; try
    if not Stopped then begin
      case FStopMode of
        smTerminate: Terminate;
        smSuspend: {DO not suspend here. Suspend is immediate. See Execute for implementation};
      end;
      Include(FOptions, itoStopped);
    end;
  finally FLock.Leave; end;
end;

function TIdThread.GetStopped: Boolean;
begin
  if Assigned(FLock) then begin
    FLock.Enter; try
      // Suspended may be True if checking stopped from another thread
      Result := Terminated or (itoStopped in FOptions) or Suspended;
    finally FLock.Leave; end;
  end else begin
    Result := True; //user call Destroy
  end;
end;

procedure TIdThread.DoStopped;
begin
  if Assigned(OnStopped) then begin
    OnStopped(Self);
  end;
end;

procedure TIdThread.DoException (AException: Exception);
begin
  if Assigned(FOnException) then begin
    FOnException(self, AException);
  end;
end;

procedure TIdThread.Terminate;
begin
  //this assert can only raise if terminate is called on an already-destroyed thread
  Assert(FLock<>nil);
  
  FLock.Enter; try
    Include(FOptions, itoStopped);
    inherited Terminate;
  finally FLock.Leave; end;
end;

procedure TIdThread.Cleanup;
begin
  Exclude(FOptions, itoReqCleanup);
  Sys.FreeAndNil(FYarn);
  if itoDataOwner in FOptions then begin
    Sys.FreeAndNil(FData);
  end;
end;

function TIdThread.HandleRunException(AException: Exception): Boolean;
begin
  // Default behavior: Exception is death sentence
  Result := False;
end;

procedure TIdThread.Synchronize(Method: TIdThreadMethod);
begin
  inherited Synchronize(Method);
end;
//BGO:TODO
//procedure TIdThread.Synchronize(Method: TMethod);
//begin
//  inherited Synchronize(TThreadMethod(Method));
//end;

{ TIdThreadWithTask }

procedure TIdThreadWithTask.AfterRun;
begin
  FTask.DoAfterRun;
  inherited AfterRun;
end;

procedure TIdThreadWithTask.BeforeRun;
begin
  inherited BeforeRun;
  FTask.DoBeforeRun;
end;

constructor TIdThreadWithTask.Create(
  ATask: TIdTask;
  AName: string
  );
begin
  inherited Create(True, True, AName);
  FTask := ATask;
end;

destructor TIdThreadWithTask.Destroy;
begin
  Sys.FreeAndNil(FTask);
  inherited Destroy;
end;

procedure TIdThreadWithTask.Run;
begin
  if not FTask.DoRun then begin
    Stop;
  end;
end;

initialization
  SetThreadName('Main');  {do not localize}
  GThreadCount := TIdThreadSafeInteger.Create;

  finalization
  // This call hangs if not all threads have been properly destroyed.
  // But without this, bad threads can often have worse results. Catch 22.
  //TIdThread.WaitAllThreadsTerminated;

  {$IFDEF IDFREEONFINAL}
  //only enable this if you know your code exits thread-clean
  Sys.FreeAndNil(GThreadCount);
  {$ENDIF}
end.