-
Notifications
You must be signed in to change notification settings - Fork 348
/
JclDebug.pas
5283 lines (4787 loc) · 160 KB
/
JclDebug.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{**************************************************************************************************}
{ }
{ Project JEDI Code Library (JCL) }
{ }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
{ License at http://www.mozilla.org/MPL/ }
{ }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
{ and limitations under the License. }
{ }
{ The Original Code is JclDebug.pas. }
{ }
{ The Initial Developers of the Original Code are Petr Vones and Marcel van Brakel. }
{ Portions created by these individuals are Copyright (C) of these individuals. }
{ All Rights Reserved. }
{ }
{ Contributor(s): }
{ Marcel van Brakel }
{ Flier Lu (flier) }
{ Florent Ouchet (outchy) }
{ Robert Marquardt (marquardt) }
{ Robert Rossmair (rrossmair) }
{ Andreas Hausladen (ahuser) }
{ Petr Vones (pvones) }
{ Soeren Muehlbauer }
{ Uwe Schuster (uschuster) }
{ }
{**************************************************************************************************}
{ }
{ Various debugging support routines and classes. This includes: Diagnostics routines, Trace }
{ routines, Stack tracing and Source Locations a la the C/C++ __FILE__ and __LINE__ macros. }
{ }
{**************************************************************************************************}
{ }
{ Last modified: $Date:: $ }
{ Revision: $Rev:: $ }
{ Author: $Author:: $ }
{ }
{**************************************************************************************************}
unit JclDebug;
interface
{$I jcl.inc}
{$R-,Q-}
uses
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
{$ENDIF UNITVERSIONING}
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF MSWINDOWS}
Classes, SysUtils, Contnrs,
JclBase, JclFileUtils, JclPeImage, JclSynch, JclTD32;
// Diagnostics
procedure AssertKindOf(const ClassName: string; const Obj: TObject); overload;
procedure AssertKindOf(const ClassType: TClass; const Obj: TObject); overload;
{$IFDEF KEEP_DEPRECATED}
procedure Trace(const Msg: string);
{$EXTERNALSYM Trace}
{$ENDIF KEEP_DEPRECATED}
procedure TraceMsg(const Msg: string);
procedure TraceFmt(const Fmt: string; const Args: array of const);
procedure TraceLoc(const Msg: string);
procedure TraceLocFmt(const Fmt: string; const Args: array of const);
// Optimized functionality of JclSysInfo functions ModuleFromAddr and IsSystemModule
type
TJclModuleInfo = class(TObject)
private
FSize: Cardinal;
FEndAddr: Pointer;
FStartAddr: Pointer;
FSystemModule: Boolean;
public
property EndAddr: Pointer read FEndAddr;
property Size: Cardinal read FSize;
property StartAddr: Pointer read FStartAddr;
property SystemModule: Boolean read FSystemModule;
end;
TJclModuleInfoList = class(TObjectList)
private
FDynamicBuild: Boolean;
FSystemModulesOnly: Boolean;
function GetItems(Index: Integer): TJclModuleInfo;
function GetModuleFromAddress(Addr: Pointer): TJclModuleInfo;
protected
procedure BuildModulesList;
function CreateItemForAddress(Addr: Pointer; SystemModule: Boolean): TJclModuleInfo;
public
constructor Create(ADynamicBuild, ASystemModulesOnly: Boolean);
function AddModule(Module: HMODULE; SystemModule: Boolean): Boolean;
function IsSystemModuleAddress(Addr: Pointer): Boolean;
function IsValidModuleAddress(Addr: Pointer): Boolean;
property DynamicBuild: Boolean read FDynamicBuild;
property Items[Index: Integer]: TJclModuleInfo read GetItems;
property ModuleFromAddress[Addr: Pointer]: TJclModuleInfo read GetModuleFromAddress;
end;
function JclValidateModuleAddress(Addr: Pointer): Boolean;
// MAP file abstract parser
type
PJclMapAddress = ^TJclMapAddress;
TJclMapAddress = packed record
Segment: Word;
Offset: Integer;
end;
PJclMapString = PAnsiChar;
TJclAbstractMapParser = class(TObject)
private
FLinkerBug: Boolean;
FLinkerBugUnitName: PJclMapString;
FStream: TJclFileMappingStream;
function GetLinkerBugUnitName: string;
protected
FModule: HMODULE;
FLastUnitName: PJclMapString;
FLastUnitFileName: PJclMapString;
procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); virtual; abstract;
procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); virtual; abstract;
procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract;
procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract;
procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); virtual; abstract;
procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); virtual; abstract;
public
constructor Create(const MapFileName: TFileName; Module: HMODULE); overload; virtual;
constructor Create(const MapFileName: TFileName); overload;
destructor Destroy; override;
procedure Parse;
class function MapStringToStr(MapString: PJclMapString; IgnoreSpaces: Boolean = False): string;
class function MapStringToFileName(MapString: PJclMapString): string;
property LinkerBug: Boolean read FLinkerBug;
property LinkerBugUnitName: string read GetLinkerBugUnitName;
property Stream: TJclFileMappingStream read FStream;
end;
// MAP file parser
TJclMapClassTableEvent = procedure(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const SectionName, GroupName: string) of object;
TJclMapSegmentEvent = procedure(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const GroupName, UnitName: string) of object;
TJclMapPublicsEvent = procedure(Sender: TObject; const Address: TJclMapAddress; const Name: string) of object;
TJclMapLineNumberUnitEvent = procedure(Sender: TObject; const UnitName, UnitFileName: string) of object;
TJclMapLineNumbersEvent = procedure(Sender: TObject; LineNumber: Integer; const Address: TJclMapAddress) of object;
TJclMapParser = class(TJclAbstractMapParser)
private
FOnClassTable: TJclMapClassTableEvent;
FOnLineNumbers: TJclMapLineNumbersEvent;
FOnLineNumberUnit: TJclMapLineNumberUnitEvent;
FOnPublicsByValue: TJclMapPublicsEvent;
FOnPublicsByName: TJclMapPublicsEvent;
FOnSegmentItem: TJclMapSegmentEvent;
protected
procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); override;
procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); override;
procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); override;
procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); override;
procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); override;
procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); override;
public
property OnClassTable: TJclMapClassTableEvent read FOnClassTable write FOnClassTable;
property OnSegment: TJclMapSegmentEvent read FOnSegmentItem write FOnSegmentItem;
property OnPublicsByName: TJclMapPublicsEvent read FOnPublicsByName write FOnPublicsByName;
property OnPublicsByValue: TJclMapPublicsEvent read FOnPublicsByValue write FOnPublicsByValue;
property OnLineNumberUnit: TJclMapLineNumberUnitEvent read FOnLineNumberUnit write FOnLineNumberUnit;
property OnLineNumbers: TJclMapLineNumbersEvent read FOnLineNumbers write FOnLineNumbers;
end;
// MAP file scanner
PJclMapSegmentClass = ^TJclMapSegmentClass;
TJclMapSegmentClass = record
Segment: Word;
Addr: DWORD;
VA: DWORD;
Len: DWORD;
SectionName: PJclMapString;
GroupName: PJclMapString;
end;
PJclMapSegment = ^TJclMapSegment;
TJclMapSegment = record
Segment: Word;
StartVA: DWORD; // VA relative to (module base address + $10000)
EndVA: DWORD;
UnitName: PJclMapString;
end;
PJclMapProcName = ^TJclMapProcName;
TJclMapProcName = record
Segment: Word;
VA: DWORD; // VA relative to (module base address + $10000)
ProcName: PJclMapString;
end;
PJclMapLineNumber = ^TJclMapLineNumber;
TJclMapLineNumber = record
Segment: Word;
VA: DWORD; // VA relative to (module base address + $10000)
LineNumber: Integer;
end;
TJclMapScanner = class(TJclAbstractMapParser)
private
FSegmentClasses: array of TJclMapSegmentClass;
FLineNumbers: array of TJclMapLineNumber;
FProcNames: array of TJclMapProcName;
FSegments: array of TJclMapSegment;
FSourceNames: array of TJclMapProcName;
FLineNumbersCnt: Integer;
FLineNumberErrors: Integer;
FNewUnitFileName: PJclMapString;
FProcNamesCnt: Integer;
FSegmentCnt: Integer;
protected
function AddrToVA(const Addr: DWORD): DWORD;
procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); override;
procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); override;
procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); override;
procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); override;
procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); override;
procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); override;
procedure Scan;
public
constructor Create(const MapFileName: TFileName; Module: HMODULE); override;
// Addr are virtual addresses relative to (module base address + $10000)
function LineNumberFromAddr(Addr: DWORD): Integer; overload;
function LineNumberFromAddr(Addr: DWORD; var Offset: Integer): Integer; overload;
function ModuleNameFromAddr(Addr: DWORD): string;
function ModuleStartFromAddr(Addr: DWORD): DWORD;
function ProcNameFromAddr(Addr: DWORD): string; overload;
function ProcNameFromAddr(Addr: DWORD; var Offset: Integer): string; overload;
function SourceNameFromAddr(Addr: DWORD): string;
property LineNumberErrors: Integer read FLineNumberErrors;
end;
type
PJclDbgHeader = ^TJclDbgHeader;
TJclDbgHeader = packed record
Signature: DWORD;
Version: Byte;
Units: Integer;
SourceNames: Integer;
Symbols: Integer;
LineNumbers: Integer;
Words: Integer;
ModuleName: Integer;
CheckSum: Integer;
CheckSumValid: Boolean;
end;
TJclBinDebugGenerator = class(TJclMapScanner)
private
FDataStream: TMemoryStream;
FMapFileName: TFileName;
protected
procedure CreateData;
public
constructor Create(const MapFileName: TFileName; Module: HMODULE); override;
destructor Destroy; override;
function CalculateCheckSum: Boolean;
property DataStream: TMemoryStream read FDataStream;
end;
TJclBinDbgNameCache = record
Addr: DWORD;
FirstWord: Integer;
SecondWord: Integer;
end;
TJclBinDebugScanner = class(TObject)
private
FCacheData: Boolean;
FStream: TCustomMemoryStream;
FValidFormat: Boolean;
FLineNumbers: array of TJclMapLineNumber;
FProcNames: array of TJclBinDbgNameCache;
function GetModuleName: string;
protected
procedure CacheLineNumbers;
procedure CacheProcNames;
procedure CheckFormat;
function DataToStr(A: Integer): string;
function MakePtr(A: Integer): Pointer;
function ReadValue(var P: Pointer; var Value: Integer): Boolean;
public
constructor Create(AStream: TCustomMemoryStream; CacheData: Boolean);
function IsModuleNameValid(const Name: TFileName): Boolean;
function LineNumberFromAddr(Addr: DWORD): Integer; overload;
function LineNumberFromAddr(Addr: DWORD; var Offset: Integer): Integer; overload;
function ProcNameFromAddr(Addr: DWORD): string; overload;
function ProcNameFromAddr(Addr: DWORD; var Offset: Integer): string; overload;
function ModuleNameFromAddr(Addr: DWORD): string;
function ModuleStartFromAddr(Addr: DWORD): DWORD;
function SourceNameFromAddr(Addr: DWORD): string;
property ModuleName: string read GetModuleName;
property ValidFormat: Boolean read FValidFormat;
end;
function ConvertMapFileToJdbgFile(const MapFileName: TFileName): Boolean; overload;
function ConvertMapFileToJdbgFile(const MapFileName: TFileName; var LinkerBugUnit: string;
var LineNumberErrors: Integer): Boolean; overload;
function ConvertMapFileToJdbgFile(const MapFileName: TFileName; var LinkerBugUnit: string;
var LineNumberErrors, MapFileSize, JdbgFileSize: Integer): Boolean; overload;
// do not change this function, it is used by the JVCL installer using dynamic
// linking (to avoid dependencies in the installer), the signature and name are
// sensible
// AnsiString and String types cannot be used because they are managed in
// memory, the memory manager of the JVCL installer is different of the memory
// manager used by the JCL package; only pointers and direct values are acceptable
function InsertDebugDataIntoExecutableFile(ExecutableFileName, MapFileName: PChar;
var MapFileSize, JclDebugDataSize: Integer): Boolean; overload;
function InsertDebugDataIntoExecutableFile(const ExecutableFileName,
MapFileName: TFileName; var LinkerBugUnit: string;
var MapFileSize, JclDebugDataSize: Integer): Boolean; overload;
function InsertDebugDataIntoExecutableFile(const ExecutableFileName,
MapFileName: TFileName; var LinkerBugUnit: string;
var MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean; overload;
function InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;
BinDebug: TJclBinDebugGenerator; var LinkerBugUnit: string;
var MapFileSize, JclDebugDataSize: Integer): Boolean; overload;
function InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;
BinDebug: TJclBinDebugGenerator; var LinkerBugUnit: string;
var MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean; overload;
// Source Locations
type
TJclDebugInfoSource = class;
PJclLocationInfo = ^TJclLocationInfo;
TJclLocationInfo = record
Address: Pointer; // Error address
UnitName: string; // Name of Delphi unit
ProcedureName: string; // Procedure name
OffsetFromProcName: Integer; // Offset from Address to ProcedureName symbol location
LineNumber: Integer; // Line number
OffsetFromLineNumber: Integer; // Offset from Address to LineNumber symbol location
SourceName: string; // Module file name
DebugInfo: TJclDebugInfoSource; // Location object
BinaryFileName: string; // Name of the binary file containing the symbol
end;
TJclDebugInfoSource = class(TObject)
private
FModule: HMODULE;
function GetFileName: TFileName;
protected
function VAFromAddr(const Addr: Pointer): DWORD; virtual;
public
constructor Create(AModule: HMODULE); virtual;
function InitializeSource: Boolean; virtual; abstract;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean; virtual; abstract;
property Module: HMODULE read FModule;
property FileName: TFileName read GetFileName;
end;
TJclDebugInfoSourceClass = class of TJclDebugInfoSource;
TJclDebugInfoList = class(TObjectList)
private
function GetItemFromModule(const Module: HMODULE): TJclDebugInfoSource;
function GetItems(Index: Integer): TJclDebugInfoSource;
protected
function CreateDebugInfo(const Module: HMODULE): TJclDebugInfoSource;
public
class procedure RegisterDebugInfoSource(
const InfoSourceClass: TJclDebugInfoSourceClass);
class procedure UnRegisterDebugInfoSource(
const InfoSourceClass: TJclDebugInfoSourceClass);
class procedure RegisterDebugInfoSourceFirst(
const InfoSourceClass: TJclDebugInfoSourceClass);
class procedure NeedInfoSourceClassList;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean;
property ItemFromModule[const Module: HMODULE]: TJclDebugInfoSource read GetItemFromModule;
property Items[Index: Integer]: TJclDebugInfoSource read GetItems;
end;
// Various source location implementations
TJclDebugInfoMap = class(TJclDebugInfoSource)
private
FScanner: TJclMapScanner;
public
destructor Destroy; override;
function InitializeSource: Boolean; override;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean; override;
end;
TJclDebugInfoBinary = class(TJclDebugInfoSource)
private
FScanner: TJclBinDebugScanner;
FStream: TCustomMemoryStream;
public
destructor Destroy; override;
function InitializeSource: Boolean; override;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean; override;
end;
TJclDebugInfoExports = class(TJclDebugInfoSource)
private
FBorImage: TJclPeBorImage;
function IsAddressInThisExportedFunction(Addr: PByteArray; FunctionStartAddr: DWORD_PTR): Boolean;
public
destructor Destroy; override;
function InitializeSource: Boolean; override;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean; override;
end;
TJclDebugInfoTD32 = class(TJclDebugInfoSource)
private
FImage: TJclPeBorTD32Image;
public
destructor Destroy; override;
function InitializeSource: Boolean; override;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean; override;
end;
TJclDebugInfoSymbols = class(TJclDebugInfoSource)
public
class function LoadDebugFunctions: Boolean;
class function UnloadDebugFunctions: Boolean;
class function InitializeDebugSymbols: Boolean;
class function CleanupDebugSymbols: Boolean;
function InitializeSource: Boolean; override;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean; override;
end;
// Source location functions
function Caller(Level: Integer = 0; FastStackWalk: Boolean = False): Pointer;
function GetLocationInfo(const Addr: Pointer): TJclLocationInfo; overload;
function GetLocationInfo(const Addr: Pointer; var Info: TJclLocationInfo): Boolean; overload;
function GetLocationInfoStr(const Addr: Pointer; IncludeModuleName: Boolean = False;
IncludeAddressOffset: Boolean = False; IncludeStartProcLineOffset: Boolean = False;
IncludeVAdress: Boolean = False): string;
function DebugInfoAvailable(const Module: HMODULE): Boolean;
procedure ClearLocationData;
function FileByLevel(const Level: Integer = 0): string;
function ModuleByLevel(const Level: Integer = 0): string;
function ProcByLevel(const Level: Integer = 0): string;
function LineByLevel(const Level: Integer = 0): Integer;
function MapByLevel(const Level: Integer; var File_, Module_, Proc_: string; var Line_: Integer): Boolean;
function FileOfAddr(const Addr: Pointer): string;
function ModuleOfAddr(const Addr: Pointer): string;
function ProcOfAddr(const Addr: Pointer): string;
function LineOfAddr(const Addr: Pointer): Integer;
function MapOfAddr(const Addr: Pointer; var File_, Module_, Proc_: string; var Line_: Integer): Boolean;
function ExtractClassName(const ProcedureName: string): string;
function ExtractMethodName(const ProcedureName: string): string;
// Original function names, deprecated will be removed in V2.0; do not use!
function __FILE__(const Level: Integer = 0): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __MODULE__(const Level: Integer = 0): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __PROC__(const Level: Integer = 0): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __LINE__(const Level: Integer = 0): Integer; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __MAP__(const Level: Integer; var _File, _Module, _Proc: string; var _Line: Integer): Boolean; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __FILE_OF_ADDR__(const Addr: Pointer): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __MODULE_OF_ADDR__(const Addr: Pointer): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __PROC_OF_ADDR__(const Addr: Pointer): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __LINE_OF_ADDR__(const Addr: Pointer): Integer; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
function __MAP_OF_ADDR__(const Addr: Pointer; var _File, _Module, _Proc: string;
var _Line: Integer): Boolean; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}
// Stack info routines base list
type
TJclStackBaseList = class(TObjectList)
private
FThreadID: DWORD;
FTimeStamp: TDateTime;
protected
FOnDestroy: TNotifyEvent;
public
constructor Create;
destructor Destroy; override;
property ThreadID: DWORD read FThreadID;
property TimeStamp: TDateTime read FTimeStamp;
end;
// Stack info routines
type
PDWORD_PTRArray = ^TDWORD_PTRArray;
TDWORD_PTRArray = array [0..(MaxInt - $F) div SizeOf(DWORD_PTR)] of DWORD_PTR;
PDWORD_PTR = ^DWORD_PTR;
PStackFrame = ^TStackFrame;
TStackFrame = record
CallersEBP: DWORD_PTR;
CallerAdr: DWORD_PTR;
end;
PStackInfo = ^TStackInfo;
TStackInfo = record
CallerAdr: DWORD_PTR;
Level: DWORD;
CallersEBP: DWORD_PTR;
DumpSize: DWORD;
ParamSize: DWORD;
ParamPtr: PDWORD_PTRArray;
case Integer of
0:
(StackFrame: PStackFrame);
1:
(DumpPtr: PJclByteArray);
end;
TJclStackInfoItem = class(TObject)
private
FStackInfo: TStackInfo;
function GetCallerAdr: Pointer;
function GetLogicalAddress: DWORD_PTR;
public
property CallerAdr: Pointer read GetCallerAdr;
property LogicalAddress: DWORD read GetLogicalAddress;
property StackInfo: TStackInfo read FStackInfo;
end;
TJclStackInfoList = class(TJclStackBaseList)
private
FIgnoreLevels: DWORD;
TopOfStack: DWORD_PTR;
BaseOfStack: DWORD_PTR;
FStackData: PPointer;
FFrameEBP: Pointer;
FModuleInfoList: TJclModuleInfoList;
FCorrectOnAccess: Boolean;
FSkipFirstItem: Boolean;
FDelayedTrace: Boolean;
FInStackTracing: Boolean;
FRaw: Boolean;
FStackOffset: DWORD_PTR;
function GetItems(Index: Integer): TJclStackInfoItem;
function NextStackFrame(var StackFrame: PStackFrame; var StackInfo: TStackInfo): Boolean;
procedure StoreToList(const StackInfo: TStackInfo);
procedure TraceStackFrames;
procedure TraceStackRaw;
procedure DelayStoreStack;
function ValidCallSite(CodeAddr: DWORD_PTR; var CallInstructionSize: Cardinal): Boolean;
function ValidStackAddr(StackAddr: DWORD_PTR): Boolean;
function GetCount: Integer;
procedure CorrectOnAccess(ASkipFirstItem: Boolean);
public
constructor Create(ARaw: Boolean; AIgnoreLevels: DWORD;
AFirstCaller: Pointer); overload;
constructor Create(ARaw: Boolean; AIgnoreLevels: DWORD;
AFirstCaller: Pointer; ADelayedTrace: Boolean); overload;
constructor Create(ARaw: Boolean; AIgnoreLevels: DWORD;
AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack: Pointer); overload;
constructor Create(ARaw: Boolean; AIgnoreLevels: DWORD;
AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack, ATopOfStack: Pointer); overload;
destructor Destroy; override;
procedure ForceStackTracing;
procedure AddToStrings(Strings: TStrings; IncludeModuleName: Boolean = False;
IncludeAddressOffset: Boolean = False; IncludeStartProcLineOffset: Boolean = False;
IncludeVAdress: Boolean = False);
property DelayedTrace: Boolean read FDelayedTrace;
property Items[Index: Integer]: TJclStackInfoItem read GetItems; default;
property IgnoreLevels: DWORD read FIgnoreLevels;
property Count: Integer read GetCount;
property Raw: Boolean read FRaw;
end;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer): TJclStackInfoList; overload;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer;
DelayedTrace: Boolean): TJclStackInfoList; overload;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer;
DelayedTrace: Boolean; BaseOfStack: Pointer): TJclStackInfoList; overload;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer;
DelayedTrace: Boolean; BaseOfStack, TopOfStack: Pointer): TJclStackInfoList; overload;
function JclCreateThreadStackTrace(Raw: Boolean; const ThreadHandle: THandle): TJclStackInfoList;
function JclCreateThreadStackTraceFromID(Raw: Boolean; ThreadID: DWORD): TJclStackInfoList;
function JclLastExceptStackList: TJclStackInfoList;
function JclLastExceptStackListToStrings(Strings: TStrings; IncludeModuleName: Boolean = False;
IncludeAddressOffset: Boolean = False; IncludeStartProcLineOffset: Boolean = False;
IncludeVAdress: Boolean = False): Boolean;
function JclGetExceptStackList(ThreadID: DWORD): TJclStackInfoList;
function JclGetExceptStackListToStrings(ThreadID: DWORD; Strings: TStrings;
IncludeModuleName: Boolean = False; IncludeAddressOffset: Boolean = False;
IncludeStartProcLineOffset: Boolean = False; IncludeVAdress: Boolean = False): Boolean;
// Exception frame info routines
type
PJmpInstruction = ^TJmpInstruction;
TJmpInstruction = packed record // from System.pas
OpCode: Byte;
Distance: Longint;
end;
TExcDescEntry = record // from System.pas
VTable: Pointer;
Handler: Pointer;
end;
PExcDesc = ^TExcDesc;
TExcDesc = packed record // from System.pas
JMP: TJmpInstruction;
case Integer of
0:
(Instructions: array [0..0] of Byte);
1:
(Cnt: Integer;
ExcTab: array [0..0] of TExcDescEntry);
end;
PExcFrame = ^TExcFrame;
TExcFrame = record // from System.pas
Next: PExcFrame;
Desc: PExcDesc;
HEBP: Pointer;
case Integer of
0:
();
1:
(ConstructedObject: Pointer);
2:
(SelfOfMethod: Pointer);
end;
PJmpTable = ^TJmpTable;
TJmpTable = packed record
OPCode: Word; // FF 25 = JMP DWORD PTR [$xxxxxxxx], encoded as $25FF
Ptr: Pointer;
end;
TExceptFrameKind =
(efkUnknown, efkFinally, efkAnyException, efkOnException, efkAutoException);
TJclExceptFrame = class(TObject)
private
FExcFrame: PExcFrame;
FFrameKind: TExceptFrameKind;
protected
procedure DoDetermineFrameKind;
public
constructor Create(AExcFrame: PExcFrame);
function Handles(ExceptObj: TObject): Boolean;
function HandlerInfo(ExceptObj: TObject; var HandlerAt: Pointer): Boolean;
function CodeLocation: Pointer;
property ExcFrame: PExcFrame read FExcFrame;
property FrameKind: TExceptFrameKind read FFrameKind;
end;
TJclExceptFrameList = class(TJclStackBaseList)
private
FIgnoreLevels: Integer;
function GetItems(Index: Integer): TJclExceptFrame;
protected
function AddFrame(AFrame: PExcFrame): TJclExceptFrame;
public
constructor Create(AIgnoreLevels: Integer);
procedure TraceExceptionFrames;
property Items[Index: Integer]: TJclExceptFrame read GetItems;
property IgnoreLevels: Integer read FIgnoreLevels write FIgnoreLevels;
end;
function JclCreateExceptFrameList(AIgnoreLevels: Integer): TJclExceptFrameList;
function JclLastExceptFrameList: TJclExceptFrameList;
function JclGetExceptFrameList(ThreadID: DWORD): TJclExceptFrameList;
function JclStartExceptionTracking: Boolean;
function JclStopExceptionTracking: Boolean;
function JclExceptionTrackingActive: Boolean;
function JclTrackExceptionsFromLibraries: Boolean;
// Thread exception tracking support
type
TJclDebugThread = class(TThread)
private
FSyncException: TObject;
FThreadName: string;
procedure DoHandleException;
function GetThreadInfo: string;
protected
procedure DoNotify;
procedure DoSyncHandleException; dynamic;
procedure HandleException(Sender: TObject = nil);
public
constructor Create(Suspended: Boolean; const AThreadName: string = '');
destructor Destroy; override;
property SyncException: TObject read FSyncException;
property ThreadInfo: string read GetThreadInfo;
property ThreadName: string read FThreadName;
end;
TJclDebugThreadNotifyEvent = procedure(Thread: TJclDebugThread) of object;
TJclThreadIDNotifyEvent = procedure(ThreadID: DWORD) of object;
TJclDebugThreadList = class(TObject)
private
FList: TStringList;
FLock: TJclCriticalSection;
FReadLock: TJclCriticalSection;
FRegSyncThreadID: DWORD;
FUnregSyncThreadID: DWORD;
FOnSyncException: TJclDebugThreadNotifyEvent;
FOnThreadRegistered: TJclThreadIDNotifyEvent;
FOnThreadUnregistered: TJclThreadIDNotifyEvent;
function GetThreadClassNames(ThreadID: DWORD): string;
function GetThreadInfos(ThreadID: DWORD): string;
function GetThreadNames(ThreadID: DWORD): string;
procedure DoSyncThreadRegistered;
procedure DoSyncThreadUnregistered;
function GetThreadHandle(Index: Integer): THandle;
function GetThreadID(Index: Integer): DWORD;
function GetThreadIDCount: Integer;
function GetThreadValues(ThreadID: DWORD; Index: Integer): string;
function IndexOfThreadID(ThreadID: DWORD): Integer;
protected
procedure DoSyncException(Thread: TJclDebugThread);
procedure DoThreadRegistered(Thread: TThread);
procedure DoThreadUnregistered(Thread: TThread);
procedure InternalRegisterThread(Thread: TThread; const ThreadName: string);
procedure InternalUnregisterThread(Thread: TThread);
public
constructor Create;
destructor Destroy; override;
procedure RegisterThread(Thread: TThread; const ThreadName: string);
procedure UnregisterThread(Thread: TThread);
property Lock: TJclCriticalSection read FLock;
//property ThreadClassNames[ThreadID: DWORD]: string index 1 read GetThreadValues;
property ThreadClassNames[ThreadID: DWORD]: string read GetThreadClassNames;
property ThreadHandles[Index: Integer]: DWORD read GetThreadHandle;
property ThreadIDs[Index: Integer]: DWORD read GetThreadID;
property ThreadIDCount: Integer read GetThreadIDCount;
//property ThreadInfos[ThreadID: DWORD]: string index 2 read GetThreadValues;
property ThreadInfos[ThreadID: DWORD]: string read GetThreadInfos;
//property ThreadNames[ThreadID: DWORD]: string index 0 read GetThreadValues;
property ThreadNames[ThreadID: DWORD]: string read GetThreadNames;
property OnSyncException: TJclDebugThreadNotifyEvent read FOnSyncException write FOnSyncException;
property OnThreadRegistered: TJclThreadIDNotifyEvent read FOnThreadRegistered write FOnThreadRegistered;
property OnThreadUnregistered: TJclThreadIDNotifyEvent read FOnThreadUnregistered write FOnThreadUnregistered;
end;
function JclDebugThreadList: TJclDebugThreadList;
// Miscellanuous
{$IFDEF MSWINDOWS}
function EnableCrashOnCtrlScroll(const Enable: Boolean): Boolean;
function IsDebuggerAttached: Boolean;
function IsHandleValid(Handle: THandle): Boolean;
{$ENDIF MSWINDOWS}
{$IFDEF SUPPORTS_EXTSYM}
{$EXTERNALSYM __FILE__}
{$EXTERNALSYM __LINE__}
{$ENDIF SUPPORTS_EXTSYM}
const
EnvironmentVarNtSymbolPath = '_NT_SYMBOL_PATH'; // do not localize
EnvironmentVarAlternateNtSymbolPath = '_NT_ALTERNATE_SYMBOL_PATH'; // do not localize
MaxStackTraceItems = 4096;
// JCL binary debug data generator and scanner
const
JclDbgDataSignature = $4742444A; // JDBG
JclDbgDataResName = AnsiString('JCLDEBUG'); // do not localize
JclDbgHeaderVersion = 1; // JCL 1.11 and 1.20
JclDbgFileExtension = '.jdbg'; // do not localize
JclMapFileExtension = '.map'; // do not localize
DrcFileExtension = '.drc'; // do not localize
// Global exceptional stack tracker enable routines and variables
type
TJclStackTrackingOption =
(stStack, stExceptFrame, stRawMode, stAllModules, stStaticModuleList,
stDelayedTrace, stTraceAllExceptions, stMainThreadOnly, stDisableIfDebuggerAttached);
TJclStackTrackingOptions = set of TJclStackTrackingOption;
{$IFDEF KEEP_DEPRECATED}
const
// replaced by RemoveIgnoredException(EAbort)
stTraceEAbort = stTraceAllExceptions;
{$ENDIF KEEP_DEPRECATED}
var
JclStackTrackingOptions: TJclStackTrackingOptions = [stStack];
{ JclDebugInfoSymbolPaths specifies a list of paths, separated by ';', in
which the DebugInfoSymbol scanner should look for symbol information. }
JclDebugInfoSymbolPaths: string = '';
// functions to add/remove exception classes to be ignored if StTraceAllExceptions is not set
procedure AddIgnoredException(const ExceptionClass: TClass);
procedure AddIgnoredExceptionByName(const AExceptionClassName: string);
procedure RemoveIgnoredException(const ExceptionClass: TClass);
procedure RemoveIgnoredExceptionByName(const AExceptionClassName: string);
function IsIgnoredException(const ExceptionClass: TClass): Boolean;
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
RCSfile: '$URL$';
Revision: '$Revision$';
Date: '$Date$';
LogPath: 'JCL\source\windows'
);
{$ENDIF UNITVERSIONING}
implementation
uses
{$IFDEF MSWINDOWS}
JclRegistry,
{$ENDIF MSWINDOWS}
JclHookExcept, JclLogic, JclStrings, JclSysInfo, JclSysUtils, JclWin32,
JclStringConversions, JclResources;
//=== Helper assembler routines ==============================================
const
ModuleCodeOffset = $1000;
{$STACKFRAMES OFF}
function GetEBP: Pointer;
asm
MOV EAX, EBP
end;
function GetESP: Pointer;
asm
MOV EAX, ESP
end;
function GetFS: Pointer;
asm
XOR EAX, EAX
MOV EAX, FS:[EAX]
end;
// Reference: Matt Pietrek, MSJ, Under the hood, on TIBs:
// http://www.microsoft.com/MSJ/archive/S2CE.HTM
function GetStackTop: DWORD_PTR;
asm
// TODO: 64 bit version
MOV EAX, FS:[0].NT_TIB32.StackBase
end;
{$IFDEF STACKFRAMES_ON}
{$STACKFRAMES ON}
{$ENDIF STACKFRAMES_ON}
//=== Diagnostics ===========================================================
procedure AssertKindOf(const ClassName: string; const Obj: TObject);
var
C: TClass;
begin
if not Obj.ClassNameIs(ClassName) then
begin
C := Obj.ClassParent;
while (C <> nil) and (not C.ClassNameIs(ClassName)) do
C := C.ClassParent;
Assert(C <> nil);
end;
end;
procedure AssertKindOf(const ClassType: TClass; const Obj: TObject);
begin
Assert(Obj.InheritsFrom(ClassType));
end;
{$IFDEF KEEP_DEPRECATED}
procedure Trace(const Msg: string);
begin
TraceMsg(Msg);
end;
{$ENDIF KEEP_DEPRECATED}
procedure TraceMsg(const Msg: string);
begin
OutputDebugString(PChar(StrDoubleQuote(Msg)));
end;
procedure TraceFmt(const Fmt: string; const Args: array of const);
begin
OutputDebugString(PChar(Format(StrDoubleQuote(Fmt), Args)));
end;
procedure TraceLoc(const Msg: string);
begin
OutputDebugString(PChar(Format('%s:%u (%s) "%s"',
[FileByLevel(1), LineByLevel(1), ProcByLevel(1), Msg])));
end;
procedure TraceLocFmt(const Fmt: string; const Args: array of const);
var
S: string;
begin
S := Format('%s:%u (%s) ', [FileByLevel(1), LineByLevel(1), ProcByLevel(1)]) +
Format(StrDoubleQuote(Fmt), Args);
OutputDebugString(PChar(S));
end;
//=== { TJclModuleInfoList } =================================================
constructor TJclModuleInfoList.Create(ADynamicBuild, ASystemModulesOnly: Boolean);
begin
inherited Create(True);
FDynamicBuild := ADynamicBuild;
FSystemModulesOnly := ASystemModulesOnly;
if not FDynamicBuild then
BuildModulesList;
end;
function TJclModuleInfoList.AddModule(Module: HMODULE; SystemModule: Boolean): Boolean;
begin
Result := not IsValidModuleAddress(Pointer(Module)) and
(CreateItemForAddress(Pointer(Module), SystemModule) <> nil);
end;
{function SortByStartAddress(Item1, Item2: Pointer): Integer;
begin
Result := INT_PTR(TJclModuleInfo(Item2).StartAddr) - INT_PTR(TJclModuleInfo(Item1).StartAddr);
end;}
procedure TJclModuleInfoList.BuildModulesList;
var
List: TStringList;
I: Integer;
CurModule: PLibModule;
begin
if FSystemModulesOnly then
begin
CurModule := LibModuleList;
while CurModule <> nil do
begin
CreateItemForAddress(Pointer(CurModule.Instance), True);
CurModule := CurModule.Next;
end;
end
else
begin
List := TStringList.Create;
try
LoadedModulesList(List, GetCurrentProcessId, True);
for I := 0 to List.Count - 1 do
CreateItemForAddress(List.Objects[I], False);
finally
List.Free;
end;
end;
//Sort(SortByStartAddress);
end;
function TJclModuleInfoList.CreateItemForAddress(Addr: Pointer; SystemModule: Boolean): TJclModuleInfo;
var
Module: HMODULE;
ModuleSize: DWORD;
begin
Result := nil;
Module := ModuleFromAddr(Addr);
if Module > 0 then
begin
ModuleSize := PeMapImgSize(Pointer(Module));
if ModuleSize <> 0 then
begin
Result := TJclModuleInfo.Create;
Result.FStartAddr := Pointer(Module);
Result.FSize := ModuleSize;
Result.FEndAddr := Pointer(Module + ModuleSize - 1);
if SystemModule then
Result.FSystemModule := True
else
Result.FSystemModule := IsSystemModule(Module);
end;
end;
if Result <> nil then
Add(Result);
end;
function TJclModuleInfoList.GetItems(Index: Integer): TJclModuleInfo;
begin
Result := TJclModuleInfo(Get(Index));
end;
function TJclModuleInfoList.GetModuleFromAddress(Addr: Pointer): TJclModuleInfo;
var
I: Integer;
Item: TJclModuleInfo;