├── demo ├── SimpleTest.res ├── Test D10.1 32bit.txt ├── Test D10.1 64bit.txt ├── Test D2009 32bit.txt ├── readme.txt ├── CompilerOptions.inc ├── SimpleTest.dproj └── SimpleTest.dpr ├── License ├── source ├── LibOptions.inc ├── Windows │ ├── WinSlimLock.pas │ └── DbgHelp.pas ├── AdditionalSymbols.inc └── StackTrace.pas └── README.md /demo/SimpleTest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-StackTrace/HEAD/demo/SimpleTest.res -------------------------------------------------------------------------------- /demo/Test D10.1 32bit.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-StackTrace/HEAD/demo/Test D10.1 32bit.txt -------------------------------------------------------------------------------- /demo/Test D10.1 64bit.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-StackTrace/HEAD/demo/Test D10.1 64bit.txt -------------------------------------------------------------------------------- /demo/Test D2009 32bit.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thatlr/Delphi-StackTrace/HEAD/demo/Test D2009 32bit.txt -------------------------------------------------------------------------------- /demo/readme.txt: -------------------------------------------------------------------------------- 1 | - This is a Delphi 2009 project. 2 | - You need to adjust the unit search path for your directory structure. 3 | - The output files are produced with the "Use debug .dcus" compiler setting. 4 | -------------------------------------------------------------------------------- /License: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /demo/CompilerOptions.inc: -------------------------------------------------------------------------------- 1 | // 2 | // Include file for stable compiler options 3 | // 4 | // Supposed Build Configurations in each project with the respective conditional defines: 5 | // - Debug: DEBUG;MEMTEST_ACTIVE 6 | // - LibDebug: LIB_DEBUG 7 | // - Release: RELEASE;NOASSERT 8 | // 9 | 10 | {$ifdef DEBUG} 11 | {$OverflowChecks on} 12 | {$RangeChecks on} 13 | {$else} 14 | {$OverflowChecks off} 15 | {$RangeChecks off} 16 | {$endif} 17 | 18 | {$ifdef NOASSERT} 19 | {$Assertions off} 20 | {$else} 21 | {$Assertions on} 22 | {$endif} 23 | 24 | {$Align on} 25 | {$BoolEval off} 26 | {$DebugInfo on} 27 | {$ExtendedSyntax on} 28 | {$Hints on} 29 | {$IoChecks on} 30 | {$LocalSymbols on} 31 | {$LongStrings on} 32 | {$MinEnumSize 1} 33 | {$OpenStrings on} 34 | {$Optimization on} 35 | {$ReferenceInfo on} 36 | {$SafeDivide off} 37 | {$StackFrames on} 38 | {$TypedAddress on} 39 | {$TypeInfo off} 40 | {$VarStringChecks on} 41 | {$Warnings on} 42 | {$WriteableConst off} 43 | 44 | {$warn SYMBOL_PLATFORM off} 45 | {$warn UNIT_PLATFORM off} 46 | 47 | {$include AdditionalSymbols.inc} 48 | 49 | {$ifndef UNICODE} {$message error 'Unicode required'} {$endif} 50 | {$ifndef D2009} {$message error 'D2009 required'} {$endif} 51 | 52 | {$Inline on} 53 | {$MethodInfo off} 54 | {$PointerMath on} 55 | {$ScopedEnums off} 56 | {$StringChecks off} 57 | 58 | {$ifdef D2011} 59 | {$StrongLinkTypes off} // Because this directive defeats the smart linker to a large degree, it can cause inflation of the executable size. 60 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} // Extended RTTI => off => smaller EXE 61 | {$WeakLinkRTTI ON} // enables more Smart Linking => smaller EXE 62 | {$endif} 63 | -------------------------------------------------------------------------------- /source/LibOptions.inc: -------------------------------------------------------------------------------- 1 | // 2 | // Include file for stable compiler options 3 | // 4 | // Supposed Build Configurations in each project with the respective conditional defines: 5 | // - Debug: DEBUG;MEMTEST_ACTIVE 6 | // - LibDebug: LIB_DEBUG 7 | // - Release: RELEASE;NOASSERT 8 | // 9 | 10 | {$ifdef LIB_DEBUG} 11 | {$DebugInfo on} 12 | {$OverflowChecks on} 13 | {$RangeChecks on} 14 | {$else} 15 | {$DebugInfo off} 16 | {$OverflowChecks off} 17 | {$RangeChecks off} 18 | {$endif} 19 | 20 | {$ifdef NOASSERT} 21 | {$Assertions off} 22 | {$else} 23 | {$Assertions on} 24 | {$endif} 25 | 26 | {$Align on} 27 | {$BoolEval off} 28 | {$ExtendedSyntax on} 29 | {$Hints on} 30 | {$IoChecks on} 31 | {$LocalSymbols on} 32 | {$LongStrings on} 33 | {$MinEnumSize 1} 34 | {$OpenStrings on} 35 | {$Optimization on} 36 | {$ReferenceInfo on} 37 | {$SafeDivide off} 38 | {$StackFrames on} 39 | {$TypedAddress on} 40 | {$TypeInfo off} 41 | {$VarStringChecks on} 42 | {$Warnings on} 43 | {$WriteableConst off} 44 | 45 | {$warn SYMBOL_PLATFORM off} 46 | {$warn UNIT_PLATFORM off} 47 | 48 | {$include AdditionalSymbols.inc} 49 | 50 | {$ifndef UNICODE} {$message error 'Unicode required'} {$endif} 51 | {$ifndef D2009} {$message error 'D2009 required'} {$endif} 52 | 53 | {$Inline on} 54 | {$MethodInfo off} 55 | {$PointerMath on} 56 | {$ScopedEnums off} 57 | {$StringChecks off} 58 | 59 | {$ifdef D2011} 60 | {$StrongLinkTypes off} // Because this directive defeats the smart linker to a large degree, it can cause inflation of the executable size. 61 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} // Extended RTTI => off => smaller EXE 62 | {$WeakLinkRTTI ON} // enables more Smart Linking => smaller EXE 63 | {$endif} 64 | -------------------------------------------------------------------------------- /source/Windows/WinSlimLock.pas: -------------------------------------------------------------------------------- 1 | unit WinSlimLock; 2 | 3 | 4 | { 5 | Unit only contains definitions that could also be used by MemTest.pas. 6 | - TSlimRWLock: Structure that wraps Windows' built-in Slim Reader/Writer Lock. 7 | } 8 | 9 | 10 | {$include LibOptions.inc} 11 | 12 | {$ifdef MEMTEST_DEBUG} 13 | {$DebugInfo on} 14 | {$else} 15 | {$DebugInfo off} 16 | {$endif} 17 | 18 | interface 19 | 20 | uses Windows; 21 | 22 | type 23 | TConditionVariable = Windows.CONDITION_VARIABLE; 24 | 25 | // Wraps Windows' built-in Slim Reader/Writer Lock (needs Windows Vista): 26 | // An initialization is not necessary if the corresponding variable is zero-initialized. 27 | TSlimRWLock = record 28 | strict private 29 | 30 | {WinNt.h + WinBase.h} 31 | type 32 | SRWLOCK = type pointer; 33 | const 34 | SRWLOCK_INIT = SRWLOCK(nil); 35 | 36 | class procedure _AcquireSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; static; 37 | class procedure _AcquireSRWLockShared(var SRWLock: SRWLOCK); stdcall; static; 38 | class procedure _ReleaseSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; static; 39 | class procedure _ReleaseSRWLockShared(var SRWLock: SRWLOCK); stdcall; static; 40 | class function _SleepConditionVariableSRW(var ConditionVariable: TConditionVariable; var SRWLock: SRWLOCK; dwMilliseconds: DWORD; Flags: ULONG): BOOL; stdcall; static; 41 | class function _TryAcquireSRWLockExclusive(var SRWLock: SRWLOCK): BOOL; stdcall; static; 42 | class function _TryAcquireSRWLockShared(var SRWLock: SRWLOCK): BOOL; stdcall; static; 43 | 44 | var 45 | FLock: SRWLOCK; 46 | public 47 | procedure Init; inline; // not needed if zero-initialized 48 | 49 | procedure AcquireExclusive; inline; 50 | function TryAcquireExclusive: boolean; inline; 51 | procedure ReleaseExclusive; inline; 52 | 53 | procedure AcquireShared; inline; 54 | function TryAcquireShared: boolean; inline; 55 | procedure ReleaseShared; inline; 56 | 57 | function SleepConditionVariable(var ConditionVariable: TConditionVariable; Milliseconds: DWORD; Flags: ULONG): boolean; inline; 58 | 59 | class procedure WakeAllConditionVariable(var ConditionVariable: TConditionVariable); stdcall; static; 60 | class procedure WakeConditionVariable(var ConditionVariable: TConditionVariable); stdcall; static; 61 | end; 62 | 63 | 64 | {############################################################################} 65 | implementation 66 | {############################################################################} 67 | 68 | { TSlimRWLock } 69 | 70 | class procedure TSlimRWLock._AcquireSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'AcquireSRWLockExclusive'; 71 | class procedure TSlimRWLock._AcquireSRWLockShared(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'AcquireSRWLockShared'; 72 | class procedure TSlimRWLock._ReleaseSRWLockExclusive(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'ReleaseSRWLockExclusive'; 73 | class procedure TSlimRWLock._ReleaseSRWLockShared(var SRWLock: SRWLOCK); stdcall; external Windows.kernel32 name 'ReleaseSRWLockShared'; 74 | class function TSlimRWLock._SleepConditionVariableSRW(var ConditionVariable: TConditionVariable; var SRWLock: SRWLOCK; dwMilliseconds: DWORD; Flags: ULONG): BOOL; stdcall; external Windows.kernel32 name 'SleepConditionVariableSRW'; 75 | class function TSlimRWLock._TryAcquireSRWLockExclusive(var SRWLock: SRWLOCK): BOOL; stdcall; external Windows.kernel32 name 'TryAcquireSRWLockExclusive'; 76 | class function TSlimRWLock._TryAcquireSRWLockShared(var SRWLock: SRWLOCK): BOOL; stdcall; external Windows.kernel32 name 'TryAcquireSRWLockShared'; 77 | 78 | // D2009: this functions are also in Windows.pas: 79 | class procedure TSlimRWLock.WakeAllConditionVariable(var ConditionVariable: TConditionVariable); stdcall; external Windows.kernel32 name 'WakeAllConditionVariable'; 80 | class procedure TSlimRWLock.WakeConditionVariable(var ConditionVariable: TConditionVariable); stdcall; external Windows.kernel32 name 'WakeConditionVariable'; 81 | 82 | 83 | //============================================================================= 84 | //============================================================================= 85 | procedure TSlimRWLock.Init; 86 | begin 87 | FLock := SRWLOCK_INIT; 88 | end; 89 | 90 | //============================================================================= 91 | // Acquires the lock in exclusive mode: 92 | //============================================================================= 93 | procedure TSlimRWLock.AcquireExclusive; 94 | begin 95 | _AcquireSRWLockExclusive(FLock); 96 | end; 97 | 98 | //============================================================================= 99 | // Acquires the lock in shared mode: 100 | //============================================================================= 101 | procedure TSlimRWLock.AcquireShared; 102 | begin 103 | _AcquireSRWLockShared(FLock); 104 | end; 105 | 106 | //============================================================================= 107 | // Attempts to acquire the lock in exclusive mode. If the lock could be acquired, 108 | // it returns true. 109 | //============================================================================= 110 | function TSlimRWLock.TryAcquireExclusive: boolean; 111 | begin 112 | Result := _TryAcquireSRWLockExclusive(FLock); 113 | end; 114 | 115 | //============================================================================= 116 | // Attempts to acquire the lock in shared mode. If the lock could be acquired, 117 | // it returns true. 118 | //============================================================================= 119 | function TSlimRWLock.TryAcquireShared: boolean; 120 | begin 121 | Result := _TryAcquireSRWLockShared(FLock); 122 | end; 123 | 124 | //============================================================================= 125 | // Releases an lock that was opened in exclusive mode. 126 | //============================================================================= 127 | procedure TSlimRWLock.ReleaseExclusive; 128 | begin 129 | _ReleaseSRWLockExclusive(FLock); 130 | end; 131 | 132 | //============================================================================= 133 | // Releases an SRW lock that was opened in shared mode. 134 | //============================================================================= 135 | procedure TSlimRWLock.ReleaseShared; 136 | begin 137 | _ReleaseSRWLockShared(FLock); 138 | end; 139 | 140 | //============================================================================= 141 | // Sleeps on the condition variable and releases the specified lock as an atomic operation. 142 | //============================================================================= 143 | function TSlimRWLock.SleepConditionVariable(var ConditionVariable: TConditionVariable; Milliseconds: DWORD; Flags: ULONG): boolean; 144 | begin 145 | Result := _SleepConditionVariableSRW(ConditionVariable, FLock, Milliseconds, Flags); 146 | end; 147 | 148 | end. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Delphi-StackTrace 2 | Capturing call stacks in Delphi 3 | 4 | This provides support for capturing and displaying 5 | stack traces at exceptions or at any custom points 6 | in Delphi code. 7 | 8 | Because it is based on Windows StackWalk functionality, 9 | it works for any module (exe and dll), as long as a matching PDB 10 | file is providing the mapping between code addresses 11 | and funtion names plus source code location. 12 | 13 | Therefore, you can use Anders Melander's map2pdb from https://github.com/andersmelander/map2pdb 14 | and enjoy nice complete and correct stack traces. 15 | 16 | Tested with: 17 | - Delphi 2009 18 | - Delphi XE 19 | - Delphi 10.1.2 Berlin: 32bit and 64bit 20 | - Delphi 12.1 Athens: 32bit and 64bit 21 | 22 | To use it: 23 | - Include the Stacktrace unit, by manually adding it to the top of the uses list in the dpr file. 24 | - Compile all source files with {$StackFrames on}. It is not strictly required but gives better stacktraces. 25 | - In the Delphi Project options, under "Linking", set "Map File" to "Detailed". 26 | - Under "Build Events", "Post-Build", add this command: 27 | map2pdb.exe "-include:0001;0002" "$(OUTPUTDIR)\$(OUTPUTNAME).map" 28 | 29 | You may want to use map2pdb with additional filters, as the PDBs gets very large, especially on 64bit. 30 | - Ship the PDB files together with the EXEs and DLLs, by putting them in the same directory. 31 | 32 | 33 | Usage notes: 34 | 35 | - The EAbort exception does not generate a stack trace because I think it is intended to implement control flow 36 | (i.e. abort processing without a special message). The VCL swallows EAbort exceptions in several places: 37 | TApplication.HandleException(), TCustomApplicationEvents.DoException(), TMultiCaster.DoException(). 38 | 39 | - The CPU stack does not record *where the call came from* but stores *where to continue after the call*. This leads to an effect 40 | that can also be experienced in the Delphi debugger: Sometimes, the source line in the stack trace is the line with the next 41 | statement that follows the actual call. 42 | 43 | - The Delphi runtime units (RTL, VCL, etc) are precompiled with {$StackFrames off} ({$W-}). Sometimes this leads to missing frames in 44 | the stack trace, since the debug engine has to guess how to interpret the stack. Since map2pdb only has the Delphi MAP file as 45 | input, the PDB file will most likely not contain "Frame Pointer Omission (FPO)" records, which would help the debug engine in 46 | these cases (https://learn.microsoft.com/en-us/windows-hardware/drivers/debugger/symbols-and-symbol-files). 47 | 48 | - In SysUtils, there are two singleton exception objects stored in the private global variables "OutOfMemory" and "InvalidPointer". 49 | Those are thrown by the procedure "System.Error" when called with reOutOfMemory or reInvalidPtr, respectively. Unfortunately, this 50 | is done by System.GetMem, System.AllocMem, System.FreeMem and System.ReallocMem to signal errors. 51 | As this singletons are *not thread-safe* in regards of (a) attaching stacktrace info to them, and (b) modifying the message text 52 | (Exception.Message) by application code, this approach should have been discarded with the explicit introduction of multi-threading 53 | in Delphi (TThread class, later: Parallel Programming Library). 54 | 55 | While I understand that out-of-memory is a situation where a pre-allocated exception object is useful (but it has to be thread-specific, 56 | or read-only, otherwise it won't work reliably in multi-threading scenarios), I don't understand why FreeMem() and ReallocMem() don't 57 | just throw an exception when erroneous application behavior is detected (e.g. an attempt to double-free memory). If the heap structure 58 | is already corrupt, throwing an exception doesn't help the application, even if a preallocated object is used. But if the heap structure 59 | is not corrupt, it would be useful to have a stack trace for a FreeMem() error. However, the EHeapException.RaisingException() method 60 | suppresses stacktrace generation for this exception classes. 61 | (Which at least prevents multiple threads from attaching their respective stack trace to it at the same time, thereby producing memory errors. 62 | But the Message property is not readonly, and modifying it on a singleton from multiple threads at the same time will cause memory leaks.) 63 | 64 | Conclusion: A heap manager replacement should signal errors within FreeMem() and ReallocMem() by explicitly throwing a normal exception 65 | not derived from EHeapException. A non-zero value must only be returned by FreeMem() and ReallocMem() when the heap management 66 | structures are corrupted, but should not be returned if a duplicate free attempt or an invalid pointer is detected before the heap was 67 | corrupted. As long as the heap is not full and not corrupted, a normal non-EHeapException will suffice. 68 | 69 | 70 | Please note: 71 | 72 | As the Delphi runtime library handles things not consistently and contains bugs (see some of the comments in the code), 73 | I don't know if this works with other Delphi versions as well. Please use a memory leak detector to verify the behavior. 74 | 75 | Generally, the 64bit compiler and RTL fixes a few things, as exception reraising now always reuses the original exception 76 | object and it also generates source-line infos for the main part of the dpr file (the lines between "begin" and "end."). 77 | 78 | The 32bit compiler and RTL makes it nearly impossible to get the stacktrace from an non-delphi exception that is reraised: 79 | For some reason, the original exception object is released by the RTL and then a new one is created, but we still need the 80 | stackinfo from the original object which is now gone. It is not possible to recreate it. So for now, I just reattach the 81 | very last stackinfo, but depending on other exceptions thrown and catched between the original point and the reraise point, 82 | it may be no longer the correct one. But: When AcquireExceptionObject is used, reraising works also in 32bit for every type 83 | of exception. 84 | 85 | 86 | ## Enable lookup of Windows symbols 87 | 88 | For general info, please look here: 89 | https://learn.microsoft.com/en-us/windows/win32/dxtecharts/debugging-with-symbols 90 | 91 | The standard dbghelp.dll that comes with Windows does not support downloading from symbol servers. To use this, you need 92 | two DLLs from the "Windows Debugging Tools": 93 | https://learn.microsoft.com/en-us/windows-hardware/drivers/debugger/debugger-download-tools 94 | 95 | Both "dbghelp.dll" and "symsrv.dll" from 96 | "C:\Program Files (x86)\Windows Kits\10\Debuggers\x86" (32 bit) 97 | or 98 | "C:\Program Files (x86)\Windows Kits\10\Debuggers\x64" (64 bit) 99 | needs to be copied into the same folder as the Delphi executable. 100 | 101 | To have the Windows symbols be used, the symbol search path needs to be altered, like this: 102 | 103 | TStackTraceHlp.SymSearchPath := 'srv*c:\temp\symbols*https://msdl.microsoft.com/download/symbols'; 104 | 105 | "c:\temp\symbols" inside this example string specifies a folder that is used as a cache for the downloaded PDBs (see 106 | https://learn.microsoft.com/en-us/windows/win32/debug/symbol-paths). 107 | 108 | As the download takes time and needs internet connectivity, and the cache folder needs to be placed somewhere, this is usually not an option 109 | for production environments (at least not on end-user PCs). 110 | 111 | Example stacktrace without Windows symbols (32 bit): 112 | 113 | Callstack from inside EnumWindows: 114 | at SimpleTest.exe: EnumWindowsCallback in SimpleTest.dpr (Line 372) 115 | at user32.dll: SendMessageW + 0x111 116 | at user32.dll: EnumWindows + 0x1A 117 | at SimpleTest.exe: TestCallStackFromWithinWindowsCallback in SimpleTest.dpr (Line 383) 118 | at SimpleTest.exe: Main in SimpleTest.dpr (Line 436) 119 | at SimpleTest.exe: SimpleTest + 0x1D 120 | at KERNEL32.DLL: BaseThreadInitThunk + 0x19 121 | at ntdll.dll: RtlGetAppContainerNamedObjectPath + 0x11E 122 | at ntdll.dll: RtlGetAppContainerNamedObjectPath + 0xEE 123 | 124 | Same with Windows symbols (32 bit): 125 | 126 | Callstack from inside EnumWindows: 127 | at SimpleTest.exe: EnumWindowsCallback in SimpleTest.dpr (Line 372) 128 | at user32.dll: EnumWindowsWorker + 0x88 129 | at user32.dll: EnumWindows + 0x1A 130 | at SimpleTest.exe: TestCallStackFromWithinWindowsCallback in SimpleTest.dpr (Line 383) 131 | at SimpleTest.exe: Main in SimpleTest.dpr (Line 435) 132 | at SimpleTest.exe: SimpleTest + 0x1D 133 | at KERNEL32.DLL: BaseThreadInitThunk + 0x19 134 | at ntdll.dll: __RtlUserThreadStart + 0x2F 135 | at ntdll.dll: _RtlUserThreadStart + 0x1B 136 | -------------------------------------------------------------------------------- /demo/SimpleTest.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {8455A6EB-8EAC-417E-8814-A061C7E385E4} 4 | SimpleTest.dpr 5 | LibDebug 6 | DCC32 7 | 12.0 8 | 9 | 10 | true 11 | 12 | 13 | true 14 | Base 15 | true 16 | 17 | 18 | true 19 | Base 20 | true 21 | 22 | 23 | true 24 | Cfg_2 25 | true 26 | true 27 | 28 | 29 | bin 30 | dcu 31 | ..\..\lib;..\..\lib\Windows;$(DCC_UnitSearchPath) 32 | 3 33 | true 34 | false 35 | bin\SimpleTest.exe 36 | 37 | 38 | RELEASE;NOASSERT;$(DCC_Define) 39 | 0 40 | false 41 | false 42 | false 43 | 44 | 45 | DEBUG;MEMTEST_ACTIVE;$(DCC_Define) 46 | 47 | 48 | LIB_DEBUG;$(DCC_Define) 49 | 50 | 51 | 52 | MainSource 53 | 54 | 55 | Base 56 | 57 | 58 | Cfg_3 59 | Cfg_2 60 | 61 | 62 | Cfg_1 63 | Base 64 | 65 | 66 | Cfg_2 67 | Base 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | Delphi.Personality.12 76 | VCLApplication 77 | 78 | 79 | 80 | SimpleTest.dpr 81 | 82 | 83 | False 84 | True 85 | False 86 | 87 | 88 | True 89 | False 90 | 1 91 | 0 92 | 0 93 | 0 94 | False 95 | False 96 | False 97 | False 98 | False 99 | 1033 100 | 1252 101 | 102 | 103 | 104 | 105 | 1.0.0.0 106 | 107 | 108 | 109 | 110 | 111 | 1.0.0.0 112 | 113 | 114 | 115 | Rave Reports 7.6 BE Package 116 | CodeGear Standardkomponenten 117 | CodeGear ActionBar-Komponenten 118 | TeeChart Standard 8 Components 119 | Indy 10 Core Design Time 120 | Indy 10 Protocols Design Time 121 | Internet Explorer-Komponenten 122 | CodeGear Internet-Komponenten 123 | CodeGear SOAP-Komponenten 124 | CodeGear Ribbon-Steuerelemente 125 | CodeGear Control Panel Applet-Package 126 | Delphi 1.0 Kompatibilitätskomponenten 127 | CodeGear BDE DB-Komponenten 128 | CodeGear Datenbankkomponenten 129 | CodeGear SQL Explorer UI-Package 130 | CodeGear Editor Emacs-Erweiterungen 131 | CodeGear Markup Language-Experten 132 | CodeGear Editor Script-Erweiterungen 133 | CodeGear DataSnap Verbindungskomponenten 134 | CodeGear MyBase Datenzugriffskomponenten 135 | CodeGear ADO DB-Komponenten 136 | CodeGear WebSnap-Komponenten 137 | CodeGear InternetExpress-Komponenten 138 | CodeGear-Treiberkomponenten 139 | CodeGear dbExpress-Komponenten 140 | CodeGear SimpleDataset-Komponente (DBX) 141 | Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automation Server 142 | Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server 143 | 144 | 145 | 146 | 12 147 | 148 | 149 | -------------------------------------------------------------------------------- /source/AdditionalSymbols.inc: -------------------------------------------------------------------------------- 1 | // 2 | // see: http://docwiki.embarcadero.com/RADStudio/en/Compiler_Versions 3 | // 4 | // https://docwiki.embarcadero.com/RADStudio/Alexandria/en/Compiler_Versions 5 | 6 | {$undef Delphi2} 7 | {$undef Delphi3} 8 | {$undef Delphi4} 9 | {$undef Delphi5} 10 | {$undef Delphi6} 11 | {$undef Delphi7} 12 | {$undef Delphi8} 13 | {$undef D2005} 14 | {$undef D2006} 15 | {$undef D2007} 16 | {$undef D2009} 17 | {$undef D2010} 18 | {$undef D2011} 19 | {$undef DelphiXE} 20 | {$undef DelphiXE2} 21 | {$undef DelphiXE3} 22 | {$undef DelphiXE4} 23 | {$undef DelphiXE5} 24 | {$undef DelphiXE6} 25 | {$undef DelphiXE7} 26 | {$undef DelphiXE8} 27 | {$undef Delphi10} 28 | {$undef Delphi101} 29 | {$undef Delphi102} 30 | {$undef Delphi103} 31 | {$undef Delphi104} 32 | {$undef Delphi11} 33 | {$undef Delphi12} 34 | 35 | // D2: VER90 36 | // D3: VER100 37 | // D4: VER120 38 | // D5: VER130 39 | // D6: VER140 40 | // D7: VER150 41 | // D8: VER160 42 | // D2005: VER170 43 | // D2006: VER180 44 | // D2007: VER190 45 | 46 | // D2009: 47 | {$ifdef VER200} 48 | {$define Delphi2} 49 | {$define Delphi3} 50 | {$define Delphi4} 51 | {$define Delphi5} 52 | {$define Delphi6} 53 | {$define Delphi7} 54 | {$define Delphi8} 55 | {$define D2005} 56 | {$define D2006} 57 | {$define D2007} 58 | {$define D2009} 59 | {$endif} 60 | 61 | // D2010: 62 | {$ifdef VER210} 63 | {$define Delphi2} 64 | {$define Delphi3} 65 | {$define Delphi4} 66 | {$define Delphi5} 67 | {$define Delphi6} 68 | {$define Delphi7} 69 | {$define Delphi8} 70 | {$define D2005} 71 | {$define D2006} 72 | {$define D2007} 73 | {$define D2009} 74 | {$define D2010} 75 | {$endif} 76 | 77 | // D2011/XE: 78 | {$ifdef VER220} 79 | {$define Delphi2} 80 | {$define Delphi3} 81 | {$define Delphi4} 82 | {$define Delphi5} 83 | {$define Delphi6} 84 | {$define Delphi7} 85 | {$define Delphi8} 86 | {$define D2005} 87 | {$define D2006} 88 | {$define D2007} 89 | {$define D2009} 90 | {$define D2010} 91 | {$define D2011} 92 | {$define DelphiXE} 93 | {$endif} 94 | 95 | // XE2: 96 | {$ifdef VER230} 97 | {$define Delphi2} 98 | {$define Delphi3} 99 | {$define Delphi4} 100 | {$define Delphi5} 101 | {$define Delphi6} 102 | {$define Delphi7} 103 | {$define Delphi8} 104 | {$define D2005} 105 | {$define D2006} 106 | {$define D2007} 107 | {$define D2009} 108 | {$define D2010} 109 | {$define D2011} 110 | {$define DelphiXE} 111 | {$define DelphiXE2} 112 | {$endif} 113 | 114 | // XE3: 115 | {$ifdef VER240} 116 | {$define Delphi2} 117 | {$define Delphi3} 118 | {$define Delphi4} 119 | {$define Delphi5} 120 | {$define Delphi6} 121 | {$define Delphi7} 122 | {$define Delphi8} 123 | {$define D2005} 124 | {$define D2006} 125 | {$define D2007} 126 | {$define D2009} 127 | {$define D2010} 128 | {$define D2011} 129 | {$define DelphiXE} 130 | {$define DelphiXE2} 131 | {$define DelphiXE3} 132 | {$endif} 133 | 134 | // XE4: 135 | {$ifdef VER250} 136 | {$define Delphi2} 137 | {$define Delphi3} 138 | {$define Delphi4} 139 | {$define Delphi5} 140 | {$define Delphi6} 141 | {$define Delphi7} 142 | {$define Delphi8} 143 | {$define D2005} 144 | {$define D2006} 145 | {$define D2007} 146 | {$define D2009} 147 | {$define D2010} 148 | {$define D2011} 149 | {$define DelphiXE} 150 | {$define DelphiXE2} 151 | {$define DelphiXE3} 152 | {$define DelphiXE4} 153 | {$endif} 154 | 155 | // XE5: 156 | {$ifdef VER260} 157 | {$define Delphi2} 158 | {$define Delphi3} 159 | {$define Delphi4} 160 | {$define Delphi5} 161 | {$define Delphi6} 162 | {$define Delphi7} 163 | {$define Delphi8} 164 | {$define D2005} 165 | {$define D2006} 166 | {$define D2007} 167 | {$define D2009} 168 | {$define D2010} 169 | {$define D2011} 170 | {$define DelphiXE} 171 | {$define DelphiXE2} 172 | {$define DelphiXE3} 173 | {$define DelphiXE4} 174 | {$define DelphiXE5} 175 | {$endif} 176 | 177 | // XE6: 178 | {$ifdef VER270} 179 | {$define Delphi2} 180 | {$define Delphi3} 181 | {$define Delphi4} 182 | {$define Delphi5} 183 | {$define Delphi6} 184 | {$define Delphi7} 185 | {$define Delphi8} 186 | {$define D2005} 187 | {$define D2006} 188 | {$define D2007} 189 | {$define D2009} 190 | {$define D2010} 191 | {$define D2011} 192 | {$define DelphiXE} 193 | {$define DelphiXE2} 194 | {$define DelphiXE3} 195 | {$define DelphiXE4} 196 | {$define DelphiXE5} 197 | {$define DelphiXE6} 198 | {$endif} 199 | 200 | // XE7: 201 | {$ifdef VER280} 202 | {$define Delphi2} 203 | {$define Delphi3} 204 | {$define Delphi4} 205 | {$define Delphi5} 206 | {$define Delphi6} 207 | {$define Delphi7} 208 | {$define Delphi8} 209 | {$define D2005} 210 | {$define D2006} 211 | {$define D2007} 212 | {$define D2009} 213 | {$define D2010} 214 | {$define D2011} 215 | {$define DelphiXE} 216 | {$define DelphiXE2} 217 | {$define DelphiXE3} 218 | {$define DelphiXE4} 219 | {$define DelphiXE5} 220 | {$define DelphiXE6} 221 | {$define DelphiXE7} 222 | {$endif} 223 | 224 | // XE8: 225 | {$ifdef VER290} 226 | {$define Delphi2} 227 | {$define Delphi3} 228 | {$define Delphi4} 229 | {$define Delphi5} 230 | {$define Delphi6} 231 | {$define Delphi7} 232 | {$define Delphi8} 233 | {$define D2005} 234 | {$define D2006} 235 | {$define D2007} 236 | {$define D2009} 237 | {$define D2010} 238 | {$define D2011} 239 | {$define DelphiXE} 240 | {$define DelphiXE2} 241 | {$define DelphiXE3} 242 | {$define DelphiXE4} 243 | {$define DelphiXE5} 244 | {$define DelphiXE6} 245 | {$define DelphiXE7} 246 | {$define DelphiXE8} 247 | {$endif} 248 | 249 | // D10 Seattle: 250 | {$ifdef VER300} 251 | {$define Delphi2} 252 | {$define Delphi3} 253 | {$define Delphi4} 254 | {$define Delphi5} 255 | {$define Delphi6} 256 | {$define Delphi7} 257 | {$define Delphi8} 258 | {$define D2005} 259 | {$define D2006} 260 | {$define D2007} 261 | {$define D2009} 262 | {$define D2010} 263 | {$define D2011} 264 | {$define DelphiXE} 265 | {$define DelphiXE2} 266 | {$define DelphiXE3} 267 | {$define DelphiXE4} 268 | {$define DelphiXE5} 269 | {$define DelphiXE6} 270 | {$define DelphiXE7} 271 | {$define DelphiXE8} 272 | {$define Delphi10} 273 | {$endif} 274 | 275 | // D10.1 Berlin: 276 | {$ifdef VER310} 277 | {$define Delphi2} 278 | {$define Delphi3} 279 | {$define Delphi4} 280 | {$define Delphi5} 281 | {$define Delphi6} 282 | {$define Delphi7} 283 | {$define Delphi8} 284 | {$define D2005} 285 | {$define D2006} 286 | {$define D2007} 287 | {$define D2009} 288 | {$define D2010} 289 | {$define D2011} 290 | {$define DelphiXE} 291 | {$define DelphiXE2} 292 | {$define DelphiXE3} 293 | {$define DelphiXE4} 294 | {$define DelphiXE5} 295 | {$define DelphiXE6} 296 | {$define DelphiXE7} 297 | {$define DelphiXE8} 298 | {$define Delphi10} 299 | {$define Delphi101} 300 | {$endif} 301 | 302 | // D10.2 Tokyo: 303 | {$ifdef VER320} 304 | {$define Delphi2} 305 | {$define Delphi3} 306 | {$define Delphi4} 307 | {$define Delphi5} 308 | {$define Delphi6} 309 | {$define Delphi7} 310 | {$define Delphi8} 311 | {$define D2005} 312 | {$define D2006} 313 | {$define D2007} 314 | {$define D2009} 315 | {$define D2010} 316 | {$define D2011} 317 | {$define DelphiXE} 318 | {$define DelphiXE2} 319 | {$define DelphiXE3} 320 | {$define DelphiXE4} 321 | {$define DelphiXE5} 322 | {$define DelphiXE6} 323 | {$define DelphiXE7} 324 | {$define DelphiXE8} 325 | {$define Delphi10} 326 | {$define Delphi101} 327 | {$define Delphi102} 328 | {$endif} 329 | 330 | // D10.3 Rio: 331 | {$ifdef VER330} 332 | {$define Delphi2} 333 | {$define Delphi3} 334 | {$define Delphi4} 335 | {$define Delphi5} 336 | {$define Delphi6} 337 | {$define Delphi7} 338 | {$define Delphi8} 339 | {$define D2005} 340 | {$define D2006} 341 | {$define D2007} 342 | {$define D2009} 343 | {$define D2010} 344 | {$define D2011} 345 | {$define DelphiXE} 346 | {$define DelphiXE2} 347 | {$define DelphiXE3} 348 | {$define DelphiXE4} 349 | {$define DelphiXE5} 350 | {$define DelphiXE6} 351 | {$define DelphiXE7} 352 | {$define DelphiXE8} 353 | {$define Delphi10} 354 | {$define Delphi101} 355 | {$define Delphi102} 356 | {$define Delphi103} 357 | {$endif} 358 | 359 | // D10.4 Sydney: 360 | {$ifdef VER340} 361 | {$define Delphi2} 362 | {$define Delphi3} 363 | {$define Delphi4} 364 | {$define Delphi5} 365 | {$define Delphi6} 366 | {$define Delphi7} 367 | {$define Delphi8} 368 | {$define D2005} 369 | {$define D2006} 370 | {$define D2007} 371 | {$define D2009} 372 | {$define D2010} 373 | {$define D2011} 374 | {$define DelphiXE} 375 | {$define DelphiXE2} 376 | {$define DelphiXE3} 377 | {$define DelphiXE4} 378 | {$define DelphiXE5} 379 | {$define DelphiXE6} 380 | {$define DelphiXE7} 381 | {$define DelphiXE8} 382 | {$define Delphi10} 383 | {$define Delphi101} 384 | {$define Delphi102} 385 | {$define Delphi103} 386 | {$define Delphi104} 387 | {$endif} 388 | 389 | // D11.0 Alexandria 390 | {$ifdef VER350} 391 | {$define Delphi2} 392 | {$define Delphi3} 393 | {$define Delphi4} 394 | {$define Delphi5} 395 | {$define Delphi6} 396 | {$define Delphi7} 397 | {$define Delphi8} 398 | {$define D2005} 399 | {$define D2006} 400 | {$define D2007} 401 | {$define D2009} 402 | {$define D2010} 403 | {$define D2011} 404 | {$define DelphiXE} 405 | {$define DelphiXE2} 406 | {$define DelphiXE3} 407 | {$define DelphiXE4} 408 | {$define DelphiXE5} 409 | {$define DelphiXE6} 410 | {$define DelphiXE7} 411 | {$define DelphiXE8} 412 | {$define Delphi10} 413 | {$define Delphi101} 414 | {$define Delphi102} 415 | {$define Delphi103} 416 | {$define Delphi104} 417 | {$define Delphi11} 418 | {$endif} 419 | 420 | // D12.0 Athens 421 | {$ifdef VER360} 422 | {$define Delphi2} 423 | {$define Delphi3} 424 | {$define Delphi4} 425 | {$define Delphi5} 426 | {$define Delphi6} 427 | {$define Delphi7} 428 | {$define Delphi8} 429 | {$define D2005} 430 | {$define D2006} 431 | {$define D2007} 432 | {$define D2009} 433 | {$define D2010} 434 | {$define D2011} 435 | {$define DelphiXE} 436 | {$define DelphiXE2} 437 | {$define DelphiXE3} 438 | {$define DelphiXE4} 439 | {$define DelphiXE5} 440 | {$define DelphiXE6} 441 | {$define DelphiXE7} 442 | {$define DelphiXE8} 443 | {$define Delphi10} 444 | {$define Delphi101} 445 | {$define Delphi102} 446 | {$define Delphi103} 447 | {$define Delphi104} 448 | {$define Delphi11} 449 | {$define Delphi12} 450 | {$endif} 451 | -------------------------------------------------------------------------------- /demo/SimpleTest.dpr: -------------------------------------------------------------------------------- 1 | program SimpleTest; 2 | 3 | {$include CompilerOptions.inc} 4 | 5 | {$AppType Console} 6 | 7 | {$R *.res} 8 | 9 | uses 10 | //WinMemMgr, 11 | //MemTest, 12 | //CorrectLocale, 13 | Stacktrace, 14 | Windows, 15 | SysUtils, 16 | ComObj; // sets System.SafeCallErrorProc in newer RTL versions (SafeCallErrorProc was set by SysUtils.pas in D2009!) 17 | 18 | 19 | // IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE = $8000: Terminal server aware 20 | // IMAGE_DLLCHARACTERISTICS_DYNAMIC_BASE = $40: Address Space Layout Randomization (ASLR) enabled 21 | // IMAGE_DLLCHARACTERISTICS_NX_COMPAT = $100: Data Execution Prevention (DEP) enabled 22 | {$SetPeOptFlags $8140} 23 | 24 | // IMAGE_FILE_LARGE_ADDRESS_AWARE: may use heap/code above 2GB 25 | {$SetPeFlags IMAGE_FILE_LARGE_ADDRESS_AWARE} 26 | 27 | 28 | // since Windows 7: 29 | function SetProcessPreferredUILanguages(dwFlags: DWORD; pwszLanguagesBuffer: PWideChar; pulNumLanguages: PULONG): BOOL; stdcall; external Windows.kernel32 name 'SetProcessPreferredUILanguages'; 30 | 31 | 32 | //=================================================================================================================== 33 | // Force a given language to be used for dynamically loaded (resource-based) texts, like Windows error message texts. 34 | // Note: Works only if the respective Windows language pack is installed. 35 | //=================================================================================================================== 36 | procedure SetLang; 37 | const 38 | MUI_LANGUAGE_NAME = $8; // use ISO language (culture) name convention 39 | LangNames: array [0..6] of WideChar = 'en-US'#0#0; 40 | begin 41 | SetProcessPreferredUILanguages(MUI_LANGUAGE_NAME, LangNames, nil); 42 | end; 43 | 44 | 45 | //=================================================================================================================== 46 | // The compiler will generate code at the call site for this. 47 | //=================================================================================================================== 48 | procedure Something; 49 | begin 50 | end; 51 | 52 | 53 | //=================================================================================================================== 54 | // Testing Delphi statement "raise Exception". 55 | //=================================================================================================================== 56 | procedure TestDelpiException; 57 | var 58 | AcquiredException: TObject; 59 | begin 60 | Something; 61 | try 62 | 63 | try 64 | try 65 | raise Exception.Create('Exception #1'); 66 | finally 67 | Something; 68 | end; 69 | except 70 | raise; 71 | end; 72 | 73 | Something; 74 | except 75 | on e: Exception do begin 76 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 77 | Writeln(e.StackTrace); 78 | 79 | try 80 | Something; 81 | 82 | try 83 | Something; 84 | 85 | try 86 | 87 | try 88 | raise Exception.Create('Exception #2'); 89 | except 90 | // test situation when AcquireExceptionObject is used: 91 | AcquiredException := System.AcquireExceptionObject; 92 | end; 93 | 94 | Something; 95 | // reraise the catched exception: 96 | raise AcquiredException; 97 | 98 | finally 99 | Something; 100 | end; 101 | 102 | Something; 103 | except 104 | raise; 105 | end; 106 | 107 | Something; 108 | except 109 | on e: Exception do begin 110 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 111 | Writeln(e.StackTrace); 112 | end; 113 | end; 114 | 115 | end; 116 | end; 117 | Something; 118 | end; 119 | 120 | 121 | //=================================================================================================================== 122 | // Testing native Windows exception "div by zero". 123 | //=================================================================================================================== 124 | procedure TestOsException; 125 | 126 | function _GetZero: integer; 127 | begin 128 | Result := 0; 129 | end; 130 | 131 | var 132 | AcquiredException: TObject; 133 | begin 134 | Something; 135 | try 136 | 137 | try 138 | try 139 | Writeln(1 div _GetZero); // force exception 140 | finally 141 | Something; 142 | end; 143 | except 144 | raise; 145 | end; 146 | 147 | Something; 148 | except 149 | on e: Exception do begin 150 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 151 | Writeln(e.StackTrace); 152 | 153 | try 154 | Something; 155 | 156 | try 157 | Something; 158 | 159 | try 160 | // compiler cannot know that the division always throws an exception: 161 | AcquiredException := nil; 162 | 163 | try 164 | Writeln(1 div _GetZero); // force exception 165 | except 166 | // test situation when AcquireExceptionObject is used: 167 | AcquiredException := System.AcquireExceptionObject; 168 | end; 169 | 170 | Something; 171 | // reraise the catched exception: 172 | raise AcquiredException; 173 | 174 | finally 175 | Something; 176 | end; 177 | 178 | Something; 179 | except 180 | raise; 181 | end; 182 | 183 | Something; 184 | except 185 | on e: Exception do begin 186 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 187 | Writeln(e.StackTrace); 188 | end; 189 | end; 190 | 191 | end; 192 | end; 193 | Something; 194 | end; 195 | 196 | 197 | //=================================================================================================================== 198 | // Testing native Windows exception "access violation". 199 | //=================================================================================================================== 200 | procedure TestEAccessViolation; 201 | var 202 | AcquiredException: TObject; 203 | begin 204 | Something; 205 | try 206 | 207 | try 208 | try 209 | PByte(nil)[20] := 0; // force exception 210 | finally 211 | Something; 212 | end; 213 | except 214 | raise; 215 | end; 216 | 217 | Something; 218 | except 219 | on e: Exception do begin 220 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 221 | Writeln(e.StackTrace); 222 | 223 | try 224 | Something; 225 | 226 | try 227 | Something; 228 | 229 | try 230 | // compiler does not detect that the assignment always throws an exception: 231 | AcquiredException := nil; 232 | 233 | try 234 | PByte(nil)[20] := 0; // force exception 235 | except 236 | // test situation when AcquireExceptionObject is used: 237 | AcquiredException := System.AcquireExceptionObject; 238 | end; 239 | 240 | Something; 241 | // reraise the catched exception: 242 | raise AcquiredException; 243 | 244 | finally 245 | Something; 246 | end; 247 | 248 | Something; 249 | except 250 | raise; 251 | end; 252 | 253 | Something; 254 | except 255 | on e: Exception do begin 256 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 257 | Writeln(e.StackTrace); 258 | end; 259 | end; 260 | 261 | end; 262 | end; 263 | Something; 264 | end; 265 | 266 | 267 | type 268 | // original COM interface: 269 | ITestComErr = interface(IUnknown) 270 | function ThrowError(arg: uint32; out res: uint32): HRESULT; stdcall; 271 | end; 272 | 273 | // minimal Delphi class which implements ITestComErr: 274 | TTestComErrObj = class(TInterfacedObject, ITestComErr) 275 | private 276 | function ThrowError(arg: uint32; out res: uint32): HRESULT; stdcall; 277 | end; 278 | 279 | // equivalent interface used as wrapper, using safecall: 280 | ITestComErrSafeCall = interface(IUnknown) 281 | function ThrowError(arg: uint32): uint32; safecall; 282 | end; 283 | 284 | 285 | //=================================================================================================================== 286 | //=================================================================================================================== 287 | function TTestComErrObj.ThrowError(arg: uint32; out res: uint32): HRESULT; 288 | begin 289 | res := arg; 290 | Result := E_NOTIMPL; //NOERROR 291 | end; 292 | 293 | 294 | //=================================================================================================================== 295 | // Testing exception thrown by safecall-wrapped COM method 296 | //=================================================================================================================== 297 | procedure TestSafecallException; 298 | var 299 | ComObj: ITestComErrSafeCall; 300 | AcquiredException: TObject; 301 | begin 302 | ITestComErr(ComObj) := TTestComErrObj.Create; 303 | 304 | Something; 305 | try 306 | 307 | try 308 | try 309 | ComObj.ThrowError(42); 310 | finally 311 | Something; 312 | end; 313 | except 314 | raise; 315 | end; 316 | 317 | Something; 318 | except 319 | on e: Exception do begin 320 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 321 | Writeln(e.StackTrace); 322 | 323 | try 324 | Something; 325 | 326 | try 327 | Something; 328 | 329 | try 330 | // Compiler cannot know that ThrowError always throws an exception: 331 | AcquiredException := nil; 332 | 333 | try 334 | ComObj.ThrowError(42); 335 | except 336 | // test situation when AcquireExceptionObject is used: 337 | AcquiredException := System.AcquireExceptionObject; 338 | end; 339 | 340 | Something; 341 | // reraise the catched exception: 342 | raise AcquiredException; 343 | 344 | finally 345 | Something; 346 | end; 347 | 348 | Something; 349 | except 350 | raise; 351 | end; 352 | 353 | Something; 354 | except 355 | on e: Exception do begin 356 | Writeln(e.Message, ': Exception "', e.ClassName, '"'); 357 | Writeln(e.StackTrace); 358 | end; 359 | end; 360 | 361 | end; 362 | end; 363 | Something; 364 | end; 365 | 366 | 367 | //=================================================================================================================== 368 | //=================================================================================================================== 369 | function EnumWindowsCallback(hwnd: HWND; lParam: LPARAM): BOOL; stdcall; 370 | begin 371 | Writeln('Callstack from inside EnumWindows:'); 372 | Writeln(TStackTraceHlp.GetStackTrace); 373 | Result := false; 374 | end; 375 | 376 | 377 | //=================================================================================================================== 378 | // Testing stack trace with full Windows DLL symbols, by capturing a call stack inside a Windows callback. 379 | //=================================================================================================================== 380 | procedure TestCallStackFromWithinWindowsCallback; 381 | begin 382 | Windows.EnumWindows(@EnumWindowsCallback, 0); 383 | end; 384 | 385 | 386 | //=================================================================================================================== 387 | // Verifying DLL unload detection in Stacktrace.pas: Load and unload a DLL *not* currently loaded by the process. 388 | //=================================================================================================================== 389 | procedure LoadAndUnloadSomeDLL; 390 | var 391 | hMod: HMODULE; 392 | begin 393 | hMod := Windows.LoadLibrary('hid.dll'); 394 | Assert(hMod <> 0); 395 | Windows.FreeLibrary(hMod); 396 | end; 397 | 398 | 399 | //=================================================================================================================== 400 | // Run the tests. 401 | //=================================================================================================================== 402 | procedure Main; 403 | begin 404 | //TStackTraceHlp.SymSearchPath := 'srv*c:\temp\symbols*https://msdl.microsoft.com/download/symbols'; 405 | //TStackTraceHlp.EnableDebugOutput := true; 406 | 407 | SetLang; 408 | 409 | Writeln('Stacktrace without exception:'); 410 | Writeln(TStackTraceHlp.GetStackTrace); 411 | 412 | Writeln('~~~~~~~~~~~~'); 413 | 414 | TestDelpiException; 415 | 416 | Writeln('~~~~~~~~~~~~'); 417 | 418 | LoadAndUnloadSomeDLL; 419 | 420 | TestOsException; 421 | 422 | Writeln('~~~~~~~~~~~~'); 423 | 424 | LoadAndUnloadSomeDLL; 425 | 426 | TestEAccessViolation; 427 | 428 | Writeln('~~~~~~~~~~~~'); 429 | 430 | TestSafecallException; 431 | 432 | Writeln('~~~~~~~~~~~~'); 433 | 434 | TestCallStackFromWithinWindowsCallback; 435 | 436 | Write('Finished (press ENTER).'); 437 | Readln; 438 | end; 439 | 440 | 441 | begin 442 | Main; 443 | end. 444 | 445 | -------------------------------------------------------------------------------- /source/Windows/DbgHelp.pas: -------------------------------------------------------------------------------- 1 | unit DbgHelp; 2 | 3 | { 4 | Selection of Windows API types and functions that are needed for stacktraces. 5 | DbgHelp.h 6 | WinNT.h 7 | https://docs.microsoft.com/en-us/windows/win32/debug/updated-platform-support 8 | } 9 | 10 | {$include LibOptions.inc} 11 | {$MinEnumSize 4} 12 | 13 | interface 14 | 15 | uses Windows; 16 | 17 | {$if not defined(Win32) and not defined(Win64)} 18 | {$message error 'wrong!'} 19 | {$ifend} 20 | 21 | type 22 | {$if declared(DWORD64)} 23 | DWORD64 = Windows.DWORD64; 24 | {$else} 25 | DWORD64 = uint64; 26 | {$ifend} 27 | 28 | {$if declared(ULONG64)} 29 | ULONG64 = Windows.ULONG64; 30 | {$else} 31 | ULONG64 = uint64; 32 | {$ifend} 33 | 34 | {$if declared(LONG)} 35 | LONG = Windows.LONG; 36 | {$else} 37 | LONG = Longint; 38 | {$ifend} 39 | 40 | const 41 | IMAGE_FILE_MACHINE_I386 = Windows.IMAGE_FILE_MACHINE_I386; 42 | {$if declared(IMAGE_FILE_MACHINE_AMD64)} 43 | IMAGE_FILE_MACHINE_AMD64 = Windows.IMAGE_FILE_MACHINE_AMD64; 44 | {$ifend} 45 | {$if declared(IMAGE_FILE_MACHINE_ARM)} 46 | IMAGE_FILE_MACHINE_ARM = Windows.IMAGE_FILE_MACHINE_ARM; 47 | {$ifend} 48 | 49 | // WinNT.h: 50 | const 51 | MAXIMUM_SUPPORTED_EXTENSION = 512; 52 | 53 | {$ifdef Win64} 54 | 55 | CONTEXT_AMD64 = $100000; 56 | 57 | CONTEXT_CONTROL = (CONTEXT_AMD64 or $01); 58 | CONTEXT_INTEGER = (CONTEXT_AMD64 or $02); 59 | CONTEXT_SEGMENTS = (CONTEXT_AMD64 or $04); 60 | CONTEXT_FLOATING_POINT = (CONTEXT_AMD64 or $08); 61 | CONTEXT_DEBUG_REGISTERS = (CONTEXT_AMD64 or $10); 62 | 63 | CONTEXT_FULL = (CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_FLOATING_POINT); 64 | 65 | CONTEXT_ALL = (CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS or CONTEXT_FLOATING_POINT or CONTEXT_DEBUG_REGISTERS); 66 | 67 | {$else} 68 | 69 | CONTEXT_i386 = $00010000; // this assumes that i386 and 70 | 71 | CONTEXT_CONTROL = (CONTEXT_i386 or $00000001); // SS:SP, CS:IP, FLAGS, BP 72 | CONTEXT_INTEGER = (CONTEXT_i386 or $00000002); // AX, BX, CX, DX, SI, DI 73 | CONTEXT_SEGMENTS = (CONTEXT_i386 or $00000004); // DS, ES, FS, GS 74 | CONTEXT_FLOATING_POINT = (CONTEXT_i386 or $00000008); // 387 state 75 | CONTEXT_DEBUG_REGISTERS = (CONTEXT_i386 or $00000010); // DB 0-3,6,7 76 | CONTEXT_EXTENDED_REGISTERS = (CONTEXT_i386 or $00000020); // cpu specific extensions 77 | 78 | CONTEXT_FULL = (CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS); 79 | 80 | CONTEXT_ALL = (CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS or CONTEXT_FLOATING_POINT or CONTEXT_DEBUG_REGISTERS or 81 | CONTEXT_EXTENDED_REGISTERS); 82 | {$endif} 83 | 84 | 85 | // WinNT.h: 86 | type 87 | //*** DECLSPEC_ALIGN(16) 88 | M128A = record 89 | Low: ULONGLONG; 90 | High: LONGLONG; 91 | end; 92 | {$if sizeof(M128A) <> 16} {$message error 'wrong size'} {$ifend} 93 | 94 | 95 | //*** DECLSPEC_ALIGN(16) 96 | XMM_SAVE_AREA32 = record 97 | case byte of 98 | 0: ( 99 | ControlWord: WORD; 100 | StatusWord: WORD; 101 | TagWord: BYTE; 102 | Reserved1: BYTE; 103 | ErrorOpcode: WORD; 104 | ErrorOffset: DWORD; 105 | ErrorSelector: WORD; 106 | Reserved2: WORD; 107 | DataOffset: DWORD; 108 | DataSelector: WORD; 109 | Reserved3: WORD; 110 | MxCsr: DWORD; 111 | MxCsr_Mask: DWORD; 112 | FloatRegisters: array [0..7] of M128A; 113 | 114 | XmmRegisters: array [0..15] of M128A; 115 | Reserved4: array [0..95] of BYTE; 116 | ); 117 | 1: ( 118 | Header: array [0..1] of M128A; 119 | Legacy: array [0..7] of M128A; 120 | Xmm0: M128A; 121 | Xmm1: M128A; 122 | Xmm2: M128A; 123 | Xmm3: M128A; 124 | Xmm4: M128A; 125 | Xmm5: M128A; 126 | Xmm6: M128A; 127 | Xmm7: M128A; 128 | Xmm8: M128A; 129 | Xmm9: M128A; 130 | Xmm10: M128A; 131 | Xmm11: M128A; 132 | Xmm12: M128A; 133 | Xmm13: M128A; 134 | Xmm14: M128A; 135 | Xmm15: M128A; 136 | ); 137 | end; 138 | {$if sizeof(XMM_SAVE_AREA32) <> 512} {$message error 'wrong size'} {$ifend} 139 | 140 | 141 | //*** DECLSPEC_ALIGN(16) 142 | CONTEXT_x64 = record 143 | 144 | // 145 | // Register parameter home addresses. 146 | // 147 | // N.B. These fields are for convience - they could be used to extend the 148 | // context record in the future. 149 | // 150 | 151 | P1Home: DWORD64; 152 | P2Home: DWORD64; 153 | P3Home: DWORD64; 154 | P4Home: DWORD64; 155 | P5Home: DWORD64; 156 | P6Home: DWORD64; 157 | 158 | // 159 | // Control flags. 160 | // 161 | 162 | ContextFlags: DWORD; 163 | MxCsr: DWORD; 164 | 165 | // 166 | // Segment Registers and processor flags. 167 | // 168 | 169 | SegCs: WORD; 170 | SegDs: WORD; 171 | SegEs: WORD; 172 | SegFs: WORD; 173 | SegGs: WORD; 174 | SegSs: WORD; 175 | EFlags: DWORD; 176 | 177 | // 178 | // Debug registers 179 | // 180 | 181 | Dr0: DWORD64; 182 | Dr1: DWORD64; 183 | Dr2: DWORD64; 184 | Dr3: DWORD64; 185 | Dr6: DWORD64; 186 | Dr7: DWORD64; 187 | 188 | // 189 | // Integer registers. 190 | // 191 | 192 | Rax: DWORD64; 193 | Rcx: DWORD64; 194 | Rdx: DWORD64; 195 | Rbx: DWORD64; 196 | Rsp: DWORD64; 197 | Rbp: DWORD64; 198 | Rsi: DWORD64; 199 | Rdi: DWORD64; 200 | R8: DWORD64; 201 | R9: DWORD64; 202 | R10: DWORD64; 203 | R11: DWORD64; 204 | R12: DWORD64; 205 | R13: DWORD64; 206 | R14: DWORD64; 207 | R15: DWORD64; 208 | 209 | // 210 | // Program counter. 211 | // 212 | 213 | Rip: DWORD64; 214 | 215 | // 216 | // Floating point state. 217 | // 218 | 219 | FltSave: XMM_SAVE_AREA32; 220 | 221 | // 222 | // Vector registers. 223 | // 224 | 225 | VectorRegister: array [0..25] of M128A; 226 | VectorControl: DWORD64; 227 | 228 | // 229 | // Special debug control registers. 230 | // 231 | 232 | DebugControl: DWORD64; 233 | LastBranchToRip: DWORD64; 234 | LastBranchFromRip: DWORD64; 235 | LastExceptionToRip: DWORD64; 236 | LastExceptionFromRip: DWORD64; 237 | end; 238 | {$if sizeof(CONTEXT_x64) <> 1232} {$message error 'wrong size'} {$ifend} 239 | 240 | 241 | CONTEXT_x32 = record 242 | 243 | // 244 | // The flags values within this flag control the contents of 245 | // a CONTEXT record. 246 | // 247 | // If the context record is used as an input parameter, then 248 | // for each portion of the context record controlled by a flag 249 | // whose value is set, it is assumed that that portion of the 250 | // context record contains valid context. If the context record 251 | // is being used to modify a threads context, then only that 252 | // portion of the threads context will be modified. 253 | // 254 | // If the context record is used as an IN OUT parameter to capture 255 | // the context of a thread, then only those portions of the thread's 256 | // context corresponding to set flags will be returned. 257 | // 258 | // The context record is never used as an OUT only parameter. 259 | // 260 | 261 | ContextFlags: DWORD; 262 | 263 | // 264 | // This section is specified/returned if CONTEXT_DEBUG_REGISTERS is 265 | // set in ContextFlags. Note that CONTEXT_DEBUG_REGISTERS is NOT 266 | // included in CONTEXT_FULL. 267 | // 268 | 269 | Dr0: DWORD; 270 | Dr1: DWORD; 271 | Dr2: DWORD; 272 | Dr3: DWORD; 273 | Dr6: DWORD; 274 | Dr7: DWORD; 275 | 276 | // 277 | // This section is specified/returned if the 278 | // ContextFlags word contians the flag CONTEXT_FLOATING_POINT. 279 | // 280 | 281 | FloatSave: Windows.FLOATING_SAVE_AREA; 282 | 283 | // 284 | // This section is specified/returned if the 285 | // ContextFlags word contians the flag CONTEXT_SEGMENTS. 286 | // 287 | 288 | SegGs: DWORD; 289 | SegFs: DWORD; 290 | SegEs: DWORD; 291 | SegDs: DWORD; 292 | 293 | // 294 | // This section is specified/returned if the 295 | // ContextFlags word contians the flag CONTEXT_INTEGER. 296 | // 297 | 298 | Edi: DWORD; 299 | Esi: DWORD; 300 | Ebx: DWORD; 301 | Edx: DWORD; 302 | Ecx: DWORD; 303 | Eax: DWORD; 304 | 305 | // 306 | // This section is specified/returned if the 307 | // ContextFlags word contians the flag CONTEXT_CONTROL. 308 | // 309 | 310 | Ebp: DWORD; 311 | Eip: DWORD; 312 | SegCs: DWORD; // MUST BE SANITIZED 313 | EFlags:DWORD; // MUST BE SANITIZED 314 | Esp: DWORD; 315 | SegSs: DWORD; 316 | 317 | // 318 | // This section is specified/returned if the ContextFlags word 319 | // contains the flag CONTEXT_EXTENDED_REGISTERS. 320 | // The format and contexts are processor specific 321 | // 322 | 323 | ExtendedRegisters: array [0..MAXIMUM_SUPPORTED_EXTENSION - 1] of BYTE; 324 | end; 325 | {$if sizeof(CONTEXT_x32) <> 716} {$message error 'wrong size'} {$ifend} 326 | 327 | CONTEXT = {$ifdef Win64}CONTEXT_x64{$else}CONTEXT_x32{$endif}; 328 | 329 | 330 | 331 | // DbgHelp.h: 332 | const 333 | DbgHelpDLL = 'DbgHelp.dll'; 334 | 335 | // 336 | // options that are set/returned by SymSetOptions() & SymGetOptions() 337 | // these are used as a mask 338 | // 339 | SYMOPT_CASE_INSENSITIVE = $00000001; 340 | SYMOPT_UNDNAME = $00000002; 341 | SYMOPT_DEFERRED_LOADS = $00000004; 342 | SYMOPT_NO_CPP = $00000008; 343 | SYMOPT_LOAD_LINES = $00000010; 344 | SYMOPT_OMAP_FIND_NEAREST = $00000020; 345 | SYMOPT_LOAD_ANYTHING = $00000040; 346 | SYMOPT_IGNORE_CVREC = $00000080; 347 | SYMOPT_NO_UNQUALIFIED_LOADS = $00000100; 348 | SYMOPT_FAIL_CRITICAL_ERRORS = $00000200; 349 | SYMOPT_EXACT_SYMBOLS = $00000400; 350 | SYMOPT_ALLOW_ABSOLUTE_SYMBOLS = $00000800; 351 | SYMOPT_IGNORE_NT_SYMPATH = $00001000; 352 | SYMOPT_INCLUDE_32BIT_MODULES = $00002000; 353 | SYMOPT_PUBLICS_ONLY = $00004000; 354 | SYMOPT_NO_PUBLICS = $00008000; 355 | SYMOPT_AUTO_PUBLICS = $00010000; 356 | SYMOPT_NO_IMAGE_SEARCH = $00020000; 357 | SYMOPT_SECURE = $00040000; 358 | SYMOPT_NO_PROMPTS = $00080000; 359 | SYMOPT_OVERWRITE = $00100000; 360 | SYMOPT_IGNORE_IMAGEDIR = $00200000; 361 | SYMOPT_FLAT_DIRECTORY = $00400000; 362 | SYMOPT_FAVOR_COMPRESSED = $00800000; 363 | SYMOPT_ALLOW_ZERO_ADDRESS = $01000000; 364 | SYMOPT_DISABLE_SYMSRV_AUTODETECT = $02000000; 365 | 366 | SYMOPT_DEBUG = $80000000; 367 | 368 | 369 | // DbgHelp.h: 370 | type 371 | KDHELP64 = record 372 | // 373 | // address of kernel thread object, as provided in the 374 | // WAIT_STATE_CHANGE packet. 375 | // 376 | Thread: DWORD64; 377 | 378 | // 379 | // offset in thread object to pointer to the current callback frame 380 | // in kernel stack. 381 | // 382 | ThCallbackStack: DWORD; 383 | 384 | // 385 | // offset in thread object to pointer to the current callback backing 386 | // store frame in kernel stack. 387 | // 388 | ThCallbackBStore: DWORD; 389 | 390 | // 391 | // offsets to values in frame: 392 | // 393 | // address of next callback frame 394 | NextCallback: DWORD; 395 | 396 | // address of saved frame pointer (if applicable) 397 | FramePointer: DWORD; 398 | 399 | 400 | // 401 | // Address of the kernel function that calls out to user mode 402 | // 403 | KiCallUserMode: DWORD64; 404 | 405 | // 406 | // Address of the user mode dispatcher function 407 | // 408 | KeUserCallbackDispatcher: DWORD64; 409 | 410 | // 411 | // Lowest kernel mode address 412 | // 413 | SystemRangeStart: DWORD64; 414 | 415 | // 416 | // Address of the user mode exception dispatcher function. 417 | // Added in API version 10. 418 | // 419 | KiUserExceptionDispatcher: DWORD64; 420 | 421 | // 422 | // Stack bounds, added in API version 11. 423 | // 424 | StackBase: DWORD64; 425 | StackLimit: DWORD64; 426 | 427 | Reserved: array [0..4] of DWORD64; 428 | end; 429 | 430 | 431 | ADDRESS_MODE = ( 432 | AddrMode1616, 433 | AddrMode1632, 434 | AddrModeReal, 435 | AddrModeFlat 436 | ); 437 | 438 | 439 | ADDRESS64 = record 440 | Offset: DWORD64; 441 | Segment: WORD; 442 | Mode: ADDRESS_MODE; 443 | end; 444 | 445 | 446 | STACKFRAME64 = record 447 | AddrPC: ADDRESS64; // program counter 448 | AddrReturn: ADDRESS64; // return address 449 | AddrFrame: ADDRESS64; // frame pointer 450 | AddrStack: ADDRESS64; // stack pointer 451 | AddrBStore: ADDRESS64; // backing store pointer 452 | FuncTableEntry: pointer; // pointer to pdata/fpo or NULL 453 | Params: array [0..3] of DWORD64;// possible arguments to the function 454 | &Far: BOOL; // WOW far call 455 | &Virtual: BOOL; // is this a virtual frame? 456 | Reserved: array [0..2] of DWORD64; 457 | KdHelp: KDHELP64; 458 | end; 459 | 460 | 461 | SYM_TYPE = ( 462 | SymNone = 0, 463 | SymCoff, 464 | SymCv, 465 | SymPdb, 466 | SymExport, 467 | SymDeferred, 468 | SymSym, // .sym file 469 | SymDia, 470 | SymVirtual, 471 | NumSymTypes 472 | ); 473 | 474 | 475 | IMAGEHLP_MODULE64 = record 476 | SizeOfStruct: DWORD; // set to sizeof(IMAGEHLP_MODULE64) 477 | BaseOfImage: DWORD64; // base load address of module 478 | ImageSize: DWORD; // virtual size of the loaded module 479 | TimeDateStamp: DWORD; // date/time stamp from pe header 480 | CheckSum: DWORD; // checksum from the pe header 481 | NumSyms: DWORD; // number of symbols in the symbol table 482 | SymType: SYM_TYPE; // type of symbols loaded 483 | ModuleName: array [0..31] of Char; // module name 484 | ImageName: array [0..255] of Char; // image name 485 | LoadedImageName: array [0..255] of Char; // symbol file name 486 | // new elements: 07-Jun-2002 487 | LoadedPdbName: array [0..255] of Char; // pdb file name 488 | CVSig: DWORD; // Signature of the CV record in the debug directories 489 | CVData: array [0..MAX_PATH * 3 - 1] of Char; // Contents of the CV record 490 | PdbSig: DWORD; // Signature of PDB 491 | PdbSig70: TGUID; // Signature of PDB (VC 7 and up) 492 | PdbAge: DWORD; // DBI age of pdb 493 | PdbUnmatched: BOOL; // loaded an unmatched pdb 494 | DbgUnmatched: BOOL; // loaded an unmatched dbg 495 | LineNumbers: BOOL; // we have line number information 496 | GlobalSymbols: BOOL; // we have internal symbol information 497 | TypeInfo: BOOL; // we have type information 498 | // new elements: 17-Dec-2003 499 | SourceIndexed: BOOL; // pdb supports source server 500 | Publics: BOOL; // contains public symbols 501 | end; 502 | 503 | 504 | SYMBOL_INFO = record 505 | SizeOfStruct: ULONG; 506 | TypeIndex: ULONG; // Type Index of symbol 507 | Reserved: array [0..1] of ULONG64; 508 | Index: ULONG; 509 | Size: ULONG; 510 | ModBase: ULONG64; // Base Address of module comtaining this symbol 511 | Flags: ULONG; 512 | Value: ULONG64; // Value of symbol, ValuePresent should be 1 513 | Address: ULONG64; // Address of symbol including base address of module 514 | &Register: ULONG; // register holding value or pointer to value 515 | Scope: ULONG; // scope of the symbol 516 | Tag: ULONG; // pdb classification 517 | NameLen: ULONG; // Actual length of name 518 | MaxNameLen: ULONG; 519 | Name: array [0..0] of char; // Name of symbol 520 | end; 521 | 522 | 523 | IMAGEHLP_LINE64 = record 524 | SizeOfStruct: DWORD; // set to sizeof(IMAGEHLP_LINE64) 525 | Key: pointer; // internal 526 | LineNumber: DWORD; // line number in file 527 | FileName: PChar; // full filename 528 | Address: DWORD64; // first instruction of line 529 | end; 530 | 531 | 532 | // DbgHelp.h: 533 | function SymInitialize( 534 | hProcess: THandle; 535 | UserSearchPath: PChar; 536 | fInvadeProcess: BOOL 537 | ): BOOL; stdcall; external DbgHelpDLL name {$ifdef UNICODE}'SymInitializeW'{$else}'SymInitialize'{$endif}; 538 | 539 | // DbgHelp.h: 540 | function SymCleanup( 541 | hProcess: THandle 542 | ): BOOL; stdcall; external DbgHelpDLL name 'SymCleanup'; 543 | 544 | // DbgHelp.h: 545 | function SymSetOptions( 546 | SymOptions: DWORD 547 | ): DWORD; stdcall; external DbgHelpDLL name 'SymSetOptions'; 548 | 549 | // DbgHelp.h: 550 | function SymRefreshModuleList( 551 | hProcess: THandle 552 | ): BOOL; stdcall; external DbgHelpDLL name 'SymRefreshModuleList'; 553 | 554 | // DbgHelp.h: 555 | function SymFunctionTableAccess64( 556 | hProcess: THandle; 557 | AddrBase: DWORD64 558 | ): pointer; stdcall; external DbgHelpDLL name 'SymFunctionTableAccess64'; 559 | 560 | // DbgHelp.h: 561 | function SymGetModuleBase64( 562 | hProcess: THandle; 563 | dwAddr: DWORD64 564 | ): DWORD64; stdcall; external DbgHelpDLL name 'SymGetModuleBase64'; 565 | 566 | // DbgHelp.h: 567 | function SymGetModuleInfo64( 568 | hProcess: THandle; 569 | dwAddr: DWORD64; 570 | out ModuleInfo: IMAGEHLP_MODULE64 571 | ): BOOL; stdcall; external DbgHelpDLL name {$ifdef UNICODE}'SymGetModuleInfoW64'{$else}'SymGetModuleInfo64'{$endif}; 572 | 573 | // DbgHelp.h: 574 | function SymFromAddr( 575 | hProcess: THandle; 576 | dwAddr: DWORD64; 577 | out Displacement: DWORD64; 578 | var Symbol: SYMBOL_INFO 579 | ): BOOL; stdcall; external DbgHelpDLL name {$ifdef UNICODE}'SymFromAddrW'{$else}'SymFromAddr'{$endif}; 580 | (* 581 | // DbgHelp.h: 582 | function SymGetSymFromAddr64( 583 | hProcess: THandle; 584 | dwAddr: DWORD64; 585 | out pdwDisplacement: DWORD64; 586 | out Symbol: IMAGEHLP_SYMBOL64 587 | ): Bool; stdcall; external DbgHelpDLL name 'SymGetSymFromAddr64'; 588 | *) 589 | // DbgHelp.h: 590 | function SymGetLineFromAddr64( 591 | hProcess: THandle; 592 | dwAddr: DWORD64; 593 | out pdwDisplacement: DWORD; 594 | out Line: IMAGEHLP_LINE64 595 | ): BOOL; stdcall; external DbgHelpDLL name {$ifdef UNICODE}'SymGetLineFromAddrW64'{$else}'SymGetLineFromAddr64'{$endif}; 596 | 597 | 598 | type 599 | // DbgHelp.h: 600 | PREAD_PROCESS_MEMORY_ROUTINE = function ( 601 | hProcess: THandle; 602 | lpBaseAddress: DWORD64; 603 | lpBuffer: pointer; 604 | nSize: DWORD; 605 | out lpNumberOfBytesRead: DWORD 606 | ): BOOL; stdcall; 607 | 608 | // DbgHelp.h: 609 | PFUNCTION_TABLE_ACCESS_ROUTINE = function ( 610 | hProcess: THandle; 611 | AddrBase: DWORD64 612 | ): pointer; stdcall; 613 | 614 | // DbgHelp.h: 615 | PGET_MODULE_BASE_ROUTINE = function ( 616 | hProcess: THandle; 617 | Address: DWORD64 618 | ): DWORD64; stdcall; 619 | 620 | // DbgHelp.h: 621 | PTRANSLATE_ADDRESS_ROUTINE = function ( 622 | hProcess: THandle; 623 | hThread: THandle; 624 | out lpaddr: ADDRESS64 625 | ): DWORD64; stdcall; 626 | 627 | // DbgHelp.h: 628 | function StackWalk64( 629 | MachineType: DWORD; 630 | hProcess: THandle; 631 | hThread: THandle; 632 | var StackFrame: STACKFRAME64; 633 | var ContextRecord: CONTEXT; 634 | ReadMemoryRoutine: PREAD_PROCESS_MEMORY_ROUTINE; 635 | FunctionTableAccessRoutine: PFUNCTION_TABLE_ACCESS_ROUTINE; 636 | GetModuleBaseRoutine: PGET_MODULE_BASE_ROUTINE; 637 | TranslateAddress: PTRANSLATE_ADDRESS_ROUTINE 638 | ): BOOL; stdcall; external DbgHelpDLL name 'StackWalk64'; 639 | 640 | (* 641 | // WinNT.h: 642 | function RtlCaptureStackBackTrace( 643 | FramesToSkip: ULONG; 644 | FramesToCapture: ULONG; 645 | BackTrace: Pointer; 646 | BackTraceHash: PULONG 647 | ): USHORT; stdcall; external Windows.kernel32 name 'RtlCaptureStackBackTrace'; 648 | *) 649 | 650 | type 651 | // WinNT.h: 652 | PEXCEPTION_POINTERS = ^EXCEPTION_POINTERS; 653 | EXCEPTION_POINTERS = record 654 | ExceptionRecord: ^Windows.EXCEPTION_RECORD; 655 | ContextRecord: ^DbgHelp.CONTEXT; 656 | end; 657 | 658 | // WinNT.h: 659 | PVECTORED_EXCEPTION_HANDLER = function(ExceptionInfo: PEXCEPTION_POINTERS): LONG; stdcall; 660 | 661 | // WinBase.h: 662 | function AddVectoredExceptionHandler( 663 | First: ULONG; 664 | Handler: PVECTORED_EXCEPTION_HANDLER 665 | ): pointer; stdcall; external Windows.Kernel32 name 'AddVectoredExceptionHandler'; 666 | 667 | // WinBase.h: 668 | function RemoveVectoredExceptionHandler( 669 | Handle: pointer 670 | ): ULONG; stdcall; external Windows.Kernel32 name 'RemoveVectoredExceptionHandler'; 671 | 672 | 673 | type 674 | // winternl.h: 675 | NTSTATUS = LONG; 676 | 677 | const 678 | // ntstatus.h: 679 | STATUS_SUCCESS = NTSTATUS(0); 680 | 681 | // https://docs.microsoft.com/en-us/windows/win32/devnotes/ldrdllnotification 682 | LDR_DLL_NOTIFICATION_REASON_LOADED = 1; 683 | LDR_DLL_NOTIFICATION_REASON_UNLOADED = 2; 684 | 685 | type 686 | // no Windows header file [This function may be changed or removed from Windows without further notice.] 687 | PLDR_DLL_NOTIFICATION_FUNCTION = procedure( 688 | NotificationReason: ULONG; 689 | NotificationData: pointer; // PCLDR_DLL_NOTIFICATION_DATA; 690 | Context: pointer 691 | ); stdcall; 692 | 693 | // no Windows header file [This function may be changed or removed from Windows without further notice.] 694 | TLdrRegisterDllNotification = function( 695 | Flags: ULONG; 696 | NotificationFunction: PLDR_DLL_NOTIFICATION_FUNCTION; 697 | Context: pointer; 698 | out Cookie: pointer 699 | ): NTSTATUS; stdcall; 700 | 701 | // no Windows header file [This function may be changed or removed from Windows without further notice.] 702 | TLdrUnregisterDllNotification = function( 703 | Cookie: pointer 704 | ): NTSTATUS; stdcall; 705 | 706 | 707 | implementation 708 | 709 | end. 710 | -------------------------------------------------------------------------------- /source/StackTrace.pas: -------------------------------------------------------------------------------- 1 | unit StackTrace; 2 | 3 | { 4 | Enables the collection and output of stack traces in Delphi code. 5 | 6 | For readable and sensible results, *current* PDB files must exist in the same directory. 7 | 8 | Anders Melander's map2pdb.exe can be used for this: 9 | https://bitbucket.org/anders_melander/map2pdb/src/master/ 10 | 11 | 12 | Notes: 13 | 14 | As the Delphi runtime library handles things not consistently and contains bugs (see some of the comments in the code), 15 | I don't know if this works with other Delphi versions as well. Please use a memory leak detector to verify the behavior. 16 | 17 | Generally, the 64bit compiler and RTL fixes a few things, as exception reraising now always reuses the original exception 18 | object and it also generates source-line infos for the main part of the dpr file (the lines between "begin" and "end."). 19 | 20 | The 32bit compiler and RTL makes it nearly impossible to get the stacktrace from an non-delphi exception that is reraised: 21 | For some reason, the original exception object is released by the RTL and then a new one is created, but we still need the 22 | stackinfo from the original object which is now gone. It is not possible to recreate it. So for now, I just reattach the 23 | very last stackinfo, but depending on other exceptions thrown and catched between the original point and the reraise point, 24 | it may be no longer the correct one. 25 | 26 | To get notifications on DLL unloading, the Windows function LdrRegisterDllNotification is used, which may change on 27 | later Windows releases (unlikely). But there is no alternative. 28 | 29 | 30 | Enable lookup of Windows symbols: 31 | 32 | The standard dbghelp.dll that comes with Windows does not support downloading from symbol servers. To use this, you need 33 | two DLLs from the "Windows Debugging Tools": 34 | https://learn.microsoft.com/en-us/windows-hardware/drivers/debugger/debugger-download-tools 35 | 36 | Both "dbghelp.dll" and "symsrv.dll" from 37 | "C:\Program Files (x86)\Windows Kits\10\Debuggers\x86" (32 bit) 38 | or 39 | "C:\Program Files (x86)\Windows Kits\10\Debuggers\x64" (64 bit) 40 | needs to be copied into the same folder as the Delphi executable. 41 | 42 | To have the Windows symbols be used, the symbol search path needs to be altered, like this: 43 | TStackTraceHlp.SymSearchPath := 'srv*c:\temp\symbols*https://msdl.microsoft.com/download/symbols'; 44 | 45 | "c:\temp\symbols" inside this example string specifies a folder that is used as a cache for the downloaded PDBs (see 46 | https://learn.microsoft.com/en-us/windows/win32/debug/symbol-paths). 47 | 48 | As the download takes time and needs internet connectivity, and the cache folder needs to be placed somewhere, this is 49 | usually not an option for production environments. 50 | } 51 | 52 | {$include LibOptions.inc} 53 | 54 | interface 55 | 56 | uses 57 | Windows, 58 | WinSlimLock, 59 | DbgHelp; 60 | 61 | type 62 | // Supports the acquisition of stack traces with build-in Windows functionality. 63 | // The methods is also the basis for the private structure TExceptionHelp, which is used to capture 64 | // stack traces when exceptions are thrown. 65 | TStackTraceHlp = record 66 | private 67 | type 68 | TAddr = DWORD_PTR; 69 | strict private 70 | type 71 | self = TStackTraceHlp; 72 | CONTEXT = DbgHelp.CONTEXT; 73 | PCONTEXT = ^CONTEXT; 74 | SYMBOL_INFO = DbgHelp.SYMBOL_INFO; 75 | 76 | TFrameInfo = record 77 | ModuleName: string; 78 | FuncName: string; 79 | SrcFilename: string; 80 | SrcLineNo: uint32; 81 | function ToString: string; 82 | end; 83 | 84 | const 85 | FThread = THandle(-2); // = Windows.GetCurrentThread 86 | class var 87 | FLock: TSlimRWLock; // lock around all DbgHelp functions 88 | FHandlerCookie: pointer; // LdrRegisterDllNotification handle 89 | FProcess: THandle; // real handle of the current process, non-zero after SymInitialize 90 | FDoReinit: boolean; // set to true when a DLL was unloaded 91 | FSymSearchPath: string; // additional locations to lookup PDB files 92 | FEnableDebugOutput: boolean; // controls debug output from dbghelp.dll 93 | 94 | class procedure InitSyms; static; 95 | class function ProcessFrame(VirtualAddr: DWORD64): TFrameInfo; static; 96 | class function GetModuleFilename(hModule: HINST): string; static; 97 | class procedure SetSymSearchPath(const Value: string); static; 98 | 99 | class function GetFuncPtr(FuncName: PAnsiChar): pointer; static; 100 | class procedure OsDllNotification(Reason: ULONG; Data: pointer; Context: pointer); stdcall; static; 101 | private 102 | class procedure Init; static; 103 | class procedure Fini; static; 104 | class procedure FiniSyms; static; 105 | class procedure DoSetupContext(var Ctx: CONTEXT); static; 106 | class function DoGetStackTrace(var Ctx: CONTEXT; SkipFrames: uint32; out Addrs: array of TAddr): uint32; static; 107 | class function InterpretStackTrace(const Addrs: array of TAddr; Count: uint32): string; static; 108 | public 109 | // for the syntax, see: https://learn.microsoft.com/en-us/windows/win32/debug/symbol-paths 110 | class property SymSearchPath: string read FSymSearchPath write SetSymSearchPath; 111 | class property EnableDebugOutput: boolean read FEnableDebugOutput write FEnableDebugOutput; 112 | 113 | class function GetStackTrace: string; static; 114 | end; 115 | 116 | 117 | {############################################################################} 118 | implementation 119 | {############################################################################} 120 | 121 | uses 122 | Types, 123 | SysUtils; 124 | 125 | type 126 | TAddr = TStackTraceHlp.TAddr; 127 | 128 | TContextHlp = record helper for DbgHelp.CONTEXT 129 | strict private 130 | function GetIP: TAddr; inline; 131 | function GetSP: TAddr; inline; 132 | function GetBP: TAddr; inline; 133 | procedure SetIP(Value: TAddr); inline; 134 | procedure SetSP(Value: TAddr); inline; 135 | procedure SetBP(Value: TAddr); inline; 136 | public 137 | procedure SetNull; inline; 138 | property IP: TAddr read GetIP write SetIP; 139 | property SP: TAddr read GetSP write SetSP; 140 | property BP: TAddr read GetBP write SetBP; 141 | end; 142 | 143 | 144 | //=================================================================================================================== 145 | //=================================================================================================================== 146 | procedure MyAssert(Cond: boolean); inline; 147 | begin 148 | {$ifopt C+} 149 | if not Cond then begin 150 | Windows.OutputDebugString('StackTrace error'); 151 | Windows.DebugBreak; 152 | end; 153 | {$endif} 154 | end; 155 | 156 | 157 | //=================================================================================================================== 158 | //=================================================================================================================== 159 | procedure ZeroMem(var Mem; Size: integer); inline; 160 | begin 161 | System.FillChar(Mem, Size, 0); 162 | end; 163 | 164 | 165 | { TContextHlp } 166 | 167 | //=================================================================================================================== 168 | //=================================================================================================================== 169 | procedure TContextHlp.SetNull; 170 | begin 171 | ZeroMem(self, sizeof(self)); 172 | end; 173 | 174 | 175 | //=================================================================================================================== 176 | //=================================================================================================================== 177 | function TContextHlp.GetIP: TAddr; 178 | begin 179 | Result := {$ifdef Win64} self.Rip {$else} self.Eip {$endif}; 180 | end; 181 | 182 | 183 | //=================================================================================================================== 184 | //=================================================================================================================== 185 | function TContextHlp.GetSP: TAddr; 186 | begin 187 | Result := {$ifdef Win64} self.Rsp {$else} self.Esp {$endif}; 188 | end; 189 | 190 | 191 | //=================================================================================================================== 192 | //=================================================================================================================== 193 | function TContextHlp.GetBP: TAddr; 194 | begin 195 | Result := {$ifdef Win64} self.Rbp {$else} self.Ebp {$endif}; 196 | end; 197 | 198 | 199 | //=================================================================================================================== 200 | //=================================================================================================================== 201 | procedure TContextHlp.SetIP(Value: TAddr); 202 | begin 203 | {$ifdef Win64} self.Rip {$else} self.Eip {$endif} := Value; 204 | end; 205 | 206 | 207 | //=================================================================================================================== 208 | //=================================================================================================================== 209 | procedure TContextHlp.SetSP(Value: TAddr); 210 | begin 211 | {$ifdef Win64} self.Rsp {$else} self.Esp {$endif} := Value; 212 | end; 213 | 214 | 215 | //=================================================================================================================== 216 | //=================================================================================================================== 217 | procedure TContextHlp.SetBP(Value: TAddr); 218 | begin 219 | {$ifdef Win64} self.Rbp {$else} self.Ebp {$endif} := Value; 220 | end; 221 | 222 | 223 | { TStackTraceHlp.TFrameInfo } 224 | 225 | //=================================================================================================================== 226 | // Returns a line of text for this stack frame. 227 | //=================================================================================================================== 228 | function TStackTraceHlp.TFrameInfo.ToString: string; 229 | begin 230 | if self.SrcLineNo = 0 then 231 | Result := SysUtils.Format('%s%s', [self.ModuleName, self.FuncName]) 232 | else 233 | Result := SysUtils.Format('%s%s in %s (Line %u)', [self.ModuleName, self.FuncName, self.SrcFilename, self.SrcLineNo]); 234 | end; 235 | 236 | 237 | { TStackTraceHlp } 238 | 239 | //=================================================================================================================== 240 | // Setup for getting stack traces on Delphi exceptions. 241 | //=================================================================================================================== 242 | class procedure TStackTraceHlp.Init; 243 | var 244 | RegisterFunc: TLdrRegisterDllNotification; 245 | begin 246 | // registering to get DLL unload notifications (may not work in future Windows versions, but there is nothing else!): 247 | RegisterFunc := self.GetFuncPtr('LdrRegisterDllNotification'); 248 | if Assigned(RegisterFunc) then 249 | MyAssert(RegisterFunc(0, self.OsDllNotification, nil, FHandlerCookie) = STATUS_SUCCESS); 250 | end; 251 | 252 | 253 | //=================================================================================================================== 254 | // Teardown for getting stack traces on Delphi exceptions. 255 | //=================================================================================================================== 256 | class procedure TStackTraceHlp.Fini; 257 | var 258 | UnregisterFunc: TLdrUnregisterDllNotification; 259 | begin 260 | if Assigned(FHandlerCookie) then begin 261 | UnregisterFunc := self.GetFuncPtr('LdrUnregisterDllNotification'); 262 | MyAssert(UnregisterFunc(FHandlerCookie) = STATUS_SUCCESS); 263 | end; 264 | end; 265 | 266 | 267 | //=================================================================================================================== 268 | // Setter for property "SymSearchPath". 269 | //=================================================================================================================== 270 | class procedure TStackTraceHlp.SetSymSearchPath(const Value: string); 271 | begin 272 | FSymSearchPath := Value; 273 | FDoReinit := true; 274 | end; 275 | 276 | 277 | //=================================================================================================================== 278 | // Initializes the DbgHelp DLL for this process. 279 | // Must run in lock, as DbgHelp functions are not thread-safe. 280 | // Does not throw exceptions. 281 | //=================================================================================================================== 282 | class procedure TStackTraceHlp.InitSyms; 283 | var 284 | SearchPath: string; 285 | SymOptions: DWORD; 286 | begin 287 | // address space of an unloaded DLL may be reused (e.g. dynamic plug-ins) => reinitialize DbgHelp's symbol cache: 288 | if FDoReinit then begin 289 | FDoReinit := false; 290 | self.FiniSyms; 291 | // Note: Calling DbgHelp.SymRefreshModuleList(FProcess) takes much longer than simply reinitializing everything, 292 | // even at the 2nd call in the same process, as it downloads Windows symbols for a lot of Windows DLLs. 293 | // This is surprising as SymInitialize() with Invade=true should load the same modules. 294 | // MyAssert(DbgHelp.SymRefreshModuleList(FProcess)); 295 | end; 296 | 297 | // A process that calls SymInitialize should not call it again unless it calls SymCleanup first. 298 | if FProcess = 0 then begin 299 | 300 | FProcess := Windows.OpenProcess(PROCESS_VM_READ or PROCESS_QUERY_INFORMATION, false, Windows.GetCurrentProcessId); 301 | MyAssert(FProcess <> 0); 302 | 303 | // SYMOPT_DEBUG will cause diagnostics to be written to the "Event Log" window of the Delphi IDE: 304 | SymOptions := SYMOPT_LOAD_LINES or SYMOPT_DEFERRED_LOADS or SYMOPT_UNDNAME; 305 | if FEnableDebugOutput then SymOptions := SymOptions or SYMOPT_DEBUG; 306 | DbgHelp.SymSetOptions(SymOptions); 307 | 308 | SearchPath := SysUtils.ExtractFileDir(self.GetModuleFilename(0)); 309 | if FSymSearchPath <> '' then begin 310 | SearchPath := SearchPath + ';' + FSymSearchPath; 311 | end; 312 | 313 | MyAssert(DbgHelp.SymInitialize(FProcess, PChar(SearchPath), true)); 314 | end; 315 | end; 316 | 317 | 318 | //=================================================================================================================== 319 | // Must run in lock, as DbgHelp functions are not thread-safe. 320 | // Does not throw exceptions. 321 | //=================================================================================================================== 322 | class procedure TStackTraceHlp.FiniSyms; 323 | begin 324 | if FProcess <> 0 then begin 325 | MyAssert(DbgHelp.SymCleanup(FProcess)); 326 | MyAssert(Windows.CloseHandle(FProcess)); 327 | FProcess := 0; 328 | end; 329 | end; 330 | 331 | 332 | //=================================================================================================================== 333 | // Get pointer of function in ntdll.dll. Returns nil if unavaiable. 334 | //=================================================================================================================== 335 | class function TStackTraceHlp.GetFuncPtr(FuncName: PAnsiChar): pointer; 336 | begin 337 | Result := Windows.GetProcAddress(Windows.LoadLibrary('ntdll.dll'), FuncName); 338 | end; 339 | 340 | 341 | //=================================================================================================================== 342 | // Is called on loading and unloading of DLLs in the process. DLL unloading can occur at the very same time some thread 343 | // is taking a stack trace, but this thread should not have addresses of an unloading/unloaded DLL in its call stack. 344 | //=================================================================================================================== 345 | class procedure TStackTraceHlp.OsDllNotification(Reason: ULONG; Data: pointer; Context: pointer); 346 | begin 347 | if Reason = LDR_DLL_NOTIFICATION_REASON_UNLOADED then 348 | FDoReinit := true; 349 | end; 350 | 351 | 352 | //=================================================================================================================== 353 | // Returns the full path to the loaded module (EXE oder DLL) . 354 | // Does not throw exceptions. 355 | //=================================================================================================================== 356 | class function TStackTraceHlp.GetModuleFilename(hModule: HINST): string; 357 | var 358 | Len: DWORD; 359 | Buffer: array [0..MAX_PATH] of char; 360 | begin 361 | Len := System.Length(Buffer); 362 | if Windows.GetModuleFileName(hModule, Buffer, Len) >= Len then 363 | Result := '???' 364 | else 365 | Result := Buffer; 366 | end; 367 | 368 | 369 | //=================================================================================================================== 370 | // Captures the stack for the CPU context . (The stack must still cover the location of .) 371 | // Does not throw exceptions. 372 | //=================================================================================================================== 373 | class function TStackTraceHlp.DoGetStackTrace(var Ctx: CONTEXT; SkipFrames: uint32; out Addrs: array of TAddr): uint32; 374 | const 375 | MachineType = {$ifdef Win64} IMAGE_FILE_MACHINE_AMD64 {$else} IMAGE_FILE_MACHINE_I386 {$endif}; 376 | var 377 | Frame: STACKFRAME64; 378 | begin 379 | // DbgHelp functions are not thread-safe: 380 | FLock.AcquireExclusive; 381 | try 382 | 383 | self.InitSyms; 384 | 385 | ZeroMem(Frame, sizeof(Frame)); 386 | Frame.AddrPC.Mode := AddrModeFlat; 387 | Frame.AddrFrame.Mode := AddrModeFlat; 388 | Frame.AddrStack.Mode := AddrModeFlat; 389 | Frame.AddrPC.Offset := Ctx.IP; 390 | Frame.AddrFrame.Offset := Ctx.BP; 391 | Frame.AddrStack.Offset := Ctx.SP; 392 | 393 | Result := 0; 394 | 395 | // ContextRecord: This context may be modified, 396 | while (int32(Result) <= System.High(Addrs)) 397 | and DbgHelp.StackWalk64(MachineType, FProcess, FThread, Frame, Ctx, nil, DbgHelp.SymFunctionTableAccess64, DbgHelp.SymGetModuleBase64, nil) 398 | do begin 399 | if SkipFrames > 0 then begin 400 | dec(SkipFrames); 401 | continue; 402 | end; 403 | // prevent a Range Check exception on 32bit if Frame.AddrPC.Offset contains uint64(-1) which happens sometimes 404 | // (what does this mean?): 405 | if Frame.AddrPC.Offset <> DWORD64(-1) then begin 406 | Addrs[Result] := Frame.AddrPC.Offset; 407 | inc(Result); 408 | end; 409 | end; 410 | 411 | finally 412 | FLock.ReleaseExclusive; 413 | end; 414 | end; 415 | 416 | 417 | //=================================================================================================================== 418 | // Provides information on the code address via Windows' built-in mechanisms. The information improves 419 | // drastically if there are suitable pdb files for the EXE and DLLs. 420 | // Does not throw exceptions. 421 | //=================================================================================================================== 422 | class function TStackTraceHlp.ProcessFrame(VirtualAddr: DWORD64): TFrameInfo; 423 | const 424 | MaxSymbolLen = 254; 425 | var 426 | SymOffset: DWORD64; 427 | LineOffset: DWORD; 428 | Symbol: record 429 | case byte of 430 | 0: (s: DbgHelp.SYMBOL_INFO); 431 | 1: (b: array [0..sizeof(SYMBOL_INFO) - sizeof(char) + MaxSymbolLen * sizeof(char)] of byte); 432 | end; 433 | HaveSymbol: boolean; 434 | Line: IMAGEHLP_LINE64; 435 | begin 436 | MyAssert(FProcess <> 0); 437 | 438 | Finalize(Result); 439 | ZeroMem(Result, sizeof(Result)); 440 | 441 | ZeroMem(Symbol, sizeof(Symbol)); 442 | Symbol.s.SizeOfStruct := sizeof(Symbol.s); 443 | Symbol.s.MaxNameLen := MaxSymbolLen; // max name length excluding the null char 444 | 445 | // DbgHelp functions are not thread-safe: 446 | FLock.AcquireExclusive; 447 | try 448 | 449 | HaveSymbol := DbgHelp.SymFromAddr(FProcess, VirtualAddr, SymOffset, Symbol.s); 450 | 451 | if not HaveSymbol or (Symbol.s.ModBase = 0) then 452 | Symbol.s.ModBase := DbgHelp.SymGetModuleBase64(FProcess, VirtualAddr); 453 | 454 | if Symbol.s.ModBase <> 0 then 455 | Result.ModuleName := SysUtils.ExtractFilename(self.GetModuleFilename(HINST(Symbol.s.ModBase))) + ': '; 456 | 457 | if not HaveSymbol then begin 458 | Result.FuncName := '0x' + SysUtils.IntToHex(VirtualAddr, 2 * sizeof(pointer)); 459 | exit; 460 | end; 461 | 462 | SetString(Result.FuncName, Symbol.s.Name, Symbol.s.NameLen); 463 | 464 | ZeroMem(Line, sizeof(Line)); 465 | Line.SizeOfStruct := sizeof(Line); 466 | 467 | if DbgHelp.SymGetLineFromAddr64(FProcess, VirtualAddr, LineOffset, Line) then begin 468 | Result.SrcFilename := Line.FileName; 469 | Result.SrcLineNo := Line.LineNumber; 470 | end 471 | else if SymOffset <> 0 then begin 472 | Result.FuncName := Result.FuncName + ' + 0x' + SysUtils.IntToHex(SymOffset, 1) 473 | end; 474 | 475 | finally 476 | FLock.ReleaseExclusive; 477 | end; 478 | end; 479 | 480 | 481 | //=================================================================================================================== 482 | // Returns textual representation of . 483 | // Does not throw exceptions. 484 | //=================================================================================================================== 485 | class function TStackTraceHlp.InterpretStackTrace(const Addrs: array of TAddr; Count: uint32): string; 486 | var 487 | i: int32; 488 | begin 489 | Result := ''; 490 | for i := 0 to int32(Count) - 1 do begin 491 | if i <> 0 then Result := Result + #13#10; 492 | Result := Result + ' at ' + self.ProcessFrame(Addrs[i]).ToString; 493 | end; 494 | end; 495 | 496 | 497 | //=================================================================================================================== 498 | // Initializes for the current thread. It is particularly important to set EIP / RIP to an address within the 499 | // body(!) of the calling function. 500 | //=================================================================================================================== 501 | class procedure TStackTraceHlp.DoSetupContext(var Ctx: CONTEXT); 502 | asm 503 | {$ifdef Win64} 504 | 505 | // RCX = @Ctx 506 | 507 | .NOFRAME 508 | MOV Ctx.ContextFlags, CONTEXT_CONTROL or CONTEXT_INTEGER 509 | // for CONTEXT_CONTROL: 510 | MOV RDX, [RSP] // top element contains return address 511 | MOV Ctx.&Rip, RDX 512 | MOV Ctx.&Rbp, RBP // unclear if used as it is not part of the x64 calling convention 513 | LEA RDX, [RSP + 8] // make .RSP consistent to .RBP 514 | MOV Ctx.&Rsp, RDX // := RSP + sizeof(return address) 515 | // CONTEXT_INTEGER seams to cover Rbp and Rsp 516 | 517 | {$else} 518 | 519 | // EAX = @Ctx 520 | 521 | MOV Ctx.ContextFlags, CONTEXT_CONTROL 522 | // for CONTEXT_CONTROL: 523 | MOV EDX, [ESP] // top element contains return address 524 | MOV Ctx.&Eip, EDX 525 | MOV Ctx.&Ebp, EBP 526 | LEA EDX, [ESP + 4] // make .ESP consistent to .EBP 527 | MOV Ctx.&Esp, EDX // := ESP + sizeof(return address) 528 | 529 | {$endif} 530 | end; 531 | 532 | 533 | //=================================================================================================================== 534 | // For usage by application code, outside of the internal Delphi or Windows exception handling. 535 | //=================================================================================================================== 536 | class function TStackTraceHlp.GetStackTrace: string; 537 | var 538 | Ctx: DbgHelp.CONTEXT; 539 | Addrs: array [0..255] of TAddr; 540 | Count: uint32; 541 | begin 542 | Ctx.SetNull; 543 | self.DoSetupContext(Ctx); 544 | Count := self.DoGetStackTrace(Ctx, 1, Addrs); 545 | Result := self.InterpretStackTrace(Addrs, Count); 546 | end; 547 | 548 | 549 | type 550 | // Provides types and methods to hook into the Delphi and Windows exception mechanisms in order to 551 | // obtain stack traces of exceptions. 552 | TExceptionHelp = record 553 | strict private 554 | const 555 | cDelphiException = $0EEDFADE; // from System.pas 556 | type 557 | self = TExceptionHelp; 558 | 559 | PFrames = ^TFrames; 560 | TFrames = record 561 | Addrs: array [0..63] of TAddr; 562 | Count: uint32; 563 | end; 564 | 565 | class var 566 | FHandlerHandle: pointer; 567 | 568 | class function OsExceptionHandler(Info: PEXCEPTION_POINTERS): LONG; stdcall; static; 569 | 570 | class function GetExceptionStackInfo(P: PExceptionRecord): pointer; static; 571 | class procedure CleanupStackInfo(Info: Pointer); static; 572 | class function GetStackInfoString(Info: Pointer): string; static; 573 | 574 | private 575 | type 576 | TOsExceptCtx = record 577 | IP: TAddr; 578 | SP: TAddr; 579 | BP: TAddr; 580 | {$ifndef Win64} 581 | Stack: TFrames; 582 | ValidCtx: boolean; 583 | {$endif} 584 | end; 585 | 586 | public 587 | class procedure Init; static; 588 | class procedure Fini; static; 589 | end; 590 | 591 | threadvar 592 | gOsExceptCtx: TExceptionHelp.TOsExceptCtx; 593 | 594 | 595 | { TExceptionHelp } 596 | 597 | //=================================================================================================================== 598 | // Setup for getting stack traces on Delphi exceptions. 599 | //=================================================================================================================== 600 | class procedure TExceptionHelp.Init; 601 | begin 602 | SysUtils.Exception.GetExceptionStackInfoProc := self.GetExceptionStackInfo; 603 | SysUtils.Exception.CleanupStackInfoProc := self.CleanupStackInfo; 604 | SysUtils.Exception.GetStackInfoStringProc := self.GetStackInfoString; 605 | 606 | // hook into Windows exception handling: 607 | FHandlerHandle := DbgHelp.AddVectoredExceptionHandler(1, OsExceptionHandler); 608 | Assert(FHandlerHandle <> nil); 609 | end; 610 | 611 | 612 | //=================================================================================================================== 613 | // Teardown for getting stack traces on Delphi exceptions. 614 | //=================================================================================================================== 615 | class procedure TExceptionHelp.Fini; 616 | begin 617 | MyAssert(DbgHelp.RemoveVectoredExceptionHandler(FHandlerHandle) <> 0); 618 | 619 | SysUtils.Exception.GetExceptionStackInfoProc := nil; 620 | // Release should remain possible: SysUtils.Exception.CleanupStackInfoProc not cleared 621 | SysUtils.Exception.GetStackInfoStringProc := nil; 622 | end; 623 | 624 | 625 | //=================================================================================================================== 626 | // Is called for every exception in the process and, in the case of Windows-generated exceptions, provides exact 627 | // information about the point at which the exception occurred. 628 | // Is not called again when re-raising an exception. 629 | // The handler should not call functions that acquire synchronization objects or allocate memory, because this can cause problems. 630 | //=================================================================================================================== 631 | class function TExceptionHelp.OsExceptionHandler(Info: PEXCEPTION_POINTERS): LONG; 632 | var 633 | Ctx: ^TOsExceptCtx; 634 | begin 635 | if Info.ExceptionRecord.ExceptionCode <> cDelphiException then begin 636 | Ctx := @gOsExceptCtx; 637 | Ctx.IP := Info.ContextRecord.IP; 638 | Ctx.SP := Info.ContextRecord.SP; 639 | Ctx.BP := Info.ContextRecord.BP; 640 | {$ifndef Win64} 641 | Ctx.ValidCtx := true; 642 | {$endif} 643 | end; 644 | 645 | Result := 0; // EXCEPTION_CONTINUE_SEARCH 646 | end; 647 | 648 | 649 | //=================================================================================================================== 650 | // Hook for Exception.GetExceptionStackInfoProc: Returns a TStack record as the result, which the Delphi RTL then 651 | // stores in the exception. 652 | // Is called by the RTL: 653 | // - For Delphi's own exceptions ("raise" statement): Before calling the Windows exception mechanism and thus 654 | // before OsExceptionHandler. 655 | // - For non-Delphi exception (i.e. Div-by-zero): As a reaction to the Windows exception and thus after OsExceptionHandler. 656 | // - For reraise ("raise" statement without argument): Without OsExceptionHandler being called. 657 | // 658 | // Win32: Reraise of Delphi exceptions: 659 | // The RTL keeps the exception objec created by the original "raise". 660 | // 661 | // Win32: Reraise of non-Delphi exceptions: 662 | // Idiotically, the RTL releases the original execption object and therefore the attached StackInfo (System.pas, 663 | // _RaiseAgain, line 12524), instead of keeping and resuing it! 664 | // The CPU stack and gOsExceptCtx are outdated and therefore unusable at this point => We only can reuse the last 665 | // stackinfo generated for the address, which is not 100% reliable... 666 | // 667 | // Win64: Reraise: The original exception *code* is lost due to _RaiseAgain calling _RaiseAtExcept, which handles 668 | // reraised non-delphi exceptions the same as Delphi exception. But the original exception object is kept and reused, 669 | // so it's stackinfo is still available. 670 | //=================================================================================================================== 671 | {$ifdef Win64} 672 | 673 | class function TExceptionHelp.GetExceptionStackInfo(p: PExceptionRecord): pointer; 674 | var 675 | OsCtx: ^TOsExceptCtx; 676 | Ctx: DbgHelp.CONTEXT; 677 | SkipFrames: uint32; 678 | begin 679 | if p.ExceptionCode = cDelphiException then begin 680 | // p.ExceptObject is only valid for Delphi exceptions (can be non-nil for EAccessViolation without pointing to an Delphi object) 681 | 682 | if TObject(p.ExceptObject) is EAbort then exit(nil); 683 | 684 | // Delphi 10.1 + Win64: Prevent memory leak, as also preserve the StackInfo from the original exception, by not 685 | // overwriting an already existing StackInfo object in the reraised exception object. 686 | if (TObject(P.ExceptObject) is Exception) and (Exception(P.ExceptObject).StackInfo <> nil) then 687 | exit(Exception(P.ExceptObject).StackInfo); 688 | 689 | // initial handling of a Delphi exception: System._RaiseExcept: Creates the Exception object before 690 | // Windows.RaiseException is called => must construct a suitable Context: 691 | Ctx.SetNull; 692 | TStackTraceHlp.DoSetupContext(Ctx); 693 | SkipFrames := 5; 694 | end 695 | else begin 696 | // initial handling of a non-Delphi exception: OsCtx contains the data captured immediately before: 697 | Ctx.SetNull; 698 | Ctx.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER; 699 | OsCtx := @gOsExceptCtx; 700 | Ctx.IP := OsCtx.IP; 701 | Ctx.SP := OsCtx.SP; 702 | Ctx.BP := OsCtx.BP; 703 | SkipFrames := 0; 704 | end; 705 | 706 | System.GetMem(Result, sizeof(TFrames)); 707 | PFrames(Result).Count := TStackTraceHlp.DoGetStackTrace(Ctx, SkipFrames, PFrames(Result).Addrs); 708 | end; 709 | 710 | {$else} 711 | 712 | class function TExceptionHelp.GetExceptionStackInfo(p: PExceptionRecord): pointer; 713 | var 714 | OsCtx: ^TOsExceptCtx; 715 | Ctx: DbgHelp.CONTEXT; 716 | begin 717 | OsCtx := @gOsExceptCtx; 718 | 719 | if p.ExceptionCode = cDelphiException then begin 720 | // p.ExceptObject is only valid for Delphi exceptions (can be non-nil for EAccessViolation without pointing to an Delphi object) 721 | 722 | if TObject(p.ExceptObject) is EAbort then exit(nil); 723 | 724 | // case "raise System.AcquireExceptionObject": Prevent memory leak, as also preserve the StackInfo from the original 725 | // exception, by not overwriting an already existing StackInfo object in the reraised exception object. 726 | if (TObject(P.ExceptObject) is Exception) and (Exception(P.ExceptObject).StackInfo <> nil) then 727 | exit(Exception(P.ExceptObject).StackInfo); 728 | 729 | // initial handling of a Delphi exception: System._RaiseExcept: Creates the Exception object before 730 | // Windows.RaiseException is called => must construct a suitable Context: 731 | Ctx.SetNull; 732 | // System.pas, procedure _RaiseExcept, puts the registers of the exception point as 7 arguments into ExceptionInformation: 733 | Assert(p.NumberParameters = 7); 734 | Ctx.ContextFlags := CONTEXT_CONTROL; 735 | Ctx.IP := TAddr(p.ExceptionAddress); 736 | Ctx.SP := TAddr(p.ExceptionInformation[6]); 737 | Ctx.BP := TAddr(p.ExceptionInformation[5]); 738 | end 739 | else if OsCtx.ValidCtx then begin 740 | // initial handling of a non-Delphi exception: OsCtx contains the data captured immediately before: 741 | Ctx.SetNull; 742 | Ctx.ContextFlags := CONTEXT_CONTROL; 743 | Ctx.IP := OsCtx.IP; 744 | Ctx.SP := OsCtx.SP; 745 | Ctx.BP := OsCtx.BP; 746 | end 747 | else if OsCtx.IP = TAddr(p.ExceptionAddress) then begin 748 | // reraise of a non-Delphi exception: OsCtx does not match the current CPU stack, which no longer covers the original 749 | // point of exception => can only reuse the last stackinfo (hopefully still the right one): 750 | System.GetMem(Result, sizeof(TFrames)); 751 | PFrames(Result)^ := OsCtx.Stack; 752 | exit; 753 | end 754 | else 755 | exit(nil); 756 | 757 | System.GetMem(Result, sizeof(TFrames)); 758 | PFrames(Result).Count := TStackTraceHlp.DoGetStackTrace(Ctx, 0, PFrames(Result).Addrs); 759 | 760 | if p.ExceptionCode <> cDelphiException then begin 761 | // non-Delphi exception: Context is consumed now, save the generated stackinfo for possible reraise: 762 | OsCtx.ValidCtx := false; 763 | OsCtx.Stack := PFrames(Result)^; 764 | end; 765 | end; 766 | {$endif} 767 | 768 | 769 | //=================================================================================================================== 770 | // Hook for Exception.CleanupStackInfoProc: Releases . 771 | //=================================================================================================================== 772 | class procedure TExceptionHelp.CleanupStackInfo(Info: Pointer); 773 | begin 774 | // Bug since Delphi 2009: SysUtils.pas, line 17891, DoneExceptions: 775 | // InvalidPointer.*Free* should be *FreeInstance* (as a few lines before with OutOfMemory.FreeInstance) 776 | // => CleanupStackInfo is also called for the shared "InvalidPointer" object which has no StackInfo 777 | System.FreeMem(Info); 778 | end; 779 | 780 | 781 | //=================================================================================================================== 782 | // Hook for Exception.GetStackInfoStringProc: Generates text from . 783 | //=================================================================================================================== 784 | class function TExceptionHelp.GetStackInfoString(Info: Pointer): string; 785 | begin 786 | if Info = nil then 787 | Result := '' 788 | else 789 | Result := TStackTraceHlp.InterpretStackTrace(PFrames(Info).Addrs, PFrames(Info).Count); 790 | end; 791 | 792 | 793 | initialization 794 | TStackTraceHlp.Init; 795 | TExceptionHelp.Init; 796 | finalization 797 | TExceptionHelp.Fini; 798 | TStackTraceHlp.Fini; 799 | end. 800 | --------------------------------------------------------------------------------