{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is ThreadExpertUnit.pas.                                                       }
{                                                                                                  }
{ The Initial Developer of the Original Code is Petr Vones.                                        }
{ Portions created by Petr Vones are Copyright (C) of Petr Vones.                                  }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Unit owner: Petr Vones                                                                           }
{ Last modified: $Date: 2006/01/08 17:16:56 $                                                      }
{                                                                                                  }
{**************************************************************************************************}

unit ThreadExpertUnit;

{$I jcl.inc}

interface

uses
  Windows, Classes, SysUtils, ToolsAPI, ComCtrls, Dialogs,
  ThreadExpertSharedNames,
  JclOtaUtils, JclSynch;

type
  TNameChangeThread = class;

  TJclThreadsExpert = class(TJclOTAExpert)
  private
    DebuggerServices: IOTADebuggerServices;
    FProcessesCount: Integer;
    FNameChangeThread: TNameChangeThread;
    FNotifierIndex: Integer;
    FSharedThreadNames: TSharedThreadNames;
    FThreadsStatusListView: TListView;
    function GetThreadsStatusListView: TListView;
    function GetThreadsStatusListViewFound: Boolean;
    procedure ListViewChange(Sender: TObject; Item: TListItem; Change: TItemChange);
    function UpdateItem(Item: TListItem): Boolean;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
    procedure UpdateContent;
    property ProcessesCount: Integer read FProcessesCount;
    property ThreadsStatusListView: TListView read GetThreadsStatusListView;
    property ThreadsStatusListViewFound: Boolean read GetThreadsStatusListViewFound;
  end;

  TDebuggerNotifier = class(TNotifierObject, IOTADebuggerNotifier)
  private
    FExpert: TJclThreadsExpert;
  protected
    procedure BreakpointAdded({$IFDEF RTL170_UP} const {$ENDIF} Breakpoint: IOTABreakpoint);
    procedure BreakpointDeleted({$IFDEF RTL170_UP} const {$ENDIF} Breakpoint: IOTABreakpoint);
    procedure ProcessCreated({$IFDEF RTL170_UP} const {$ENDIF} Process: IOTAProcess);
    procedure ProcessDestroyed({$IFDEF RTL170_UP} const {$ENDIF} Process: IOTAProcess);
  public
    constructor Create(AExpert: TJclThreadsExpert);
  end;

  TNameChangeThread = class(TThread)
  private
    FExpert: TJclThreadsExpert;
    FNotifyEvent: TJclEvent;
    FTerminateEvent: THandle;
    procedure TryFindThreadsStatusListView;
    procedure UpdateRequest;
  protected
    procedure Execute; override;
  public
    constructor Create(AExpert: TJclThreadsExpert; ANotifyEvent: TJclEvent);
    destructor Destroy; override;
    procedure TerminateThread;
  end;

// design package entry point
procedure Register;

// expert DLL entry point
function JCLWizardInit(const BorlandIDEServices: IBorlandIDEServices;
  RegisterProc: TWizardRegisterProc;
  var TerminateProc: TWizardTerminateProc): Boolean; stdcall;

implementation

uses
  Forms, Controls,
  JclSysUtils,
  JclOtaConsts, JclOtaResources;

const
  ThreadsStatusListViewFindPeriod = 2000;
  ReadNameTimeout                 = 500;

procedure Register;
begin
  try
    RegisterPackageWizard(TJclThreadsExpert.Create);
  except
    on ExceptionObj: TObject do
    begin
      JclExpertShowExceptionDialog(ExceptionObj);
      raise;
    end;
  end;
end;

var
  JCLWizardIndex: Integer = -1;

procedure JclWizardTerminate;
var
  OTAWizardServices: IOTAWizardServices;
begin
  try
    if JCLWizardIndex <> -1 then
    begin
      Supports(BorlandIDEServices, IOTAWizardServices, OTAWizardServices);
      if not Assigned(OTAWizardServices) then
        raise EJclExpertException.CreateTrace(RsENoWizardServices);

      OTAWizardServices.RemoveWizard(JCLWizardIndex);
    end;
  except
    on ExceptionObj: TObject do
    begin
      JclExpertShowExceptionDialog(ExceptionObj);
    end;
  end;
end;

function JCLWizardInit(const BorlandIDEServices: IBorlandIDEServices;
    RegisterProc: TWizardRegisterProc;
    var TerminateProc: TWizardTerminateProc): Boolean stdcall;
var
  OTAWizardServices: IOTAWizardServices;
begin
  try
    TerminateProc := JclWizardTerminate;

    Supports(BorlandIDEServices, IOTAWizardServices, OTAWizardServices);
    if not Assigned(OTAWizardServices) then
      raise EJclExpertException.CreateTrace(RsENoWizardServices);

    JCLWizardIndex := OTAWizardServices.AddWizard(TJclThreadsExpert.Create);

    Result := True;
  except
    on ExceptionObj: TObject do
    begin
      JclExpertShowExceptionDialog(ExceptionObj);
      Result := False;
    end;
  end;
end;

//== { TJclThreadsExpert } ===================================================

constructor TJclThreadsExpert.Create;
begin
  inherited Create(JclThreadsExpertName);
  DebuggerServices := BorlandIDEServices as IOTADebuggerServices;
  FSharedThreadNames := TSharedThreadNames.Create(True);
  FNotifierIndex := DebuggerServices.AddNotifier(TDebuggerNotifier.Create(Self));
  FNameChangeThread := TNameChangeThread.Create(Self, FSharedThreadNames.NotifyEvent);
end;

destructor TJclThreadsExpert.Destroy;
begin
  if FNotifierIndex <> -1 then
    DebuggerServices.RemoveNotifier(FNotifierIndex);
  if Assigned(FThreadsStatusListView) then
    FThreadsStatusListView.OnChange := nil;
  FNameChangeThread.TerminateThread;
  FreeAndNil(FNameChangeThread);
  FreeAndNil(FSharedThreadNames);
  inherited Destroy;
end;

function TJclThreadsExpert.GetThreadsStatusListView: TListView;
var
  I: Integer;
  F: TForm;
begin
  if FThreadsStatusListView = nil then
  begin
    F := nil;
    with Screen do
      for I := 0 to FormCount - 1 do
        if Forms[I].ClassName = 'TThreadStatus' then
        begin
          F := Forms[I];
          Break;
        end;
    if F <> nil then
      with F do
        for I := 0 to ControlCount -1 do
          if Controls[I] is TListView then
          begin
            FThreadsStatusListView := TListView(Controls[I]);
            Break;
          end;
    if FThreadsStatusListView <> nil then
      FThreadsStatusListView.OnChange := ListViewChange;
  end;
  Result := FThreadsStatusListView;
end;

function TJclThreadsExpert.GetThreadsStatusListViewFound: Boolean;
begin
  Result := Assigned(FThreadsStatusListView);
end;

procedure TJclThreadsExpert.ListViewChange(Sender: TObject; Item: TListItem; Change: TItemChange);
begin
  try
    if Change = ctText then
      UpdateItem(Item);
  except
    on ExceptionObj: TObject do
    begin
      JclExpertShowExceptionDialog(ExceptionObj);
      raise;
    end;
  end;
end;

procedure TJclThreadsExpert.UpdateContent;
var
  I: Integer;
begin
  try
    with ThreadsStatusListView do
    begin
      {Items.BeginUpdate;
      try}
        for I := 0 to Items.Count - 1 do
          if not UpdateItem(Items[I]) then
            Break;
      {finally
        Items.EndUpdate;
      end;}
    end;          
  except
    on ExceptionObj: TObject do
    begin
      JclExpertShowExceptionDialog(ExceptionObj);
      raise;
    end;
  end;
end;

var
  CaptionChanging: Boolean;

function TJclThreadsExpert.UpdateItem(Item: TListItem): Boolean;
var
  TID: DWORD;
  Caption, ThreadName: string;
begin
  Result := True;
  if CaptionChanging then
    Exit;
  Caption := Item.Caption;
  if (Length(Caption) >= 9) and (Caption[1] = '$') then
  begin
    Caption := Copy(Caption, 1, 9);
    TID := StrToInt(Caption);
    Result := FSharedThreadNames.ThreadNameTimoeut(TID, ReadNameTimeout, ThreadName);
    if Result then
    begin
      CaptionChanging := True;
      try
        Item.Caption := Format('%s  %s', [Caption, ThreadName]);
      finally
        CaptionChanging := False;
      end;
    end;
  end;
end;

//=== { TDebuggerNotifier } ==================================================

constructor TDebuggerNotifier.Create(AExpert: TJclThreadsExpert);
begin
  FExpert := AExpert;
end;

procedure TDebuggerNotifier.BreakpointAdded({$IFDEF RTL170_UP} const {$ENDIF} Breakpoint: IOTABreakpoint);
begin
end;

procedure TDebuggerNotifier.BreakpointDeleted({$IFDEF RTL170_UP} const {$ENDIF} Breakpoint: IOTABreakpoint);
begin
end;

procedure TDebuggerNotifier.ProcessCreated({$IFDEF RTL170_UP} const {$ENDIF} Process: IOTAProcess);
begin
  try
    FExpert.GetThreadsStatusListView;
    Inc(FExpert.FProcessesCount);
  except
    on ExceptionObj: TObject do
    begin
      JclExpertShowExceptionDialog(ExceptionObj);
      raise;
    end;
  end;
end;

procedure TDebuggerNotifier.ProcessDestroyed({$IFDEF RTL170_UP} const {$ENDIF} Process: IOTAProcess);
begin
  try
    Dec(FExpert.FProcessesCount);
    FExpert.FSharedThreadNames.Cleanup(Process.ProcessId);
  except
    on ExceptionObj: TObject do
    begin
      JclExpertShowExceptionDialog(ExceptionObj);
      raise;
    end;
  end;
end;

//=== { TNameChangeThread } ==================================================

constructor TNameChangeThread.Create(AExpert: TJclThreadsExpert; ANotifyEvent: TJclEvent);
begin
  inherited Create(True);
  Priority := tpLowest;
  FExpert := AExpert;
  FNotifyEvent := ANotifyEvent;
  FTerminateEvent := CreateEvent(nil, True, False, nil);
  Resume;
end;

destructor TNameChangeThread.Destroy;
begin
  CloseHandle(FTerminateEvent);
  inherited Destroy;
end;

procedure TNameChangeThread.Execute;
var
  WaitHandles: array [0..1] of THandle;
  WaitTimeout: DWORD;
begin
  WaitHandles[0] := FTerminateEvent;
  WaitHandles[1] := FNotifyEvent.Handle;
  WaitTimeout := ThreadsStatusListViewFindPeriod;
  repeat
    case Windows.WaitForMultipleObjects(2, @WaitHandles, False, WaitTimeout) of
      WAIT_OBJECT_0:
        Break;
      WAIT_OBJECT_0 + 1:
        begin
          Synchronize(UpdateRequest);
          Sleep(30); // To prevent overload the IDE by many update requests
        end;
      WAIT_TIMEOUT:
        if FExpert.ProcessesCount > 0 then
        begin
          if not FExpert.ThreadsStatusListViewFound then
            Synchronize(TryFindThreadsStatusListView);
          if FExpert.ThreadsStatusListViewFound then
            WaitTimeout := INFINITE;
        end;
    end;
  until Terminated;
end;

procedure TNameChangeThread.TerminateThread;
begin
  Terminate;
  SetEvent(FTerminateEvent);
  WaitFor;
end;

procedure TNameChangeThread.TryFindThreadsStatusListView;
begin
  if FExpert.GetThreadsStatusListView <> nil then
    FExpert.UpdateContent;
end;

procedure TNameChangeThread.UpdateRequest;
begin
  FExpert.UpdateContent;
end;

// History:

// $Log: ThreadExpertUnit.pas,v $
// Revision 1.7  2006/01/08 17:16:56  outchy
// Settings reworked.
// Common window for expert configurations
//
// Revision 1.6  2005/12/26 18:03:40  outchy
// Enhanced bds support (including C#1 and D8)
// Introduction of dll experts
// Project types in templates
//
// Revision 1.5  2005/12/16 23:46:25  outchy
// Added expert stack form.
// Added code to display call stack on expert exception.
// Fixed package extension for D2006.
//
// Revision 1.4  2005/10/26 03:29:44  rrossmair
// - improved header information, added Date and Log CVS tags
//

end.