}
+
+// 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;
+
+ TSymbolObjNameInfo = packed record
+ Signature: DWORD; // Signature for the CodeView information contained in
+ // this module
+ NameIndex: DWORD; // Name index of the object file
+ end;
+
+ TSymbolDataInfo = packed record
+ Offset: DWORD; // Offset portion of the segmented address of
+ // the start of the data in the code segment
+ Segment: Word; // Segment portion of the segmented address of
+ // the start of the data in the code segment
+ Reserved: Word;
+ TypeIndex: DWORD; // Type index of the symbol
+ NameIndex: DWORD; // Name index of the symbol
+ end;
+
+ TSymbolWithInfo = packed record
+ pParent: DWORD;
+ pEnd: DWORD;
+ Size: DWORD; // Length in bytes of this "with"
+ Offset: DWORD; // Offset portion of the segmented address of
+ // the start of the "with" in the code segment
+ Segment: Word; // Segment portion of the segmented address of
+ // the start of the "with" in the code segment
+ Reserved: Word;
+ NameIndex: DWORD; // Name index of the "with"
+ end;
+
+ TSymbolLabelInfo = packed record
+ Offset: DWORD; // Offset portion of the segmented address of
+ // the start of the label in the code segment
+ Segment: Word; // Segment portion of the segmented address of
+ // the start of the label in the code segment
+ NearFar: Byte; // Address mode of the label:
+ // 0 near
+ // 4 far
+ Reserved: Byte;
+ NameIndex: DWORD; // Name index of the label
+ end;
+
+ TSymbolConstantInfo = packed record
+ TypeIndex: DWORD; // Type index of the constant (for enums)
+ NameIndex: DWORD; // Name index of the constant
+ Reserved: DWORD;
+ Value: DWORD; // value of the constant
+ end;
+
+ TSymbolUdtInfo = packed record
+ TypeIndex: DWORD; // Type index of the type
+ Properties: Word; // isTag:1 True if this is a tag (not a typedef)
+ // isNest:1 True if the type is a nested type (its name
+ // will be 'class_name::type_name' in that case)
+ NameIndex: DWORD; // Name index of the type
+ Reserved: DWORD;
+ end;
+
+ TSymbolVftPathInfo = packed record
+ Offset: DWORD; // Offset portion of start of the virtual function table
+ Segment: Word; // Segment portion of the virtual function table
+ Reserved: Word;
+ RootIndex: DWORD; // The type index of the class at the root of the path
+ PathIndex: DWORD; // Type index of the record describing the base class
+ // path from the root to the leaf class for the virtual
+ // function table
+ 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);
+ SYMBOL_TYPE_OBJNAME:
+ (ObjName: TSymbolObjNameInfo);
+ SYMBOL_TYPE_LDATA32, SYMBOL_TYPE_GDATA32, SYMBOL_TYPE_PUB32:
+ (Data: TSymbolDataInfo);
+ SYMBOL_TYPE_WITH32:
+ (With32: TSymbolWithInfo);
+ SYMBOL_TYPE_LABEL32:
+ (Label32: TSymbolLabelInfo);
+ SYMBOL_TYPE_CONST:
+ (Constant: TSymbolConstantInfo);
+ SYMBOL_TYPE_UDT:
+ (Udt: TSymbolUdtInfo);
+ SYMBOL_TYPE_VFTPATH32:
+ (VftPath: TSymbolVftPathInfo);
+ 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
+ TJclTD32ModuleInfo = class(TObject)
+ private
+ FNameIndex: DWORD;
+ FSegments: PSegmentInfoArray;
+ FSegmentCount: Integer;
+ function GetSegment(const Idx: Integer): TSegmentInfo;
+ public
+ constructor Create(pModInfo: PModuleInfo);
+ property NameIndex: DWORD read FNameIndex;
+ property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;
+ property Segment[const Idx: Integer]: TSegmentInfo read GetSegment; default;
+ end;
+
+ TJclTD32LineInfo = class(TObject)
+ private
+ FLineNo: DWORD;
+ FOffset: DWORD;
+ public
+ constructor Create(ALineNo, AOffset: DWORD);
+ property LineNo: DWORD read FLineNo;
+ property Offset: DWORD read FOffset;
+ end;
+
+ TJclTD32SourceModuleInfo = class(TObject)
+ private
+ FLines: TObjectList;
+ FSegments: POffsetPairArray;
+ FSegmentCount: Integer;
+ FNameIndex: DWORD;
+ function GetLine(const Idx: Integer): TJclTD32LineInfo;
+ function GetLineCount: Integer;
+ function GetSegment(const Idx: Integer): TOffsetPair;
+ public
+ constructor Create(pSrcFile: PSourceFileEntry; Base: TJclAddr);
+ destructor Destroy; override;
+ function FindLine(const AAddr: DWORD; out ALine: TJclTD32LineInfo): Boolean;
+ property NameIndex: DWORD read FNameIndex;
+ property LineCount: Integer read GetLineCount;
+ property Line[const Idx: Integer]: TJclTD32LineInfo read GetLine; default;
+ property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;
+ property Segment[const Idx: Integer]: TOffsetPair read GetSegment;
+ end;
+
+ TJclTD32SymbolInfo = class(TObject)
+ private
+ FSymbolType: Word;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); virtual;
+ property SymbolType: Word read FSymbolType;
+ end;
+
+ TJclTD32ProcSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FNameIndex: DWORD;
+ FOffset: DWORD;
+ FSize: DWORD;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property NameIndex: DWORD read FNameIndex;
+ property Offset: DWORD read FOffset;
+ property Size: DWORD read FSize;
+ end;
+
+ TJclTD32LocalProcSymbolInfo = class(TJclTD32ProcSymbolInfo);
+ TJclTD32GlobalProcSymbolInfo = class(TJclTD32ProcSymbolInfo);
+
+ { not used by Delphi }
+ TJclTD32ObjNameSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FSignature: DWORD;
+ FNameIndex: DWORD;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property NameIndex: DWORD read FNameIndex;
+ property Signature: DWORD read FSignature;
+ end;
+
+ TJclTD32DataSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FOffset: DWORD;
+ FTypeIndex: DWORD;
+ FNameIndex: DWORD;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property NameIndex: DWORD read FNameIndex;
+ property TypeIndex: DWORD read FTypeIndex;
+ property Offset: DWORD read FOffset;
+ end;
+
+ TJclTD32LDataSymbolInfo = class(TJclTD32DataSymbolInfo);
+ TJclTD32GDataSymbolInfo = class(TJclTD32DataSymbolInfo);
+ TJclTD32PublicSymbolInfo = class(TJclTD32DataSymbolInfo);
+
+ TJclTD32WithSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FOffset: DWORD;
+ FSize: DWORD;
+ FNameIndex: DWORD;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property NameIndex: DWORD read FNameIndex;
+ property Offset: DWORD read FOffset;
+ property Size: DWORD read FSize;
+ end;
+
+ { not used by Delphi }
+ TJclTD32LabelSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FOffset: DWORD;
+ FNameIndex: DWORD;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property NameIndex: DWORD read FNameIndex;
+ property Offset: DWORD read FOffset;
+ end;
+
+ { not used by Delphi }
+ TJclTD32ConstantSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FValue: DWORD;
+ FTypeIndex: DWORD;
+ FNameIndex: DWORD;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property NameIndex: DWORD read FNameIndex;
+ property TypeIndex: DWORD read FTypeIndex; // for enums
+ property Value: DWORD read FValue;
+ end;
+
+ TJclTD32UdtSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FTypeIndex: DWORD;
+ FNameIndex: DWORD;
+ FProperties: Word;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property NameIndex: DWORD read FNameIndex;
+ property TypeIndex: DWORD read FTypeIndex;
+ property Properties: Word read FProperties;
+ end;
+
+ { not used by Delphi }
+ TJclTD32VftPathSymbolInfo = class(TJclTD32SymbolInfo)
+ private
+ FRootIndex: DWORD;
+ FPathIndex: DWORD;
+ FOffset: DWORD;
+ public
+ constructor Create(pSymInfo: PSymbolInfo); override;
+ property RootIndex: DWORD read FRootIndex;
+ property PathIndex: DWORD read FPathIndex;
+ property Offset: DWORD read FOffset;
+ end;
+
+ // TD32 parser
+ TJclTD32InfoParser = class(TObject)
+ private
+ FBase: Pointer;
+ FData: TCustomMemoryStream;
+ FNames: TList;
+ FModules: TObjectList;
+ FSourceModules: TObjectList;
+ FSymbols: TObjectList;
+ FProcSymbols: TList;
+ FValidData: Boolean;
+ FUnmangledNames: TStrings;
+ function GetName(const Idx: Integer): string;
+ function GetNameCount: Integer;
+ function GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;
+ function GetSymbolCount: Integer;
+ function GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;
+ function GetProcSymbolCount: Integer;
+ function GetModule(const Idx: Integer): TJclTD32ModuleInfo;
+ function GetModuleCount: Integer;
+ function GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;
+ function GetSourceModuleCount: Integer;
+ function FormatProcName(const ProcName: string): string;
+ protected
+ procedure Analyse;
+ procedure AnalyseNames(const pSubsection: Pointer; const Size: DWORD); virtual;
+ procedure AnalyseGlobalTypes(const pTypes: 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; out AMod: TJclTD32ModuleInfo): Boolean;
+ function FindSourceModule(const AAddr: DWORD; out ASrcMod: TJclTD32SourceModuleInfo): Boolean;
+ function FindProc(const AAddr: DWORD; out AProc: TJclTD32ProcSymbolInfo): Boolean;
+ procedure GenerateUnmangledNames;
+ 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]: TJclTD32SymbolInfo read GetSymbol;
+ property SymbolCount: Integer read GetSymbolCount;
+ property ProcSymbols[const Idx: Integer]: TJclTD32ProcSymbolInfo read GetProcSymbol;
+ property ProcSymbolCount: Integer read GetProcSymbolCount;
+ property Modules[const Idx: Integer]: TJclTD32ModuleInfo read GetModule;
+ property ModuleCount: Integer read GetModuleCount;
+ property SourceModules[const Idx: Integer]: TJclTD32SourceModuleInfo 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; out Offset: Integer): Integer; overload;
+ function LineNumberFromAddr(AAddr: DWORD): Integer; overload;
+ function ProcNameFromAddr(AAddr: DWORD): string; overload;
+ function ProcNameFromAddr(AAddr: DWORD; out Offset: Integer): string; overload;
+ function ModuleNameFromAddr(AAddr: DWORD): string;
+ function SourceNameFromAddr(AAddr: DWORD): string;
+ function VAFromUnitAndProcName(const UnitName, ProcName: string): DWORD;
+ end;
+
+ {$IFDEF BORLAND}
+ // 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;
+ {$ENDIF BORLAND}
+
+{$IFDEF UNITVERSIONING}
+const
+ UnitVersioning: TUnitVersionInfo = (
+ RCSfile: '$URL$';
+ Revision: '$Revision$';
+ Date: '$Date$';
+ LogPath: 'JCL\source\windows';
+ Extra: '';
+ Data: nil
+ );
+{$ENDIF UNITVERSIONING}
+
+implementation
+
+uses
+ JclResources, JclSysUtils, JclStringConversions;
+
+{$IFDEF BORLAND}
+const
+ TurboDebuggerSymbolExt = '.tds';
+{$ENDIF BORLAND}
+
+//=== { TJclModuleInfo } =====================================================
+
+constructor TJclTD32ModuleInfo.Create(pModInfo: PModuleInfo);
+begin
+ Assert(Assigned(pModInfo));
+ inherited Create;
+ FNameIndex := pModInfo.NameIndex;
+ FSegments := @pModInfo.Segments[0];
+ FSegmentCount := pModInfo.SegmentCount;
+end;
+
+function TJclTD32ModuleInfo.GetSegment(const Idx: Integer): TSegmentInfo;
+begin
+ Assert((0 <= Idx) and (Idx < FSegmentCount));
+ Result := FSegments[Idx];
+end;
+
+//=== { TJclLineInfo } =======================================================
+
+constructor TJclTD32LineInfo.Create(ALineNo, AOffset: DWORD);
+begin
+ inherited Create;
+ FLineNo := ALineNo;
+ FOffset := AOffset;
+end;
+
+//=== { TJclSourceModuleInfo } ===============================================
+
+constructor TJclTD32SourceModuleInfo.Create(pSrcFile: PSourceFileEntry; Base: TJclAddr);
+type
+ PArrayOfWord = ^TArrayOfWord;
+ TArrayOfWord = array [0..MaxInt div SizeOf(Word) - 1] 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(TJclTD32LineInfo.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 TJclTD32SourceModuleInfo.Destroy;
+begin
+ FreeAndNil(FLines);
+ inherited Destroy;
+end;
+
+function TJclTD32SourceModuleInfo.GetLine(const Idx: Integer): TJclTD32LineInfo;
+begin
+ Result := TJclTD32LineInfo(FLines.Items[Idx]);
+end;
+
+function TJclTD32SourceModuleInfo.GetLineCount: Integer;
+begin
+ Result := FLines.Count;
+end;
+
+function TJclTD32SourceModuleInfo.GetSegment(const Idx: Integer): TOffsetPair;
+begin
+ Assert((0 <= Idx) and (Idx < FSegmentCount));
+ Result := FSegments[Idx];
+end;
+
+function TJclTD32SourceModuleInfo.FindLine(const AAddr: DWORD; out ALine: TJclTD32LineInfo): 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 TJclTD32SymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create;
+ FSymbolType := pSymInfo.SymbolType;
+end;
+
+//=== { TJclProcSymbolInfo } =================================================
+
+constructor TJclTD32ProcSymbolInfo.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;
+
+//=== { TJclObjNameSymbolInfo } ==============================================
+
+constructor TJclTD32ObjNameSymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create(pSymInfo);
+ with pSymInfo^ do
+ begin
+ FNameIndex := ObjName.NameIndex;
+ FSignature := ObjName.Signature;
+ end;
+end;
+
+//=== { TJclDataSymbolInfo } =================================================
+
+constructor TJclTD32DataSymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create(pSymInfo);
+ with pSymInfo^ do
+ begin
+ FTypeIndex := Data.TypeIndex;
+ FNameIndex := Data.NameIndex;
+ FOffset := Data.Offset;
+ end;
+end;
+
+//=== { TJclWithSymbolInfo } =================================================
+
+constructor TJclTD32WithSymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create(pSymInfo);
+ with pSymInfo^ do
+ begin
+ FNameIndex := With32.NameIndex;
+ FOffset := With32.Offset;
+ FSize := With32.Size;
+ end;
+end;
+
+//=== { TJclLabelSymbolInfo } ================================================
+
+constructor TJclTD32LabelSymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create(pSymInfo);
+ with pSymInfo^ do
+ begin
+ FNameIndex := Label32.NameIndex;
+ FOffset := Label32.Offset;
+ end;
+end;
+
+//=== { TJclConstantSymbolInfo } =============================================
+
+constructor TJclTD32ConstantSymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create(pSymInfo);
+ with pSymInfo^ do
+ begin
+ FNameIndex := Constant.NameIndex;
+ FTypeIndex := Constant.TypeIndex;
+ FValue := Constant.Value;
+ end;
+end;
+
+//=== { TJclUdtSymbolInfo } ==================================================
+
+constructor TJclTD32UdtSymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create(pSymInfo);
+ with pSymInfo^ do
+ begin
+ FNameIndex := Udt.NameIndex;
+ FTypeIndex := Udt.TypeIndex;
+ FProperties := Udt.Properties;
+ end;
+end;
+
+//=== { TJclVftPathSymbolInfo } ==============================================
+
+constructor TJclTD32VftPathSymbolInfo.Create(pSymInfo: PSymbolInfo);
+begin
+ Assert(Assigned(pSymInfo));
+ inherited Create(pSymInfo);
+ with pSymInfo^ do
+ begin
+ FRootIndex := VftPath.RootIndex;
+ FPathIndex := VftPath.PathIndex;
+ FOffset := VftPath.Offset;
+ 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;
+ FProcSymbols := TList.Create;
+ FNames.Add(nil);
+ FData := ATD32Data;
+ FBase := FData.Memory;
+ FValidData := IsTD32DebugInfoValid(FBase, FData.Size);
+ FUnmangledNames := TStringList.Create;
+ if FValidData then
+ Analyse;
+end;
+
+destructor TJclTD32InfoParser.Destroy;
+begin
+ FreeAndNil(FProcSymbols);
+ FreeAndNil(FSymbols);
+ FreeAndNil(FSourceModules);
+ FreeAndNil(FModules);
+ FreeAndNil(FNames);
+ FreeAndNil(FUnmangledNames);
+ 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);
+ SUBSECTION_TYPE_GLOBAL_TYPES:
+ AnalyseGlobalTypes(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: PAnsiChar;
+begin
+ Count := PDWORD(pSubsection)^;
+ pszName := PAnsiChar(TJclAddr(pSubsection) + SizeOf(DWORD));
+ if Count > 0 then
+ begin
+ FNames.Capacity := FNames.Capacity + Count;
+ 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);
+ // first, skip the length of name
+ Inc(pszName, Len);
+ // the length is only correct modulo 256 because it is stored on a single byte,
+ // so we have to iterate until we find the real end of the string
+ while PszName^ <> #0 do
+ Inc(pszName, 256);
+ // then, skip a NULL at the end
+ Inc(pszName, 1);
+ end;
+ end;
+end;
+
+{ // unused
+const
+ // Leaf indices for type records that can be referenced from symbols
+ LF_MODIFIER = $0001;
+ LF_POINTER = $0002;
+ LF_ARRAY = $0003;
+ LF_CLASS = $0004;
+ LF_STRUCTURE = $0005;
+ LF_UNION = $0006;
+ LF_ENUM = $0007;
+ LF_PROCEDURE = $0008;
+ LF_MFUNCTION = $0009;
+ LF_VTSHAPE = $000a;
+ LF_COBOL0 = $000b;
+ LF_COBOL1 = $000c;
+ LF_BARRAY = $000d;
+ LF_LABEL = $000e;
+ LF_NULL = $000f;
+ LF_NOTTRAN = $0010;
+ LF_DIMARRAY = $0011;
+ LF_VFTPATH = $0012;
+
+ // Leaf indices for type records that can be referenced from other type records
+ LF_SKIP = $0200;
+ LF_ARGLIST = $0201;
+ LF_DEFARG = $0202;
+ LF_LIST = $0203;
+ LF_FIELDLIST = $0204;
+ LF_DERIVED = $0205;
+ LF_BITFIELD = $0206;
+ LF_METHODLIST = $0207;
+ LF_DIMCONU = $0208;
+ LF_DIMCONLU = $0209;
+ LF_DIMVARU = $020a;
+ LF_DIMVARLU = $020b;
+ LF_REFSYM = $020c;
+
+ // Leaf indices for fields of complex lists:
+ LF_BCLASS = $0400;
+ LF_VBCLASS = $0401;
+ LF_IVBCLASS = $0402;
+ LF_ENUMERATE = $0403;
+ LF_FRIENDFCN = $0404;
+ LF_INDEX = $0405;
+ LF_MEMBER = $0406;
+ LF_STMEMBER = $0407;
+ LF_METHOD = $0408;
+ LF_NESTTYPE = $0409;
+ LF_VFUNCTAB = $040a;
+ LF_FRIENDCLS = $040b;
+
+ // Leaf indices for numeric fields of symbols and type records:
+ LF_NUMERIC = $8000;
+ LF_CHAR = $8001;
+ LF_SHORT = $8002;
+ LF_USHORT = $8003;
+ LF_LONG = $8004;
+ LF_ULONG = $8005;
+ LF_REAL32 = $8006;
+ LF_REAL64 = $8007;
+ LF_REAL80 = $8008;
+ LF_REAL128 = $8009;
+ LF_QUADWORD = $800a;
+ LF_UQUADWORD = $800b;
+ LF_REAL48 = $800c;
+
+ LF_PAD0 = $f0;
+ LF_PAD1 = $f1;
+ LF_PAD2 = $f2;
+ LF_PAD3 = $f3;
+ LF_PAD4 = $f4;
+ LF_PAD5 = $f5;
+ LF_PAD6 = $f6;
+ LF_PAD7 = $f7;
+ LF_PAD8 = $f8;
+ LF_PAD9 = $f9;
+ LF_PAD10 = $fa;
+ LF_PAD11 = $fb;
+ LF_PAD12 = $fc;
+ LF_PAD13 = $fd;
+ LF_PAD14 = $fe;
+ LF_PAD15 = $ff;
+}
+
+type
+ PSymbolTypeInfo = ^TSymbolTypeInfo;
+ TSymbolTypeInfo = packed record
+ TypeId: DWORD;
+ NameIndex: DWORD; // 0 if unnamed
+ Size: Word; // size in bytes of the object
+ MaxSize: Byte;
+ ParentIndex: DWORD;
+ end;
+
+{ unused
+const
+ TID_VOID = $00; // Unknown or no type
+ TID_LSTR = $01; // Basic Literal string
+ TID_DSTR = $02; // Basic Dynamic string
+ TID_PSTR = $03; // Pascal style string
+}
+
+procedure TJclTD32InfoParser.AnalyseGlobalTypes(const pTypes: Pointer; const Size: DWORD);
+var
+ pTyp: PSymbolTypeInfo;
+begin
+ pTyp := PSymbolTypeInfo(pTypes);
+ repeat
+ {case pTyp.TypeId of
+ TID_VOID: ;
+ end;}
+ pTyp := PSymbolTypeInfo(TJclAddr(pTyp) + pTyp.Size + SizeOf(pTyp^));
+ until TJclAddr(pTyp) >= TJclAddr(pTypes) + Size;
+end;
+
+procedure TJclTD32InfoParser.AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD);
+var
+ Offset: TJclAddr;
+ pInfo: PSymbolInfo;
+ Symbol: TJclTD32SymbolInfo;
+begin
+ Offset := TJclAddr(@pSymbols.Symbols[0]) - TJclAddr(pSymbols);
+ while Offset < Size do
+ begin
+ pInfo := PSymbolInfo(TJclAddr(pSymbols) + Offset);
+ case pInfo.SymbolType of
+ SYMBOL_TYPE_LPROC32:
+ begin
+ Symbol := TJclTD32LocalProcSymbolInfo.Create(pInfo);
+ FProcSymbols.Add(Symbol);
+ end;
+ SYMBOL_TYPE_GPROC32:
+ begin
+ Symbol := TJclTD32GlobalProcSymbolInfo.Create(pInfo);
+ FProcSymbols.Add(Symbol);
+ end;
+ SYMBOL_TYPE_OBJNAME:
+ Symbol := TJclTD32ObjNameSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_LDATA32:
+ Symbol := TJclTD32LDataSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_GDATA32:
+ Symbol := TJclTD32GDataSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_PUB32:
+ Symbol := TJclTD32PublicSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_WITH32:
+ Symbol := TJclTD32WithSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_LABEL32:
+ Symbol := TJclTD32LabelSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_CONST:
+ Symbol := TJclTD32ConstantSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_UDT:
+ Symbol := TJclTD32UdtSymbolInfo.Create(pInfo);
+ SYMBOL_TYPE_VFTPATH32:
+ Symbol := TJclTD32VftPathSymbolInfo.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(TJclTD32ModuleInfo.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(TJclAddr(pSrcModInfo) + pSrcModInfo.BaseSrcFiles[I]);
+ if pSrcFile.NameIndex > 0 then
+ FSourceModules.Add(TJclTD32SourceModuleInfo.Create(pSrcFile, TJclAddr(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.FormatProcName(const ProcName: string): string;
+var
+ SecondAtChar, P: PChar;
+begin
+ Result := ProcName;
+ if (Length(ProcName) > 1) and (ProcName[1] = '@') then
+ begin
+ SecondAtChar := StrScan(PChar(ProcName) + 1, '@');
+ if SecondAtChar <> nil then
+ begin
+ Inc(SecondAtChar);
+ Result := SecondAtChar;
+ P := PChar(Result);
+ while P^ <> #0 do
+ begin
+ if (SecondAtChar^ = '@') and ((SecondAtChar - 1)^ <> '@') then
+ P^ := '.';
+ Inc(P);
+ Inc(SecondAtChar);
+ end;
+ end;
+ end;
+
+ if PeIsNameMangled(Result) <> umNotMangled then
+ Result := PeBorUnmangleName(Result);
+end;
+
+procedure TJclTD32InfoParser.GenerateUnmangledNames;
+var
+ I: Integer;
+begin
+ if FUnmangledNames.Count <> 0 then
+ Exit;
+// FUnmangledNames.Capacity := NameCount;
+ for I := 0 to NameCount - 1 do
+ FUnmangledNames.Add(FormatProcName(UTF8ToString(PAnsiChar(FNames.Items[I]))));
+end;
+
+function TJclTD32InfoParser.GetModule(const Idx: Integer): TJclTD32ModuleInfo;
+begin
+ Result := TJclTD32ModuleInfo(FModules.Items[Idx]);
+end;
+
+function TJclTD32InfoParser.GetModuleCount: Integer;
+begin
+ Result := FModules.Count;
+end;
+
+function TJclTD32InfoParser.GetName(const Idx: Integer): string;
+begin
+ if FUnmangledNames.Count > Idx then
+ Result := FUnmangledNames[Idx]
+ else
+ Result := UTF8ToString(PAnsiChar(FNames.Items[Idx]));
+end;
+
+function TJclTD32InfoParser.GetNameCount: Integer;
+begin
+ Result := FNames.Count;
+end;
+
+function TJclTD32InfoParser.GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;
+begin
+ Result := TJclTD32SourceModuleInfo(FSourceModules.Items[Idx]);
+end;
+
+function TJclTD32InfoParser.GetSourceModuleCount: Integer;
+begin
+ Result := FSourceModules.Count;
+end;
+
+function TJclTD32InfoParser.GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;
+begin
+ Result := TJclTD32SymbolInfo(FSymbols.Items[Idx]);
+end;
+
+function TJclTD32InfoParser.GetSymbolCount: Integer;
+begin
+ Result := FSymbols.Count;
+end;
+
+function TJclTD32InfoParser.GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;
+begin
+ Result := TJclTD32ProcSymbolInfo(FProcSymbols.Items[Idx]);
+end;
+
+function TJclTD32InfoParser.GetProcSymbolCount: Integer;
+begin
+ Result := FProcSymbols.Count;
+end;
+
+function TJclTD32InfoParser.FindModule(const AAddr: DWORD; out AMod: TJclTD32ModuleInfo): 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 (FSegments[J].Flags = 1) and (AAddr >= FSegments[J].Offset) and (AAddr - FSegments[J].Offset <= Segment[J].Size) then
+ begin
+ Result := True;
+ AMod := Modules[I];
+ Exit;
+ end;
+ end;
+ Result := False;
+ AMod := nil;
+end;
+
+function TJclTD32InfoParser.FindSourceModule(const AAddr: DWORD; out ASrcMod: TJclTD32SourceModuleInfo): 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;
+ ASrcMod := nil;
+ Result := False;
+end;
+
+function TJclTD32InfoParser.FindProc(const AAddr: DWORD; out AProc: TJclTD32ProcSymbolInfo): Boolean;
+var
+ I: Integer;
+begin
+ if ValidData then
+ for I := 0 to ProcSymbolCount - 1 do
+ begin
+ AProc := ProcSymbols[I];
+ with AProc do
+ if (Offset <= AAddr) and (AAddr < Offset + Size) then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+ AProc := nil;
+ Result := False;
+end;
+
+class function TJclTD32InfoParser.IsTD32DebugInfoValid(
+ const DebugData: Pointer; const DebugDataSize: LongWord): Boolean;
+var
+ Sign: TJclTD32FileSignature;
+ EndOfDebugData: TJclAddr;
+begin
+ Assert(not IsBadReadPtr(DebugData, DebugDataSize));
+ Result := False;
+ EndOfDebugData := TJclAddr(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(TJclAddr(FBase) + Lfa)
+end;
+
+//=== { TJclTD32InfoScanner } ================================================
+
+function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD): Integer;
+var
+ Dummy: Integer;
+begin
+ Result := LineNumberFromAddr(AAddr, Dummy);
+end;
+
+function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD; out Offset: Integer): Integer;
+var
+ ASrcMod: TJclTD32SourceModuleInfo;
+ ALine: TJclTD32LineInfo;
+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: TJclTD32ModuleInfo;
+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; out Offset: Integer): string;
+var
+ AProc: TJclTD32ProcSymbolInfo;
+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: TJclTD32SourceModuleInfo;
+begin
+ if FindSourceModule(AAddr, ASrcMod) then
+ Result := Names[ASrcMod.NameIndex];
+end;
+
+function TJclTD32InfoScanner.VAFromUnitAndProcName(const UnitName, ProcName: string): DWORD;
+var
+ I: Integer;
+ QualifiedName: string;
+begin
+ Result := 0;
+ if (UnitName = '') or (ProcName = '') then
+ Exit;
+ QualifiedName := UnitName + '.' + ProcName;
+
+ for I := 0 to ProcSymbolCount - 1 do
+ begin
+ if CompareText(FormatProcName(Names[ProcSymbols[I].FNameIndex]), QualifiedName) = 0 then
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 TJclTD32SymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create;
- FSymbolType := pSymInfo.SymbolType;
-end;
-
-//=== { TJclProcSymbolInfo } =================================================
-
-constructor TJclTD32ProcSymbolInfo.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;
-
-//=== { TJclObjNameSymbolInfo } ==============================================
-
-constructor TJclTD32ObjNameSymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create(pSymInfo);
- with pSymInfo^ do
- begin
- FNameIndex := ObjName.NameIndex;
- FSignature := ObjName.Signature;
- end;
-end;
-
-//=== { TJclDataSymbolInfo } =================================================
-
-constructor TJclTD32DataSymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create(pSymInfo);
- with pSymInfo^ do
- begin
- FTypeIndex := Data.TypeIndex;
- FNameIndex := Data.NameIndex;
- FOffset := Data.Offset;
- end;
-end;
-
-//=== { TJclWithSymbolInfo } =================================================
-
-constructor TJclTD32WithSymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create(pSymInfo);
- with pSymInfo^ do
- begin
- FNameIndex := With32.NameIndex;
- FOffset := With32.Offset;
- FSize := With32.Size;
- end;
-end;
-
-//=== { TJclLabelSymbolInfo } ================================================
-
-constructor TJclTD32LabelSymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create(pSymInfo);
- with pSymInfo^ do
- begin
- FNameIndex := Label32.NameIndex;
- FOffset := Label32.Offset;
- end;
-end;
-
-//=== { TJclConstantSymbolInfo } =============================================
-
-constructor TJclTD32ConstantSymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create(pSymInfo);
- with pSymInfo^ do
- begin
- FNameIndex := Constant.NameIndex;
- FTypeIndex := Constant.TypeIndex;
- FValue := Constant.Value;
- end;
-end;
-
-//=== { TJclUdtSymbolInfo } ==================================================
-
-constructor TJclTD32UdtSymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create(pSymInfo);
- with pSymInfo^ do
- begin
- FNameIndex := Udt.NameIndex;
- FTypeIndex := Udt.TypeIndex;
- FProperties := Udt.Properties;
- end;
-end;
-
-//=== { TJclVftPathSymbolInfo } ==============================================
-
-constructor TJclTD32VftPathSymbolInfo.Create(pSymInfo: PSymbolInfo);
-begin
- Assert(Assigned(pSymInfo));
- inherited Create(pSymInfo);
- with pSymInfo^ do
- begin
- FRootIndex := VftPath.RootIndex;
- FPathIndex := VftPath.PathIndex;
- FOffset := VftPath.Offset;
- 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;
- FProcSymbols := TList.Create;
- FNames.Add(nil);
- FData := ATD32Data;
- FBase := FData.Memory;
- FValidData := IsTD32DebugInfoValid(FBase, FData.Size);
- if FValidData then
- Analyse;
-end;
-
-destructor TJclTD32InfoParser.Destroy;
-begin
- FreeAndNil(FProcSymbols);
- 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);
- SUBSECTION_TYPE_GLOBAL_TYPES:
- AnalyseGlobalTypes(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
+ Result := ProcSymbols[I].FOffset;
Break;
- end;
-end;
-
-procedure TJclTD32InfoParser.AnalyseNames(const pSubsection: Pointer; const Size: DWORD);
-var
- I, Count, Len: Integer;
- pszName: PAnsiChar;
-begin
- Count := PDWORD(pSubsection)^;
- pszName := PAnsiChar(TJclAddr(pSubsection) + SizeOf(DWORD));
- if Count > 0 then
- begin
- FNames.Capacity := FNames.Capacity + Count;
- 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);
- // first, skip the length of name
- Inc(pszName, Len);
- // the length is only correct modulo 256 because it is stored on a single byte,
- // so we have to iterate until we find the real end of the string
- while PszName^ <> #0 do
- Inc(pszName, 256);
- // then, skip a NULL at the end
- Inc(pszName, 1);
- end;
- end;
-end;
-
-{ // unused
-const
- // Leaf indices for type records that can be referenced from symbols
- LF_MODIFIER = $0001;
- LF_POINTER = $0002;
- LF_ARRAY = $0003;
- LF_CLASS = $0004;
- LF_STRUCTURE = $0005;
- LF_UNION = $0006;
- LF_ENUM = $0007;
- LF_PROCEDURE = $0008;
- LF_MFUNCTION = $0009;
- LF_VTSHAPE = $000a;
- LF_COBOL0 = $000b;
- LF_COBOL1 = $000c;
- LF_BARRAY = $000d;
- LF_LABEL = $000e;
- LF_NULL = $000f;
- LF_NOTTRAN = $0010;
- LF_DIMARRAY = $0011;
- LF_VFTPATH = $0012;
-
- // Leaf indices for type records that can be referenced from other type records
- LF_SKIP = $0200;
- LF_ARGLIST = $0201;
- LF_DEFARG = $0202;
- LF_LIST = $0203;
- LF_FIELDLIST = $0204;
- LF_DERIVED = $0205;
- LF_BITFIELD = $0206;
- LF_METHODLIST = $0207;
- LF_DIMCONU = $0208;
- LF_DIMCONLU = $0209;
- LF_DIMVARU = $020a;
- LF_DIMVARLU = $020b;
- LF_REFSYM = $020c;
-
- // Leaf indices for fields of complex lists:
- LF_BCLASS = $0400;
- LF_VBCLASS = $0401;
- LF_IVBCLASS = $0402;
- LF_ENUMERATE = $0403;
- LF_FRIENDFCN = $0404;
- LF_INDEX = $0405;
- LF_MEMBER = $0406;
- LF_STMEMBER = $0407;
- LF_METHOD = $0408;
- LF_NESTTYPE = $0409;
- LF_VFUNCTAB = $040a;
- LF_FRIENDCLS = $040b;
-
- // Leaf indices for numeric fields of symbols and type records:
- LF_NUMERIC = $8000;
- LF_CHAR = $8001;
- LF_SHORT = $8002;
- LF_USHORT = $8003;
- LF_LONG = $8004;
- LF_ULONG = $8005;
- LF_REAL32 = $8006;
- LF_REAL64 = $8007;
- LF_REAL80 = $8008;
- LF_REAL128 = $8009;
- LF_QUADWORD = $800a;
- LF_UQUADWORD = $800b;
- LF_REAL48 = $800c;
-
- LF_PAD0 = $f0;
- LF_PAD1 = $f1;
- LF_PAD2 = $f2;
- LF_PAD3 = $f3;
- LF_PAD4 = $f4;
- LF_PAD5 = $f5;
- LF_PAD6 = $f6;
- LF_PAD7 = $f7;
- LF_PAD8 = $f8;
- LF_PAD9 = $f9;
- LF_PAD10 = $fa;
- LF_PAD11 = $fb;
- LF_PAD12 = $fc;
- LF_PAD13 = $fd;
- LF_PAD14 = $fe;
- LF_PAD15 = $ff;
-}
-
-type
- PSymbolTypeInfo = ^TSymbolTypeInfo;
- TSymbolTypeInfo = packed record
- TypeId: DWORD;
- NameIndex: DWORD; // 0 if unnamed
- Size: Word; // size in bytes of the object
- MaxSize: Byte;
- ParentIndex: DWORD;
- end;
-
-{ unused
-const
- TID_VOID = $00; // Unknown or no type
- TID_LSTR = $01; // Basic Literal string
- TID_DSTR = $02; // Basic Dynamic string
- TID_PSTR = $03; // Pascal style string
-}
-
-procedure TJclTD32InfoParser.AnalyseGlobalTypes(const pTypes: Pointer; const Size: DWORD);
-var
- pTyp: PSymbolTypeInfo;
-begin
- pTyp := PSymbolTypeInfo(pTypes);
- repeat
- {case pTyp.TypeId of
- TID_VOID: ;
- end;}
- pTyp := PSymbolTypeInfo(TJclAddr(pTyp) + pTyp.Size + SizeOf(pTyp^));
- until TJclAddr(pTyp) >= TJclAddr(pTypes) + Size;
-end;
-
-procedure TJclTD32InfoParser.AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD);
-var
- Offset: TJclAddr;
- pInfo: PSymbolInfo;
- Symbol: TJclTD32SymbolInfo;
-begin
- Offset := TJclAddr(@pSymbols.Symbols[0]) - TJclAddr(pSymbols);
- while Offset < Size do
- begin
- pInfo := PSymbolInfo(TJclAddr(pSymbols) + Offset);
- case pInfo.SymbolType of
- SYMBOL_TYPE_LPROC32:
- begin
- Symbol := TJclTD32LocalProcSymbolInfo.Create(pInfo);
- FProcSymbols.Add(Symbol);
- end;
- SYMBOL_TYPE_GPROC32:
- begin
- Symbol := TJclTD32GlobalProcSymbolInfo.Create(pInfo);
- FProcSymbols.Add(Symbol);
- end;
- SYMBOL_TYPE_OBJNAME:
- Symbol := TJclTD32ObjNameSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_LDATA32:
- Symbol := TJclTD32LDataSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_GDATA32:
- Symbol := TJclTD32GDataSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_PUB32:
- Symbol := TJclTD32PublicSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_WITH32:
- Symbol := TJclTD32WithSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_LABEL32:
- Symbol := TJclTD32LabelSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_CONST:
- Symbol := TJclTD32ConstantSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_UDT:
- Symbol := TJclTD32UdtSymbolInfo.Create(pInfo);
- SYMBOL_TYPE_VFTPATH32:
- Symbol := TJclTD32VftPathSymbolInfo.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(TJclTD32ModuleInfo.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(TJclAddr(pSrcModInfo) + pSrcModInfo.BaseSrcFiles[I]);
- if pSrcFile.NameIndex > 0 then
- FSourceModules.Add(TJclTD32SourceModuleInfo.Create(pSrcFile, TJclAddr(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): TJclTD32ModuleInfo;
-begin
- Result := TJclTD32ModuleInfo(FModules.Items[Idx]);
-end;
-
-function TJclTD32InfoParser.GetModuleCount: Integer;
-begin
- Result := FModules.Count;
-end;
-
-function TJclTD32InfoParser.GetName(const Idx: Integer): string;
-begin
- Result := UTF8ToString(PAnsiChar(FNames.Items[Idx]));
-end;
-
-function TJclTD32InfoParser.GetNameCount: Integer;
-begin
- Result := FNames.Count;
-end;
-
-function TJclTD32InfoParser.GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;
-begin
- Result := TJclTD32SourceModuleInfo(FSourceModules.Items[Idx]);
-end;
-
-function TJclTD32InfoParser.GetSourceModuleCount: Integer;
-begin
- Result := FSourceModules.Count;
-end;
-
-function TJclTD32InfoParser.GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;
-begin
- Result := TJclTD32SymbolInfo(FSymbols.Items[Idx]);
-end;
-
-function TJclTD32InfoParser.GetSymbolCount: Integer;
-begin
- Result := FSymbols.Count;
-end;
-
-function TJclTD32InfoParser.GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;
-begin
- Result := TJclTD32ProcSymbolInfo(FProcSymbols.Items[Idx]);
-end;
-
-function TJclTD32InfoParser.GetProcSymbolCount: Integer;
-begin
- Result := FProcSymbols.Count;
-end;
-
-function TJclTD32InfoParser.FindModule(const AAddr: DWORD; out AMod: TJclTD32ModuleInfo): 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 (FSegments[J].Flags = 1) and (AAddr >= FSegments[J].Offset) and (AAddr - FSegments[J].Offset <= Segment[J].Size) then
- begin
- Result := True;
- AMod := Modules[I];
- Exit;
- end;
- end;
- Result := False;
- AMod := nil;
-end;
-
-function TJclTD32InfoParser.FindSourceModule(const AAddr: DWORD; out ASrcMod: TJclTD32SourceModuleInfo): 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;
- ASrcMod := nil;
- Result := False;
-end;
-
-function TJclTD32InfoParser.FindProc(const AAddr: DWORD; out AProc: TJclTD32ProcSymbolInfo): Boolean;
-var
- I: Integer;
-begin
- if ValidData then
- for I := 0 to ProcSymbolCount - 1 do
- begin
- AProc := ProcSymbols[I];
- with AProc do
- if (Offset <= AAddr) and (AAddr < Offset + Size) then
- begin
- Result := True;
- Exit;
- end;
- end;
- AProc := nil;
- Result := False;
-end;
-
-class function TJclTD32InfoParser.IsTD32DebugInfoValid(
- const DebugData: Pointer; const DebugDataSize: LongWord): Boolean;
-var
- Sign: TJclTD32FileSignature;
- EndOfDebugData: TJclAddr;
-begin
- Assert(not IsBadReadPtr(DebugData, DebugDataSize));
- Result := False;
- EndOfDebugData := TJclAddr(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(TJclAddr(FBase) + Lfa)
-end;
-
-//=== { TJclTD32InfoScanner } ================================================
-
-function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD): Integer;
-var
- Dummy: Integer;
-begin
- Result := LineNumberFromAddr(AAddr, Dummy);
-end;
-
-function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD; out Offset: Integer): Integer;
-var
- ASrcMod: TJclTD32SourceModuleInfo;
- ALine: TJclTD32LineInfo;
-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: TJclTD32ModuleInfo;
-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; out Offset: Integer): string;
-var
- AProc: TJclTD32ProcSymbolInfo;
-
- 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: TJclTD32SourceModuleInfo;
-begin
- if FindSourceModule(AAddr, ASrcMod) then
- Result := Names[ASrcMod.NameIndex];
-end;
-
-{$IFDEF BORLAND}
-
-//=== { 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.CreateResFmt(@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, fmOpenRead or fmShareDenyNone);
- try
- Result := TJclTD32InfoParser.IsTD32DebugInfoValid(TempStream.Memory, TempStream.Size);
- if Result then
- DataStream := TempStream
- else
- TempStream.Free;
- except
- TempStream.Free;
- raise;
end;
- end;
-end;
-
-{$ENDIF BORLAND}
-{$IFDEF UNITVERSIONING}
-initialization
- RegisterUnitVersion(HInstance, UnitVersioning);
-
-finalization
- UnregisterUnitVersion(HInstance);
-{$ENDIF UNITVERSIONING}
-
-end.
+ end;
+end;
+
+{$IFDEF BORLAND}
+
+//=== { 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.CreateResFmt(@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, fmOpenRead or fmShareDenyNone);
+ try
+ Result := TJclTD32InfoParser.IsTD32DebugInfoValid(TempStream.Memory, TempStream.Size);
+ if Result then
+ DataStream := TempStream
+ else
+ TempStream.Free;
+ except
+ TempStream.Free;
+ raise;
+ end;
+ end;
+end;
+
+{$ENDIF BORLAND}
+{$IFDEF UNITVERSIONING}
+initialization
+ RegisterUnitVersion(HInstance, UnitVersioning);
+
+finalization
+ UnregisterUnitVersion(HInstance);
+{$ENDIF UNITVERSIONING}
+
+end.
diff --git a/3rdParty/JCL/source/windows/JclWin32.pas b/3rdParty/JCL/source/windows/JclWin32.pas
index 5ec7f10..ea67dff 100644
--- a/3rdParty/JCL/source/windows/JclWin32.pas
+++ b/3rdParty/JCL/source/windows/JclWin32.pas
@@ -1666,7 +1666,7 @@ function IMAGE_FIRST_SECTION(NtHeader: PImageNtHeaders): PImageSectionHeader;
{$EXTERNALSYM IMAGE_SCN_LNK_NRELOC_OVFL}
IMAGE_SCN_MEM_DISCARDABLE = $02000000; // Section can be discarded.
{$EXTERNALSYM IMAGE_SCN_MEM_DISCARDABLE}
- IMAGE_SCN_MEM_NOT_CACHED = $04000000; // Section is not cachable.
+ IMAGE_SCN_MEM_NOT_CACHED = $04000000; // Section is not cacheable.
{$EXTERNALSYM IMAGE_SCN_MEM_NOT_CACHED}
IMAGE_SCN_MEM_NOT_PAGED = $08000000; // Section is not pageable.
{$EXTERNALSYM IMAGE_SCN_MEM_NOT_PAGED}
@@ -1936,7 +1936,7 @@ _IMAGE_TLS_DIRECTORY32 = record
{$EXTERNALSYM TImageTlsDirectory32}
PImageTlsDirectory32 = PIMAGE_TLS_DIRECTORY32;
{$EXTERNALSYM PImageTlsDirectory32}
-
+
const
IMAGE_ORDINAL_FLAG = IMAGE_ORDINAL_FLAG32;
{$EXTERNALSYM IMAGE_ORDINAL_FLAG}
@@ -2161,7 +2161,7 @@ _IMAGE_RESOURCE_DATA_ENTRY = record
{$EXTERNALSYM IMAGE_RESOURCE_DATA_ENTRY}
TImageResourceDataEntry = IMAGE_RESOURCE_DATA_ENTRY;
PImageResourceDataEntry = PIMAGE_RESOURCE_DATA_ENTRY;
-
+
//
// Load Configuration Directory Entry
//
@@ -2756,7 +2756,7 @@ _OSVERSIONINFOEXW = record
{$EXTERNALSYM POSVERSIONINFOEX}
LPOSVERSIONINFOEX = LPOSVERSIONINFOEXA;
{$EXTERNALSYM LPOSVERSIONINFOEX}
- TOSVersionInfoEx = TOSVersionInfoExA;
+ TOSVersionInfoEx = TOSVersionInfoExA;
{$ENDIF ~SUPPORTS_UNICODE}
@@ -3021,7 +3021,7 @@ _OSVERSIONINFOEXW = record
function GlobalMemoryStatusEx(out lpBuffer: TMemoryStatusEx): BOOL; stdcall;
// line 3189
-
+
function BackupSeek(hFile: THandle; dwLowBytesToSeek, dwHighBytesToSeek: DWORD;
out lpdwLowByteSeeked, lpdwHighByteSeeked: DWORD;
@@ -4985,7 +4985,7 @@ _USER_INFO_2 = record
{$EXTERNALSYM USER_PRIV_ADMIN}
// line 1177
-
+
//
// Group Class
//
@@ -5829,8 +5829,8 @@ function Netbios(pncb: PNCB): UCHAR; stdcall;
CSIDL_COMMON_MUSIC = $0035; { All Users\My Music }
CSIDL_COMMON_PICTURES = $0036; { All Users\My Pictures }
CSIDL_COMMON_VIDEO = $0037; { All Users\My Video }
- CSIDL_RESOURCES = $0038; { Resource Direcotry }
- CSIDL_RESOURCES_LOCALIZED = $0039; { Localized Resource Direcotry }
+ CSIDL_RESOURCES = $0038; { Resource Directory }
+ CSIDL_RESOURCES_LOCALIZED = $0039; { Localized Resource Directory }
CSIDL_COMMON_OEM_LINKS = $003A; { Links to All Users OEM specific apps }
CSIDL_CDBURN_AREA = $003B; { USERPROFILE\Local Settings\Application Data\Microsoft\CD Burning }
CSIDL_COMPUTERSNEARME = $003D; { Computers Near Me (computered from Workgroup membership) }
@@ -6600,7 +6600,7 @@ THUMBBUTTON = record
FSCTL_FIND_FILES_BY_SID = (
(FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or
- (35 shl 2) or METHOD_NEITHER);
+ (35 shl 2) or METHOD_NEITHER);
{$EXTERNALSYM FSCTL_FIND_FILES_BY_SID}
// decommissioned fsctl value 36
@@ -7052,7 +7052,7 @@ function EnumCalendarInfoExW(lpCalInfoEnumProcEx: CALINFO_ENUMPROCEXW;
MAXIMUM_RESERVED_MANIFEST_RESOURCE_ID = MAKEINTRESOURCE(16{inclusive});
{$EXTERNALSYM MAXIMUM_RESERVED_MANIFEST_RESOURCE_ID}
-// line 1451
+// line 1451
KLF_SETFORPROCESS = $00000100;
{$EXTERNALSYM KLF_SETFORPROCESS}
@@ -9085,7 +9085,7 @@ function IMAGE_SNAP_BY_ORDINAL(Ordinal: DWORD): Boolean;
const
PowrprofLib = 'PowrProf.dll';
-
+
type
TIsPwrSuspendAllowed = function : BOOL; stdcall;
@@ -9142,7 +9142,7 @@ function SetSuspendState(Hibernate, ForceCritical, DisableWakeEvent: BOOL): BOOL
TStgCreateStorageEx = function (const pwcsName: PWideChar; grfMode: DWORD;
stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: PSTGOPTIONS; reserved2: Pointer;
riid: PGUID; out stgOpen: IInterface): HResult; stdcall;
-
+
var
_StgCreateStorageEx: TStgCreateStorageEx = nil;
diff --git a/README.markdown b/README.markdown
index 81381d5..1ba1759 100644
--- a/README.markdown
+++ b/README.markdown
@@ -4,7 +4,7 @@
Delphi Code Coverage is a simple Code Coverage tool for Delphi that creates code coverage reports
based on detailed MAP files.
-Please also check out [this project](https://github.com/trident-job/delphi-code-coverage-wizard) as it adds a wizard to the
+Please also check out [this project](https://github.com/MHumm/delphi-code-coverage-wizard-plus) as it adds a wizard to the
Delphi IDE to help create configuration and launch Delphi Code Coverage.
## Preconditions
@@ -57,7 +57,8 @@ well as using emma for generating reports.
DCC is compatible with Delphi up to 10.4.2, both 32 and 64 bit.
### SonarQube integration
-You can integrate the results of the xml report in SonarQube. See the [Delphi SonarQube plugin](https://github.com/mendrix/SonarDelphi)
+You can integrate the results of the xml report in SonarQube. See the [Delphi SonarQube plugin](https://github.com/mendrix/SonarDelphi)
+or [newer version here](https://github.com/JAM-Software/SonarDelphi)
for detailed information.
### Hudson integration
@@ -79,6 +80,8 @@ unfinished form on my harddrive for more than a year. Finally it slipped out.
-sp directory directory2 | The directories where the source can be found |
-spf filename | Use source directories listed in the file pointed to by filename. One directory per line in the file |
-esm mask1 mask2 etc | A list of file masks to exclude from list of units |
+ -ism mask1 mask2 etc | Incude only units matching the provided file masks |
+ -ecp prefix1 mask2 etc | A list of class prefixes to exclude from coverage |
-od directory | The directory where the output files will be put - note - the directory must exist |
-u TestUnit TestUnit2 | The units that shall be checked for code coverage |
-uf filename | Cover units listed in the file pointed to by filename. One unit per line in the file |
diff --git a/SetupEnvironment.bat b/SetupEnvironment.bat
index c3ad6ad..2310891 100644
--- a/SetupEnvironment.bat
+++ b/SetupEnvironment.bat
@@ -12,6 +12,22 @@ if "%DPF%"=="" (
SET DPF="%PROGRAMFILES%"
)
+IF EXIST "%DPF%\Embarcadero\Studio\23.0\bin\rsvars.bat" (
+ ECHO Found Delphi 12 Athens
+ CALL "%DPF%\Embarcadero\Studio\23.0\bin\rsvars.bat"
+) ELSE (
+IF EXIST "%DPF%\Embarcadero\Studio\22.0\bin\rsvars.bat" (
+ ECHO Found Delphi 11 Alexandria
+ CALL "%DPF%\Embarcadero\Studio\22.0\bin\rsvars.bat"
+) ELSE (
+IF EXIST "%DPF%\Embarcadero\Studio\21.0\bin\rsvars.bat" (
+ ECHO Found Delphi 10.4 Sydney
+ CALL "%DPF%\Embarcadero\Studio\21.0\bin\rsvars.bat"
+) ELSE (
+IF EXIST "%DPF%\Embarcadero\Studio\20.0\bin\rsvars.bat" (
+ ECHO Found Delphi 10.3 Rio
+ CALL "%DPF%\Embarcadero\Studio\20.0\bin\rsvars.bat"
+) ELSE (
IF EXIST "%DPF%\Embarcadero\Studio\19.0\bin\rsvars.bat" (
ECHO Found Delphi 10.2 Tokyo
CALL "%DPF%\Embarcadero\Studio\19.0\bin\rsvars.bat"
@@ -31,3 +47,7 @@ IF EXIST "%DPF%\Embarcadero\Studio\14.0\bin\rsvars.bat" (
)
)
)
+)
+)
+)
+)
diff --git a/Source/BreakpointList.pas b/Source/BreakpointList.pas
index 1814282..2645fbf 100644
--- a/Source/BreakpointList.pas
+++ b/Source/BreakpointList.pas
@@ -27,6 +27,7 @@ TBreakPointList = class(TInterfacedObject, IBreakPointList)
function GetBreakPointByAddress(const AAddress: Pointer): IBreakPoint;
property BreakPointByAddress[const AAddress: Pointer]: IBreakPoint read GetBreakPointByAddress;
+ function HasBreakPointUnitModuleName(const AUnitModuleName: String): Boolean;
constructor Create;
destructor Destroy; override;
@@ -79,6 +80,11 @@ function TBreakPointList.GetBreakPointByAddress(const AAddress: Pointer): IBreak
Result := IBreakPoint(FBreakPointLst.KeyInterface[IntToHex(Integer(AAddress), 8)]);
end;
+function TBreakPointList.HasBreakPointUnitModuleName(const AUnitModuleName: String): Boolean;
+begin
+ Result := FBreakPointLst.IndexOf(AUnitModuleName) > 0;
+end;
+
procedure TBreakPointList.SetCapacity(const AValue: Integer);
begin
FBreakPointLst.Capacity := AValue;
diff --git a/Source/ClassInfoUnit.pas b/Source/ClassInfoUnit.pas
index 3889110..7e0d2c5 100644
--- a/Source/ClassInfoUnit.pas
+++ b/Source/ClassInfoUnit.pas
@@ -13,7 +13,7 @@
interface
uses
- Generics.Collections,
+ System.Generics.Collections,
I_BreakPoint,
I_LogManager;
@@ -151,6 +151,8 @@ TModuleList = class(TEnumerable)
const AModuleName: string;
const AModuleFileName: string): TModuleInfo;
+ class function GetProcedureName(const AModuleName: String; const AQualifiedProcName: String): String;
+ class function GetClassName(const AModuleName: String; const AQualifiedProcName: String): String;
procedure HandleBreakPoint(
const AModuleName: string;
@@ -283,6 +285,59 @@ function TModuleList.EnsureModuleInfo(
end;
end;
+function GetClassProcedureName(const AModuleName: String; const AQualifiedProcName: String): String;
+begin
+ Result := RightStr(AQualifiedProcName, Length(AQualifiedProcName) - (Length(AModuleName) + 1));
+ // detect module initialization section
+ if Result = AModuleName then
+ begin
+ Result := 'Initialization';
+ end;
+
+ if EndsStr(TProcedureInfo.BodySuffix, Result) then
+ begin
+ Result := LeftStr(Result, Length(Result) - Length(TProcedureInfo.BodySuffix));
+ end;
+end;
+
+class function TModuleList.GetProcedureName(const AModuleName: String; const AQualifiedProcName: String): String;
+var
+ QualifiedNameParts: TArray;
+begin
+ QualifiedNameParts := GetClassProcedureName(AModuleName, AQualifiedProcName).Split(['.']);
+ if Length(QualifiedNameParts) > 0 then
+ begin
+ Result := SplitString(QualifiedNameParts[Length(QualifiedNameParts) - 1], '$')[0];
+ end;
+end;
+
+class function TModuleList.GetClassName(const AModuleName: String; const AQualifiedProcName: String): String;
+var
+ QualifiedNameParts: TArray;
+ I: Integer;
+begin
+ QualifiedNameParts := GetClassProcedureName(AModuleName, AQualifiedProcName).Split(['.']);
+ if Length(QualifiedNameParts) > 2 then
+ begin
+ Result := '';
+ for I := 0 to Length(QualifiedNameParts) - 2 do
+ begin
+ Result := IfThen(Result = '', '', Result + '.') + QualifiedNameParts[I];
+ end;
+ end
+ else
+ begin
+ if SameText(QualifiedNameParts[0], 'finalization') or SameText(QualifiedNameParts[0], 'initialization') then
+ begin
+ Result := StringReplace(AModuleName, '.', '_', [rfReplaceAll]);
+ end
+ else
+ begin
+ Result := QualifiedNameParts[0];
+ end;
+ end;
+end;
+
procedure TModuleList.HandleBreakPoint(
const AModuleName: string;
const AModuleFileName: string;
@@ -291,65 +346,20 @@ procedure TModuleList.HandleBreakPoint(
const ABreakPoint: IBreakPoint;
const ALogManager: ILogManager);
var
- List: TStrings;
ClassName: string;
ProcedureName: string;
ClsInfo: TClassInfo;
ProcInfo: TProcedureInfo;
Module: TModuleInfo;
- ProcedureNameParts: TStringDynArray;
- I: Integer;
- ClassProcName: string;
begin
ALogManager.Log('Adding breakpoint for '+ AQualifiedProcName + ' in ' + AModuleFileName);
- List := TStringList.Create;
- try
- ClassProcName := RightStr(AQualifiedProcName, Length(AQualifiedProcName) - (Length(AModuleName) + 1));
- // detect module initialization section
- if ClassProcName = AModuleName then
- begin
- ClassProcName := 'Initialization';
- end;
- if EndsStr(TProcedureInfo.BodySuffix, ClassProcName) then
- begin
- ClassProcName := LeftStr(ClassProcName, Length(ClassProcName) - Length(TProcedureInfo.BodySuffix));
- end;
-
- ExtractStrings(['.'], [], PWideChar(ClassProcName), List);
- if List.Count > 0 then
- begin
- ProcedureNameParts := SplitString(List[List.Count - 1], '$');
- ProcedureName := ProcedureNameParts[0];
-
- if List.Count > 2 then
- begin
- ClassName := '';
- for I := 0 to List.Count - 2 do
- begin
- ClassName := IfThen(ClassName = '', '', ClassName + '.') + List[I];
- end;
- end
- else
- begin
- if SameText(List[0], 'finalization') or SameText(List[0], 'initialization') then
- begin
- ClassName := StringReplace(AModuleName, '.', '_', [rfReplaceAll]);
- end
- else
- begin
- ClassName := List[0];
- end;
- end;
-
- Module := EnsureModuleInfo(AModuleName, AModuleFileName);
- ClsInfo := Module.EnsureClassInfo(AModuleName, ClassName);
- ProcInfo := ClsInfo.EnsureProcedure(ProcedureName);
- ProcInfo.AddBreakPoint(ALineNo, ABreakPoint);
- end;
- finally
- List.Free;
- end;
+ ClassName := GetClassName(AModuleName, AQualifiedProcName);
+ ProcedureName := GetProcedureName(AModuleName, AQualifiedProcName);
+ Module := EnsureModuleInfo(AModuleName, AModuleFileName);
+ ClsInfo := Module.EnsureClassInfo(AModuleName, ClassName);
+ ProcInfo := ClsInfo.EnsureProcedure(ProcedureName);
+ ProcInfo.AddBreakPoint(ALineNo, ABreakPoint);
end;
{$endregion 'TModuleList'}
diff --git a/Source/CodeCoverage.dpr b/Source/CodeCoverage.dpr
index d844dd7..9e0fdc6 100644
--- a/Source/CodeCoverage.dpr
+++ b/Source/CodeCoverage.dpr
@@ -48,7 +48,8 @@ uses
ModuleNameSpaceUnit in 'ModuleNameSpaceUnit.pas',
uConsoleOutput in 'uConsoleOutput.pas',
HtmlHelper in 'HtmlHelper.pas',
- JclMapScannerHelper in 'JclMapScannerHelper.pas';
+ JclMapScannerHelper in 'JclMapScannerHelper.pas',
+ JacocoCoverageFileUnit in 'JacocoCoverageFileUnit.pas';
{$R *.res}
var
diff --git a/Source/CodeCoverage.dproj b/Source/CodeCoverage.dproj
index bb095a8..775bf25 100644
--- a/Source/CodeCoverage.dproj
+++ b/Source/CodeCoverage.dproj
@@ -1,15 +1,15 @@
{27E66171-9D6A-4E9D-84EE-13E81C1D1915}
- 19.2
+ 19.5
CodeCoverage.dpr
- Release
+ Debug
DCC32
True
3
Console
None
- Win64
+ Win32
true
@@ -67,7 +67,7 @@
$(BDS)\bin\delphi_PROJECTICNS.icns
$(BDS)\bin\delphi_PROJECTICON.ico
$(BDS)\bin\default_app.manifest
- CompanyName=;FileDescription=Delphi Code Coverage;FileVersion=1.0.14.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.14.0;Comments=
+ CompanyName=;FileDescription=Delphi Code Coverage;FileVersion=1.0.15.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.15.0;Comments=
1033
CodeCoverage
..\build\dcu\$(PLATFORM)
@@ -82,7 +82,7 @@
false
false
true
- 14
+ 15
true
true
@@ -94,7 +94,7 @@
Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)
Debug
- CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.14.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.14.0;Comments=
+ CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.15.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.15.0;Comments=
$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png
$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png
@@ -107,11 +107,10 @@
$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png
$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png
- true
+ -m "C:\Users\mark.humphreys\Desktop\JHCSystems\delphi-alex\src\test\Transactions\bin\TransactionTests.map" -cobertura -e "C:\Users\mark.humphreys\Desktop\JHCSystems\delphi-alex\src\test\Transactions\bin\TransactionTests.exe" -od "C:\Users\mark.humphreys\Desktop\JHCSystems\delphi-alex\src\test\Transactions"
- CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.14.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.14.0;Comments=
- true
+ CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.15.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.15.0;Comments=
3
@@ -122,8 +121,9 @@
None
- -e UnittestCodeCoverageTest.exe -m UnittestCodeCoverageTest.map -spf dcov_paths.lst -uf dcov_units.lst -html -od .\reports
- C:\Users\ekot\Documents\Projects\CodeCoverageTest\test\UnitTest
+ -sd C:\Users\Eugene\Documents\GitHub\DelphiCodeCoverage -spf C:\Users\Eugene\Documents\GitHub\DelphiCodeCoverage\coverage_dirs.lst
+ 16
+ CompanyName=;FileDescription=Delphi Code Coverage;FileVersion=1.0.16.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.15.0;Comments=
false
@@ -170,18 +170,19 @@
+
Base
-
- Cfg_2
- Base
-
Cfg_1
Base
+
+ Cfg_2
+ Base
+
Cfg_3
Base
@@ -230,8 +231,6 @@
- Microsoft Office 2000 Sample Automation Server Wrapper Components
- Microsoft Office XP Sample Automation Server Wrapper Components
False
@@ -239,50 +238,8 @@
True
True
-
-
-
- Assets\
- Logo44x44.png
- true
-
-
-
-
- true
-
-
-
-
- Assets\
- Logo150x150.png
- true
-
-
-
-
- CodeCoverage.exe
- true
-
-
-
-
- .\
- true
-
-
-
-
- Assets\
- Logo150x150.png
- true
-
-
-
-
- true
-
-
+
+
true
@@ -293,18 +250,20 @@
true
-
+
+
true
-
-
- Assets\
- Logo44x44.png
- true
-
-
+
+
+
+
+
+
+
+
1
@@ -313,14 +272,14 @@
0
-
+
classes
- 1
+ 64
classes
- 1
+ 64
@@ -611,6 +570,10 @@
1
.framework
+
+ 1
+ .framework
+
0
@@ -624,6 +587,10 @@
1
.dylib
+
+ 1
+ .dylib
+
0
.dll;.bpl
@@ -638,7 +605,7 @@
1
.dylib
-
+
1
.dylib
@@ -650,6 +617,10 @@
1
.dylib
+
+ 1
+ .dylib
+
0
.bpl
@@ -668,7 +639,7 @@
0
-
+
0
@@ -677,200 +648,251 @@
0
+
+ 0
+
0
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
+ 1
+
+
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
+
+
+
+ Contents\Resources
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ Contents\Resources
+ 1
+
+
+ Contents\Resources
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
+ library\lib\armeabi-v7a
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ library\lib\arm64-v8a
1
-
-
1
1
-
+
1
-
-
-
+
1
-
+
1
-
+
+ 1
+
+
1
+
+ 0
+
-
-
+
+
+ library\lib\armeabi-v7a
1
-
+
+
+
1
-
+
1
-
+
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
+ 1
+
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
1
-
+
+
+
+
1
1
-
+
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+
+ Assets
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ Assets
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
+ Assets
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ Assets
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
-
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+ 1
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+ 1
+
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+ 1
+
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
@@ -879,7 +901,7 @@
..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
@@ -889,7 +911,7 @@
..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
@@ -899,7 +921,7 @@
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
@@ -909,7 +931,7 @@
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
@@ -919,7 +941,7 @@
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
@@ -929,7 +951,7 @@
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
@@ -939,7 +961,7 @@
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
@@ -949,132 +971,23 @@
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
- 1
-
-
- 1
-
-
-
-
- ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
- 1
-
-
- ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
- 1
-
-
-
-
-
-
-
-
- 1
-
-
- 1
-
-
- 1
-
-
-
-
-
-
-
- Contents\Resources
- 1
-
-
- Contents\Resources
- 1
-
-
-
-
- library\lib\armeabi-v7a
- 1
-
-
- library\lib\arm64-v8a
- 1
-
-
- 1
-
-
- 1
-
-
- 1
-
-
- 1
-
-
- 1
-
-
- 1
-
-
- 0
-
-
-
-
- library\lib\armeabi-v7a
- 1
-
-
-
-
- 1
-
-
- 1
-
-
-
-
- Assets
- 1
-
-
- Assets
- 1
-
-
-
-
- Assets
- 1
-
-
- Assets
- 1
-
-
-
-
+
+
+
+
+
-
-
-
-
+
+
+
12
diff --git a/Source/CoverageConfiguration.pas b/Source/CoverageConfiguration.pas
index 91e3bf3..3f015f3 100644
--- a/Source/CoverageConfiguration.pas
+++ b/Source/CoverageConfiguration.pas
@@ -20,13 +20,16 @@ interface
I_ParameterProvider,
I_LogManager,
ModuleNameSpaceUnit,
- uConsoleOutput;
+ uConsoleOutput,
+ System.Generics.Collections;
type
TCoverageConfiguration = class(TInterfacedObject, ICoverageConfiguration)
strict private
FExeFileName: string;
+ FExeFileNames: TList;
FMapFileName: string;
+ FMapFileNames: TList;
FSourceDir: string;
FOutputDir: string;
FDebugLogFileName: string;
@@ -35,11 +38,13 @@ TCoverageConfiguration = class(TInterfacedObject, ICoverageConfiguration)
FDProjUnitsLst: TStringList;
FUnitsStrLst: TStringList;
FExcludedUnitsStrLst: TStringList;
+ FExcludedClassPrefixesStrLst: TStringList;
FExeParamsStrLst: TStrings;
FSourcePathLst: TStrings;
FStripFileExtension: Boolean;
FEmmaOutput: Boolean;
FEmmaOutput21: Boolean;
+ FJacocoOutput: boolean;
FSeparateMeta: Boolean;
FXmlOutput: Boolean;
FXmlLines: Boolean;
@@ -48,6 +53,7 @@ TCoverageConfiguration = class(TInterfacedObject, ICoverageConfiguration)
FTestExeExitCode: Boolean;
FUseTestExePathAsWorkingDir: Boolean;
FExcludeSourceMaskLst: TStrings;
+ FIncludeSourceMaskLst: TStrings;
FLoadingFromDProj: Boolean;
FModuleNameSpaces: TModuleNameSpaceList;
FUnitNameSpaces: TUnitNameSpaceList;
@@ -64,6 +70,7 @@ TCoverageConfiguration = class(TInterfacedObject, ICoverageConfiguration)
function GetExeOutputFromDProj(const Project: IXMLNode; const ProjectName: TFileName): string;
function GetSourceDirsFromDProj(const Project: IXMLNode): string;
function GetCodePageFromDProj(const Project: IXMLNode): Integer;
+ procedure ParseDGroupProj(const DGroupProjFilename: TFileName);
procedure ParseDProj(const DProjFilename: TFileName);
function IsPathInExclusionList(const APath: TFileName): Boolean;
procedure ExcludeSourcePaths;
@@ -78,6 +85,8 @@ TCoverageConfiguration = class(TInterfacedObject, ICoverageConfiguration)
procedure ParseMapFileSwitch(var AParameter: Integer);
procedure ParseUnitSwitch(var AParameter: Integer);
procedure AddUnitString(AUnitString: string);
+ procedure ParseExcludedClassPrefixesSwitch(var AParameter: Integer);
+ procedure AddExcludedClassPrefix(AClassPrefix: string);
procedure ParseUnitFileSwitch(var AParameter: Integer);
procedure ReadUnitsFile(const AUnitsFileName: string);
procedure ParseExecutableParametersSwitch(var AParameter: Integer);
@@ -87,12 +96,15 @@ TCoverageConfiguration = class(TInterfacedObject, ICoverageConfiguration)
procedure ParseOutputDirectorySwitch(var AParameter: Integer);
procedure ParseLoggingTextSwitch(var AParameter: Integer);
procedure ParseWinApiLoggingSwitch(var AParameter: Integer);
+ procedure ParseDgroupProjSwitch(var AParameter: Integer);
procedure ParseDprojSwitch(var AParameter: Integer);
- procedure ParseExcludeSourceMaskSwitch(var AParameter: Integer);
+ procedure ParseSourceMaskSwitch(var AParameter: Integer; out AMaskLst: TStrings);
procedure ParseModuleNameSpaceSwitch(var AParameter: Integer);
procedure ParseUnitNameSpaceSwitch(var AParameter: Integer);
procedure ParseLineCountSwitch(var AParameter: Integer);
procedure ParseCodePageSwitch(var AParameter: Integer);
+ private
+ function GetMainSource(const Project: IXMLNode): string;
public
constructor Create(const AParameterProvider: IParameterProvider);
destructor Destroy; override;
@@ -101,17 +113,21 @@ TCoverageConfiguration = class(TInterfacedObject, ICoverageConfiguration)
function ApplicationParameters: string;
function ExeFileName: string;
+ function ExeFileNames: TList;
function MapFileName: string;
+ function MapFileNames: TList;
function OutputDir: string;
function SourceDir: string;
function DebugLogFile: string;
function SourcePaths: TStrings;
function Units: TStrings;
function ExcludedUnits: TStrings;
+ function ExcludedClassPrefixes: TStrings;
function UseApiDebug: Boolean;
function IsComplete(var AReason: string): Boolean;
function EmmaOutput: Boolean;
function EmmaOutput21: Boolean;
+ function JacocoOutput: Boolean;
function SeparateMeta: Boolean;
function XmlOutput: Boolean;
function XmlLines: Boolean;
@@ -162,6 +178,9 @@ constructor TCoverageConfiguration.Create(const AParameterProvider: IParameterPr
begin
inherited Create;
+ FMapFileNames := TList.Create;
+ FExeFileNames := TList.Create;
+
FLogManager := nil;
FParameterProvider := AParameterProvider;
@@ -177,6 +196,11 @@ constructor TCoverageConfiguration.Create(const AParameterProvider: IParameterPr
FExcludedUnitsStrLst.Sorted := True;
FExcludedUnitsStrLst.Duplicates := dupIgnore;
+ FExcludedClassPrefixesStrLst := TStringList.Create;
+ FExcludedClassPrefixesStrLst.CaseSensitive := False;
+ FExcludedClassPrefixesStrLst.Sorted := True;
+ FExcludedClassPrefixesStrLst.Duplicates := dupIgnore;
+
FDProjUnitsLst := TStringList.Create;
FDProjUnitsLst.CaseSensitive := False;
FDProjUnitsLst.Sorted := True;
@@ -194,21 +218,28 @@ constructor TCoverageConfiguration.Create(const AParameterProvider: IParameterPr
FXmlOutput := False;
FXmlLines := False;
FExcludeSourceMaskLst := TStringList.Create;
+ FIncludeSourceMaskLst := TStringList.Create;
FModuleNameSpaces := TModuleNameSpaceList.Create;
FUnitNameSpaces := TUnitNameSpaceList.Create;
FLineCountLimit := 0;
+
+ FOutputDir := ExtractFilePath(ParamStr(0));
end;
destructor TCoverageConfiguration.Destroy;
begin
FLogManager := nil;
FUnitsStrLst.Free;
+ FExcludedClassPrefixesStrLst.Free;
FExcludedUnitsStrLst.Free;
FExeParamsStrLst.Free;
FSourcePathLst.Free;
FExcludeSourceMaskLst.Free;
+ FIncludeSourceMaskLst.Free;
FModuleNameSpaces.Free;
FUnitNameSpaces.free;
+ FMapFileNames.free;
+ FExeFileNames.free;
inherited;
end;
@@ -264,6 +295,11 @@ function TCoverageConfiguration.ExcludedUnits : TStrings;
Result := FExcludedUnitsStrLst;
end;
+function TCoverageConfiguration.ExcludedClassPrefixes: TStrings;
+begin
+ Result := FExcludedClassPrefixesStrLst;
+end;
+
function TCoverageConfiguration.SourcePaths: TStrings;
begin
Result := FSourcePathLst;
@@ -290,11 +326,21 @@ function TCoverageConfiguration.MapFileName: string;
Result := FMapFileName;
end;
+function TCoverageConfiguration.MapFileNames: TList;
+begin
+ Result := FMapFileNames;
+end;
+
function TCoverageConfiguration.ExeFileName: string;
begin
Result := FExeFileName;
end;
+function TCoverageConfiguration.ExeFileNames: TList;
+begin
+ Result := FExeFileNames;
+end;
+
function TCoverageConfiguration.OutputDir: string;
begin
Result := FOutputDir;
@@ -383,8 +429,21 @@ function TCoverageConfiguration.UseTestExePathAsWorkingDir: Boolean;
function TCoverageConfiguration.IsPathInExclusionList(const APath: TFileName): Boolean;
var
Mask: string;
+ IsIncluded: boolean;
begin
Result := False;
+ // if inclusion list is empty, everything is included
+ IsIncluded := true;
+ // first check if present in inclusion list
+ for Mask in FIncludeSourceMaskLst do
+ begin
+ IsIncluded := MatchesMask(APath, Mask);
+ if IsIncluded then
+ break;
+ end;
+ if not IsIncluded then
+ Exit(True);
+
for Mask in FExcludeSourceMaskLst do
begin
if MatchesMask(APath, Mask) then
@@ -392,6 +451,11 @@ function TCoverageConfiguration.IsPathInExclusionList(const APath: TFileName): B
end;
end;
+function TCoverageConfiguration.JacocoOutput: Boolean;
+begin
+ result := FJacocoOutput;
+end;
+
procedure TCoverageConfiguration.ParseBooleanSwitches;
function CleanSwitch(const Switch: string): string;
begin
@@ -415,6 +479,7 @@ procedure TCoverageConfiguration.ParseBooleanSwitches;
uConsoleOutput.G_Verbose_Output := IsSet(I_CoverageConfiguration.cPARAMETER_VERBOSE);
FTestExeExitCode := IsSet(I_CoverageConfiguration.cPARAMETER_TESTEXE_EXIT_CODE);
FUseTestExePathAsWorkingDir := IsSet(I_CoverageConfiguration.cPARAMETER_USE_TESTEXE_WORKING_DIR);
+ FJacocoOutput:= IsSet(I_CoverageConfiguration.cPARAMETER_JACOCO);
end;
procedure TCoverageConfiguration.ExcludeSourcePaths;
@@ -519,6 +584,8 @@ procedure TCoverageConfiguration.LogTracking;
for CurrentUnit in FExcludedUnitsStrLst do
VerboseOutput('Exclude from coverage tracking for: ' + CurrentUnit);
+
+ VerboseOutput('Exclude from coverage tracking classes with prefix: ' + FExcludedClassPrefixesStrLst.CommaText);
end;
function TCoverageConfiguration.ParseParameter(const AParameter: Integer): string;
@@ -561,6 +628,8 @@ procedure TCoverageConfiguration.ParseSwitch(var AParameter: Integer);
ParseMapFileSwitch(AParameter)
else if SwitchItem = I_CoverageConfiguration.cPARAMETER_UNIT then
ParseUnitSwitch(AParameter)
+ else if SwitchItem = I_CoverageConfiguration.cPARAMETER_EXCLUDE_CLASS_PREFIX then
+ ParseExcludedClassPrefixesSwitch(AParameter)
else if SwitchItem = I_CoverageConfiguration.cPARAMETER_UNIT_FILE then
ParseUnitFileSwitch(AParameter)
else if SwitchItem = I_CoverageConfiguration.cPARAMETER_EXECUTABLE_PARAMETER then
@@ -594,14 +663,19 @@ procedure TCoverageConfiguration.ParseSwitch(var AParameter: Integer);
or (SwitchItem = I_CoverageConfiguration.cPARAMETER_HTML_OUTPUT)
or (SwitchItem = I_CoverageConfiguration.cPARAMETER_VERBOSE)
or (SwitchItem = I_CoverageConfiguration.cPARAMETER_TESTEXE_EXIT_CODE)
+ or (SwitchItem = I_CoverageConfiguration.cPARAMETER_JACOCO)
or (SwitchItem = I_CoverageConfiguration.cPARAMETER_USE_TESTEXE_WORKING_DIR) then
begin
// do nothing, because its already parsed
end
+ else if SwitchItem = I_CoverageConfiguration.cPARAMETER_DGROUPPROJ then
+ ParseDgroupProjSwitch(AParameter)
else if SwitchItem = I_CoverageConfiguration.cPARAMETER_DPROJ then
ParseDprojSwitch(AParameter)
else if SwitchItem = I_CoverageConfiguration.cPARAMETER_EXCLUDE_SOURCE_MASK then
- ParseExcludeSourceMaskSwitch(AParameter)
+ ParseSourceMaskSwitch(AParameter, {out} FExcludeSourceMaskLst)
+ else if SwitchItem = I_CoverageConfiguration.cPARAMETER_INCLUDE_SOURCE_MASK then
+ ParseSourceMaskSwitch(AParameter, {out} FIncludeSourceMaskLst)
else if SwitchItem = I_CoverageConfiguration.cPARAMETER_MODULE_NAMESPACE then
ParseModuleNameSpaceSwitch(AParameter)
else if SwitchItem = I_CoverageConfiguration.cPARAMETER_UNIT_NAMESPACE then
@@ -661,6 +735,31 @@ procedure TCoverageConfiguration.ParseUnitSwitch(var AParameter: Integer);
end;
end;
+procedure TCoverageConfiguration.ParseExcludedClassPrefixesSwitch(var AParameter: Integer);
+var
+ Prefix: string;
+begin
+ Inc(AParameter);
+ try
+ Prefix := ParseParameter(AParameter);
+ while Prefix <> '' do
+ begin
+ AddExcludedClassPrefix(Prefix);
+
+ Inc(AParameter);
+ Prefix := ParseParameter(AParameter);
+ end;
+
+ if FExcludedClassPrefixesStrLst.Count = 0 then
+ raise EConfigurationException.Create('Expected at least one class prefix');
+
+ Dec(AParameter);
+ except
+ on EParameterIndexException do
+ raise EConfigurationException.Create('Expected at least one class prefix');
+ end;
+end;
+
procedure TCoverageConfiguration.AddUnitString(AUnitString: string);
begin
if Length(AUnitString) > 0 then
@@ -676,6 +775,14 @@ procedure TCoverageConfiguration.AddUnitString(AUnitString: string);
end;
end;
+procedure TCoverageConfiguration.AddExcludedClassPrefix(AClassPrefix: string);
+begin
+ if Length(AClassPrefix) > 0 then
+ begin
+ FExcludedClassPrefixesStrLst.add(AClassPrefix);
+ end;
+end;
+
procedure TCoverageConfiguration.ParseUnitFileSwitch(var AParameter: Integer);
var
UnitsFileName: string;
@@ -808,7 +915,8 @@ procedure TCoverageConfiguration.ParseSourcePathsFileSwitch(var AParameter: Inte
procedure TCoverageConfiguration.ReadSourcePathFile(const ASourceFileName: string);
var
InputFile: TextFile;
- SourcePathLine: string;
+ SourcePathLine,
+ FullSourceDir: string;
begin
OpenInputFileForReading(ASourceFileName, InputFile);
try
@@ -816,6 +924,14 @@ procedure TCoverageConfiguration.ReadSourcePathFile(const ASourceFileName: strin
begin
ReadLn(InputFile, SourcePathLine);
+ if (FSourceDir <> '') and TPath.IsRelativePath(SourcePathLine) then
+ begin
+ FullSourceDir := TPath.Combine(FSourceDir, SourcePathLine);
+ if TDirectory.Exists(FullSourceDir) then
+ begin
+ FSourcePathLst.Add(FullSourceDir);
+ end;
+ end;
SourcePathLine := MakePathAbsolute(SourcePathLine, ASourceFileName);
if DirectoryExists(SourcePathLine) then
@@ -909,6 +1025,22 @@ function TCoverageConfiguration.GetCurrentConfig(const Project: IXMLNode): strin
end;
end;
+function TCoverageConfiguration.GetMainSource(const Project: IXMLNode): string;
+var
+ Node: IXMLNode;
+ MainSourceNode: IXMLNode;
+begin
+ Assert(Assigned(Project));
+ Result := '';
+ Node := Project.ChildNodes.Get(0);
+ if (Node.LocalName = 'PropertyGroup') then
+ begin
+ MainSourceNode := Node.ChildNodes.FindNode('MainSource');
+ if MainSourceNode <> nil then
+ Result := MainSourceNode.Text;
+ end;
+end;
+
function TCoverageConfiguration.GetBasePropertyGroupNode(const Project: IXMLNode): IXMLNode;
var
GroupIndex: Integer;
@@ -960,12 +1092,15 @@ function TCoverageConfiguration.GetExeOutputFromDProj(const Project: IXMLNode; c
var
CurrentConfig: string;
CurrentPlatform: string;
- DCC_ExeOutputNode: IXMLNode;
+ MainSource: string;
+ DCC_OutputNode: IXMLNode;
DCC_ExeOutput: string;
+ DCC_ExtensionOutput: string;
Node: IXMLNode;
begin
Result := '';
Assert(Assigned(Project));
+ MainSource := GetMainSource(Project);
CurrentConfig := GetCurrentConfig(Project);
{$IFDEF WIN64}
@@ -979,18 +1114,78 @@ function TCoverageConfiguration.GetExeOutputFromDProj(const Project: IXMLNode; c
begin
if CurrentConfig <> '' then
begin
- DCC_ExeOutputNode := Node.ChildNodes.FindNode('DCC_ExeOutput');
- if DCC_ExeOutputNode <> nil then
+ if ExtractFileExt(MainSource) = '.dpk' then
+ Begin
+ DCC_OutputNode := Node.ChildNodes.FindNode('DCC_BplOutput');
+ DCC_ExtensionOutput := '.bpl';
+ End
+ else
+ BEgin
+ DCC_OutputNode := Node.ChildNodes.FindNode('DCC_ExeOutput');
+ DCC_ExtensionOutput := '.exe';
+ End;
+
+ if DCC_OutputNode <> nil then
begin
- DCC_ExeOutput := DCC_ExeOutputNode.Text;
+ DCC_ExeOutput := DCC_OutputNode.Text;
DCC_ExeOutput := StringReplace(DCC_ExeOutput, '$(Platform)', CurrentPlatform, [rfReplaceAll, rfIgnoreCase]);
DCC_ExeOutput := StringReplace(DCC_ExeOutput, '$(Config)', CurrentConfig, [rfReplaceAll, rfIgnoreCase]);
- Result := IncludeTrailingPathDelimiter(DCC_ExeOutput) + ChangeFileExt(ExtractFileName(ProjectName), '.exe');
+ Result := IncludeTrailingPathDelimiter(DCC_ExeOutput) + ChangeFileExt(ExtractFileName(ProjectName), DCC_ExtensionOutput);
end
else
- Result := ChangeFileExt(ProjectName, '.exe');
+ Result := ChangeFileExt(ProjectName,DCC_ExtensionOutput);
+ end;
+ end;
+end;
+
+procedure TCoverageConfiguration.ParseDGroupProj(const DGroupProjFilename: TFileName);
+var
+ Document: IXMLDocument;
+ ItemGroup: IXMLNode;
+ Node: IXMLNode;
+ Project: IXMLNode;
+ ProjectName, Path, SearchPaths: string;
+ I: Integer;
+ RootPath: TFileName;
+ SourcePath: TFileName;
+ ExeFileName: TFileName;
+begin
+ RootPath := ExtractFilePath(TPath.GetFullPath(DGroupProjFilename));
+ Document := TXMLDocument.Create(nil);
+ Document.LoadFromFile(DGroupProjFilename);
+ Project := Document.ChildNodes.FindNode('Project');
+ if Project <> nil then
+ begin
+ ItemGroup := Project.ChildNodes.FindNode('ItemGroup');
+ if ItemGroup <> nil then
+ begin
+ FLoadingFromDProj := True;
+ for I := 0 to ItemGroup.ChildNodes.Count - 1 do
+ begin
+ Node := ItemGroup.ChildNodes.Get(I);
+ if Node.LocalName = 'Projects' then
+ begin
+ ProjectName := TPath.GetFullPath(TPath.Combine(RootPath, Node.Attributes['Include']));
+ ParseDProj(ProjectName);
+ end;
end;
end;
+ end;
+end;
+
+procedure TCoverageConfiguration.ParseDgroupProjSwitch(var AParameter: Integer);
+var
+ DGroupProjPath: TFileName;
+begin
+ Inc(AParameter);
+ try
+ DGroupProjPath := ParseParameter(AParameter);
+ ParseDGroupProj(DGroupProjPath);
+ except
+ on EParameterIndexException do
+ raise EConfigurationException.Create('Expected parameter for project file');
+ end;
+
end;
procedure TCoverageConfiguration.ParseDProj(const DProjFilename: TFileName);
@@ -1016,8 +1211,10 @@ procedure TCoverageConfiguration.ParseDProj(const DProjFilename: TFileName);
begin
if FExeFileName = '' then
FExeFileName := TPath.GetFullPath(TPath.Combine(RootPath, ExeFileName));
+ FExeFileNames.Add(TPath.GetFullPath(TPath.Combine(RootPath, ExeFileName)));
if FMapFileName = '' then
FMapFileName := ChangeFileExt(FExeFileName, '.map');
+ FMapFileNames.Add(TPath.GetFullPath(TPath.Combine(RootPath, ChangeFileExt(ExeFileName, '.map'))));
end;
SearchPaths := GetSourceDirsFromDProj(Project);
@@ -1056,7 +1253,7 @@ procedure TCoverageConfiguration.ParseDProj(const DProjFilename: TFileName);
end;
end;
-procedure TCoverageConfiguration.ParseExcludeSourceMaskSwitch(var AParameter: Integer);
+procedure TCoverageConfiguration.ParseSourceMaskSwitch(var AParameter: Integer; out AMaskLst: TStrings);
var
SourcePathString: string;
begin
@@ -1065,18 +1262,18 @@ procedure TCoverageConfiguration.ParseExcludeSourceMaskSwitch(var AParameter: In
SourcePathString := ParseParameter(AParameter);
while SourcePathString <> '' do
begin
- FExcludeSourceMaskLst.Add(ReplaceStr(SourcePathString, '/', TPath.DirectorySeparatorChar));
+ AMaskLst.Add(ReplaceStr(SourcePathString, '/', TPath.DirectorySeparatorChar));
Inc(AParameter);
SourcePathString := ParseParameter(AParameter);
end;
- if FExcludeSourceMaskLst.Count = 0 then
- raise EConfigurationException.Create('Expected at least one exclude source mask');
+ if AMaskLst.Count = 0 then
+ raise EConfigurationException.Create('Expected at least one source mask');
Dec(AParameter);
except
on EParameterIndexException do
- raise EConfigurationException.Create('Expected at least one exclude source mask');
+ raise EConfigurationException.Create('Expected at least one source mask');
end;
end;
@@ -1182,5 +1379,4 @@ procedure TCoverageConfiguration.ParseCodePageSwitch(var AParameter: Integer);
end;
end;
-end.
-
+end.
\ No newline at end of file
diff --git a/Source/DebugProcess.pas b/Source/DebugProcess.pas
index e67375b..1cdbf38 100644
--- a/Source/DebugProcess.pas
+++ b/Source/DebugProcess.pas
@@ -173,8 +173,9 @@ function TDebugProcess.FindDebugModuleFromAddress(Addr: Pointer): IDebugModule;
ModuleAddress: NativeUINT;
function AddressBelongsToModule(const AModule: IDebugModule): Boolean;
+ var Base: HMODULE;
begin
- var Base := AModule.Base;
+ Base := AModule.Base;
Result := ((ModuleAddress >= Base)
and (ModuleAddress <= (Base + AModule.Size)));
end;
diff --git a/Source/Debugger.pas b/Source/Debugger.pas
index 0f2a127..3641e31 100644
--- a/Source/Debugger.pas
+++ b/Source/Debugger.pas
@@ -31,7 +31,8 @@ interface
ModuleNameSpaceUnit,
uConsoleOutput,
JclPEImage,
- JwaPsApi;
+ JwaPsApi,
+ System.Generics.Collections;
type
TDebugger = class(TInterfacedObject, IDebugger)
@@ -60,6 +61,7 @@ TDebugger = class(TInterfacedObject, IDebugger)
procedure AddBreakPoints(
const AModuleList: TStrings;
const AExcludedModuleList: TStrings;
+ const AExcludedClassesPrefixes: TStrings;
const AModule: IDebugModule;
const AMapScanner: TJCLMapScanner;
AModuleNameSpace: TModuleNameSpace = nil;
@@ -69,6 +71,7 @@ TDebugger = class(TInterfacedObject, IDebugger)
function StartProcessToDebug: Boolean;
procedure ProcessDebugEvents;
+ procedure ProcessDebugEventsWinthoutTest(AMapFileNames: TList);
procedure HandleExceptionDebug(
const ADebugEvent: DEBUG_EVENT;
@@ -89,6 +92,7 @@ TDebugger = class(TInterfacedObject, IDebugger)
procedure GenerateReport;
+
procedure PrintUsage;
procedure PrintSummary;
public
@@ -103,6 +107,7 @@ implementation
uses
Winapi.ActiveX,
System.SysUtils,
+ System.StrUtils,
JwaNtStatus,
JwaWinNT,
{$IFDEF madExcept}
@@ -123,8 +128,51 @@ implementation
I_DebugThread,
I_Report,
EmmaCoverageFileUnit,
+ JacocoCoverageFileUnit,
DebugModule,
- JclFileUtils, JclMapScannerHelper;
+ JclMapScannerHelper,
+ JclFileUtils,
+ System.Types;
+
+function GetApplicationVersion: string;
+var
+ VersionSegmentSize: DWORD;
+ VersionValue: PChar;
+ BufferSize: DWORD;
+ ApplicationName: String;
+ VersionBuffer: PChar;
+ VersionType : String;
+begin
+ Result := '';
+ ApplicationName := ParamStr(0);
+ BufferSize := GetFileVersionInfoSize(PChar(ApplicationName), BufferSize);
+ if BufferSize > 0 then
+ begin
+ VersionBuffer := AllocMem(BufferSize);
+ try
+ GetFileVersionInfo(PChar(ApplicationName), 0, BufferSize, VersionBuffer);
+ VersionValue := nil;
+ VerQueryValue(VersionBuffer, PChar('\VarFileInfo\Translation'),
+ Pointer(VersionValue), VersionSegmentSize);
+
+ VersionType := IntToHex(LoWord(PLongInt(VersionValue)^), 4) +
+ IntToHex(HiWord(PLongInt(VersionValue)^), 4)+ '\ProductVersion';
+
+ if VerQueryValue(VersionBuffer, PChar('\StringFileInfo\' + VersionType),
+ Pointer(VersionValue), VersionSegmentSize) then
+ begin
+ Result := VersionValue;
+ Result := ReplaceText(ReplaceText(Result, 'Build', '.'), ' ', '');
+ end;
+ finally
+ FreeMem(VersionBuffer, BufferSize);
+ end;
+ end
+ else
+ begin
+ OutputDebugString(PChar('GetApplicationProductVersion error ' + SysErrorMessage(GetLastError)));
+ end;
+end;
constructor TDebugger.Create;
begin
@@ -138,6 +186,7 @@ constructor TDebugger.Create;
FLogManager := TLogManager.Create;
uConsoleOutput.G_LogManager := FLogManager;
+ ConsoleOutput('CodeCoverage v' + GetApplicationVersion);
FModuleList := TModuleList.Create;
end;
@@ -166,6 +215,9 @@ procedure TDebugger.PrintUsage;
ConsoleOutput(I_CoverageConfiguration.cPARAMETER_EXECUTABLE +
' executable.exe -- the executable to run');
ConsoleOutput('or');
+ ConsoleOutput(I_CoverageConfiguration.cPARAMETER_DGROUPPROJ +
+ ' Project.dgroupProj -- Delphi group project file');
+
ConsoleOutput(I_CoverageConfiguration.cPARAMETER_DPROJ +
' Project.dproj -- Delphi project file');
ConsoleOutput('');
@@ -177,6 +229,12 @@ procedure TDebugger.PrintUsage;
ConsoleOutput(I_CoverageConfiguration.cPARAMETER_EXCLUDE_SOURCE_MASK +
' mask1 mask2 etc -- a list of file masks to exclude from list of units'
);
+ ConsoleOutput(I_CoverageConfiguration.cPARAMETER_INCLUDE_SOURCE_MASK +
+ ' mask1 mask2 etc -- incude only units matching the provided file masks'
+ );
+ ConsoleOutput(I_CoverageConfiguration.cPARAMETER_EXCLUDE_CLASS_PREFIX +
+ ' prefix1 prefix2 etc -- a list of class prefixes to exclude from coverage analysis'
+ );
ConsoleOutput(I_CoverageConfiguration.cPARAMETER_UNIT_FILE +
' filename -- a file containing a list of units to create');
ConsoleOutput(' reports for - one unit per line');
@@ -247,6 +305,8 @@ procedure TDebugger.PrintUsage;
' -- Passthrough the exitcode of the application');
ConsoleOutput(I_CoverageConfiguration.cPARAMETER_USE_TESTEXE_WORKING_DIR +
' -- Use the application''s path as working directory');
+ ConsoleOutput(I_CoverageConfiguration.cPARAMETER_JACOCO +
+ ' -- Output jacoco coverage XML file in the output directory');
end;
@@ -360,6 +420,12 @@ procedure TDebugger.GenerateReport;
CoverageReport := TEmmaCoverageFile.Create(FCoverageConfiguration);
CoverageReport.Generate(FCoverageStats, FModuleList,FLogManager);
end;
+
+ if (FCoverageConfiguration.JacocoOutput) then
+ begin
+ CoverageReport := TJacocoCoverageReport.Create(FCoverageConfiguration);
+ CoverageReport.Generate(FCoverageStats, FModuleList,FLogManager);
+ end;
end;
function TDebugger.StartProcessToDebug: Boolean;
@@ -445,6 +511,7 @@ procedure TDebugger.Debug;
VerboseOutput('Started successfully');
ProcessDebugEvents;
VerboseOutput('Finished processing debug events');
+ ProcessDebugEventsWinthoutTest(FCoverageConfiguration.MapFileNames);
GenerateReport;
VerboseOutput('Finished generating reports');
PrintSummary;
@@ -564,13 +631,60 @@ procedure TDebugger.ProcessDebugEvents;
end;
end;
+procedure TDebugger.ProcessDebugEventsWinthoutTest(AMapFileNames: TList);
+ var MapFileName, ProcessName: String;
+begin
+
+ for MapFileName in FCoverageConfiguration.MapFileNames do
+ begin
+ try
+ ProcessName := PathRemoveExtension(MapFileName) + '.bpl';
+ AddBreakPoints(
+ FCoverageConfiguration.Units(),
+ FCoverageConfiguration.ExcludedUnits(),
+ FCoverageConfiguration.ExcludedClassPrefixes(),
+ FDebugProcess,
+ TJCLMapScanner.Create(MapFileName),
+ FCoverageConfiguration.ModuleNameSpace(ExtractFileName(ProcessName)),
+ FCoverageConfiguration.UnitNameSpace(ExtractFileName(ProcessName)));
+
+ except
+ on E: Exception do
+ begin
+ FLogManager.Log(
+ 'Exception during add breakpoints:' + E.Message + ' ' + E.ToString());
+ end;
+ end;
+ end;
+
+
+
+end;
+
procedure TDebugger.AddBreakPoints(
const AModuleList: TStrings;
const AExcludedModuleList: TStrings;
+ const AExcludedClassesPrefixes: TStrings;
const AModule: IDebugModule;
const AMapScanner: TJCLMapScanner;
AModuleNameSpace: TModuleNameSpace;
AUnitNameSpace: TUnitNameSpace);
+
+ function IsClassExcluded(const AClassName: String): Boolean;
+ var
+ Prefix: String;
+ begin
+ for Prefix in AExcludedClassesPrefixes do
+ begin
+ if StartsText(Prefix, AClassName) then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+ Result := False;
+ end;
+
var
LineIndex: Integer;
BreakPoint: IBreakPoint;
@@ -582,6 +696,10 @@ procedure TDebugger.AddBreakPoints(
SkippedModules: TStringList;
Prefix: String;
UnitNameSpace : String;
+ QualifiedModuleName: String;
+ QualifiedProcName: String;
+ TheClassName: String;
+ SkippedClassNames: TStringList;
begin
UnitNameSpace := '';
if Assigned(AModuleNameSpace) then
@@ -592,9 +710,12 @@ procedure TDebugger.AddBreakPoints(
if (AMapScanner <> nil) then
begin
SkippedModules := TStringList.Create;
+ SkippedClassNames := TStringList.Create;
try
SkippedModules.Sorted := True;
SkippedModules.Duplicates := dupIgnore;
+ SkippedClassNames.Sorted := True;
+ SkippedClassNames.Duplicates := dupIgnore;
FLogManager.Log('Adding breakpoints for module:' + AModule.Name);
@@ -606,7 +727,7 @@ procedure TDebugger.AddBreakPoints(
MapLineNumber := AMapScanner.LineNumberByIndex[LineIndex];
// RINGN:Segment 2 are .itext (ICODE).
- if (MapLineNumber.Segment in [1, 2]) then
+ if (MapLineNumber.Segment in [1,2]) then
begin
ModuleName := AMapScanner.MapStringToStr(MapLineNumber.UnitName);
ModuleNameFromAddr := AMapScanner.ModuleNameFromAddr(MapLineNumber.VA);
@@ -639,53 +760,63 @@ procedure TDebugger.AddBreakPoints(
and (AModuleList.IndexOf(ModuleName) > -1)
and (AExcludedModuleList.IndexOf(UnitModuleName) < 0) then
begin
- FLogManager.Log(
- 'Setting BreakPoint for module: ' + ModuleName +
- ' unit ' + UnitName +
- ' moduleName: ' + ModuleName +
- ' unitModuleName: ' + UnitModuleName +
- ' addr:' + IntToStr(LineIndex) +
- {$IF CompilerVersion > 31}
- ' VA:' + IntToHex(MapLineNumber.VA) +
- {$ELSE}
- ' VA:' + IntToHex(MapLineNumber.VA, SizeOf(DWORD)*2) +
- {$ENDIF}
- ' Base:' + IntToStr(AModule.Base) +
- {$IF CompilerVersion > 31}
- ' Address: ' + IntToHex(Integer(AddressFromVA(MapLineNumber.VA, AModule.Base)))
- {$ELSE}
- ' Address: ' + IntToHex(Integer(AddressFromVA(MapLineNumber.VA, AModule.Base)), SizeOf(DWORD)*2)
- {$ENDIF}
- );
+ QualifiedModuleName := Prefix + UnitNameSpace + ModuleName;
+ QualifiedProcName := AMapScanner.ProcNameFromAddr(MapLineNumber.VA);
+ TheClassName := TModuleList.GetClassName(QualifiedModuleName, QualifiedProcName);
+ if IsClassExcluded(TheClassName) then begin
+ FLogManager.Log('NOT ADDING BREAKPOINT FOR "' + QualifiedProcName
+ + '" in EXCLUDED class "' + TheClassName + '" in "' + QualifiedModuleName + '".');
+ SkippedClassNames.Add(TheClassName);
+ end
+ else begin
+ FLogManager.Log(
+ 'Setting BreakPoint for module: ' + ModuleName +
+ ' unit ' + UnitName +
+ ' moduleName: ' + ModuleName +
+ ' unitModuleName: ' + UnitModuleName +
+ ' addr:' + IntToStr(LineIndex) +
+ {$IF CompilerVersion > 31}
+ ' VA:' + IntToHex(MapLineNumber.VA) +
+ {$ELSE}
+ ' VA:' + IntToHex(MapLineNumber.VA, SizeOf(DWORD)*2) +
+ {$ENDIF}
+ ' Base:' + IntToStr(AModule.Base) +
+ {$IF CompilerVersion > 31}
+ ' Address: ' + IntToHex(Integer(AddressFromVA(MapLineNumber.VA, AModule.Base)))
+ {$ELSE}
+ ' Address: ' + IntToHex(Integer(AddressFromVA(MapLineNumber.VA, AModule.Base)), SizeOf(DWORD)*2)
+ {$ENDIF}
+ );
- BreakPoint := FBreakPointList.BreakPointByAddress[(AddressFromVA(MapLineNumber.VA, AModule.Base))];
- if not Assigned(BreakPoint) then
- begin
- BreakPoint := TBreakPoint.Create(
- FDebugProcess,
- AddressFromVA(MapLineNumber.VA, AModule.Base),
- AModule,
- FLogManager
- );
- FBreakPointList.Add(BreakPoint);
- FModuleList.HandleBreakPoint(
+ BreakPoint := FBreakPointList.BreakPointByAddress[(AddressFromVA(MapLineNumber.VA, AModule.Base))];
+ if not Assigned(BreakPoint) then
+ begin
+ BreakPoint := TBreakPoint.Create(
+ FDebugProcess,
+ AddressFromVA(MapLineNumber.VA, AModule.Base),
+ AModule,
+ FLogManager
+ );
+ FBreakPointList.Add(BreakPoint);
+ FModuleList.HandleBreakPoint(
+ QualifiedModuleName,
+ UnitName,
+ QualifiedProcName,
+ MapLineNumber.LineNumber,
+ BreakPoint,
+ FLogManager
+ );
+ end;
+
+ BreakPoint.AddDetails(
Prefix + UnitNameSpace + ModuleName,
UnitName,
- AMapScanner.ProcNameFromAddr(MapLineNumber.VA),
- MapLineNumber.LineNumber,
- BreakPoint,
- FLogManager
+ MapLineNumber.LineNumber
);
- end;
-
- BreakPoint.AddDetails(
- Prefix + UnitNameSpace + ModuleName,
- UnitName,
- MapLineNumber.LineNumber
- );
- if (not BreakPoint.Activate) then
- FLogManager.Log('BP FAILED to activate successfully');
+ if (not BreakPoint.Activate) then
+ FLogManager.Log('BP FAILED to activate successfully');
+ end;
end
else
SkippedModules.Add(UnitModuleName);
@@ -701,8 +832,13 @@ procedure TDebugger.AddBreakPoints(
begin
FLogManager.Log('Module ' + UnitModuleName + ' skipped');
end;
+ for TheClassName in SkippedClassNames do
+ begin
+ FLogManager.Log('Class ' + TheClassName + ' skipped');
+ end;
finally
SkippedModules.Free;
+ SkippedClassNames.Free;
end;
end;
@@ -802,6 +938,7 @@ procedure TDebugger.HandleCreateProcess(const ADebugEvent: DEBUG_EVENT);
AddBreakPoints(
FCoverageConfiguration.Units(),
FCoverageConfiguration.ExcludedUnits(),
+ FCoverageConfiguration.ExcludedClassPrefixes(),
FDebugProcess,
FMapScanner,
FCoverageConfiguration.ModuleNameSpace(ExtractFileName(ProcessName)),
@@ -1211,6 +1348,7 @@ procedure TDebugger.HandleLoadDLL(const ADebugEvent: DEBUG_EVENT);
AddBreakPoints(
FCoverageConfiguration.Units,
FCoverageConfiguration.ExcludedUnits,
+ FCoverageConfiguration.ExcludedClassPrefixes,
Module,
MapScanner,
ModuleNameSpace,
diff --git a/Source/HTMLCoverageReport.pas b/Source/HTMLCoverageReport.pas
index 885fc14..36298a3 100644
--- a/Source/HTMLCoverageReport.pas
+++ b/Source/HTMLCoverageReport.pas
@@ -432,7 +432,7 @@ procedure THTMLCoverageReport.AddStatistics(
const ASourceFileName: string;
const AOutFile: TTextWriter);
var
- percent : String;
+ percent : String;
begin
AOutFile.WriteLine('Statistics for ' + ASourceFileName + '
');
diff --git a/Source/I_CoverageConfiguration.pas b/Source/I_CoverageConfiguration.pas
index 4695e65..43cd993 100644
--- a/Source/I_CoverageConfiguration.pas
+++ b/Source/I_CoverageConfiguration.pas
@@ -15,7 +15,8 @@ interface
uses
System.Classes,
ModuleNameSpaceUnit,
- I_LogManager;
+ I_LogManager,
+ System.Generics.Collections;
type
ICoverageConfiguration = interface
@@ -23,17 +24,21 @@ interface
function ApplicationParameters: string;
function ExeFileName: string;
+ function ExeFileNames: TList;
function MapFileName: string;
+ function MapFileNames: TList;
function OutputDir: string;
function SourceDir: string;
function SourcePaths: TStrings;
function Units: TStrings;
function ExcludedUnits: TStrings;
+ function ExcludedClassPrefixes: TStrings;
function DebugLogFile: string;
function UseApiDebug: Boolean;
function IsComplete(var AReason: string): Boolean;
function EmmaOutput: Boolean;
function EmmaOutput21: Boolean;
+ function JacocoOutput: Boolean;
function SeparateMeta: Boolean;
function XmlOutput: Boolean;
function XmlLines: Boolean;
@@ -54,6 +59,7 @@ interface
cPARAMETER_EXECUTABLE = '-e';
cPARAMETER_MAP_FILE = '-m';
cPARAMETER_UNIT = '-u';
+ cPARAMETER_EXCLUDE_CLASS_PREFIX = '-ecp';
cPARAMETER_UNIT_FILE = '-uf';
cPARAMETER_SOURCE_DIRECTORY = '-sd';
cPARAMETER_OUTPUT_DIRECTORY = '-od';
@@ -71,7 +77,9 @@ interface
cPARAMETER_XML_LINES_MERGE_GENERICS = '-xmlgenerics';
cPARAMETER_HTML_OUTPUT = '-html';
cPARAMETER_DPROJ = '-dproj';
+ cPARAMETER_DGROUPPROJ = '-dgroupproj';
cPARAMETER_EXCLUDE_SOURCE_MASK = '-esm';
+ cPARAMETER_INCLUDE_SOURCE_MASK = '-ism';
cPARAMETER_MODULE_NAMESPACE = '-mns';
cPARAMETER_UNIT_NAMESPACE = '-uns';
cPARAMETER_EMMA_SEPARATE_META = '-meta';
@@ -79,6 +87,7 @@ interface
cPARAMETER_USE_TESTEXE_WORKING_DIR = '-twd';
cPARAMETER_LINE_COUNT = '-lcl';
cPARAMETER_CODE_PAGE = '-cp';
+ cPARAMETER_JACOCO = '-jacoco';
cIGNORE_UNIT_PREFIX = '!';
implementation
diff --git a/Source/JacocoCoverageFileUnit.pas b/Source/JacocoCoverageFileUnit.pas
new file mode 100644
index 0000000..3be7681
--- /dev/null
+++ b/Source/JacocoCoverageFileUnit.pas
@@ -0,0 +1,413 @@
+(* ********************************************************************* *)
+(* Delphi Code Coverage *)
+(* *)
+(* A quick hack of a Code Coverage Tool for Delphi *)
+(* by Christer Fahlgren and Nick Ring *)
+(* *)
+(* This Source Code Form is subject to the terms of the Mozilla Public *)
+(* License, v. 2.0. If a copy of the MPL was not distributed with this *)
+(* file, You can obtain one at http://mozilla.org/MPL/2.0/. *)
+
+unit JacocoCoverageFileUnit;
+
+interface
+
+uses
+ I_Report,
+ I_CoverageStats,
+ JclSimpleXml,
+ JclStreams,
+ I_CoverageConfiguration,
+ ClassInfoUnit,
+ I_LogManager;
+
+type
+ TJacocoCoverageReport = class(TInterfacedObject, IReport)
+ strict private
+ FCoverageConfiguration: ICoverageConfiguration;
+
+ procedure AddModuleInfo(AAllElement: TJclSimpleXMLElem; const AModuleInfo: TModuleInfo;
+ const ACoverage: ICoverageStats);
+ procedure AddLineCodeStats(ARootElement: TJclSimpleXMLElem; const ACoverage: ICoverageStats;
+ const AModule: TModuleInfo);
+ procedure AddModuleLineHits(ALineHitsElement: TJclSimpleXMLElem; const ACoverage: ICoverageStats);
+ procedure AddModuleStats(const RootElement: TJclSimpleXMLElem; const AModule: TModuleInfo);
+ procedure AddClassInfo(ASourceFileElement: TJclSimpleXMLElem; const AModule: TModuleInfo);
+ procedure AddClassStats(const ARootElement: TJclSimpleXMLElem; const AClass: TClassInfo);
+ procedure AddMethodInfo(AClassElement: TJclSimpleXMLElem; const AMethod: TProcedureInfo);
+ procedure AddMethodStats(const ARootElement: TJclSimpleXMLElem; const AMethod: TProcedureInfo);
+ procedure AddSourceStats(const ARootElement: TJclSimpleXMLElem; const AModule: TModuleInfo);
+
+ procedure AddCoverageElement(const RootElement: TJclSimpleXMLElem; const AType: string;
+ const TotalCoveredCount, TotalUncoveredCount: Integer);
+ function GetCoverageStringValue(const ACovered, ATotal: Integer): string;
+ public
+ constructor Create(const ACoverageConfiguration: ICoverageConfiguration);
+
+ procedure Generate(const ACoverage: ICoverageStats; const AModuleInfoList: TModuleList;
+ const ALogManager: ILogManager);
+ end;
+
+ TJacocoCoverageReportMerger = class helper for TJacocoCoverageReport
+ class function MergeCoverageStatsForGenerics(const ACoverageStatsIn: ICoverageStats): ICoverageStats;
+ end;
+
+implementation
+
+uses
+ System.DateUtils,
+ System.StrUtils,
+ System.SysUtils,
+ System.Math,
+ JclFileUtils,
+ Generics.Collections, CoverageStats;
+
+constructor TJacocoCoverageReport.Create(const ACoverageConfiguration: ICoverageConfiguration);
+begin
+ inherited Create;
+ FCoverageConfiguration := ACoverageConfiguration;
+end;
+
+procedure TJacocoCoverageReport.Generate(const ACoverage: ICoverageStats; const AModuleInfoList: TModuleList;
+ const ALogManager: ILogManager);
+
+var
+ StatsElement: TJclSimpleXMLElem;
+
+ procedure AddValueElement(const AElementName: string; const AValue: Integer);
+ begin
+ StatsElement.Items.Add(AElementName).Properties.Add('value', AValue);
+ end;
+
+ procedure AddElement(AElement: TJclSimpleXMLElem; const APropertyName: string; const AValue: Integer); overload;
+ begin
+ AElement.Properties.Add(APropertyName, AValue);
+ end;
+
+ procedure AddElement(AElement: TJclSimpleXMLElem; const APropertyName: string; const AValue: String); overload;
+ begin
+ AElement.Properties.Add(APropertyName, AValue);
+ end;
+
+var
+ Uid: TGuid;
+ Result: HResult;
+
+ ModuleInfo: TModuleInfo;
+ XML: TJclSimpleXML;
+ SessionElement: TJclSimpleXMLElem;
+ DataElement: TJclSimpleXMLElem;
+ LineHitsElement: TJclSimpleXMLElem;
+ CoverageIndex: Integer;
+ FileIndex: Integer;
+ ModuleCoverage: ICoverageStats;
+ XmlLinesCoverage: ICoverageStats;
+begin
+ ALogManager.Log('Generating jacoco xml report');
+
+ XML := TJclSimpleXML.Create;
+ try
+
+ // Prolog doesn't seem to get written properly (with carriage returns)
+ XML.Prolog.AddDocType('report PUBLIC "-//JACOCO//DTD Report 1.0//EN" "report.dtd"');
+ XML.Prolog.Standalone := true;
+
+ XML.Root.Name := 'report';
+ AddElement(XML.Root, 'name', 'debug'); // For now
+
+ SessionElement := XML.Root.Items.Add('session');
+
+ Result := CreateGuid(Uid);
+ if Result = S_OK then
+ SessionElement.Properties.Add('id', GuidToString(Uid)); { TODO: Not sure of the format }
+ SessionElement.Properties.Add('start', DateTimeToUnix(now)); { TODO: Should be a start time }
+ SessionElement.Properties.Add('dump', DateTimeToUnix(now));
+
+ for ModuleInfo in AModuleInfoList do
+ begin
+ AddModuleInfo(XML.Root, ModuleInfo, ACoverage);
+ end;
+ (*
+ if FCoverageConfiguration.XmlLines then
+ begin
+ if FCoverageConfiguration.XmlMergeGenerics then begin
+ ALogManager.Log('Merging units for generics.');
+ XmlLinesCoverage := MergeCoverageStatsForGenerics(ACoverage);
+ end else
+ XmlLinesCoverage := ACoverage;
+
+ LineHitsElement := DataElement.Items.Add('linehits');
+ for CoverageIndex := 0 to XmlLinesCoverage.Count - 1 do
+ begin
+ ModuleCoverage := XmlLinesCoverage.CoverageReport[CoverageIndex];
+ ALogManager.Log('Coverage for module: ' + ModuleCoverage.Name);
+ for FileIndex := 0 to ModuleCoverage.Count - 1 do
+ begin
+ AddModuleLineHits(LineHitsElement, ModuleCoverage[FileIndex]);
+ end;
+ end;
+ end;
+ *)
+
+ XML.SaveToFile(PathAppend(FCoverageConfiguration.OutputDir, 'jacoco.xml'), seUTF8);
+ finally
+ XML.Free;
+ end;
+end;
+
+procedure TJacocoCoverageReport.AddModuleInfo(AAllElement: TJclSimpleXMLElem; const AModuleInfo: TModuleInfo;
+ const ACoverage: ICoverageStats);
+var
+ PackageElement: TJclSimpleXMLElem;
+ SourceFileElement: TJclSimpleXMLElem;
+begin
+ PackageElement := AAllElement.Items.Add('package');
+ PackageElement.Properties.Add('name', AModuleInfo.ModuleName.Replace('.', '/'));
+
+ AddClassInfo(PackageElement, AModuleInfo);
+
+ SourceFileElement := PackageElement.Items.Add('sourcefile');
+ SourceFileElement.Properties.Add('name', AModuleInfo.ModuleFileName);
+
+ AddLineCodeStats(SourceFileElement, ACoverage, AModuleInfo);
+
+ { TODO: Lines }
+ AddSourceStats(SourceFileElement, AModuleInfo);
+
+end;
+
+procedure TJacocoCoverageReport.AddModuleLineHits(ALineHitsElement: TJclSimpleXMLElem; const ACoverage: ICoverageStats);
+var
+ Line: Integer;
+ FileElement: TJclSimpleXMLElem;
+ StringBuilder: TStringBuilder;
+ CoverageLine: TCoverageLine;
+begin
+ if FCoverageConfiguration.ExcludedUnits.IndexOf(StringReplace(ExtractFileName(ACoverage.Name),
+ ExtractFileExt(ACoverage.Name), '', [rfReplaceAll, rfIgnoreCase])) < 0 then
+ begin
+ FileElement := ALineHitsElement.Items.Add('file');
+ FileElement.Properties.Add('name', ACoverage.Name);
+ StringBuilder := TStringBuilder.Create;
+ try
+ for Line := 0 to ACoverage.GetCoverageLineCount - 1 do
+ begin
+ CoverageLine := ACoverage.CoverageLine[Line];
+ StringBuilder.Append(IfThen(Line = 0, '', ';')).Append(CoverageLine.LineNumber).Append('=')
+ .Append(CoverageLine.LineCount);
+ end;
+ FileElement.Value := StringBuilder.ToString;
+ finally
+ StringBuilder.Free;
+ end;
+ end;
+end;
+
+procedure TJacocoCoverageReport.AddModuleStats(const RootElement: TJclSimpleXMLElem; const AModule: TModuleInfo);
+begin
+ AddCoverageElement(RootElement, 'class, %', AModule.CoveredClassCount, AModule.ClassCount);
+
+ AddCoverageElement(RootElement, 'method, %', AModule.CoveredMethodCount, AModule.MethodCount);
+
+ AddCoverageElement(RootElement, 'block, %', AModule.CoveredLineCount, AModule.LineCount);
+
+ AddCoverageElement(RootElement, 'line, %', AModule.CoveredLineCount, AModule.LineCount);
+end;
+
+procedure TJacocoCoverageReport.AddSourceStats(const ARootElement: TJclSimpleXMLElem; const AModule: TModuleInfo);
+begin
+ AddCoverageElement(ARootElement, 'LINE', AModule.CoveredLineCount, AModule.LineCount - AModule.CoveredLineCount);
+
+ AddCoverageElement(ARootElement, 'METHOD', AModule.CoveredMethodCount,
+ AModule.MethodCount - AModule.CoveredMethodCount);
+
+ AddCoverageElement(ARootElement, 'CLASS', AModule.CoveredClassCount, AModule.ClassCount - AModule.CoveredClassCount);
+end;
+
+procedure TJacocoCoverageReport.AddClassInfo(ASourceFileElement: TJclSimpleXMLElem; const AModule: TModuleInfo);
+var
+ Method: TProcedureInfo;
+ ClassElement: TJclSimpleXMLElem;
+ ClassInfo: TClassInfo;
+begin
+ for ClassInfo in AModule do
+ begin
+ ClassElement := ASourceFileElement.Items.Add('class');
+ { TODO: Check whether this is enough }
+ ClassElement.Properties.Add('name', ClassInfo.Module.Replace('.', '/') + '/' + ClassInfo.TheClassName);
+ ClassElement.Properties.Add('sourcefilename', AModule.ModuleFileName);
+
+ for Method in ClassInfo do
+ AddMethodInfo(ClassElement, Method);
+
+ AddClassStats(ClassElement, ClassInfo);
+ end;
+end;
+
+procedure TJacocoCoverageReport.AddClassStats(const ARootElement: TJclSimpleXMLElem; const AClass: TClassInfo);
+begin
+ AddCoverageElement(ARootElement, 'LINE', AClass.CoveredLineCount, AClass.LineCount - AClass.CoveredLineCount);
+
+ AddCoverageElement(ARootElement, 'METHOD', AClass.CoveredProcedureCount,
+ AClass.ProcedureCount - AClass.CoveredProcedureCount);
+
+ // AddCoverageElement(ARootElement,
+ // 'CLASS',
+ // AClass.,
+ // 100 - AClass.PercentCovered);
+end;
+
+procedure TJacocoCoverageReport.AddMethodInfo(AClassElement: TJclSimpleXMLElem; const AMethod: TProcedureInfo);
+var
+ MethodElement: TJclSimpleXMLElem;
+begin
+ MethodElement := AClassElement.Items.Add('method');
+ MethodElement.Properties.Add('name', AMethod.Name);
+ MethodElement.Properties.Add('desc', '()'); { TODO: Not sure we can pull this out }
+ AddMethodStats(MethodElement, AMethod);
+end;
+
+procedure TJacocoCoverageReport.AddMethodStats(const ARootElement: TJclSimpleXMLElem; const AMethod: TProcedureInfo);
+// var
+// IsCovered: Integer;
+begin
+ // IsCovered := IfThen(AMethod.PercentCovered > 0, 1, 0);
+
+ { TODO: Not sure about these either! }
+
+ // INSTRUCTION
+ { TODO: Is this the same as LINE? }
+ // AddCoverageElement(ARootElement,
+ // 'counter',
+ // 'INSTRUCTION',
+ // AMethod.CoveredLineCount,
+ // AMethod.LineCount - AMethod.CoveredLineCount);
+
+ // LINE
+ AddCoverageElement(ARootElement, 'LINE', AMethod.CoveredLineCount, AMethod.LineCount - AMethod.CoveredLineCount);
+
+ // AddCoverageElement(ARootElement,
+ // 'METHOD',
+ // AMethod.PercentCovered,
+ // 100 - AMethod.PercentCovered);
+
+ // AddCoverageElement(ARootElement,
+ // 'counter',
+ // 'INSTRUCTION',
+ // AMethod.CoveredLineCount,
+ // AMethod.LineCount - AMethod.CoveredLineCount);
+
+ // AddCoverageElement(ARootElement,
+ // 'counter',
+ // 'COMPLEXITY',
+ // AMethod.CoveredLineCount,
+ // AMethod.LineCount - AMethod.CoveredLineCount);
+
+ (*
+ AddCoverageElement(
+ ARootElement, 'counter',
+ AMethod.CoveredLineCount, AMethod.LineCount
+ );
+
+ AddCoverageElement(
+ ARootElement, 'counter',
+ AMethod.CoveredLineCount, AMethod.LineCount
+ );
+
+ AddCoverageElement(
+ ARootElement, 'counter',
+ AMethod.CoveredLineCount, AMethod.LineCount
+ );
+ *)
+end;
+
+procedure TJacocoCoverageReport.AddCoverageElement(const RootElement: TJclSimpleXMLElem; const AType: string;
+ const TotalCoveredCount, TotalUncoveredCount: Integer);
+var
+ CoverageElement: TJclSimpleXMLElem;
+begin
+ CoverageElement := RootElement.Items.Add('counter');
+ CoverageElement.Properties.Add('type', AType);
+ CoverageElement.Properties.Add('covered', TotalCoveredCount);
+ CoverageElement.Properties.Add('missed', TotalUncoveredCount);
+
+end;
+
+procedure TJacocoCoverageReport.AddLineCodeStats(ARootElement: TJclSimpleXMLElem; const ACoverage: ICoverageStats;
+ const AModule: TModuleInfo);
+var
+ LineCount: Integer;
+ LineCoverage: TCoverageLine;
+ CoverageUnit: ICoverageStats;
+ CoverageLineElement: TJclSimpleXMLElem;
+begin
+ LineCount := 0;
+
+ CoverageUnit := ACoverage.CoverageReportByName[AModule.ModuleName].CoverageReportByName[AModule.ModuleFileName];
+
+ for LineCount := 0 to Pred(CoverageUnit.LineCount) do
+ begin
+ LineCoverage := CoverageUnit.CoverageLine[LineCount];
+
+ CoverageLineElement := ARootElement.Items.Add('line');
+ CoverageLineElement.Properties.Add('nr', LineCoverage.LineNumber);
+
+ CoverageLineElement.Properties.Add('mi', IfThen(LineCoverage.IsCovered, 0, 1));
+ CoverageLineElement.Properties.Add('ci', IfThen(LineCoverage.IsCovered, 1, 0));
+ CoverageLineElement.Properties.Add('mb', 0);
+ CoverageLineElement.Properties.Add('cb', 0);
+ end;
+end;
+
+function TJacocoCoverageReport.GetCoverageStringValue(const ACovered, ATotal: Integer): string;
+var
+ Percent: Integer;
+begin
+ if ATotal = 0 then
+ Percent := 0
+ else
+ Percent := Round(ACovered * 100 / ATotal);
+
+ Result := IntToStr(Percent) + '% (' + IntToStr(ACovered) + '/' + IntToStr(ATotal) + ')';
+end;
+
+{ TJacocoCoverageReportMerger }
+
+class function TJacocoCoverageReportMerger.MergeCoverageStatsForGenerics(const ACoverageStatsIn: ICoverageStats)
+ : ICoverageStats;
+var
+ i, j, Line: Integer;
+ LModuleStats, LUnitStats, LResultStats: ICoverageStats;
+ FResultModuleName, FResultUnitName: String;
+ LCoverageLine: TCoverageLine;
+begin
+ Result := TCoverageStats.Create(ACoverageStatsIn.Name, ACoverageStatsIn.Parent);
+
+ // Loop all modules
+ for i := 0 to ACoverageStatsIn.Count - 1 do
+ begin
+ LModuleStats := ACoverageStatsIn.CoverageReport[i];
+
+ // Loop all units
+ for j := 0 to LModuleStats.Count - 1 do
+ begin
+ LUnitStats := LModuleStats.CoverageReport[j];
+
+ FResultModuleName := LUnitStats.Name.Substring(0, LUnitStats.Name.LastIndexOf('.'));
+ FResultUnitName := LUnitStats.Name;
+
+ LResultStats := Result.CoverageReportByName[FResultModuleName].CoverageReportByName[FResultUnitName];
+
+ // Add all coverage lines
+ for Line := 0 to ACoverageStatsIn.CoverageReport[i].CoverageReport[j].GetCoverageLineCount - 1 do
+ begin
+ LCoverageLine := ACoverageStatsIn.CoverageReport[i].CoverageReport[j].CoverageLine[Line];
+ LResultStats.AddLineCoverage(LCoverageLine.LineNumber, LCoverageLine.LineCount);
+ end;
+ end;
+ end;
+
+ Result.Calculate;
+end;
+
+end.
diff --git a/Source/LogManager.pas b/Source/LogManager.pas
index 9ebd11b..90632e2 100644
--- a/Source/LogManager.pas
+++ b/Source/LogManager.pas
@@ -13,7 +13,7 @@
interface
uses
- Generics.Collections,
+ System.Generics.Collections,
I_LogManager,
I_Logger;
diff --git a/Source/XMLCoverageReport.pas b/Source/XMLCoverageReport.pas
index 08cffcc..d9f941e 100644
--- a/Source/XMLCoverageReport.pas
+++ b/Source/XMLCoverageReport.pas
@@ -74,7 +74,7 @@ implementation
System.SysUtils,
System.Math,
JclFileUtils,
- Generics.Collections, CoverageStats;
+ CoverageStats;
constructor TXMLCoverageReport.Create(
const ACoverageConfiguration: ICoverageConfiguration);
diff --git a/Test/ClassInfoUnitTest.pas b/Test/ClassInfoUnitTest.pas
index 7457189..5efa3d1 100644
--- a/Test/ClassInfoUnitTest.pas
+++ b/Test/ClassInfoUnitTest.pas
@@ -24,6 +24,8 @@ TClassInfoUnitTest = class(TTestCase)
published
procedure TestClassInfo;
+ procedure TestGetProcedureName;
+ procedure TestGetClassName;
end;
@@ -36,6 +38,84 @@ procedure TClassInfoUnitTest.TestClassInfo;
cinfo.ensureProcedure('TestProcedure');
end;
+procedure TClassInfoUnitTest.TestGetProcedureName;
+begin
+ CheckEquals(
+ 'Bar',
+ TModuleList.GetProcedureName('foo', 'foo.Bar'),
+ 'foo.Bar should have Bar as procedure name'
+ );
+ CheckEquals(
+ 'Baz',
+ TModuleList.GetProcedureName('foo', 'foo.Bar.Baz'),
+ 'foo.Bar.Baz should have Baz as procedure name'
+ );
+ CheckEquals(
+ 'Baz',
+ TModuleList.GetProcedureName('foo', 'foo.Bar.Baz$0'),
+ 'foo.Bar.Baz$0 should have Baz as procedure name'
+ );
+ CheckEquals(
+ '',
+ TModuleList.GetProcedureName('foo', 'foo.Bar.Baz$ActRec.$0$Body'),
+ 'foo.Bar.Baz$ActRec.$0$Body anonymous function should have no procedure name'
+ );
+ CheckEquals(
+ 'Boo',
+ TModuleList.GetProcedureName('foo', 'foo.Bar.Baz.Boo'),
+ 'foo.Bar.Baz.Boo should have Boo as procedure name'
+ );
+ CheckEquals(
+ 'Boo',
+ TModuleList.GetProcedureName('foo', 'foo.Bar.Baz.Boo$0'),
+ 'foo.Bar.Baz.Boo$0 should have Boo as procedure name'
+ );
+ CheckEquals(
+ '',
+ TModuleList.GetProcedureName('foo', 'foo.Bar.Baz.Boo$ActRec.$0$Body'),
+ 'foo.Bar.Baz.Boo$ActRec.$0$Body anonymous function should have no procedure name'
+ );
+end;
+
+procedure TClassInfoUnitTest.TestGetClassName;
+begin
+ CheckEquals(
+ 'Bar',
+ TModuleList.GetClassName('foo', 'foo.Bar'),
+ 'foo.Bar should have Bar as class name'
+ );
+ CheckEquals(
+ 'Bar',
+ TModuleList.GetClassName('foo', 'foo.Bar.Baz'),
+ 'foo.Bar.Baz should have Bar as class name'
+ );
+ CheckEquals(
+ 'Bar',
+ TModuleList.GetClassName('foo', 'foo.Bar.Baz$0'),
+ 'foo.Bar.Baz$0 should have Bar as class name'
+ );
+ CheckEquals(
+ 'Bar.Baz$ActRec',
+ TModuleList.GetClassName('foo', 'foo.Bar.Baz$ActRec.$0$Body'),
+ 'foo.Bar.Baz$ActRec.$0$Body anonymous function should have Bar as class name'
+ );
+ CheckEquals(
+ 'Bar.Baz',
+ TModuleList.GetClassName('foo', 'foo.Bar.Baz.Boo'),
+ 'foo.Bar.Baz.Boo should have Bar.Baz as class name'
+ );
+ CheckEquals(
+ 'Bar.Baz',
+ TModuleList.GetClassName('foo', 'foo.Bar.Baz.Boo$0$Body'),
+ 'foo.Bar.Baz.Boo$0$Body should have Bar.Baz as class name'
+ );
+ CheckEquals(
+ 'Bar.Baz',
+ TModuleList.GetClassName('foo', 'foo.Bar.Baz.$0$Body'),
+ 'foo.Bar.Baz.$0$Body anonymous function should have Bar as class name'
+ );
+end;
+
//==============================================================================
initialization
RegisterTest(TClassInfoUnitTest.Suite);
diff --git a/Test/CodeCoverageTests.dproj b/Test/CodeCoverageTests.dproj
index 8e3078b..183fe11 100644
--- a/Test/CodeCoverageTests.dproj
+++ b/Test/CodeCoverageTests.dproj
@@ -1,7 +1,7 @@
{FC98FAC7-E261-4363-B04E-2C0F432CCF9B}
- 19.2
+ 19.5
Release
DCC32
CodeCoverageTests.dpr
@@ -153,10 +153,6 @@
-
- Cfg_2
- Base
-
Base
@@ -164,6 +160,10 @@
Cfg_1
Base
+
+ Cfg_2
+ Base
+
@@ -221,13 +221,8 @@
True
False
-
-
-
- CodeCoverageTests.exe
- true
-
-
+
+
1
@@ -240,14 +235,14 @@
0
-
+
classes
- 1
+ 64
classes
- 1
+ 64
@@ -541,6 +536,11 @@
1
.framework
+
+ Contents\MacOS
+ 1
+ .framework
+
0
@@ -554,7 +554,7 @@
1
.dylib
-
+
1
.dylib
@@ -568,6 +568,11 @@
1
.dylib
+
+ Contents\MacOS
+ 1
+ .dylib
+
0
.dll;.bpl
@@ -582,7 +587,7 @@
1
.dylib
-
+
1
.dylib
@@ -596,6 +601,11 @@
1
.dylib
+
+ Contents\MacOS
+ 1
+ .dylib
+
0
.bpl
@@ -614,7 +624,7 @@
0
-
+
0
@@ -625,464 +635,417 @@
Contents\Resources\StartUp\
0
-
+
+ Contents\Resources\StartUp\
0
-
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
- 1
+
+ 0
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
1
-
-
+
+
+ ..\
1
-
+
+ ..\
1
-
+
+ ..\
1
-
-
+
+
+ Contents
1
-
+
+ Contents
1
-
+
+ Contents
1
-
-
+
+
+ Contents\Resources
1
-
+
+ Contents\Resources
1
-
+
+ Contents\Resources
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+
+ library\lib\armeabi-v7a
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ library\lib\arm64-v8a
1
-
-
1
1
-
+
1
-
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ Contents\MacOS
1
-
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ Contents\MacOS
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ Contents\MacOS
1
-
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
- 1
+
+ 0
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
+
+ library\lib\armeabi-v7a
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
- 1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
1
-
+
+
+ ..\
+ 1
+
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+ ..\
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ ..\
1
-
+
1
1
-
+
1
-
+
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
- 1
+ ..\$(PROJECTNAME).launchscreen
+ 64
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
- 1
+
+ ..\$(PROJECTNAME).launchscreen
+ 64
-
+
1
1
-
+
1
-
-
- 1
-
-
+
+
+ Assets
1
-
+
+ Assets
1
-
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+
+ Assets
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ Assets
1
-
+
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
- ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
- ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
- 1
-
+
- ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
- 1
-
-
-
-
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
- ..\
- 1
-
+
- ..\
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
-
- ..\$(PROJECTNAME).launchscreen
- 64
-
-
- ..\$(PROJECTNAME).launchscreen
- 64
-
-
-
-
- 1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
- 1
-
-
-
-
- ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
-
- ..\
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
- ..\
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
-
- Contents
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
- Contents
+
+ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset
1
-
-
- Contents\Resources
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- Contents\Resources
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
- library\lib\armeabi-v7a
- 1
-
-
- library\lib\arm64-v8a
- 1
-
-
- 1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- 1
-
-
- 1
-
-
- Contents\MacOS
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- Contents\MacOS
+
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- 0
-
-
-
-
- library\lib\armeabi-v7a
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
- Assets
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- Assets
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
- Assets
+
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
- Assets
+
+ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset
1
-
-
+
+
+
+
+
-
-
-
-
+
+
+
12
diff --git a/Test/CodeCoverageTests.res b/Test/CodeCoverageTests.res
index a143854..d070105 100644
Binary files a/Test/CodeCoverageTests.res and b/Test/CodeCoverageTests.res differ
diff --git a/Test/CoverageConfigurationTest.pas b/Test/CoverageConfigurationTest.pas
index e90454a..1a0a3f3 100644
--- a/Test/CoverageConfigurationTest.pas
+++ b/Test/CoverageConfigurationTest.pas
@@ -86,7 +86,10 @@ TCoverageConfigurationTest = class(TTestCase)
procedure TestFileExtensionFromUnitFileToggling;
procedure TestExcludeSourceMask;
+ procedure TestIncludeSourceMask;
+ procedure TestMixIncludeExcludeSourceMask ;
procedure TestDProj;
+ procedure TestDGroupProj;
end;
implementation
@@ -117,8 +120,9 @@ implementation
cMAP_FILE_PARAMETER : array [0 .. 0] of string = (I_CoverageConfiguration.cPARAMETER_MAP_FILE);
cEXECUTABLE_PARAMETER : array [0 .. 0] of string = (I_CoverageConfiguration.cPARAMETER_EXECUTABLE);
cCODE_PAGE : array [0 .. 1] of string = (I_CoverageConfiguration.cPARAMETER_CODE_PAGE, '1250');
- cSOME_EXTENSION = '.someExt';
- cEXCLUDE_FILES_PREFIX = 'exclude';
+ cSOME_EXTENSION : string = '.someExt';
+ cEXCLUDE_FILES_PREFIX : string = 'exclude';
+ cINCLUDE_FILES_PREFIX : string = 'include';
//==============================================================================
function TCoverageConfigurationTest.RandomFileName: string;
var
@@ -147,7 +151,7 @@ procedure TCoverageConfigurationTest.TestPreParsing;
CheckEquals('', LCoverageConfiguration.ApplicationParameters, 'Application Parameters set');
CheckEquals('', LCoverageConfiguration.ExeFileName, 'Executable file name should not be set');
CheckEquals('', LCoverageConfiguration.MapFileName, 'Map file name should not be set');
- CheckEquals('', LCoverageConfiguration.OutputDir, 'Report output directory should not be set');
+ CheckEquals(ExtractFilePath(ParamStr(0)), LCoverageConfiguration.OutputDir, 'Report output directory should not be set');
CheckEquals('', LCoverageConfiguration.SourceDir, 'Source directory should not be set');
CheckEquals('', LCoverageConfiguration.DebugLogFile, 'Debug logging file name should not be set');
CheckEquals(0, LCoverageConfiguration.SourcePaths.Count, 'Source paths should not have directories listed');
@@ -176,7 +180,7 @@ procedure TCoverageConfigurationTest.TestNoParameters;
CheckEquals('', LCoverageConfiguration.ApplicationParameters, 'Application Parameters set');
CheckEquals('', LCoverageConfiguration.ExeFileName, 'Executable file name should not be set');
CheckEquals('', LCoverageConfiguration.MapFileName, 'Map file name should not be set');
- CheckEquals('', LCoverageConfiguration.OutputDir, 'Report output directory should not be set');
+ CheckEquals(ExtractFilePath(ParamStr(0)), LCoverageConfiguration.OutputDir, 'Report output directory should not be set');
CheckEquals('', LCoverageConfiguration.SourceDir, 'Source directory should not be set');
CheckEquals('', LCoverageConfiguration.DebugLogFile, 'Debug logging file name should not be set');
CheckEquals(0, LCoverageConfiguration.SourcePaths.Count, 'Source paths should not have directories listed');
@@ -208,7 +212,7 @@ procedure TCoverageConfigurationTest.TestInvalidParameter;
CheckEquals('', LCoverageConfiguration.ApplicationParameters, 'Application Parameters set');
CheckEquals('', LCoverageConfiguration.ExeFileName, 'Executable file name should not be set');
CheckEquals('', LCoverageConfiguration.MapFileName, 'Map file name should not be set');
- CheckEquals('', LCoverageConfiguration.OutputDir, 'Report output directory should not be set');
+ CheckEquals(ExtractFilePath(ParamStr(0)), LCoverageConfiguration.OutputDir, 'Report output directory should not be set');
CheckEquals('', LCoverageConfiguration.SourceDir, 'Source directory should not be set');
CheckEquals('', LCoverageConfiguration.DebugLogFile, 'Debug logging file name should not be set');
CheckEquals(0, LCoverageConfiguration.SourcePaths.Count, 0, 'Source paths should not have directories listed');
@@ -1470,6 +1474,208 @@ procedure TCoverageConfigurationTest.TestExcludeSourceMask;
end;
end;
+procedure TCoverageConfigurationTest.TestIncludeSourceMask;
+var
+ LNumOfFiles : Integer;
+ LTotalUnitList : TStrings;
+ LUnitName : TFileName;
+ LCmdParams : array of string;
+ LCoverageConfiguration : ICoverageConfiguration;
+ I : Integer;
+begin
+ LNumOfFiles := Random(20) + 5;
+ SetLength(LCmdParams, LNumOfFiles + 3);
+ LCmdParams[0] := '-ism';
+ LCmdParams[1] := cINCLUDE_FILES_PREFIX + '*';
+ LCmdParams[2] := '-u';
+
+ LTotalUnitList := TStringList.Create;
+ try
+ for I := 1 to LNumOfFiles do
+ begin
+ LUnitName := IfThen(I mod 2 = 0, cINCLUDE_FILES_PREFIX, '') + RandomFileName();
+ LTotalUnitList.Add(LUnitName);
+ LCmdParams[I + 2] := LUnitName;
+ end;
+
+ LCoverageConfiguration := TCoverageConfiguration.Create(TMockCommandLineProvider.Create(LCmdParams));
+ LCoverageConfiguration.ParseCommandLine;
+ for I := 0 to Pred(LTotalUnitList.Count) do
+ if LeftStr(LTotalUnitList[I], Length(cINCLUDE_FILES_PREFIX)) = cINCLUDE_FILES_PREFIX then
+ CheckNotEquals(-1, LCoverageConfiguration.Units.IndexOf(LTotalUnitList[I]), 'Missing included unit')
+ else
+ CheckEquals(-1, LCoverageConfiguration.Units.IndexOf(LTotalUnitList[I]), 'Unit should have been excluded');
+ finally
+ LTotalUnitList.Free;
+ end;
+end;
+
+procedure TCoverageConfigurationTest.TestMixIncludeExcludeSourceMask;
+var
+ LNumOfFiles : Integer;
+ LTotalUnitList : TStrings;
+ LUnitName : TFileName;
+ LCmdParams : array of string;
+ LCoverageConfiguration : ICoverageConfiguration;
+ I : Integer;
+begin
+ const cINCLUDE_EXCLUDE_FILES_PREFIX = cINCLUDE_FILES_PREFIX + cEXCLUDE_FILES_PREFIX;
+
+ LNumOfFiles := Random(20) + 10;
+ SetLength(LCmdParams, LNumOfFiles + 5);
+ LCmdParams[0] := '-esm';
+ LCmdParams[1] := cINCLUDE_EXCLUDE_FILES_PREFIX + '*';
+ LCmdParams[2] := '-ism';
+ LCmdParams[3] := cINCLUDE_FILES_PREFIX + '*';
+ LCmdParams[4] := '-u';
+
+ LTotalUnitList := TStringList.Create;
+ try
+ for I := 1 to LNumOfFiles do
+ begin
+ case I mod 3 of
+ // one on three is included because explicitely in included pattern
+ 0 : LUnitName := cINCLUDE_FILES_PREFIX + 'a' + RandomFileName(); //include 'a' to prevent error if random starts with "exclude"
+ // one on three is in included pattern but also in excluded : it is excluded
+ 1 : LUnitName := cINCLUDE_FILES_PREFIX + cEXCLUDE_FILES_PREFIX + RandomFileName();
+ // one on three is not in included pattern : it is excluded
+ 2 : LUnitName := RandomFileName();
+ end;
+ LTotalUnitList.Add(LUnitName);
+ LCmdParams[I + 4] := LUnitName;
+ end;
+
+ LCoverageConfiguration := TCoverageConfiguration.Create(TMockCommandLineProvider.Create(LCmdParams));
+ LCoverageConfiguration.ParseCommandLine;
+ for I := 0 to Pred(LTotalUnitList.Count) do
+ if ((LeftStr(LTotalUnitList[I], Length(cINCLUDE_FILES_PREFIX)) = cINCLUDE_FILES_PREFIX)
+ and not (LeftStr(LTotalUnitList[I], Length(cINCLUDE_EXCLUDE_FILES_PREFIX)) = cINCLUDE_EXCLUDE_FILES_PREFIX)) then
+ CheckNotEquals(-1, LCoverageConfiguration.Units.IndexOf(LTotalUnitList[I]), 'Missing included unit')
+ else
+ CheckEquals(-1, LCoverageConfiguration.Units.IndexOf(LTotalUnitList[I]), 'Unit should have been excluded');
+ finally
+ LTotalUnitList.Free;
+ end;
+end;
+
+procedure TCoverageConfigurationTest.TestDGroupProj;
+var
+ LDProjName : TFileName;
+ LDGroupProjName : TFileName;
+ LNumOfFiles : Integer;
+ LNunOfProjects : Integer;
+ LTotalProjectList : TStrings;
+ LTotalUnitList : TStrings;
+ LDproj : TStrings;
+ LDGroupProj : TStrings;
+ LUnitName : TFileName;
+ LExeName : TFileName;
+ LCmdParams : array of string;
+ LCoverageConfiguration : ICoverageConfiguration;
+ I,P : Integer;
+ ExpectedExeName : TFileName;
+ ExpectedSourcePath : TFileName;
+ PlatformName : string;
+begin
+ LDProjName := IncludeTrailingPathDelimiter(GetCurrentDir()) + RandomFileName() + '.dproj';
+ LDGroupProj := TStringList.Create;
+ LTotalUnitList := TStringList.Create;
+ LTotalProjectList := TStringList.Create;
+
+ try
+ LNunOfProjects := Random(5) + 2;
+ for P := 0 to LNunOfProjects - 1 do
+ begin
+ LExeName := RandomFileName();
+ LTotalProjectList.Add(LExeName);
+ LDProjName := IncludeTrailingPathDelimiter(GetCurrentDir()) + LExeName + '.dproj';
+
+ LDproj := TStringList.Create;
+ try
+ LDproj.Add('');
+ LDProj.Add('');
+ LDProj.Add('Debug');
+ LDProj.Add('');
+ LDProj.Add('');
+ LDProj.Add('..\build\$(PLATFORM)');
+ LDProj.Add('..\src\;$(DCC_UnitSearchPath)');
+ LDProj.Add('65001');
+ LDProj.Add('');
+
+
+ LNumOfFiles := Random(20) + 5;
+ LDProj.Add('');
+ for I := 0 to LNumOfFiles - 1 do
+ begin
+ LUnitName := RandomFileName();
+ LTotalUnitList.Add(LUnitName);
+ LDProj.Add('');
+ end;
+ LDProj.Add('');
+ LDProj.Add('');
+ LDProj.SaveToFile(LDProjName);
+ finally
+ LDproj.Free;
+ end;
+ end;
+
+ LDGroupProjName := IncludeTrailingPathDelimiter(GetCurrentDir()) + RandomFileName() + '.groupproj';
+ LDGroupProj.Add('');
+ LDGroupProj.Add('');
+ LDGroupProj.Add('{476211CD-F879-4C5A-BAA5-DD7D35748B26}');
+ LDGroupProj.Add('');
+ LDGroupProj.Add('');
+ for I := 0 to LTotalProjectList.Count - 1 do
+ begin
+ LDProjName := IncludeTrailingPathDelimiter(GetCurrentDir()) + LTotalProjectList[I] + '.dproj';
+ LDGroupProj.Add('');
+ LDGroupProj.Add('');
+ end;
+ LDGroupProj.Add('');
+ LDGroupProj.Add('');
+ LDGroupProj.SaveToFile(LDGroupProjName);
+
+ SetLength(LCmdParams, 2);
+ LCmdParams[0] := '-dgroupproj';
+ LCmdParams[1] := LDGroupProjName;
+
+ LCoverageConfiguration := TCoverageConfiguration.Create(TMockCommandLineProvider.Create(LCmdParams));
+ LCoverageConfiguration.ParseCommandLine;
+
+ CheckEquals(LTotalUnitList.Count, LCoverageConfiguration.Units.Count, 'Incorrect number of units listed');
+ CheckEquals(LTotalProjectList.Count, LCoverageConfiguration.ExeFileNames.Count, 'Incorrect number of executables listed');
+ {$IFDEF WIN64}
+ PlatformName := 'Win64';
+ {$ELSE}
+ PlatformName := 'Win32';
+ {$ENDIF}
+ for I := 0 to Pred(LTotalProjectList.Count) do
+ begin
+ LDProjName := IncludeTrailingPathDelimiter(GetCurrentDir()) + LTotalProjectList[I] + '.dproj';
+ ExpectedExeName := TPath.GetDirectoryName(GetCurrentDir()) + '\build\' + PlatformName + '\' + LTotalProjectList[I];
+ ExpectedSourcePath := TPath.GetFullPath(TPath.Combine(TPath.GetDirectoryName(LDProjName), '..\src\'));
+
+ CheckNotEquals(-1, LCoverageConfiguration.ExeFileNames.IndexOf(ChangeFileExt(ExpectedExeName,'.exe')), 'Missing executable listed');
+ CheckNotEquals(-1, LCoverageConfiguration.MapFileNames.IndexOf(ChangeFileExt(ExpectedExeName,'.map')), 'Missing map file listed');
+ CheckTrue(LCoverageConfiguration.SourcePaths.IndexOf(ExpectedSourcePath) <> -1, 'Incorrect SourcePaths');
+
+ TFile.Delete(LDProjName);
+ end;
+
+ for I := 0 to Pred(LTotalUnitList.Count) do
+ CheckNotEquals(-1, LCoverageConfiguration.Units.IndexOf(LTotalUnitList[I]), 'Missing unit name');
+
+ finally
+ TFile.Delete(LDGroupProjName);
+ LDGroupProj.Free;
+ LTotalUnitList.Free;
+ LTotalProjectList.Free;
+ end;
+
+
+
+end;
+
procedure TCoverageConfigurationTest.TestDProj;
var
LDProjName : TFileName;