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

https://github.com/the-Arioch/jcl · Pascal · 768 lines · 601 code · 89 blank · 78 comment · 62 complexity · cb57ca3f7315233da098d42e19af3499 MD5 · raw file

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