/jcl/experts/repository/ExceptionDialog/StandardDialogs/ExceptDlg.pas

  1{**************************************************************************************************}
  2{                                                                                                  }
  3{ Project JEDI Code Library (JCL)                                                                  }
  4{                                                                                                  }
  5{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
  6{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
  7{ License at http://www.mozilla.org/MPL/                                                           }
  8{                                                                                                  }
  9{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
 10{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
 11{ and limitations under the License.                                                               }
 12{                                                                                                  }
 13{ The Original Code is ExceptDlg.pas.                                                              }
 14{                                                                                                  }
 15{ The Initial Developer of the Original Code is Petr Vones.                                        }
 16{ Portions created by Petr Vones are Copyright (C) of Petr Vones.                                  }
 17{                                                                                                  }
 18{**************************************************************************************************}
 19{                                                                                                  }
 20{ Last modified: $Date::                                                                         $ }
 21{ Revision:      $Rev::                                                                          $ }
 22{ Author:        $Author::                                                                       $ }
 23{                                                                                                  }
 24{**************************************************************************************************}
 25
 26unit ExceptDlg;
 27
 28interface
 29
 30uses
 31  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 32  Dialogs, StdCtrls, ExtCtrls, AppEvnts,
 33  JclSysUtils, JclUnitVersioning, JclUnitVersioningProviders, JclDebug;
 34
 35
 36const
 37  UM_CREATEDETAILS = WM_USER + $100;
 38
 39type
 40  TExceptionDialog = class(TForm)
 41    SaveBtn: TButton;
 42    TextMemo: TMemo;
 43    OkBtn: TButton;
 44    DetailsBtn: TButton;
 45    BevelDetails: TBevel;
 46    DetailsMemo: TMemo;
 47    procedure SaveBtnClick(Sender: TObject);
 48    procedure FormPaint(Sender: TObject);
 49    procedure FormCreate(Sender: TObject);
 50    procedure FormShow(Sender: TObject);
 51    procedure DetailsBtnClick(Sender: TObject);
 52    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
 53    procedure FormDestroy(Sender: TObject);
 54    procedure FormResize(Sender: TObject);
 55  private
 56    private
 57    FDetailsVisible: Boolean;
 58    FThreadID: DWORD;
 59    FLastActiveControl: TWinControl;
 60    FNonDetailsHeight: Integer;
 61    FFullHeight: Integer;
 62    procedure SaveToLogFile(const FileName: TFileName);
 63    function GetReportAsText: string;
 64    procedure SetDetailsVisible(const Value: Boolean);
 65    procedure UMCreateDetails(var Message: TMessage); message UM_CREATEDETAILS;
 66  protected
 67    procedure AfterCreateDetails; dynamic;
 68    procedure BeforeCreateDetails; dynamic;
 69    procedure CreateDetails; dynamic;
 70    procedure CreateReport;
 71    function ReportMaxColumns: Integer; virtual;
 72    function ReportNewBlockDelimiterChar: Char; virtual;
 73    procedure NextDetailBlock;
 74    procedure UpdateTextMemoScrollbars;
 75  public
 76    procedure CopyReportToClipboard;
 77    class procedure ExceptionHandler(Sender: TObject; E: Exception);
 78    class procedure ExceptionThreadHandler(Thread: TJclDebugThread);
 79    class procedure ShowException(E: TObject; Thread: TJclDebugThread);
 80    property DetailsVisible: Boolean read FDetailsVisible
 81      write SetDetailsVisible;
 82    property ReportAsText: string read GetReportAsText;
 83  end;
 84
 85  TExceptionDialogClass = class of TExceptionDialog;
 86
 87var
 88  ExceptionDialogClass: TExceptionDialogClass = TExceptionDialog;
 89
 90implementation
 91
 92{$R *.dfm}
 93
 94uses
 95  ClipBrd, Math,
 96  JclBase, JclFileUtils, JclHookExcept, JclPeImage, JclStrings, JclSysInfo, JclWin32;
 97
 98resourcestring
 99  RsAppError = '%s - application error';
100  RsExceptionClass = 'Exception class: %s';
101  RsExceptionMessage = 'Exception message: %s';
102  RsExceptionAddr = 'Exception address: %p';
103  RsStackList = 'Stack list, generated %s';
104  RsModulesList = 'List of loaded modules:';
105  RsOSVersion = 'System   : %s %s, Version: %d.%d, Build: %x, "%s"';
106  RsProcessor = 'Processor: %s, %s, %d MHz';
107  RsMemory = 'Memory: %d; free %d';
108  RsScreenRes = 'Display  : %dx%d pixels, %d bpp';
109  RsActiveControl = 'Active Controls hierarchy:';
110  RsThread = 'Thread: %s';
111  RsMissingVersionInfo = '(no module version info)';
112  RsExceptionStack = 'Exception stack';
113  RsMainThreadID = 'Main thread ID = %d';
114  RsExceptionThreadID = 'Exception thread ID = %d';
115  RsMainThreadCallStack = 'Call stack for main thread';
116  RsThreadCallStack = 'Call stack for thread %d %s "%s"';
117  RsExceptionThreadCallStack = 'Call stack for exception thread %s';
118  RsErrorMessage = 'There was an error during the execution of this program.' + NativeLineBreak +
119                   'The application might become unstable and even useless.' + NativeLineBreak +
120                   'It''s recommended that you save your work and close this application.' + NativeLineBreak + NativeLineBreak;
121  RsDetailsIntro = 'Exception log with detailed tech info. Generated on %s.' + NativeLineBreak +
122                   'You may send it to the application vendor, helping him to understand what had happened.' + NativeLineBreak +
123                   ' Application title: %s' + NativeLineBreak +
124                   ' Application file: %s';
125  RsUnitVersioningIntro = 'Unit versioning information:';
126
127var
128  ExceptionDialog: TExceptionDialog;
129
130//============================================================================
131// Helper routines
132//============================================================================
133
134// SortModulesListByAddressCompare
135// sorts module by address
136function SortModulesListByAddressCompare(List: TStringList;
137  Index1, Index2: Integer): Integer;
138var
139  Addr1, Addr2: TJclAddr;
140begin
141  Addr1 := TJclAddr(List.Objects[Index1]);
142  Addr2 := TJclAddr(List.Objects[Index2]);
143  if Addr1 > Addr2 then
144    Result := 1
145  else if Addr1 < Addr2 then
146    Result := -1
147  else
148    Result := 0;
149end;
150
151//============================================================================
152// TApplication.HandleException method code hooking for exceptions from DLLs
153//============================================================================
154
155// We need to catch the last line of TApplication.HandleException method:
156// [...]
157//   end else
158//    SysUtils.ShowException(ExceptObject, ExceptAddr);
159// end;
160
161procedure HookShowException(ExceptObject: TObject; ExceptAddr: Pointer);
162begin
163  if JclValidateModuleAddress(ExceptAddr)
164    and (ExceptObject.InstanceSize >= Exception.InstanceSize) then
165    TExceptionDialog.ExceptionHandler(nil, Exception(ExceptObject))
166  else
167    SysUtils.ShowException(ExceptObject, ExceptAddr);
168end;
169
170//----------------------------------------------------------------------------
171
172function HookTApplicationHandleException: Boolean;
173const
174  CallOffset      = $86;   // Until D2007
175  CallOffsetDebug = $94;   // Until D2007
176  CallOffsetWin32 = $7A;   // D2009 and newer
177  CallOffsetWin64 = $95;   // DXE2 for Win64
178type
179  PCALLInstruction = ^TCALLInstruction;
180  TCALLInstruction = packed record
181    Call: Byte;
182    Address: Integer;
183  end;
184var
185  TApplicationHandleExceptionAddr, SysUtilsShowExceptionAddr: Pointer;
186  CALLInstruction: TCALLInstruction;
187  CallAddress: Pointer;
188  WrittenBytes: Cardinal;
189
190  function CheckAddressForOffset(Offset: Cardinal): Boolean;
191  begin
192    try
193      CallAddress := Pointer(TJclAddr(TApplicationHandleExceptionAddr) + Offset);
194      CALLInstruction.Call := $E8;
195      Result := PCALLInstruction(CallAddress)^.Call = CALLInstruction.Call;
196      if Result then
197      begin
198        if IsCompiledWithPackages then
199          Result := PeMapImgResolvePackageThunk(Pointer(SizeInt(CallAddress) + Integer(PCALLInstruction(CallAddress)^.Address) + SizeOf(CALLInstruction))) = SysUtilsShowExceptionAddr
200        else
201          Result := PCALLInstruction(CallAddress)^.Address = SizeInt(SysUtilsShowExceptionAddr) - SizeInt(CallAddress) - SizeOf(CALLInstruction);
202      end;
203    except
204      Result := False;
205    end;
206  end;
207
208begin
209  TApplicationHandleExceptionAddr := PeMapImgResolvePackageThunk(@TApplication.HandleException);
210  SysUtilsShowExceptionAddr := PeMapImgResolvePackageThunk(@SysUtils.ShowException);
211  if Assigned(TApplicationHandleExceptionAddr) and Assigned(SysUtilsShowExceptionAddr) then
212  begin
213    Result := CheckAddressForOffset(CallOffset) or CheckAddressForOffset(CallOffsetDebug) or
214      CheckAddressForOffset(CallOffsetWin32) or CheckAddressForOffset(CallOffsetWin64);
215    if Result then
216    begin
217      CALLInstruction.Address := SizeInt(@HookShowException) - SizeInt(CallAddress) - SizeOf(CALLInstruction);
218      Result := WriteProtectedMemory(CallAddress, @CallInstruction, SizeOf(CallInstruction), WrittenBytes);
219    end;
220  end
221  else
222    Result := False;
223end;
224
225//============================================================================
226// Exception dialog
227//============================================================================
228
229var
230  ExceptionShowing: Boolean;
231
232//=== { TExceptionDialog } ===============================================
233
234procedure TExceptionDialog.AfterCreateDetails;
235begin
236  SaveBtn.Enabled := True;
237end;
238
239//----------------------------------------------------------------------------
240
241procedure TExceptionDialog.BeforeCreateDetails;
242begin
243  SaveBtn.Enabled := False;
244end;
245
246//----------------------------------------------------------------------------
247
248function TExceptionDialog.ReportMaxColumns: Integer;
249begin
250  Result := 78;
251end;
252
253
254
255//----------------------------------------------------------------------------
256
257procedure TExceptionDialog.SaveBtnClick(Sender: TObject);
258begin
259  with TSaveDialog.Create(Self) do
260  try
261    DefaultExt := '.log';
262    FileName := 'filename.log';
263    Filter := 'Log Files (*.log)|*.log|All files (*.*)|*.*';
264    Title := 'Save log as...';
265    Options := [ofHideReadOnly,ofPathMustExist,ofNoReadOnlyReturn,ofEnableSizing,ofDontAddToRecent];
266    if Execute then
267      SaveToLogFile(FileName);
268  finally
269    Free;    
270  end;
271end;
272
273//----------------------------------------------------------------------------
274
275procedure TExceptionDialog.CopyReportToClipboard;
276begin
277  ClipBoard.AsText := ReportAsText;
278end;
279
280//----------------------------------------------------------------------------
281
282procedure TExceptionDialog.CreateDetails;
283begin
284  Screen.Cursor := crHourGlass;
285  DetailsMemo.Lines.BeginUpdate;
286  try
287    CreateReport;
288    DetailsMemo.SelStart := 0;
289    SendMessage(DetailsMemo.Handle, EM_SCROLLCARET, 0, 0);
290    AfterCreateDetails;
291  finally
292    DetailsMemo.Lines.EndUpdate;
293    OkBtn.Enabled := True;
294    DetailsBtn.Enabled := True;
295    OkBtn.SetFocus;
296    Screen.Cursor := crDefault;
297  end;
298end;
299
300//----------------------------------------------------------------------------
301
302procedure TExceptionDialog.CreateReport;
303var
304  SL: TStringList;
305  I: Integer;
306  ModuleName: TFileName;
307  NtHeaders32: PImageNtHeaders32;
308  NtHeaders64: PImageNtHeaders64;
309  ModuleBase: TJclAddr;
310  ImageBaseStr: string;
311  C: TWinControl;
312  CpuInfo: TCpuInfo;
313  ProcessorDetails: string;
314  StackList: TJclStackInfoList;
315  ThreadList: TJclDebugThreadList;
316  AThreadID: DWORD;
317  PETarget: TJclPeTarget;
318  UnitVersioning: TUnitVersioning;
319  UnitVersioningModule: TUnitVersioningModule;
320  UnitVersion: TUnitVersion;
321  ModuleIndex, UnitIndex: Integer;
322begin
323  DetailsMemo.Lines.Add(Format(LoadResString(PResStringRec(@RsMainThreadID)), [MainThreadID]));
324  DetailsMemo.Lines.Add(Format(LoadResString(PResStringRec(@RsExceptionThreadID)), [MainThreadID]));
325  NextDetailBlock;
326
327  SL := TStringList.Create;
328  try
329    // Except stack list
330    StackList := JclGetExceptStackList(FThreadID);
331    if Assigned(StackList) then
332    begin
333      DetailsMemo.Lines.Add(RsExceptionStack);
334      DetailsMemo.Lines.Add(Format(LoadResString(PResStringRec(@RsStackList)), [DateTimeToStr(StackList.TimeStamp)]));
335      StackList.AddToStrings(DetailsMemo.Lines, True, True, True, True);
336      NextDetailBlock;
337    end;
338
339    // Main thread
340    StackList := JclCreateThreadStackTraceFromID(True, MainThreadID);
341    if Assigned(StackList) then
342    begin
343      DetailsMemo.Lines.Add(LoadResString(PResStringRec(@RsMainThreadCallStack)));
344      DetailsMemo.Lines.Add(Format(LoadResString(PResStringRec(@RsStackList)), [DateTimeToStr(StackList.TimeStamp)]));
345      StackList.AddToStrings(DetailsMemo.Lines, True, True, True, True);
346      NextDetailBlock;
347    end;
348
349    // All threads
350    ThreadList := JclDebugThreadList;
351    ThreadList.Lock.Enter; // avoid modifications
352    try
353      for I := 0 to ThreadList.ThreadIDCount - 1 do
354      begin
355        AThreadID := ThreadList.ThreadIDs[I];
356        if (AThreadID <> FThreadID) then
357        begin
358          StackList := JclCreateThreadStackTrace(True, ThreadList.ThreadHandles[I]);
359          if Assigned(StackList) then
360          begin
361            DetailsMemo.Lines.Add(Format(RsThreadCallStack, [AThreadID, ThreadList.ThreadInfos[AThreadID], ThreadList.ThreadNames[AThreadID]]));
362            DetailsMemo.Lines.Add(Format(LoadResString(PResStringRec(@RsStackList)), [DateTimeToStr(StackList.TimeStamp)]));
363            StackList.AddToStrings(DetailsMemo.Lines, True, True, True, True);
364            NextDetailBlock;
365          end;
366        end;
367      end;
368    finally
369      ThreadList.Lock.Leave;
370    end;
371
372    // System and OS information
373    DetailsMemo.Lines.Add(Format(RsOSVersion, [GetWindowsVersionString, NtProductTypeString,
374      Win32MajorVersion, Win32MinorVersion, Win32BuildNumber, Win32CSDVersion]));
375    GetCpuInfo(CpuInfo);
376    ProcessorDetails := Format(RsProcessor, [CpuInfo.Manufacturer, CpuInfo.CpuName,
377      RoundFrequency(CpuInfo.FrequencyInfo.NormFreq)]);
378    if not CpuInfo.IsFDIVOK then
379      ProcessorDetails := ProcessorDetails + ' [FDIV Bug]';
380    if CpuInfo.ExMMX then
381      ProcessorDetails := ProcessorDetails + ' MMXex';
382    if CpuInfo.MMX then
383      ProcessorDetails := ProcessorDetails + ' MMX';
384    if sse in CpuInfo.SSE then
385      ProcessorDetails := ProcessorDetails + ' SSE';
386    if sse2 in CpuInfo.SSE then
387      ProcessorDetails := ProcessorDetails + ' SSE2';
388    if sse3 in CpuInfo.SSE then
389      ProcessorDetails := ProcessorDetails + ' SSE3';
390    if ssse3 in CpuInfo.SSE then
391      ProcessorDetails := ProcessorDetails + ' SSSE3';
392    if sse41 in CpuInfo.SSE then
393      ProcessorDetails := ProcessorDetails + ' SSE41';
394    if sse42 in CpuInfo.SSE then
395      ProcessorDetails := ProcessorDetails + ' SSE42';
396    if sse4A in CpuInfo.SSE then
397      ProcessorDetails := ProcessorDetails + ' SSE4A';
398    if sse5 in CpuInfo.SSE then
399      ProcessorDetails := ProcessorDetails + ' SSE5';
400    if CpuInfo.Ex3DNow then
401      ProcessorDetails := ProcessorDetails + ' 3DNow!ex';
402    if CpuInfo._3DNow then
403      ProcessorDetails := ProcessorDetails + ' 3DNow!';
404    if CpuInfo.Is64Bits then
405      ProcessorDetails := ProcessorDetails + ' 64 bits';
406    if CpuInfo.DEPCapable then
407      ProcessorDetails := ProcessorDetails + ' DEP';
408    DetailsMemo.Lines.Add(ProcessorDetails);
409    DetailsMemo.Lines.Add(Format(RsMemory, [GetTotalPhysicalMemory div 1024 div 1024,
410      GetFreePhysicalMemory div 1024 div 1024]));
411    DetailsMemo.Lines.Add(Format(RsScreenRes, [Screen.Width, Screen.Height, GetBPP]));
412    NextDetailBlock;
413
414    // Modules list
415    if LoadedModulesList(SL, GetCurrentProcessId) then
416    begin
417      UnitVersioning := GetUnitVersioning;
418      UnitVersioning.RegisterProvider(TJclDefaultUnitVersioningProvider);
419      DetailsMemo.Lines.Add(RsModulesList);
420      SL.CustomSort(SortModulesListByAddressCompare);
421      for I := 0 to SL.Count - 1 do
422      begin
423        ModuleName := SL[I];
424        ModuleBase := TJclAddr(SL.Objects[I]);
425        DetailsMemo.Lines.Add(Format('[' + HexDigitFmt + '] %s', [ModuleBase, ModuleName]));
426        PETarget := PeMapImgTarget(Pointer(ModuleBase));
427        NtHeaders32 := nil;
428        NtHeaders64 := nil;
429        if PETarget = taWin32 then
430          NtHeaders32 := PeMapImgNtHeaders32(Pointer(ModuleBase))
431        else
432        if PETarget = taWin64 then
433          NtHeaders64 := PeMapImgNtHeaders64(Pointer(ModuleBase));
434        if (NtHeaders32 <> nil) and (NtHeaders32^.OptionalHeader.ImageBase <> ModuleBase) then
435          ImageBaseStr := Format('<' + HexDigitFmt32 + '> ', [NtHeaders32^.OptionalHeader.ImageBase])
436        else
437        if (NtHeaders64 <> nil) and (NtHeaders64^.OptionalHeader.ImageBase <> ModuleBase) then
438          ImageBaseStr := Format('<' + HexDigitFmt64 + '> ', [NtHeaders64^.OptionalHeader.ImageBase])
439        else
440          ImageBaseStr := StrRepeat(' ', 11);
441        if VersionResourceAvailable(ModuleName) then
442          with TJclFileVersionInfo.Create(ModuleName) do
443          try
444            DetailsMemo.Lines.Add(ImageBaseStr + BinFileVersion + ' - ' + FileVersion);
445            if FileDescription <> '' then
446              DetailsMemo.Lines.Add(StrRepeat(' ', 11) + FileDescription);
447          finally
448            Free;
449          end
450        else
451          DetailsMemo.Lines.Add(ImageBaseStr + RsMissingVersionInfo);
452        for ModuleIndex := 0 to UnitVersioning.ModuleCount - 1 do
453        begin
454          UnitVersioningModule := UnitVersioning.Modules[ModuleIndex];
455          if UnitVersioningModule.Instance = ModuleBase then
456          begin
457            if UnitVersioningModule.Count > 0 then
458              DetailsMemo.Lines.Add(StrRepeat(' ', 11) + LoadResString(PResStringRec(@RsUnitVersioningIntro)));
459            for UnitIndex := 0 to UnitVersioningModule.Count - 1 do
460            begin
461              UnitVersion := UnitVersioningModule.Items[UnitIndex];
462              DetailsMemo.Lines.Add(Format('%s%s %s %s %s', [StrRepeat(' ', 13), UnitVersion.LogPath, UnitVersion.RCSfile, UnitVersion.Revision, UnitVersion.Date]));
463            end;
464          end;
465        end;
466      end;
467      NextDetailBlock;
468    end;
469
470    // Active controls
471    if (FLastActiveControl <> nil) then
472    begin
473      DetailsMemo.Lines.Add(RsActiveControl);
474      C := FLastActiveControl;
475      while C <> nil do
476      begin
477        DetailsMemo.Lines.Add(Format('%s "%s"', [C.ClassName, C.Name]));
478        C := C.Parent;
479      end;
480      NextDetailBlock;
481    end;
482  finally
483    SL.Free;
484  end;
485end;
486
487//--------------------------------------------------------------------------------------------------
488
489procedure TExceptionDialog.DetailsBtnClick(Sender: TObject);
490begin
491  DetailsVisible := not DetailsVisible;
492end;
493
494//--------------------------------------------------------------------------------------------------
495
496class procedure TExceptionDialog.ExceptionHandler(Sender: TObject; E: Exception);
497begin
498  if Assigned(E) then
499    if ExceptionShowing then
500      Application.ShowException(E)
501    else
502    begin
503      ExceptionShowing := True;
504      try
505        if IsIgnoredException(E.ClassType) then
506          Application.ShowException(E)
507        else
508          ShowException(E, nil);
509      finally
510        ExceptionShowing := False;
511      end;
512    end;
513end;
514
515//--------------------------------------------------------------------------------------------------
516
517class procedure TExceptionDialog.ExceptionThreadHandler(Thread: TJclDebugThread);
518var
519  E: Exception;
520begin
521  E := Exception(Thread.SyncException);
522  if Assigned(E) then
523    if ExceptionShowing then
524      Application.ShowException(E)
525    else
526    begin
527      ExceptionShowing := True;
528      try
529        if IsIgnoredException(E.ClassType) then
530          Application.ShowException(E)
531        else
532          ShowException(E, Thread);
533      finally
534        ExceptionShowing := False;
535      end;
536    end;
537end;
538
539//--------------------------------------------------------------------------------------------------
540
541procedure TExceptionDialog.FormCreate(Sender: TObject);
542begin
543  FFullHeight := ClientHeight;
544  DetailsVisible := False;
545  Caption := Format(RsAppError, [Application.Title]);
546end;
547
548//--------------------------------------------------------------------------------------------------
549
550procedure TExceptionDialog.FormDestroy(Sender: TObject);
551begin
552
553end;
554
555//--------------------------------------------------------------------------------------------------
556
557procedure TExceptionDialog.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
558begin
559  if (Key = Ord('C')) and (ssCtrl in Shift) then
560  begin
561    CopyReportToClipboard;
562    MessageBeep(MB_OK);
563  end;
564end;
565
566//--------------------------------------------------------------------------------------------------
567
568procedure TExceptionDialog.FormPaint(Sender: TObject);
569begin
570  DrawIcon(Canvas.Handle, TextMemo.Left - GetSystemMetrics(SM_CXICON) - 15,
571    TextMemo.Top, LoadIcon(0, IDI_ERROR));
572end;
573
574//--------------------------------------------------------------------------------------------------
575
576procedure TExceptionDialog.FormResize(Sender: TObject);
577begin
578  UpdateTextMemoScrollbars;
579end;
580
581//--------------------------------------------------------------------------------------------------
582
583procedure TExceptionDialog.FormShow(Sender: TObject);
584begin
585  BeforeCreateDetails;
586  MessageBeep(MB_ICONERROR);
587  if (GetCurrentThreadId = MainThreadID) and (GetWindowThreadProcessId(Handle, nil) = MainThreadID) then
588    PostMessage(Handle, UM_CREATEDETAILS, 0, 0)
589  else
590    CreateReport;
591end;
592
593//--------------------------------------------------------------------------------------------------
594
595function TExceptionDialog.GetReportAsText: string;
596begin
597  Result := StrEnsureSuffix(NativeCrLf, TextMemo.Text) + NativeCrLf + DetailsMemo.Text;
598end;
599
600//--------------------------------------------------------------------------------------------------
601
602procedure TExceptionDialog.NextDetailBlock;
603begin
604  DetailsMemo.Lines.Add(StrRepeat(ReportNewBlockDelimiterChar, ReportMaxColumns));
605end;
606
607//--------------------------------------------------------------------------------------------------
608
609function TExceptionDialog.ReportNewBlockDelimiterChar: Char;
610begin
611  Result := '-';
612end;
613
614//--------------------------------------------------------------------------------------------------
615
616procedure TExceptionDialog.SaveToLogFile(const FileName: TFileName);
617var
618  SimpleLog: TJclSimpleLog;
619begin
620  SimpleLog := TJclSimpleLog.Create(FileName);
621  try
622    SimpleLog.WriteStamp(ReportMaxColumns);
623    SimpleLog.Write(ReportAsText);
624    SimpleLog.CloseLog;
625  finally
626    SimpleLog.Free;
627  end;
628end;
629//--------------------------------------------------------------------------------------------------
630
631procedure TExceptionDialog.SetDetailsVisible(const Value: Boolean);
632const
633  DirectionChars: array [0..1] of Char = ( '<', '>' );
634var
635  DetailsCaption: string;
636begin
637  FDetailsVisible := Value;
638  DetailsCaption := Trim(StrRemoveChars(DetailsBtn.Caption, DirectionChars));
639  if Value then
640  begin
641    Constraints.MinHeight := FNonDetailsHeight + 100;
642    Constraints.MaxHeight := Screen.Height;
643    DetailsCaption := '<< ' + DetailsCaption;
644    ClientHeight := FFullHeight;
645    DetailsMemo.Height := FFullHeight - DetailsMemo.Top - 3;
646  end
647  else
648  begin
649    FFullHeight := ClientHeight;
650    DetailsCaption := DetailsCaption + ' >>';
651    if FNonDetailsHeight = 0 then
652    begin
653      ClientHeight := BevelDetails.Top;
654      FNonDetailsHeight := Height;
655    end
656    else
657      Height := FNonDetailsHeight;
658    Constraints.MinHeight := FNonDetailsHeight;
659    Constraints.MaxHeight := FNonDetailsHeight
660  end;
661  DetailsBtn.Caption := DetailsCaption;
662  DetailsMemo.Enabled := Value;
663end;
664
665//--------------------------------------------------------------------------------------------------
666
667class procedure TExceptionDialog.ShowException(E: TObject; Thread: TJclDebugThread);
668begin
669  if ExceptionDialog = nil then
670    ExceptionDialog := ExceptionDialogClass.Create(Application);
671  try
672    with ExceptionDialog do
673    begin
674      if Assigned(Thread) then
675        FThreadID := Thread.ThreadID
676      else
677        FThreadID := MainThreadID;
678      FLastActiveControl := Screen.ActiveControl;
679      if E is Exception then
680        TextMemo.Text := RsErrorMessage + AdjustLineBreaks(StrEnsureSuffix('.', Exception(E).Message))
681      else
682        TextMemo.Text := RsErrorMessage + AdjustLineBreaks(StrEnsureSuffix('.', E.ClassName));
683      UpdateTextMemoScrollbars;
684      NextDetailBlock;
685      //Arioch: some header for possible saving to txt-file/e-mail/clipboard/NTEvent...
686      DetailsMemo.Lines.Add(Format(RsDetailsIntro, [DateTimeToStr(Now), Application.Title, Application.ExeName]));
687      NextDetailBlock;
688      DetailsMemo.Lines.Add(Format(RsExceptionClass, [E.ClassName]));
689      if E is Exception then
690        DetailsMemo.Lines.Add(Format(RsExceptionMessage, [StrEnsureSuffix('.', Exception(E).Message)]));
691      if Thread = nil then
692        DetailsMemo.Lines.Add(Format(RsExceptionAddr, [ExceptAddr]))
693      else
694        DetailsMemo.Lines.Add(Format(RsThread, [Thread.ThreadInfo]));
695      NextDetailBlock;
696      ShowModal;
697    end;
698  finally
699    FreeAndNil(ExceptionDialog);
700  end;
701end;
702
703//--------------------------------------------------------------------------------------------------
704
705procedure TExceptionDialog.UMCreateDetails(var Message: TMessage);
706begin
707  Update;
708  CreateDetails;
709end;
710
711//--------------------------------------------------------------------------------------------------
712
713procedure TExceptionDialog.UpdateTextMemoScrollbars;
714begin
715  Canvas.Font := TextMemo.Font;
716  if TextMemo.Lines.Count * Canvas.TextHeight('Wg') > TextMemo.ClientHeight then
717    TextMemo.ScrollBars := ssVertical
718  else
719    TextMemo.ScrollBars := ssNone;   
720end;
721
722//==================================================================================================
723// Exception handler initialization code
724//==================================================================================================
725
726var
727  AppEvents: TApplicationEvents = nil;
728
729procedure InitializeHandler;
730begin
731  if AppEvents = nil then
732  begin
733    AppEvents := TApplicationEvents.Create(nil);
734    AppEvents.OnException := TExceptionDialog.ExceptionHandler;
735    JclStackTrackingOptions := JclStackTrackingOptions + [stRawMode];
736    JclStackTrackingOptions := JclStackTrackingOptions + [stStaticModuleList];
737    JclStackTrackingOptions := JclStackTrackingOptions + [stDelayedTrace];
738    JclDebugThreadList.OnSyncException := TExceptionDialog.ExceptionThreadHandler;
739    JclHookThreads;
740    JclStartExceptionTracking;
741    if HookTApplicationHandleException then
742      JclTrackExceptionsFromLibraries;
743  end;
744end;
745
746//--------------------------------------------------------------------------------------------------
747
748procedure UnInitializeHandler;
749begin
750  if AppEvents <> nil then
751  begin
752    FreeAndNil(AppEvents);
753    JclDebugThreadList.OnSyncException := nil;
754    JclUnhookExceptions;
755    JclStopExceptionTracking;
756    JclUnhookThreads;
757  end;
758end;
759
760//--------------------------------------------------------------------------------------------------
761
762initialization
763  InitializeHandler;
764
765finalization
766  UnInitializeHandler;
767
768end.