/jcl/experts/repository/ExceptionDialog/StandardDialogs/ExceptDlg.pas
Pascal | 768 lines | 601 code | 89 blank | 78 comment | 62 complexity | cb57ca3f7315233da098d42e19af3499 MD5 | raw file
Possible License(s): BSD-3-Clause
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.