david
13eee3f7f4
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.jcl@20 c37d764d-f447-7644-a108-883140d013fb
6389 lines
200 KiB
ObjectPascal
6389 lines
200 KiB
ObjectPascal
{**************************************************************************************************}
|
|
{ }
|
|
{ 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:: 2009-11-04 13:12:24 +0100 (mer., 04 nov. 2009) $ }
|
|
{ Revision: $Rev:: 3064 $ }
|
|
{ Author: $Author:: outchy $ }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
|
|
unit JclDebug;
|
|
|
|
interface
|
|
|
|
{$I jcl.inc}
|
|
|
|
uses
|
|
{$IFDEF UNITVERSIONING}
|
|
JclUnitVersioning,
|
|
{$ENDIF UNITVERSIONING}
|
|
{$IFDEF MSWINDOWS}
|
|
Windows,
|
|
{$ENDIF MSWINDOWS}
|
|
Classes, SysUtils, Contnrs,
|
|
JclBase, JclFileUtils, JclPeImage,
|
|
{$IFDEF BORLAND}
|
|
JclTD32,
|
|
{$ENDIF BORLAND}
|
|
JclSynch;
|
|
|
|
// 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: TJclAddr;
|
|
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 MapStringToFileName(MapString: PJclMapString): string;
|
|
class function MapStringToModuleName(MapString: PJclMapString): string;
|
|
class function MapStringToStr(MapString: PJclMapString; IgnoreSpaces: Boolean = False): 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; out Offset: Integer): Integer; overload;
|
|
function ModuleNameFromAddr(Addr: DWORD): string;
|
|
function ModuleStartFromAddr(Addr: DWORD): DWORD;
|
|
function ProcNameFromAddr(Addr: DWORD): string; overload;
|
|
function ProcNameFromAddr(Addr: DWORD; out 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; out Offset: Integer): Integer; overload;
|
|
function ProcNameFromAddr(Addr: DWORD): string; overload;
|
|
function ProcNameFromAddr(Addr: DWORD; out 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; out LinkerBugUnit: string;
|
|
out LineNumberErrors: Integer): Boolean; overload;
|
|
function ConvertMapFileToJdbgFile(const MapFileName: TFileName; out LinkerBugUnit: string;
|
|
out LineNumberErrors, MapFileSize, JdbgFileSize: Integer): Boolean; overload;
|
|
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName,
|
|
MapFileName: TFileName; out LinkerBugUnit: string;
|
|
out MapFileSize, JclDebugDataSize: Integer): Boolean; overload;
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName,
|
|
MapFileName: TFileName; out LinkerBugUnit: string;
|
|
out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean; overload;
|
|
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;
|
|
BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;
|
|
out MapFileSize, JclDebugDataSize: Integer): Boolean; overload;
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;
|
|
BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;
|
|
out 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;
|
|
|
|
TJclLocationInfoExValues = set of (lievLocationInfo, lievProcedureStartLocationInfo, lievUnitVersionInfo);
|
|
|
|
TJclCustomLocationInfoList = class;
|
|
|
|
TJclLocationInfoListOptions = set of (liloAutoGetAddressInfo, liloAutoGetLocationInfo, liloAutoGetUnitVersionInfo);
|
|
|
|
TJclLocationInfoEx = class(TPersistent)
|
|
private
|
|
FAddress: Pointer;
|
|
FBinaryFileName: string;
|
|
FDebugInfo: TJclDebugInfoSource;
|
|
FLineNumber: Integer;
|
|
FLineNumberOffsetFromProcedureStart: Integer;
|
|
FModuleName: string;
|
|
FOffsetFromLineNumber: Integer;
|
|
FOffsetFromProcName: Integer;
|
|
FParent: TJclCustomLocationInfoList;
|
|
FProcedureName: string;
|
|
FSourceName: string;
|
|
FSourceUnitName: string;
|
|
FUnitVersionDateTime: TDateTime;
|
|
FUnitVersionExtra: string;
|
|
FUnitVersionLogPath: string;
|
|
FUnitVersionRCSfile: string;
|
|
FUnitVersionRevision: string;
|
|
FVAddress: Pointer;
|
|
FValues: TJclLocationInfoExValues;
|
|
procedure Fill(AOptions: TJclLocationInfoListOptions);
|
|
function GetAsString: string;
|
|
protected
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
public
|
|
constructor Create(AParent: TJclCustomLocationInfoList; Address: Pointer);
|
|
procedure Clear; virtual;
|
|
property Address: Pointer read FAddress write FAddress;
|
|
property AsString: string read GetAsString;
|
|
property BinaryFileName: string read FBinaryFileName write FBinaryFileName;
|
|
property DebugInfo: TJclDebugInfoSource read FDebugInfo write FDebugInfo;
|
|
property LineNumber: Integer read FLineNumber write FLineNumber;
|
|
property LineNumberOffsetFromProcedureStart: Integer read FLineNumberOffsetFromProcedureStart write FLineNumberOffsetFromProcedureStart;
|
|
property ModuleName: string read FModuleName write FModuleName;
|
|
property OffsetFromLineNumber: Integer read FOffsetFromLineNumber write FOffsetFromLineNumber;
|
|
property OffsetFromProcName: Integer read FOffsetFromProcName write FOffsetFromProcName;
|
|
property ProcedureName: string read FProcedureName write FProcedureName;
|
|
property SourceName: string read FSourceName write FSourceName;
|
|
{ this is equal to TJclLocationInfo.UnitName, but has been renamed because
|
|
UnitName is a class function in TObject since Delphi 2009 }
|
|
property SourceUnitName: string read FSourceUnitName write FSourceUnitName;
|
|
property UnitVersionDateTime: TDateTime read FUnitVersionDateTime write FUnitVersionDateTime;
|
|
property UnitVersionExtra: string read FUnitVersionExtra write FUnitVersionExtra;
|
|
property UnitVersionLogPath: string read FUnitVersionLogPath write FUnitVersionLogPath;
|
|
property UnitVersionRCSfile: string read FUnitVersionRCSfile write FUnitVersionRCSfile;
|
|
property UnitVersionRevision: string read FUnitVersionRevision write FUnitVersionRevision;
|
|
property VAddress: Pointer read FVAddress write FVAddress;
|
|
property Values: TJclLocationInfoExValues read FValues write FValues;
|
|
end;
|
|
|
|
TJclLocationInfoClass = class of TJclLocationInfoEx;
|
|
|
|
TJclCustomLocationInfoListClass = class of TJclCustomLocationInfoList;
|
|
|
|
TJclCustomLocationInfoList = class(TPersistent)
|
|
protected
|
|
FItemClass: TJclLocationInfoClass;
|
|
FItems: TObjectList;
|
|
FOptions: TJclLocationInfoListOptions;
|
|
function GetAsString: string;
|
|
function GetCount: Integer;
|
|
function InternalAdd(Addr: Pointer): TJclLocationInfoEx;
|
|
protected
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
public
|
|
constructor Create; virtual;
|
|
destructor Destroy; override;
|
|
procedure AddStackInfoList(AStackInfoList: TObject);
|
|
procedure Clear;
|
|
property AsString: string read GetAsString;
|
|
property Count: Integer read GetCount;
|
|
property Options: TJclLocationInfoListOptions read FOptions write FOptions;
|
|
end;
|
|
|
|
TJclLocationInfoList = class(TJclCustomLocationInfoList)
|
|
private
|
|
function GetItems(AIndex: Integer): TJclLocationInfoEx;
|
|
public
|
|
constructor Create; override;
|
|
function Add(Addr: Pointer): TJclLocationInfoEx;
|
|
property Items[AIndex: Integer]: TJclLocationInfoEx read GetItems; default;
|
|
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; out 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; out 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; out 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; out Info: TJclLocationInfo): Boolean; override;
|
|
end;
|
|
|
|
TJclDebugInfoExports = class(TJclDebugInfoSource)
|
|
private
|
|
{$IFDEF BORLAND}
|
|
FImage: TJclPeBorImage;
|
|
{$ENDIF BORLAND}
|
|
{$IFDEF FPC}
|
|
FImage: TJclPeImage;
|
|
{$ENDIF FPC}
|
|
function IsAddressInThisExportedFunction(Addr: PByteArray; FunctionStartAddr: TJclAddr): Boolean;
|
|
public
|
|
destructor Destroy; override;
|
|
function InitializeSource: Boolean; override;
|
|
function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;
|
|
end;
|
|
|
|
{$IFDEF BORLAND}
|
|
TJclDebugInfoTD32 = class(TJclDebugInfoSource)
|
|
private
|
|
FImage: TJclPeBorTD32Image;
|
|
public
|
|
destructor Destroy; override;
|
|
function InitializeSource: Boolean; override;
|
|
function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;
|
|
end;
|
|
{$ENDIF BORLAND}
|
|
|
|
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; out 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; out Info: TJclLocationInfo): Boolean; overload;
|
|
function GetLocationInfoStr(const Addr: Pointer; IncludeModuleName: Boolean = False;
|
|
IncludeAddressOffset: Boolean = False; IncludeStartProcLineOffset: Boolean = False;
|
|
IncludeVAddress: 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;
|
|
{$IFNDEF FPC}
|
|
PDWORD_PTR = ^DWORD_PTR;
|
|
{$ENDIF ~FPC}
|
|
|
|
PStackFrame = ^TStackFrame;
|
|
TStackFrame = record
|
|
CallerFrame: TJclAddr;
|
|
CallerAddr: TJclAddr;
|
|
end;
|
|
|
|
PStackInfo = ^TStackInfo;
|
|
TStackInfo = record
|
|
CallerAddr: TJclAddr;
|
|
Level: DWORD;
|
|
CallerFrame: TJclAddr;
|
|
DumpSize: DWORD;
|
|
ParamSize: DWORD;
|
|
ParamPtr: PDWORD_PTRArray;
|
|
case Integer of
|
|
0:
|
|
(StackFrame: PStackFrame);
|
|
1:
|
|
(DumpPtr: PJclByteArray);
|
|
end;
|
|
|
|
TJclStackInfoItem = class(TObject)
|
|
private
|
|
FStackInfo: TStackInfo;
|
|
function GetCallerAddr: Pointer;
|
|
function GetLogicalAddress: TJclAddr;
|
|
public
|
|
property CallerAddr: Pointer read GetCallerAddr;
|
|
property LogicalAddress: TJclAddr read GetLogicalAddress;
|
|
property StackInfo: TStackInfo read FStackInfo;
|
|
end;
|
|
|
|
TJclStackInfoList = class(TJclStackBaseList)
|
|
private
|
|
FIgnoreLevels: DWORD;
|
|
TopOfStack: TJclAddr;
|
|
BaseOfStack: TJclAddr;
|
|
FStackData: PPointer;
|
|
FFramePointer: Pointer;
|
|
FModuleInfoList: TJclModuleInfoList;
|
|
FCorrectOnAccess: Boolean;
|
|
FSkipFirstItem: Boolean;
|
|
FDelayedTrace: Boolean;
|
|
FInStackTracing: Boolean;
|
|
FRaw: Boolean;
|
|
FStackOffset: TJclAddr;
|
|
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: TJclAddr; out CallInstructionSize: Cardinal): Boolean;
|
|
function ValidStackAddr(StackAddr: TJclAddr): 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;
|
|
IncludeVAddress: 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;
|
|
IncludeVAddress: Boolean = False): Boolean;
|
|
|
|
function JclGetExceptStackList(ThreadID: DWORD): TJclStackInfoList;
|
|
function JclGetExceptStackListToStrings(ThreadID: DWORD; Strings: TStrings;
|
|
IncludeModuleName: Boolean = False; IncludeAddressOffset: Boolean = False;
|
|
IncludeStartProcLineOffset: Boolean = False; IncludeVAddress: 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;
|
|
FramePointer: 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
|
|
FFrameKind: TExceptFrameKind;
|
|
FFrameLocation: Pointer;
|
|
FCodeLocation: Pointer;
|
|
FExcTab: array of TExcDescEntry;
|
|
protected
|
|
procedure AnalyseExceptFrame(AExcDesc: PExcDesc);
|
|
public
|
|
constructor Create(AFrameLocation: Pointer; AExcDesc: PExcDesc);
|
|
function Handles(ExceptObj: TObject): Boolean;
|
|
function HandlerInfo(ExceptObj: TObject; out HandlerAt: Pointer): Boolean;
|
|
property CodeLocation: Pointer read FCodeLocation;
|
|
property FrameLocation: Pointer read FFrameLocation;
|
|
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(ASuspended: 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: TObjectList;
|
|
FLock: TJclCriticalSection;
|
|
FReadLock: TJclCriticalSection;
|
|
FRegSyncThreadID: DWORD;
|
|
FSaveCreationStack: Boolean;
|
|
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 GetThreadCreationTime(ThreadID: DWORD): TDateTime;
|
|
function GetThreadHandle(Index: Integer): THandle;
|
|
function GetThreadID(Index: Integer): DWORD;
|
|
function GetThreadIDCount: Integer;
|
|
function GetThreadParentID(ThreadID: DWORD): DWORD;
|
|
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; ThreadID: DWORD; const ThreadName: string);
|
|
procedure InternalUnregisterThread(Thread: TThread; ThreadID: DWORD);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function AddStackListToLocationInfoList(ThreadID: DWORD; AList: TJclLocationInfoList): Boolean;
|
|
procedure RegisterThread(Thread: TThread; const ThreadName: string);
|
|
procedure RegisterThreadID(AThreadID: DWORD);
|
|
procedure UnregisterThread(Thread: TThread);
|
|
procedure UnregisterThreadID(AThreadID: DWORD);
|
|
property Lock: TJclCriticalSection read FLock;
|
|
//property ThreadClassNames[ThreadID: DWORD]: string index 1 read GetThreadValues;
|
|
property SaveCreationStack: Boolean read FSaveCreationStack write FSaveCreationStack;
|
|
property ThreadClassNames[ThreadID: DWORD]: string read GetThreadClassNames;
|
|
property ThreadCreationTime[ThreadID: DWORD]: TDateTime read GetThreadCreationTime;
|
|
property ThreadHandles[Index: Integer]: THandle 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 ThreadParentIDs[ThreadID: DWORD]: DWORD read GetThreadParentID;
|
|
property OnSyncException: TJclDebugThreadNotifyEvent read FOnSyncException write FOnSyncException;
|
|
property OnThreadRegistered: TJclThreadIDNotifyEvent read FOnThreadRegistered write FOnThreadRegistered;
|
|
property OnThreadUnregistered: TJclThreadIDNotifyEvent read FOnThreadUnregistered write FOnThreadUnregistered;
|
|
end;
|
|
|
|
TJclDebugThreadInfo = class(TObject)
|
|
private
|
|
FCreationTime: TDateTime;
|
|
FParentThreadID: DWORD;
|
|
FStackList: TJclStackInfoList;
|
|
FThreadClassName: string;
|
|
FThreadID: DWORD;
|
|
FThreadHandle: THandle;
|
|
FThreadName: string;
|
|
public
|
|
constructor Create(AParentThreadID, AThreadID: DWORD; AStack: Boolean);
|
|
destructor Destroy; override;
|
|
property CreationTime: TDateTime read FCreationTime;
|
|
property ParentThreadID: DWORD read FParentThreadID;
|
|
property StackList: TJclStackInfoList read FStackList;
|
|
property ThreadClassName: string read FThreadClassName write FThreadClassName;
|
|
property ThreadID: DWORD read FThreadID;
|
|
property ThreadHandle: THandle read FThreadHandle write FThreadHandle;
|
|
property ThreadName: string read FThreadName write FThreadName;
|
|
end;
|
|
|
|
TJclThreadInfoOptions = set of (tioIsMainThread, tioName, tioCreationTime, tioParentThreadID, tioStack, tioCreationStack);
|
|
|
|
TJclCustomThreadInfo = class(TPersistent)
|
|
protected
|
|
FCreationTime: TDateTime;
|
|
FCreationStack: TJclCustomLocationInfoList;
|
|
FName: string;
|
|
FParentThreadID: DWORD;
|
|
FStack: TJclCustomLocationInfoList;
|
|
FThreadID: DWORD;
|
|
FValues: TJclThreadInfoOptions;
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
function GetStackClass: TJclCustomLocationInfoListClass; virtual;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
property CreationTime: TDateTime read FCreationTime write FCreationTime;
|
|
property Name: string read FName write FName;
|
|
property ParentThreadID: DWORD read FParentThreadID write FParentThreadID;
|
|
property ThreadID: DWORD read FThreadID write FThreadID;
|
|
property Values: TJclThreadInfoOptions read FValues write FValues;
|
|
end;
|
|
|
|
TJclThreadInfo = class(TJclCustomThreadInfo)
|
|
private
|
|
function GetAsString: string;
|
|
procedure InternalFill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions; AExceptThread: Boolean);
|
|
function GetStack(const AIndex: Integer): TJclLocationInfoList;
|
|
protected
|
|
function GetStackClass: TJclCustomLocationInfoListClass; override;
|
|
public
|
|
procedure Fill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions);
|
|
procedure FillFromExceptThread(AGatherOptions: TJclThreadInfoOptions);
|
|
property AsString: string read GetAsString;
|
|
property CreationStack: TJclLocationInfoList index 1 read GetStack;
|
|
property Stack: TJclLocationInfoList index 2 read GetStack;
|
|
end;
|
|
|
|
TJclThreadInfoList = class(TPersistent)
|
|
private
|
|
FGatherOptions: TJclThreadInfoOptions;
|
|
FItems: TObjectList;
|
|
function GetAsString: string;
|
|
function GetCount: Integer;
|
|
function GetItems(AIndex: Integer): TJclThreadInfo;
|
|
procedure InternalGather(AIncludeThreadIDs, AExcludeThreadIDs: array of DWORD);
|
|
protected
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function Add: TJclThreadInfo;
|
|
procedure Clear;
|
|
procedure Gather(AExceptThreadID: DWORD);
|
|
procedure GatherExclude(AThreadIDs: array of DWORD);
|
|
procedure GatherInclude(AThreadIDs: array of DWORD);
|
|
property AsString: string read GetAsString;
|
|
property Count: Integer read GetCount;
|
|
property GatherOptions: TJclThreadInfoOptions read FGatherOptions write FGatherOptions;
|
|
property Items[AIndex: Integer]: TJclThreadInfo read GetItems; default;
|
|
end;
|
|
|
|
function JclDebugThreadList: TJclDebugThreadList;
|
|
|
|
function JclHookThreads: Boolean;
|
|
function JclUnhookThreads: Boolean;
|
|
function JclThreadsHooked: Boolean;
|
|
|
|
// 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: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.1-Build3536/jcl/source/windows/JclDebug.pas $';
|
|
Revision: '$Revision: 3064 $';
|
|
Date: '$Date: 2009-11-04 13:12:24 +0100 (mer., 04 nov. 2009) $';
|
|
LogPath: 'JCL\source\windows';
|
|
Extra: '';
|
|
Data: nil
|
|
);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFDEF MSWINDOWS}
|
|
JclRegistry,
|
|
{$ENDIF MSWINDOWS}
|
|
JclHookExcept, JclStrings, JclSysInfo, JclSysUtils, JclWin32,
|
|
JclStringConversions, JclResources;
|
|
|
|
//=== Helper assembler routines ==============================================
|
|
|
|
const
|
|
ModuleCodeOffset = $1000;
|
|
|
|
{$STACKFRAMES OFF}
|
|
|
|
function GetFramePointer: Pointer;
|
|
asm
|
|
{$IFDEF CPU32}
|
|
MOV EAX, EBP
|
|
{$ENDIF CPU32}
|
|
{$IFDEF CPU64}
|
|
MOV RAX, RBP
|
|
{$ENDIF CPU64}
|
|
end;
|
|
|
|
function GetStackPointer: Pointer;
|
|
asm
|
|
{$IFDEF CPU32}
|
|
MOV EAX, ESP
|
|
{$ENDIF CPU32}
|
|
{$IFDEF CPU64}
|
|
MOV RAX, RSP
|
|
{$ENDIF CPU64}
|
|
end;
|
|
|
|
function GetExceptionPointer: Pointer;
|
|
asm
|
|
{$IFDEF CPU32}
|
|
XOR EAX, EAX
|
|
MOV EAX, FS:[EAX]
|
|
{$ENDIF CPU32}
|
|
{$IFDEF CPU64}
|
|
XOR RAX, RAX
|
|
MOV RAX, FS:[RAX]
|
|
{$ENDIF CPU64}
|
|
end;
|
|
|
|
// Reference: Matt Pietrek, MSJ, Under the hood, on TIBs:
|
|
// http://www.microsoft.com/MSJ/archive/S2CE.HTM
|
|
|
|
function GetStackTop: TJclAddr;
|
|
asm
|
|
{$IFDEF CPU32}
|
|
MOV EAX, FS:[0].NT_TIB32.StackBase
|
|
{$ENDIF CPU32}
|
|
{$IFDEF CPU64}
|
|
MOV RAX, FS:[0].NT_TIB64.StackBase
|
|
{$ENDIF CPU64}
|
|
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;
|
|
begin
|
|
Result := nil;
|
|
for I := 0 to Count - 1 do
|
|
begin
|
|
Item := Items[I];
|
|
if (TJclAddr(Item.StartAddr) <= TJclAddr(Addr)) and (TJclAddr(Item.EndAddr) > TJclAddr(Addr)) then
|
|
begin
|
|
Result := Item;
|
|
Break;
|
|
end;
|
|
end;
|
|
if DynamicBuild and (Result = nil) then
|
|
Result := CreateItemForAddress(Addr, False);
|
|
end;
|
|
|
|
function TJclModuleInfoList.IsSystemModuleAddress(Addr: Pointer): Boolean;
|
|
var
|
|
Item: TJclModuleInfo;
|
|
begin
|
|
Item := ModuleFromAddress[Addr];
|
|
Result := (Item <> nil) and Item.SystemModule;
|
|
end;
|
|
|
|
function TJclModuleInfoList.IsValidModuleAddress(Addr: Pointer): Boolean;
|
|
begin
|
|
Result := ModuleFromAddress[Addr] <> nil;
|
|
end;
|
|
|
|
//=== { TJclAbstractMapParser } ==============================================
|
|
|
|
constructor TJclAbstractMapParser.Create(const MapFileName: TFileName; Module: HMODULE);
|
|
begin
|
|
inherited Create;
|
|
FModule := Module;
|
|
if FileExists(MapFileName) then
|
|
FStream := TJclFileMappingStream.Create(MapFileName, fmOpenRead or fmShareDenyWrite);
|
|
end;
|
|
|
|
constructor TJclAbstractMapParser.Create(const MapFileName: TFileName);
|
|
begin
|
|
Create(MapFileName, 0);
|
|
end;
|
|
|
|
destructor TJclAbstractMapParser.Destroy;
|
|
begin
|
|
FreeAndNil(FStream);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclAbstractMapParser.GetLinkerBugUnitName: string;
|
|
begin
|
|
Result := MapStringToStr(FLinkerBugUnitName);
|
|
end;
|
|
|
|
class function TJclAbstractMapParser.MapStringToFileName(MapString: PJclMapString): string;
|
|
var
|
|
PEnd: PJclMapString;
|
|
begin
|
|
if MapString = nil then
|
|
begin
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
PEnd := MapString;
|
|
while (PEnd^ <> '=') and not CharIsReturn(Char(PEnd^)) do
|
|
Inc(PEnd);
|
|
if (PEnd^ = '=') then
|
|
begin
|
|
while (PEnd >= MapString) and not (PEnd^ = NativeSpace) do
|
|
Dec(PEnd);
|
|
while (PEnd >= MapString) and ((PEnd-1)^ = NativeSpace) do
|
|
Dec(PEnd);
|
|
end;
|
|
SetString(Result, MapString, PEnd - MapString);
|
|
end;
|
|
|
|
class function TJclAbstractMapParser.MapStringToModuleName(MapString: PJclMapString): string;
|
|
var
|
|
PStart, PEnd, PExtension: PJclMapString;
|
|
begin
|
|
if MapString = nil then
|
|
begin
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
PEnd := MapString;
|
|
while (PEnd^ <> '=') and not CharIsReturn(Char(PEnd^)) do
|
|
Inc(PEnd);
|
|
if (PEnd^ = '=') then
|
|
begin
|
|
while (PEnd >= MapString) and not (PEnd^ = NativeSpace) do
|
|
Dec(PEnd);
|
|
while (PEnd >= MapString) and ((PEnd-1)^ = NativeSpace) do
|
|
Dec(PEnd);
|
|
end;
|
|
PExtension := PEnd;
|
|
while (PExtension >= MapString) and (PExtension^ <> '.') and (PExtension^ <> '|') do
|
|
Dec(PExtension);
|
|
if (PExtension^ = '.') then
|
|
PEnd := PExtension;
|
|
PExtension := PEnd;
|
|
while (PExtension >= MapString) and (PExtension^ <> '|') and (PExtension^ <> '\') do
|
|
Dec(PExtension);
|
|
if PExtension >= MapString then
|
|
PStart := PExtension + 1
|
|
else
|
|
PStart := MapString;
|
|
SetString(Result, PStart, PEnd - PStart);
|
|
end;
|
|
|
|
class function TJclAbstractMapParser.MapStringToStr(MapString: PJclMapString;
|
|
IgnoreSpaces: Boolean): string;
|
|
var
|
|
P: PJclMapString;
|
|
begin
|
|
if MapString = nil then
|
|
begin
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
if MapString^ = '(' then
|
|
begin
|
|
Inc(MapString);
|
|
P := MapString;
|
|
while (P^ <> ')') and not CharIsReturn(Char(P^)) do
|
|
Inc(P);
|
|
end
|
|
else
|
|
begin
|
|
P := MapString;
|
|
if IgnoreSpaces then
|
|
while (P^ <> '(') and not CharIsReturn(Char(P^)) do
|
|
Inc(P)
|
|
else
|
|
while (P^ <> '(') and not CharIsWhiteSpace(Char(P^)) do
|
|
Inc(P);
|
|
end;
|
|
SetString(Result, MapString, P - MapString);
|
|
end;
|
|
|
|
procedure TJclAbstractMapParser.Parse;
|
|
const
|
|
TableHeader : array [0..3] of string = ('Start', 'Length', 'Name', 'Class');
|
|
SegmentsHeader : array [0..3] of string = ('Detailed', 'map', 'of', 'segments');
|
|
PublicsByNameHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Name');
|
|
PublicsByValueHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Value');
|
|
LineNumbersPrefix : string = 'Line numbers for';
|
|
var
|
|
CurrPos, EndPos: PJclMapString;
|
|
{$IFNDEF COMPILER9_UP}
|
|
PreviousA,
|
|
{$ENDIF COMPILER9_UP}
|
|
A: TJclMapAddress;
|
|
L: Integer;
|
|
P1, P2: PJclMapString;
|
|
|
|
procedure SkipWhiteSpace;
|
|
begin
|
|
while CharIsWhiteSpace(Char(CurrPos^)) do
|
|
Inc(CurrPos);
|
|
end;
|
|
|
|
procedure SkipEndLine;
|
|
begin
|
|
while not CharIsReturn(Char(CurrPos^)) do
|
|
Inc(CurrPos);
|
|
SkipWhiteSpace;
|
|
end;
|
|
|
|
function Eof: Boolean;
|
|
begin
|
|
Result := (CurrPos >= EndPos);
|
|
end;
|
|
|
|
function IsDecDigit: Boolean;
|
|
begin
|
|
Result := CharIsDigit(Char(CurrPos^));
|
|
end;
|
|
|
|
function ReadTextLine: string;
|
|
var
|
|
P: PJclMapString;
|
|
begin
|
|
P := CurrPos;
|
|
while (CurrPos^ <> NativeNull) and not CharIsReturn(Char(CurrPos^)) do
|
|
Inc(CurrPos);
|
|
SetString(Result, P, CurrPos - P);
|
|
end;
|
|
|
|
|
|
function ReadDecValue: Integer;
|
|
begin
|
|
Result := 0;
|
|
while CharIsDigit(Char(CurrPos^)) do
|
|
begin
|
|
Result := Result * 10 + (Ord(CurrPos^) - Ord('0'));
|
|
Inc(CurrPos);
|
|
end;
|
|
end;
|
|
|
|
function ReadHexValue: Integer;
|
|
var
|
|
C: Char;
|
|
begin
|
|
Result := 0;
|
|
repeat
|
|
C := Char(CurrPos^);
|
|
case C of
|
|
'0'..'9':
|
|
begin
|
|
Result := Result * 16;
|
|
Inc(Result, Ord(C) - Ord('0'));
|
|
end;
|
|
'A'..'F':
|
|
begin
|
|
Result := Result * 16;
|
|
Inc(Result, Ord(C) - Ord('A') + 10);
|
|
end;
|
|
'a'..'f':
|
|
begin
|
|
Result := Result * 16;
|
|
Inc(Result, Ord(C) - Ord('a') + 10);
|
|
end;
|
|
'H', 'h':
|
|
begin
|
|
Inc(CurrPos);
|
|
Break;
|
|
end;
|
|
else
|
|
Break;
|
|
end;
|
|
Inc(CurrPos);
|
|
until False;
|
|
end;
|
|
|
|
function ReadAddress: TJclMapAddress;
|
|
begin
|
|
Result.Segment := ReadHexValue;
|
|
if CurrPos^ = ':' then
|
|
begin
|
|
Inc(CurrPos);
|
|
Result.Offset := ReadHexValue;
|
|
end
|
|
else
|
|
Result.Offset := 0;
|
|
end;
|
|
|
|
function ReadString: PJclMapString;
|
|
begin
|
|
SkipWhiteSpace;
|
|
Result := CurrPos;
|
|
while not CharIsWhiteSpace(Char(CurrPos^)) do
|
|
Inc(CurrPos);
|
|
end;
|
|
|
|
procedure FindParam(Param: AnsiChar);
|
|
begin
|
|
while not ((CurrPos^ = Param) and ((CurrPos + 1)^ = '=')) do
|
|
Inc(CurrPos);
|
|
Inc(CurrPos, 2);
|
|
end;
|
|
|
|
function SyncToHeader(const Header: array of string): Boolean;
|
|
var
|
|
S: string;
|
|
TokenIndex, OldPosition, CurrentPosition: Integer;
|
|
begin
|
|
Result := False;
|
|
while not Eof do
|
|
begin
|
|
S := Trim(ReadTextLine);
|
|
TokenIndex := Low(Header);
|
|
CurrentPosition := 0;
|
|
OldPosition := 0;
|
|
while (TokenIndex <= High(Header)) do
|
|
begin
|
|
CurrentPosition := Pos(Header[TokenIndex],S);
|
|
if (CurrentPosition <= OldPosition) then
|
|
begin
|
|
CurrentPosition := 0;
|
|
Break;
|
|
end;
|
|
OldPosition := CurrentPosition;
|
|
Inc(TokenIndex);
|
|
end;
|
|
Result := CurrentPosition <> 0;
|
|
if Result then
|
|
Break;
|
|
SkipEndLine;
|
|
end;
|
|
if not Eof then
|
|
SkipWhiteSpace;
|
|
end;
|
|
|
|
function SyncToPrefix(const Prefix: string): Boolean;
|
|
var
|
|
I: Integer;
|
|
P: PJclMapString;
|
|
S: string;
|
|
begin
|
|
if Eof then
|
|
begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
SkipWhiteSpace;
|
|
I := Length(Prefix);
|
|
P := CurrPos;
|
|
while not Eof and (P^ <> NativeCarriageReturn) and (P^ <> NativeNull) and (I > 0) do
|
|
begin
|
|
Inc(P);
|
|
Dec(I);
|
|
end;
|
|
SetString(S, CurrPos, Length(Prefix));
|
|
Result := (S = Prefix);
|
|
if Result then
|
|
CurrPos := P;
|
|
SkipWhiteSpace;
|
|
end;
|
|
|
|
begin
|
|
if FStream <> nil then
|
|
begin
|
|
FLinkerBug := False;
|
|
{$IFNDEF COMPILER9_UP}
|
|
PreviousA.Segment := 0;
|
|
PreviousA.Offset := 0;
|
|
{$ENDIF COMPILER9_UP}
|
|
CurrPos := FStream.Memory;
|
|
EndPos := CurrPos + FStream.Size;
|
|
if SyncToHeader(TableHeader) then
|
|
while IsDecDigit do
|
|
begin
|
|
A := ReadAddress;
|
|
SkipWhiteSpace;
|
|
L := ReadHexValue;
|
|
P1 := ReadString;
|
|
P2 := ReadString;
|
|
SkipEndLine;
|
|
ClassTableItem(A, L, P1, P2);
|
|
end;
|
|
if SyncToHeader(SegmentsHeader) then
|
|
while IsDecDigit do
|
|
begin
|
|
A := ReadAddress;
|
|
SkipWhiteSpace;
|
|
L := ReadHexValue;
|
|
FindParam('C');
|
|
P1 := ReadString;
|
|
FindParam('M');
|
|
P2 := ReadString;
|
|
SkipEndLine;
|
|
SegmentItem(A, L, P1, P2);
|
|
end;
|
|
if SyncToHeader(PublicsByNameHeader) then
|
|
while IsDecDigit do
|
|
begin
|
|
A := ReadAddress;
|
|
P1 := ReadString;
|
|
SkipEndLine; // compatibility with C++Builder MAP files
|
|
PublicsByNameItem(A, P1);
|
|
end;
|
|
if SyncToHeader(PublicsByValueHeader) then
|
|
while IsDecDigit do
|
|
begin
|
|
A := ReadAddress;
|
|
P1 := ReadString;
|
|
SkipEndLine; // compatibility with C++Builder MAP files
|
|
PublicsByValueItem(A, P1);
|
|
end;
|
|
while SyncToPrefix(LineNumbersPrefix) do
|
|
begin
|
|
FLastUnitName := CurrPos;
|
|
FLastUnitFileName := CurrPos;
|
|
while FLastUnitFileName^ <> '(' do
|
|
Inc(FLastUnitFileName);
|
|
SkipEndLine;
|
|
LineNumberUnitItem(FLastUnitName, FLastUnitFileName);
|
|
repeat
|
|
SkipWhiteSpace;
|
|
L := ReadDecValue;
|
|
SkipWhiteSpace;
|
|
A := ReadAddress;
|
|
SkipWhiteSpace;
|
|
LineNumbersItem(L, A);
|
|
{$IFNDEF COMPILER9_UP}
|
|
if (not FLinkerBug) and (A.Offset < PreviousA.Offset) then
|
|
begin
|
|
FLinkerBugUnitName := FLastUnitName;
|
|
FLinkerBug := True;
|
|
end;
|
|
PreviousA := A;
|
|
{$ENDIF COMPILER9_UP}
|
|
until not IsDecDigit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclMapParser 0 ======================================================
|
|
|
|
procedure TJclMapParser.ClassTableItem(const Address: TJclMapAddress;
|
|
Len: Integer; SectionName, GroupName: PJclMapString);
|
|
begin
|
|
if Assigned(FOnClassTable) then
|
|
FOnClassTable(Self, Address, Len, MapStringToStr(SectionName), MapStringToStr(GroupName));
|
|
end;
|
|
|
|
procedure TJclMapParser.LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress);
|
|
begin
|
|
if Assigned(FOnLineNumbers) then
|
|
FOnLineNumbers(Self, LineNumber, Address);
|
|
end;
|
|
|
|
procedure TJclMapParser.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString);
|
|
begin
|
|
if Assigned(FOnLineNumberUnit) then
|
|
FOnLineNumberUnit(Self, MapStringToStr(UnitName), MapStringToStr(UnitFileName));
|
|
end;
|
|
|
|
procedure TJclMapParser.PublicsByNameItem(const Address: TJclMapAddress;
|
|
Name: PJclMapString);
|
|
begin
|
|
if Assigned(FOnPublicsByName) then
|
|
// MAP files generated by C++Builder have spaces in their identifier names
|
|
FOnPublicsByName(Self, Address, MapStringToStr(Name, True));
|
|
end;
|
|
|
|
procedure TJclMapParser.PublicsByValueItem(const Address: TJclMapAddress;
|
|
Name: PJclMapString);
|
|
begin
|
|
if Assigned(FOnPublicsByValue) then
|
|
// MAP files generated by C++Builder have spaces in their identifier names
|
|
FOnPublicsByValue(Self, Address, MapStringToStr(Name, True));
|
|
end;
|
|
|
|
procedure TJclMapParser.SegmentItem(const Address: TJclMapAddress;
|
|
Len: Integer; GroupName, UnitName: PJclMapString);
|
|
begin
|
|
if Assigned(FOnSegmentItem) then
|
|
FOnSegmentItem(Self, Address, Len, MapStringToStr(GroupName), MapStringToModuleName(UnitName));
|
|
end;
|
|
|
|
//=== { TJclMapScanner } =====================================================
|
|
|
|
constructor TJclMapScanner.Create(const MapFileName: TFileName; Module: HMODULE);
|
|
begin
|
|
inherited Create(MapFileName, Module);
|
|
Scan;
|
|
end;
|
|
|
|
function TJclMapScanner.AddrToVA(const Addr: DWORD): DWORD;
|
|
begin
|
|
// MAP file format was changed in Delphi 2005
|
|
// before Delphi 2005: segments started at offset 0
|
|
// only one segment of code
|
|
// after Delphi 2005: segments started at code base address (module base address + $10000)
|
|
// 2 segments of code
|
|
if (Length(FSegmentClasses) > 0) and (FSegmentClasses[0].Addr > 0) and (Addr > 0) then
|
|
// Delphi 2005 and later
|
|
// The first segment should be code starting at module base address + $10000
|
|
Result := Addr - FSegmentClasses[0].Addr
|
|
else
|
|
// before Delphi 2005
|
|
Result := Addr;
|
|
end;
|
|
|
|
procedure TJclMapScanner.ClassTableItem(const Address: TJclMapAddress; Len: Integer;
|
|
SectionName, GroupName: PJclMapString);
|
|
var
|
|
C: Integer;
|
|
SectionHeader: PImageSectionHeader;
|
|
begin
|
|
C := Length(FSegmentClasses);
|
|
SetLength(FSegmentClasses, C + 1);
|
|
FSegmentClasses[C].Segment := Address.Segment;
|
|
FSegmentClasses[C].Addr := Address.Offset;
|
|
FSegmentClasses[C].VA := AddrToVA(Address.Offset);
|
|
FSegmentClasses[C].Len := Len;
|
|
FSegmentClasses[C].SectionName := SectionName;
|
|
FSegmentClasses[C].GroupName := GroupName;
|
|
|
|
if FModule <> 0 then
|
|
begin
|
|
{ Fix the section addresses }
|
|
SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(SectionName));
|
|
if SectionHeader = nil then
|
|
{ before Delphi 2005 the class names where used for the section names }
|
|
SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(GroupName));
|
|
|
|
if SectionHeader <> nil then
|
|
begin
|
|
FSegmentClasses[C].Addr := TJclAddr(FModule) + SectionHeader.VirtualAddress;
|
|
FSegmentClasses[C].VA := SectionHeader.VirtualAddress;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclMapScanner.LineNumberFromAddr(Addr: DWORD): Integer;
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
Result := LineNumberFromAddr(Addr, Dummy);
|
|
end;
|
|
|
|
function Search_MapLineNumber(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := Integer(PJclMapLineNumber(Item1)^.VA) - PInteger(Item2)^;
|
|
end;
|
|
|
|
function TJclMapScanner.LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer;
|
|
var
|
|
I: Integer;
|
|
ModuleStartAddr: DWORD;
|
|
begin
|
|
ModuleStartAddr := ModuleStartFromAddr(Addr);
|
|
Result := 0;
|
|
Offset := 0;
|
|
I := SearchDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Search_MapLineNumber, @Addr, True);
|
|
if (I <> -1) and (FLineNumbers[I].VA >= ModuleStartAddr) then
|
|
begin
|
|
Result := FLineNumbers[I].LineNumber;
|
|
Offset := Addr - FLineNumbers[I].VA;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclMapScanner.LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress);
|
|
var
|
|
SegIndex, C: Integer;
|
|
VA: DWORD;
|
|
Added: Boolean;
|
|
begin
|
|
Added := False;
|
|
for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do
|
|
if (FSegmentClasses[SegIndex].Segment = Address.Segment)
|
|
and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then
|
|
begin
|
|
VA := AddrToVA(Address.Offset + FSegmentClasses[SegIndex].Addr);
|
|
{ Starting with Delphi 2005, "empty" units are listes with the last line and
|
|
the VA 0001:00000000. When we would accept 0 VAs here, System.pas functions
|
|
could be mapped to other units and line numbers. Discaring such items should
|
|
have no impact on the correct information, because there can't be a function
|
|
that starts at VA 0. }
|
|
if VA = 0 then
|
|
Continue;
|
|
if FLineNumbersCnt mod 256 = 0 then
|
|
SetLength(FLineNumbers, FLineNumbersCnt + 256);
|
|
FLineNumbers[FLineNumbersCnt].Segment := FSegmentClasses[SegIndex].Segment;
|
|
FLineNumbers[FLineNumbersCnt].VA := VA;
|
|
FLineNumbers[FLineNumbersCnt].LineNumber := LineNumber;
|
|
Inc(FLineNumbersCnt);
|
|
Added := True;
|
|
if FNewUnitFileName <> nil then
|
|
begin
|
|
C := Length(FSourceNames);
|
|
SetLength(FSourceNames, C + 1);
|
|
FSourceNames[C].Segment := FSegmentClasses[SegIndex].Segment;
|
|
FSourceNames[C].VA := VA;
|
|
FSourceNames[C].ProcName := FNewUnitFileName;
|
|
FNewUnitFileName := nil;
|
|
end;
|
|
Break;
|
|
end;
|
|
if not Added then
|
|
Inc(FLineNumberErrors);
|
|
end;
|
|
|
|
procedure TJclMapScanner.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString);
|
|
begin
|
|
FNewUnitFileName := UnitFileName;
|
|
end;
|
|
|
|
function TJclMapScanner.ModuleNameFromAddr(Addr: DWORD): string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := '';
|
|
for I := Length(FSegments) - 1 downto 0 do
|
|
if (FSegments[I].StartVA <= Addr) and (Addr < FSegments[I].EndVA) then
|
|
begin
|
|
Result := MapStringToModuleName(FSegments[I].UnitName);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function TJclMapScanner.ModuleStartFromAddr(Addr: DWORD): DWORD;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := DWORD(-1);
|
|
for I := Length(FSegments) - 1 downto 0 do
|
|
if (FSegments[I].StartVA <= Addr) and (Addr < FSegments[I].EndVA) then
|
|
begin
|
|
Result := FSegments[I].StartVA;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function TJclMapScanner.ProcNameFromAddr(Addr: DWORD): string;
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
Result := ProcNameFromAddr(Addr, Dummy);
|
|
end;
|
|
|
|
function Search_MapProcName(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := Integer(PJclMapProcName(Item1)^.VA) - PInteger(Item2)^;
|
|
end;
|
|
|
|
function TJclMapScanner.ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string;
|
|
var
|
|
I: Integer;
|
|
ModuleStartAddr: DWORD;
|
|
begin
|
|
ModuleStartAddr := ModuleStartFromAddr(Addr);
|
|
Result := '';
|
|
Offset := 0;
|
|
I := SearchDynArray(FProcNames, SizeOf(FProcNames[0]), Search_MapProcName, @Addr, True);
|
|
if (I <> -1) and (FProcNames[I].VA >= ModuleStartAddr) then
|
|
begin
|
|
Result := MapStringToStr(FProcNames[I].ProcName, True);
|
|
Offset := Addr - FProcNames[I].VA;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclMapScanner.PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString);
|
|
begin
|
|
{ TODO : What to do? }
|
|
end;
|
|
|
|
procedure TJclMapScanner.PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString);
|
|
var
|
|
SegIndex: Integer;
|
|
begin
|
|
for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do
|
|
if (FSegmentClasses[SegIndex].Segment = Address.Segment)
|
|
and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then
|
|
begin
|
|
if FProcNamesCnt mod 256 = 0 then
|
|
SetLength(FProcNames, FProcNamesCnt + 256);
|
|
FProcNames[FProcNamesCnt].Segment := FSegmentClasses[SegIndex].Segment;
|
|
FProcNames[FProcNamesCnt].VA := AddrToVA(Address.Offset + FSegmentClasses[SegIndex].Addr);
|
|
FProcNames[FProcNamesCnt].ProcName := Name;
|
|
Inc(FProcNamesCnt);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function Sort_MapLineNumber(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := Integer(PJclMapLineNumber(Item1)^.VA) - Integer(PJclMapLineNumber(Item2)^.VA);
|
|
end;
|
|
|
|
function Sort_MapProcName(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := Integer(PJclMapProcName(Item1)^.VA) - Integer(PJclMapProcName(Item2)^.VA);
|
|
end;
|
|
|
|
function Sort_MapSegment(Item1, Item2: Pointer): Integer;
|
|
begin
|
|
Result := Integer(PJclMapSegment(Item1)^.StartVA) - Integer(PJclMapSegment(Item2)^.StartVA);
|
|
end;
|
|
|
|
procedure TJclMapScanner.Scan;
|
|
begin
|
|
FLineNumberErrors := 0;
|
|
FSegmentCnt := 0;
|
|
FProcNamesCnt := 0;
|
|
Parse;
|
|
SetLength(FLineNumbers, FLineNumbersCnt);
|
|
SetLength(FProcNames, FProcNamesCnt);
|
|
SetLength(FSegments, FSegmentCnt);
|
|
SortDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Sort_MapLineNumber);
|
|
SortDynArray(FProcNames, SizeOf(FProcNames[0]), Sort_MapProcName);
|
|
SortDynArray(FSegments, SizeOf(FSegments[0]), Sort_MapSegment);
|
|
SortDynArray(FSourceNames, SizeOf(FSourceNames[0]), Sort_MapProcName);
|
|
end;
|
|
|
|
procedure TJclMapScanner.SegmentItem(const Address: TJclMapAddress; Len: Integer;
|
|
GroupName, UnitName: PJclMapString);
|
|
var
|
|
SegIndex: Integer;
|
|
VA: DWORD;
|
|
begin
|
|
for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do
|
|
if (FSegmentClasses[SegIndex].Segment = Address.Segment)
|
|
and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then
|
|
begin
|
|
VA := AddrToVA(Address.Offset + FSegmentClasses[SegIndex].Addr);
|
|
if FSegmentCnt mod 16 = 0 then
|
|
SetLength(FSegments, FSegmentCnt + 16);
|
|
FSegments[FSegmentCnt].Segment := FSegmentClasses[SegIndex].Segment;
|
|
FSegments[FSegmentCnt].StartVA := VA;
|
|
FSegments[FSegmentCnt].EndVA := VA + DWORD(Len);
|
|
FSegments[FSegmentCnt].UnitName := UnitName;
|
|
Inc(FSegmentCnt);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
function TJclMapScanner.SourceNameFromAddr(Addr: DWORD): string;
|
|
var
|
|
I: Integer;
|
|
ModuleStartVA: DWORD;
|
|
begin
|
|
// try with line numbers first (Delphi compliance)
|
|
ModuleStartVA := ModuleStartFromAddr(Addr);
|
|
Result := '';
|
|
I := SearchDynArray(FSourceNames, SizeOf(FSourceNames[0]), Search_MapProcName, @Addr, True);
|
|
if (I <> -1) and (FSourceNames[I].VA >= ModuleStartVA) then
|
|
Result := MapStringToStr(FSourceNames[I].ProcName);
|
|
if Result = '' then
|
|
begin
|
|
// try with module names (C++Builder compliance)
|
|
for I := Length(FSegments) - 1 downto 0 do
|
|
if (FSegments[I].StartVA <= Addr) and (Addr < FSegments[I].EndVA) then
|
|
begin
|
|
Result := MapStringToFileName(FSegments[I].UnitName);
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// JCL binary debug format string encoding/decoding routines
|
|
{ Strings are compressed to following 6bit format (A..D represents characters) and terminated with }
|
|
{ 6bit #0 char. First char = #1 indicates non compressed text, #2 indicates compressed text with }
|
|
{ leading '@' character }
|
|
{ }
|
|
{ 7 6 5 4 3 2 1 0 | }
|
|
{--------------------------------- }
|
|
{ B1 B0 A5 A4 A3 A2 A1 A0 | Data byte 0 }
|
|
{--------------------------------- }
|
|
{ C3 C2 C1 C0 B5 B4 B3 B2 | Data byte 1 }
|
|
{--------------------------------- }
|
|
{ D5 D4 D3 D2 D1 D0 C5 C4 | Data byte 2 }
|
|
{--------------------------------- }
|
|
|
|
function SimpleCryptString(const S: TUTF8String): TUTF8String;
|
|
var
|
|
I: Integer;
|
|
C: Byte;
|
|
P: PByte;
|
|
begin
|
|
SetLength(Result, Length(S));
|
|
P := PByte(Result);
|
|
for I := 1 to Length(S) do
|
|
begin
|
|
C := Ord(S[I]);
|
|
if C <> $AA then
|
|
C := C xor $AA;
|
|
P^ := C;
|
|
Inc(P);
|
|
end;
|
|
end;
|
|
|
|
function DecodeNameString(const S: PAnsiChar): string;
|
|
var
|
|
I, B: Integer;
|
|
C: Byte;
|
|
P: PByte;
|
|
Buffer: array [0..255] of AnsiChar;
|
|
begin
|
|
Result := '';
|
|
B := 0;
|
|
P := PByte(S);
|
|
case P^ of
|
|
1:
|
|
begin
|
|
Inc(P);
|
|
Result := UTF8ToString(SimpleCryptString(PAnsiChar(P)));
|
|
Exit;
|
|
end;
|
|
2:
|
|
begin
|
|
Inc(P);
|
|
Buffer[B] := '@';
|
|
Inc(B);
|
|
end;
|
|
end;
|
|
I := 0;
|
|
C := 0;
|
|
repeat
|
|
case I and $03 of
|
|
0:
|
|
C := P^ and $3F;
|
|
1:
|
|
begin
|
|
C := (P^ shr 6) and $03;
|
|
Inc(P);
|
|
Inc(C, (P^ and $0F) shl 2);
|
|
end;
|
|
2:
|
|
begin
|
|
C := (P^ shr 4) and $0F;
|
|
Inc(P);
|
|
Inc(C, (P^ and $03) shl 4);
|
|
end;
|
|
3:
|
|
begin
|
|
C := (P^ shr 2) and $3F;
|
|
Inc(P);
|
|
end;
|
|
end;
|
|
case C of
|
|
$00:
|
|
Break;
|
|
$01..$0A:
|
|
Inc(C, Ord('0') - $01);
|
|
$0B..$24:
|
|
Inc(C, Ord('A') - $0B);
|
|
$25..$3E:
|
|
Inc(C, Ord('a') - $25);
|
|
$3F:
|
|
C := Ord('_');
|
|
end;
|
|
Buffer[B] := AnsiChar(C);
|
|
Inc(B);
|
|
Inc(I);
|
|
until B >= SizeOf(Buffer) - 1;
|
|
Buffer[B] := NativeNull;
|
|
Result := UTF8ToString(Buffer);
|
|
end;
|
|
|
|
function EncodeNameString(const S: string): AnsiString;
|
|
var
|
|
I, StartIndex: Integer;
|
|
C: Byte;
|
|
P: PByte;
|
|
begin
|
|
if (Length(S) > 1) and (S[1] = '@') then
|
|
StartIndex := 1
|
|
else
|
|
StartIndex := 0;
|
|
for I := StartIndex + 1 to Length(S) do
|
|
if not CharIsValidIdentifierLetter(Char(S[I])) then
|
|
begin
|
|
Result := #1 + SimpleCryptString(StringToUTF8(S)) + #0;
|
|
Exit;
|
|
end;
|
|
SetLength(Result, Length(S) + StartIndex);
|
|
P := Pointer(Result);
|
|
if StartIndex = 1 then
|
|
P^ := 2 // store '@' leading char information
|
|
else
|
|
Dec(P);
|
|
for I := 0 to Length(S) - StartIndex do // including null char
|
|
begin
|
|
C := Byte(S[I + 1 + StartIndex]);
|
|
case AnsiChar(C) of
|
|
#0:
|
|
C := 0;
|
|
'0'..'9':
|
|
Dec(C, Ord('0') - $01);
|
|
'A'..'Z':
|
|
Dec(C, Ord('A') - $0B);
|
|
'a'..'z':
|
|
Dec(C, Ord('a') - $25);
|
|
'_':
|
|
C := $3F;
|
|
else
|
|
C := $3F;
|
|
end;
|
|
case I and $03 of
|
|
0:
|
|
begin
|
|
Inc(P);
|
|
P^ := C;
|
|
end;
|
|
1:
|
|
begin
|
|
P^ := P^ or (C and $03) shl 6;
|
|
Inc(P);
|
|
P^ := (C shr 2) and $0F;
|
|
end;
|
|
2:
|
|
begin
|
|
P^ := P^ or (C shl 4);
|
|
Inc(P);
|
|
P^ := (C shr 4) and $03;
|
|
end;
|
|
3:
|
|
P^ := P^ or (C shl 2);
|
|
end;
|
|
end;
|
|
SetLength(Result, TJclAddr(P) - TJclAddr(Pointer(Result)) + 1);
|
|
end;
|
|
|
|
function ConvertMapFileToJdbgFile(const MapFileName: TFileName): Boolean;
|
|
var
|
|
Dummy1: string;
|
|
Dummy2, Dummy3, Dummy4: Integer;
|
|
begin
|
|
Result := ConvertMapFileToJdbgFile(MapFileName, Dummy1, Dummy2, Dummy3, Dummy4);
|
|
end;
|
|
|
|
function ConvertMapFileToJdbgFile(const MapFileName: TFileName; out LinkerBugUnit: string;
|
|
out LineNumberErrors: Integer): Boolean;
|
|
var
|
|
Dummy1, Dummy2: Integer;
|
|
begin
|
|
Result := ConvertMapFileToJdbgFile(MapFileName, LinkerBugUnit, LineNumberErrors,
|
|
Dummy1, Dummy2);
|
|
end;
|
|
|
|
function ConvertMapFileToJdbgFile(const MapFileName: TFileName; out LinkerBugUnit: string;
|
|
out LineNumberErrors, MapFileSize, JdbgFileSize: Integer): Boolean;
|
|
var
|
|
JDbgFileName: TFileName;
|
|
Generator: TJclBinDebugGenerator;
|
|
begin
|
|
JDbgFileName := ChangeFileExt(MapFileName, JclDbgFileExtension);
|
|
Generator := TJclBinDebugGenerator.Create(MapFileName, 0);
|
|
try
|
|
MapFileSize := Generator.Stream.Size;
|
|
JdbgFileSize := Generator.DataStream.Size;
|
|
Result := (Generator.DataStream.Size > 0) and Generator.CalculateCheckSum;
|
|
if Result then
|
|
Generator.DataStream.SaveToFile(JDbgFileName);
|
|
LinkerBugUnit := Generator.LinkerBugUnitName;
|
|
LineNumberErrors := Generator.LineNumberErrors;
|
|
finally
|
|
Generator.Free;
|
|
end;
|
|
end;
|
|
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName, MapFileName: TFileName;
|
|
out LinkerBugUnit: string; out MapFileSize, JclDebugDataSize: Integer): Boolean;
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
Result := InsertDebugDataIntoExecutableFile(ExecutableFileName, MapFileName, LinkerBugUnit,
|
|
MapFileSize, JclDebugDataSize, Dummy);
|
|
end;
|
|
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName, MapFileName: TFileName;
|
|
out LinkerBugUnit: string; out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean;
|
|
var
|
|
BinDebug: TJclBinDebugGenerator;
|
|
begin
|
|
BinDebug := TJclBinDebugGenerator.Create(MapFileName, 0);
|
|
try
|
|
Result := InsertDebugDataIntoExecutableFile(ExecutableFileName, BinDebug,
|
|
LinkerBugUnit, MapFileSize, JclDebugDataSize, LineNumberErrors);
|
|
finally
|
|
BinDebug.Free;
|
|
end;
|
|
end;
|
|
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;
|
|
BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;
|
|
out MapFileSize, JclDebugDataSize: Integer): Boolean;
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
Result := InsertDebugDataIntoExecutableFile(ExecutableFileName, BinDebug, LinkerBugUnit,
|
|
MapFileSize, JclDebugDataSize, Dummy);
|
|
end;
|
|
|
|
// TODO 64 bit version
|
|
function InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;
|
|
BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;
|
|
out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean;
|
|
var
|
|
ImageStream: TMemoryStream;
|
|
NtHeaders32: PImageNtHeaders32;
|
|
Sections, LastSection, JclDebugSection: PImageSectionHeader;
|
|
VirtualAlignedSize: DWORD;
|
|
I, X, NeedFill: Integer;
|
|
|
|
procedure RoundUpToAlignment(var Value: DWORD; Alignment: DWORD);
|
|
begin
|
|
if (Value mod Alignment) <> 0 then
|
|
Value := ((Value div Alignment) + 1) * Alignment;
|
|
end;
|
|
|
|
begin
|
|
MapFileSize := 0;
|
|
JclDebugDataSize := 0;
|
|
LineNumberErrors := 0;
|
|
LinkerBugUnit := '';
|
|
if BinDebug.Stream <> nil then
|
|
begin
|
|
Result := True;
|
|
if BinDebug.LinkerBug then
|
|
begin
|
|
LinkerBugUnit := BinDebug.LinkerBugUnitName;
|
|
LineNumberErrors := BinDebug.LineNumberErrors;
|
|
end;
|
|
end
|
|
else
|
|
Result := False;
|
|
if not Result then
|
|
Exit;
|
|
|
|
ImageStream := TMemoryStream.Create;
|
|
try
|
|
try
|
|
ImageStream.LoadFromFile(ExecutableFileName);
|
|
if PeMapImgTarget(ImageStream.Memory) = taWin32 then
|
|
begin
|
|
MapFileSize := BinDebug.Stream.Size;
|
|
JclDebugDataSize := BinDebug.DataStream.Size;
|
|
NtHeaders32 := PeMapImgNtHeaders32(ImageStream.Memory);
|
|
Assert(NtHeaders32 <> nil);
|
|
Sections := PeMapImgSections32(NtHeaders32);
|
|
Assert(Sections <> nil);
|
|
// Check whether there is not a section with the name already. If so, return True (#0000069)
|
|
if PeMapImgFindSection32(NtHeaders32, JclDbgDataResName) <> nil then
|
|
begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
|
|
LastSection := Sections;
|
|
Inc(LastSection, NtHeaders32^.FileHeader.NumberOfSections - 1);
|
|
JclDebugSection := LastSection;
|
|
Inc(JclDebugSection);
|
|
|
|
// Increase the number of sections
|
|
Inc(NtHeaders32^.FileHeader.NumberOfSections);
|
|
ResetMemory(JclDebugSection^, SizeOf(TImageSectionHeader));
|
|
// JCLDEBUG Virtual Address
|
|
JclDebugSection^.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;
|
|
RoundUpToAlignment(JclDebugSection^.VirtualAddress, NtHeaders32^.OptionalHeader.SectionAlignment);
|
|
// JCLDEBUG Physical Offset
|
|
JclDebugSection^.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;
|
|
RoundUpToAlignment(JclDebugSection^.PointerToRawData, NtHeaders32^.OptionalHeader.FileAlignment);
|
|
// JCLDEBUG Section name
|
|
StrPLCopy(PAnsiChar(@JclDebugSection^.Name), JclDbgDataResName, IMAGE_SIZEOF_SHORT_NAME);
|
|
// JCLDEBUG Characteristics flags
|
|
JclDebugSection^.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;
|
|
|
|
// Size of virtual data area
|
|
JclDebugSection^.Misc.VirtualSize := JclDebugDataSize;
|
|
VirtualAlignedSize := JclDebugDataSize;
|
|
RoundUpToAlignment(VirtualAlignedSize, NtHeaders32^.OptionalHeader.SectionAlignment);
|
|
// Update Size of Image
|
|
Inc(NtHeaders32^.OptionalHeader.SizeOfImage, VirtualAlignedSize);
|
|
// Raw data size
|
|
JclDebugSection^.SizeOfRawData := JclDebugDataSize;
|
|
RoundUpToAlignment(JclDebugSection^.SizeOfRawData, NtHeaders32^.OptionalHeader.FileAlignment);
|
|
// Update Initialized data size
|
|
Inc(NtHeaders32^.OptionalHeader.SizeOfInitializedData, JclDebugSection^.SizeOfRawData);
|
|
|
|
// Fill data to alignment
|
|
NeedFill := INT_PTR(JclDebugSection^.SizeOfRawData) - JclDebugDataSize;
|
|
|
|
// Note: Delphi linker seems to generate incorrect (unaligned) size of
|
|
// the executable when adding TD32 debug data so the position could be
|
|
// behind the size of the file then.
|
|
ImageStream.Seek(JclDebugSection^.PointerToRawData, soFromBeginning);
|
|
ImageStream.CopyFrom(BinDebug.DataStream, 0);
|
|
X := 0;
|
|
for I := 1 to NeedFill do
|
|
ImageStream.WriteBuffer(X, 1);
|
|
|
|
ImageStream.SaveToFile(ExecutableFileName);
|
|
end
|
|
else
|
|
Result := False;
|
|
except
|
|
Result := False;
|
|
end;
|
|
finally
|
|
ImageStream.Free;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclBinDebugGenerator } ==============================================
|
|
|
|
constructor TJclBinDebugGenerator.Create(const MapFileName: TFileName; Module: HMODULE);
|
|
begin
|
|
inherited Create(MapFileName, Module);
|
|
FDataStream := TMemoryStream.Create;
|
|
FMapFileName := MapFileName;
|
|
if FStream <> nil then
|
|
CreateData;
|
|
end;
|
|
|
|
destructor TJclBinDebugGenerator.Destroy;
|
|
begin
|
|
FreeAndNil(FDataStream);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{$OVERFLOWCHECKS OFF}
|
|
|
|
function TJclBinDebugGenerator.CalculateCheckSum: Boolean;
|
|
var
|
|
Header: PJclDbgHeader;
|
|
P, EndData: PAnsiChar;
|
|
CheckSum: Integer;
|
|
begin
|
|
Result := DataStream.Size >= SizeOf(TJclDbgHeader);
|
|
if Result then
|
|
begin
|
|
P := DataStream.Memory;
|
|
EndData := P + DataStream.Size;
|
|
Header := PJclDbgHeader(P);
|
|
CheckSum := 0;
|
|
Header^.CheckSum := 0;
|
|
Header^.CheckSumValid := True;
|
|
while P < EndData do
|
|
begin
|
|
Inc(CheckSum, PInteger(P)^);
|
|
Inc(PInteger(P));
|
|
end;
|
|
Header^.CheckSum := CheckSum;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF OVERFLOWCHECKS_ON}
|
|
{$OVERFLOWCHECKS ON}
|
|
{$ENDIF OVERFLOWCHECKS_ON}
|
|
|
|
procedure TJclBinDebugGenerator.CreateData;
|
|
var
|
|
WordList: TStringList;
|
|
WordStream: TMemoryStream;
|
|
LastSegmentID: Word;
|
|
LastSegmentStored: Boolean;
|
|
|
|
function AddWord(const S: string): Integer;
|
|
var
|
|
N: Integer;
|
|
E: AnsiString;
|
|
begin
|
|
if S = '' then
|
|
begin
|
|
Result := 0;
|
|
Exit;
|
|
end;
|
|
N := WordList.IndexOf(S);
|
|
if N = -1 then
|
|
begin
|
|
Result := WordStream.Position;
|
|
E := EncodeNameString(S);
|
|
WordStream.WriteBuffer(E[1], Length(E));
|
|
WordList.AddObject(S, TObject(Result));
|
|
end
|
|
else
|
|
Result := DWORD(WordList.Objects[N]);
|
|
Inc(Result);
|
|
end;
|
|
|
|
procedure WriteValue(Value: Integer);
|
|
var
|
|
L: Integer;
|
|
D: DWORD;
|
|
P: array [1..5] of Byte;
|
|
begin
|
|
D := Value and $FFFFFFFF;
|
|
L := 0;
|
|
while D > $7F do
|
|
begin
|
|
Inc(L);
|
|
P[L] := (D and $7F) or $80;
|
|
D := D shr 7;
|
|
end;
|
|
Inc(L);
|
|
P[L] := (D and $7F);
|
|
FDataStream.WriteBuffer(P, L);
|
|
end;
|
|
|
|
procedure WriteValueOfs(Value: Integer; var LastValue: Integer);
|
|
begin
|
|
WriteValue(Value - LastValue);
|
|
LastValue := Value;
|
|
end;
|
|
|
|
function IsSegmentStored(SegID: Word): Boolean;
|
|
var
|
|
SegIndex: Integer;
|
|
GroupName: string;
|
|
begin
|
|
if (SegID <> LastSegmentID) then
|
|
begin
|
|
LastSegmentID := $FFFF;
|
|
LastSegmentStored := False;
|
|
for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do
|
|
if FSegmentClasses[SegIndex].Segment = SegID then
|
|
begin
|
|
LastSegmentID := FSegmentClasses[SegIndex].Segment;
|
|
GroupName := MapStringToStr(FSegmentClasses[SegIndex].GroupName);
|
|
LastSegmentStored := (GroupName = 'CODE') or (GroupName = 'ICODE');
|
|
Break;
|
|
end;
|
|
end;
|
|
Result := LastSegmentStored;
|
|
end;
|
|
|
|
var
|
|
FileHeader: TJclDbgHeader;
|
|
I, D: Integer;
|
|
S: string;
|
|
L1, L2, L3: Integer;
|
|
FirstWord, SecondWord: Integer;
|
|
begin
|
|
LastSegmentID := $FFFF;
|
|
WordStream := TMemoryStream.Create;
|
|
WordList := TStringList.Create;
|
|
try
|
|
WordList.Sorted := True;
|
|
WordList.Duplicates := dupError;
|
|
|
|
FileHeader.Signature := JclDbgDataSignature;
|
|
FileHeader.Version := JclDbgHeaderVersion;
|
|
FileHeader.CheckSum := 0;
|
|
FileHeader.CheckSumValid := False;
|
|
FileHeader.ModuleName := AddWord(PathExtractFileNameNoExt(FMapFileName));
|
|
FDataStream.WriteBuffer(FileHeader, SizeOf(FileHeader));
|
|
|
|
FileHeader.Units := FDataStream.Position;
|
|
L1 := 0;
|
|
L2 := 0;
|
|
for I := 0 to Length(FSegments) - 1 do
|
|
if IsSegmentStored(FSegments[I].Segment) then
|
|
begin
|
|
WriteValueOfs(FSegments[I].StartVA, L1);
|
|
WriteValueOfs(AddWord(MapStringToModuleName(FSegments[I].UnitName)), L2);
|
|
end;
|
|
WriteValue(MaxInt);
|
|
|
|
FileHeader.SourceNames := FDataStream.Position;
|
|
L1 := 0;
|
|
L2 := 0;
|
|
for I := 0 to Length(FSourceNames) - 1 do
|
|
if IsSegmentStored(FSourceNames[I].Segment) then
|
|
begin
|
|
WriteValueOfs(FSourceNames[I].VA, L1);
|
|
WriteValueOfs(AddWord(MapStringToStr(FSourceNames[I].ProcName)), L2);
|
|
end;
|
|
WriteValue(MaxInt);
|
|
|
|
FileHeader.Symbols := FDataStream.Position;
|
|
L1 := 0;
|
|
L2 := 0;
|
|
L3 := 0;
|
|
for I := 0 to Length(FProcNames) - 1 do
|
|
if IsSegmentStored(FProcNames[I].Segment) then
|
|
begin
|
|
WriteValueOfs(FProcNames[I].VA, L1);
|
|
// MAP files generated by C++Builder have spaces in their names
|
|
S := MapStringToStr(FProcNames[I].ProcName, True);
|
|
D := Pos('.', S);
|
|
if D = 1 then
|
|
begin
|
|
FirstWord := 0;
|
|
SecondWord := 0;
|
|
end
|
|
else
|
|
if D = 0 then
|
|
begin
|
|
FirstWord := AddWord(S);
|
|
SecondWord := 0;
|
|
end
|
|
else
|
|
begin
|
|
FirstWord := AddWord(Copy(S, 1, D - 1));
|
|
SecondWord := AddWord(Copy(S, D + 1, Length(S)));
|
|
end;
|
|
WriteValueOfs(FirstWord, L2);
|
|
WriteValueOfs(SecondWord, L3);
|
|
end;
|
|
WriteValue(MaxInt);
|
|
|
|
FileHeader.LineNumbers := FDataStream.Position;
|
|
L1 := 0;
|
|
L2 := 0;
|
|
for I := 0 to Length(FLineNumbers) - 1 do
|
|
if IsSegmentStored(FLineNumbers[I].Segment) then
|
|
begin
|
|
WriteValueOfs(FLineNumbers[I].VA, L1);
|
|
WriteValueOfs(FLineNumbers[I].LineNumber, L2);
|
|
end;
|
|
WriteValue(MaxInt);
|
|
|
|
FileHeader.Words := FDataStream.Position;
|
|
FDataStream.CopyFrom(WordStream, 0);
|
|
I := 0;
|
|
while FDataStream.Size mod 4 <> 0 do
|
|
FDataStream.WriteBuffer(I, 1);
|
|
FDataStream.Seek(0, soFromBeginning);
|
|
FDataStream.WriteBuffer(FileHeader, SizeOf(FileHeader));
|
|
finally
|
|
WordStream.Free;
|
|
WordList.Free;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclBinDebugScanner } ================================================
|
|
|
|
constructor TJclBinDebugScanner.Create(AStream: TCustomMemoryStream; CacheData: Boolean);
|
|
begin
|
|
inherited Create;
|
|
FCacheData := CacheData;
|
|
FStream := AStream;
|
|
CheckFormat;
|
|
end;
|
|
|
|
procedure TJclBinDebugScanner.CacheLineNumbers;
|
|
var
|
|
P: Pointer;
|
|
Value, LineNumber, C, Ln: Integer;
|
|
CurrVA: DWORD;
|
|
begin
|
|
if FLineNumbers = nil then
|
|
begin
|
|
LineNumber := 0;
|
|
CurrVA := 0;
|
|
C := 0;
|
|
Ln := 0;
|
|
P := MakePtr(PJclDbgHeader(FStream.Memory)^.LineNumbers);
|
|
Value := 0;
|
|
while ReadValue(P, Value) do
|
|
begin
|
|
Inc(CurrVA, Value);
|
|
ReadValue(P, Value);
|
|
Inc(LineNumber, Value);
|
|
if C = Ln then
|
|
begin
|
|
if Ln < 64 then
|
|
Ln := 64
|
|
else
|
|
Ln := Ln + Ln div 4;
|
|
SetLength(FLineNumbers, Ln);
|
|
end;
|
|
FLineNumbers[C].VA := CurrVA;
|
|
FLineNumbers[C].LineNumber := LineNumber;
|
|
Inc(C);
|
|
end;
|
|
SetLength(FLineNumbers, C);
|
|
end;
|
|
end;
|
|
|
|
procedure TJclBinDebugScanner.CacheProcNames;
|
|
var
|
|
P: Pointer;
|
|
Value, FirstWord, SecondWord, C, Ln: Integer;
|
|
CurrAddr: DWORD;
|
|
begin
|
|
if FProcNames = nil then
|
|
begin
|
|
FirstWord := 0;
|
|
SecondWord := 0;
|
|
CurrAddr := 0;
|
|
C := 0;
|
|
Ln := 0;
|
|
P := MakePtr(PJclDbgHeader(FStream.Memory)^.Symbols);
|
|
Value := 0;
|
|
while ReadValue(P, Value) do
|
|
begin
|
|
Inc(CurrAddr, Value);
|
|
ReadValue(P, Value);
|
|
Inc(FirstWord, Value);
|
|
ReadValue(P, Value);
|
|
Inc(SecondWord, Value);
|
|
if C = Ln then
|
|
begin
|
|
if Ln < 64 then
|
|
Ln := 64
|
|
else
|
|
Ln := Ln + Ln div 4;
|
|
SetLength(FProcNames, Ln);
|
|
end;
|
|
FProcNames[C].Addr := CurrAddr;
|
|
FProcNames[C].FirstWord := FirstWord;
|
|
FProcNames[C].SecondWord := SecondWord;
|
|
Inc(C);
|
|
end;
|
|
SetLength(FProcNames, C);
|
|
end;
|
|
end;
|
|
|
|
{$OVERFLOWCHECKS OFF}
|
|
|
|
procedure TJclBinDebugScanner.CheckFormat;
|
|
var
|
|
CheckSum: Integer;
|
|
Data, EndData: PAnsiChar;
|
|
Header: PJclDbgHeader;
|
|
begin
|
|
Data := FStream.Memory;
|
|
Header := PJclDbgHeader(Data);
|
|
FValidFormat := (Data <> nil) and (FStream.Size > SizeOf(TJclDbgHeader)) and
|
|
(FStream.Size mod 4 = 0) and
|
|
(Header^.Signature = JclDbgDataSignature) and (Header^.Version = JclDbgHeaderVersion);
|
|
if FValidFormat and Header^.CheckSumValid then
|
|
begin
|
|
CheckSum := -Header^.CheckSum;
|
|
EndData := Data + FStream.Size;
|
|
while Data < EndData do
|
|
begin
|
|
Inc(CheckSum, PInteger(Data)^);
|
|
Inc(PInteger(Data));
|
|
end;
|
|
CheckSum := (CheckSum shr 8) or (CheckSum shl 24);
|
|
FValidFormat := (CheckSum = Header^.CheckSum);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF OVERFLOWCHECKS_ON}
|
|
{$OVERFLOWCHECKS ON}
|
|
{$ENDIF OVERFLOWCHECKS_ON}
|
|
|
|
function TJclBinDebugScanner.DataToStr(A: Integer): string;
|
|
var
|
|
P: PAnsiChar;
|
|
begin
|
|
if A = 0 then
|
|
Result := ''
|
|
else
|
|
begin
|
|
P := PAnsiChar(TJclAddr(FStream.Memory) + TJclAddr(A) + TJclAddr(PJclDbgHeader(FStream.Memory)^.Words) - 1);
|
|
Result := DecodeNameString(P);
|
|
end;
|
|
end;
|
|
|
|
function TJclBinDebugScanner.GetModuleName: string;
|
|
begin
|
|
Result := DataToStr(PJclDbgHeader(FStream.Memory)^.ModuleName);
|
|
end;
|
|
|
|
function TJclBinDebugScanner.IsModuleNameValid(const Name: TFileName): Boolean;
|
|
begin
|
|
Result := AnsiSameText(ModuleName, PathExtractFileNameNoExt(Name));
|
|
end;
|
|
|
|
function TJclBinDebugScanner.LineNumberFromAddr(Addr: DWORD): Integer;
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
Result := LineNumberFromAddr(Addr, Dummy);
|
|
end;
|
|
|
|
function TJclBinDebugScanner.LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer;
|
|
var
|
|
P: Pointer;
|
|
Value, LineNumber: Integer;
|
|
CurrVA, ModuleStartVA, ItemVA: DWORD;
|
|
begin
|
|
ModuleStartVA := ModuleStartFromAddr(Addr);
|
|
LineNumber := 0;
|
|
Offset := 0;
|
|
if FCacheData then
|
|
begin
|
|
CacheLineNumbers;
|
|
for Value := Length(FLineNumbers) - 1 downto 0 do
|
|
if FLineNumbers[Value].VA <= Addr then
|
|
begin
|
|
if FLineNumbers[Value].VA >= ModuleStartVA then
|
|
begin
|
|
LineNumber := FLineNumbers[Value].LineNumber;
|
|
Offset := Addr - FLineNumbers[Value].VA;
|
|
end;
|
|
Break;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
P := MakePtr(PJclDbgHeader(FStream.Memory)^.LineNumbers);
|
|
CurrVA := 0;
|
|
ItemVA := 0;
|
|
while ReadValue(P, Value) do
|
|
begin
|
|
Inc(CurrVA, Value);
|
|
if Addr < CurrVA then
|
|
begin
|
|
if ItemVA < ModuleStartVA then
|
|
begin
|
|
LineNumber := 0;
|
|
Offset := 0;
|
|
end;
|
|
Break;
|
|
end
|
|
else
|
|
begin
|
|
ItemVA := CurrVA;
|
|
ReadValue(P, Value);
|
|
Inc(LineNumber, Value);
|
|
Offset := Addr - CurrVA;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := LineNumber;
|
|
end;
|
|
|
|
function TJclBinDebugScanner.MakePtr(A: Integer): Pointer;
|
|
begin
|
|
Result := Pointer(TJclAddr(FStream.Memory) + TJclAddr(A));
|
|
end;
|
|
|
|
function TJclBinDebugScanner.ModuleNameFromAddr(Addr: DWORD): string;
|
|
var
|
|
Value, Name: Integer;
|
|
StartAddr: DWORD;
|
|
P: Pointer;
|
|
begin
|
|
P := MakePtr(PJclDbgHeader(FStream.Memory)^.Units);
|
|
Name := 0;
|
|
StartAddr := 0;
|
|
Value := 0;
|
|
while ReadValue(P, Value) do
|
|
begin
|
|
Inc(StartAddr, Value);
|
|
if Addr < StartAddr then
|
|
Break
|
|
else
|
|
begin
|
|
ReadValue(P, Value);
|
|
Inc(Name, Value);
|
|
end;
|
|
end;
|
|
Result := DataToStr(Name);
|
|
end;
|
|
|
|
function TJclBinDebugScanner.ModuleStartFromAddr(Addr: DWORD): DWORD;
|
|
var
|
|
Value: Integer;
|
|
StartAddr, ModuleStartAddr: DWORD;
|
|
P: Pointer;
|
|
begin
|
|
P := MakePtr(PJclDbgHeader(FStream.Memory)^.Units);
|
|
StartAddr := 0;
|
|
ModuleStartAddr := DWORD(-1);
|
|
Value := 0;
|
|
while ReadValue(P, Value) do
|
|
begin
|
|
Inc(StartAddr, Value);
|
|
if Addr < StartAddr then
|
|
Break
|
|
else
|
|
begin
|
|
ReadValue(P, Value);
|
|
ModuleStartAddr := StartAddr;
|
|
end;
|
|
end;
|
|
Result := ModuleStartAddr;
|
|
end;
|
|
|
|
function TJclBinDebugScanner.ProcNameFromAddr(Addr: DWORD): string;
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
Result := ProcNameFromAddr(Addr, Dummy);
|
|
end;
|
|
|
|
function TJclBinDebugScanner.ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string;
|
|
var
|
|
P: Pointer;
|
|
Value, FirstWord, SecondWord: Integer;
|
|
CurrAddr, ModuleStartAddr, ItemAddr: DWORD;
|
|
begin
|
|
ModuleStartAddr := ModuleStartFromAddr(Addr);
|
|
FirstWord := 0;
|
|
SecondWord := 0;
|
|
Offset := 0;
|
|
if FCacheData then
|
|
begin
|
|
CacheProcNames;
|
|
for Value := Length(FProcNames) - 1 downto 0 do
|
|
if FProcNames[Value].Addr <= Addr then
|
|
begin
|
|
if FProcNames[Value].Addr >= ModuleStartAddr then
|
|
begin
|
|
FirstWord := FProcNames[Value].FirstWord;
|
|
SecondWord := FProcNames[Value].SecondWord;
|
|
Offset := Addr - FProcNames[Value].Addr;
|
|
end;
|
|
Break;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
P := MakePtr(PJclDbgHeader(FStream.Memory)^.Symbols);
|
|
CurrAddr := 0;
|
|
ItemAddr := 0;
|
|
while ReadValue(P, Value) do
|
|
begin
|
|
Inc(CurrAddr, Value);
|
|
if Addr < CurrAddr then
|
|
begin
|
|
if ItemAddr < ModuleStartAddr then
|
|
begin
|
|
FirstWord := 0;
|
|
SecondWord := 0;
|
|
Offset := 0;
|
|
end;
|
|
Break;
|
|
end
|
|
else
|
|
begin
|
|
ItemAddr := CurrAddr;
|
|
ReadValue(P, Value);
|
|
Inc(FirstWord, Value);
|
|
ReadValue(P, Value);
|
|
Inc(SecondWord, Value);
|
|
Offset := Addr - CurrAddr;
|
|
end;
|
|
end;
|
|
end;
|
|
if FirstWord <> 0 then
|
|
begin
|
|
Result := DataToStr(FirstWord);
|
|
if SecondWord <> 0 then
|
|
Result := Result + '.' + DataToStr(SecondWord)
|
|
end
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
function TJclBinDebugScanner.ReadValue(var P: Pointer; var Value: Integer): Boolean;
|
|
var
|
|
N: Integer;
|
|
I: Integer;
|
|
B: Byte;
|
|
begin
|
|
N := 0;
|
|
I := 0;
|
|
repeat
|
|
B := PByte(P)^;
|
|
Inc(PByte(P));
|
|
Inc(N, (B and $7F) shl I);
|
|
Inc(I, 7);
|
|
until B and $80 = 0;
|
|
Value := N;
|
|
Result := (Value <> MaxInt);
|
|
end;
|
|
|
|
function TJclBinDebugScanner.SourceNameFromAddr(Addr: DWORD): string;
|
|
var
|
|
Value, Name: Integer;
|
|
StartAddr, ModuleStartAddr, ItemAddr: DWORD;
|
|
P: Pointer;
|
|
Found: Boolean;
|
|
begin
|
|
ModuleStartAddr := ModuleStartFromAddr(Addr);
|
|
P := MakePtr(PJclDbgHeader(FStream.Memory)^.SourceNames);
|
|
Name := 0;
|
|
StartAddr := 0;
|
|
ItemAddr := 0;
|
|
Found := False;
|
|
Value := 0;
|
|
while ReadValue(P, Value) do
|
|
begin
|
|
Inc(StartAddr, Value);
|
|
if Addr < StartAddr then
|
|
begin
|
|
if ItemAddr < ModuleStartAddr then
|
|
Name := 0
|
|
else
|
|
Found := True;
|
|
Break;
|
|
end
|
|
else
|
|
begin
|
|
ItemAddr := StartAddr;
|
|
ReadValue(P, Value);
|
|
Inc(Name, Value);
|
|
end;
|
|
end;
|
|
if Found then
|
|
Result := DataToStr(Name)
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
//=== { TJclLocationInfoEx } =================================================
|
|
|
|
constructor TJclLocationInfoEx.Create(AParent: TJclCustomLocationInfoList; Address: Pointer);
|
|
var
|
|
Options: TJclLocationInfoListOptions;
|
|
begin
|
|
inherited Create;
|
|
FAddress := Address;
|
|
FParent := AParent;
|
|
if Assigned(FParent) then
|
|
Options := FParent.Options
|
|
else
|
|
Options := [];
|
|
Fill(Options);
|
|
end;
|
|
|
|
procedure TJclLocationInfoEx.AssignTo(Dest: TPersistent);
|
|
begin
|
|
if Dest is TJclLocationInfoEx then
|
|
begin
|
|
TJclLocationInfoEx(Dest).FAddress := FAddress;
|
|
TJclLocationInfoEx(Dest).FBinaryFileName := FBinaryFileName;
|
|
TJclLocationInfoEx(Dest).FDebugInfo := FDebugInfo;
|
|
TJclLocationInfoEx(Dest).FLineNumber := FLineNumber;
|
|
TJclLocationInfoEx(Dest).FLineNumberOffsetFromProcedureStart := FLineNumberOffsetFromProcedureStart;
|
|
TJclLocationInfoEx(Dest).FModuleName := FModuleName;
|
|
TJclLocationInfoEx(Dest).FOffsetFromLineNumber := FOffsetFromLineNumber;
|
|
TJclLocationInfoEx(Dest).FOffsetFromProcName := FOffsetFromProcName;
|
|
TJclLocationInfoEx(Dest).FProcedureName := FProcedureName;
|
|
TJclLocationInfoEx(Dest).FSourceName := FSourceName;
|
|
TJclLocationInfoEx(Dest).FSourceUnitName := FSourceUnitName;
|
|
TJclLocationInfoEx(Dest).FUnitVersionDateTime := FUnitVersionDateTime;
|
|
TJclLocationInfoEx(Dest).FUnitVersionExtra := FUnitVersionExtra;
|
|
TJclLocationInfoEx(Dest).FUnitVersionLogPath := FUnitVersionLogPath;
|
|
TJclLocationInfoEx(Dest).FUnitVersionRCSfile := FUnitVersionRCSfile;
|
|
TJclLocationInfoEx(Dest).FUnitVersionRevision := FUnitVersionRevision;
|
|
TJclLocationInfoEx(Dest).FVAddress := FVAddress;
|
|
TJclLocationInfoEx(Dest).FValues := FValues;
|
|
end
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
procedure TJclLocationInfoEx.Clear;
|
|
begin
|
|
FAddress := nil;
|
|
Fill([]);
|
|
end;
|
|
|
|
procedure TJclLocationInfoEx.Fill(AOptions: TJclLocationInfoListOptions);
|
|
var
|
|
Info, StartProcInfo: TJclLocationInfo;
|
|
FixedProcedureName: string;
|
|
Module: HMODULE;
|
|
{$IFDEF UNITVERSIONING}
|
|
I: Integer;
|
|
UnitVersion: TUnitVersion;
|
|
UnitVersioning: TUnitVersioning;
|
|
UnitVersioningModule: TUnitVersioningModule;
|
|
{$ENDIF UNITVERSIONING}
|
|
begin
|
|
FValues := [];
|
|
if liloAutoGetAddressInfo in AOptions then
|
|
begin
|
|
Module := ModuleFromAddr(FAddress);
|
|
FVAddress := Pointer(TJclAddr(FAddress) - Module - ModuleCodeOffset);
|
|
FModuleName := ExtractFileName(GetModulePath(Module));
|
|
end
|
|
else
|
|
begin
|
|
{$IFDEF UNITVERSIONING}
|
|
Module := 0;
|
|
{$ENDIF UNITVERSIONING}
|
|
FVAddress := nil;
|
|
FModuleName := '';
|
|
end;
|
|
if (liloAutoGetLocationInfo in AOptions) and GetLocationInfo(FAddress, Info) then
|
|
begin
|
|
FValues := FValues + [lievLocationInfo];
|
|
FOffsetFromProcName := Info.OffsetFromProcName;
|
|
FSourceUnitName := Info.UnitName;
|
|
FixedProcedureName := Info.ProcedureName;
|
|
if Pos(Info.UnitName + '.', FixedProcedureName) = 1 then
|
|
FixedProcedureName := Copy(FixedProcedureName, Length(Info.UnitName) + 2, Length(FixedProcedureName) - Length(Info.UnitName) - 1);
|
|
FProcedureName := FixedProcedureName;
|
|
FSourceName := Info.SourceName;
|
|
FLineNumber := Info.LineNumber;
|
|
if FLineNumber > 0 then
|
|
FOffsetFromLineNumber := Info.OffsetFromLineNumber
|
|
else
|
|
FOffsetFromLineNumber := 0;
|
|
if GetLocationInfo(Pointer(TJclAddr(Info.Address) -
|
|
Cardinal(Info.OffsetFromProcName)), StartProcInfo) and (StartProcInfo.LineNumber > 0) then
|
|
begin
|
|
FLineNumberOffsetFromProcedureStart := Info.LineNumber - StartProcInfo.LineNumber;
|
|
FValues := FValues + [lievProcedureStartLocationInfo];
|
|
end
|
|
else
|
|
FLineNumberOffsetFromProcedureStart := 0;
|
|
FDebugInfo := Info.DebugInfo;
|
|
FBinaryFileName := Info.BinaryFileName;
|
|
end
|
|
else
|
|
begin
|
|
FOffsetFromProcName := 0;
|
|
FSourceUnitName := '';
|
|
FProcedureName := '';
|
|
FSourceName := '';
|
|
FLineNumber := 0;
|
|
FOffsetFromLineNumber := 0;
|
|
FLineNumberOffsetFromProcedureStart := 0;
|
|
FDebugInfo := nil;
|
|
FBinaryFileName := '';
|
|
end;
|
|
FUnitVersionDateTime := 0;
|
|
FUnitVersionLogPath := '';
|
|
FUnitVersionRCSfile := '';
|
|
FUnitVersionRevision := '';
|
|
{$IFDEF UNITVERSIONING}
|
|
if (liloAutoGetUnitVersionInfo in AOptions) and (FSourceName <> '') then
|
|
begin
|
|
if not (liloAutoGetAddressInfo in AOptions) then
|
|
Module := ModuleFromAddr(FAddress);
|
|
UnitVersioning := GetUnitVersioning;
|
|
for I := 0 to UnitVersioning.ModuleCount - 1 do
|
|
begin
|
|
UnitVersioningModule := UnitVersioning.Modules[I];
|
|
if UnitVersioningModule.Instance = Module then
|
|
begin
|
|
UnitVersion := UnitVersioningModule.FindUnit(FSourceName);
|
|
if Assigned(UnitVersion) then
|
|
begin
|
|
FUnitVersionDateTime := UnitVersion.DateTime;
|
|
FUnitVersionLogPath := UnitVersion.LogPath;
|
|
FUnitVersionRCSfile := UnitVersion.RCSfile;
|
|
FUnitVersionRevision := UnitVersion.Revision;
|
|
FValues := FValues + [lievUnitVersionInfo];
|
|
Break;
|
|
end;
|
|
end;
|
|
if lievUnitVersionInfo in FValues then
|
|
Break;
|
|
end;
|
|
end;
|
|
{$ENDIF UNITVERSIONING}
|
|
end;
|
|
|
|
{ TODO -oUSc : Include... better as function than property? }
|
|
function TJclLocationInfoEx.GetAsString: string;
|
|
const
|
|
IncludeStartProcLineOffset = True;
|
|
IncludeAddressOffset = True;
|
|
IncludeModuleName = True;
|
|
var
|
|
IncludeVAddress: Boolean;
|
|
OffsetStr, StartProcOffsetStr: string;
|
|
begin
|
|
IncludeVAddress := True;
|
|
OffsetStr := '';
|
|
if lievLocationInfo in FValues then
|
|
begin
|
|
if LineNumber > 0 then
|
|
begin
|
|
if IncludeStartProcLineOffset and (lievProcedureStartLocationInfo in FValues) then
|
|
StartProcOffsetStr := Format(' + %d', [LineNumberOffsetFromProcedureStart])
|
|
else
|
|
StartProcOffsetStr := '';
|
|
if IncludeAddressOffset then
|
|
begin
|
|
if OffsetFromLineNumber >= 0 then
|
|
OffsetStr := Format(' + $%x', [OffsetFromLineNumber])
|
|
else
|
|
OffsetStr := Format(' - $%x', [-OffsetFromLineNumber])
|
|
end;
|
|
Result := Format('[%p] %s.%s (Line %u, "%s"%s)%s', [Address, SourceUnitName, ProcedureName, LineNumber,
|
|
SourceName, StartProcOffsetStr, OffsetStr]);
|
|
end
|
|
else
|
|
begin
|
|
if IncludeAddressOffset then
|
|
OffsetStr := Format(' + $%x', [OffsetFromProcName]);
|
|
if SourceUnitName <> '' then
|
|
Result := Format('[%p] %s.%s%s', [Address, SourceUnitName, ProcedureName, OffsetStr])
|
|
else
|
|
Result := Format('[%p] %s%s', [Address, ProcedureName, OffsetStr]);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Result := Format('[%p]', [Address]);
|
|
IncludeVAddress := True;
|
|
end;
|
|
if IncludeVAddress or IncludeModuleName then
|
|
begin
|
|
if IncludeVAddress then
|
|
begin
|
|
OffsetStr := Format('(%p) ', [VAddress]);
|
|
Result := OffsetStr + Result;
|
|
end;
|
|
if IncludeModuleName then
|
|
Insert(Format('{%-12s}', [ModuleName]), Result, 11);
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclCustomLocationInfoList } =========================================
|
|
|
|
constructor TJclCustomLocationInfoList.Create;
|
|
begin
|
|
inherited Create;
|
|
FItemClass := TJclLocationInfoEx;
|
|
FItems := TObjectList.Create;
|
|
FOptions := [];
|
|
end;
|
|
|
|
destructor TJclCustomLocationInfoList.Destroy;
|
|
begin
|
|
FItems.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJclCustomLocationInfoList.AddStackInfoList(AStackInfoList: TObject);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
TJclStackInfoList(AStackInfoList).ForceStackTracing;
|
|
for I := 0 to TJclStackInfoList(AStackInfoList).Count - 1 do
|
|
InternalAdd(TJclStackInfoList(AStackInfoList)[I].CallerAddr);
|
|
end;
|
|
|
|
procedure TJclCustomLocationInfoList.AssignTo(Dest: TPersistent);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if Dest is TJclCustomLocationInfoList then
|
|
begin
|
|
TJclCustomLocationInfoList(Dest).Clear;
|
|
for I := 0 to Count - 1 do
|
|
TJclCustomLocationInfoList(Dest).InternalAdd(nil).Assign(TJclLocationInfoEx(FItems[I]));
|
|
end
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
procedure TJclCustomLocationInfoList.Clear;
|
|
begin
|
|
FItems.Clear;
|
|
end;
|
|
|
|
function TJclCustomLocationInfoList.GetAsString: string;
|
|
var
|
|
I: Integer;
|
|
Strings: TStringList;
|
|
begin
|
|
Strings := TStringList.Create;
|
|
try
|
|
for I := 0 to Count - 1 do
|
|
Strings.Add(TJclLocationInfoEx(FItems[I]).AsString);
|
|
Result := Strings.Text;
|
|
finally
|
|
Strings.Free;
|
|
end;
|
|
end;
|
|
|
|
function TJclCustomLocationInfoList.GetCount: Integer;
|
|
begin
|
|
Result := FItems.Count;
|
|
end;
|
|
|
|
function TJclCustomLocationInfoList.InternalAdd(Addr: Pointer): TJclLocationInfoEx;
|
|
begin
|
|
FItems.Add(FItemClass.Create(Self, Addr));
|
|
Result := TJclLocationInfoEx(FItems.Last);
|
|
end;
|
|
|
|
//=== { TJclLocationInfoList } ===============================================
|
|
|
|
function TJclLocationInfoList.Add(Addr: Pointer): TJclLocationInfoEx;
|
|
begin
|
|
Result := InternalAdd(Addr);
|
|
end;
|
|
|
|
constructor TJclLocationInfoList.Create;
|
|
begin
|
|
inherited Create;
|
|
FOptions := [liloAutoGetAddressInfo, liloAutoGetLocationInfo, liloAutoGetUnitVersionInfo];
|
|
end;
|
|
|
|
function TJclLocationInfoList.GetItems(AIndex: Integer): TJclLocationInfoEx;
|
|
begin
|
|
Result := TJclLocationInfoEx(FItems[AIndex]);
|
|
end;
|
|
|
|
//=== { TJclDebugInfoSource } ================================================
|
|
|
|
constructor TJclDebugInfoSource.Create(AModule: HMODULE);
|
|
begin
|
|
FModule := AModule;
|
|
end;
|
|
|
|
function TJclDebugInfoSource.GetFileName: TFileName;
|
|
begin
|
|
Result := GetModulePath(FModule);
|
|
end;
|
|
|
|
function TJclDebugInfoSource.VAFromAddr(const Addr: Pointer): DWORD;
|
|
begin
|
|
Result := DWORD(TJclAddr(Addr) - FModule - ModuleCodeOffset);
|
|
end;
|
|
|
|
//=== { TJclDebugInfoList } ==================================================
|
|
|
|
var
|
|
DebugInfoList: TJclDebugInfoList = nil;
|
|
InfoSourceClassList: TList = nil;
|
|
DebugInfoCritSect: TJclCriticalSection;
|
|
|
|
procedure NeedDebugInfoList;
|
|
begin
|
|
if DebugInfoList = nil then
|
|
DebugInfoList := TJclDebugInfoList.Create;
|
|
end;
|
|
|
|
function TJclDebugInfoList.CreateDebugInfo(const Module: HMODULE): TJclDebugInfoSource;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
NeedInfoSourceClassList;
|
|
|
|
Result := nil;
|
|
for I := 0 to InfoSourceClassList.Count - 1 do
|
|
begin
|
|
Result := TJclDebugInfoSourceClass(InfoSourceClassList.Items[I]).Create(Module);
|
|
try
|
|
if Result.InitializeSource then
|
|
Break
|
|
else
|
|
FreeAndNil(Result);
|
|
except
|
|
Result.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugInfoList.GetItemFromModule(const Module: HMODULE): TJclDebugInfoSource;
|
|
var
|
|
I: Integer;
|
|
TempItem: TJclDebugInfoSource;
|
|
begin
|
|
Result := nil;
|
|
if Module = 0 then
|
|
Exit;
|
|
for I := 0 to Count - 1 do
|
|
begin
|
|
TempItem := Items[I];
|
|
if TempItem.Module = Module then
|
|
begin
|
|
Result := TempItem;
|
|
Break;
|
|
end;
|
|
end;
|
|
if Result = nil then
|
|
begin
|
|
Result := CreateDebugInfo(Module);
|
|
if Result <> nil then
|
|
Add(Result);
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugInfoList.GetItems(Index: Integer): TJclDebugInfoSource;
|
|
begin
|
|
Result := TJclDebugInfoSource(Get(Index));
|
|
end;
|
|
|
|
function TJclDebugInfoList.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;
|
|
var
|
|
Item: TJclDebugInfoSource;
|
|
begin
|
|
ResetMemory(Info, SizeOf(Info));
|
|
Item := ItemFromModule[ModuleFromAddr(Addr)];
|
|
if Item <> nil then
|
|
Result := Item.GetLocationInfo(Addr, Info)
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
class procedure TJclDebugInfoList.NeedInfoSourceClassList;
|
|
begin
|
|
if not Assigned(InfoSourceClassList) then
|
|
begin
|
|
InfoSourceClassList := TList.Create;
|
|
{$IFNDEF DEBUG_NO_BINARY}
|
|
InfoSourceClassList.Add(Pointer(TJclDebugInfoBinary));
|
|
{$ENDIF !DEBUG_NO_BINARY}
|
|
{$IFNDEF DEBUG_NO_TD32}
|
|
InfoSourceClassList.Add(Pointer(TJclDebugInfoTD32));
|
|
{$ENDIF !DEBUG_NO_TD32}
|
|
{$IFNDEF DEBUG_NO_MAP}
|
|
InfoSourceClassList.Add(Pointer(TJclDebugInfoMap));
|
|
{$ENDIF !DEBUG_NO_MAP}
|
|
{$IFNDEF DEBUG_NO_SYMBOLS}
|
|
InfoSourceClassList.Add(Pointer(TJclDebugInfoSymbols));
|
|
{$ENDIF !DEBUG_NO_SYMBOLS}
|
|
{$IFNDEF DEBUG_NO_EXPORTS}
|
|
InfoSourceClassList.Add(Pointer(TJclDebugInfoExports));
|
|
{$ENDIF !DEBUG_NO_EXPORTS}
|
|
end;
|
|
end;
|
|
|
|
class procedure TJclDebugInfoList.RegisterDebugInfoSource(
|
|
const InfoSourceClass: TJclDebugInfoSourceClass);
|
|
begin
|
|
NeedInfoSourceClassList;
|
|
|
|
InfoSourceClassList.Add(Pointer(InfoSourceClass));
|
|
end;
|
|
|
|
class procedure TJclDebugInfoList.RegisterDebugInfoSourceFirst(
|
|
const InfoSourceClass: TJclDebugInfoSourceClass);
|
|
begin
|
|
NeedInfoSourceClassList;
|
|
|
|
InfoSourceClassList.Insert(0, Pointer(InfoSourceClass));
|
|
end;
|
|
|
|
class procedure TJclDebugInfoList.UnRegisterDebugInfoSource(
|
|
const InfoSourceClass: TJclDebugInfoSourceClass);
|
|
begin
|
|
if Assigned(InfoSourceClassList) then
|
|
InfoSourceClassList.Remove(Pointer(InfoSourceClass));
|
|
end;
|
|
|
|
//=== { TJclDebugInfoMap } ===================================================
|
|
|
|
destructor TJclDebugInfoMap.Destroy;
|
|
begin
|
|
FreeAndNil(FScanner);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclDebugInfoMap.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;
|
|
var
|
|
VA: DWORD;
|
|
begin
|
|
VA := VAFromAddr(Addr);
|
|
with FScanner do
|
|
begin
|
|
Info.UnitName := ModuleNameFromAddr(VA);
|
|
Result := Info.UnitName <> '';
|
|
if Result then
|
|
begin
|
|
Info.Address := Addr;
|
|
Info.ProcedureName := ProcNameFromAddr(VA, Info.OffsetFromProcName);
|
|
Info.LineNumber := LineNumberFromAddr(VA, Info.OffsetFromLineNumber);
|
|
Info.SourceName := SourceNameFromAddr(VA);
|
|
Info.DebugInfo := Self;
|
|
Info.BinaryFileName := FileName;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugInfoMap.InitializeSource: Boolean;
|
|
var
|
|
MapFileName: TFileName;
|
|
begin
|
|
MapFileName := ChangeFileExt(FileName, JclMapFileExtension);
|
|
Result := FileExists(MapFileName);
|
|
if Result then
|
|
FScanner := TJclMapScanner.Create(MapFileName, Module);
|
|
end;
|
|
|
|
//=== { TJclDebugInfoBinary } ================================================
|
|
|
|
destructor TJclDebugInfoBinary.Destroy;
|
|
begin
|
|
FreeAndNil(FScanner);
|
|
FreeAndNil(FStream);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclDebugInfoBinary.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;
|
|
var
|
|
VA: DWORD;
|
|
begin
|
|
VA := VAFromAddr(Addr);
|
|
with FScanner do
|
|
begin
|
|
Info.UnitName := ModuleNameFromAddr(VA);
|
|
Result := Info.UnitName <> '';
|
|
if Result then
|
|
begin
|
|
Info.Address := Addr;
|
|
Info.ProcedureName := ProcNameFromAddr(VA, Info.OffsetFromProcName);
|
|
Info.LineNumber := LineNumberFromAddr(VA, Info.OffsetFromLineNumber);
|
|
Info.SourceName := SourceNameFromAddr(VA);
|
|
Info.DebugInfo := Self;
|
|
Info.BinaryFileName := FileName;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugInfoBinary.InitializeSource: Boolean;
|
|
var
|
|
JdbgFileName: TFileName;
|
|
VerifyFileName: Boolean;
|
|
begin
|
|
VerifyFileName := False;
|
|
Result := (PeMapImgFindSectionFromModule(Pointer(Module), JclDbgDataResName) <> nil);
|
|
if Result then
|
|
FStream := TJclPeSectionStream.Create(Module, JclDbgDataResName)
|
|
else
|
|
begin
|
|
JdbgFileName := ChangeFileExt(FileName, JclDbgFileExtension);
|
|
Result := FileExists(JdbgFileName);
|
|
if Result then
|
|
begin
|
|
FStream := TJclFileMappingStream.Create(JdbgFileName, fmOpenRead or fmShareDenyWrite);
|
|
VerifyFileName := True;
|
|
end;
|
|
end;
|
|
if Result then
|
|
begin
|
|
FScanner := TJclBinDebugScanner.Create(FStream, True);
|
|
Result := FScanner.ValidFormat and
|
|
(not VerifyFileName or FScanner.IsModuleNameValid(FileName));
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclDebugInfoExports } ===============================================
|
|
|
|
destructor TJclDebugInfoExports.Destroy;
|
|
begin
|
|
FreeAndNil(FImage);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclDebugInfoExports.IsAddressInThisExportedFunction(Addr: PByteArray; FunctionStartAddr: TJclAddr): Boolean;
|
|
begin
|
|
Dec(TJclAddr(Addr), 6);
|
|
Result := False;
|
|
|
|
while TJclAddr(Addr) > FunctionStartAddr do
|
|
begin
|
|
if IsBadReadPtr(Addr, 6) then
|
|
Exit;
|
|
|
|
if (Addr[0] = $C2) and // ret $xxxx
|
|
(((Addr[3] = $90) and (Addr[4] = $90) and (Addr[5] = $90)) or // nop
|
|
((Addr[3] = $CC) and (Addr[4] = $CC) and (Addr[5] = $CC))) then // int 3
|
|
Exit;
|
|
|
|
if (Addr[0] = $C3) and // ret
|
|
(((Addr[1] = $90) and (Addr[2] = $90) and (Addr[3] = $90)) or // nop
|
|
((Addr[1] = $CC) and (Addr[2] = $CC) and (Addr[3] = $CC))) then // int 3
|
|
Exit;
|
|
|
|
if (Addr[0] = $E9) and // jmp rel-far
|
|
(((Addr[5] = $90) and (Addr[6] = $90) and (Addr[7] = $90)) or // nop
|
|
((Addr[5] = $CC) and (Addr[6] = $CC) and (Addr[7] = $CC))) then // int 3
|
|
Exit;
|
|
|
|
if (Addr[0] = $EB) and // jmp rel-near
|
|
(((Addr[2] = $90) and (Addr[3] = $90) and (Addr[4] = $90)) or // nop
|
|
((Addr[2] = $CC) and (Addr[3] = $CC) and (Addr[4] = $CC))) then // int 3
|
|
Exit;
|
|
|
|
Dec(TJclAddr(Addr));
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function TJclDebugInfoExports.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;
|
|
var
|
|
I, BasePos: Integer;
|
|
VA: DWORD;
|
|
Desc: TJclBorUmDescription;
|
|
Unmangled: string;
|
|
RawName: Boolean;
|
|
begin
|
|
Result := False;
|
|
VA := DWORD(TJclAddr(Addr) - FModule);
|
|
{$IFDEF BORLAND}
|
|
RawName := not FImage.IsPackage;
|
|
{$ENDIF BORLAND}
|
|
{$IFDEF FPC}
|
|
RawName := True;
|
|
{$ENDIF FPC}
|
|
Info.OffsetFromProcName := 0;
|
|
Info.OffsetFromLineNumber := 0;
|
|
Info.BinaryFileName := FileName;
|
|
with FImage.ExportList do
|
|
begin
|
|
SortList(esAddress, False);
|
|
for I := Count - 1 downto 0 do
|
|
if Items[I].Address <= VA then
|
|
begin
|
|
if RawName then
|
|
begin
|
|
Info.ProcedureName := Items[I].Name;
|
|
Info.OffsetFromProcName := VA - Items[I].Address;
|
|
Result := True;
|
|
end
|
|
else
|
|
begin
|
|
case PeBorUnmangleName(Items[I].Name, Unmangled, Desc, BasePos) of
|
|
urOk:
|
|
begin
|
|
Info.UnitName := Copy(Unmangled, 1, BasePos - 2);
|
|
if not (Desc.Kind in [skRTTI, skVTable]) then
|
|
begin
|
|
Info.ProcedureName := Copy(Unmangled, BasePos, Length(Unmangled));
|
|
if smLinkProc in Desc.Modifiers then
|
|
Info.ProcedureName := '@' + Info.ProcedureName;
|
|
Info.OffsetFromProcName := VA - Items[I].Address;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
urNotMangled:
|
|
begin
|
|
Info.ProcedureName := Items[I].Name;
|
|
Info.OffsetFromProcName := VA - Items[I].Address;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
end;
|
|
if Result then
|
|
begin
|
|
Info.Address := Addr;
|
|
Info.DebugInfo := Self;
|
|
|
|
{ Check if we have a valid address in an exported function. }
|
|
if not IsAddressInThisExportedFunction(Addr, FModule + Items[I].Address) then
|
|
begin
|
|
//Info.UnitName := '[' + AnsiLowerCase(ExtractFileName(GetModulePath(FModule))) + ']'
|
|
Info.ProcedureName := Format(LoadResString(@RsUnknownFunctionAt), [Info.ProcedureName]);
|
|
end;
|
|
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugInfoExports.InitializeSource: Boolean;
|
|
begin
|
|
{$IFDEF BORLAND}
|
|
FImage := TJclPeBorImage.Create(True);
|
|
{$ENDIF BORLAND}
|
|
{$IFDEF FPC}
|
|
FImage := TJclPeImage.Create(True);
|
|
{$ENDIF FPC}
|
|
FImage.AttachLoadedModule(FModule);
|
|
Result := FImage.StatusOK and (FImage.ExportList.Count > 0);
|
|
end;
|
|
|
|
{$IFDEF BORLAND}
|
|
|
|
//=== { TJclDebugInfoTD32 } ==================================================
|
|
|
|
destructor TJclDebugInfoTD32.Destroy;
|
|
begin
|
|
FreeAndNil(FImage);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclDebugInfoTD32.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;
|
|
var
|
|
VA: DWORD;
|
|
begin
|
|
VA := VAFromAddr(Addr);
|
|
Info.UnitName := FImage.TD32Scanner.ModuleNameFromAddr(VA);
|
|
Result := Info.UnitName <> '';
|
|
if Result then
|
|
with Info do
|
|
begin
|
|
Address := Addr;
|
|
ProcedureName := FImage.TD32Scanner.ProcNameFromAddr(VA, OffsetFromProcName);
|
|
LineNumber := FImage.TD32Scanner.LineNumberFromAddr(VA, OffsetFromLineNumber);
|
|
SourceName := FImage.TD32Scanner.SourceNameFromAddr(VA);
|
|
DebugInfo := Self;
|
|
BinaryFileName := FileName;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugInfoTD32.InitializeSource: Boolean;
|
|
begin
|
|
FImage := TJclPeBorTD32Image.Create(True);
|
|
try
|
|
FImage.AttachLoadedModule(Module);
|
|
Result := FImage.IsTD32DebugPresent;
|
|
except
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
{$ENDIF BORLAND}
|
|
|
|
//=== { TJclDebugInfoSymbols } ===============================================
|
|
|
|
type
|
|
TSymInitializeAFunc = function (hProcess: THandle; UserSearchPath: LPSTR;
|
|
fInvadeProcess: Bool): Bool; stdcall;
|
|
TSymInitializeWFunc = function (hProcess: THandle; UserSearchPath: LPWSTR;
|
|
fInvadeProcess: Bool): Bool; stdcall;
|
|
TSymGetOptionsFunc = function: DWORD; stdcall;
|
|
TSymSetOptionsFunc = function (SymOptions: DWORD): DWORD; stdcall;
|
|
TSymCleanupFunc = function (hProcess: THandle): Bool; stdcall;
|
|
TSymGetSymFromAddrAFunc = function (hProcess: THandle; dwAddr: DWORD;
|
|
pdwDisplacement: PDWORD; var Symbol: JclWin32.TImagehlpSymbolA): Bool; stdcall;
|
|
TSymGetSymFromAddrWFunc = function (hProcess: THandle; dwAddr: DWORD;
|
|
pdwDisplacement: PDWORD; var Symbol: JclWin32.TImagehlpSymbolW): Bool; stdcall;
|
|
TSymGetModuleInfoAFunc = function (hProcess: THandle; dwAddr: DWORD;
|
|
var ModuleInfo: JclWin32.TImagehlpModuleA): Bool; stdcall;
|
|
TSymGetModuleInfoWFunc = function (hProcess: THandle; dwAddr: DWORD;
|
|
var ModuleInfo: JclWin32.TImagehlpModuleW): Bool; stdcall;
|
|
TSymLoadModuleFunc = function (hProcess: THandle; hFile: THandle; ImageName,
|
|
ModuleName: LPSTR; BaseOfDll, SizeOfDll: DWORD): DWORD; stdcall;
|
|
TSymGetLineFromAddrAFunc = function (hProcess: THandle; dwAddr: DWORD;
|
|
pdwDisplacement: PDWORD; var Line: JclWin32.TImageHlpLineA): Bool; stdcall;
|
|
TSymGetLineFromAddrWFunc = function (hProcess: THandle; dwAddr: DWORD;
|
|
pdwDisplacement: PDWORD; var Line: JclWin32.TImageHlpLineW): Bool; stdcall;
|
|
|
|
var
|
|
DebugSymbolsInitialized: Boolean = False;
|
|
DebugSymbolsLoadFailed: Boolean = False;
|
|
ImageHlpDllHandle: THandle = 0;
|
|
SymInitializeAFunc: TSymInitializeAFunc = nil;
|
|
SymInitializeWFunc: TSymInitializeWFunc = nil;
|
|
SymGetOptionsFunc: TSymGetOptionsFunc = nil;
|
|
SymSetOptionsFunc: TSymSetOptionsFunc = nil;
|
|
SymCleanupFunc: TSymCleanupFunc = nil;
|
|
SymGetSymFromAddrAFunc: TSymGetSymFromAddrAFunc = nil;
|
|
SymGetSymFromAddrWFunc: TSymGetSymFromAddrWFunc = nil;
|
|
SymGetModuleInfoAFunc: TSymGetModuleInfoAFunc = nil;
|
|
SymGetModuleInfoWFunc: TSymGetModuleInfoWFunc = nil;
|
|
SymLoadModuleFunc: TSymLoadModuleFunc = nil;
|
|
SymGetLineFromAddrAFunc: TSymGetLineFromAddrAFunc = nil;
|
|
SymGetLineFromAddrWFunc: TSymGetLineFromAddrWFunc = nil;
|
|
|
|
const
|
|
ImageHlpDllName = 'imagehlp.dll'; // do not localize
|
|
SymInitializeAFuncName = 'SymInitialize'; // do not localize
|
|
SymInitializeWFuncName = 'SymInitializeW'; // do not localize
|
|
SymGetOptionsFuncName = 'SymGetOptions'; // do not localize
|
|
SymSetOptionsFuncName = 'SymSetOptions'; // do not localize
|
|
SymCleanupFuncName = 'SymCleanup'; // do not localize
|
|
SymGetSymFromAddrAFuncName = 'SymGetSymFromAddr'; // do not localize
|
|
SymGetSymFromAddrWFuncName = 'SymGetSymFromAddrW'; // do not localize
|
|
SymGetModuleInfoAFuncName = 'SymGetModuleInfo'; // do not localize
|
|
SymGetModuleInfoWFuncName = 'SymGetModuleInfoW'; // do not localize
|
|
SymLoadModuleFuncName = 'SymLoadModule'; // do not localize
|
|
SymGetLineFromAddrAFuncName = 'SymGetLineFromAddr'; // do not localize
|
|
SymGetLineFromAddrWFuncName = 'SymGetLineFromAddrW'; // do not localize
|
|
|
|
function StrRemoveEmptyPaths(const Paths: string): string;
|
|
var
|
|
List: TStrings;
|
|
I: Integer;
|
|
begin
|
|
List := TStringList.Create;
|
|
try
|
|
StrToStrings(Paths, DirSeparator, List, False);
|
|
for I := 0 to List.Count - 1 do
|
|
if Trim(List[I]) = '' then
|
|
List[I] := '';
|
|
Result := StringsToStr(List, DirSeparator, False);
|
|
finally
|
|
List.Free;
|
|
end;
|
|
end;
|
|
|
|
class function TJclDebugInfoSymbols.InitializeDebugSymbols: Boolean;
|
|
var
|
|
EnvironmentVarValue, SearchPath: string;
|
|
SymOptions: Cardinal;
|
|
ProcessHandle: THandle;
|
|
begin
|
|
Result := DebugSymbolsInitialized;
|
|
if not DebugSymbolsLoadFailed then
|
|
begin
|
|
Result := LoadDebugFunctions;
|
|
DebugSymbolsLoadFailed := not Result;
|
|
|
|
if Result then
|
|
begin
|
|
if JclDebugInfoSymbolPaths <> '' then
|
|
begin
|
|
SearchPath := StrEnsureSuffix(DirSeparator, JclDebugInfoSymbolPaths);
|
|
SearchPath := StrEnsureNoSuffix(DirSeparator, SearchPath + GetCurrentFolder);
|
|
|
|
if GetEnvironmentVar(EnvironmentVarNtSymbolPath, EnvironmentVarValue) and (EnvironmentVarValue <> '') then
|
|
SearchPath := StrEnsureNoSuffix(DirSeparator, StrEnsureSuffix(DirSeparator, EnvironmentVarValue) + SearchPath);
|
|
if GetEnvironmentVar(EnvironmentVarAlternateNtSymbolPath, EnvironmentVarValue) and (EnvironmentVarValue <> '') then
|
|
SearchPath := StrEnsureNoSuffix(DirSeparator, StrEnsureSuffix(DirSeparator, EnvironmentVarValue) + SearchPath);
|
|
|
|
// DbgHelp.dll crashes when an empty path is specified.
|
|
// This also means that the SearchPath must not end with a DirSeparator. }
|
|
SearchPath := StrRemoveEmptyPaths(SearchPath);
|
|
end
|
|
else
|
|
// Fix crash SymLoadModuleFunc on WinXP SP3 when SearchPath=''
|
|
SearchPath := GetCurrentFolder;
|
|
|
|
if IsWinNT then
|
|
// in Windows NT, first argument is a process handle
|
|
ProcessHandle := GetCurrentProcess
|
|
else
|
|
// in Windows 95, 98, ME first argument is a process identifier
|
|
ProcessHandle := GetCurrentProcessId;
|
|
|
|
// Debug(WinXPSP3): SymInitializeWFunc==nil
|
|
if Assigned(SymInitializeWFunc) then
|
|
Result := SymInitializeWFunc(ProcessHandle, PWideChar(WideString(SearchPath)), False)
|
|
else
|
|
if Assigned(SymInitializeAFunc) then
|
|
Result := SymInitializeAFunc(ProcessHandle, PAnsiChar(AnsiString(SearchPath)), False)
|
|
else
|
|
Result := False;
|
|
|
|
if Result then
|
|
begin
|
|
SymOptions := SymGetOptionsFunc or SYMOPT_DEFERRED_LOADS
|
|
or SYMOPT_FAIL_CRITICAL_ERRORS or SYMOPT_INCLUDE_32BIT_MODULES or SYMOPT_LOAD_LINES;
|
|
SymOptions := SymOptions and (not (SYMOPT_NO_UNQUALIFIED_LOADS or SYMOPT_UNDNAME));
|
|
SymSetOptionsFunc(SymOptions);
|
|
end;
|
|
|
|
DebugSymbolsInitialized := Result;
|
|
end
|
|
else
|
|
UnloadDebugFunctions;
|
|
end;
|
|
end;
|
|
|
|
class function TJclDebugInfoSymbols.CleanupDebugSymbols: Boolean;
|
|
begin
|
|
Result := True;
|
|
|
|
if DebugSymbolsInitialized then
|
|
Result := SymCleanupFunc(GetCurrentProcess);
|
|
|
|
UnloadDebugFunctions;
|
|
end;
|
|
|
|
function TJclDebugInfoSymbols.GetLocationInfo(const Addr: Pointer;
|
|
out Info: TJclLocationInfo): Boolean;
|
|
const
|
|
SymbolNameLength = 1000;
|
|
SymbolSizeA = SizeOf(TImagehlpSymbolA) + SymbolNameLength * SizeOf(AnsiChar);
|
|
SymbolSizeW = SizeOf(TImagehlpSymbolW) + SymbolNameLength * SizeOf(WideChar);
|
|
var
|
|
Displacement: DWORD;
|
|
ProcessHandle: THandle;
|
|
SymbolA: PImagehlpSymbolA;
|
|
SymbolW: PImagehlpSymbolW;
|
|
LineA: TImageHlpLineA;
|
|
LineW: TImageHlpLineW;
|
|
begin
|
|
ProcessHandle := GetCurrentProcess;
|
|
|
|
if Assigned(SymGetSymFromAddrWFunc) then
|
|
begin
|
|
GetMem(SymbolW, SymbolSizeW);
|
|
try
|
|
ZeroMemory(SymbolW, SymbolSizeW);
|
|
SymbolW^.SizeOfStruct := SizeOf(TImageHlpSymbolW);
|
|
SymbolW^.MaxNameLength := SymbolNameLength;
|
|
Displacement := 0;
|
|
|
|
Result := SymGetSymFromAddrWFunc(ProcessHandle, TJclAddr(Addr), @Displacement, SymbolW^);
|
|
if Result then
|
|
begin
|
|
Info.DebugInfo := Self;
|
|
Info.Address := Addr;
|
|
Info.BinaryFileName := FileName;
|
|
Info.OffsetFromProcName := Displacement;
|
|
JclPeImage.UnDecorateSymbolName(string(WideString(SymbolW^.Name)), Info.ProcedureName, UNDNAME_NAME_ONLY or UNDNAME_NO_ARGUMENTS);
|
|
end;
|
|
finally
|
|
FreeMem(SymbolW);
|
|
end;
|
|
end
|
|
else
|
|
if Assigned(SymGetSymFromAddrAFunc) then
|
|
begin
|
|
GetMem(SymbolA, SymbolSizeA);
|
|
try
|
|
ZeroMemory(SymbolA, SymbolSizeA);
|
|
SymbolA^.SizeOfStruct := SizeOf(TImageHlpSymbolA);
|
|
SymbolA^.MaxNameLength := SymbolNameLength;
|
|
Displacement := 0;
|
|
|
|
Result := SymGetSymFromAddrAFunc(ProcessHandle, TJclAddr(Addr), @Displacement, SymbolA^);
|
|
if Result then
|
|
begin
|
|
Info.DebugInfo := Self;
|
|
Info.Address := Addr;
|
|
Info.BinaryFileName := FileName;
|
|
Info.OffsetFromProcName := Displacement;
|
|
JclPeImage.UnDecorateSymbolName(string(AnsiString(SymbolA^.Name)), Info.ProcedureName, UNDNAME_NAME_ONLY or UNDNAME_NO_ARGUMENTS);
|
|
end;
|
|
finally
|
|
FreeMem(SymbolA);
|
|
end;
|
|
end
|
|
else
|
|
Result := False;
|
|
|
|
// line number is optional
|
|
if Result and Assigned(SymGetLineFromAddrWFunc) then
|
|
begin
|
|
ZeroMemory(@LineW, SizeOf(LineW));
|
|
LineW.SizeOfStruct := SizeOf(LineW);
|
|
Displacement := 0;
|
|
|
|
if SymGetLineFromAddrWFunc(ProcessHandle, TJclAddr(Addr), @Displacement, LineW) then
|
|
begin
|
|
Info.LineNumber := LineW.LineNumber;
|
|
Info.UnitName := string(LineW.FileName);
|
|
Info.OffsetFromLineNumber := Displacement;
|
|
end;
|
|
end
|
|
else
|
|
if Result and Assigned(SymGetLineFromAddrAFunc) then
|
|
begin
|
|
ZeroMemory(@LineA, SizeOf(LineA));
|
|
LineA.SizeOfStruct := SizeOf(LineA);
|
|
Displacement := 0;
|
|
|
|
if SymGetLineFromAddrAFunc(ProcessHandle, TJclAddr(Addr), @Displacement, LineA) then
|
|
begin
|
|
Info.LineNumber := LineA.LineNumber;
|
|
Info.UnitName := string(LineA.FileName);
|
|
Info.OffsetFromLineNumber := Displacement;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugInfoSymbols.InitializeSource: Boolean;
|
|
var
|
|
ModuleFileName: TFileName;
|
|
ModuleInfoA: TImagehlpModuleA;
|
|
ModuleInfoW: TImagehlpModuleW;
|
|
ProcessHandle: THandle;
|
|
begin
|
|
Result := InitializeDebugSymbols;
|
|
if Result then
|
|
begin
|
|
if IsWinNT then
|
|
// in Windows NT, first argument is a process handle
|
|
ProcessHandle := GetCurrentProcess
|
|
else
|
|
// in Windows 95, 98, ME, first argument is a process identifier
|
|
ProcessHandle := GetCurrentProcessId;
|
|
|
|
if Assigned(SymGetModuleInfoWFunc) then
|
|
begin
|
|
ZeroMemory(@ModuleInfoW, SizeOf(ModuleInfoW));
|
|
ModuleInfoW.SizeOfStruct := SizeOf(ModuleInfoW);
|
|
Result := SymGetModuleInfoWFunc(ProcessHandle, Module, ModuleInfoW);
|
|
if not Result then
|
|
begin
|
|
// the symbols for this module are not loaded yet: load the module and query for the symbol again
|
|
ModuleFileName := GetModulePath(Module);
|
|
ZeroMemory(@ModuleInfoW, SizeOf(ModuleInfoW));
|
|
ModuleInfoW.SizeOfStruct := SizeOf(ModuleInfoW);
|
|
// warning: crash on WinXP SP3 when SymInitializeAFunc is called with empty SearchPath
|
|
// OF: possible loss of data
|
|
Result := (SymLoadModuleFunc(ProcessHandle, 0, PAnsiChar(AnsiString(ModuleFileName)), nil, 0, 0) <> 0) and
|
|
SymGetModuleInfoWFunc(ProcessHandle, Module, ModuleInfoW);
|
|
end;
|
|
Result := Result and (ModuleInfoW.BaseOfImage <> 0) and
|
|
not (ModuleInfoW.SymType in [SymNone, SymExport]);
|
|
end
|
|
else
|
|
if Assigned(SymGetModuleInfoAFunc) then
|
|
begin
|
|
ZeroMemory(@ModuleInfoA, SizeOf(ModuleInfoA));
|
|
ModuleInfoA.SizeOfStruct := SizeOf(ModuleInfoA);
|
|
Result := SymGetModuleInfoAFunc(ProcessHandle, Module, ModuleInfoA);
|
|
if not Result then
|
|
begin
|
|
// the symbols for this module are not loaded yet: load the module and query for the symbol again
|
|
ModuleFileName := GetModulePath(Module);
|
|
ZeroMemory(@ModuleInfoA, SizeOf(ModuleInfoA));
|
|
ModuleInfoA.SizeOfStruct := SizeOf(ModuleInfoA);
|
|
// warning: crash on WinXP SP3 when SymInitializeAFunc is called with empty SearchPath
|
|
// OF: possible loss of data
|
|
Result := (SymLoadModuleFunc(ProcessHandle, 0, PAnsiChar(AnsiString(ModuleFileName)), nil, 0, 0) <> 0) and
|
|
SymGetModuleInfoAFunc(ProcessHandle, Module, ModuleInfoA);
|
|
end;
|
|
Result := Result and (ModuleInfoW.BaseOfImage <> 0) and
|
|
not (ModuleInfoA.SymType in [SymNone, SymExport]);
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
class function TJclDebugInfoSymbols.LoadDebugFunctions: Boolean;
|
|
begin
|
|
ImageHlpDllHandle := SafeLoadLibrary(ImageHlpDllName);
|
|
|
|
if ImageHlpDllHandle <> 0 then
|
|
begin
|
|
SymInitializeAFunc := GetProcAddress(ImageHlpDllHandle, SymInitializeAFuncName);
|
|
SymInitializeWFunc := GetProcAddress(ImageHlpDllHandle, SymInitializeWFuncName);
|
|
SymGetOptionsFunc := GetProcAddress(ImageHlpDllHandle, SymGetOptionsFuncName);
|
|
SymSetOptionsFunc := GetProcAddress(ImageHlpDllHandle, SymSetOptionsFuncName);
|
|
SymCleanupFunc := GetProcAddress(ImageHlpDllHandle, SymCleanupFuncName);
|
|
SymGetSymFromAddrAFunc := GetProcAddress(ImageHlpDllHandle, SymGetSymFromAddrAFuncName);
|
|
SymGetSymFromAddrWFunc := GetProcAddress(ImageHlpDllHandle, SymGetSymFromAddrWFuncName);
|
|
SymGetModuleInfoAFunc := GetProcAddress(ImageHlpDllHandle, SymGetModuleInfoAFuncName);
|
|
SymGetModuleInfoWFunc := GetProcAddress(ImageHlpDllHandle, SymGetModuleInfoWFuncName);
|
|
SymLoadModuleFunc := GetProcAddress(ImageHlpDllHandle, SymLoadModuleFuncName);
|
|
SymGetLineFromAddrAFunc := GetProcAddress(ImageHlpDllHandle, SymGetLineFromAddrAFuncName);
|
|
SymGetLineFromAddrWFunc := GetProcAddress(ImageHlpDllHandle, SymGetLineFromAddrWFuncName);
|
|
end;
|
|
|
|
// SymGetLineFromAddrFunc is optional
|
|
Result := (ImageHlpDllHandle <> 0) and
|
|
Assigned(SymGetOptionsFunc) and Assigned(SymSetOptionsFunc) and
|
|
Assigned(SymCleanupFunc) and Assigned(SymLoadModuleFunc) and
|
|
(Assigned(SymInitializeAFunc) or Assigned(SymInitializeWFunc)) and
|
|
(Assigned(SymGetSymFromAddrAFunc) or Assigned(SymGetSymFromAddrWFunc)) and
|
|
(Assigned(SymGetModuleInfoAFunc) or Assigned(SymGetModuleInfoWFunc));
|
|
end;
|
|
|
|
class function TJclDebugInfoSymbols.UnloadDebugFunctions: Boolean;
|
|
begin
|
|
Result := ImageHlpDllHandle <> 0;
|
|
|
|
if Result then
|
|
FreeLibrary(ImageHlpDllHandle);
|
|
|
|
ImageHlpDllHandle := 0;
|
|
|
|
SymInitializeAFunc := nil;
|
|
SymInitializeWFunc := nil;
|
|
SymGetOptionsFunc := nil;
|
|
SymSetOptionsFunc := nil;
|
|
SymCleanupFunc := nil;
|
|
SymGetSymFromAddrAFunc := nil;
|
|
SymGetSymFromAddrWFunc := nil;
|
|
SymGetModuleInfoAFunc := nil;
|
|
SymGetModuleInfoWFunc := nil;
|
|
SymLoadModuleFunc := nil;
|
|
SymGetLineFromAddrAFunc := nil;
|
|
SymGetLineFromAddrWFunc := nil;
|
|
end;
|
|
|
|
//=== Source location functions ==============================================
|
|
|
|
{$STACKFRAMES ON}
|
|
|
|
function Caller(Level: Integer; FastStackWalk: Boolean): Pointer;
|
|
var
|
|
TopOfStack: TJclAddr;
|
|
BaseOfStack: TJclAddr;
|
|
StackFrame: PStackFrame;
|
|
begin
|
|
Result := nil;
|
|
try
|
|
if FastStackWalk then
|
|
begin
|
|
StackFrame := GetFramePointer;
|
|
BaseOfStack := TJclAddr(StackFrame) - 1;
|
|
TopOfStack := GetStackTop;
|
|
while (BaseOfStack < TJclAddr(StackFrame)) and (TJclAddr(StackFrame) < TopOfStack) do
|
|
begin
|
|
if Level = 0 then
|
|
begin
|
|
Result := Pointer(StackFrame^.CallerAddr - 1);
|
|
Break;
|
|
end;
|
|
StackFrame := PStackFrame(StackFrame^.CallerFrame);
|
|
Dec(Level);
|
|
end;
|
|
end
|
|
else
|
|
with TJclStackInfoList.Create(False, 1, nil, False, nil, nil) do
|
|
try
|
|
if Level < Count then
|
|
Result := Items[Level].CallerAddr;
|
|
finally
|
|
Free;
|
|
end;
|
|
except
|
|
Result := nil;
|
|
end;
|
|
end;
|
|
|
|
{$IFNDEF STACKFRAMES_ON}
|
|
{$STACKFRAMES OFF}
|
|
{$ENDIF ~STACKFRAMES_ON}
|
|
|
|
function GetLocationInfo(const Addr: Pointer): TJclLocationInfo;
|
|
begin
|
|
try
|
|
DebugInfoCritSect.Enter;
|
|
try
|
|
NeedDebugInfoList;
|
|
DebugInfoList.GetLocationInfo(Addr, Result)
|
|
finally
|
|
DebugInfoCritSect.Leave;
|
|
end;
|
|
except
|
|
Finalize(Result);
|
|
ResetMemory(Result, SizeOf(Result));
|
|
end;
|
|
end;
|
|
|
|
function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;
|
|
begin
|
|
try
|
|
DebugInfoCritSect.Enter;
|
|
try
|
|
NeedDebugInfoList;
|
|
Result := DebugInfoList.GetLocationInfo(Addr, Info);
|
|
finally
|
|
DebugInfoCritSect.Leave;
|
|
end;
|
|
except
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function GetLocationInfoStr(const Addr: Pointer; IncludeModuleName, IncludeAddressOffset,
|
|
IncludeStartProcLineOffset: Boolean; IncludeVAddress: Boolean): string;
|
|
var
|
|
Info, StartProcInfo: TJclLocationInfo;
|
|
OffsetStr, StartProcOffsetStr, FixedProcedureName: string;
|
|
Module : HMODULE;
|
|
begin
|
|
OffsetStr := '';
|
|
if GetLocationInfo(Addr, Info) then
|
|
with Info do
|
|
begin
|
|
FixedProcedureName := ProcedureName;
|
|
if Pos(UnitName + '.', FixedProcedureName) = 1 then
|
|
FixedProcedureName := Copy(FixedProcedureName, Length(UnitName) + 2, Length(FixedProcedureName) - Length(UnitName) - 1);
|
|
|
|
if LineNumber > 0 then
|
|
begin
|
|
if IncludeStartProcLineOffset and GetLocationInfo(Pointer(TJclAddr(Info.Address) -
|
|
Cardinal(Info.OffsetFromProcName)), StartProcInfo) and (StartProcInfo.LineNumber > 0) then
|
|
StartProcOffsetStr := Format(' + %d', [LineNumber - StartProcInfo.LineNumber])
|
|
else
|
|
StartProcOffsetStr := '';
|
|
if IncludeAddressOffset then
|
|
begin
|
|
if OffsetFromLineNumber >= 0 then
|
|
OffsetStr := Format(' + $%x', [OffsetFromLineNumber])
|
|
else
|
|
OffsetStr := Format(' - $%x', [-OffsetFromLineNumber])
|
|
end;
|
|
Result := Format('[%p] %s.%s (Line %u, "%s"%s)%s', [Addr, UnitName, FixedProcedureName, LineNumber,
|
|
SourceName, StartProcOffsetStr, OffsetStr]);
|
|
end
|
|
else
|
|
begin
|
|
if IncludeAddressOffset then
|
|
OffsetStr := Format(' + $%x', [OffsetFromProcName]);
|
|
if UnitName <> '' then
|
|
Result := Format('[%p] %s.%s%s', [Addr, UnitName, FixedProcedureName, OffsetStr])
|
|
else
|
|
Result := Format('[%p] %s%s', [Addr, FixedProcedureName, OffsetStr]);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Result := Format('[%p]', [Addr]);
|
|
IncludeVAddress := True;
|
|
end;
|
|
if IncludeVAddress or IncludeModuleName then
|
|
begin
|
|
Module := ModuleFromAddr(Addr);
|
|
if IncludeVAddress then
|
|
begin
|
|
OffsetStr := Format('(%p) ', [Pointer(TJclAddr(Addr) - Module - ModuleCodeOffset)]);
|
|
Result := OffsetStr + Result;
|
|
end;
|
|
if IncludeModuleName then
|
|
Insert(Format('{%-12s}', [ExtractFileName(GetModulePath(Module))]), Result, 11);
|
|
end;
|
|
end;
|
|
|
|
function DebugInfoAvailable(const Module: HMODULE): Boolean;
|
|
begin
|
|
DebugInfoCritSect.Enter;
|
|
try
|
|
NeedDebugInfoList;
|
|
Result := (DebugInfoList.ItemFromModule[Module] <> nil);
|
|
finally
|
|
DebugInfoCritSect.Leave;
|
|
end;
|
|
end;
|
|
|
|
procedure ClearLocationData;
|
|
begin
|
|
DebugInfoCritSect.Enter;
|
|
try
|
|
if DebugInfoList <> nil then
|
|
DebugInfoList.Clear;
|
|
finally
|
|
DebugInfoCritSect.Leave;
|
|
end;
|
|
end;
|
|
|
|
{$STACKFRAMES ON}
|
|
|
|
function FileByLevel(const Level: Integer): string;
|
|
begin
|
|
Result := GetLocationInfo(Caller(Level + 1)).SourceName;
|
|
end;
|
|
|
|
function ModuleByLevel(const Level: Integer): string;
|
|
begin
|
|
Result := GetLocationInfo(Caller(Level + 1)).UnitName;
|
|
end;
|
|
|
|
function ProcByLevel(const Level: Integer): string;
|
|
begin
|
|
Result := GetLocationInfo(Caller(Level + 1)).ProcedureName;
|
|
end;
|
|
|
|
function LineByLevel(const Level: Integer): Integer;
|
|
begin
|
|
Result := GetLocationInfo(Caller(Level + 1)).LineNumber;
|
|
end;
|
|
|
|
function MapByLevel(const Level: Integer; var File_, Module_, Proc_: string;
|
|
var Line_: Integer): Boolean;
|
|
begin
|
|
Result := MapOfAddr(Caller(Level + 1), File_, Module_, Proc_, Line_);
|
|
end;
|
|
|
|
function ExtractClassName(const ProcedureName: string): string;
|
|
var
|
|
D: Integer;
|
|
begin
|
|
D := Pos('.', ProcedureName);
|
|
if D < 2 then
|
|
Result := ''
|
|
else
|
|
Result := Copy(ProcedureName, 1, D - 1);
|
|
end;
|
|
|
|
function ExtractMethodName(const ProcedureName: string): string;
|
|
begin
|
|
Result := Copy(ProcedureName, Pos('.', ProcedureName) + 1, Length(ProcedureName));
|
|
end;
|
|
|
|
function __FILE__(const Level: Integer): string;
|
|
begin
|
|
Result := FileByLevel(Level + 1);
|
|
end;
|
|
|
|
function __MODULE__(const Level: Integer): string;
|
|
begin
|
|
Result := ModuleByLevel(Level + 1);
|
|
end;
|
|
|
|
function __PROC__(const Level: Integer): string;
|
|
begin
|
|
Result := ProcByLevel(Level + 1);
|
|
end;
|
|
|
|
function __LINE__(const Level: Integer): Integer;
|
|
begin
|
|
Result := LineByLevel(Level + 1);
|
|
end;
|
|
|
|
function __MAP__(const Level: Integer; var _File, _Module, _Proc: string; var _Line: Integer): Boolean;
|
|
begin
|
|
Result := MapByLevel(Level + 1, _File, _Module, _Proc, _Line);
|
|
end;
|
|
|
|
{$IFNDEF STACKFRAMES_ON}
|
|
{$STACKFRAMES OFF}
|
|
{$ENDIF ~STACKFRAMES_ON}
|
|
|
|
function FileOfAddr(const Addr: Pointer): string;
|
|
begin
|
|
Result := GetLocationInfo(Addr).SourceName;
|
|
end;
|
|
|
|
function ModuleOfAddr(const Addr: Pointer): string;
|
|
begin
|
|
Result := GetLocationInfo(Addr).UnitName;
|
|
end;
|
|
|
|
function ProcOfAddr(const Addr: Pointer): string;
|
|
begin
|
|
Result := GetLocationInfo(Addr).ProcedureName;
|
|
end;
|
|
|
|
function LineOfAddr(const Addr: Pointer): Integer;
|
|
begin
|
|
Result := GetLocationInfo(Addr).LineNumber;
|
|
end;
|
|
|
|
function MapOfAddr(const Addr: Pointer; var File_, Module_, Proc_: string;
|
|
var Line_: Integer): Boolean;
|
|
var
|
|
LocInfo: TJclLocationInfo;
|
|
begin
|
|
NeedDebugInfoList;
|
|
Result := DebugInfoList.GetLocationInfo(Addr, LocInfo);
|
|
if Result then
|
|
begin
|
|
File_ := LocInfo.SourceName;
|
|
Module_ := LocInfo.UnitName;
|
|
Proc_ := LocInfo.ProcedureName;
|
|
Line_ := LocInfo.LineNumber;
|
|
end;
|
|
end;
|
|
|
|
function __FILE_OF_ADDR__(const Addr: Pointer): string;
|
|
begin
|
|
Result := FileOfAddr(Addr);
|
|
end;
|
|
|
|
function __MODULE_OF_ADDR__(const Addr: Pointer): string;
|
|
begin
|
|
Result := ModuleOfAddr(Addr);
|
|
end;
|
|
|
|
function __PROC_OF_ADDR__(const Addr: Pointer): string;
|
|
begin
|
|
Result := ProcOfAddr(Addr);
|
|
end;
|
|
|
|
function __LINE_OF_ADDR__(const Addr: Pointer): Integer;
|
|
begin
|
|
Result := LineOfAddr(Addr);
|
|
end;
|
|
|
|
function __MAP_OF_ADDR__(const Addr: Pointer; var _File, _Module, _Proc: string;
|
|
var _Line: Integer): Boolean;
|
|
begin
|
|
Result := MapOfAddr(Addr, _File, _Module, _Proc, _Line);
|
|
end;
|
|
|
|
//=== { TJclStackBaseList } ==================================================
|
|
|
|
constructor TJclStackBaseList.Create;
|
|
begin
|
|
inherited Create(True);
|
|
FThreadID := GetCurrentThreadId;
|
|
FTimeStamp := Now;
|
|
end;
|
|
|
|
destructor TJclStackBaseList.Destroy;
|
|
begin
|
|
if Assigned(FOnDestroy) then
|
|
FOnDestroy(Self);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
//=== { TJclGlobalStackList } ================================================
|
|
|
|
type
|
|
TJclStackBaseListClass = class of TJclStackBaseList;
|
|
|
|
TJclGlobalStackList = class(TThreadList)
|
|
private
|
|
FLockedTID: DWORD;
|
|
FTIDLocked: Boolean;
|
|
function GetExceptStackInfo(TID: DWORD): TJclStackInfoList;
|
|
function GetLastExceptFrameList(TID: DWORD): TJclExceptFrameList;
|
|
procedure ItemDestroyed(Sender: TObject);
|
|
public
|
|
destructor Destroy; override;
|
|
procedure AddObject(AObject: TJclStackBaseList);
|
|
procedure LockThreadID(TID: DWORD);
|
|
procedure UnlockThreadID;
|
|
function FindObject(TID: DWORD; AClass: TJclStackBaseListClass): TJclStackBaseList;
|
|
property ExceptStackInfo[TID: DWORD]: TJclStackInfoList read GetExceptStackInfo;
|
|
property LastExceptFrameList[TID: DWORD]: TJclExceptFrameList read GetLastExceptFrameList;
|
|
end;
|
|
|
|
var
|
|
GlobalStackList: TJclGlobalStackList;
|
|
|
|
destructor TJclGlobalStackList.Destroy;
|
|
begin
|
|
with LockList do
|
|
try
|
|
while Count > 0 do
|
|
TObject(Items[0]).Free;
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJclGlobalStackList.AddObject(AObject: TJclStackBaseList);
|
|
var
|
|
ReplacedObj: TObject;
|
|
begin
|
|
AObject.FOnDestroy := ItemDestroyed;
|
|
with LockList do
|
|
try
|
|
ReplacedObj := FindObject(AObject.ThreadID, TJclStackBaseListClass(AObject.ClassType));
|
|
if ReplacedObj <> nil then
|
|
begin
|
|
Remove(ReplacedObj);
|
|
ReplacedObj.Free;
|
|
end;
|
|
Add(AObject);
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
function TJclGlobalStackList.FindObject(TID: DWORD; AClass: TJclStackBaseListClass): TJclStackBaseList;
|
|
var
|
|
I: Integer;
|
|
Item: TJclStackBaseList;
|
|
begin
|
|
Result := nil;
|
|
with LockList do
|
|
try
|
|
if FTIDLocked and (GetCurrentThreadId = MainThreadID) then
|
|
TID := FLockedTID;
|
|
for I := 0 to Count - 1 do
|
|
begin
|
|
Item := Items[I];
|
|
if (Item.ThreadID = TID) and (Item is AClass) then
|
|
begin
|
|
Result := Item;
|
|
Break;
|
|
end;
|
|
end;
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
function TJclGlobalStackList.GetExceptStackInfo(TID: DWORD): TJclStackInfoList;
|
|
begin
|
|
Result := TJclStackInfoList(FindObject(TID, TJclStackInfoList));
|
|
end;
|
|
|
|
function TJclGlobalStackList.GetLastExceptFrameList(TID: DWORD): TJclExceptFrameList;
|
|
begin
|
|
Result := TJclExceptFrameList(FindObject(TID, TJclExceptFrameList));
|
|
end;
|
|
|
|
procedure TJclGlobalStackList.ItemDestroyed(Sender: TObject);
|
|
begin
|
|
with LockList do
|
|
try
|
|
Remove(Sender);
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclGlobalStackList.LockThreadID(TID: DWORD);
|
|
begin
|
|
with LockList do
|
|
try
|
|
if GetCurrentThreadId = MainThreadID then
|
|
begin
|
|
FTIDLocked := True;
|
|
FLockedTID := TID;
|
|
end
|
|
else
|
|
FTIDLocked := False;
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclGlobalStackList.UnlockThreadID;
|
|
begin
|
|
with LockList do
|
|
try
|
|
FTIDLocked := False;
|
|
finally
|
|
UnlockList;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclGlobalModulesList } ==============================================
|
|
|
|
type
|
|
TJclGlobalModulesList = class(TObject)
|
|
private
|
|
FHookedModules: TJclModuleArray;
|
|
FLock: TJclCriticalSection;
|
|
FModulesList: TJclModuleInfoList;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function CreateModulesList: TJclModuleInfoList;
|
|
procedure FreeModulesList(var ModulesList: TJclModuleInfoList);
|
|
function ValidateAddress(Addr: Pointer): Boolean;
|
|
end;
|
|
|
|
var
|
|
GlobalModulesList: TJclGlobalModulesList;
|
|
|
|
constructor TJclGlobalModulesList.Create;
|
|
begin
|
|
FLock := TJclCriticalSection.Create;
|
|
end;
|
|
|
|
destructor TJclGlobalModulesList.Destroy;
|
|
begin
|
|
FreeAndNil(FLock);
|
|
FreeAndNil(FModulesList);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclGlobalModulesList.CreateModulesList: TJclModuleInfoList;
|
|
var
|
|
I: Integer;
|
|
SystemModulesOnly: Boolean;
|
|
IsMultiThreaded: Boolean;
|
|
begin
|
|
IsMultiThreaded := IsMultiThread;
|
|
if IsMultiThreaded then
|
|
FLock.Enter;
|
|
try
|
|
if FModulesList = nil then
|
|
begin
|
|
SystemModulesOnly := not (stAllModules in JclStackTrackingOptions);
|
|
Result := TJclModuleInfoList.Create(False, SystemModulesOnly);
|
|
// Add known Borland modules collected by DLL exception hooking code
|
|
if SystemModulesOnly and JclHookedExceptModulesList(FHookedModules) then
|
|
for I := Low(FHookedModules) to High(FHookedModules) do
|
|
Result.AddModule(FHookedModules[I], True);
|
|
if stStaticModuleList in JclStackTrackingOptions then
|
|
FModulesList := Result;
|
|
end
|
|
else
|
|
Result := FModulesList;
|
|
finally
|
|
if IsMultiThreaded then
|
|
FLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclGlobalModulesList.FreeModulesList(var ModulesList: TJclModuleInfoList);
|
|
var
|
|
IsMultiThreaded: Boolean;
|
|
begin
|
|
if FModulesList <> ModulesList then
|
|
begin
|
|
IsMultiThreaded := IsMultiThread;
|
|
if IsMultiThreaded then
|
|
FLock.Enter;
|
|
try
|
|
FreeAndNil(ModulesList);
|
|
finally
|
|
if IsMultiThreaded then
|
|
FLock.Leave;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclGlobalModulesList.ValidateAddress(Addr: Pointer): Boolean;
|
|
var
|
|
TempList: TJclModuleInfoList;
|
|
begin
|
|
TempList := CreateModulesList;
|
|
try
|
|
Result := TempList.IsValidModuleAddress(Addr);
|
|
finally
|
|
FreeModulesList(TempList);
|
|
end;
|
|
end;
|
|
|
|
function JclValidateModuleAddress(Addr: Pointer): Boolean;
|
|
begin
|
|
Result := GlobalModulesList.ValidateAddress(Addr);
|
|
end;
|
|
|
|
//=== Stack info routines ====================================================
|
|
|
|
{$STACKFRAMES OFF}
|
|
|
|
function ValidCodeAddr(CodeAddr: DWORD; ModuleList: TJclModuleInfoList): Boolean;
|
|
begin
|
|
if stAllModules in JclStackTrackingOptions then
|
|
Result := ModuleList.IsValidModuleAddress(Pointer(CodeAddr))
|
|
else
|
|
Result := ModuleList.IsSystemModuleAddress(Pointer(CodeAddr));
|
|
end;
|
|
|
|
procedure CorrectExceptStackListTop(List: TJclStackInfoList; SkipFirstItem: Boolean);
|
|
var
|
|
TopItem, I, FoundPos: Integer;
|
|
begin
|
|
FoundPos := -1;
|
|
if SkipFirstItem then
|
|
TopItem := 1
|
|
else
|
|
TopItem := 0;
|
|
with List do
|
|
begin
|
|
for I := Count - 1 downto TopItem do
|
|
if JclBelongsHookedCode(Items[I].CallerAddr) then
|
|
begin
|
|
FoundPos := I;
|
|
Break;
|
|
end;
|
|
if FoundPos <> -1 then
|
|
for I := FoundPos downto TopItem do
|
|
Delete(I);
|
|
end;
|
|
end;
|
|
|
|
{$STACKFRAMES ON}
|
|
|
|
procedure DoExceptionStackTrace(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean;
|
|
BaseOfStack: Pointer);
|
|
var
|
|
IgnoreLevels: DWORD;
|
|
FirstCaller: Pointer;
|
|
RawMode: Boolean;
|
|
Delayed: Boolean;
|
|
begin
|
|
RawMode := stRawMode in JclStackTrackingOptions;
|
|
Delayed := stDelayedTrace in JclStackTrackingOptions;
|
|
if BaseOfStack = nil then
|
|
begin
|
|
BaseOfStack := GetFramePointer;
|
|
IgnoreLevels := 1;
|
|
end
|
|
else
|
|
IgnoreLevels := Cardinal(-1); // because of the "IgnoreLevels + 1" in TJclStackInfoList.StoreToList()
|
|
if OSException then
|
|
begin
|
|
if IgnoreLevels = Cardinal(-1) then
|
|
IgnoreLevels := 0
|
|
else
|
|
Inc(IgnoreLevels); // => HandleAnyException
|
|
FirstCaller := ExceptAddr;
|
|
end
|
|
else
|
|
FirstCaller := nil;
|
|
JclCreateStackList(RawMode, IgnoreLevels, FirstCaller, Delayed, BaseOfStack).CorrectOnAccess(OSException);
|
|
end;
|
|
|
|
function JclLastExceptStackList: TJclStackInfoList;
|
|
begin
|
|
Result := GlobalStackList.ExceptStackInfo[GetCurrentThreadID];
|
|
end;
|
|
|
|
function JclLastExceptStackListToStrings(Strings: TStrings; IncludeModuleName, IncludeAddressOffset,
|
|
IncludeStartProcLineOffset, IncludeVAddress: Boolean): Boolean;
|
|
var
|
|
List: TJclStackInfoList;
|
|
begin
|
|
List := JclLastExceptStackList;
|
|
Result := Assigned(List);
|
|
if Result then
|
|
List.AddToStrings(Strings, IncludeModuleName, IncludeAddressOffset, IncludeStartProcLineOffset,
|
|
IncludeVAddress);
|
|
end;
|
|
|
|
function JclGetExceptStackList(ThreadID: DWORD): TJclStackInfoList;
|
|
begin
|
|
Result := GlobalStackList.ExceptStackInfo[ThreadID];
|
|
end;
|
|
|
|
function JclGetExceptStackListToStrings(ThreadID: DWORD; Strings: TStrings;
|
|
IncludeModuleName: Boolean = False; IncludeAddressOffset: Boolean = False;
|
|
IncludeStartProcLineOffset: Boolean = False; IncludeVAddress: Boolean = False): Boolean;
|
|
var
|
|
List: TJclStackInfoList;
|
|
begin
|
|
List := JclGetExceptStackList(ThreadID);
|
|
Result := Assigned(List);
|
|
if Result then
|
|
List.AddToStrings(Strings, IncludeModuleName, IncludeAddressOffset, IncludeStartProcLineOffset,
|
|
IncludeVAddress);
|
|
end;
|
|
|
|
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer): TJclStackInfoList;
|
|
begin
|
|
Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, False, nil, nil);
|
|
GlobalStackList.AddObject(Result);
|
|
end;
|
|
|
|
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer;
|
|
DelayedTrace: Boolean): TJclStackInfoList;
|
|
begin
|
|
Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, DelayedTrace, nil, nil);
|
|
GlobalStackList.AddObject(Result);
|
|
end;
|
|
|
|
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer;
|
|
DelayedTrace: Boolean; BaseOfStack: Pointer): TJclStackInfoList;
|
|
begin
|
|
Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, DelayedTrace, BaseOfStack, nil);
|
|
GlobalStackList.AddObject(Result);
|
|
end;
|
|
|
|
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: DWORD; FirstCaller: Pointer;
|
|
DelayedTrace: Boolean; BaseOfStack, TopOfStack: Pointer): TJclStackInfoList;
|
|
begin
|
|
Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, DelayedTrace, BaseOfStack, TopOfStack);
|
|
GlobalStackList.AddObject(Result);
|
|
end;
|
|
|
|
function GetThreadTopOfStack(ThreadHandle: THandle): TJclAddr;
|
|
var
|
|
TBI: THREAD_BASIC_INFORMATION;
|
|
ReturnedLength: ULONG;
|
|
begin
|
|
Result := 0;
|
|
ReturnedLength := 0;
|
|
if (NtQueryInformationThread(ThreadHandle, ThreadBasicInformation, @TBI, SizeOf(TBI), @ReturnedLength) < $80000000) and
|
|
(ReturnedLength = SizeOf(TBI)) then
|
|
{$IFDEF CPU32}
|
|
Result := TJclAddr(PNT_TIB32(TBI.TebBaseAddress)^.StackBase)
|
|
{$ENDIF CPU32}
|
|
{$IFDEF CPU64}
|
|
Result := TJclAddr(PNT_TIB64(TBI.TebBaseAddress)^.StackBase)
|
|
{$ENDIF CPU64}
|
|
else
|
|
RaiseLastOSError;
|
|
end;
|
|
|
|
function JclCreateThreadStackTrace(Raw: Boolean; const ThreadHandle: THandle): TJclStackInfoList;
|
|
var
|
|
C: CONTEXT;
|
|
begin
|
|
Result := nil;
|
|
ResetMemory(C, SizeOf(C));
|
|
C.ContextFlags := CONTEXT_FULL;
|
|
{$IFDEF CPU32}
|
|
if GetThreadContext(ThreadHandle, C) then
|
|
Result := JclCreateStackList(Raw, DWORD(-1), Pointer(C.Eip), False, Pointer(C.Ebp),
|
|
Pointer(GetThreadTopOfStack(ThreadHandle)));
|
|
{$ENDIF CPU32}
|
|
{$IFDEF CPU64}
|
|
if GetThreadContext(ThreadHandle, C) then
|
|
Result := JclCreateStackList(Raw, DWORD(-1), Pointer(C.Rip), False, Pointer(C.Rbp),
|
|
Pointer(GetThreadTopOfStack(ThreadHandle)));
|
|
{$ENDIF CPU64}
|
|
end;
|
|
|
|
function JclCreateThreadStackTraceFromID(Raw: Boolean; ThreadID: DWORD): TJclStackInfoList;
|
|
type
|
|
TOpenThreadFunc = function(DesiredAccess: DWORD; InheritHandle: BOOL; ThreadID: DWORD): THandle; stdcall;
|
|
const
|
|
THREAD_GET_CONTEXT = $0008;
|
|
THREAD_QUERY_INFORMATION = $0040;
|
|
var
|
|
Kernel32Lib, ThreadHandle: THandle;
|
|
OpenThreadFunc: TOpenThreadFunc;
|
|
begin
|
|
Result := nil;
|
|
Kernel32Lib := GetModuleHandle(kernel32);
|
|
if Kernel32Lib <> 0 then
|
|
begin
|
|
// OpenThread only exists since Windows ME
|
|
OpenThreadFunc := GetProcAddress(Kernel32Lib, 'OpenThread');
|
|
if Assigned(OpenThreadFunc) then
|
|
begin
|
|
ThreadHandle := OpenThreadFunc(THREAD_GET_CONTEXT or THREAD_QUERY_INFORMATION, False, ThreadID);
|
|
if ThreadHandle <> 0 then
|
|
try
|
|
Result := JclCreateThreadStackTrace(Raw, ThreadHandle);
|
|
finally
|
|
CloseHandle(ThreadHandle);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclStackInfoItem } ==================================================
|
|
|
|
function TJclStackInfoItem.GetCallerAddr: Pointer;
|
|
begin
|
|
Result := Pointer(FStackInfo.CallerAddr);
|
|
end;
|
|
|
|
function TJclStackInfoItem.GetLogicalAddress: TJclAddr;
|
|
begin
|
|
Result := FStackInfo.CallerAddr - TJclAddr(ModuleFromAddr(CallerAddr));
|
|
end;
|
|
|
|
//=== { TJclStackInfoList } ==================================================
|
|
|
|
constructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: DWORD;
|
|
AFirstCaller: Pointer);
|
|
begin
|
|
Create(ARaw, AIgnoreLevels, AFirstCaller, False, nil, nil);
|
|
end;
|
|
|
|
constructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: DWORD;
|
|
AFirstCaller: Pointer; ADelayedTrace: Boolean);
|
|
begin
|
|
Create(ARaw, AIgnoreLevels, AFirstCaller, ADelayedTrace, nil, nil);
|
|
end;
|
|
|
|
constructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: DWORD;
|
|
AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack: Pointer);
|
|
begin
|
|
Create(ARaw, AIgnoreLevels, AFirstCaller, ADelayedTrace, ABaseOfStack, nil);
|
|
end;
|
|
|
|
constructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: DWORD;
|
|
AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack, ATopOfStack: Pointer);
|
|
var
|
|
Item: TJclStackInfoItem;
|
|
begin
|
|
inherited Create;
|
|
FIgnoreLevels := AIgnoreLevels;
|
|
FDelayedTrace := ADelayedTrace;
|
|
FRaw := ARaw;
|
|
BaseOfStack := TJclAddr(ABaseOfStack);
|
|
FStackOffset := 0;
|
|
FFramePointer := ABaseOfStack;
|
|
|
|
if ATopOfStack = nil then
|
|
TopOfStack := GetStackTop
|
|
else
|
|
TopOfStack := TJclAddr(ATopOfStack);
|
|
|
|
FModuleInfoList := GlobalModulesList.CreateModulesList;
|
|
if AFirstCaller <> nil then
|
|
begin
|
|
Item := TJclStackInfoItem.Create;
|
|
Item.FStackInfo.CallerAddr := TJclAddr(AFirstCaller);
|
|
Add(Item);
|
|
end;
|
|
if DelayedTrace then
|
|
DelayStoreStack
|
|
else
|
|
if Raw then
|
|
TraceStackRaw
|
|
else
|
|
TraceStackFrames;
|
|
end;
|
|
|
|
destructor TJclStackInfoList.Destroy;
|
|
begin
|
|
if Assigned(FStackData) then
|
|
FreeMem(FStackData);
|
|
GlobalModulesList.FreeModulesList(FModuleInfoList);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJclStackInfoList.ForceStackTracing;
|
|
begin
|
|
if DelayedTrace and Assigned(FStackData) and not FInStackTracing then
|
|
begin
|
|
FInStackTracing := True;
|
|
try
|
|
if Raw then
|
|
TraceStackRaw
|
|
else
|
|
TraceStackFrames;
|
|
if FCorrectOnAccess then
|
|
CorrectExceptStackListTop(Self, FSkipFirstItem);
|
|
finally
|
|
FInStackTracing := False;
|
|
FDelayedTrace := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJclStackInfoList.GetCount: Integer;
|
|
begin
|
|
ForceStackTracing;
|
|
Result := inherited Count;
|
|
end;
|
|
|
|
procedure TJclStackInfoList.CorrectOnAccess(ASkipFirstItem: Boolean);
|
|
begin
|
|
FCorrectOnAccess := True;
|
|
FSkipFirstItem := ASkipFirstItem;
|
|
end;
|
|
|
|
procedure TJclStackInfoList.AddToStrings(Strings: TStrings; IncludeModuleName, IncludeAddressOffset,
|
|
IncludeStartProcLineOffset, IncludeVAddress: Boolean);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
ForceStackTracing;
|
|
Strings.BeginUpdate;
|
|
try
|
|
for I := 0 to Count - 1 do
|
|
Strings.Add(GetLocationInfoStr(Items[I].CallerAddr, IncludeModuleName, IncludeAddressOffset,
|
|
IncludeStartProcLineOffset, IncludeVAddress));
|
|
finally
|
|
Strings.EndUpdate;
|
|
end;
|
|
end;
|
|
|
|
function TJclStackInfoList.GetItems(Index: Integer): TJclStackInfoItem;
|
|
begin
|
|
ForceStackTracing;
|
|
Result := TJclStackInfoItem(Get(Index));
|
|
end;
|
|
|
|
function TJclStackInfoList.NextStackFrame(var StackFrame: PStackFrame; var StackInfo: TStackInfo): Boolean;
|
|
var
|
|
CallInstructionSize: Cardinal;
|
|
StackFrameCallerFrame, NewFrame: TJclAddr;
|
|
StackFrameCallerAddr: TJclAddr;
|
|
begin
|
|
// Only report this stack frame into the StockInfo structure
|
|
// if the StackFrame pointer, the frame pointer and the return address on the stack
|
|
// are valid addresses
|
|
StackFrameCallerFrame := StackInfo.CallerFrame;
|
|
while ValidStackAddr(TJclAddr(StackFrame)) do
|
|
begin
|
|
// CallersEBP above the previous CallersEBP
|
|
NewFrame := StackFrame^.CallerFrame;
|
|
if NewFrame <= StackFrameCallerFrame then
|
|
Break;
|
|
StackFrameCallerFrame := NewFrame;
|
|
|
|
// CallerAddr within current process space, code segment etc.
|
|
// CallerFrame within current thread stack. Added Mar 12 2002 per Hallvard's suggestion
|
|
StackFrameCallerAddr := StackFrame^.CallerAddr;
|
|
if ValidCodeAddr(StackFrameCallerAddr, FModuleInfoList) and ValidStackAddr(StackFrameCallerFrame + FStackOffset) then
|
|
begin
|
|
Inc(StackInfo.Level);
|
|
StackInfo.StackFrame := StackFrame;
|
|
StackInfo.ParamPtr := PDWORD_PTRArray(TJclAddr(StackFrame) + SizeOf(TStackFrame));
|
|
|
|
if StackFrameCallerFrame > StackInfo.CallerFrame then
|
|
StackInfo.CallerFrame := StackFrameCallerFrame
|
|
else
|
|
// the frame pointer points to an address that is below
|
|
// the last frame pointer, so it must be invalid
|
|
Break;
|
|
|
|
// Calculate the address of caller by subtracting the CALL instruction size (if possible)
|
|
if ValidCallSite(StackFrameCallerAddr, CallInstructionSize) then
|
|
StackInfo.CallerAddr := StackFrameCallerAddr - CallInstructionSize
|
|
else
|
|
StackInfo.CallerAddr := StackFrameCallerAddr;
|
|
StackInfo.DumpSize := StackFrameCallerFrame - TJclAddr(StackFrame);
|
|
StackInfo.ParamSize := (StackInfo.DumpSize - SizeOf(TStackFrame)) div 4;
|
|
if PStackFrame(StackFrame^.CallerFrame) = StackFrame then
|
|
Break;
|
|
// Step to the next stack frame by following the frame pointer
|
|
StackFrame := PStackFrame(StackFrameCallerFrame + FStackOffset);
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
// Step to the next stack frame by following the frame pointer
|
|
StackFrame := PStackFrame(StackFrameCallerFrame + FStackOffset);
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TJclStackInfoList.StoreToList(const StackInfo: TStackInfo);
|
|
var
|
|
Item: TJclStackInfoItem;
|
|
begin
|
|
if ((IgnoreLevels = Cardinal(-1)) and (StackInfo.Level > 0)) or
|
|
(StackInfo.Level > (IgnoreLevels + 1)) then
|
|
begin
|
|
Item := TJclStackInfoItem.Create;
|
|
Item.FStackInfo := StackInfo;
|
|
Add(Item);
|
|
end;
|
|
end;
|
|
|
|
procedure TJclStackInfoList.TraceStackFrames;
|
|
var
|
|
StackFrame: PStackFrame;
|
|
StackInfo: TStackInfo;
|
|
begin
|
|
Capacity := 32; // reduce ReallocMem calls, must be > 1 because the caller's EIP register is already in the list
|
|
|
|
// Start at level 0
|
|
StackInfo.Level := 0;
|
|
StackInfo.CallerFrame := 0;
|
|
if DelayedTrace then
|
|
// Get the current stack frame from the frame register
|
|
StackFrame := FFramePointer
|
|
else
|
|
begin
|
|
// We define the bottom of the valid stack to be the current ESP pointer
|
|
if BaseOfStack = 0 then
|
|
BaseOfStack := TJclAddr(GetFramePointer);
|
|
// Get a pointer to the current bottom of the stack
|
|
StackFrame := PStackFrame(BaseOfStack);
|
|
end;
|
|
|
|
// We define the bottom of the valid stack to be the current frame Pointer
|
|
// There is a TIB field called pvStackUserBase, but this includes more of the
|
|
// stack than what would define valid stack frames.
|
|
BaseOfStack := TJclAddr(StackFrame) - 1;
|
|
// Loop over and report all valid stackframes
|
|
while NextStackFrame(StackFrame, StackInfo) and (inherited Count <> MaxStackTraceItems) do
|
|
StoreToList(StackInfo);
|
|
end;
|
|
|
|
function SearchForStackPtrManipulation(StackPtr: Pointer; Proc: Pointer): Pointer;
|
|
{$IFDEF SUPPORTS_INLINE}
|
|
inline;
|
|
{$ENDIF SUPPORTS_INLINE}
|
|
{var
|
|
Addr: PByteArray;}
|
|
begin
|
|
{ Addr := Proc;
|
|
while (Addr <> nil) and (DWORD_PTR(Addr) > DWORD_PTR(Proc) - $100) and not IsBadReadPtr(Addr, 6) do
|
|
begin
|
|
if (Addr[0] = $55) and // push ebp
|
|
(Addr[1] = $8B) and (Addr[2] = $EC) then // mov ebp,esp
|
|
begin
|
|
if (Addr[3] = $83) and (Addr[4] = $C4) then // add esp,c8
|
|
begin
|
|
Result := Pointer(INT_PTR(StackPtr) - ShortInt(Addr[5]));
|
|
Exit;
|
|
end;
|
|
Break;
|
|
end;
|
|
|
|
if (Addr[0] = $C2) and // ret $xxxx
|
|
(((Addr[3] = $90) and (Addr[4] = $90) and (Addr[5] = $90)) or // nop
|
|
((Addr[3] = $CC) and (Addr[4] = $CC) and (Addr[5] = $CC))) then // int 3
|
|
Break;
|
|
|
|
if (Addr[0] = $C3) and // ret
|
|
(((Addr[1] = $90) and (Addr[2] = $90) and (Addr[3] = $90)) or // nop
|
|
((Addr[1] = $CC) and (Addr[2] = $CC) and (Addr[3] = $CC))) then // int 3
|
|
Break;
|
|
|
|
if (Addr[0] = $E9) and // jmp rel-far
|
|
(((Addr[5] = $90) and (Addr[6] = $90) and (Addr[7] = $90)) or // nop
|
|
((Addr[5] = $CC) and (Addr[6] = $CC) and (Addr[7] = $CC))) then // int 3
|
|
Break;
|
|
|
|
if (Addr[0] = $EB) and // jmp rel-near
|
|
(((Addr[2] = $90) and (Addr[3] = $90) and (Addr[4] = $90)) or // nop
|
|
((Addr[2] = $CC) and (Addr[3] = $CC) and (Addr[4] = $CC))) then // int 3
|
|
Break;
|
|
|
|
Dec(DWORD_TR(Addr));
|
|
end;}
|
|
Result := StackPtr;
|
|
end;
|
|
|
|
procedure TJclStackInfoList.TraceStackRaw;
|
|
var
|
|
StackInfo: TStackInfo;
|
|
StackPtr: PJclAddr;
|
|
PrevCaller: TJclAddr;
|
|
CallInstructionSize: Cardinal;
|
|
StackTop: TJclAddr;
|
|
begin
|
|
Capacity := 32; // reduce ReallocMem calls, must be > 1 because the caller's EIP register is already in the list
|
|
|
|
if DelayedTrace then
|
|
begin
|
|
if not Assigned(FStackData) then
|
|
Exit;
|
|
StackPtr := PJclAddr(FStackData);
|
|
end
|
|
else
|
|
begin
|
|
// We define the bottom of the valid stack to be the current ESP pointer
|
|
if BaseOfStack = 0 then
|
|
BaseOfStack := TJclAddr(GetStackPointer);
|
|
// Get a pointer to the current bottom of the stack
|
|
StackPtr := PJclAddr(BaseOfStack);
|
|
end;
|
|
|
|
StackTop := TopOfStack;
|
|
|
|
if Count > 0 then
|
|
StackPtr := SearchForStackPtrManipulation(StackPtr, Pointer(Items[0].StackInfo.CallerAddr));
|
|
|
|
// We will not be able to fill in all the fields in the StackInfo record,
|
|
// so just blank it all out first
|
|
ResetMemory(StackInfo, SizeOf(StackInfo));
|
|
// Clear the previous call address
|
|
PrevCaller := 0;
|
|
// Loop through all of the valid stack space
|
|
while (TJclAddr(StackPtr) < StackTop) and (inherited Count <> MaxStackTraceItems) do
|
|
begin
|
|
// If the current DWORD on the stack refers to a valid call site...
|
|
if ValidCallSite(StackPtr^, CallInstructionSize) and (StackPtr^ <> PrevCaller) then
|
|
begin
|
|
// then pick up the callers address
|
|
StackInfo.CallerAddr := StackPtr^ - CallInstructionSize;
|
|
// remember to callers address so that we don't report it repeatedly
|
|
PrevCaller := StackPtr^;
|
|
// increase the stack level
|
|
Inc(StackInfo.Level);
|
|
// then report it back to our caller
|
|
StoreToList(StackInfo);
|
|
StackPtr := SearchForStackPtrManipulation(StackPtr, Pointer(StackInfo.CallerAddr));
|
|
end;
|
|
// Look at the next DWORD on the stack
|
|
Inc(StackPtr);
|
|
end;
|
|
if Assigned(FStackData) then
|
|
begin
|
|
FreeMem(FStackData);
|
|
FStackData := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclStackInfoList.DelayStoreStack;
|
|
var
|
|
StackPtr: PJclAddr;
|
|
StackDataSize: Cardinal;
|
|
begin
|
|
if Assigned(FStackData) then
|
|
begin
|
|
FreeMem(FStackData);
|
|
FStackData := nil;
|
|
end;
|
|
// We define the bottom of the valid stack to be the current ESP pointer
|
|
if BaseOfStack = 0 then
|
|
begin
|
|
BaseOfStack := TJclAddr(GetStackPointer);
|
|
FFramePointer := GetFramePointer;
|
|
end;
|
|
|
|
// Get a pointer to the current bottom of the stack
|
|
StackPtr := PJclAddr(BaseOfStack);
|
|
if TJclAddr(StackPtr) < TopOfStack then
|
|
begin
|
|
StackDataSize := TopOfStack - TJclAddr(StackPtr);
|
|
GetMem(FStackData, StackDataSize);
|
|
System.Move(StackPtr^, FStackData^, StackDataSize);
|
|
//CopyMemory(FStackData, StackPtr, StackDataSize);
|
|
end;
|
|
|
|
FStackOffset := TJclAddr(FStackData) - TJclAddr(StackPtr);
|
|
FFramePointer := Pointer(TJclAddr(FFramePointer) + FStackOffset);
|
|
TopOfStack := TopOfStack + FStackOffset;
|
|
end;
|
|
|
|
// Validate that the code address is a valid code site
|
|
//
|
|
// Information from Intel Manual 24319102(2).pdf, Download the 6.5 MBs from:
|
|
// http://developer.intel.com/design/pentiumii/manuals/243191.htm
|
|
// Instruction format, Chapter 2 and The CALL instruction: page 3-53, 3-54
|
|
|
|
function TJclStackInfoList.ValidCallSite(CodeAddr: TJclAddr; out CallInstructionSize: Cardinal): Boolean;
|
|
var
|
|
CodeDWORD4: DWORD;
|
|
CodeDWORD8: DWORD;
|
|
C4P, C8P: PDWORD;
|
|
RM1, RM2, RM5: Byte;
|
|
begin
|
|
// todo: 64 bit version
|
|
|
|
// First check that the address is within range of our code segment!
|
|
Result := CodeAddr > 8;
|
|
if Result then
|
|
begin
|
|
C8P := PDWORD(CodeAddr - 8);
|
|
C4P := PDWORD(CodeAddr - 4);
|
|
Result := ValidCodeAddr(TJclAddr(C8P), FModuleInfoList) and not IsBadReadPtr(C8P, 8);
|
|
|
|
// Now check to see if the instruction preceding the return address
|
|
// could be a valid CALL instruction
|
|
if Result then
|
|
begin
|
|
try
|
|
CodeDWORD8 := PDWORD(C8P)^;
|
|
CodeDWORD4 := PDWORD(C4P)^;
|
|
// CodeDWORD8 = (ReturnAddr-5):(ReturnAddr-6):(ReturnAddr-7):(ReturnAddr-8)
|
|
// CodeDWORD4 = (ReturnAddr-1):(ReturnAddr-2):(ReturnAddr-3):(ReturnAddr-4)
|
|
|
|
// ModR/M bytes contain the following bits:
|
|
// Mod = (76)
|
|
// Reg/Opcode = (543)
|
|
// R/M = (210)
|
|
RM1 := (CodeDWORD4 shr 24) and $7;
|
|
RM2 := (CodeDWORD4 shr 16) and $7;
|
|
//RM3 := (CodeDWORD4 shr 8) and $7;
|
|
//RM4 := CodeDWORD4 and $7;
|
|
RM5 := (CodeDWORD8 shr 24) and $7;
|
|
//RM6 := (CodeDWORD8 shr 16) and $7;
|
|
//RM7 := (CodeDWORD8 shr 8) and $7;
|
|
|
|
// Check the instruction prior to the potential call site.
|
|
// We consider it a valid call site if we find a CALL instruction there
|
|
// Check the most common CALL variants first
|
|
if ((CodeDWORD8 and $FF000000) = $E8000000) then
|
|
// 5 bytes, "CALL NEAR REL32" (E8 cd)
|
|
CallInstructionSize := 5
|
|
else
|
|
if ((CodeDWORD4 and $F8FF0000) = $10FF0000) and not (RM1 in [4, 5]) then
|
|
// 2 bytes, "CALL NEAR [EAX]" (FF /2) where Reg = 010, Mod = 00, R/M <> 100 (1 extra byte)
|
|
// and R/M <> 101 (4 extra bytes)
|
|
CallInstructionSize := 2
|
|
else
|
|
if ((CodeDWORD4 and $F8FF0000) = $D0FF0000) then
|
|
// 2 bytes, "CALL NEAR EAX" (FF /2) where Reg = 010 and Mod = 11
|
|
CallInstructionSize := 2
|
|
else
|
|
if ((CodeDWORD4 and $00FFFF00) = $0014FF00) then
|
|
// 3 bytes, "CALL NEAR [EAX+EAX*i]" (FF /2) where Reg = 010, Mod = 00 and RM = 100
|
|
// SIB byte not validated
|
|
CallInstructionSize := 3
|
|
else
|
|
if ((CodeDWORD4 and $00F8FF00) = $0050FF00) and (RM2 <> 4) then
|
|
// 3 bytes, "CALL NEAR [EAX+$12]" (FF /2) where Reg = 010, Mod = 01 and RM <> 100 (1 extra byte)
|
|
CallInstructionSize := 3
|
|
else
|
|
if ((CodeDWORD4 and $0000FFFF) = $000054FF) then
|
|
// 4 bytes, "CALL NEAR [EAX+EAX+$12]" (FF /2) where Reg = 010, Mod = 01 and RM = 100
|
|
// SIB byte not validated
|
|
CallInstructionSize := 4
|
|
else
|
|
if ((CodeDWORD8 and $FFFF0000) = $15FF0000) then
|
|
// 6 bytes, "CALL NEAR [$12345678]" (FF /2) where Reg = 010, Mod = 00 and RM = 101
|
|
CallInstructionSize := 6
|
|
else
|
|
if ((CodeDWORD8 and $F8FF0000) = $90FF0000) and (RM5 <> 4) then
|
|
// 6 bytes, "CALL NEAR [EAX+$12345678]" (FF /2) where Reg = 010, Mod = 10 and RM <> 100 (1 extra byte)
|
|
CallInstructionSize := 6
|
|
else
|
|
if ((CodeDWORD8 and $00FFFF00) = $0094FF00) then
|
|
// 7 bytes, "CALL NEAR [EAX+EAX+$1234567]" (FF /2) where Reg = 010, Mod = 10 and RM = 100
|
|
CallInstructionSize := 7
|
|
else
|
|
if ((CodeDWORD8 and $0000FF00) = $00009A00) then
|
|
// 7 bytes, "CALL FAR $1234:12345678" (9A ptr16:32)
|
|
CallInstructionSize := 7
|
|
else
|
|
Result := False;
|
|
// Because we're not doing a complete disassembly, we will potentially report
|
|
// false positives. If there is odd code that uses the CALL 16:32 format, we
|
|
// can also get false negatives.
|
|
except
|
|
Result := False;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFNDEF STACKFRAMES_ON}
|
|
{$STACKFRAMES OFF}
|
|
{$ENDIF ~STACKFRAMES_ON}
|
|
|
|
function TJclStackInfoList.ValidStackAddr(StackAddr: TJclAddr): Boolean;
|
|
begin
|
|
Result := (BaseOfStack < StackAddr) and (StackAddr < TopOfStack);
|
|
end;
|
|
|
|
//=== Exception frame info routines ==========================================
|
|
|
|
function JclCreateExceptFrameList(AIgnoreLevels: Integer): TJclExceptFrameList;
|
|
begin
|
|
Result := TJclExceptFrameList.Create(AIgnoreLevels);
|
|
GlobalStackList.AddObject(Result);
|
|
end;
|
|
|
|
function JclLastExceptFrameList: TJclExceptFrameList;
|
|
begin
|
|
Result := GlobalStackList.LastExceptFrameList[GetCurrentThreadID];
|
|
end;
|
|
|
|
function JclGetExceptFrameList(ThreadID: DWORD): TJclExceptFrameList;
|
|
begin
|
|
Result := GlobalStackList.LastExceptFrameList[ThreadID];
|
|
end;
|
|
|
|
procedure DoExceptFrameTrace;
|
|
begin
|
|
// Ignore first 2 levels; the First level is an undefined frame (I haven't a
|
|
// clue as to where it comes from. The second level is the try..finally block
|
|
// in DoExceptNotify.
|
|
JclCreateExceptFrameList(4);
|
|
end;
|
|
|
|
{$OVERFLOWCHECKS OFF}
|
|
|
|
function GetJmpDest(Jmp: PJmpInstruction): Pointer;
|
|
begin
|
|
// TODO : 64 bit version
|
|
if Jmp^.opCode = $E9 then
|
|
Result := Pointer(TJclAddr(Jmp) + TJclAddr(Jmp^.distance) + 5)
|
|
else
|
|
if Jmp.opCode = $EB then
|
|
Result := Pointer(TJclAddr(Jmp) + TJclAddr(ShortInt(Jmp^.distance)) + 2)
|
|
else
|
|
Result := nil;
|
|
if (Result <> nil) and (PJmpTable(Result).OPCode = $25FF) then
|
|
if not IsBadReadPtr(PJmpTable(Result).Ptr, SizeOf(Pointer)) then
|
|
Result := Pointer(PJclAddr(PJmpTable(Result).Ptr)^);
|
|
end;
|
|
|
|
{$IFDEF OVERFLOWCHECKS_ON}
|
|
{$OVERFLOWCHECKS ON}
|
|
{$ENDIF OVERFLOWCHECKS_ON}
|
|
|
|
//=== { TJclExceptFrame } ====================================================
|
|
|
|
constructor TJclExceptFrame.Create(AFrameLocation: Pointer; AExcDesc: PExcDesc);
|
|
begin
|
|
inherited Create;
|
|
FFrameKind := efkUnknown;
|
|
FFrameLocation := AFrameLocation;
|
|
FCodeLocation := nil;
|
|
AnalyseExceptFrame(AExcDesc);
|
|
end;
|
|
|
|
{$RANGECHECKS OFF}
|
|
|
|
procedure TJclExceptFrame.AnalyseExceptFrame(AExcDesc: PExcDesc);
|
|
var
|
|
Dest: Pointer;
|
|
LocInfo: TJclLocationInfo;
|
|
FixedProcedureName: string;
|
|
DotPos, I: Integer;
|
|
begin
|
|
Dest := GetJmpDest(@AExcDesc^.Jmp);
|
|
if Dest <> nil then
|
|
begin
|
|
// get frame kind
|
|
LocInfo := GetLocationInfo(Dest);
|
|
if CompareText(LocInfo.UnitName, 'system') = 0 then
|
|
begin
|
|
FixedProcedureName := LocInfo.ProcedureName;
|
|
DotPos := Pos('.', FixedProcedureName);
|
|
if DotPos > 0 then
|
|
FixedProcedureName := Copy(FixedProcedureName, DotPos + 1, Length(FixedProcedureName) - DotPos);
|
|
if CompareText(FixedProcedureName, '@HandleAnyException') = 0 then
|
|
FFrameKind := efkAnyException
|
|
else
|
|
if CompareText(FixedProcedureName, '@HandleOnException') = 0 then
|
|
FFrameKind := efkOnException
|
|
else
|
|
if CompareText(FixedProcedureName, '@HandleAutoException') = 0 then
|
|
FFrameKind := efkAutoException
|
|
else
|
|
if CompareText(FixedProcedureName, '@HandleFinally') = 0 then
|
|
FFrameKind := efkFinally;
|
|
end;
|
|
|
|
// get location
|
|
if FFrameKind <> efkUnknown then
|
|
begin
|
|
FCodeLocation := GetJmpDest(PJmpInstruction(TJclAddr(@AExcDesc^.Instructions)));
|
|
if FCodeLocation = nil then
|
|
FCodeLocation := @AExcDesc^.Instructions;
|
|
end
|
|
else
|
|
begin
|
|
FCodeLocation := GetJmpDest(PJmpInstruction(TJclAddr(AExcDesc)));
|
|
if FCodeLocation = nil then
|
|
FCodeLocation := AExcDesc;
|
|
end;
|
|
|
|
// get on handlers
|
|
if FFrameKind = efkOnException then
|
|
begin
|
|
SetLength(FExcTab, AExcDesc^.Cnt);
|
|
for I := 0 to AExcDesc^.Cnt - 1 do
|
|
begin
|
|
if AExcDesc^.ExcTab[I].VTable = nil then
|
|
begin
|
|
SetLength(FExcTab, I);
|
|
Break;
|
|
end
|
|
else
|
|
FExcTab[I] := AExcDesc^.ExcTab[I];
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF RANGECHECKS_ON}
|
|
{$RANGECHECKS ON}
|
|
{$ENDIF RANGECHECKS_ON}
|
|
|
|
function TJclExceptFrame.Handles(ExceptObj: TObject): Boolean;
|
|
var
|
|
Handler: Pointer;
|
|
begin
|
|
Result := HandlerInfo(ExceptObj, Handler);
|
|
end;
|
|
|
|
{$OVERFLOWCHECKS OFF}
|
|
|
|
function TJclExceptFrame.HandlerInfo(ExceptObj: TObject; out HandlerAt: Pointer): Boolean;
|
|
var
|
|
I: Integer;
|
|
ObjVTable, VTable, ParentVTable: Pointer;
|
|
begin
|
|
Result := FrameKind in [efkAnyException, efkAutoException];
|
|
if not Result and (FrameKind = efkOnException) then
|
|
begin
|
|
HandlerAt := nil;
|
|
ObjVTable := Pointer(ExceptObj.ClassType);
|
|
for I := Low(FExcTab) to High(FExcTab) do
|
|
begin
|
|
VTable := ObjVTable;
|
|
Result := FExcTab[I].VTable = nil;
|
|
while (not Result) and (VTable <> nil) do
|
|
begin
|
|
Result := (FExcTab[I].VTable = VTable) or
|
|
(PShortString(PPointer(PJclAddr(FExcTab[I].VTable)^ + TJclAddr(vmtClassName))^)^ =
|
|
PShortString(PPointer(TJclAddr(VTable) + TJclAddr(vmtClassName))^)^);
|
|
if Result then
|
|
HandlerAt := FExcTab[I].Handler
|
|
else
|
|
begin
|
|
ParentVTable := PPointer(TJclAddr(VTable) + TJclAddr(vmtParent))^;
|
|
if ParentVTable = VTable then
|
|
VTable := nil
|
|
else
|
|
VTable := ParentVTable;
|
|
end;
|
|
end;
|
|
if Result then
|
|
Break;
|
|
end;
|
|
end
|
|
else
|
|
if Result then
|
|
HandlerAt := FCodeLocation
|
|
else
|
|
HandlerAt := nil;
|
|
end;
|
|
|
|
{$IFDEF OVERFLOWCHECKS_ON}
|
|
{$OVERFLOWCHECKS ON}
|
|
{$ENDIF OVERFLOWCHECKS_ON}
|
|
|
|
//=== { TJclExceptFrameList } ================================================
|
|
|
|
constructor TJclExceptFrameList.Create(AIgnoreLevels: Integer);
|
|
begin
|
|
inherited Create;
|
|
FIgnoreLevels := AIgnoreLevels;
|
|
TraceExceptionFrames;
|
|
end;
|
|
|
|
function TJclExceptFrameList.AddFrame(AFrame: PExcFrame): TJclExceptFrame;
|
|
begin
|
|
Result := TJclExceptFrame.Create(AFrame, AFrame^.Desc);
|
|
Add(Result);
|
|
end;
|
|
|
|
function TJclExceptFrameList.GetItems(Index: Integer): TJclExceptFrame;
|
|
begin
|
|
Result := TJclExceptFrame(Get(Index));
|
|
end;
|
|
|
|
procedure TJclExceptFrameList.TraceExceptionFrames;
|
|
var
|
|
ExceptionPointer: PExcFrame;
|
|
Level: Integer;
|
|
ModulesList: TJclModuleInfoList;
|
|
begin
|
|
Clear;
|
|
ModulesList := GlobalModulesList.CreateModulesList;
|
|
try
|
|
Level := 0;
|
|
ExceptionPointer := GetExceptionPointer;
|
|
while TJclAddr(ExceptionPointer) <> High(TJclAddr) do
|
|
begin
|
|
if (Level >= IgnoreLevels) and ValidCodeAddr(TJclAddr(ExceptionPointer^.Desc), ModulesList) then
|
|
AddFrame(ExceptionPointer);
|
|
Inc(Level);
|
|
ExceptionPointer := ExceptionPointer^.next;
|
|
end;
|
|
finally
|
|
GlobalModulesList.FreeModulesList(ModulesList);
|
|
end;
|
|
end;
|
|
|
|
//=== Exception hooking ======================================================
|
|
|
|
var
|
|
TrackingActive: Boolean;
|
|
IgnoredExceptions: TThreadList = nil;
|
|
IgnoredExceptionClassNames: TStringList = nil;
|
|
IgnoredExceptionClassNamesCritSect: TJclCriticalSection = nil;
|
|
|
|
procedure AddIgnoredException(const ExceptionClass: TClass);
|
|
begin
|
|
if Assigned(ExceptionClass) then
|
|
begin
|
|
if not Assigned(IgnoredExceptions) then
|
|
IgnoredExceptions := TThreadList.Create;
|
|
|
|
IgnoredExceptions.Add(ExceptionClass);
|
|
end;
|
|
end;
|
|
|
|
procedure AddIgnoredExceptionByName(const AExceptionClassName: string);
|
|
begin
|
|
if AExceptionClassName <> '' then
|
|
begin
|
|
if not Assigned(IgnoredExceptionClassNamesCritSect) then
|
|
IgnoredExceptionClassNamesCritSect := TJclCriticalSection.Create;
|
|
if not Assigned(IgnoredExceptionClassNames) then
|
|
begin
|
|
IgnoredExceptionClassNames := TStringList.Create;
|
|
IgnoredExceptionClassNames.Duplicates := dupIgnore;
|
|
IgnoredExceptionClassNames.Sorted := True;
|
|
end;
|
|
IgnoredExceptionClassNamesCritSect.Enter;
|
|
try
|
|
IgnoredExceptionClassNames.Add(AExceptionClassName);
|
|
finally
|
|
IgnoredExceptionClassNamesCritSect.Leave;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure RemoveIgnoredException(const ExceptionClass: TClass);
|
|
var
|
|
ClassList: TList;
|
|
begin
|
|
if Assigned(ExceptionClass) and Assigned(IgnoredExceptions) then
|
|
begin
|
|
ClassList := IgnoredExceptions.LockList;
|
|
try
|
|
ClassList.Remove(ExceptionClass);
|
|
finally
|
|
IgnoredExceptions.UnlockList;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure RemoveIgnoredExceptionByName(const AExceptionClassName: string);
|
|
var
|
|
Index: Integer;
|
|
begin
|
|
if Assigned(IgnoredExceptionClassNames) and (AExceptionClassName <> '') then
|
|
begin
|
|
IgnoredExceptionClassNamesCritSect.Enter;
|
|
try
|
|
Index := IgnoredExceptionClassNames.IndexOf(AExceptionClassName);
|
|
if Index <> -1 then
|
|
IgnoredExceptionClassNames.Delete(Index);
|
|
finally
|
|
IgnoredExceptionClassNamesCritSect.Leave;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function IsIgnoredException(const ExceptionClass: TClass): Boolean;
|
|
var
|
|
ClassList: TList;
|
|
Index: Integer;
|
|
begin
|
|
Result := False;
|
|
if Assigned(IgnoredExceptions) and not (stTraceAllExceptions in JclStackTrackingOptions) then
|
|
begin
|
|
ClassList := IgnoredExceptions.LockList;
|
|
try
|
|
for Index := 0 to ClassList.Count - 1 do
|
|
if ExceptionClass.InheritsFrom(TClass(ClassList.Items[Index])) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
finally
|
|
IgnoredExceptions.UnlockList;
|
|
end;
|
|
end;
|
|
if not Result and Assigned(IgnoredExceptionClassNames) and not (stTraceAllExceptions in JclStackTrackingOptions) then
|
|
begin
|
|
IgnoredExceptionClassNamesCritSect.Enter;
|
|
try
|
|
Result := IgnoredExceptionClassNames.IndexOf(ExceptionClass.ClassName) <> -1;
|
|
if not Result then
|
|
for Index := 0 to IgnoredExceptionClassNames.Count - 1 do
|
|
if InheritsFromByName(ExceptionClass, IgnoredExceptionClassNames[Index]) then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
finally
|
|
IgnoredExceptionClassNamesCritSect.Leave;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure DoExceptNotify(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean;
|
|
BaseOfStack: Pointer);
|
|
begin
|
|
if TrackingActive and (not (stDisableIfDebuggerAttached in JclStackTrackingOptions) or (not IsDebuggerAttached)) and
|
|
Assigned(ExceptObj) and (not IsIgnoredException(ExceptObj.ClassType)) and
|
|
(not (stMainThreadOnly in JclStackTrackingOptions) or (GetCurrentThreadId = MainThreadID)) then
|
|
begin
|
|
if stStack in JclStackTrackingOptions then
|
|
DoExceptionStackTrace(ExceptObj, ExceptAddr, OSException, BaseOfStack);
|
|
if stExceptFrame in JclStackTrackingOptions then
|
|
DoExceptFrameTrace;
|
|
end;
|
|
end;
|
|
|
|
function JclStartExceptionTracking: Boolean;
|
|
begin
|
|
if TrackingActive then
|
|
Result := False
|
|
else
|
|
begin
|
|
Result := JclHookExceptions and JclAddExceptNotifier(DoExceptNotify, npFirstChain);
|
|
TrackingActive := Result;
|
|
end;
|
|
end;
|
|
|
|
function JclStopExceptionTracking: Boolean;
|
|
begin
|
|
if TrackingActive then
|
|
begin
|
|
Result := JclRemoveExceptNotifier(DoExceptNotify);
|
|
TrackingActive := False;
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
function JclExceptionTrackingActive: Boolean;
|
|
begin
|
|
Result := TrackingActive;
|
|
end;
|
|
|
|
function JclTrackExceptionsFromLibraries: Boolean;
|
|
begin
|
|
Result := TrackingActive;
|
|
if Result then
|
|
JclInitializeLibrariesHookExcept;
|
|
end;
|
|
|
|
//=== Thread exception tracking support ======================================
|
|
|
|
var
|
|
RegisteredThreadList: TJclDebugThreadList;
|
|
|
|
function JclDebugThreadList: TJclDebugThreadList;
|
|
begin
|
|
if RegisteredThreadList = nil then
|
|
RegisteredThreadList := TJclDebugThreadList.Create;
|
|
Result := RegisteredThreadList;
|
|
end;
|
|
|
|
type
|
|
TKernel32_CreateThread = function(SecurityAttributes: Pointer; StackSize: LongWord;
|
|
ThreadFunc: TThreadFunc; Parameter: Pointer;
|
|
CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;
|
|
TKernel32_ExitThread = procedure(ExitCode: Integer); stdcall;
|
|
|
|
var
|
|
ThreadsHooked: Boolean;
|
|
Kernel32_CreateThread: TKernel32_CreateThread = nil;
|
|
Kernel32_ExitThread: TKernel32_ExitThread = nil;
|
|
|
|
function HookedCreateThread(SecurityAttributes: Pointer; StackSize: LongWord;
|
|
ThreadFunc: TThreadFunc; Parameter: Pointer;
|
|
CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;
|
|
begin
|
|
Result := Kernel32_CreateThread(SecurityAttributes, StackSize, ThreadFunc, Parameter, CreationFlags, ThreadId);
|
|
if Result <> 0 then
|
|
JclDebugThreadList.RegisterThreadID(ThreadId);
|
|
end;
|
|
|
|
procedure HookedExitThread(ExitCode: Integer); stdcall;
|
|
begin
|
|
JclDebugThreadList.UnregisterThreadID(GetCurrentThreadID);
|
|
Kernel32_ExitThread(ExitCode);
|
|
end;
|
|
|
|
function JclHookThreads: Boolean;
|
|
var
|
|
ProcAddrCache: Pointer;
|
|
begin
|
|
if not ThreadsHooked then
|
|
begin
|
|
ProcAddrCache := GetProcAddress(GetModuleHandle(kernel32), 'CreateThread');
|
|
with TJclPeMapImgHooks do
|
|
Result := ReplaceImport(SystemBase, kernel32, ProcAddrCache, @HookedCreateThread);
|
|
if Result then
|
|
begin
|
|
@Kernel32_CreateThread := ProcAddrCache;
|
|
|
|
ProcAddrCache := GetProcAddress(GetModuleHandle(kernel32), 'ExitThread');
|
|
with TJclPeMapImgHooks do
|
|
Result := ReplaceImport(SystemBase, kernel32, ProcAddrCache, @HookedExitThread);
|
|
if Result then
|
|
@Kernel32_ExitThread := ProcAddrCache
|
|
else
|
|
with TJclPeMapImgHooks do
|
|
ReplaceImport(SystemBase, kernel32, @HookedCreateThread, @Kernel32_CreateThread);
|
|
end;
|
|
ThreadsHooked := Result;
|
|
end
|
|
else
|
|
Result := True;
|
|
end;
|
|
|
|
function JclUnhookThreads: Boolean;
|
|
begin
|
|
if ThreadsHooked then
|
|
begin
|
|
with TJclPeMapImgHooks do
|
|
begin
|
|
ReplaceImport(SystemBase, kernel32, @HookedCreateThread, @Kernel32_CreateThread);
|
|
ReplaceImport(SystemBase, kernel32, @HookedExitThread, @Kernel32_ExitThread);
|
|
end;
|
|
Result := True;
|
|
ThreadsHooked := False;
|
|
end
|
|
else
|
|
Result := True;
|
|
end;
|
|
|
|
function JclThreadsHooked: Boolean;
|
|
begin
|
|
Result := ThreadsHooked;
|
|
end;
|
|
|
|
//=== { TJclDebugThread } ====================================================
|
|
|
|
constructor TJclDebugThread.Create(ASuspended: Boolean; const AThreadName: string);
|
|
begin
|
|
FThreadName := AThreadName;
|
|
inherited Create(True);
|
|
JclDebugThreadList.RegisterThread(Self, AThreadName);
|
|
{$IFDEF RTL210_UP}
|
|
Suspended := False;
|
|
{$ELSE ~RTL210_UP}
|
|
if not ASuspended then
|
|
Resume;
|
|
{$ENDIF ~RTL210_UP}
|
|
end;
|
|
|
|
destructor TJclDebugThread.Destroy;
|
|
begin
|
|
JclDebugThreadList.UnregisterThread(Self);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJclDebugThread.DoHandleException;
|
|
begin
|
|
GlobalStackList.LockThreadID(ThreadID);
|
|
try
|
|
DoSyncHandleException;
|
|
finally
|
|
GlobalStackList.UnlockThreadID;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclDebugThread.DoNotify;
|
|
begin
|
|
JclDebugThreadList.DoSyncException(Self);
|
|
end;
|
|
|
|
procedure TJclDebugThread.DoSyncHandleException;
|
|
begin
|
|
// Note: JclLastExceptStackList and JclLastExceptFrameList returns information
|
|
// for this Thread ID instead of MainThread ID here to allow use a common
|
|
// exception handling routine easily.
|
|
// Any other call of those JclLastXXX routines from another thread at the same
|
|
// time will return expected information for current Thread ID.
|
|
DoNotify;
|
|
end;
|
|
|
|
function TJclDebugThread.GetThreadInfo: string;
|
|
begin
|
|
Result := JclDebugThreadList.ThreadInfos[ThreadID];
|
|
end;
|
|
|
|
procedure TJclDebugThread.HandleException(Sender: TObject);
|
|
begin
|
|
FSyncException := Sender;
|
|
try
|
|
if not Assigned(FSyncException) then
|
|
FSyncException := Exception(ExceptObject);
|
|
if Assigned(FSyncException) and not IsIgnoredException(FSyncException.ClassType) then
|
|
Synchronize(DoHandleException);
|
|
finally
|
|
FSyncException := nil;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclDebugThreadList } ================================================
|
|
|
|
type
|
|
TThreadAccess = class(TThread);
|
|
|
|
constructor TJclDebugThreadList.Create;
|
|
begin
|
|
FLock := TJclCriticalSection.Create;
|
|
FReadLock := TJclCriticalSection.Create;
|
|
FList := TObjectList.Create;
|
|
FSaveCreationStack := False;
|
|
end;
|
|
|
|
destructor TJclDebugThreadList.Destroy;
|
|
begin
|
|
FreeAndNil(FList);
|
|
FreeAndNil(FLock);
|
|
FreeAndNil(FReadLock);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclDebugThreadList.AddStackListToLocationInfoList(ThreadID: DWORD; AList: TJclLocationInfoList): Boolean;
|
|
var
|
|
I: Integer;
|
|
List: TJclStackInfoList;
|
|
begin
|
|
Result := False;
|
|
FReadLock.Enter;
|
|
try
|
|
I := IndexOfThreadID(ThreadID);
|
|
if (I <> -1) and Assigned(TJclDebugThreadInfo(FList[I]).StackList) then
|
|
begin
|
|
List := TJclDebugThreadInfo(FList[I]).StackList;
|
|
AList.AddStackInfoList(List);
|
|
Result := True;
|
|
end;
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.DoSyncException(Thread: TJclDebugThread);
|
|
begin
|
|
if Assigned(FOnSyncException) then
|
|
FOnSyncException(Thread);
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.DoSyncThreadRegistered;
|
|
begin
|
|
if Assigned(FOnThreadRegistered) then
|
|
FOnThreadRegistered(FRegSyncThreadID);
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.DoSyncThreadUnregistered;
|
|
begin
|
|
if Assigned(FOnThreadUnregistered) then
|
|
FOnThreadUnregistered(FUnregSyncThreadID);
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.DoThreadRegistered(Thread: TThread);
|
|
begin
|
|
if Assigned(FOnThreadRegistered) then
|
|
begin
|
|
FRegSyncThreadID := Thread.ThreadID;
|
|
TThreadAccess(Thread).Synchronize(DoSyncThreadRegistered);
|
|
end;
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.DoThreadUnregistered(Thread: TThread);
|
|
begin
|
|
if Assigned(FOnThreadUnregistered) then
|
|
begin
|
|
FUnregSyncThreadID := Thread.ThreadID;
|
|
TThreadAccess(Thread).Synchronize(DoSyncThreadUnregistered);
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadClassNames(ThreadID: DWORD): string;
|
|
begin
|
|
Result := GetThreadValues(ThreadID, 1);
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadCreationTime(ThreadID: DWORD): TDateTime;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FReadLock.Enter;
|
|
try
|
|
I := IndexOfThreadID(ThreadID);
|
|
if I <> -1 then
|
|
Result := TJclDebugThreadInfo(FList[I]).CreationTime
|
|
else
|
|
Result := 0;
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadIDCount: Integer;
|
|
begin
|
|
FReadLock.Enter;
|
|
try
|
|
Result := FList.Count;
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadHandle(Index: Integer): THandle;
|
|
begin
|
|
FReadLock.Enter;
|
|
try
|
|
Result := TJclDebugThreadInfo(FList[Index]).ThreadHandle;
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadID(Index: Integer): DWORD;
|
|
begin
|
|
FReadLock.Enter;
|
|
try
|
|
Result := TJclDebugThreadInfo(FList[Index]).ThreadID;
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadInfos(ThreadID: DWORD): string;
|
|
begin
|
|
Result := GetThreadValues(ThreadID, 2);
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadNames(ThreadID: DWORD): string;
|
|
begin
|
|
Result := GetThreadValues(ThreadID, 0);
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadParentID(ThreadID: DWORD): DWORD;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FReadLock.Enter;
|
|
try
|
|
I := IndexOfThreadID(ThreadID);
|
|
if I <> -1 then
|
|
Result := TJclDebugThreadInfo(FList[I]).ParentThreadID
|
|
else
|
|
Result := 0;
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugThreadList.GetThreadValues(ThreadID: DWORD; Index: Integer): string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FReadLock.Enter;
|
|
try
|
|
I := IndexOfThreadID(ThreadID);
|
|
if I <> -1 then
|
|
begin
|
|
case Index of
|
|
0:
|
|
Result := TJclDebugThreadInfo(FList[I]).ThreadName;
|
|
1:
|
|
Result := TJclDebugThreadInfo(FList[I]).ThreadClassName;
|
|
2:
|
|
Result := Format('%.8x [%s] "%s"', [ThreadID, TJclDebugThreadInfo(FList[I]).ThreadClassName,
|
|
TJclDebugThreadInfo(FList[I]).ThreadName]);
|
|
end;
|
|
end
|
|
else
|
|
Result := '';
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
function TJclDebugThreadList.IndexOfThreadID(ThreadID: DWORD): Integer;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := -1;
|
|
for I := FList.Count - 1 downto 0 do
|
|
if TJclDebugThreadInfo(FList[I]).ThreadID = ThreadID then
|
|
begin
|
|
Result := I;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.InternalRegisterThread(Thread: TThread; ThreadID: DWORD; const ThreadName: string);
|
|
var
|
|
I: Integer;
|
|
ThreadInfo: TJclDebugThreadInfo;
|
|
begin
|
|
FLock.Enter;
|
|
try
|
|
I := IndexOfThreadID(ThreadID);
|
|
if I = -1 then
|
|
begin
|
|
FReadLock.Enter;
|
|
try
|
|
FList.Add(TJclDebugThreadInfo.Create(GetCurrentThreadId, ThreadID, FSaveCreationStack));
|
|
ThreadInfo := TJclDebugThreadInfo(FList.Last);
|
|
if Assigned(Thread) then
|
|
begin
|
|
ThreadInfo.ThreadHandle := Thread.Handle;
|
|
ThreadInfo.ThreadClassName := Thread.ClassName;
|
|
end
|
|
else
|
|
begin
|
|
ThreadInfo.ThreadHandle := 0;
|
|
ThreadInfo.ThreadClassName := '';
|
|
end;
|
|
ThreadInfo.ThreadName := ThreadName;
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
if Assigned(Thread) then
|
|
DoThreadRegistered(Thread);
|
|
end;
|
|
finally
|
|
FLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.InternalUnregisterThread(Thread: TThread; ThreadID: DWORD);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FLock.Enter;
|
|
try
|
|
I := IndexOfThreadID(ThreadID);
|
|
if I <> -1 then
|
|
begin
|
|
if Assigned(Thread) then
|
|
DoThreadUnregistered(Thread);
|
|
FReadLock.Enter;
|
|
try
|
|
FList.Delete(I);
|
|
finally
|
|
FReadLock.Leave;
|
|
end;
|
|
end;
|
|
finally
|
|
FLock.Leave;
|
|
end;
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.RegisterThread(Thread: TThread; const ThreadName: string);
|
|
begin
|
|
InternalRegisterThread(Thread, Thread.ThreadID, ThreadName);
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.RegisterThreadID(AThreadID: DWORD);
|
|
begin
|
|
InternalRegisterThread(nil, AThreadID, '');
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.UnregisterThread(Thread: TThread);
|
|
begin
|
|
InternalUnregisterThread(Thread, Thread.ThreadID);
|
|
end;
|
|
|
|
procedure TJclDebugThreadList.UnregisterThreadID(AThreadID: DWORD);
|
|
begin
|
|
InternalUnregisterThread(nil, AThreadID);
|
|
end;
|
|
|
|
//=== { TJclDebugThreadInfo } ================================================
|
|
|
|
constructor TJclDebugThreadInfo.Create(AParentThreadID, AThreadID: DWORD; AStack: Boolean);
|
|
begin
|
|
FCreationTime := Now;
|
|
FParentThreadID := AParentThreadID;
|
|
try
|
|
{ TODO -oUSc : ... }
|
|
// FStackList := JclCreateStackList(True, 0, nil, True);//probably IgnoreLevels = 11
|
|
if AStack then
|
|
FStackList := TJclStackInfoList.Create(True, 0, nil, True, nil, nil)
|
|
else
|
|
FStackList := nil;
|
|
except
|
|
FStackList := nil;
|
|
end;
|
|
FThreadID := AThreadID;
|
|
end;
|
|
|
|
destructor TJclDebugThreadInfo.Destroy;
|
|
begin
|
|
FStackList.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
//=== { TJclCustomThreadInfo } ===============================================
|
|
|
|
constructor TJclCustomThreadInfo.Create;
|
|
var
|
|
StackClass: TJclCustomLocationInfoListClass;
|
|
begin
|
|
inherited Create;
|
|
StackClass := GetStackClass;
|
|
FCreationTime := 0;
|
|
FCreationStack := StackClass.Create;
|
|
FName := '';
|
|
FParentThreadID := 0;
|
|
FStack := StackClass.Create;
|
|
FThreadID := 0;
|
|
FValues := [];
|
|
end;
|
|
|
|
destructor TJclCustomThreadInfo.Destroy;
|
|
begin
|
|
FCreationStack.Free;
|
|
FStack.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJclCustomThreadInfo.AssignTo(Dest: TPersistent);
|
|
begin
|
|
if Dest is TJclCustomThreadInfo then
|
|
begin
|
|
TJclCustomThreadInfo(Dest).FCreationTime := FCreationTime;
|
|
TJclCustomThreadInfo(Dest).FCreationStack.Assign(FCreationStack);
|
|
TJclCustomThreadInfo(Dest).FName := FName;
|
|
TJclCustomThreadInfo(Dest).FParentThreadID := FParentThreadID;
|
|
TJclCustomThreadInfo(Dest).FStack.Assign(FStack);
|
|
TJclCustomThreadInfo(Dest).FThreadID := FThreadID;
|
|
TJclCustomThreadInfo(Dest).FValues := FValues;
|
|
end
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
function TJclCustomThreadInfo.GetStackClass: TJclCustomLocationInfoListClass;
|
|
begin
|
|
Result := TJclLocationInfoList;
|
|
end;
|
|
|
|
//=== { TJclThreadInfo } =====================================================
|
|
|
|
procedure TJclThreadInfo.Fill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions);
|
|
begin
|
|
InternalFill(AThreadHandle, AThreadID, AGatherOptions, False);
|
|
end;
|
|
|
|
procedure TJclThreadInfo.FillFromExceptThread(AGatherOptions: TJclThreadInfoOptions);
|
|
begin
|
|
InternalFill(0, GetCurrentThreadID, AGatherOptions, True);
|
|
end;
|
|
|
|
function TJclThreadInfo.GetAsString: string;
|
|
var
|
|
ExceptInfo, ThreadName, ThreadInfoStr: string;
|
|
begin
|
|
if tioIsMainThread in Values then
|
|
ThreadName := ' [MainThread]'
|
|
else
|
|
if tioName in Values then
|
|
ThreadName := Name
|
|
else
|
|
ThreadName := '';
|
|
ThreadInfoStr := '';
|
|
if tioCreationTime in Values then
|
|
ThreadInfoStr := ThreadInfoStr + Format(' CreationTime: %s', [DateTimeToStr(CreationTime)]);
|
|
if tioParentThreadID in Values then
|
|
ThreadInfoStr := ThreadInfoStr + Format(' ParentThreadID: %d', [ParentThreadID]);
|
|
ExceptInfo := Format('ThreadID: %d%s%s', [ThreadID, ThreadName, ThreadInfoStr]) + #13#10;
|
|
if tioStack in Values then
|
|
ExceptInfo := ExceptInfo + Stack.AsString;
|
|
if tioCreationStack in Values then
|
|
ExceptInfo := ExceptInfo + 'Created at:' + #13#10 + CreationStack.AsString + #13#10;
|
|
Result := ExceptInfo + #13#10;
|
|
end;
|
|
|
|
function TJclThreadInfo.GetStack(const AIndex: Integer): TJclLocationInfoList;
|
|
begin
|
|
case AIndex of
|
|
1: Result := TJclLocationInfoList(FCreationStack);
|
|
2: Result := TJclLocationInfoList(FStack);
|
|
else
|
|
Result := nil;
|
|
end;
|
|
end;
|
|
|
|
function TJclThreadInfo.GetStackClass: TJclCustomLocationInfoListClass;
|
|
begin
|
|
Result := TJclLocationInfoList;
|
|
end;
|
|
|
|
procedure TJclThreadInfo.InternalFill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions; AExceptThread: Boolean);
|
|
var
|
|
Idx: Integer;
|
|
List: TJclStackInfoList;
|
|
begin
|
|
if tioStack in AGatherOptions then
|
|
begin
|
|
if AExceptThread then
|
|
List := JclLastExceptStackList
|
|
else
|
|
List := JclCreateThreadStackTrace(True, AThreadHandle);
|
|
try
|
|
Stack.AddStackInfoList(List);
|
|
Values := Values + [tioStack];
|
|
except
|
|
{ TODO -oUSc : ... }
|
|
end;
|
|
end;
|
|
ThreadID := AThreadID;
|
|
if tioIsMainThread in AGatherOptions then
|
|
begin
|
|
if MainThreadID = AThreadID then
|
|
Values := Values + [tioIsMainThread];
|
|
end;
|
|
if AGatherOptions * [tioName, tioCreationTime, tioParentThreadID, tioCreationStack] <> [] then
|
|
Idx := JclDebugThreadList.IndexOfThreadID(AThreadID)
|
|
else
|
|
Idx := -1;
|
|
if (tioName in AGatherOptions) and (Idx <> -1) then
|
|
begin
|
|
Name := JclDebugThreadList.ThreadNames[AThreadID];
|
|
Values := Values + [tioName];
|
|
end;
|
|
if (tioCreationTime in AGatherOptions) and (Idx <> -1) then
|
|
begin
|
|
CreationTime := JclDebugThreadList.ThreadCreationTime[AThreadID];
|
|
Values := Values + [tioCreationTime];
|
|
end;
|
|
if (tioParentThreadID in AGatherOptions) and (Idx <> -1) then
|
|
begin
|
|
ParentThreadID := JclDebugThreadList.ThreadParentIDs[AThreadID];
|
|
Values := Values + [tioParentThreadID];
|
|
end;
|
|
if (tioCreationStack in AGatherOptions) and (Idx <> -1) then
|
|
begin
|
|
try
|
|
if JclDebugThreadList.AddStackListToLocationInfoList(AThreadID, CreationStack) then
|
|
Values := Values + [tioCreationStack];
|
|
except
|
|
{ TODO -oUSc : ... }
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//=== { TJclThreadInfoList } =================================================
|
|
|
|
constructor TJclThreadInfoList.Create;
|
|
begin
|
|
inherited Create;
|
|
FItems := TObjectList.Create;
|
|
FGatherOptions := [tioIsMainThread, tioName, tioCreationTime, tioParentThreadID, tioStack, tioCreationStack];
|
|
end;
|
|
|
|
destructor TJclThreadInfoList.Destroy;
|
|
begin
|
|
FItems.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJclThreadInfoList.Add: TJclThreadInfo;
|
|
begin
|
|
FItems.Add(TJclThreadInfo.Create);
|
|
Result := TJclThreadInfo(FItems.Last);
|
|
end;
|
|
|
|
procedure TJclThreadInfoList.AssignTo(Dest: TPersistent);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if Dest is TJclThreadInfoList then
|
|
begin
|
|
TJclThreadInfoList(Dest).Clear;
|
|
for I := 0 to Count - 1 do
|
|
TJclThreadInfoList(Dest).Add.Assign(Items[I]);
|
|
TJclThreadInfoList(Dest).GatherOptions := FGatherOptions;
|
|
end
|
|
else
|
|
inherited AssignTo(Dest);
|
|
end;
|
|
|
|
procedure TJclThreadInfoList.Clear;
|
|
begin
|
|
FItems.Clear;
|
|
end;
|
|
|
|
function TJclThreadInfoList.GetAsString: string;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := '';
|
|
for I := 0 to Count - 1 do
|
|
Result := Result + Items[I].AsString + #13#10;
|
|
end;
|
|
|
|
procedure TJclThreadInfoList.Gather(AExceptThreadID: DWORD);
|
|
begin
|
|
InternalGather([], [AExceptThreadID]);
|
|
end;
|
|
|
|
procedure TJclThreadInfoList.GatherExclude(AThreadIDs: array of DWORD);
|
|
begin
|
|
InternalGather([], AThreadIDs);
|
|
end;
|
|
|
|
procedure TJclThreadInfoList.GatherInclude(AThreadIDs: array of DWORD);
|
|
begin
|
|
InternalGather(AThreadIDs, []);
|
|
end;
|
|
|
|
function TJclThreadInfoList.GetCount: Integer;
|
|
begin
|
|
Result := FItems.Count;
|
|
end;
|
|
|
|
function TJclThreadInfoList.GetItems(AIndex: Integer): TJclThreadInfo;
|
|
begin
|
|
Result := TJclThreadInfo(FItems[AIndex]);
|
|
end;
|
|
|
|
procedure TJclThreadInfoList.InternalGather(AIncludeThreadIDs, AExcludeThreadIDs: array of DWORD);
|
|
|
|
function OpenThread(ThreadID: DWORD): THandle;
|
|
type
|
|
TOpenThreadFunc = function(DesiredAccess: DWORD; InheritHandle: BOOL; ThreadID: DWORD): THandle; stdcall;
|
|
const
|
|
THREAD_SUSPEND_RESUME = $0002;
|
|
THREAD_GET_CONTEXT = $0008;
|
|
THREAD_QUERY_INFORMATION = $0040;
|
|
var
|
|
Kernel32Lib: THandle;
|
|
OpenThreadFunc: TOpenThreadFunc;
|
|
begin
|
|
Result := 0;
|
|
Kernel32Lib := GetModuleHandle(kernel32);
|
|
if Kernel32Lib <> 0 then
|
|
begin
|
|
// OpenThread only exists since Windows ME
|
|
OpenThreadFunc := GetProcAddress(Kernel32Lib, 'OpenThread');
|
|
if Assigned(OpenThreadFunc) then
|
|
Result := OpenThreadFunc(THREAD_SUSPEND_RESUME or THREAD_GET_CONTEXT or THREAD_QUERY_INFORMATION, False, ThreadID);
|
|
end;
|
|
end;
|
|
|
|
function SearchThreadInArray(AThreadIDs: array of DWORD; AThreadID: DWORD): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := False;
|
|
if Length(AThreadIDs) > 0 then
|
|
for I := Low(AThreadIDs) to High(AThreadIDs) do
|
|
if AThreadIDs[I] = AThreadID then
|
|
begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
SnapProcHandle: THandle;
|
|
ThreadEntry: TThreadEntry32;
|
|
NextThread: Boolean;
|
|
ThreadIDList, ThreadHandleList: TList;
|
|
I: Integer;
|
|
PID, TID: DWORD;
|
|
ThreadHandle: THandle;
|
|
ThreadInfo: TJclThreadInfo;
|
|
begin
|
|
ThreadIDList := TList.Create;
|
|
ThreadHandleList := TList.Create;
|
|
try
|
|
SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
|
|
if SnapProcHandle <> INVALID_HANDLE_VALUE then
|
|
try
|
|
PID := GetCurrentProcessId;
|
|
ThreadEntry.dwSize := SizeOf(ThreadEntry);
|
|
NextThread := Thread32First(SnapProcHandle, ThreadEntry);
|
|
while NextThread do
|
|
begin
|
|
if ThreadEntry.th32OwnerProcessID = PID then
|
|
begin
|
|
if SearchThreadInArray(AIncludeThreadIDs, ThreadEntry.th32ThreadID) or
|
|
not SearchThreadInArray(AExcludeThreadIDs, ThreadEntry.th32ThreadID) then
|
|
ThreadIDList.Add(Pointer(ThreadEntry.th32ThreadID));
|
|
end;
|
|
NextThread := Thread32Next(SnapProcHandle, ThreadEntry);
|
|
end;
|
|
finally
|
|
CloseHandle(SnapProcHandle);
|
|
end;
|
|
for I := 0 to ThreadIDList.Count - 1 do
|
|
begin
|
|
ThreadHandle := OpenThread(TJclAddr(ThreadIDList[I]));
|
|
ThreadHandleList.Add(Pointer(ThreadHandle));
|
|
if ThreadHandle <> 0 then
|
|
SuspendThread(ThreadHandle);
|
|
end;
|
|
try
|
|
for I := 0 to ThreadIDList.Count - 1 do
|
|
begin
|
|
ThreadHandle := THandle(ThreadHandleList[I]);
|
|
TID := TJclAddr(ThreadIDList[I]);
|
|
|
|
ThreadInfo := Add;
|
|
ThreadInfo.Fill(ThreadHandle, TID, FGatherOptions);
|
|
end;
|
|
finally
|
|
for I := 0 to ThreadHandleList.Count - 1 do
|
|
if ThreadHandleList[I] <> nil then
|
|
begin
|
|
ThreadHandle := THandle(ThreadHandleList[I]);
|
|
ResumeThread(ThreadHandle);
|
|
CloseHandle(ThreadHandle);
|
|
end;
|
|
end;
|
|
finally
|
|
ThreadIDList.Free;
|
|
ThreadHandleList.Free;
|
|
end;
|
|
end;
|
|
|
|
//== Miscellanuous ===========================================================
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
|
|
function EnableCrashOnCtrlScroll(const Enable: Boolean): Boolean;
|
|
const
|
|
CrashCtrlScrollKey = 'SYSTEM\CurrentControlSet\Services\i8042prt\Parameters';
|
|
CrashCtrlScrollName = 'CrashOnCtrlScroll';
|
|
var
|
|
Enabled: Integer;
|
|
begin
|
|
Enabled := 0;
|
|
if Enable then
|
|
Enabled := 1;
|
|
RegWriteInteger(HKEY_LOCAL_MACHINE, CrashCtrlScrollKey, CrashCtrlScrollName, Enabled);
|
|
Result := RegReadInteger(HKEY_LOCAL_MACHINE, CrashCtrlScrollKey, CrashCtrlScrollName) = Enabled;
|
|
end;
|
|
|
|
function IsDebuggerAttached: Boolean;
|
|
var
|
|
IsDebuggerPresent: function: Boolean; stdcall;
|
|
KernelHandle: THandle;
|
|
P: Pointer;
|
|
begin
|
|
KernelHandle := GetModuleHandle(kernel32);
|
|
@IsDebuggerPresent := GetProcAddress(KernelHandle, 'IsDebuggerPresent');
|
|
if @IsDebuggerPresent <> nil then
|
|
begin
|
|
// Win98+ / NT4+
|
|
Result := IsDebuggerPresent
|
|
end
|
|
else
|
|
begin
|
|
// Win9x uses thunk pointer outside the module when under a debugger
|
|
P := GetProcAddress(KernelHandle, 'GetProcAddress');
|
|
Result := TJclAddr(P) < KernelHandle;
|
|
end;
|
|
end;
|
|
|
|
function IsHandleValid(Handle: THandle): Boolean;
|
|
var
|
|
Duplicate: THandle;
|
|
Flags: DWORD;
|
|
begin
|
|
if IsWinNT then
|
|
begin
|
|
Flags := 0;
|
|
Result := GetHandleInformation(Handle, Flags);
|
|
end
|
|
else
|
|
Result := False;
|
|
if not Result then
|
|
begin
|
|
// DuplicateHandle is used as an additional check for those object types not
|
|
// supported by GetHandleInformation (e.g. according to the documentation,
|
|
// GetHandleInformation doesn't support window stations and desktop although
|
|
// tests show that it does). GetHandleInformation is tried first because its
|
|
// much faster. Additionally GetHandleInformation is only supported on NT...
|
|
Result := DuplicateHandle(GetCurrentProcess, Handle, GetCurrentProcess,
|
|
@Duplicate, 0, False, DUPLICATE_SAME_ACCESS);
|
|
if Result then
|
|
Result := CloseHandle(Duplicate);
|
|
end;
|
|
end;
|
|
|
|
{$ENDIF MSWINDOWS}
|
|
|
|
initialization
|
|
DebugInfoCritSect := TJclCriticalSection.Create;
|
|
GlobalModulesList := TJclGlobalModulesList.Create;
|
|
GlobalStackList := TJclGlobalStackList.Create;
|
|
AddIgnoredException(EAbort);
|
|
{$IFDEF UNITVERSIONING}
|
|
RegisterUnitVersion(HInstance, UnitVersioning);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
finalization
|
|
{$IFDEF UNITVERSIONING}
|
|
UnregisterUnitVersion(HInstance);
|
|
{$ENDIF UNITVERSIONING}
|
|
|
|
{ TODO -oPV -cInvestigate : Calling JclStopExceptionTracking causes linking of various classes to
|
|
the code without a real need. Although there doesn't seem to be a way to unhook exceptions
|
|
safely because we need to be covered by JclHookExcept.Notifiers critical section }
|
|
JclStopExceptionTracking;
|
|
|
|
FreeAndNil(RegisteredThreadList);
|
|
FreeAndNil(DebugInfoList);
|
|
FreeAndNil(GlobalStackList);
|
|
FreeAndNil(GlobalModulesList);
|
|
FreeAndNil(DebugInfoCritSect);
|
|
FreeAndNil(InfoSourceClassList);
|
|
FreeAndNil(IgnoredExceptions);
|
|
FreeAndNil(IgnoredExceptionClassNames);
|
|
FreeAndNil(IgnoredExceptionClassNamesCritSect);
|
|
|
|
TJclDebugInfoSymbols.CleanupDebugSymbols;
|
|
|
|
end.
|