•  
Создано: 18.02.2011 1:51:35 · Исправлено: 18.02.2011 1:51:35 · Прочтений: 1122

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  12006: IdThread.pas
{
    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 г. 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}

interface

uses
  Classes,
  IdGlobal, IdException, IdYarn, IdTask, IdThreadSafe,
  SysUtils;

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(TThread)
  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: TThreadMethod); 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;
    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;
    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;

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
  try
    // Must make this call from INSIDE the thread. The call in Create was naming
    // the thread that was creating this thread. :(
    SetThreadName(Name);
    try
      BeforeExecute;
      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;

        try
          try
            Include(FOptions, itoReqCleanup);
            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;
              FreeAndNil(FYarn);
            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
    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;
  inherited Destroy; //+WaitFor!
  try
    if itoReqCleanup in FOptions then begin
      Cleanup;
    end;
  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;

    FreeAndNil(FLock);
    GThreadCount.Decrement;
  end;
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
  FLock.Enter; try
    Include(FOptions, itoStopped);
    inherited Terminate;
  finally FLock.Leave; end;
end;

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

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

procedure TIdThread.Synchronize(Method: TThreadMethod);
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;
end;

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

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

destructor TIdThreadWithTask.Destroy;
begin
  FreeAndNil(FTask);
  inherited;
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;
//  FreeAndNil(GThreadCount);
end.