{**************************************************************************************************}
{ }
{ 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 JclTD32.pas. }
{ }
{ The Initial Developers of the Original Code are documented in the accompanying help file }
{ JCLHELP.hlp. Portions created by these individuals are Copyright (C) of these individuals. }
{ }
{**************************************************************************************************}
{ }
{ Borland TD32 symbolic debugging information support routines and classes. }
{ }
{ Unit owner: Flier Lu }
{ }
{**************************************************************************************************}
// $Id: JclTD32.pas,v 1.2 2004/04/14 21:55:07 druid Exp $
unit JclTD32;
interface
{$I jcl.inc}
{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}
{$WEAKPACKAGEUNIT ON}
{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF MSWINDOWS}
Classes, SysUtils, Contnrs,
JclBase, JclFileUtils, JclPeImage;
{ TODO -cDOC : Original code: "Flier Lu" <flier_lu@yahoo.com.cn> }
//--------------------------------------------------------------------------------------------------
// TD32 constants and structures
//--------------------------------------------------------------------------------------------------
{*******************************************************************************
[-----------------------------------------------------------------------]
[ Symbol and Type OMF Format Borland Executable Files ]
[-----------------------------------------------------------------------]
Introduction
This section describes the format used to embed debugging information into
the executable file.
Debug Information Format
The format encompasses a block of data which goes at the end of the .EXE
file, i.e., after the header plus load image, overlays, and
Windows/Presentation Manager resource compiler information. The lower
portion of the file is unaffected by the additional data.
The last eight bytes of the file contain a signature and a long file offset
from the end of the file (lfoBase). The signature is FBxx, where xx is the
version number. The long offset indicates the position in the file
(relative to the end of the file) of the base address. For the LX format
executables, the base address is determined by looking at the executable
header.
The signatures have the following meanings:
FB09 The signature for a Borland 32 bit symbol file.
The value
lfaBase=length of the file - lfoBase
gives the base address of the start of the Symbol and Type OMF information
relative to the beginning of the file. All other file offsets in the
Symbol and Type OMF are relative to the lfaBase. At the base address the
signature is repeated, followed by the long displacement to the subsection
directory (lfoDir). All subsections start on a long word boundary and are
designed to maintain natural alignment internally in each subsection and
within the subsection directory.
Subsection Directory
The subsection directory has the format
Directory header
Directory entry 0
Directory entry 1
.
.
.
Directory entry n
There is no requirement for a particular subsection of a particular module to exist.
The following is the layout of the FB09 debug information in the image:
FB09 Header
sstModule [1]
.
.
.
sstModule [n]
sstAlignSym [1]
sstSrcModule [1]
.
.
.
sstAlignSym [n]
sstSrcModule [n]
sstGlobalSym
sstGlobalTypes
sstNames
SubSection Directory
FB09 Trailer
*******************************************************************************}
const
Borland32BitSymbolFileSignatureForDelphi = $39304246; // 'FB09'
Borland32BitSymbolFileSignatureForBCB = $41304246; // 'FB0A'
type
{ Signature structure }
PJclTD32FileSignature = ^TJclTD32FileSignature;
TJclTD32FileSignature = packed record
Signature: DWORD;
Offset: DWORD;
end;
const
{ Subsection Types }
SUBSECTION_TYPE_MODULE = $120;
SUBSECTION_TYPE_TYPES = $121;
SUBSECTION_TYPE_SYMBOLS = $124;
SUBSECTION_TYPE_ALIGN_SYMBOLS = $125;
SUBSECTION_TYPE_SOURCE_MODULE = $127;
SUBSECTION_TYPE_GLOBAL_SYMBOLS = $129;
SUBSECTION_TYPE_GLOBAL_TYPES = $12B;
SUBSECTION_TYPE_NAMES = $130;
type
{ Subsection directory header structure }
{ The directory header structure is followed by the directory entries
which specify the subsection type, module index, file offset, and size.
The subsection directory gives the location (LFO) and size of each subsection,
as well as its type and module number if applicable. }
PDirectoryEntry = ^TDirectoryEntry;
TDirectoryEntry = packed record
SubsectionType: Word; // Subdirectory type
ModuleIndex: Word; // Module index
Offset: DWORD; // Offset from the base offset lfoBase
Size: DWORD; // Number of bytes in subsection
end;
{ The subsection directory is prefixed with a directory header structure
indicating size and number of subsection directory entries that follow. }
PDirectoryHeader = ^TDirectoryHeader;
TDirectoryHeader = packed record
Size: Word; // Length of this structure
DirEntrySize: Word; // Length of each directory entry
DirEntryCount: DWORD; // Number of directory entries
lfoNextDir: DWORD; // Offset from lfoBase of next directory.
Flags: DWORD; // Flags describing directory and subsection tables.
DirEntries: array [0..0] of TDirectoryEntry;
end;
{*******************************************************************************
SUBSECTION_TYPE_MODULE $120
This describes the basic information about an object module including code
segments, module name, and the number of segments for the modules that
follow. Directory entries for sstModules precede all other subsection
directory entries.
*******************************************************************************}
type
PSegmentInfo = ^TSegmentInfo;
TSegmentInfo = packed record
Segment: Word; // Segment that this structure describes
Flags: Word; // Attributes for the logical segment.
// The following attributes are defined:
// $0000 Data segment
// $0001 Code segment
Offset: DWORD; // Offset in segment where the code starts
Size: DWORD; // Count of the number of bytes of code in the segment
end;
PSegmentInfoArray = ^TSegmentInfoArray;
TSegmentInfoArray = array [0..32767] of TSegmentInfo;
PModuleInfo = ^TModuleInfo;
TModuleInfo = packed record
OverlayNumber: Word; // Overlay number
LibraryIndex: Word; // Index into sstLibraries subsection
// if this module was linked from a library
SegmentCount: Word; // Count of the number of code segments
// this module contributes to
DebuggingStyle: Word; // Debugging style for this module.
NameIndex: DWORD; // Name index of module.
TimeStamp: DWORD; // Time stamp from the OBJ file.
Reserved: array [0..2] of DWORD; // Set to 0.
Segments: array [0..0] of TSegmentInfo;
// Detailed information about each segment
// that code is contributed to.
// This is an array of cSeg count segment
// information descriptor structures.
end;
{*******************************************************************************
SUBSECTION_TYPE_SOURCE_MODULE $0127
This table describes the source line number to addressing mapping
information for a module. The table permits the description of a module
containing multiple source files with each source file contributing code to
one or more code segments. The base addresses of the tables described
below are all relative to the beginning of the sstSrcModule table.
Module header
Information for source file 1
Information for segment 1
.
.
.
Information for segment n
.
.
.
Information for source file n
Information for segment 1
.
.
.
Information for segment n
*******************************************************************************}
type
{ The line number to address mapping information is contained in a table with
the following format: }
PLineMappingEntry = ^TLineMappingEntry;
TLineMappingEntry = packed record
SegmentIndex: Word; // Segment index for this table
PairCount: Word; // Count of the number of source line pairs to follow
Offsets: array [0..0] of DWORD;
// An array of 32-bit offsets for the offset
// within the code segment ofthe start of ine contained
// in the parallel array linenumber.
(*
{ This is an array of 16-bit line numbers of the lines in the source file
that cause code to be emitted to the code segment.
This array is parallel to the offset array.
If cPair is not even, then a zero word is emitted to
maintain natural alignment in the sstSrcModule table. }
LineNumbers: array [0..PairCount - 1] of Word;
*)
end;
TOffsetPair = packed record
StartOffset: DWORD;
EndOffset: DWORD;
end;
POffsetPairArray = ^TOffsetPairArray;
TOffsetPairArray = array [0..32767] of TOffsetPair;
{ The file table describes the code segments that receive code from this
source file. Source file entries have the following format: }
PSourceFileEntry = ^TSourceFileEntry;
TSourceFileEntry = packed record
SegmentCount: Word; // Number of segments that receive code from this source file.
NameIndex: DWORD; // Name index of Source file name.
BaseSrcLines: array [0..0] of DWORD;
// An array of offsets for the line/address mapping
// tables for each of the segments that receive code
// from this source file.
(*
{ An array of two 32-bit offsets per segment that
receives code from this module. The first offset
is the offset within the segment of the first byte
of code from this module. The second offset is the
ending address of the code from this module. The
order of these pairs corresponds to the ordering of
the segments in the seg array. Zeros in these
entries means that the information is not known and
the file and line tables described below need to be
examined to determine if an address of interest is
contained within the code from this module. }
SegmentAddress: array [0..SegmentCount - 1] of TOffsetPair;
Name: ShortString; // Count of the number of bytes in source file name
*)
end;
{ The module header structure describes the source file and code segment
organization of the module. Each module header has the following format: }
PSourceModuleInfo = ^TSourceModuleInfo;
TSourceModuleInfo = packed record
FileCount: Word; // The number of source file scontributing code to segments
SegmentCount: Word; // The number of code segments receiving code from this module
BaseSrcFiles: array [0..0] of DWORD;
(*
// This is an array of base offsets from the beginning of the sstSrcModule table
BaseSrcFiles: array [0..FileCount - 1] of DWORD;
{ An array of two 32-bit offsets per segment that
receives code from this module. The first offset
is the offset within the segment of the first byte
of code from this module. The second offset is the
ending address of the code from this module. The
order of these pairs corresponds to the ordering of
the segments in the seg array. Zeros in these
entries means that the information is not known and
the file and line tables described below need to be
examined to determine if an address of interest is
contained within the code from this module. }
SegmentAddress: array [0..SegmentCount - 1] of TOffsetPair;
{ An array of segment indices that receive code from
this module. If the number of segments is not
even, a pad word is inserted to maintain natural
alignment. }
SegmentIndexes: array [0..SegmentCount - 1] of Word;
*)
end;
{*******************************************************************************
SUBSECTION_TYPE_GLOBAL_TYPES $12b
This subsection contains the packed type records for the executable file.
The first long word of the subsection contains the number of types in the
table. This count is followed by a count-sized array of long offsets to
the corresponding type record. As the sstGlobalTypes subsection is
written, each type record is forced to start on a long word boundary.
However, the length of the type string is NOT adjusted by the pad count.
The remainder of the subsection contains the type records.
*******************************************************************************}
type
PGlobalTypeInfo = ^TGlobalTypeInfo;
TGlobalTypeInfo = packed record
Count: DWORD; // count of the number of types
// offset of each type string from the beginning of table
Offsets: array [0..0] of DWORD;
end;
const
{ Symbol type defines }
SYMBOL_TYPE_COMPILE = $0001; // Compile flags symbol
SYMBOL_TYPE_REGISTER = $0002; // Register variable
SYMBOL_TYPE_CONST = $0003; // Constant symbol
SYMBOL_TYPE_UDT = $0004; // User-defined Type
SYMBOL_TYPE_SSEARCH = $0005; // Start search
SYMBOL_TYPE_END = $0006; // End block, procedure, with, or thunk
SYMBOL_TYPE_SKIP = $0007; // Skip - Reserve symbol space
SYMBOL_TYPE_CVRESERVE = $0008; // Reserved for Code View internal use
SYMBOL_TYPE_OBJNAME = $0009; // Specify name of object file
SYMBOL_TYPE_BPREL16 = $0100; // BP relative 16:16
SYMBOL_TYPE_LDATA16 = $0101; // Local data 16:16
SYMBOL_TYPE_GDATA16 = $0102; // Global data 16:16
SYMBOL_TYPE_PUB16 = $0103; // Public symbol 16:16
SYMBOL_TYPE_LPROC16 = $0104; // Local procedure start 16:16
SYMBOL_TYPE_GPROC16 = $0105; // Global procedure start 16:16
SYMBOL_TYPE_THUNK16 = $0106; // Thunk start 16:16
SYMBOL_TYPE_BLOCK16 = $0107; // Block start 16:16
SYMBOL_TYPE_WITH16 = $0108; // With start 16:16
SYMBOL_TYPE_LABEL16 = $0109; // Code label 16:16
SYMBOL_TYPE_CEXMODEL16 = $010A; // Change execution model 16:16
SYMBOL_TYPE_VFTPATH16 = $010B; // Virtual function table path descriptor 16:16
SYMBOL_TYPE_BPREL32 = $0200; // BP relative 16:32
SYMBOL_TYPE_LDATA32 = $0201; // Local data 16:32
SYMBOL_TYPE_GDATA32 = $0202; // Global data 16:32
SYMBOL_TYPE_PUB32 = $0203; // Public symbol 16:32
SYMBOL_TYPE_LPROC32 = $0204; // Local procedure start 16:32
SYMBOL_TYPE_GPROC32 = $0205; // Global procedure start 16:32
SYMBOL_TYPE_THUNK32 = $0206; // Thunk start 16:32
SYMBOL_TYPE_BLOCK32 = $0207; // Block start 16:32
SYMBOL_TYPE_WITH32 = $0208; // With start 16:32
SYMBOL_TYPE_LABEL32 = $0209; // Label 16:32
SYMBOL_TYPE_CEXMODEL32 = $020A; // Change execution model 16:32
SYMBOL_TYPE_VFTPATH32 = $020B; // Virtual function table path descriptor 16:32
{*******************************************************************************
Global and Local Procedure Start 16:32
SYMBOL_TYPE_LPROC32 $0204
SYMBOL_TYPE_GPROC32 $0205
The symbol records define local (file static) and global procedure
definition. For C/C++, functions that are declared static to a module are
emitted as Local Procedure symbols. Functions not specifically declared
static are emitted as Global Procedures.
For each SYMBOL_TYPE_GPROC32 emitted, an SYMBOL_TYPE_GPROCREF symbol
must be fabricated and emitted to the SUBSECTION_TYPE_GLOBAL_SYMBOLS section.
*******************************************************************************}
type
TSymbolProcInfo = packed record
pParent: DWORD;
pEnd: DWORD;
pNext: DWORD;
Size: DWORD; // Length in bytes of this procedure
DebugStart: DWORD; // Offset in bytes from the start of the procedure to
// the point where the stack frame has been set up.
DebugEnd: DWORD; // Offset in bytes from the start of the procedure to
// the point where the procedure is ready to return
// and has calculated its return value, if any.
// Frame and register variables an still be viewed.
Offset: DWORD; // Offset portion of the segmented address of
// the start of the procedure in the code segment
Segment: Word; // Segment portion of the segmented address of
// the start of the procedure in the code segment
ProcType: DWORD; // Type of the procedure type record
NearFar: Byte; // Type of return the procedure makes:
// 0 near
// 4 far
Reserved: Byte;
NameIndex: DWORD; // Name index of procedure
end;
type
{ Symbol Information Records }
PSymbolInfo = ^TSymbolInfo;
TSymbolInfo = packed record
Size: Word;
SymbolType: Word;
case Word of
SYMBOL_TYPE_LPROC32, SYMBOL_TYPE_GPROC32:
(Proc: TSymbolProcInfo;);
end;
PSymbolInfos = ^TSymbolInfos;
TSymbolInfos = packed record
Signature: DWORD;
Symbols: array [0..0] of TSymbolInfo;
end;
{$IFDEF SUPPORTS_EXTSYM}
{$EXTERNALSYM Borland32BitSymbolFileSignatureForDelphi}
{$EXTERNALSYM Borland32BitSymbolFileSignatureForBCB}
{$EXTERNALSYM SUBSECTION_TYPE_MODULE}
{$EXTERNALSYM SUBSECTION_TYPE_TYPES}
{$EXTERNALSYM SUBSECTION_TYPE_SYMBOLS}
{$EXTERNALSYM SUBSECTION_TYPE_ALIGN_SYMBOLS}
{$EXTERNALSYM SUBSECTION_TYPE_SOURCE_MODULE}
{$EXTERNALSYM SUBSECTION_TYPE_GLOBAL_SYMBOLS}
{$EXTERNALSYM SUBSECTION_TYPE_GLOBAL_TYPES}
{$EXTERNALSYM SUBSECTION_TYPE_NAMES}
{$EXTERNALSYM SYMBOL_TYPE_COMPILE}
{$EXTERNALSYM SYMBOL_TYPE_REGISTER}
{$EXTERNALSYM SYMBOL_TYPE_CONST}
{$EXTERNALSYM SYMBOL_TYPE_UDT}
{$EXTERNALSYM SYMBOL_TYPE_SSEARCH}
{$EXTERNALSYM SYMBOL_TYPE_END}
{$EXTERNALSYM SYMBOL_TYPE_SKIP}
{$EXTERNALSYM SYMBOL_TYPE_CVRESERVE}
{$EXTERNALSYM SYMBOL_TYPE_OBJNAME}
{$EXTERNALSYM SYMBOL_TYPE_BPREL16}
{$EXTERNALSYM SYMBOL_TYPE_LDATA16}
{$EXTERNALSYM SYMBOL_TYPE_GDATA16}
{$EXTERNALSYM SYMBOL_TYPE_PUB16}
{$EXTERNALSYM SYMBOL_TYPE_LPROC16}
{$EXTERNALSYM SYMBOL_TYPE_GPROC16}
{$EXTERNALSYM SYMBOL_TYPE_THUNK16}
{$EXTERNALSYM SYMBOL_TYPE_BLOCK16}
{$EXTERNALSYM SYMBOL_TYPE_WITH16}
{$EXTERNALSYM SYMBOL_TYPE_LABEL16}
{$EXTERNALSYM SYMBOL_TYPE_CEXMODEL16}
{$EXTERNALSYM SYMBOL_TYPE_VFTPATH16}
{$EXTERNALSYM SYMBOL_TYPE_BPREL32}
{$EXTERNALSYM SYMBOL_TYPE_LDATA32}
{$EXTERNALSYM SYMBOL_TYPE_GDATA32}
{$EXTERNALSYM SYMBOL_TYPE_PUB32}
{$EXTERNALSYM SYMBOL_TYPE_LPROC32}
{$EXTERNALSYM SYMBOL_TYPE_GPROC32}
{$EXTERNALSYM SYMBOL_TYPE_THUNK32}
{$EXTERNALSYM SYMBOL_TYPE_BLOCK32}
{$EXTERNALSYM SYMBOL_TYPE_WITH32}
{$EXTERNALSYM SYMBOL_TYPE_LABEL32}
{$EXTERNALSYM SYMBOL_TYPE_CEXMODEL32}
{$EXTERNALSYM SYMBOL_TYPE_VFTPATH32}
{$ENDIF SUPPORTS_EXTSYM}
//--------------------------------------------------------------------------------------------------
// TD32 information related classes
//--------------------------------------------------------------------------------------------------
type
TJclModuleInfo = class(TObject)
private
FNameIndex: DWORD;
FSegments: PSegmentInfoArray;
FSegmentCount: Integer;
function GetSegment(const Idx: Integer): TSegmentInfo;
protected
constructor Create(pModInfo: PModuleInfo);
public
property NameIndex: DWORD read FNameIndex;
property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;
property Segment[const Idx: Integer]: TSegmentInfo read GetSegment; default;
end;
TJclLineInfo = class(TObject)
private
FLineNo: DWORD;
FOffset: DWORD;
protected
constructor Create(ALineNo, AOffset: DWORD);
public
property LineNo: DWORD read FLineNo;
property Offset: DWORD read FOffset;
end;
TJclSourceModuleInfo = class(TObject)
private
FLines: TObjectList;
FSegments: POffsetPairArray;
FSegmentCount: Integer;
FNameIndex: DWORD;
function GetLine(const Idx: Integer): TJclLineInfo;
function GetLineCount: Integer;
function GetSegment(const Idx: Integer): TOffsetPair;
protected
constructor Create(pSrcFile: PSourceFileEntry; Base: DWORD);
public
destructor Destroy; override;
function FindLine(const AAddr: DWORD; var ALine: TJclLineInfo): Boolean;
property NameIndex: DWORD read FNameIndex;
property LineCount: Integer read GetLineCount;
property Line[const Idx: Integer]: TJclLineInfo read GetLine; default;
property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;
property Segment[const Idx: Integer]: TOffsetPair read GetSegment;
end;
TJclSymbolInfo = class(TObject)
private
FSymbolType: Word;
protected
constructor Create(pSymInfo: PSymbolInfo); virtual;
property SymbolType: Word read FSymbolType;
end;
TJclProcSymbolInfo = class(TJclSymbolInfo)
private
FNameIndex: DWORD;
FOffset: DWORD;
FSize: DWORD;
protected
constructor Create(pSymInfo: PSymbolInfo); override;
public
property NameIndex: DWORD read FNameIndex;
property Offset: DWORD read FOffset;
property Size: DWORD read FSize;
end;
TJclLocalProcSymbolInfo = class(TJclProcSymbolInfo);
TJclGlobalProcSymbolInfo = class(TJclProcSymbolInfo);
//--------------------------------------------------------------------------------------------------
// TD32 parser
//--------------------------------------------------------------------------------------------------
TJclTD32InfoParser = class(TObject)
private
FBase: Pointer;
FData: TCustomMemoryStream;
FNames: TList;
FModules: TObjectList;
FSourceModules: TObjectList;
FSymbols: TObjectList;
FValidData: Boolean;
function GetName(const Idx: Integer): string;
function GetNameCount: Integer;
function GetSymbol(const Idx: Integer): TJclSymbolInfo;
function GetSymbolCount: Integer;
function GetModule(const Idx: Integer): TJclModuleInfo;
function GetModuleCount: Integer;
function GetSourceModule(const Idx: Integer): TJclSourceModuleInfo;
function GetSourceModuleCount: Integer;
protected
procedure Analyse;
procedure AnalyseNames(const pSubsection: Pointer; const Size: DWORD); virtual;
procedure AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD); virtual;
procedure AnalyseModules(pModInfo: PModuleInfo; const Size: DWORD); virtual;
procedure AnalyseSourceModules(pSrcModInfo: PSourceModuleInfo; const Size: DWORD); virtual;
procedure AnalyseUnknownSubSection(const pSubsection: Pointer; const Size: DWORD); virtual;
function LfaToVa(Lfa: DWORD): Pointer;
public
constructor Create(const ATD32Data: TCustomMemoryStream); // Data mustn't be freed before the class is destroyed
destructor Destroy; override;
function FindModule(const AAddr: DWORD; var AMod: TJclModuleInfo): Boolean;
function FindSourceModule(const AAddr: DWORD; var ASrcMod: TJclSourceModuleInfo): Boolean;
function FindProc(const AAddr: DWORD; var AProc: TJclProcSymbolInfo): Boolean;
class function IsTD32Sign(const Sign: TJclTD32FileSignature): Boolean;
class function IsTD32DebugInfoValid(const DebugData: Pointer; const DebugDataSize: LongWord): Boolean;
property Data: TCustomMemoryStream read FData;
property Names[const Idx: Integer]: string read GetName;
property NameCount: Integer read GetNameCount;
property Symbols[const Idx: Integer]: TJclSymbolInfo read GetSymbol;
property SymbolCount: Integer read GetSymbolCount;
property Modules[const Idx: Integer]: TJclModuleInfo read GetModule;
property ModuleCount: Integer read GetModuleCount;
property SourceModules[const Idx: Integer]: TJclSourceModuleInfo read GetSourceModule;
property SourceModuleCount: Integer read GetSourceModuleCount;
property ValidData: Boolean read FValidData;
end;
//--------------------------------------------------------------------------------------------------
// TD32 scanner with source location methods
//--------------------------------------------------------------------------------------------------
TJclTD32InfoScanner = class(TJclTD32InfoParser)
public
function LineNumberFromAddr(AAddr: DWORD; var Offset: Integer): Integer; overload;
function LineNumberFromAddr(AAddr: DWORD): Integer; overload;
function ProcNameFromAddr(AAddr: DWORD): string; overload;
function ProcNameFromAddr(AAddr: DWORD; var Offset: Integer): string; overload;
function ModuleNameFromAddr(AAddr: DWORD): string;
function SourceNameFromAddr(AAddr: DWORD): string;
end;
//--------------------------------------------------------------------------------------------------
// PE Image with TD32 information and source location support
//--------------------------------------------------------------------------------------------------
TJclPeBorTD32Image = class(TJclPeBorImage)
private
FIsTD32DebugPresent: Boolean;
FTD32DebugData: TCustomMemoryStream;
FTD32Scanner: TJclTD32InfoScanner;
protected
procedure AfterOpen; override;
procedure Clear; override;
procedure ClearDebugData;
procedure CheckDebugData;
function IsDebugInfoInImage(var DataStream: TCustomMemoryStream): Boolean;
function IsDebugInfoInTds(var DataStream: TCustomMemoryStream): Boolean;
public
property IsTD32DebugPresent: Boolean read FIsTD32DebugPresent;
property TD32DebugData: TCustomMemoryStream read FTD32DebugData;
property TD32Scanner: TJclTD32InfoScanner read FTD32Scanner;
end;
implementation
uses
JclResources, JclSysUtils;
const
TurboDebuggerSymbolExt = '.tds';
//==================================================================================================
// TJclModuleInfo
//==================================================================================================
constructor TJclModuleInfo.Create(pModInfo: PModuleInfo);
begin
Assert(Assigned(pModInfo));
inherited Create;
FNameIndex := pModInfo.NameIndex;
FSegments := @pModInfo.Segments[0];
FSegmentCount := pModInfo.SegmentCount;
end;
//--------------------------------------------------------------------------------------------------
function TJclModuleInfo.GetSegment(const Idx: Integer): TSegmentInfo;
begin
Assert((0 <= Idx) and (Idx < FSegmentCount));
Result := FSegments[Idx];
end;
//==================================================================================================
// TJclLineInfo
//==================================================================================================
constructor TJclLineInfo.Create(ALineNo, AOffset: DWORD);
begin
inherited Create;
FLineNo := ALineNo;
FOffset := AOffset;
end;
//==================================================================================================
// TJclSourceModuleInfo
//==================================================================================================
constructor TJclSourceModuleInfo.Create(pSrcFile: PSourceFileEntry; Base: DWORD);
type
PArrayOfWord = ^TArrayOfWord;
TArrayOfWord = array [0..0] of Word;
var
I, J: Integer;
pLineEntry: PLineMappingEntry;
begin
Assert(Assigned(pSrcFile));
inherited Create;
FNameIndex := pSrcFile.NameIndex;
FLines := TObjectList.Create;
{$RANGECHECKS OFF}
for I := 0 to pSrcFile.SegmentCount - 1 do
begin
pLineEntry := PLineMappingEntry(Base + pSrcFile.BaseSrcLines[I]);
for J := 0 to pLineEntry.PairCount - 1 do
FLines.Add(TJclLineInfo.Create(
PArrayOfWord(@pLineEntry.Offsets[pLineEntry.PairCount])^[J],
pLineEntry.Offsets[J]));
end;
FSegments := @pSrcFile.BaseSrcLines[pSrcFile.SegmentCount];
FSegmentCount := pSrcFile.SegmentCount;
{$IFDEF RANGECHECKS_ON}
{$RANGECHECKS ON}
{$ENDIF RANGECHECKS_ON}
end;
//--------------------------------------------------------------------------------------------------
destructor TJclSourceModuleInfo.Destroy;
begin
FreeAndNil(FLines);
inherited Destroy;
end;
//--------------------------------------------------------------------------------------------------
function TJclSourceModuleInfo.GetLine(const Idx: Integer): TJclLineInfo;
begin
Result := TJclLineInfo(FLines.Items[Idx]);
end;
//--------------------------------------------------------------------------------------------------
function TJclSourceModuleInfo.GetLineCount: Integer;
begin
Result := FLines.Count;
end;
//--------------------------------------------------------------------------------------------------
function TJclSourceModuleInfo.GetSegment(const Idx: Integer): TOffsetPair;
begin
Assert((0 <= Idx) and (Idx < FSegmentCount));
Result := FSegments[Idx];
end;
//--------------------------------------------------------------------------------------------------
function TJclSourceModuleInfo.FindLine(const AAddr: DWORD; var ALine: TJclLineInfo): Boolean;
var
I: Integer;
begin
for I := 0 to LineCount - 1 do
with Line[I] do
begin
if AAddr = Offset then
begin
Result := True;
ALine := Line[I];
Exit;
end
else
if (I > 1) and (Line[I - 1].Offset < AAddr) and (AAddr < Offset) then
begin
Result := True;
ALine := Line[I-1];
Exit;
end;
end;
Result := False;
ALine := nil;
end;
//==================================================================================================
// TJclSymbolInfo
//==================================================================================================
constructor TJclSymbolInfo.Create(pSymInfo: PSymbolInfo);
begin
Assert(Assigned(pSymInfo));
inherited Create;
FSymbolType := pSymInfo.SymbolType;
end;
//==================================================================================================
// TJclProcSymbolInfo
//==================================================================================================
constructor TJclProcSymbolInfo.Create(pSymInfo: PSymbolInfo);
begin
Assert(Assigned(pSymInfo));
inherited Create(pSymInfo);
with pSymInfo^ do
begin
FNameIndex := Proc.NameIndex;
FOffset := Proc.Offset;
FSize := Proc.Size;
end;
end;
//==================================================================================================
// TJclTD32InfoParser
//==================================================================================================
constructor TJclTD32InfoParser.Create(const ATD32Data: TCustomMemoryStream);
begin
Assert(Assigned(ATD32Data));
inherited Create;
FNames := TList.Create;
FModules := TObjectList.Create;
FSourceModules := TObjectList.Create;
FSymbols := TObjectList.Create;
FNames.Add(nil);
FData := ATD32Data;
FBase := FData.Memory;
FValidData := IsTD32DebugInfoValid(FBase, FData.Size);
if FValidData then
Analyse;
end;
//--------------------------------------------------------------------------------------------------
destructor TJclTD32InfoParser.Destroy;
begin
FreeAndNil(FSymbols);
FreeAndNil(FSourceModules);
FreeAndNil(FModules);
FreeAndNil(FNames);
inherited Destroy;
end;
//--------------------------------------------------------------------------------------------------
procedure TJclTD32InfoParser.Analyse;
var
I: Integer;
pDirHeader: PDirectoryHeader;
pSubsection: Pointer;
begin
pDirHeader := PDirectoryHeader(LfaToVa(PJclTD32FileSignature(LfaToVa(0)).Offset));
while True do
begin
Assert(pDirHeader.DirEntrySize = SizeOf(TDirectoryEntry));
{$RANGECHECKS OFF}
for I := 0 to pDirHeader.DirEntryCount - 1 do
with pDirHeader.DirEntries[I] do
begin
pSubsection := LfaToVa(Offset);
case SubsectionType of
SUBSECTION_TYPE_MODULE:
AnalyseModules(pSubsection, Size);
SUBSECTION_TYPE_ALIGN_SYMBOLS:
AnalyseAlignSymbols(pSubsection, Size);
SUBSECTION_TYPE_SOURCE_MODULE:
AnalyseSourceModules(pSubsection, Size);
SUBSECTION_TYPE_NAMES:
AnalyseNames(pSubsection, Size);
else
AnalyseUnknownSubSection(pSubsection, Size);
end;
end;
{$IFDEF RANGECHECKS_ON}
{$RANGECHECKS ON}
{$ENDIF RANGECHECKS_ON}
if pDirHeader.lfoNextDir <> 0 then
pDirHeader := PDirectoryHeader(LfaToVa(pDirHeader.lfoNextDir))
else
Break;
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TJclTD32InfoParser.AnalyseNames(const pSubsection: Pointer; const Size: DWORD);
var
I, Count, Len: Integer;
pszName: PChar;
begin
Count := PDWORD(pSubsection)^;
pszName := PChar(DWORD(pSubsection) + SizeOf(DWORD));
for I := 0 to Count - 1 do
begin
// Get the length of the name
Len := Ord(pszName^);
Inc(pszName);
// Get the name
FNames.Add(pszName);
// skip the length of name and a NULL at the end
Inc(pszName, Len + 1);
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TJclTD32InfoParser.AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD);
var
Offset: DWORD;
pInfo: PSymbolInfo;
Symbol: TJclSymbolInfo;
begin
Offset := DWORD(@pSymbols.Symbols[0]) - DWORD(pSymbols);
while Offset < Size do
begin
pInfo := PSymbolInfo(DWORD(pSymbols) + Offset);
case pInfo.SymbolType of
SYMBOL_TYPE_LPROC32:
Symbol := TJclLocalProcSymbolInfo.Create(pInfo);
SYMBOL_TYPE_GPROC32:
Symbol := TJclGlobalProcSymbolInfo.Create(pInfo);
else
Symbol := nil;
end;
if Assigned(Symbol) then
FSymbols.Add(Symbol);
Inc(Offset, pInfo.Size + SizeOf(pInfo.Size));
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TJclTD32InfoParser.AnalyseModules(pModInfo: PModuleInfo; const Size: DWORD);
begin
FModules.Add(TJclModuleInfo.Create(pModInfo));
end;
//--------------------------------------------------------------------------------------------------
procedure TJclTD32InfoParser.AnalyseSourceModules(pSrcModInfo: PSourceModuleInfo; const Size: DWORD);
var
I: Integer;
pSrcFile: PSourceFileEntry;
begin
{$RANGECHECKS OFF}
for I := 0 to pSrcModInfo.FileCount - 1 do
begin
pSrcFile := PSourceFileEntry(DWORD(pSrcModInfo) + pSrcModInfo.BaseSrcFiles[I]);
if pSrcFile.NameIndex > 0 then
FSourceModules.Add(TJclSourceModuleInfo.Create(pSrcFile, DWORD(pSrcModInfo)));
end;
{$IFDEF RANGECHECKS_ON}
{$RANGECHECKS ON}
{$ENDIF RANGECHECKS_ON}
end;
//--------------------------------------------------------------------------------------------------
procedure TJclTD32InfoParser.AnalyseUnknownSubSection(const pSubsection: Pointer; const Size: DWORD);
begin
// do nothing
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetModule(const Idx: Integer): TJclModuleInfo;
begin
Result := TJclModuleInfo(FModules.Items[Idx]);
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetModuleCount: Integer;
begin
Result := FModules.Count;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetName(const Idx: Integer): string;
begin
Result := PChar(FNames.Items[Idx]);
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetNameCount: Integer;
begin
Result := FNames.Count;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetSourceModule(const Idx: Integer): TJclSourceModuleInfo;
begin
Result := TJclSourceModuleInfo(FSourceModules.Items[Idx]);
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetSourceModuleCount: Integer;
begin
Result := FSourceModules.Count;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetSymbol(const Idx: Integer): TJclSymbolInfo;
begin
Result := TJclSymbolInfo(FSymbols.Items[Idx]);
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.GetSymbolCount: Integer;
begin
Result := FSymbols.Count;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.FindModule(const AAddr: DWORD;
var AMod: TJclModuleInfo): Boolean;
var
I, J: Integer;
begin
if ValidData then
for I := 0 to ModuleCount - 1 do
with Modules[I] do
for J := 0 to SegmentCount - 1 do
begin
if AAddr >= FSegments[J].Offset then
begin
if AAddr - FSegments[J].Offset <= Segment[J].Size then
begin
Result := True;
AMod := Modules[I];
Exit;
end;
end;
end;
Result := False;
AMod := nil;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.FindSourceModule(const AAddr: DWORD;
var ASrcMod: TJclSourceModuleInfo): Boolean;
var
I, J: Integer;
begin
if ValidData then
for I := 0 to SourceModuleCount - 1 do
with SourceModules[I] do
for J := 0 to SegmentCount - 1 do
with Segment[J] do
if (StartOffset <= AAddr) and (AAddr < EndOffset) then
begin
Result := True;
ASrcMod := SourceModules[I];
Exit;
end;
Result := False;
ASrcMod := nil;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.FindProc(const AAddr: DWORD; var AProc: TJclProcSymbolInfo): Boolean;
var
I: Integer;
begin
if ValidData then
for I := 0 to SymbolCount - 1 do
if Symbols[I].InheritsFrom(TJclProcSymbolInfo) then
with Symbols[I] as TJclProcSymbolInfo do
if (Offset <= AAddr) and (AAddr < Offset + Size) then
begin
Result := True;
AProc := TJclProcSymbolInfo(Symbols[I]);
Exit;
end;
Result := False;
AProc := nil;
end;
//--------------------------------------------------------------------------------------------------
class function TJclTD32InfoParser.IsTD32DebugInfoValid(
const DebugData: Pointer; const DebugDataSize: LongWord): Boolean;
var
Sign: TJclTD32FileSignature;
EndOfDebugData: LongWord;
begin
Assert(not IsBadReadPtr(DebugData, DebugDataSize));
Result := False;
EndOfDebugData := LongWord(DebugData) + DebugDataSize;
if DebugDataSize > SizeOf(Sign) then
begin
Sign := PJclTD32FileSignature(EndOfDebugData - SizeOf(Sign))^;
if IsTD32Sign(Sign) and (Sign.Offset <= DebugDataSize) then
begin
Sign := PJclTD32FileSignature(EndOfDebugData - Sign.Offset)^;
Result := IsTD32Sign(Sign);
end;
end;
end;
//--------------------------------------------------------------------------------------------------
class function TJclTD32InfoParser.IsTD32Sign(const Sign: TJclTD32FileSignature): Boolean;
begin
Result := (Sign.Signature = Borland32BitSymbolFileSignatureForDelphi) or
(Sign.Signature = Borland32BitSymbolFileSignatureForBCB);
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoParser.LfaToVa(Lfa: DWORD): Pointer;
begin
Result := Pointer(DWORD(FBase) + Lfa)
end;
//==================================================================================================
// TJclTD32InfoScanner
//==================================================================================================
function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD): Integer;
var
Dummy: Integer;
begin
Result := LineNumberFromAddr(AAddr, Dummy);
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD; var Offset: Integer): Integer;
var
ASrcMod: TJclSourceModuleInfo;
ALine: TJclLineInfo;
begin
if FindSourceModule(AAddr, ASrcMod) and ASrcMod.FindLine(AAddr, ALine) then
begin
Result := ALine.LineNo;
Offset := AAddr - ALine.Offset;
end
else
begin
Result := 0;
Offset := 0;
end;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoScanner.ModuleNameFromAddr(AAddr: DWORD): string;
var
AMod: TJclModuleInfo;
begin
if FindModule(AAddr, AMod) then
Result := Names[AMod.NameIndex]
else
Result := '';
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoScanner.ProcNameFromAddr(AAddr: DWORD): string;
var
Dummy: Integer;
begin
Result := ProcNameFromAddr(AAddr, Dummy);
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoScanner.ProcNameFromAddr(AAddr: DWORD; var Offset: Integer): string;
var
AProc: TJclProcSymbolInfo;
function FormatProcName(const ProcName: string): string;
var
pchSecondAt, P: PChar;
begin
Result := ProcName;
if (Length(ProcName) > 0) and (ProcName[1] = '@') then
begin
pchSecondAt := StrScan(PChar(Copy(ProcName, 2, Length(ProcName) - 1)), '@');
if pchSecondAt <> nil then
begin
Inc(pchSecondAt);
Result := pchSecondAt;
P := PChar(Result);
while P^ <> #0 do
begin
if (pchSecondAt^ = '@') and ((pchSecondAt - 1)^ <> '@') then
P^ := '.';
Inc(P);
Inc(pchSecondAt);
end;
end;
end;
end;
begin
if FindProc(AAddr, AProc) then
begin
Result := FormatProcName(Names[AProc.NameIndex]);
Offset := AAddr - AProc.Offset;
end
else
begin
Result := '';
Offset := 0;
end;
end;
//--------------------------------------------------------------------------------------------------
function TJclTD32InfoScanner.SourceNameFromAddr(AAddr: DWORD): string;
var
ASrcMod: TJclSourceModuleInfo;
begin
if FindSourceModule(AAddr, ASrcMod) then
Result := Names[ASrcMod.NameIndex];
end;
//==================================================================================================
// TJclPeBorTD32Image
//==================================================================================================
procedure TJclPeBorTD32Image.AfterOpen;
begin
inherited AfterOpen;
CheckDebugData;
end;
//--------------------------------------------------------------------------------------------------
procedure TJclPeBorTD32Image.CheckDebugData;
begin
FIsTD32DebugPresent := IsDebugInfoInImage(FTD32DebugData);
if not FIsTD32DebugPresent then
FIsTD32DebugPresent := IsDebugInfoInTds(FTD32DebugData);
if FIsTD32DebugPresent then
begin
FTD32Scanner := TJclTD32InfoScanner.Create(FTD32DebugData);
if not FTD32Scanner.ValidData then
begin
ClearDebugData;
if not NoExceptions then
raise EJclError.CreateResRecFmt(@RsHasNotTD32Info, [FileName]);
end;
end;
end;
//--------------------------------------------------------------------------------------------------
procedure TJclPeBorTD32Image.Clear;
begin
ClearDebugData;
inherited Clear;
end;
//--------------------------------------------------------------------------------------------------
procedure TJclPeBorTD32Image.ClearDebugData;
begin
FIsTD32DebugPresent := False;
FreeAndNil(FTD32Scanner);
FreeAndNil(FTD32DebugData);
end;
//--------------------------------------------------------------------------------------------------
function TJclPeBorTD32Image.IsDebugInfoInImage(var DataStream: TCustomMemoryStream): Boolean;
var
DebugDir: TImageDebugDirectory;
BugDataStart: Pointer;
DebugDataSize: Integer;
begin
Result := False;
DataStream := nil;
if IsBorlandImage and (DebugList.Count = 1) then
begin
DebugDir := DebugList[0];
if DebugDir._Type = IMAGE_DEBUG_TYPE_UNKNOWN then
begin
BugDataStart := RvaToVa(DebugDir.AddressOfRawData);
DebugDataSize := DebugDir.SizeOfData;
Result := TJclTD32InfoParser.IsTD32DebugInfoValid(BugDataStart, DebugDataSize);
if Result then
DataStream := TJclReferenceMemoryStream.Create(BugDataStart, DebugDataSize);
end;
end;
end;
//--------------------------------------------------------------------------------------------------
function TJclPeBorTD32Image.IsDebugInfoInTds(var DataStream: TCustomMemoryStream): Boolean;
var
TdsFileName: TFileName;
TempStream: TCustomMemoryStream;
begin
Result := False;
DataStream := nil;
TdsFileName := ChangeFileExt(FileName, TurboDebuggerSymbolExt);
if FileExists(TdsFileName) then
begin
TempStream := TJclFileMappingStream.Create(TdsFileName);
try
Result := TJclTD32InfoParser.IsTD32DebugInfoValid(TempStream.Memory, TempStream.Size);
if Result then
DataStream := TempStream
else
TempStream.Free;
except
TempStream.Free;
raise;
end;
end;
end;
end.