jvmtthreading.pas

East make Tray Icon in delphi

  // run OnExecute event
  try
    if Assigned(FOnExecute) then
      FOnExecute(Self);
  except
    on E: EMTTerminateError do
      {nothing};
    on E: Exception do
      Log('OnExecute Exception: "' + E.Message + '"'); // do not localize
  end;
  
  // make sure terminate flag is set
  FIntThread.Terminate;

  // run OnTerminating event
  try
    if Assigned(FOnTerminating) then
      FOnTerminating(Self);
  except
    on E: Exception do
      Log('OnTerminate Exception: "' + E.Message + '"'); // do not localize
  end;
  {$IFDEF COMPILER5}
  FIntThread.OnTerminate := nil;
  Synchronize(SyncOnIntThreadTerminate);
  {$ENDIF COMPILER5}
end;

{$IFDEF COMPILER5}
procedure TMTThread.SyncOnIntThreadTerminate;
begin
  OnIntThreadTerminate(Self);
end;
{$ENDIF COMPILER5}

procedure TMTThread.OnIntThreadTerminate(Sender: TObject);
begin
  FStatusChange.Acquire;
  try
    if FFinished then
      Exit;
    FFinished := True;
  finally
    FStatusChange.Release;
  end;

  if Assigned(FOnFinished) then
    FOnFinished(Self);

  FStatusChange.Acquire;
  try
    FIntThread := nil;
  finally
    FStatusChange.Release;
  end;

  // After a call to OnThreadFinished, this object might be destroyed.
  // So don't access any fields after this call.
  FManager.OnThreadFinished(Self);
end;

procedure TMTThread.Release;
begin
  FManager.ReleaseThread(FTicket);
end;

procedure TMTThread.Run;
begin
  FStatusChange.Acquire;
  try
    if Status = tsInitializing then
      CreateAndRun
    else
    if Status = tsWaiting then
      FIntThread.Resume
    else
      raise EMTThreadError.CreateRes(@RsEThreadNotInitializedOrWaiting);
  finally
    FStatusChange.Release;
  end;
end;

procedure TMTThread.SetName(const Value: string);
begin
  FStatusChange.Acquire;
  try
    if Status in [tsInitializing, tsFinished] then
      FName := Value
    else
    begin
      if CurrentMTThread <> Self then
        raise EMTThreadError.CreateRes(@RsECannotChangeNameOfOtherActiveThread);
  
      FName := Value;
      if FIntThread <> nil then
      begin
        FIntThread.Name := FName;
        FIntThread.RaiseName;
      end;
    end;
  finally
    FStatusChange.Release;
  end;
end;

procedure TMTThread.Synchronize(Method: TThreadMethod);
begin
  if CurrentMTThread = Self then
    FIntThread.Synchronize(Method)
  else
  if CurrentMTThread = nil then
    Method
  else
    CurrentMTThread.Synchronize(Method);
end;

procedure TMTThread.Terminate;
begin
  if Status in [tsTerminating, tsFinished] then
    Exit;
  
  FStatusChange.Acquire;
  try
    if FIntThread <> nil then
      FIntThread.Terminate  {thread was Running}
    else
      FFinished := True;    {thread was initializing}
  
    // make sure thread escapes from any Wait() calls
    ReleaseSemaphore(FTerminateSignal, 1, nil);
  finally
    FStatusChange.Release;
  end;
end;

procedure TMTThread.Wait;
var
  SelfRef: TMTThread;
begin
  if FManager.AcquireThread(Ticket, SelfRef) then
  try
    if GetCurrentThreadID = MainThreadID then
    begin
      while Status <> tsFinished do
      begin
        CheckSynchronize;
        Sleep(1);
      end;
    end
    else
    begin
      while Status <> tsFinished do
        Sleep(1);
    end;
  finally
    Release;
  end;
end;

//=== { TMTManager } =========================================================

constructor TMTManager.Create;
begin
  inherited Create;
  FGenTicket := TCriticalSection.Create;
  FThreadsChange := TCriticalSection.Create;
  FThreads := TObjectList.Create(True);
end;

destructor TMTManager.Destroy;
var
  I: Integer;
begin
  // set the terminate flag at each thread
  TerminateThreads;
  // wait for them to finish
  WaitThreads;

  FThreadsChange.Acquire;
  try
    for I := 0 to FThreads.Count-1 do
      Log('Unreleased thread: "' + TMTThread(FThreads[I]).Name + '"'); // do not localize
  finally
    FThreadsChange.Release;
  end;

  FThreads.Free;
  FThreadsChange.Free;
  FGenTicket.Free;
  inherited Destroy;
end;

function TMTManager.AcquireNewThread: TMTThread;
begin
  Result := TMTThread.Create(Self, GenerateTicket);
  try
    Result.IncRef;
    FThreadsChange.Acquire;
    try
      FThreads.Add(Result);
    finally
      FThreadsChange.Release;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function TMTManager.AcquireThread(Ticket: TMTTicket; var Thread: TMTThread):
  Boolean;
begin
  FThreadsChange.Acquire;
  try
    Result := FindThread(Ticket, Thread);
    if Result then
      Thread.IncRef;
  finally
    FThreadsChange.Release;
  end;
end;

// returns 0 = False
//         1 = True
//        -1 = RaiseID found and active

function TMTManager.InternalActiveThreads(RaiseID: Longword): Integer;
var
  I: Integer;
begin
  Result := 0;
  FThreadsChange.Acquire;
  try
    for I := 0 to FThreads.Count - 1 do
      if TMTThread(FThreads[I]).Status <> tsFinished then
      begin
        if (RaiseID <> 0) and
           (TMTThread(FThreads[I]).FIntThread.ThreadID = RaiseID) then
          Result := -1
          // no Break; here: Return -1 only when RaiseID is the last active thread 
        else
        begin
          Result := 1;
          Break;
        end;
      end;
  finally
    FThreadsChange.Release;
  end;
end;

function TMTManager.ActiveThreads: Boolean;
begin
  Result := InternalActiveThreads(0) <> 0;
end;

function TMTManager.FindThread(Ticket: TMTTicket; var Thread: TMTThread):
  Boolean;
var
  I: Integer;
begin
  FThreadsChange.Acquire;
  try
    I := FThreads.Count-1;
    while (I <> -1) and (TMTThread(FThreads[I]).Ticket <> Ticket) do
      Dec(I);
  
    Result := I <> -1;
    if Result then
      Thread := TMTThread(FThreads[I])
    else
      Thread := nil;

  finally
    FThreadsChange.Release;
  end;
end;

function TMTManager.GenerateTicket: TMTTicket;
begin
  FGenTicket.Acquire;
  try
    Result := FNextTicket;
    Inc(FNextTicket);
  finally
    FGenTicket.Release;
  end;
end;

procedure TMTManager.Log(const Msg: string);
begin
  // (rom) no OutputDebugString in production code
  {$IFDEF DEBUGINFO_ON}
  OutputDebugString(PChar('[' + ClassName + '] ' + Msg));
  {$ENDIF DEBUGINFO_ON}
end;

procedure TMTManager.OnThreadFinished(Thread: TMTThread);
begin
  TryRemoveThread(Thread);
end;

procedure TMTManager.ReleaseThread(Ticket: TMTTicket);
var
  Thread: TMTThread;
begin
  FThreadsChange.Acquire;
  try
    if FindThread(Ticket, Thread) then
      Thread.DecRef
    else
      raise EMTThreadError.CreateRes(@RsEReleaseOfUnusedTicket);

    // if this was the last reference then the thread must be removed
    TryRemoveThread(Thread);
  finally
    FThreadsChange.Release;
  end;
end;

procedure TMTManager.TerminateThreads;
var
  I: Integer;
begin
  FThreadsChange.Acquire;
  try
    for I := 0 to FThreads.Count-1 do
      TMTThread(FThreads[I]).Terminate;
  finally
    FThreadsChange.Release;
  end;
end;

procedure TMTManager.TryRemoveThread(Thread: TMTThread);
begin
  FThreadsChange.Acquire;
  try
    if (Thread.Status = tsFinished) and (Thread.ReferenceCount = 0) then
      FThreads.Remove(Thread);
  finally
    FThreadsChange.Release;
  end;
end;

// wait until the threads are all finished

procedure TMTManager.WaitThreads;
begin
  // running from inside the main VCL thread?
  if GetCurrentThreadID = MainThreadID then
  begin
    //  use CheckSynchronise to process the OnFinished events
    while ActiveThreads do
    begin
      CheckSynchronize;
      Sleep(1);
    end;
  end
  else
  begin
    //running in a MTThread, just wait for all threads to finish
    while True do
    begin
      case InternalActiveThreads(GetCurrentThreadID) of
        0:
          Break;
        1:
          { Nothing };
       -1:
         raise EMTThreadError.CreateRes(@RsECurThreadIsPartOfManager);
      end;
      Sleep(1);
    end;
  end;
end;

{$IFDEF COMPILER5}

var
  SyncWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @SyncWndProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'JvMTThreadingSyncWindow');

procedure CreateSyncWindow;
begin
  RegisterClass(SyncWindowClass);
  SyncWindow := CreateWindowEx(WS_EX_TOOLWINDOW, SyncWindowClass.lpszClassName,
    '', WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);
end;

{$ENDIF COMPILER5}

initialization
  {$IFDEF USEJVCL}
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}
  {$ENDIF USEJVCL}
  {$IFDEF COMPILER5}
  InitializeCriticalSection(ThreadSyncLock);
  CreateSyncWindow;
  {$ENDIF COMPILER5}

finalization
  {$IFDEF COMPILER5}
  FinalizeSyncRequestList;
  DeleteCriticalSection(ThreadSyncLock);
  DestroyWindow(SyncWindow);
  SyncWindow := 0;
  {$ENDIF COMPILER5}
  {$IFDEF USEJVCL}
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}
  {$ENDIF USEJVCL}

end.