Permalink
Fetching contributors…
Cannot retrieve contributors at this time
7330 lines (6684 sloc) 224 KB
{**************************************************************************************************}
{ }
{ Project JEDI Code Library (JCL) }
{ }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
{ License at http://www.mozilla.org/MPL/ }
{ }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
{ and limitations under the License. }
{ }
{ The Original Code is JclDebug.pas. }
{ }
{ The Initial Developers of the Original Code are Petr Vones and Marcel van Brakel. }
{ Portions created by these individuals are Copyright (C) of these individuals. }
{ All Rights Reserved. }
{ }
{ Contributor(s): }
{ Marcel van Brakel }
{ Flier Lu (flier) }
{ Florent Ouchet (outchy) }
{ Robert Marquardt (marquardt) }
{ Robert Rossmair (rrossmair) }
{ Andreas Hausladen (ahuser) }
{ Petr Vones (pvones) }
{ Soeren Muehlbauer }
{ Uwe Schuster (uschuster) }
{ }
{**************************************************************************************************}
{ }
{ Various debugging support routines and classes. This includes: Diagnostics routines, Trace }
{ routines, Stack tracing and Source Locations a la the C/C++ __FILE__ and __LINE__ macros. }
{ }
{**************************************************************************************************}
{ }
{ Last modified: $Date:: $ }
{ Revision: $Rev:: $ }
{ Author: $Author:: $ }
{ }
{**************************************************************************************************}
unit JclDebug;
interface
{$I jcl.inc}
{$I windowsonly.inc}
uses
{$IFDEF UNITVERSIONING}
JclUnitVersioning,
{$ENDIF UNITVERSIONING}
{$IFDEF HAS_UNITSCOPE}
{$IFDEF MSWINDOWS}
Winapi.Windows,
{$ENDIF MSWINDOWS}
System.Classes, System.SysUtils, System.Contnrs,
{$ELSE ~HAS_UNITSCOPE}
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF MSWINDOWS}
Classes, SysUtils, Contnrs,
{$ENDIF ~HAS_UNITSCOPE}
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;
// use TraceMsg
// procedure Trace(const Msg: string);
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;
function CanHandlePublicsByName: Boolean; virtual; abstract;
function CanHandlePublicsByValue: Boolean; 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;
function CanHandlePublicsByName: Boolean; override;
function CanHandlePublicsByValue: Boolean; 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;
TJclMapStringCache = record
CachedValue: string;
RawValue: PJclMapString;
TLS: Boolean;
end;
// MAP file scanner
PJclMapSegmentClass = ^TJclMapSegmentClass;
TJclMapSegmentClass = record
Segment: Word; // segment ID
Start: DWORD; // start as in the map file
Addr: DWORD; // start as in process memory
VA: DWORD; // position relative to module base adress
Len: DWORD; // segment length
SectionName: TJclMapStringCache;
GroupName: TJclMapStringCache;
end;
PJclMapSegment = ^TJclMapSegment;
TJclMapSegment = record
Segment: Word;
StartVA: DWORD; // VA relative to (module base address + $10000)
EndVA: DWORD;
UnitName: TJclMapStringCache;
end;
PJclMapProcName = ^TJclMapProcName;
TJclMapProcName = record
Segment: Word;
VA: DWORD; // VA relative to (module base address + $10000)
ProcName: TJclMapStringCache;
end;
PJclMapLineNumber = ^TJclMapLineNumber;
TJclMapLineNumber = record
Segment: Word;
VA: DWORD; // VA relative to (module base address + $10000)
LineNumber: Integer;
UnitName: PJclMapString;
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;
FCurrentUnitName: PJclMapString;
FProcNamesCnt: Integer;
FSegmentCnt: Integer;
FLastAccessedSegementIndex: Integer;
function IndexOfSegment(Addr: DWORD): Integer;
protected
function MAPAddrToVA(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;
function CanHandlePublicsByName: Boolean; override;
function CanHandlePublicsByValue: Boolean; 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;
function GetLineNumberByIndex(Index: Integer): TJCLMapLineNumber;
public
constructor Create(const MapFileName: TFileName; Module: HMODULE); override;
class function MapStringCacheToFileName(var MapString: TJclMapStringCache): string;
class function MapStringCacheToModuleName(var MapString: TJclMapStringCache): string;
class function MapStringCacheToStr(var MapString: TJclMapStringCache; IgnoreSpaces: Boolean = False): string;
// 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;
property LineNumbersCnt: Integer read FLineNumbersCnt;
property LineNumberByIndex[Index: Integer]: TJclMapLineNumber read GetLineNumberByIndex;
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;
procedure BeginGetLocationInfoCache;
procedure EndGetLocationInfoCache;
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; OnlyProcedureName: boolean =false): 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: Integer;
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: Integer;
TopOfStack: TJclAddr;
BaseOfStack: TJclAddr;
FStackData: PPointer;
FFramePointer: Pointer;
FModuleInfoList: TJclModuleInfoList;
FCorrectOnAccess: Boolean;
FSkipFirstItem: Boolean;
FDelayedTrace: Boolean;
FInStackTracing: Boolean;
FRaw: Boolean;
FStackOffset: Int64;
{$IFDEF CPU64}
procedure CaptureBackTrace;
{$ENDIF CPU64}
function GetItems(Index: Integer): TJclStackInfoItem;
function NextStackFrame(var StackFrame: PStackFrame; var StackInfo: TStackInfo): Boolean;
procedure StoreToList(const StackInfo: TStackInfo);
procedure TraceStackFrames;
procedure TraceStackRaw;
{$IFDEF CPU32}
procedure DelayStoreStack;
{$ENDIF CPU32}
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: Integer;
AFirstCaller: Pointer); overload;
constructor Create(ARaw: Boolean; AIgnoreLevels: Integer;
AFirstCaller: Pointer; ADelayedTrace: Boolean); overload;
constructor Create(ARaw: Boolean; AIgnoreLevels: Integer;
AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack: Pointer); overload;
constructor Create(ARaw: Boolean; AIgnoreLevels: Integer;
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: Integer read FIgnoreLevels;
property Count: Integer read GetCount;
property Raw: Boolean read FRaw;
end;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer): TJclStackInfoList; overload;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;
DelayedTrace: Boolean): TJclStackInfoList; overload;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;
DelayedTrace: Boolean; BaseOfStack: Pointer): TJclStackInfoList; overload;
function JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; 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;
// helper function for DUnit runtime memory leak check
procedure JclClearGlobalStackData;
// 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
{$IFDEF HAS_EXCEPTION_STACKTRACE}
// Resolves the Exception.Stacktrace string when the exception is raised. This is more
// exact if modules are unloaded before the delayed resolving happens, but it slows down
// the exception handling if no stacktrace is needed for the exception.
, stImmediateExceptionStacktraceResolving
{$ENDIF HAS_EXCEPTION_STACKTRACE}
);
TJclStackTrackingOptions = set of TJclStackTrackingOption;
{$IFDEF HAS_EXCEPTION_STACKTRACE}
TJclExceptionStacktraceOption = (
estoIncludeModuleName,
estoIncludeAdressOffset,
estoIncludeStartProcLineOffset,
estoIncludeVAddress
);
TJclExceptionStacktraceOptions = set of TJclExceptionStacktraceOption;
{$ENDIF HAS_EXCEPTION_STACKTRACE}
var
JclStackTrackingOptions: TJclStackTrackingOptions = [stStack];
{$IFDEF HAS_EXCEPTION_STACKTRACE}
// JclExceptionStacktraceOptions controls the Exception.Stacktrace string's format
JclExceptionStacktraceOptions: TJclExceptionStacktraceOptions =
[estoIncludeModuleName, estoIncludeAdressOffset, estoIncludeStartProcLineOffset, estoIncludeVAddress];
{$ENDIF HAS_EXCEPTION_STACKTRACE}
{ 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;
// function to add additional system modules to be included in the stack trace
procedure AddModule(const ModuleName: string);
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
RCSfile: '$URL$';
Revision: '$Revision$';
Date: '$Date$';
LogPath: 'JCL\source\windows';
Extra: '';
Data: nil
);
{$ENDIF UNITVERSIONING}
implementation
uses
{$IFDEF HAS_UNITSCOPE}
System.RTLConsts,
System.Types, // for inlining TList.Remove
{$IFDEF HAS_UNIT_CHARACTER}
System.Character,
{$ENDIF HAS_UNIT_CHARACTER}
{$IFDEF SUPPORTS_GENERICS}
System.Generics.Collections,
{$ENDIF SUPPORTS_GENERICS}
{$ELSE ~HAS_UNITSCOPE}
RTLConsts,
{$IFDEF HAS_UNIT_CHARACTER}
Character,
{$ENDIF HAS_UNIT_CHARACTER}
{$IFDEF SUPPORTS_GENERICS}
Generics.Collections,
{$ENDIF SUPPORTS_GENERICS}
{$ENDIF ~HAS_UNITSCOPE}
{$IFDEF MSWINDOWS}
JclRegistry,
{$ENDIF MSWINDOWS}
JclHookExcept, JclAnsiStrings, JclStrings, JclSysInfo, JclSysUtils, JclWin32,
JclStringConversions, JclResources;
//=== Helper assembler routines ==============================================
const
ModuleCodeOffset = $1000;
var
HexMap: array[AnsiChar] of Byte;
{$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;
{$IFDEF CPU32}
function GetExceptionPointer: Pointer;
asm
XOR EAX, EAX
MOV EAX, FS:[EAX]
end;
{$ENDIF CPU32}
// 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}
{$IFDEF DELPHI64_TEMPORARY}
//TODO: check if the FS version doesn't work in general in 64-bit mode
MOV RAX, GS:[ABS 8]
{$ELSE ~DELPHI64_TEMPORARY}
MOV RAX, FS:[0].NT_TIB64.StackBase
{$ENDIF ~DELPHI64_TEMPORARY}
{$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;
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^ <> #0) and not (PEnd^ in ['=', #10, #13]) do
Inc(PEnd);
if (PEnd^ = '=') then
begin
while (PEnd >= MapString) and (PEnd^ <> ' ') do
Dec(PEnd);
while (PEnd >= MapString) and ((PEnd-1)^ = ' ') 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^ <> #0) and not (PEnd^ in ['=', #10, #13]) do
Inc(PEnd);
if (PEnd^ = '=') then
begin
while (PEnd >= MapString) and (PEnd^ <> ' ') do
Dec(PEnd);
while (PEnd >= MapString) and ((PEnd-1)^ = ' ') do
Dec(PEnd);
end;
PExtension := PEnd;
while (PExtension >= MapString) and (PExtension^ <> '.') and (PExtension^ <> '|') do
Dec(PExtension);
if (StrLICompA(PExtension, '.pas ', 5) = 0) or
(StrLICompA(PExtension, '.obj ', 5) = 0) 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^ <> #0) and not (P^ in [')', #10, #13]) do
Inc(P);
end
else
begin
P := MapString;
if IgnoreSpaces then
while (P^ <> #0) and not (P^ in ['(', #10, #13]) do
Inc(P)
else
while (P^ <> #0) and (P^ <> '(') and (P^ > ' ') do
Inc(P);
end;
SetString(Result, MapString, P - MapString);
end;
function IsDecDigit(P: PJclMapString): Boolean; {$IFDEF SUPPORTS_INLINE}inline{$ENDIF}
begin
Result := False;
case P^ of
'0'..'9':
Result := True;
end;
end;
function SkipMapBlock(P, EndPos: PJclMapString): PJclMapString;
begin
Result := P;
while Result < EndPos do
begin
if not IsDecDigit(Result) then
Break;
Inc(Result);
// Skip to the end of the line
while Result < EndPos do
begin
case Result^ of
#10, #13:
Break;
end;
Inc(Result);
end;
// Skip WhiteSpaces
while (Result < EndPos) and (Result^ <= ' ') do
Inc(Result);
end;
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;
function Eof: Boolean;
begin
Result := CurrPos >= EndPos;
end;
function SkipWhiteSpace: PJclMapString;
var
LEndPos: PJclMapString;
begin
Result := CurrPos;
LEndPos := EndPos;
while (Result < LEndPos) and (Result^ <= ' ') do
Inc(Result);
CurrPos := Result;
end;
procedure SkipEndLine;
var
P, LEndPos: PJclMapString;
begin
P := CurrPos;
LEndPos := EndPos;
while P < LEndPos do
begin
case P^ of
#10, #13:
Break;
end;
Inc(P);
end;
// Skip WhiteSpaces
while (P < LEndPos) and (P^ <= ' ') do
Inc(P);
CurrPos := P;
end;
function ReadTrimmedTextLine: string;
var
Start, P: PJclMapString;
begin
Start := CurrPos;
P := Start;
while (P^ <> #0) and not (P^ in [#10, #13]) do
Inc(P);
CurrPos := P;
// Trim
while (Start^ <> #0) and (Start^ <= ' ') do
Inc(Start);
Dec(P);
while (P > Start) and (P^ <= ' ') do
Dec(P);
Inc(P);
SetString(Result, Start, P - Start);
end;
function ReadDecValue: Integer;
var
P: PJclMapString;
begin
P := CurrPos;
Result := 0;
while P^ in ['0'..'9'] do
begin
Result := Result * 10 + (Ord(P^) - Ord('0'));
Inc(P);
end;
CurrPos := P;
end;
function ReadHexValue: DWORD;
var
C: AnsiChar;
V: Byte;
P: PJclMapString;
begin
P := CurrPos;
Result := 0;
repeat
C := P^;
V := HexMap[C];
if V and $80 <> 0 then
Break;
Result := (Result shl 4) or V;
Inc(P);
until False;
if (C = 'H') or (C = 'h') then
Inc(P);
CurrPos := P;
end;
procedure ReadAddress(var Result: TJclMapAddress);
begin
Result.Segment := ReadHexValue;
if CurrPos^ = ':' then
begin
Inc(CurrPos);
Result.Offset := ReadHexValue;
end
else
Result.Offset := 0;
end;
function ReadString: PJclMapString;
var
P, LEndPos: PJclMapString;
begin
// Skip WhiteSpaces
LEndPos := EndPos;
P := CurrPos;
while (P < LEndPos) and (P^ <= ' ') do
Inc(P);
Result := P;
while {(P^ <> #0) and} (P^ > ' ') do
Inc(P);
CurrPos := P;
end;
procedure FindParam(Param: AnsiChar);
var
P: PJclMapString;
begin
P := CurrPos;
while not ((P^ = Param) and (P[1] = '=')) do
Inc(P);
CurrPos := P + 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 := ReadTrimmedTextLine;
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;
P := CurrPos;
I := Length(Prefix);
while not Eof and (P^ <> #13) and (P^ <> #0) 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(CurrPos) do
begin
ReadAddress(A);
SkipWhiteSpace;
L := ReadHexValue;
P1 := ReadString;
P2 := ReadString;
SkipEndLine;
ClassTableItem(A, L, P1, P2);
end;
if SyncToHeader(SegmentsHeader) then
while IsDecDigit(CurrPos) do
begin
ReadAddress(A);
SkipWhiteSpace;
L := ReadHexValue;
FindParam('C');
P1 := ReadString;
FindParam('M');
P2 := ReadString;
SkipEndLine;
SegmentItem(A, L, P1, P2);
end;
if SyncToHeader(PublicsByNameHeader) then
begin
if not CanHandlePublicsByName then
CurrPos := SkipMapBlock(CurrPos, EndPos)
else
begin
while IsDecDigit(CurrPos) do
begin
ReadAddress(A);
P1 := ReadString;
SkipEndLine; // compatibility with C++Builder MAP files
PublicsByNameItem(A, P1);
end;
end;
end;
if SyncToHeader(PublicsByValueHeader) then
if not CanHandlePublicsByValue then
CurrPos := SkipMapBlock(CurrPos, EndPos)
else
begin
while not Eof and IsDecDigit(CurrPos) do
begin
ReadAddress(A);
P1 := ReadString;
SkipEndLine; // compatibility with C++Builder MAP files
PublicsByValueItem(A, P1);
end;
end;
while SyncToPrefix(LineNumbersPrefix) do
begin
FLastUnitName := CurrPos;
FLastUnitFileName := CurrPos;
while FLastUnitFileName^ <> '(' do
Inc(FLastUnitFileName);
SkipEndLine;
LineNumberUnitItem(FLastUnitName, FLastUnitFileName);
repeat
SkipWhiteSpace;
L := ReadDecValue;
SkipWhiteSpace;
ReadAddress(A);
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(CurrPos);
end;
end;
end;
//=== { TJclMapParser } ======================================================
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;
function TJclMapParser.CanHandlePublicsByName: Boolean;
begin
Result := Assigned(FOnPublicsByName);
end;
function TJclMapParser.CanHandlePublicsByValue: Boolean;
begin
Result := Assigned(FOnPublicsByValue);
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.MAPAddrToVA(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].Start > 0) and (Addr >= FSegmentClasses[0].Start) then
// Delphi 2005 and later
// The first segment should be code starting at module base address + $10000
Result := Addr - FSegmentClasses[0].Start
else
// before Delphi 2005
Result := Addr;
end;
class function TJclMapScanner.MapStringCacheToFileName(
var MapString: TJclMapStringCache): string;
begin
Result := MapString.CachedValue;
if Result = '' then
begin
Result := MapStringToFileName(MapString.RawValue);
MapString.CachedValue := Result;
end;
end;
class function TJclMapScanner.MapStringCacheToModuleName(
var MapString: TJclMapStringCache): string;
begin
Result := MapString.CachedValue;
if Result = '' then
begin
Result := MapStringToModuleName(MapString.RawValue);
MapString.CachedValue := Result;
end;
end;
class function TJclMapScanner.MapStringCacheToStr(var MapString: TJclMapStringCache;
IgnoreSpaces: Boolean): string;
begin
Result := MapString.CachedValue;
if Result = '' then
begin
Result := MapStringToStr(MapString.RawValue, IgnoreSpaces);
MapString.CachedValue := Result;
end;
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].Start := Address.Offset;
FSegmentClasses[C].Addr := Address.Offset; // will be fixed below while considering module mapped address
// test GroupName because SectionName = '.tls' in Delphi and '_tls' in BCB
if StrLICompA(GroupName, 'TLS', 3) = 0 then
begin
FSegmentClasses[C].VA := FSegmentClasses[C].Start;
FSegmentClasses[C].GroupName.TLS := True;
end
else
begin
FSegmentClasses[C].VA := MAPAddrToVA(FSegmentClasses[C].Start);
FSegmentClasses[C].GroupName.TLS := False;
end;
FSegmentClasses[C].Len := Len;
FSegmentClasses[C].SectionName.RawValue := SectionName;
FSegmentClasses[C].GroupName.RawValue := 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
if FSegmentClasses[SegIndex].GroupName.TLS then
Va := Address.Offset
else
VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);
{ 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 = Length(FLineNumbers) then
begin
if FLineNumbersCnt < 512 then
SetLength(FLineNumbers, FLineNumbersCnt + 512)
else
SetLength(FLineNumbers, FLineNumbersCnt * 2);
end;
FLineNumbers[FLineNumbersCnt].Segment := FSegmentClasses[SegIndex].Segment;
FLineNumbers[FLineNumbersCnt].VA := VA;
FLineNumbers[FLineNumbersCnt].LineNumber := LineNumber;
FLineNumbers[FLineNumbersCnt].UnitName := FCurrentUnitName;
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.RawValue := FNewUnitFileName;
FNewUnitFileName := nil;
end;
Break;
end;
if not Added then
Inc(FLineNumberErrors);
end;
procedure TJclMapScanner.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString);
begin
FNewUnitFileName := UnitFileName;
FCurrentUnitName := UnitName;
end;
function TJclMapScanner.GetLineNumberByIndex(Index: Integer): TJCLMapLineNumber;
begin
Result := FLineNumbers[Index];
end;
function TJclMapScanner.IndexOfSegment(Addr: DWORD): Integer;
var
L, R: Integer;
S: PJclMapSegment;
begin
R := Length(FSegments) - 1;
Result := FLastAccessedSegementIndex;
if Result <= R then
begin
S := @FSegments[Result];
if (S.StartVA <= Addr) and (Addr < S.EndVA) then
Exit;
end;
// binary search
L := 0;
while L <= R do
begin
Result := L + (R - L) div 2;
S := @FSegments[Result];
if Addr >= S.EndVA then
L := Result + 1
else
begin
R := Result - 1;
if (S.StartVA <= Addr) and (Addr < S.EndVA) then
begin
FLastAccessedSegementIndex := Result;
Exit;
end;
end;
end;
Result := -1;
end;
function TJclMapScanner.ModuleNameFromAddr(Addr: DWORD): string;
var
I: Integer;
begin
I := IndexOfSegment(Addr);
if I <> -1 then
Result := MapStringCacheToModuleName(FSegments[I].UnitName)
else
Result := '';
end;
function TJclMapScanner.ModuleStartFromAddr(Addr: DWORD): DWORD;
var
I: Integer;
begin
I := IndexOfSegment(Addr);
Result := DWORD(-1);
if I <> -1 then
Result := FSegments[I].StartVA;
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 := MapStringCacheToStr(FProcNames[I].ProcName, True);
Offset := Addr - FProcNames[I].VA;
end;
end;
function TJclMapScanner.CanHandlePublicsByName: Boolean;
begin
Result := False;
end;
function TJclMapScanner.CanHandlePublicsByValue: Boolean;
begin
Result := True;
end;
procedure TJclMapScanner.PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString);
begin
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 = Length(FProcNames) then
begin
if FProcNamesCnt < 512 then
SetLength(FProcNames, FProcNamesCnt + 512)
else
SetLength(FProcNames, FProcNamesCnt * 2);
end;
FProcNames[FProcNamesCnt].Segment := FSegmentClasses[SegIndex].Segment;
if FSegmentClasses[SegIndex].GroupName.TLS then
FProcNames[FProcNamesCnt].VA := Address.Offset
else
FProcNames[FProcNamesCnt].VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);
FProcNames[FProcNamesCnt].ProcName.RawValue := 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)^.EndVA) - Integer(PJclMapSegment(Item2)^.EndVA);
if Result = 0 then
Result := Integer(PJclMapSegment(Item1)^.StartVA) - Integer(PJclMapSegment(Item2)^.StartVA);
end;
type
PJclMapLineNumberArray = ^TJclMapLineNumberArray;
TJclMapLineNumberArray = array[0..MaxInt div SizeOf(TJclMapLineNumber) - 1] of TJclMapLineNumber;
PJclMapProcNameArray = ^TJclMapProcNameArray;
TJclMapProcNameArray = array[0..MaxInt div SizeOf(TJclMapProcName) - 1] of TJclMapProcName;
// specialized quicksort functions
procedure SortLineNumbers(ArrayVar: PJclMapLineNumberArray; L, R: Integer);
var
I, J, P: Integer;
Temp: TJclMapLineNumber;
AV: PJclMapLineNumber;
V: Integer;
begin
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
V := Integer(ArrayVar[P].VA);
AV := @ArrayVar[I];
while Integer(AV.VA) - V < 0 do begin Inc(I); Inc(AV); end;
AV := @ArrayVar[J];
while Integer(AV.VA) - V > 0 do begin Dec(J); Dec(AV); end;
if I <= J then
begin
if I <> J then
begin
Temp := ArrayVar[I];
ArrayVar[I] := ArrayVar[J];
ArrayVar[J] := Temp;
end;
if P = I then
P := J
else if P = J then
P := I;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
SortLineNumbers(ArrayVar, L, J);
L := I;
until I >= R;
end;
procedure SortProcNames(ArrayVar: PJclMapProcNameArray; L, R: Integer);
var
I, J, P: Integer;
Temp: TJclMapProcName;
V: Integer;
AV: PJclMapProcName;
begin
repeat
I := L;
J := R;
P := (L + R) shr 1;
repeat
V := Integer(ArrayVar[P].VA);
AV := @ArrayVar[I];
while Integer(AV.VA) - V < 0 do begin Inc(I); Inc(AV); end;
AV := @ArrayVar[J];
while Integer(AV.VA) - V > 0 do begin Dec(J); Dec(AV); end;
if I <= J then
begin
if I <> J then
begin
Temp := ArrayVar[I];
ArrayVar[I] := ArrayVar[J];
ArrayVar[J] := Temp;
end;
if P = I then
P := J
else if P = J then
P := I;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
SortProcNames(ArrayVar, L, J);
L := I;
until I >= R;
end;
procedure TJclMapScanner.Scan;
begin
FLineNumberErrors := 0;
FSegmentCnt := 0;
FProcNamesCnt := 0;
FLastAccessedSegementIndex := 0;
Parse;
SetLength(FLineNumbers, FLineNumbersCnt);
SetLength(FProcNames, FProcNamesCnt);
SetLength(FSegments, FSegmentCnt);
//SortDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Sort_MapLineNumber);
if FLineNumbers <> nil then
SortLineNumbers(PJclMapLineNumberArray(FLineNumbers), 0, Length(FLineNumbers) - 1);
//SortDynArray(FProcNames, SizeOf(FProcNames[0]), Sort_MapProcName);
if FProcNames <> nil then
SortProcNames(PJclMapProcNameArray(FProcNames), 0, Length(FProcNames) - 1);
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
if FSegmentClasses[SegIndex].GroupName.TLS then
VA := Address.Offset
else
VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);
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.RawValue := 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 := MapStringCacheToStr(FSourceNames[I].ProcName);
if Result = '' then
begin
// try with module names (C++Builder compliance)
I := IndexOfSegment(Addr);
if I <> -1 then
Result := MapStringCacheToFileName(FSegments[I].UnitName);
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] := #0;
Result := UTF8ToString(Buffer);
end;
function EncodeNameString(const S: string): AnsiString;
var
I, StartIndex, EndIndex: 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
{$IFDEF SUPPORTS_UNICODE}
Result := #1 + SimpleCryptString(UTF8Encode(S)) + #0; // UTF8Encode is much faster than StringToUTF8
{$ELSE}
Result := #1 + SimpleCryptString(StringToUTF8(S)) + #0;
{$ENDIF SUPPORTS_UNICODE}
Exit;
end;
SetLength(Result, Length(S) + StartIndex);
P := Pointer(Result);
if StartIndex = 1 then
P^ := 2 // store '@' leading char information
else
Dec(P);
EndIndex := Length(S) - StartIndex;
for I := 0 to EndIndex do // including null char
begin
if I = EndIndex then
C := 0
else
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 Byte(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;
function InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;
BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;
out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean;
var
ImageStream: TStream;
NtHeaders32: TImageNtHeaders32;
NtHeaders64: TImageNtHeaders64;
ImageSectionHeaders: TImageSectionHeaderArray;
NtHeadersPosition, ImageSectionHeadersPosition, JclDebugSectionPosition: Int64;
JclDebugSection: TImageSectionHeader;
LastSection: PImageSectionHeader;
VirtualAlignedSize: DWORD;
NeedFill: Integer;
procedure RoundUpToAlignment(var Value: DWORD; Alignment: DWORD);
begin
if (Value mod Alignment) <> 0 then
Value := ((Value div Alignment) + 1) * Alignment;
end;
procedure MovePointerToRawData(AOffset: DWORD);
var
I: Integer;
begin
for I := Low(ImageSectionHeaders) to High(ImageSectionHeaders) do
ImageSectionHeaders[I].PointerToRawData := ImageSectionHeaders[I].PointerToRawData + AOffset;
end;
procedure FillZeros(AStream: TStream; ACount: Integer);
var
I: Integer;
X: array[0..511] of Byte;
begin
if ACount > 0 then
begin
if ACount > Length(X) then
FillChar(X, SizeOf(X), 0)
else
FillChar(X, ACount, 0);
while ACount > 0 do
begin
I := ACount;
if I > SizeOf(X) then
I := SizeOf(X);
AStream.WriteBuffer(X, I);
Dec(ACount, I);
end;
end;
end;
procedure WriteSectionHeaders(AStream: TStream; APosition: Integer);
var
HeaderSize: Integer;
begin
HeaderSize := SizeOf(TImageSectionHeader) * Length(ImageSectionHeaders);
if (AStream.Seek(APosition, soFromBeginning) <> APosition) or
(AStream.Write(ImageSectionHeaders[0], HeaderSize) <> HeaderSize) then
raise EJclPeImageError.CreateRes(@SWriteError);
FillZeros(AStream, ImageSectionHeaders[0].PointerToRawData - AStream.Position);
end;
procedure MoveData(AStream: TStream; AStart, AOffset: Integer);
var
CurPos: Integer;
CurSize: Integer;
Buffer: array of Byte;
StartPos: Integer;
begin
SetLength(Buffer, 1024 * 1024);
CurPos := AStream.Size - Length(Buffer);
StartPos := ImageSectionHeaders[0].PointerToRawData;
while CurPos > StartPos do
begin
if (AStream.Seek(CurPos, soBeginning) <> CurPos) or
(AStream.Read(Buffer[0], Length(Buffer)) <> Length(Buffer)) then
raise EJclPeImageError.CreateRes(@SReadError);
if (AStream.Seek(CurPos + AOffset, soBeginning) <> CurPos + AOffset) or
(AStream.Write(Buffer[0], Length(Buffer)) <> Length(Buffer)) then
raise EJclPeImageError.CreateRes(@SWriteError);
Dec(CurPos, Length(Buffer));
end;
CurSize := Length(Buffer) + CurPos - StartPos;
if (AStream.Seek(StartPos, soBeginning) <> StartPos) or
(AStream.Read(Buffer[0], CurSize) <> CurSize) then
raise EJclPeImageError.CreateRes(@SReadError);
if (AStream.Seek(StartPos + AOffset, soBeginning) <> StartPos + AOffset) or
(AStream.Write(Buffer[0], CurSize) <> CurSize) then
raise EJclPeImageError.CreateRes(@SWriteError);
end;
procedure CheckHeadersSpace(AStream: TStream);
begin
if ImageSectionHeaders[0].PointerToRawData < ImageSectionHeadersPosition +
(SizeOf(TImageSectionHeader) * (Length(ImageSectionHeaders) + 1)) then
begin
MoveData(AStream, ImageSectionHeaders[0].PointerToRawData, NtHeaders64.OptionalHeader.FileAlignment);
MovePointerToRawData(NtHeaders64.OptionalHeader.FileAlignment);
WriteSectionHeaders(AStream, ImageSectionHeadersPosition);
end;
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 := TFileStream.Create(ExecutableFileName, fmOpenReadWrite or fmShareExclusive);
try
try
MapFileSize := BinDebug.Stream.Size;
JclDebugDataSize := BinDebug.DataStream.Size;
VirtualAlignedSize := JclDebugDataSize;
// JCLDEBUG
ResetMemory(JclDebugSection, SizeOf(JclDebugSection));
// JCLDEBUG Virtual Size
JclDebugSection.Misc.VirtualSize := JclDebugDataSize;
// JCLDEBUG Raw data size
JclDebugSection.SizeOfRawData := JclDebugDataSize;
// JCLDEBUG Section name
Move(JclDbgDataResName, JclDebugSection.Name, IMAGE_SIZEOF_SHORT_NAME);
// JCLDEBUG Characteristics flags
JclDebugSection.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;
case PeMapImgTarget(ImageStream, 0) of
taWin32:
begin
NtHeadersPosition := PeMapImgNtHeaders32(ImageStream, 0, NtHeaders32);
Assert(NtHeadersPosition <> -1);
ImageSectionHeadersPosition := PeMapImgSections32(ImageStream, NtHeadersPosition, NtHeaders32, ImageSectionHeaders);
Assert(ImageSectionHeadersPosition <> -1);
// Check whether there is not a section with the name already. If so, return True (0000069)
if PeMapImgFindSection(ImageSectionHeaders, JclDbgDataResName) <> -1 then
begin
Result := True;
Exit;
end;
JclDebugSectionPosition := ImageSectionHeadersPosition + (SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders));
LastSection := @ImageSectionHeaders[High(ImageSectionHeaders)];
// Increase the number of sections
Inc(NtHeaders32.FileHeader.NumberOfSections);
// JCLDEBUG Virtual Address
JclDebugSection.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;
// JCLDEBUG Physical Offset
JclDebugSection.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;
// JCLDEBUG section rounding :
RoundUpToAlignment(JclDebugSection.VirtualAddress, NtHeaders32.OptionalHeader.SectionAlignment);
RoundUpToAlignment(JclDebugSection.PointerToRawData, NtHeaders32.OptionalHeader.FileAlignment);
RoundUpToAlignment(JclDebugSection.SizeOfRawData, NtHeaders32.OptionalHeader.FileAlignment);
// Size of virtual data area
RoundUpToAlignment(VirtualAlignedSize, NtHeaders32.OptionalHeader.SectionAlignment);
// Update Size of Image
Inc(NtHeaders32.OptionalHeader.SizeOfImage, VirtualAlignedSize);
// Update Initialized data size
Inc(NtHeaders32.OptionalHeader.SizeOfInitializedData, JclDebugSection.SizeOfRawData);
// write NT Headers 32
if (ImageStream.Seek(NtHeadersPosition, soBeginning) <> NtHeadersPosition) or
(ImageStream.Write(NtHeaders32, SizeOf(NtHeaders32)) <> SizeOf(NtHeaders32)) then
raise EJclPeImageError.CreateRes(@SWriteError);
end;
taWin64:
begin
NtHeadersPosition := PeMapImgNtHeaders64(ImageStream, 0, NtHeaders64);
Assert(NtHeadersPosition <> -1);
ImageSectionHeadersPosition := PeMapImgSections64(ImageStream, NtHeadersPosition, NtHeaders64, ImageSectionHeaders);
Assert(ImageSectionHeadersPosition <> -1);
// Check whether there is not a section with the name already. If so, return True (0000069)
if PeMapImgFindSection(ImageSectionHeaders, JclDbgDataResName) <> -1 then
begin
Result := True;
Exit;
end;
// Check if there is enough space for additional header
CheckHeadersSpace(ImageStream);
JclDebugSectionPosition := ImageSectionHeadersPosition + (SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders));
LastSection := @ImageSectionHeaders[High(ImageSectionHeaders)];
// Increase the number of sections
Inc(NtHeaders64.FileHeader.NumberOfSections);
// JCLDEBUG Virtual Address
JclDebugSection.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;
// JCLDEBUG Physical Offset
JclDebugSection.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;
// JCLDEBUG section rounding :
RoundUpToAlignment(JclDebugSection.VirtualAddress, NtHeaders64.OptionalHeader.SectionAlignment);
RoundUpToAlignment(JclDebugSection.PointerToRawData, NtHeaders64.OptionalHeader.FileAlignment);
RoundUpToAlignment(JclDebugSection.SizeOfRawData, NtHeaders64.OptionalHeader.FileAlignment);
// Size of virtual data area
RoundUpToAlignment(VirtualAlignedSize, NtHeaders64.OptionalHeader.SectionAlignment);
// Update Size of Image
Inc(NtHeaders64.OptionalHeader.SizeOfImage, VirtualAlignedSize);
// Update Initialized data size
Inc(NtHeaders64.OptionalHeader.SizeOfInitializedData, JclDebugSection.SizeOfRawData);
// write NT Headers 64
if (ImageStream.Seek(NtHeadersPosition, soBeginning) <> NtHeadersPosition) or
(ImageStream.Write(NtHeaders64, SizeOf(NtHeaders64)) <> SizeOf(NtHeaders64)) then
raise EJclPeImageError.CreateRes(@SWriteError);
end;
else
Result := False;
Exit;
end;
// write section header
if (ImageStream.Seek(JclDebugSectionPosition, soBeginning) <> JclDebugSectionPosition) or
(ImageStream.Write(JclDebugSection, SizeOf(JclDebugSection)) <> SizeOf(JclDebugSection)) then
raise EJclPeImageError.CreateRes(@SWriteError);
// 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({0 +} JclDebugSection.PointerToRawData, soBeginning);
ImageStream.CopyFrom(BinDebug.DataStream, 0);
FillZeros(ImageStream, NeedFill);
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
{$IFDEF SUPPORTS_GENERICS}
WordList: TDictionary<string, Integer>;
{$ELSE}
WordList: TStringList;
{$ENDIF SUPPORTS_GENERICS}
WordStream: TMemoryStream;
LastSegmentID: Word;
LastSegmentStored: Boolean;
function AddWord(const S: string): Integer;
var
{$IFDEF SUPPORTS_GENERICS}
LowerS: string;
{$ELSE}
N: Integer;
{$ENDIF SUPPORTS_GENERICS}
E: AnsiString;
begin
if S = '' then
begin
Result := 0;
Exit;
end;
{$IFDEF SUPPORTS_GENERICS}
LowerS := AnsiLowerCase(S);
if not WordList.TryGetValue(LowerS, Result) then
begin
Result := WordStream.Position;
E := EncodeNameString(S);
WordStream.Write(E[1], Length(E));
WordList.Add(LowerS, Result);
end;
{$ELSE} // for large map files this is very slow
N := WordList.IndexOf(S);
if N = -1 then
begin
Result := WordStream.Position;
E := EncodeNameString(S);
WordStream.Write(E[1], Length(E));
WordList.AddObject(S, TObject(Result));
end
else
Result := DWORD(WordList.Objects[N]);
{$ENDIF SUPPORTS_GENERICS}
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.Write(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 := MapStringCacheToStr(FSegmentClasses[SegIndex].GroupName);
LastSegmentStored := (GroupName = 'CODE') or (GroupName = 'ICODE');
Break;
end;
end;
Result := LastSegmentStored;
end;
const
AlignBytes: array[0..2] of Byte = (0, 0, 0);
var
FileHeader: TJclDbgHeader;
I, D: Integer;
S: string;
L1, L2, L3: Integer;
FirstWord, SecondWord: Integer;
WordStreamSize, DataStreamSize: Int64;
begin
LastSegmentID := $FFFF;
WordStream := TMemoryStream.Create;
{$IFDEF SUPPORTS_GENERICS}
WordList := TDictionary<string, Integer>.Create(Length(FSourceNames) + Length(FProcNames));
{$ELSE}
WordList := TStringList.Create;
{$ENDIF SUPPORTS_GENERICS}
try
{$IFNDEF SUPPORTS_GENERICS}
WordList.Sorted := True;
WordList.Duplicates := dupError;
{$ENDIF ~SUPPORTS_GENERICS}
WordStream.SetSize((Length(FSourceNames) + Length(FProcNames)) * 40); // take an average of 40 chars per identifier
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(MapStringCacheToModuleName(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(MapStringCacheToStr(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 := MapStringCacheToStr(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;
// Calculate and allocate the required size in advance instead of reallocating on the fly.
WordStreamSize := WordStream.Position;
DataStreamSize := FDataStream.Position + WordStreamSize;
DataStreamSize := DataStreamSize + (4 - (DataStreamSize and $3));
FDataStream.Size := DataStreamSize; // set capacity
WordStream.Position := 0;
FDataStream.CopyFrom(WordStream, WordStreamSize);
// Align to 4 bytes
FDataStream.WriteBuffer(AlignBytes, 4 - (FDataStream.Position and $3));
if FDataStream.Size <> FDataStream.Position then // just in case something changed without adjusting the size calculation
FDataStream.Size := FDataStream.Position;
// Update the file header
FDataStream.Seek(0, soBeginning);
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) - TJclAddr(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 {$IFDEF CPUX64}+ 8{$ENDIF});
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) - TJclAddr(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[CachedModuleFromAddr(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