├── .gitattributes ├── Bin └── readme.txt ├── Lib └── readme.txt ├── Source ├── map2pdb.res ├── debug.info.pdb.pas ├── debug.info.reader.pas ├── debug.info.writer.pas ├── debug.info.reader.test.pas ├── debug.info.utilities.pas ├── debug.info.log.pas ├── map2pdb.mes ├── amVersionInfo.pas ├── debug.map.reader.pas ├── map2pdb.dpr ├── debug.info.writer.yaml.pas ├── debug.info.pdb.bind.pas ├── debug.info.reader.jdbg.pas ├── debug.info.pas └── debug.info.msf.pas ├── Info └── vtune_delphi.png ├── Tools └── readme.txt ├── Test ├── Source │ ├── map2pdb_test.res │ ├── map2pdb_test.dpr │ ├── TestFileWriter.pas │ ├── TestFileReader.pas │ └── map2pdb_test.dproj ├── Data │ └── readme.txt └── DUnit │ └── FileTestFramework.pas ├── .gitignore ├── map2pdb_group.groupproj └── readme.md /.gitattributes: -------------------------------------------------------------------------------- 1 | *text=auto 2 | *.pas text 3 | *.dpr text 4 | *.dproj text 5 | -------------------------------------------------------------------------------- /Bin/readme.txt: -------------------------------------------------------------------------------- 1 | Destination folder for binaries. 2 | Folder should be empty except this file. -------------------------------------------------------------------------------- /Lib/readme.txt: -------------------------------------------------------------------------------- 1 | Destination folder for library files. 2 | Folder should be empty except this file. -------------------------------------------------------------------------------- /Source/map2pdb.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andersmelander/map2pdb/HEAD/Source/map2pdb.res -------------------------------------------------------------------------------- /Info/vtune_delphi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andersmelander/map2pdb/HEAD/Info/vtune_delphi.png -------------------------------------------------------------------------------- /Source/debug.info.pdb.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andersmelander/map2pdb/HEAD/Source/debug.info.pdb.pas -------------------------------------------------------------------------------- /Tools/readme.txt: -------------------------------------------------------------------------------- 1 | llvm-pdbutil can be downloaded here: 2 | https://github.com/shaharv/llvm-pdbutil-builds/releases -------------------------------------------------------------------------------- /Test/Source/map2pdb_test.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andersmelander/map2pdb/HEAD/Test/Source/map2pdb_test.res -------------------------------------------------------------------------------- /Test/Data/readme.txt: -------------------------------------------------------------------------------- 1 | Place test data files in this folder (or in sub-folders). 2 | The reader unit-test will process any .map, .jdbg, or .test files found here. -------------------------------------------------------------------------------- /Test/Source/map2pdb_test.dpr: -------------------------------------------------------------------------------- 1 | program map2pdb_test; 2 | { 3 | 4 | Delphi DUnit Test Project 5 | ------------------------- 6 | This project contains the DUnit test framework and the GUI/Console test runners. 7 | Add "CONSOLE_TESTRUNNER" to the conditional defines entry in the project options 8 | to use the console test runner. Otherwise the GUI test runner will be used by 9 | default. 10 | 11 | } 12 | 13 | {$IFDEF CONSOLE_TESTRUNNER} 14 | {$APPTYPE CONSOLE} 15 | {$ENDIF} 16 | 17 | uses 18 | TestFramework, 19 | GUITestRunner, 20 | TextTestRunner, 21 | DUnitTestRunner, 22 | SysUtils, 23 | Forms, 24 | debug.info.log, 25 | TestFileReader in 'TestFileReader.pas', 26 | FileTestFramework in '..\DUnit\FileTestFramework.pas', 27 | TestFileWriter in 'TestFileWriter.pas'; 28 | 29 | {$R *.RES} 30 | 31 | type 32 | TDebugInfoUnitTestLogger = class(TInterfacedObject, IDebugInfoLogger) 33 | protected 34 | // IDebugInfoLogger 35 | procedure Log(Category: TDebugInfoLogCategory; LogModule: TDebugInfoLogModule; const Msg: string); 36 | end; 37 | 38 | procedure TDebugInfoUnitTestLogger.Log(Category: TDebugInfoLogCategory; LogModule: TDebugInfoLogModule; const Msg: string); 39 | begin 40 | if (Category = lcFatal) then 41 | raise Exception.Create(Msg); 42 | end; 43 | 44 | begin 45 | RegisterDebugInfoLogger(TDebugInfoUnitTestLogger.Create); 46 | 47 | Application.Initialize; 48 | if IsConsole then 49 | with TextTestRunner.RunRegisteredTests do 50 | Free 51 | else 52 | GUITestRunner.RunRegisteredTests; 53 | end. 54 | 55 | 56 | -------------------------------------------------------------------------------- /Test/Source/TestFileWriter.pas: -------------------------------------------------------------------------------- 1 | unit TestFileWriter; 2 | 3 | interface 4 | 5 | uses 6 | Classes, Types, 7 | FileTestFramework, 8 | debug.info, 9 | TestFileReader; 10 | 11 | type 12 | TTestFileWriter = class(TCustomMapTest) 13 | protected 14 | procedure ProcessDebugInfo(DebugInfo: TDebugInfo); override; 15 | published 16 | procedure TestWritePDB; 17 | end; 18 | 19 | implementation 20 | 21 | uses 22 | Windows, 23 | SysUtils, 24 | IOUtils, 25 | TestFramework, 26 | debug.info.writer.pdb; 27 | 28 | 29 | { TTestFileWriter } 30 | 31 | procedure TTestFileWriter.ProcessDebugInfo(DebugInfo: TDebugInfo); 32 | begin 33 | var BlockSize: Integer := 0; 34 | 35 | var TargetFilename := TPath.ChangeExtension(TestFileName, '.pdb'); 36 | (* 37 | var TargetPath := TPath.GetDirectoryName(TestFileName); 38 | TargetPath := TPath.Combine(TargetPath, '..\..\Output'); 39 | 40 | var TargetFilename := TPath.ChangeExtension(TPath.GetFileName(TestFileName), '.pdb'); 41 | TargetFilename := TPath.Combine(TargetPath, TestFileName); 42 | *) 43 | try 44 | 45 | var Writer := TDebugInfoPdbWriter.Create(BlockSize); 46 | try 47 | 48 | Writer.SaveToFile(TargetFilename, DebugInfo); 49 | 50 | finally 51 | Writer.Free; 52 | end; 53 | 54 | finally 55 | TFile.Delete(TargetFilename); 56 | end; 57 | 58 | Check(True); 59 | end; 60 | 61 | procedure TTestFileWriter.TestWritePDB; 62 | begin 63 | DoLoadFromFile; 64 | end; 65 | 66 | initialization 67 | var TestSuite := TFolderTestSuiteSkipErrors.Create('Write PDB files', TTestFileWriter, '..\..\..\Data', '*.*', True); 68 | RegisterTest(TestSuite); 69 | end. 70 | 71 | 72 | -------------------------------------------------------------------------------- /Source/debug.info.reader.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.reader; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | 15 | uses 16 | System.Classes, 17 | debug.info, 18 | debug.info.log; 19 | 20 | type 21 | // Abstract reader base class 22 | TDebugInfoReader = class abstract 23 | private 24 | FModuleLogger: IDebugInfoModuleLogger; 25 | protected 26 | property Logger: IDebugInfoModuleLogger read FModuleLogger; 27 | public 28 | constructor Create; virtual; 29 | 30 | procedure LoadFromStream(Stream: TStream; DebugInfo: TDebugInfo); virtual; abstract; 31 | procedure LoadFromFile(const Filename: string; DebugInfo: TDebugInfo); virtual; 32 | end; 33 | 34 | TDebugInfoReaderClass = class of TDebugInfoReader; 35 | 36 | 37 | implementation 38 | 39 | uses 40 | System.SysUtils; 41 | 42 | 43 | constructor TDebugInfoReader.Create; 44 | begin 45 | inherited Create; 46 | FModuleLogger := RegisterDebugInfoModuleLogger('reader'); 47 | end; 48 | 49 | procedure TDebugInfoReader.LoadFromFile(const Filename: string; DebugInfo: TDebugInfo); 50 | begin 51 | try 52 | 53 | var Stream := TBufferedFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite); 54 | try 55 | 56 | LoadFromStream(Stream, DebugInfo); 57 | 58 | finally 59 | Stream.Free; 60 | end; 61 | 62 | except 63 | on E: EFOpenError do 64 | Logger.Error(E.Message); 65 | end; 66 | end; 67 | 68 | end. 69 | 70 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat -------------------------------------------------------------------------------- /map2pdb_group.groupproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {95A1DADA-3CBA-483D-A3F3-B75EC77F8223} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Default.Personality.12 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /Source/debug.info.writer.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.writer; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | 15 | // Define SAVE_MEMSTREAM to use a TMemoryStream when constructing the PDB. 16 | // Otherwise a TBufferedFileStream is used. 17 | {$define SAVE_MEMSTREAM} 18 | 19 | uses 20 | System.Classes, 21 | debug.info, 22 | debug.info.log; 23 | 24 | type 25 | // Abstract writer base class 26 | TDebugInfoWriter = class abstract 27 | private 28 | FModuleLogger: IDebugInfoModuleLogger; 29 | protected 30 | property Logger: IDebugInfoModuleLogger read FModuleLogger; 31 | public 32 | constructor Create(ABlockSize: Cardinal = 0); virtual; 33 | 34 | procedure SaveToStream(Stream: TStream; DebugInfo: TDebugInfo); virtual; abstract; 35 | procedure SaveToFile(const Filename: string; DebugInfo: TDebugInfo); 36 | end; 37 | 38 | TDebugInfoWriterClass = class of TDebugInfoWriter; 39 | 40 | 41 | implementation 42 | 43 | uses 44 | System.SysUtils; 45 | 46 | type 47 | // TSafeMemoryStream: A memory stream that clears the allocated memory 48 | // in order to avoid writing junk to the pdb file. 49 | TSafeMemoryStream = class(TMemoryStream) 50 | protected 51 | function Realloc(var NewCapacity: NativeInt): Pointer; override; 52 | end; 53 | 54 | function TSafeMemoryStream.Realloc(var NewCapacity: NativeInt): Pointer; 55 | begin 56 | Result := inherited Realloc(NewCapacity); 57 | 58 | if (NewCapacity > Capacity) then 59 | FillChar((PByte(Result) + Capacity)^, NewCapacity - Capacity, 0); 60 | end; 61 | 62 | constructor TDebugInfoWriter.Create(ABlockSize: Cardinal); 63 | begin 64 | inherited Create; 65 | FModuleLogger := RegisterDebugInfoModuleLogger('writer'); 66 | end; 67 | 68 | procedure TDebugInfoWriter.SaveToFile(const Filename: string; DebugInfo: TDebugInfo); 69 | begin 70 | try 71 | 72 | {$ifdef SAVE_MEMSTREAM} 73 | var Stream := TSafeMemoryStream.Create; 74 | {$else SAVE_MEMSTREAM} 75 | var Stream := TBufferedFileStream.Create(Filename, fmCreate, $8000); 76 | {$endif SAVE_MEMSTREAM} 77 | try 78 | 79 | SaveToStream(Stream, DebugInfo); 80 | 81 | {$ifdef SAVE_MEMSTREAM} 82 | Stream.SaveToFile(Filename); 83 | {$endif SAVE_MEMSTREAM} 84 | 85 | finally 86 | Stream.Free; 87 | end; 88 | 89 | except 90 | on E: EFCreateError do 91 | Logger.Error(E.Message); 92 | end; 93 | end; 94 | 95 | end. 96 | 97 | -------------------------------------------------------------------------------- /Source/debug.info.reader.test.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.reader.test; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | 15 | uses 16 | System.Classes, 17 | debug.info, 18 | debug.info.reader; 19 | 20 | type 21 | TDebugInfoSyntheticReader = class(TDebugInfoReader) 22 | private 23 | procedure SynthesizeDebugInfo(DebugInfo: TDebugInfo); 24 | protected 25 | public 26 | procedure LoadFromStream(Stream: TStream; DebugInfo: TDebugInfo); override; 27 | procedure LoadFromFile(const Filename: string; DebugInfo: TDebugInfo); override; 28 | end; 29 | 30 | 31 | 32 | implementation 33 | 34 | procedure TDebugInfoSyntheticReader.LoadFromFile(const Filename: string; DebugInfo: TDebugInfo); 35 | begin 36 | SynthesizeDebugInfo(DebugInfo); 37 | end; 38 | 39 | procedure TDebugInfoSyntheticReader.LoadFromStream(Stream: TStream; DebugInfo: TDebugInfo); 40 | begin 41 | SynthesizeDebugInfo(DebugInfo); 42 | end; 43 | 44 | procedure TDebugInfoSyntheticReader.SynthesizeDebugInfo(DebugInfo: TDebugInfo); 45 | begin 46 | // var Segment := DebugInfo.SegmentClasses.Add(2, sctDATA, 'FOOBAR'); 47 | // Segment.Offset := $00171717; 48 | // Segment.Size := $00272727; 49 | 50 | var Segment := DebugInfo.Segments.Add(1, '.text', sctCODE); 51 | Segment.Offset := $00474747; 52 | Segment.Size := 123456; 53 | 54 | 55 | var Module := DebugInfo.Modules.Add('modmodmodmodmod', Segment, $121212, $202020); 56 | Module.ObjectName := 'objobjobjob.obj'; 57 | 58 | var SourceFile := Module.SourceFiles.Add('foofoofoofo.pas'); 59 | Module.SourceLines.Add(SourceFile, $0077, $0000); 60 | Module.SourceLines.Add(SourceFile, $0099, $0011); 61 | 62 | SourceFile := Module.SourceFiles.Add('yyyyyyyyyyy.pas'); 63 | Module.SourceLines.Add(SourceFile, $0066, $0022); 64 | 65 | SourceFile := Module.SourceFiles.Add('barbarbarba.pas'); 66 | Module.SourceLines.Add(SourceFile, $0044, $0033); 67 | Module.SourceLines.Add(SourceFile, $0055, $0044); 68 | 69 | 70 | 71 | Module := DebugInfo.Modules.Add('zzzzzzzzzzzzzzz', Segment, $101010, $202020); 72 | 73 | SourceFile := Module.SourceFiles.Add('yyyyyyyyyyy.pas'); 74 | Module.SourceLines.Add(SourceFile, $1111, $0101); 75 | 76 | 77 | Module.Symbols.Add('aaaaaaaa', $0f0f0f); 78 | // Module.Symbols.Add('bbbbbbbb', $200); 79 | 80 | // Module.ObjectName := 'objobjobjob.obj'; 81 | // SourceFile := Module.SourceFiles.Add('yyyyyyyyyyy.pas'); 82 | 83 | end; 84 | 85 | 86 | end. 87 | 88 | -------------------------------------------------------------------------------- /Test/DUnit/FileTestFramework.pas: -------------------------------------------------------------------------------- 1 | unit FileTestFramework; 2 | 3 | interface 4 | 5 | uses 6 | TestFramework; 7 | 8 | // Adapted from "A DUnit Folder Iterator Extension" 9 | // https://www.uweraabe.de/Blog/2012/03/17/a-dunit-folder-iterator-extension/ 10 | type 11 | TFileTestCaseClass = class of TFileTestCase; 12 | 13 | TFileTestCase = class(TTestCase) 14 | private 15 | FTestFileName: string; 16 | public 17 | constructor Create(const AMethodName, ATestFileName: string); reintroduce; overload; virtual; 18 | class function HandlesFiles(const AFilename: string): boolean; virtual; 19 | function GetName: string; override; 20 | property TestFileName: string read FTestFileName; 21 | end; 22 | 23 | TFolderTestSuite = class(TTestSuite) 24 | private 25 | FBaseFolder: string; 26 | FFileMask: string; 27 | FRecursive: Boolean; 28 | protected 29 | procedure AddMethodTests(TestClass: TTestCaseClass; const NameOfMethod: string); overload; virtual; 30 | procedure ProcessFile(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, FileName: string); virtual; 31 | procedure ProcessFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, Path, FileMask: string; 32 | Recursive: Boolean); overload; virtual; 33 | procedure ProcessBaseFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod: string); virtual; 34 | public 35 | constructor Create(const AName: string; TestClass: TFileTestCaseClass; const ABaseFolder, AFileMask: string; ARecursive: Boolean); overload; 36 | procedure AddTests(testClass: TTestCaseClass); override; 37 | property BaseFolder: string read FBaseFolder; 38 | property FileMask: string read FFileMask; 39 | property Recursive: Boolean read FRecursive; 40 | end; 41 | 42 | implementation 43 | 44 | uses 45 | IOUtils; 46 | 47 | constructor TFolderTestSuite.Create(const AName: string; TestClass: TFileTestCaseClass; const ABaseFolder, AFileMask: string; ARecursive: Boolean); 48 | begin 49 | inherited Create(AName); 50 | 51 | FBaseFolder := ABaseFolder; 52 | FFileMask := AFileMask; 53 | FRecursive := ARecursive; 54 | 55 | AddTests(TestClass); 56 | end; 57 | 58 | procedure TFolderTestSuite.AddMethodTests(TestClass: TTestCaseClass; const NameOfMethod: string); 59 | begin 60 | if TestClass.InheritsFrom(TFileTestCase) then 61 | begin 62 | var suite := TTestSuite.Create(NameOfMethod); 63 | AddSuite(suite); 64 | ProcessBaseFolder(suite, TFileTestCaseClass(TestClass), NameOfMethod); 65 | end else 66 | begin 67 | AddTest(TestClass.Create(NameOfMethod)); 68 | end; 69 | end; 70 | 71 | procedure TFolderTestSuite.AddTests(testClass: TTestCaseClass); 72 | var 73 | MethodEnumerator: TMethodEnumerator; 74 | begin 75 | { call on the method enumerator to get the names of the test 76 | cases in the testClass } 77 | MethodEnumerator := nil; 78 | try 79 | MethodEnumerator := TMethodEnumerator.Create(testClass); 80 | { make sure we add each test case to the list of tests } 81 | for var MethodIter := 0 to MethodEnumerator.Methodcount-1 do 82 | begin 83 | var NameOfMethod := MethodEnumerator.nameOfMethod[MethodIter]; 84 | AddMethodTests(testClass, NameOfMethod); 85 | end; 86 | finally 87 | MethodEnumerator.free; 88 | end; 89 | end; 90 | 91 | procedure TFolderTestSuite.ProcessBaseFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod: string); 92 | begin 93 | ProcessFolder(Suite, TestClass, NameOfMethod, BaseFolder, FileMask, Recursive); 94 | end; 95 | 96 | procedure TFolderTestSuite.ProcessFile(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, FileName: string); 97 | begin 98 | if (TestClass.HandlesFiles(FileName)) then 99 | Suite.AddTest(TestClass.Create(NameOfMethod, FileName)); 100 | end; 101 | 102 | procedure TFolderTestSuite.ProcessFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, Path, FileMask: string; Recursive: Boolean); 103 | begin 104 | for var Filename in TDirectory.GetFiles(Path, FileMask) do 105 | ProcessFile(suite, TestClass, NameOfMethod, Filename); 106 | 107 | if Recursive then 108 | begin 109 | for var Folder in TDirectory.GetDirectories(Path) do 110 | begin 111 | var TestSuite := TTestSuite.Create(TPath.GetFileName(Folder)); 112 | Suite.AddSuite(TestSuite); 113 | ProcessFolder(TestSuite, TestClass, NameOfMethod, Folder, FileMask, true); 114 | end; 115 | end; 116 | end; 117 | 118 | constructor TFileTestCase.Create(const AMethodName, ATestFileName: string); 119 | begin 120 | inherited Create(AMethodName); 121 | FTestFileName := ATestFileName; 122 | end; 123 | 124 | function TFileTestCase.GetName: string; 125 | begin 126 | Result := TPath.GetFileNameWithoutExtension(TestFileName); 127 | end; 128 | 129 | class function TFileTestCase.HandlesFiles(const AFilename: string): boolean; 130 | begin 131 | Result := True; 132 | end; 133 | 134 | end. 135 | 136 | -------------------------------------------------------------------------------- /Test/Source/TestFileReader.pas: -------------------------------------------------------------------------------- 1 | unit TestFileReader; 2 | 3 | interface 4 | 5 | uses 6 | Classes, Types, 7 | TestFramework, 8 | FileTestFramework, 9 | debug.info, 10 | debug.info.reader; 11 | 12 | type 13 | TCustomMapTest = class(TFileTestCase) 14 | strict private 15 | FDebugInfo: TDebugInfo; 16 | private 17 | protected 18 | procedure DoLoadFromFile; 19 | procedure ProcessDebugInfo(DebugInfo: TDebugInfo); virtual; 20 | public 21 | procedure SetUp; override; 22 | procedure TearDown; override; 23 | end; 24 | 25 | TTestFileReader = class(TCustomMapTest) 26 | published 27 | procedure TestLoadFromFile; 28 | end; 29 | 30 | TTestFileReaderErrors = class(TTestFileReader) 31 | protected 32 | procedure RunTest(TestResult: TTestResult); override; 33 | end; 34 | 35 | type 36 | TFolderTestSuiteSkipErrors = class(TFolderTestSuite) 37 | protected 38 | procedure ProcessFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, Path, FileMask: string; Recursive: Boolean); override; 39 | end; 40 | 41 | type 42 | TFolderTestSuiteOnlyErrors = class(TFolderTestSuite) 43 | protected 44 | procedure ProcessFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, Path, FileMask: string; Recursive: Boolean); override; 45 | end; 46 | 47 | implementation 48 | 49 | uses 50 | Windows, 51 | SysUtils, 52 | IOUtils, 53 | debug.info.reader.map, 54 | debug.info.reader.test, 55 | debug.info.reader.jdbg; 56 | 57 | type 58 | TInputFormat = (ifMap, ifJdbg, ifTest); 59 | const 60 | sInputFileTypes: array[TInputFormat] of string = ('.map', '.jdbg', '.test'); 61 | ReaderClasses: array[TInputFormat] of TDebugInfoReaderClass = (TDebugInfoMapReader, TDebugInfoJdbgReader, TDebugInfoSyntheticReader); 62 | 63 | function TryStrToInputFormat(const AName: string; var InputFormat: TInputFormat): boolean; 64 | begin 65 | for var InFormat := Low(TInputFormat) to High(TInputFormat) do 66 | if (SameText(AName, sInputFileTypes[InFormat])) then 67 | begin 68 | InputFormat := InFormat; 69 | Exit(True); 70 | end; 71 | Result := False; 72 | end; 73 | 74 | procedure TCustomMapTest.SetUp; 75 | begin 76 | FDebugInfo := TDebugInfo.Create; 77 | end; 78 | 79 | procedure TCustomMapTest.TearDown; 80 | begin 81 | FDebugInfo.Free; 82 | FDebugInfo := nil; 83 | end; 84 | 85 | procedure TCustomMapTest.DoLoadFromFile; 86 | begin 87 | (* 88 | ** Determine source file format 89 | *) 90 | var InputFormat: TInputFormat; 91 | var FileType := TPath.GetExtension(TestFileName); 92 | if (not TryStrToInputFormat(FileType, InputFormat)) then 93 | begin 94 | Check(True); 95 | Status('Unknown file format'); 96 | exit; 97 | end; 98 | 99 | (* 100 | ** Read source file 101 | *) 102 | var ReaderClass: TDebugInfoReaderClass := ReaderClasses[InputFormat]; 103 | 104 | var Reader := ReaderClass.Create; 105 | try 106 | 107 | Reader.LoadFromFile(TestFileName, FDebugInfo); 108 | 109 | finally 110 | Reader.Free; 111 | end; 112 | 113 | ProcessDebugInfo(FDebugInfo); 114 | end; 115 | 116 | procedure TCustomMapTest.ProcessDebugInfo(DebugInfo: TDebugInfo); 117 | begin 118 | Check(DebugInfo.Segments.Count > 0, 'No segments'); 119 | Check(DebugInfo.Modules.Count > 0, 'No modules'); 120 | if (DebugInfo.SourceFiles.Count = 0) then 121 | Self.Status('No source files'); 122 | end; 123 | 124 | procedure TTestFileReader.TestLoadFromFile; 125 | begin 126 | DoLoadFromFile; 127 | end; 128 | 129 | 130 | { TFolderTestSuiteSkipErrors } 131 | 132 | procedure TFolderTestSuiteSkipErrors.ProcessFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, Path, 133 | FileMask: string; Recursive: Boolean); 134 | begin 135 | if SameText(TPath.GetFileName(Path), 'errors') then 136 | exit; 137 | 138 | inherited; 139 | end; 140 | 141 | { TFolderTestSuiteOnlyErrors } 142 | 143 | procedure TFolderTestSuiteOnlyErrors.ProcessFolder(Suite: ITestSuite; TestClass: TFileTestCaseClass; const NameOfMethod, Path, 144 | FileMask: string; Recursive: Boolean); 145 | begin 146 | if SameText(TPath.GetFileName(Path), 'errors') then 147 | begin 148 | inherited; 149 | exit; 150 | end; 151 | 152 | if Recursive then 153 | for var Folder in TDirectory.GetDirectories(Path) do 154 | ProcessFolder(Suite, TestClass, NameOfMethod, Folder, FileMask, true); 155 | end; 156 | 157 | { TTestFileReaderErrors } 158 | 159 | procedure TTestFileReaderErrors.RunTest(TestResult: TTestResult); 160 | begin 161 | try 162 | 163 | inherited; 164 | 165 | Fail('Passed without expected error: '+TPath.GetFileNameWithoutExtension(TestFileName)); 166 | 167 | except 168 | on E: Exception do 169 | begin 170 | var Msg := E.Message.ToLower; 171 | Msg := StringReplace(Msg, '/', '-', [rfReplaceAll]); 172 | Msg := StringReplace(Msg, '"', '', [rfReplaceAll]); 173 | if (Msg.Contains(TPath.GetFileNameWithoutExtension(TestFileName).ToLower)) then 174 | Check(True) 175 | else 176 | raise; 177 | end; 178 | end; 179 | end; 180 | 181 | initialization 182 | var TestSuite: TTestSuite := TFolderTestSuiteSkipErrors.Create('Load map files', TTestFileReader, '..\..\..\Data', '*.*', True); 183 | RegisterTest(TestSuite); 184 | TestSuite := TFolderTestSuiteOnlyErrors.Create('Reader errors', TTestFileReaderErrors, '..\..\..\Data', '*.*', True); 185 | RegisterTest(TestSuite); 186 | end. 187 | 188 | 189 | -------------------------------------------------------------------------------- /Source/debug.info.utilities.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.utilities; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | uses 14 | debug.info, 15 | debug.info.log; 16 | 17 | 18 | // ----------------------------------------------------------------------------- 19 | // 20 | // FilterModules 21 | // 22 | // ----------------------------------------------------------------------------- 23 | // Remove modules from debug info based on name and segment. 24 | // ----------------------------------------------------------------------------- 25 | procedure FilterModules(DebugInfo: TDebugInfo; const ModuleFilter: string; Include: boolean; Logger: IDebugInfoModuleLogger); 26 | 27 | 28 | // ----------------------------------------------------------------------------- 29 | // 30 | // PostImportValidation 31 | // 32 | // ----------------------------------------------------------------------------- 33 | // Perform variaous validation on debug info. 34 | // ----------------------------------------------------------------------------- 35 | procedure PostImportValidation(DebugInfo: TDebugInfo; Logger: IDebugInfoModuleLogger); 36 | 37 | 38 | // ----------------------------------------------------------------------------- 39 | // ----------------------------------------------------------------------------- 40 | // ----------------------------------------------------------------------------- 41 | 42 | implementation 43 | 44 | uses 45 | System.Generics.Collections, 46 | System.Masks, 47 | System.SysUtils, 48 | System.StrUtils; 49 | 50 | // ----------------------------------------------------------------------------- 51 | // 52 | // FilterModules 53 | // 54 | // ----------------------------------------------------------------------------- 55 | procedure FilterModules(DebugInfo: TDebugInfo; const ModuleFilter: string; Include: boolean; Logger: IDebugInfoModuleLogger); 56 | begin 57 | try 58 | var MaskValues := ModuleFilter.Split([';']); 59 | 60 | var SymbolsIncludeEliminateCount := 0; 61 | var SymbolsExcludeEliminateCount := 0; 62 | var ModulesIncludeEliminateCount := 0; 63 | var ModulesExcludeEliminateCount := 0; 64 | 65 | var Masks := TObjectList.Create; 66 | var Segments := TList.Create; 67 | try 68 | Masks.Capacity := Length(MaskValues); 69 | for var MaskValue in MaskValues do 70 | begin 71 | var Segment: integer; 72 | if (MaskValue.Length = 4) and (TryStrToInt(MaskValue, Segment)) and (Segment <= $FFFF) then 73 | Segments.Add(Segment) 74 | else 75 | Masks.Add(TMask.Create(MaskValue)); 76 | end; 77 | 78 | for var i := DebugInfo.Modules.Count-1 downto 0 do 79 | begin 80 | var Module := DebugInfo.Modules[i]; 81 | var KeepIt: boolean := not Include; 82 | 83 | for var Mask in Masks do 84 | if (Mask.Matches(Module.Name)) then 85 | begin 86 | KeepIt := Include; 87 | break; 88 | end; 89 | 90 | if (KeepIt = not Include) then 91 | for var Segment in Segments do 92 | if (Module.Segment.Index = Segment) then 93 | begin 94 | KeepIt := Include; 95 | break; 96 | end; 97 | 98 | if (not KeepIt) then 99 | begin 100 | if (Include) then 101 | begin 102 | Inc(ModulesIncludeEliminateCount); 103 | Inc(SymbolsIncludeEliminateCount, Module.Symbols.Count); 104 | Logger.Debug('Include filter eliminated module: [%.4X] %s', [Module.Segment.Index, Module.Name]) 105 | end else 106 | begin 107 | Inc(ModulesExcludeEliminateCount); 108 | Inc(SymbolsExcludeEliminateCount, Module.Symbols.Count); 109 | Logger.Debug('Exclude filter eliminated module: [%.4X] %s', [Module.Segment.Index, Module.Name]); 110 | end; 111 | 112 | DebugInfo.Modules.Remove(Module); 113 | end; 114 | end; 115 | finally 116 | Segments.Free; 117 | Masks.Free; 118 | end; 119 | 120 | if (ModulesIncludeEliminateCount > 0) then 121 | Logger.Info('Include filter eliminated %.0n module(s), %.0n symbol(s)', [ModulesIncludeEliminateCount * 1.0, SymbolsIncludeEliminateCount * 1.0]); 122 | 123 | if (ModulesExcludeEliminateCount > 0) then 124 | Logger.Info('Exclude filter eliminated %.0n module(s), %.0n symbols(s)', [ModulesExcludeEliminateCount * 1.0, SymbolsExcludeEliminateCount * 1.0]); 125 | 126 | except 127 | on E: EMaskException do 128 | Logger.Error('Invalid filter. %s', [E.Message]); 129 | end; 130 | end; 131 | 132 | // ----------------------------------------------------------------------------- 133 | // 134 | // PostImportValidation 135 | // 136 | // ----------------------------------------------------------------------------- 137 | procedure PostImportValidation(DebugInfo: TDebugInfo; Logger: IDebugInfoModuleLogger); 138 | begin 139 | // Modules with lines but no source or vice versa 140 | for var Module in DebugInfo.Modules do 141 | begin 142 | if (Module.SourceFiles.Count = 0) then 143 | begin 144 | if (Module.SourceLines.Count = 0) then 145 | Logger.Debug('Module has no source files: [%.4X] %s', [Module.Segment.Index, Module.Name]) 146 | else 147 | Logger.Debug('Module has source lines but no source file: [%.4X] %s', [Module.Segment.Index, Module.Name]); 148 | end else 149 | if (Module.SourceLines.Count = 0) then 150 | Logger.Debug('Module has source files but no source lines: [%.4X] %s', [Module.Segment.Index, Module.Name]); 151 | end; 152 | end; 153 | 154 | // ----------------------------------------------------------------------------- 155 | 156 | end. 157 | 158 | -------------------------------------------------------------------------------- /Source/debug.info.log.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.log; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | 15 | type 16 | TDebugInfoLogCategory = (lcDebug, lcInfo, lcWarning, lcError, lcFatal); 17 | TDebugInfoLogModule = integer; // Just a handle 18 | 19 | IDebugInfoLogger = interface 20 | ['{0EFE498C-E264-4466-AF51-D25BF7F300AE}'] 21 | procedure Log(Category: TDebugInfoLogCategory; LogModule: TDebugInfoLogModule; const Msg: string); 22 | end; 23 | 24 | function DebugInfoLogger: IDebugInfoLogger; 25 | 26 | function RegisterDebugInfoLogger(const Logger: IDebugInfoLogger): IDebugInfoLogger; 27 | 28 | function RegisterDebugInfoLogModule(const ModuleName: string): TDebugInfoLogModule; 29 | function GetDebugInfoLogModuleName(LogModule: TDebugInfoLogModule): string; 30 | 31 | 32 | // Get and set the log level. 33 | // Messages with a category less than the log level will not be logged. 34 | function DebugInfoLogLevel: TDebugInfoLogCategory; 35 | procedure SetDebugInfoLogLevel(Category: TDebugInfoLogCategory); 36 | 37 | 38 | // IDebugInfoModuleLogger wraps the DebugInfoLogger/RegisterDebugInfoLogModule combo 39 | // into a single object for convenience. 40 | // Additionally it provides overloads for formatted output. 41 | type 42 | IDebugInfoModuleLogger = interface 43 | ['{4472B73B-7D35-4FD1-9A38-EBAE5BDA188D}'] 44 | procedure Debug(const Msg: string); overload; 45 | procedure Debug(const Fmt: string; const Args: array of const); overload; 46 | 47 | procedure Info(const Msg: string); overload; 48 | procedure Info(const Fmt: string; const Args: array of const); overload; 49 | 50 | procedure Warning(const Msg: string); overload; 51 | procedure Warning(const Fmt: string; const Args: array of const); overload; 52 | 53 | procedure Error(const Msg: string; Fatal: boolean = True); overload; 54 | procedure Error(const Fmt: string; const Args: array of const; Fatal: boolean = True); overload; 55 | end; 56 | 57 | function RegisterDebugInfoModuleLogger(const ModuleName: string): IDebugInfoModuleLogger; 58 | 59 | 60 | implementation 61 | 62 | uses 63 | System.Generics.Collections, 64 | System.SysUtils, 65 | Debug.Info; // EDebugInfo 66 | 67 | var 68 | FDebugInfoLogLevel: TDebugInfoLogCategory = lcError; 69 | 70 | function DebugInfoLogLevel: TDebugInfoLogCategory; 71 | begin 72 | Result := FDebugInfoLogLevel; 73 | end; 74 | 75 | procedure SetDebugInfoLogLevel(Category: TDebugInfoLogCategory); 76 | begin 77 | FDebugInfoLogLevel := Category; 78 | end; 79 | 80 | type 81 | TDebugInfoModuleLogger = class abstract(TInterfacedObject, IDebugInfoModuleLogger) 82 | private 83 | FLogModule: TDebugInfoLogModule; 84 | protected 85 | procedure Debug(const Msg: string); overload; 86 | procedure Debug(const Fmt: string; const Args: array of const); overload; 87 | procedure Info(const Msg: string); overload; 88 | procedure Info(const Fmt: string; const Args: array of const); overload; 89 | procedure Warning(const Msg: string); overload; 90 | procedure Warning(const Fmt: string; const Args: array of const); overload; 91 | procedure Error(const Msg: string; Fatal: boolean = True); overload; 92 | procedure Error(const Fmt: string; const Args: array of const; Fatal: boolean = True); overload; 93 | public 94 | constructor Create(ALogModule: TDebugInfoLogModule); 95 | end; 96 | 97 | constructor TDebugInfoModuleLogger.Create(ALogModule: TDebugInfoLogModule); 98 | begin 99 | inherited Create; 100 | FLogModule := ALogModule; 101 | end; 102 | 103 | procedure TDebugInfoModuleLogger.Debug(const Fmt: string; const Args: array of const); 104 | begin 105 | if (FDebugInfoLogLevel <= lcDebug) then 106 | Debug(Format(Fmt, Args)); 107 | end; 108 | 109 | procedure TDebugInfoModuleLogger.Debug(const Msg: string); 110 | begin 111 | if (FDebugInfoLogLevel <= lcDebug) then 112 | DebugInfoLogger.Log(lcDebug, FLogModule, Msg); 113 | end; 114 | 115 | procedure TDebugInfoModuleLogger.Error(const Fmt: string; const Args: array of const; Fatal: boolean); 116 | begin 117 | if (FDebugInfoLogLevel <= lcError) or (Fatal) then 118 | Error(Format(Fmt, Args), Fatal); 119 | end; 120 | 121 | procedure TDebugInfoModuleLogger.Error(const Msg: string; Fatal: boolean); 122 | const 123 | ErrorCategory: array[boolean] of TDebugInfoLogCategory = (lcError, lcFatal); 124 | begin 125 | if (FDebugInfoLogLevel <= lcError) or (Fatal) then 126 | DebugInfoLogger.Log(ErrorCategory[Fatal], FLogModule, Msg); 127 | end; 128 | 129 | procedure TDebugInfoModuleLogger.Info(const Fmt: string; const Args: array of const); 130 | begin 131 | if (FDebugInfoLogLevel <= lcInfo) then 132 | Info(Format(Fmt, Args)); 133 | end; 134 | 135 | procedure TDebugInfoModuleLogger.Info(const Msg: string); 136 | begin 137 | if (FDebugInfoLogLevel <= lcInfo) then 138 | DebugInfoLogger.Log(lcInfo, FLogModule, Msg); 139 | end; 140 | 141 | procedure TDebugInfoModuleLogger.Warning(const Fmt: string; const Args: array of const); 142 | begin 143 | if (FDebugInfoLogLevel <= lcWarning) then 144 | Warning(Format(Fmt, Args)); 145 | end; 146 | 147 | procedure TDebugInfoModuleLogger.Warning(const Msg: string); 148 | begin 149 | if (FDebugInfoLogLevel <= lcWarning) then 150 | DebugInfoLogger.Log(lcWarning, FLogModule, Msg); 151 | end; 152 | 153 | function RegisterDebugInfoModuleLogger(const ModuleName: string): IDebugInfoModuleLogger; 154 | begin 155 | var LogModule := RegisterDebugInfoLogModule(ModuleName); 156 | Result := TDebugInfoModuleLogger.Create(LogModule); 157 | end; 158 | 159 | type 160 | TDebugInfoNullLogger = class(TInterfacedObject, IDebugInfoLogger) 161 | protected 162 | // IDebugInfoLogger 163 | procedure Log(Category: TDebugInfoLogCategory; LogModule: TDebugInfoLogModule; const Msg: string); 164 | end; 165 | 166 | procedure TDebugInfoNullLogger.Log(Category: TDebugInfoLogCategory; LogModule: TDebugInfoLogModule; const Msg: string); 167 | begin 168 | if (Category = lcFatal) then 169 | Abort; 170 | end; 171 | 172 | var 173 | FDebugInfoLogger: IDebugInfoLogger; 174 | FDebugInfoNullLogger: IDebugInfoLogger; 175 | 176 | function DebugInfoLogger: IDebugInfoLogger; 177 | begin 178 | if (FDebugInfoLogger = nil) then 179 | begin 180 | if (FDebugInfoNullLogger = nil) then 181 | FDebugInfoNullLogger := TDebugInfoNullLogger.Create; 182 | Result := FDebugInfoNullLogger; 183 | end else 184 | Result := FDebugInfoLogger; 185 | end; 186 | 187 | function RegisterDebugInfoLogger(const Logger: IDebugInfoLogger): IDebugInfoLogger; 188 | begin 189 | Result := FDebugInfoLogger; 190 | FDebugInfoLogger := Logger; 191 | end; 192 | 193 | var 194 | FLogModules: TList; 195 | 196 | function RegisterDebugInfoLogModule(const ModuleName: string): TDebugInfoLogModule; 197 | begin 198 | if (FLogModules = nil) then 199 | FLogModules := TList.Create; 200 | 201 | Result := FLogModules.IndexOf(ModuleName); 202 | 203 | if (Result = -1) then 204 | Result := FLogModules.Add(ModuleName); 205 | end; 206 | 207 | function GetDebugInfoLogModuleName(LogModule: TDebugInfoLogModule): string; 208 | begin 209 | if (FLogModules = nil) then 210 | raise EDebugInfo.CreateFmt('Invalid log module handle: %d', [LogModule]); 211 | 212 | Result := FLogModules[LogModule]; 213 | end; 214 | 215 | 216 | initialization 217 | finalization 218 | FDebugInfoLogger := nil; 219 | FDebugInfoNullLogger := nil; 220 | FreeAndNil(FLogModules); 221 | end. 222 | 223 | -------------------------------------------------------------------------------- /Source/map2pdb.mes: -------------------------------------------------------------------------------- 1 | [GeneralSettings] 2 | MesVersion=4 3 | HandleExceptions=1 4 | LinkInCode=1 5 | AppendMapFileToBinary=1 6 | NoOwnMadExceptSettings=0 7 | CheckFileCrc=1 8 | CheckForFrozenMainThread=0 9 | FreezeTimeout=60000 10 | ReportLeaks=0 11 | WindowsLogo=0 12 | CrashOnBuffer=0 13 | CrashOnUnderrun=0 14 | AutomaticallySaveBugReport=1 15 | AutoSaveBugReportIfNotSent=1 16 | AutomaticallyMailBugReport=0 17 | AutoMailProgressBox=0 18 | CopyBugReportToClipboard=0 19 | SuspendAllRunningThreads=0 20 | ShowPleaseWaitBox=1 21 | PleaseWaitIcon=plwait1 22 | AutomaticallyContinueApplication=0 23 | AutomaticallyRestartApplication=0 24 | AutomaticallyCloseApplication=0 25 | SendInBackground=1 26 | SendHelper=196608 27 | Send32Icon=send321 28 | UploadViaHttp=0 29 | HttpServer= 30 | HttpSsl=0 31 | HttpPort=0 32 | HttpAccount= 33 | HttpPassword= 34 | UploadToFogBugz=0 35 | UploadToBugZilla=0 36 | UploadToMantis=0 37 | BugTrackerAccount= 38 | BugTrackerPassword= 39 | BugTrackerProject= 40 | BugTrackerArea= 41 | BugTrackerAssignTo= 42 | MailAsSmtpServer=0 43 | MailAsSmtpClient=0 44 | SmtpServer= 45 | SmtpSsl=0 46 | SmtpTls=0 47 | SmtpPort=0 48 | SmtpAccount= 49 | SmtpPassword= 50 | MailViaMapi=1 51 | MailViaMailto=1 52 | MailAddress= 53 | BugReportFile=bugreport.txt 54 | AttachBugReport=1 55 | AttachBugReportFile=1 56 | DeleteBugReportFile=1 57 | BugReportSendAs=bugreport.txt 58 | BugReportZip= 59 | ScreenShotDepth=8 60 | ScreenShotAppOnly=0 61 | ScreenShotSendAs=screenshot.png 62 | ScreenShotZip= 63 | AdditionalAttachments= 64 | AppendBugReports=1 65 | BugReportFileSize=100000 66 | DontSaveDuplicateExceptions=1 67 | DontSaveDuplicateFreezings=1 68 | DuplicateExceptionDefinition=1 69 | DuplicateFreezeDefinition=2 70 | ShowExceptionBox=1 71 | OkBtnText=&OK 72 | DetailsBtnText=&Details 73 | PleaseWaitTitle=Information 74 | PleaseWaitText=Please wait a moment... 75 | BugTrackerTitle=%25appname%25, %25exceptMsg%25 76 | BugTrackerDescr=error details: %0d%0a%25errorDetails%25 77 | MailSubject=bug report 78 | MailBody=please find the bug report attached 79 | SendBoxTitle=Sending bug report... 80 | PrepareAttachMsg=Preparing attachments... 81 | MxLookupMsg=Searching for mail server... 82 | ConnectMsg=Connecting to server... 83 | SendMailMsg=Sending mail... 84 | FieldsMsg=Setting fields... 85 | SendAttachMsg=Sending attachments... 86 | SendFinalizeMsg=Finalizing... 87 | MailFailureMsg=Sorry, sending the bug report didn't work. 88 | VersionVariable= 89 | [ExceptionBox] 90 | ShowButtonMailBugReport=0 91 | ShowButtonSaveBugReport=0 92 | ShowButtonPrintBugReport=0 93 | ShowButtonShowBugReport=1 94 | ShowButtonContinueApplication=1 95 | ShowButtonRestartApplication=0 96 | ShowButtonCloseApplication=1 97 | IconButtonSendBugReport=send1 98 | IconButtonSaveBugReport=save1 99 | IconButtonPrintBugReport=print1 100 | IconButtonShowBugReport=show1 101 | IconButtonContinueApplication=continue1 102 | IconButtonCantContinueApplication=cantContinue1 103 | IconButtonRestartApplication=restart1 104 | IconButtonCloseApplication=close1 105 | FocusedButton=3 106 | SendAssistant=SendAssistant 107 | SaveAssistant=SaveAssistant 108 | PrintAssistant=PrintAssistant 109 | AutomaticallyShowBugReport=0 110 | NoOwnerDrawButtons=0 111 | BigExceptionIcon=big1 112 | TitleBar=%25appname%25 113 | ExceptionMessage=An error occurred in the application. 114 | FrozenMessage=The application seems to be frozen. 115 | BitFaultMsg=The file "%25modname%25" seems to be corrupt! 116 | MailBugReportText=send bug report 117 | SaveBugReportText=save bug report 118 | PrintBugReportText=print bug report 119 | ShowBugReportText=show bug report 120 | ContinueApplicationText=continue application 121 | RestartApplicationText=restart application 122 | CloseApplicationText=close application 123 | [BugReport] 124 | ListThreads=1 125 | ListModules=0 126 | ListHardware=0 127 | ShowCpuRegisters=0 128 | ShowStackDump=0 129 | Disassembly=0 130 | HideUglyItems=0 131 | ShowRelativeAddrs=1 132 | ShowRelativeLines=1 133 | FormatDisassembly=0 134 | LimitDisassembly=5 135 | EnabledPlugins= 136 | [Filters] 137 | Filter1ExceptionClasses=EDBEditError 138 | Filter1DontCreateBugReport=1 139 | Filter1DontCreateScreenshot=1 140 | Filter1DontSuspendThreads=1 141 | Filter1DontCallHandlers=1 142 | Filter1ShowBox=3 143 | Filter1Assis= 144 | Filter2ExceptionClasses= 145 | Filter2DontCreateBugReport=0 146 | Filter2DontCreateScreenshot=0 147 | Filter2DontSuspendThreads=0 148 | Filter2DontCallHandlers=0 149 | Filter2ShowBox=0 150 | Filter2Assis= 151 | GeneralDontCreateBugReport=0 152 | GeneralDontCreateScreenshot=0 153 | GeneralDontSuspendThreads=0 154 | GeneralDontCallHandlers=0 155 | GeneralShowBox=0 156 | GeneralAssis= 157 | [Assistants] 158 | Assistant1=SendAssistant|Send Assistant|ContactForm|DetailsForm|ScrShotForm 159 | Assistant2=SaveAssistant|Save Assistant|ContactForm|DetailsForm 160 | Assistant3=PrintAssistant|Print Assistant|ContactForm|DetailsForm 161 | Forms1=TPF0%0eTMEContactForm%0bContactForm%07Message%0c%13%00%00%00Contact Information%08MinWidth%04%00%00%00%00%08OnAction%0c%1b%00%00%00madExcept.HandleContactForm%05Timer%04%00%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%08%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%09CancelBtn%07Caption%0c%06%00%00%00Cancel%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%08INVLabel%06Label1%07Caption%0c%0a%00%00%00your name:%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%08NameEdit%07Colored%09%07Enabled%09%05Lines%04%01%00%00%00%08Optional%09%0aOutputName%0c%0c%00%00%00contact name%0aOutputType%07%09nvoHeader%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%05Valid%09%00%00%08INVLabel%06Label2%07Caption%0c%0b%00%00%00your email:%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%09EmailEdit%07Colored%09%07Enabled%09%05Lines%04%01%00%00%00%08Optional%08%0aOutputName%0c%0d%00%00%00contact email%0aOutputType%07%09nvoHeader%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%05Valid%09%00%00%0bINVCheckBox%08MemCheck%07Caption%0c%0b%00%00%00remember me%07Checked%08%07Enabled%09%0aOutputName%0c%00%00%00%00%07Spacing%04%00%00%00%00%00%00%00 162 | Forms2=TPF0%0eTMEDetailsForm%0bDetailsForm%07Message%0c%0d%00%00%00Error Details%08MinWidth%04%00%00%00%00%08OnAction%0c%00%00%00%00%05Timer%04%00%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%09CancelBtn%07Caption%0c%06%00%00%00Cancel%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%08INVLabel%06Label1%07Caption%0c,%00%00%00what were you doing when the error occurred?%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%0bDetailsMemo%07Colored%09%07Enabled%09%05Lines%04%09%00%00%00%08Optional%08%0aOutputName%0c%0d%00%00%00error details%0aOutputType%07%0dnvoOwnSection%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%05Valid%09%00%00%00 163 | Forms3=TPF0%0eTMEScrShotForm%0bScrShotForm%0dActiveControl%07%0bContinueBtn%07Message%0c%18%00%00%00Screenshot Configuration%08MinWidth%04%00%00%00%00%08OnAction%0c%1e%00%00%00madExcept.HandleScreenshotForm%05Timer%04%fa%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%08%0bNoOwnerDraw%08%07Visible%09%00%00%09INVButton%09CancelBtn%07Caption%0c%06%00%00%00Cancel%07Enabled%09%0bNoOwnerDraw%08%07Visible%09%00%00%0bINVCheckBox%0bAttachCheck%07Caption%0c%25%00%00%00attach a screenshot to the bug report%07Checked%09%07Enabled%09%0aOutputName%0c%00%00%00%00%07Spacing%04%00%00%00%00%00%00%08INVImage%0aScrShotImg%06Border%09%09Clickable%09%07Enabled%09%04File%0c%00%00%00%00%06Height%04%00%00%00%00%07Spacing%04%00%00%00%00%05Width%04%00%00%00%00%00%00%08INVLabel%06Label1%07Caption%0c%15%00%00%00(click to edit image)%07Enabled%09%07Spacing%04%00%00%00%00%00%00%00 164 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # map2pdb 2 | 3 | ## Generating Microsoft PDB files from Delphi and C++ Builder MAP files 4 | 5 | Copyright (c) 2021 Anders Melander 6 | 7 | https://github.com/andersmelander/map2pdb 8 | 9 | **map2pdb** is a tool used to convert the MAP files produced by the Delphi and C++ Builder compilers to Microsoft PDB files for use in [tools that support that format](#tools-that-consume-pdb-files). 10 | 11 | ![Profiling a Delphi application in VTune](Info/vtune_delphi.png) 12 | 13 | map2pdb is written in pure Delphi with no dependencies on other libraries or tools. Unlike other similar solutions, it does not [rely on the undocumented Visual Studio DLLs](https://github.com/rainers/cv2pdb/blob/master/src/mspdb.cpp) to build and write the PDB file. 14 | 15 | ### Usage 16 | 17 | map2pdb is a console-mode application. To use it you simply run it from the command line with the appropriate parameters. You can also add it to the Tools menu inside the Delphi or C++ Builder IDE so it's easily available there. More on that below. 18 | 19 | ``` 20 | map2pdb [options] 21 | ``` 22 | 23 | | Option | Meaning | 24 | | --------------------------- | ------------------------------------------------------------------------- | 25 | | `-pdb[:]` | Writes a PDB file (default) | 26 | | `-yaml[:]` | Writes an YAML file that can be used with `llvm-pdbutil yam2pdb` | 27 | | `-bind[:]` | Patches the specified exe/dll file to include a reference to the PDB file | 28 | | `-include:` | Only include data that satisfies the specified filters in the PDB | 29 | | `-exclude:` | Exclude data that satisfies the specified filter from the PDB | 30 | | `-v` | Print verbose output | 31 | | `-debug` | Print debug information | 32 | | `-pause` | Prompt after completion | 33 | | -? | Display help | 34 | 35 | The order of parameters is not significant. 36 | 37 | #### Filters 38 | 39 | Filters can be used to limit the size of the produced PDB. This can be necessary either because of memory constraints or because some tools (I'm looking at you, VTune) get very slow with large PDB files. 40 | 41 | Filters are applied after the map file has been imported but before the PDB is produced. More than one filter can be specified. 42 | 43 | First, the include-filters are applied; Everything that doesn't satisfy the include-filter is excluded from the PDB. Then the exclude-filters are applied; Everything that satisfies the exclude-filter is excluded from the PDB. 44 | 45 | ##### Module filter 46 | 47 | A module filter specifies the names of modules (units in Delphi terms) to include or exclude from the PDB. Wildcards are supported and multiple filenames can be specified by separating them with semicolons. 48 | For example to exclude all DevExpress units and Firedac: 49 | 50 | ``` 51 | -exclude:dx*;cx*;firedac.* 52 | ``` 53 | 54 | ##### Segment filter 55 | 56 | A segment filter specifies the index value of segments/sections to include or exclude from the PDB. The list of segments can be found at the very top of the MAP file. 57 | Most of the code is typically located in segment 0001 so a common filter would be: 58 | 59 | ``` 60 | -include:0001 61 | ``` 62 | 63 | In order for a filter to be recognized as a segment filter it must consist of 4 decimal digits. 64 | 65 | #### Examples 66 | 67 | * Read from foobar.map, create foobar.pdb, patch foobar.exe to reference foobar.pdb and only include symbols from segment 0001 but ignore all units starting with "dx" or "cx": 68 | 69 | ``` 70 | map2pdb -include:0001 -exclude:dx*;cx* -bind foobar.map 71 | ``` 72 | 73 | * Read from mypackage.map, create mypackage.pdb and patch mypackage.bpl to reference mypackage.pdb: 74 | 75 | ``` 76 | map2pdb -bind:mypackage.bpl mypackage.map 77 | ``` 78 | 79 | ### Requirements 80 | 81 | Since map2pdb uses the information in your project's MAP file to generate the PDB file, you need to link your projects with a **Detailed** map file. You do not need to link with debug information but the detailed MAP file is required. Additionally, you should compile with full **Debug Information** enabled since this controls if the MAP file will contain line number information or not. 82 | None of these options will affect the final output of your compiled project; They only affect the debug information which is stored in the MAP and DCU files. 83 | 84 | You enable the Detailed MAP file in your project's [linker options](http://docwiki.embarcadero.com/RADStudio/Sydney/en/Linking) and the Debug information in the project's [compiler options](http://docwiki.embarcadero.com/RADStudio/Sydney/en/Compiling#Debugging_Options). 85 | 86 | ### Delphi and C++ Builder integration 87 | 88 | 1. From the "Tools" menu select "Configure Tools...". 89 | 2. Select "Add...". 90 | 3. Give the tool a name. E.g. "map2pdb". 91 | 4. In the "Program" field specify the complete path to the `map2pdb.exe` file. 92 | 5. In the "Parameters" field write the following: 93 | `-pause -bind:$EXENAME $PATH($EXENAME)$NAMEONLY($EXENAME).map` 94 | 6. Close the dialog. 95 | 96 | You should now have a new menu item in the Tools menu. When you have compiled your project and want to generate a PDB file you can now just use this menu item to do so. 97 | 98 | The purpose of the **-pause** switch in the example above is to enable you to see what's happening. Without it the command window would just open briefly and then close when map2pdb was done. You can remove it if you don't need that. 99 | Of course, you can also add whatever additional parameters you need. 100 | 101 | ### References 102 | 103 | The following resources were used as references and inspiration during the development of map2pdb: 104 | 105 | - [Microsoft pdb](https://github.com/Microsoft/microsoft-pdb) 106 | Incomplete source code "documenting" the PDB file format. 107 | 108 | - [llvm's PDB documentation](https://llvm.org/docs/PDB/) 109 | Nice but incomplete documentation of the PDB and MSF file formats. 110 | 111 | - [Epoch](https://github.com/apoch/epoch-language/blob/renewal/EpochCompiler/Linker/PDB.epoch) 112 | The Epoch compiler/linker contains an incomplete PDB writer. 113 | 114 | - [Matching debug information](http://www.debuginfo.com/articles/debuginfomatch.html) 115 | Information about how the PDB file is associated with an EXE file. 116 | 117 | ### Tools 118 | 119 | #### PDB forensic tools 120 | 121 | - [llvm-pdbutil](https://llvm.org/docs/CommandGuide/llvm-pdbutil.html) 122 | Used to validate, read and (partially) write PDB files and dump the information in various formats. 123 | Unofficial downloads here: https://github.com/shaharv/llvm-pdbutil-builds/releases 124 | 125 | - [cvdump](https://github.com/microsoft/microsoft-pdb/tree/master/cvdump) 126 | Microsoft's cvdump utilty. Used to validate and read PDB files and dump the information in text format. 127 | 128 | #### Tools that consume PDB files 129 | 130 | - [Intel VTune profiler](https://software.intel.com/content/www/us/en/develop/tools/oneapi/components/vtune-profiler.html) 131 | - [AMD μProf profiler](https://developer.amd.com/amd-uprof/) 132 | - [WinDbg debugger](https://docs.microsoft.com/en-us/windows-hardware/drivers/debugger/debugger-download-tools) 133 | - [OllyDbg debugger](http://www.ollydbg.de/) 134 | 135 | ##### Performance problems with Intel VTune 136 | 137 | Due to a bug in the **msdia140.dll** file that comes bundled with some older versions of VTune you can experience that VTune takes an extremely long time to resolve symbols on anything but the smallest projects. 138 | 139 | msdia140.dll implements the [Debug Interface Access SDK](https://docs.microsoft.com/en-us/visualstudio/debugger/debug-interface-access/debug-interface-access-sdk?view=vs-2019). The bug was introduced in VS2017 and supposedly fixed in VS2019 but apparently, it took a while for Intel to discover that so they continued shipping the old VS2017 version of msdia140.dll. 140 | 141 | To fix this problem (if you have it) all you have to do is replace VTune's msdia140.dll with a newer version. The file is located in the bin32 and bin64 folders under the VTune root folder. Note that the 32-bit and 64-bit files are not the same. You need to replace the file in the bin32 folder with the 32-bit version of msdia140.dll and the one in the bin64 folder with the 64-bit version. 142 | 143 | Now here's the catch; The files you need to replace are not the ones that are actually named msdia140.dll. You need to replace the ones named **amplxe_msdia140.dll**. Remember to save the old ones first in case you mess this up. 144 | 145 | If you have a newer version of VS installed you can probably find the required files somewhere on your system. I guess anything newer than version 14.10.x.x should do. You can also install the [Visual Studio Redistributable](https://visualstudio.microsoft.com/downloads/#microsoft-visual-c-redistributable-for-visual-studio-2019) and get the files from there or you can just get the two files from the [old repository download section](https://bitbucket.org/anders_melander/map2pdb/downloads/). 146 | 147 | ### Building map2pdb from source 148 | 149 | The source requires Delphi 10.3 or later and will not compiler with older versions due to the language features used (inline vars). 150 | 151 | To build map2pdb just open `map2pdb.dproj` in Delphi, build and you're done. 152 | 153 | ### Download 154 | 155 | A precompiled map2pdb.exe can be downloaded here: https://github.com/andersmelander/map2pdb/releases 156 | It has been virus scanned locally with Kaspersky and remotely with [VirusTotal](https://www.virustotal.com). 157 | Note that some anti-virus programs regularly flags map2pdb as a threat due to the fact that it contains code to modify a PE file. There's not much I can do about this. 158 | 159 | ### License 160 | 161 | The source code is released under the MPL 2.0 license: 162 | 163 | > Copyright © 2021 Anders Melander 164 | > This Source Code Form is subject to the terms of the Mozilla Public 165 | > License, v. 2.0. If a copy of the MPL was not distributed with this 166 | > file, You can obtain one at http://mozilla.org/MPL/2.0/. -------------------------------------------------------------------------------- /Source/amVersionInfo.pas: -------------------------------------------------------------------------------- 1 | unit amVersionInfo; 2 | 3 | (* 4 | * Copyright © 2008 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | uses 14 | Classes, 15 | Windows; 16 | 17 | type 18 | TTranslationRec = packed record 19 | case Integer of 20 | 0: ( 21 | LanguageID: WORD; 22 | CharsetID: WORD); 23 | 1: ( 24 | TranslationID: DWORD); 25 | end; 26 | PTranslationRec = ^TTranslationRec; 27 | TTranslationTable = array[0..0] of TTranslationRec; 28 | PTranslationTable = ^TTranslationTable; 29 | 30 | 31 | TVersionInfo = class 32 | strict private 33 | FVersionBuffer: pointer; 34 | FValid: boolean; 35 | FFileInfo: PVSFixedFileInfo; 36 | FTranslationTable: PTranslationTable; 37 | FTranslationCount: integer; 38 | private 39 | function DoGetString(const Key: string): string; 40 | function GetCharset(Index: integer): WORD; 41 | function GetLanguage(Index: integer): WORD; 42 | function GetLanguageName(Index: integer): string; 43 | function GetFileVersion: int64; 44 | function GetProductVersion: int64; 45 | function GetFileFlags: DWORD; 46 | function GetFileDate: int64; 47 | function GetFileSubType: DWORD; 48 | function GetFileType: DWORD; 49 | function GetOS: DWORD; 50 | function GetTranslationRec(Index: integer): PTranslationRec; 51 | property TranslationTable[Index: integer]: PTranslationRec read GetTranslationRec; 52 | protected 53 | property VersionBuffer: pointer read FVersionBuffer; 54 | public 55 | constructor Create(const Filename: string); 56 | destructor Destroy; override; 57 | class function VersionToString(Version: int64): string; 58 | class function StringToVersion(const Value: string): int64; 59 | class function VersionMajor(Version: int64): Word; 60 | class function VersionMinor(Version: int64): Word; 61 | class function VersionRelease(Version: int64): Word; 62 | class function VersionBuild(Version: int64): Word; 63 | class function FileVersionString(const Filename: string): string; 64 | function GetString(const Key: string; LanguageID: integer; CharsetID: integer): string; overload; 65 | function GetString(const Key, TranslationID: string): string; overload; 66 | function GetString(const Key: string; Index: integer = 0): string; overload; 67 | property Valid: boolean read FValid; 68 | property Strings[const Key: string]: string read DoGetString; default; 69 | property FileVersion: int64 read GetFileVersion; 70 | property ProductVersion: int64 read GetProductVersion; 71 | property FileFlags: DWORD read GetFileFlags; 72 | property OS: DWORD read GetOS; 73 | property FileType: DWORD read GetFileType; 74 | property FileSubType: DWORD read GetFileSubType; 75 | property FileDate: int64 read GetFileDate; 76 | property LanguageID[Index: integer]: WORD read GetLanguage; 77 | property CharsetID[Index: integer]: WORD read GetCharset; 78 | property LanguageNames[Index: integer]: string read GetLanguageName; 79 | property TranslationCount: integer read FTranslationCount; 80 | end; 81 | 82 | 83 | implementation 84 | 85 | uses 86 | SysUtils, 87 | RTLConsts; 88 | 89 | { TVersionInfo } 90 | 91 | constructor TVersionInfo.Create(const Filename: string); 92 | var 93 | OrgFileName: string; 94 | InfoSize, Dummy: DWORD; 95 | Size: DWORD; 96 | begin 97 | inherited Create; 98 | 99 | // GetFileVersionInfo modifies the filename parameter data while parsing. 100 | // Copy the const string into a local variable to create a writeable copy. 101 | OrgFileName := Filename; 102 | UniqueString(OrgFileName); 103 | InfoSize := GetFileVersionInfoSize(PChar(OrgFileName), Dummy); 104 | if InfoSize <> 0 then 105 | begin 106 | GetMem(FVersionBuffer, InfoSize); 107 | try 108 | if GetFileVersionInfo(PChar(OrgFileName), Dummy, InfoSize, FVersionBuffer) then 109 | begin 110 | FValid := True; 111 | if (not VerQueryValue(FVersionBuffer, '\', Pointer(FFileInfo), Size)) then 112 | FFileInfo := nil; 113 | 114 | if (VerQueryValue(VersionBuffer, '\VarFileInfo\Translation', pointer(FTranslationTable), Size)) then 115 | FTranslationCount := Size div SizeOf(TTranslationRec) 116 | else 117 | FTranslationCount := 0; 118 | end; 119 | finally 120 | if (not FValid) then 121 | begin 122 | FreeMem(FVersionBuffer); 123 | FVersionBuffer := nil; 124 | end; 125 | end; 126 | end; 127 | end; 128 | 129 | destructor TVersionInfo.Destroy; 130 | begin 131 | if (FVersionBuffer <> nil) then 132 | FreeMem(FVersionBuffer); 133 | FValid := False; 134 | inherited Destroy; 135 | end; 136 | 137 | function TVersionInfo.GetCharset(Index: integer): WORD; 138 | begin 139 | Result := TranslationTable[Index].CharsetID; 140 | end; 141 | 142 | function TVersionInfo.GetFileDate: int64; 143 | var 144 | LargeInteger: ULarge_Integer; 145 | begin 146 | if (Valid) and (FFileInfo <> nil) then 147 | begin 148 | LargeInteger.LowPart := FFileInfo.dwFileDateLS; 149 | LargeInteger.HighPart := FFileInfo.dwFileDateMS; 150 | Result := LargeInteger.QuadPart; 151 | end else 152 | Result := 0; 153 | end; 154 | 155 | function TVersionInfo.GetFileFlags: DWORD; 156 | begin 157 | if (Valid) and (FFileInfo <> nil) then 158 | Result := FFileInfo.dwFileFlags and FFileInfo.dwFileFlagsMask 159 | else 160 | Result := 0; 161 | end; 162 | 163 | function TVersionInfo.GetFileSubType: DWORD; 164 | begin 165 | if (Valid) and (FFileInfo <> nil) then 166 | Result := FFileInfo.dwFileSubtype 167 | else 168 | Result := 0; 169 | end; 170 | 171 | function TVersionInfo.GetFileType: DWORD; 172 | begin 173 | if (Valid) and (FFileInfo <> nil) then 174 | Result := FFileInfo.dwFileType 175 | else 176 | Result := 0; 177 | end; 178 | 179 | function TVersionInfo.GetFileVersion: int64; 180 | var 181 | LargeInteger: ULarge_Integer; 182 | begin 183 | if (Valid) and (FFileInfo <> nil) then 184 | begin 185 | LargeInteger.LowPart := FFileInfo.dwFileVersionLS; 186 | LargeInteger.HighPart := FFileInfo.dwFileVersionMS; 187 | Result := LargeInteger.QuadPart; 188 | end else 189 | Result := 0; 190 | end; 191 | 192 | function TVersionInfo.GetLanguage(Index: integer): WORD; 193 | begin 194 | Result := TranslationTable[Index].LanguageID; 195 | end; 196 | 197 | function TVersionInfo.GetLanguageName(Index: integer): string; 198 | var 199 | Size: DWORD; 200 | begin 201 | SetLength(Result, 255); 202 | Size := VerLanguageName(TranslationTable[Index].TranslationID, PChar(Result), Length(Result)); 203 | SetLength(Result, Size); 204 | end; 205 | 206 | {$IFOPT R+} 207 | {$DEFINE R_PLUS} 208 | {$RANGECHECKS OFF} 209 | {$ENDIF} 210 | function TVersionInfo.GetTranslationRec(Index: integer): PTranslationRec; 211 | begin 212 | if (not Valid) or (Index < 0) or (Index >= FTranslationCount) then 213 | raise Exception.CreateFmt(SListIndexError, [Index]); 214 | Result := @(FTranslationTable[Index]); 215 | end; 216 | {$IFDEF R_PLUS} 217 | {$RANGECHECKS ON} 218 | {$UNDEF R_PLUS} 219 | {$ENDIF} 220 | 221 | function TVersionInfo.GetOS: DWORD; 222 | begin 223 | if (Valid) and (FFileInfo <> nil) then 224 | Result := FFileInfo.dwFileOS 225 | else 226 | Result := 0; 227 | end; 228 | 229 | function TVersionInfo.GetProductVersion: int64; 230 | var 231 | LargeInteger: ULarge_Integer; 232 | begin 233 | if (Valid) and (FFileInfo <> nil) then 234 | begin 235 | LargeInteger.LowPart := FFileInfo.dwProductVersionLS; 236 | LargeInteger.HighPart := FFileInfo.dwProductVersionMS; 237 | Result := LargeInteger.QuadPart; 238 | end else 239 | Result := 0; 240 | end; 241 | 242 | function TVersionInfo.GetString(const Key: string; Index: integer): string; 243 | var 244 | TranslationRec: PTranslationRec; 245 | begin 246 | TranslationRec := TranslationTable[Index]; 247 | Result := GetString(Key, TranslationRec.LanguageID, TranslationRec.CharsetID); 248 | end; 249 | 250 | function TVersionInfo.DoGetString(const Key: string): string; 251 | begin 252 | Result := GetString(Key, 0); 253 | end; 254 | 255 | class function TVersionInfo.FileVersionString(const Filename: string): string; 256 | var 257 | VersionInfo: TVersionInfo; 258 | begin 259 | VersionInfo := TVersionInfo.Create(Filename); 260 | try 261 | 262 | Result := VersionToString(VersionInfo.FileVersion); 263 | 264 | finally 265 | VersionInfo.Free; 266 | end; 267 | end; 268 | 269 | function TVersionInfo.GetString(const Key: string; LanguageID, CharsetID: integer): string; 270 | var 271 | TranslationID: string; 272 | begin 273 | TranslationID := Format('%.4x%.4x', [LanguageID, CharsetID]); 274 | Result := GetString(Key, TranslationID); 275 | end; 276 | 277 | function TVersionInfo.GetString(const Key: string; const TranslationID: string): string; 278 | var 279 | Value: PChar; 280 | s: string; 281 | Size: DWORD; 282 | begin 283 | if (Valid) then 284 | begin 285 | s := Format('\StringFileInfo\%s\%s', [TranslationID, Key]); 286 | if (VerQueryValue(VersionBuffer, PChar(s), pointer(Value), Size)) then 287 | Result := PChar(Value) 288 | else 289 | Result := ''; 290 | end else 291 | Result := ''; 292 | end; 293 | 294 | class function TVersionInfo.StringToVersion(const Value: string): int64; 295 | var 296 | s, n: string; 297 | w: integer; 298 | i: integer; 299 | begin 300 | s := Value; 301 | w := 0; 302 | Result := 0; 303 | while (s <> '') and (w < 4) do 304 | begin 305 | i := pos('.', s); 306 | if (i <= 0) then 307 | i := Length(s)+1; 308 | n := Copy(s, 1, i-1); 309 | s := Copy(s, i+1, MaxInt); 310 | Result := (Result shl 16) + StrToInt(n); 311 | inc(w); 312 | end; 313 | end; 314 | 315 | class function TVersionInfo.VersionBuild(Version: int64): Word; 316 | var 317 | v: ULarge_Integer; 318 | begin 319 | v.QuadPart := Version; 320 | Result := v.LowPart and $FFFF; 321 | end; 322 | 323 | class function TVersionInfo.VersionMajor(Version: int64): Word; 324 | var 325 | v: ULarge_Integer; 326 | begin 327 | v.QuadPart := Version; 328 | Result := v.HighPart shr 16; 329 | end; 330 | 331 | class function TVersionInfo.VersionMinor(Version: int64): Word; 332 | var 333 | v: ULarge_Integer; 334 | begin 335 | v.QuadPart := Version; 336 | Result := v.HighPart and $FFFF; 337 | end; 338 | 339 | class function TVersionInfo.VersionRelease(Version: int64): Word; 340 | var 341 | v: ULarge_Integer; 342 | begin 343 | v.QuadPart := Version; 344 | Result := v.LowPart shr 16; 345 | end; 346 | 347 | class function TVersionInfo.VersionToString(Version: int64): string; 348 | var 349 | v: ULarge_Integer; 350 | begin 351 | v.QuadPart := Version; 352 | Result := Format('%d.%d.%d.%d', 353 | [v.HighPart shr 16, v.HighPart and $FFFF, v.LowPart shr 16, v.LowPart and $FFFF]); 354 | end; 355 | 356 | end. 357 | -------------------------------------------------------------------------------- /Test/Source/map2pdb_test.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {15044BC3-86F8-48DF-AB45-74DE56C1143C} 4 | map2pdb_test.dpr 5 | True 6 | Debug 7 | map2pdb_test 8 | 32769 9 | Application 10 | VCL 11 | 20.1 12 | Win32 13 | 14 | 15 | true 16 | 17 | 18 | true 19 | Base 20 | true 21 | 22 | 23 | true 24 | Base 25 | true 26 | 27 | 28 | true 29 | Base 30 | true 31 | 32 | 33 | true 34 | Base 35 | true 36 | 37 | 38 | true 39 | Cfg_1 40 | true 41 | true 42 | 43 | 44 | true 45 | Base 46 | true 47 | 48 | 49 | true 50 | Cfg_2 51 | true 52 | true 53 | 54 | 55 | true 56 | Cfg_2 57 | true 58 | true 59 | 60 | 61 | false 62 | false 63 | false 64 | false 65 | false 66 | 00400000 67 | map2pdb_test 68 | Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX;Winapi;$(DCC_Namespace) 69 | 1030 70 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= 71 | ..\..\Source;$(DCC_UnitSearchPath) 72 | ..\Lib\$(Platform)\$(Config) 73 | ..\Bin\$(Platform)\$(Config) 74 | 75 | 76 | $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png 77 | activity-1.7.2.dex.jar;annotation-experimental-1.3.0.dex.jar;annotation-jvm-1.6.0.dex.jar;annotations-13.0.dex.jar;appcompat-1.2.0.dex.jar;appcompat-resources-1.2.0.dex.jar;billing-6.0.1.dex.jar;biometric-1.1.0.dex.jar;browser-1.4.0.dex.jar;cloud-messaging.dex.jar;collection-1.1.0.dex.jar;concurrent-futures-1.1.0.dex.jar;core-1.10.1.dex.jar;core-common-2.2.0.dex.jar;core-ktx-1.10.1.dex.jar;core-runtime-2.2.0.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;error_prone_annotations-2.9.0.dex.jar;exifinterface-1.3.6.dex.jar;firebase-annotations-16.2.0.dex.jar;firebase-common-20.3.1.dex.jar;firebase-components-17.1.0.dex.jar;firebase-datatransport-18.1.7.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-encoders-proto-16.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.1.3.dex.jar;firebase-installations-interop-17.1.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-23.1.2.dex.jar;fmx.dex.jar;fragment-1.2.5.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;kotlin-stdlib-1.8.22.dex.jar;kotlin-stdlib-common-1.8.22.dex.jar;kotlin-stdlib-jdk7-1.8.22.dex.jar;kotlin-stdlib-jdk8-1.8.22.dex.jar;kotlinx-coroutines-android-1.6.4.dex.jar;kotlinx-coroutines-core-jvm-1.6.4.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.6.1.dex.jar;lifecycle-livedata-2.6.1.dex.jar;lifecycle-livedata-core-2.6.1.dex.jar;lifecycle-runtime-2.6.1.dex.jar;lifecycle-service-2.6.1.dex.jar;lifecycle-viewmodel-2.6.1.dex.jar;lifecycle-viewmodel-savedstate-2.6.1.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;okio-jvm-3.4.0.dex.jar;play-services-ads-22.2.0.dex.jar;play-services-ads-base-22.2.0.dex.jar;play-services-ads-identifier-18.0.0.dex.jar;play-services-ads-lite-22.2.0.dex.jar;play-services-appset-16.0.1.dex.jar;play-services-base-18.1.0.dex.jar;play-services-basement-18.1.0.dex.jar;play-services-cloud-messaging-17.0.1.dex.jar;play-services-location-21.0.1.dex.jar;play-services-maps-18.1.0.dex.jar;play-services-measurement-base-20.1.2.dex.jar;play-services-measurement-sdk-api-20.1.2.dex.jar;play-services-stats-17.0.2.dex.jar;play-services-tasks-18.0.2.dex.jar;print-1.0.0.dex.jar;profileinstaller-1.3.0.dex.jar;room-common-2.2.5.dex.jar;room-runtime-2.2.5.dex.jar;savedstate-1.2.1.dex.jar;sqlite-2.1.0.dex.jar;sqlite-framework-2.1.0.dex.jar;startup-runtime-1.1.1.dex.jar;tracing-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.1.8.dex.jar;transport-runtime-3.1.8.dex.jar;user-messaging-platform-2.0.0.dex.jar;vectordrawable-1.1.0.dex.jar;vectordrawable-animated-1.1.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.7.0.dex.jar 78 | 79 | 80 | System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 81 | Debug 82 | true 83 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) 84 | 1033 85 | $(BDS)\bin\default_app.manifest 86 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 87 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 88 | 89 | 90 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 91 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 92 | 93 | 94 | RELEASE;$(DCC_Define) 95 | 0 96 | false 97 | 0 98 | 99 | 100 | PerMonitorV2 101 | 102 | 103 | DEBUG;$(DCC_Define) 104 | false 105 | true 106 | true 107 | true 108 | 109 | 110 | Debug 111 | 112 | 113 | PerMonitorV2 114 | true 115 | 1033 116 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) 117 | 118 | 119 | 120 | MainSource 121 | 122 | 123 | 124 | 125 | 126 | Base 127 | 128 | 129 | Cfg_1 130 | Base 131 | 132 | 133 | Cfg_2 134 | Base 135 | 136 | 137 | 138 | Delphi.Personality.12 139 | 140 | 141 | 142 | 143 | map2pdb_test.dpr 144 | 145 | 146 | Microsoft Office 2000 Sample Automation Server Wrapper Components 147 | Microsoft Office XP Sample Automation Server Wrapper Components 148 | 149 | 150 | 151 | True 152 | True 153 | False 154 | 155 | 156 | 12 157 | 158 | 159 | 160 | 161 | -------------------------------------------------------------------------------- /Source/debug.map.reader.pas: -------------------------------------------------------------------------------- 1 | unit debug.map.reader; 2 | 3 | interface 4 | 5 | uses 6 | Classes, 7 | debug.info; 8 | 9 | type 10 | TMapReader = class 11 | public 12 | procedure ImportMap(Stream: TStream; DebugInfo: TDebugInfo); overload; 13 | procedure ImportMap(const Filename: string; DebugInfo: TDebugInfo); overload; 14 | end; 15 | 16 | implementation 17 | 18 | uses 19 | SysUtils; 20 | 21 | { TMapReader } 22 | 23 | procedure TMapReader.ImportMap(const Filename: string; DebugInfo: TDebugInfo); 24 | begin 25 | var Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite); 26 | try 27 | 28 | ImportMap(Stream, DebugInfo); 29 | 30 | finally 31 | Stream.Free; 32 | end; 33 | end; 34 | 35 | procedure TMapReader.ImportMap(Stream: TStream; DebugInfo: TDebugInfo); 36 | var 37 | MapLineNumber: integer; 38 | LineBuffer: string; 39 | PeekBuffer: string; 40 | 41 | function PeekLine(Reader: TStreamReader; Skip: boolean = False): string; 42 | begin 43 | if (PeekBuffer = '') then 44 | begin 45 | while (not Reader.EndOfStream) do 46 | begin 47 | PeekBuffer := Reader.ReadLine.TrimLeft; 48 | Inc(MapLineNumber); 49 | if (not Skip) or (not PeekBuffer.IsEmpty) then 50 | break; 51 | end; 52 | end; 53 | 54 | Result := PeekBuffer; 55 | end; 56 | 57 | function CurrentLine(Reader: TStreamReader; Skip: boolean = False): string; 58 | begin 59 | if (LineBuffer = '') then 60 | begin 61 | if (PeekBuffer = '') then 62 | begin 63 | while (not Reader.EndOfStream) do 64 | begin 65 | LineBuffer := Reader.ReadLine.TrimLeft; 66 | Inc(MapLineNumber); 67 | if (not Skip) or (not LineBuffer.IsEmpty) then 68 | break; 69 | end; 70 | end else 71 | begin 72 | LineBuffer := PeekBuffer; 73 | PeekBuffer := ''; 74 | end; 75 | end; 76 | 77 | Result := LineBuffer; 78 | end; 79 | 80 | function NextLine(Reader: TStreamReader; Skip: boolean = False): string; 81 | begin 82 | LineBuffer := ''; 83 | Result := CurrentLine(Reader, Skip); 84 | end; 85 | 86 | function HasData(Reader: TStreamReader): boolean; 87 | begin 88 | Result := (LineBuffer <> '') or (PeekBuffer <> '') or (not Reader.EndOfStream); 89 | end; 90 | 91 | function HexToNibble(c: char): Cardinal; 92 | begin 93 | case c of 94 | '0'..'9': Result := Ord(c)-Ord('0'); 95 | 'a'..'f': Result := 10 + Ord(c)-Ord('a'); 96 | 'A'..'F': Result := 10 + Ord(c)-Ord('A'); 97 | else 98 | Result := $FF; 99 | end; 100 | end; 101 | 102 | function HexToInt16(const s: string; Offset: integer): Word; 103 | begin 104 | Result := 0; 105 | for var i := 1 to SizeOf(Result)*2 do 106 | if (i+Offset <= Length(s)) then 107 | begin 108 | var Nibble := HexToNibble(s[i+Offset]); 109 | if (Nibble = $FF) then 110 | raise Exception.CreateFmt('Invalid hex number: "%s"', [Copy(s, 1+Offset, 4)]); 111 | Result := (Result SHL 4) or Nibble 112 | end else 113 | raise Exception.CreateFmt('Invalid hex number: "%s"', [Copy(s, 1+Offset, 4)]); 114 | end; 115 | 116 | function HexToInt32(const s: string; Offset: integer): Cardinal; 117 | begin 118 | Result := 0; 119 | for var i := 1 to SizeOf(Result)*2 do 120 | if (i+Offset <= Length(s)) then 121 | begin 122 | var Nibble := HexToNibble(s[i+Offset]); 123 | if (Nibble = $FF) then 124 | raise Exception.CreateFmt('Invalid hex number: "%s"', [Copy(s, 1+Offset, 8)]); 125 | Result := (Result SHL 4) or Nibble 126 | end else 127 | raise Exception.CreateFmt('Invalid hex number: "%s"', [Copy(s, 1+Offset, 8)]); 128 | end; 129 | 130 | begin 131 | var Reader := TStreamReader.Create(Stream); 132 | try 133 | MapLineNumber := 0; 134 | 135 | (* 136 | ** Segments 137 | *) 138 | 139 | // " Start Length Name Class" 140 | while (HasData(Reader)) and (not CurrentLine(Reader, True).StartsWith('Start')) and (not LineBuffer.EndsWith('Class')) do 141 | NextLine(Reader, True); 142 | 143 | // Skip empty lines and exit if no more lines 144 | if (NextLine(Reader, True).IsEmpty) then 145 | Exit; 146 | 147 | // " 0001:00401000 000F47FCH .text CODE" 148 | while (not CurrentLine(Reader).IsEmpty) do 149 | begin 150 | var n := Pos(':', LineBuffer); 151 | var SegmentID: TDebugInfoSegment := HexToInt16(LineBuffer, 0); 152 | var Offset: TDebugInfoOffset := HexToInt32(LineBuffer, n); 153 | n := Pos(' ', LineBuffer, n+1); 154 | var Size: TDebugInfoOffset := HexToInt32(LineBuffer, n); 155 | 156 | n := Pos('.', LineBuffer, n+1); 157 | var n2 := Pos(' ', LineBuffer, n+1); 158 | var Name := Copy(LineBuffer, n, n2-n); 159 | 160 | var ClassName := Copy(LineBuffer, n2+1, MaxInt).Trim; 161 | 162 | var SegmentClass := DebugInfo.SegmentClasses.Add(SegmentID, ClassName, Name); 163 | 164 | SegmentClass.Offset := Offset; 165 | SegmentClass.Size := Size; 166 | 167 | NextLine(Reader); 168 | end; 169 | 170 | 171 | (* 172 | ** Modules 173 | *) 174 | 175 | // "Detailed map of segments" 176 | while (HasData(Reader)) and (CurrentLine(Reader, True) <> 'Detailed map of segments') do 177 | NextLine(Reader, True); 178 | 179 | // Skip empty lines and exit if no more lines 180 | if (NextLine(Reader, True).IsEmpty) then 181 | Exit; 182 | 183 | // " 0001:00000000 0000F684 C=CODE S=.text G=(none) M=System ACBP=A9" 184 | while (not CurrentLine(Reader).IsEmpty) do 185 | begin 186 | var n := Pos(' C=', LineBuffer); 187 | var Address := Copy(LineBuffer, 1, n-1); 188 | 189 | n := Pos('M=', LineBuffer); 190 | var Name := Copy(LineBuffer, n+2, Pos(' ', LineBuffer, n+2)-n-2); 191 | 192 | var Segment: TDebugInfoSegment := HexToInt16(Address, 0); 193 | n := Pos(':', Address); 194 | var Offset: TDebugInfoOffset := HexToInt32(Address, n); 195 | n := Pos(' ', Address); 196 | var Size: TDebugInfoOffset := HexToInt32(Address, n); 197 | 198 | var SegmentClass := DebugInfo.SegmentClasses.FindByValue(Segment); 199 | 200 | var Module := DebugInfo.Modules.Add(Name, SegmentClass, Offset); 201 | 202 | Module.Size := Size; 203 | 204 | NextLine(Reader); 205 | end; 206 | 207 | (* 208 | ** Symbols - sorted by name 209 | *) 210 | 211 | // " Address Publics by Name" 212 | while (HasData(Reader)) and (not CurrentLine(Reader, True).EndsWith('Publics by Name')) do 213 | NextLine(Reader, True); 214 | 215 | // Skip empty lines and exit if no more lines 216 | if (NextLine(Reader, True).IsEmpty) then 217 | Exit; 218 | 219 | // " 0001:000E99AC debug.info..TDebugInfo" 220 | while (not CurrentLine(Reader).IsEmpty) do 221 | begin 222 | var n := Pos(' ', LineBuffer); 223 | var Address := Copy(LineBuffer, 1, n-1); 224 | var Name := Copy(LineBuffer, n+1, MaxInt).TrimLeft; 225 | 226 | var Segment: TDebugInfoSegment := HexToInt16(Address, 0); 227 | n := Pos(':', Address); 228 | var Offset: TDebugInfoOffset := HexToInt32(Address, n); 229 | 230 | var SegmentClass := DebugInfo.SegmentClasses.FindByValue(Segment); 231 | 232 | var Symbol := DebugInfo.Symbols.Add(Name, SegmentClass, Offset); 233 | 234 | NextLine(Reader); 235 | end; 236 | 237 | (* 238 | ** Symbols - sorted by address 239 | *) 240 | 241 | // " Address Publics by Value" 242 | while (HasData(Reader)) and (not CurrentLine(Reader, True).EndsWith('Publics by Value')) do 243 | NextLine(Reader, True); 244 | 245 | // Skip this section - it duplicates the previous 246 | 247 | (* 248 | ** Line numbers - grouped by module & segment 249 | *) 250 | 251 | // Rest of file is: 252 | // "Line numbers for System(WindowsAPIs.INC) segment .text" 253 | while (HasData(Reader)) do 254 | begin 255 | const sPrefix = 'Line numbers for '; 256 | while (HasData(Reader)) and (not CurrentLine(Reader, True).StartsWith(sPrefix)) do 257 | NextLine(Reader, True); 258 | 259 | if (not HasData(Reader)) then 260 | break; 261 | 262 | var n := Pos('(', LineBuffer); 263 | if (n = 0) then 264 | raise Exception.CreateFmt('[%d] Source file start marker "(" not found: %s', [MapLineNumber, LineBuffer]); 265 | var ModuleName := Copy(LineBuffer, Length(sPrefix)+1, n-1-Length(sPrefix)); 266 | 267 | var n2 := Pos(')', LineBuffer, n+1); 268 | if (n2 = 0) then 269 | raise Exception.CreateFmt('[%d] Source file end marker ")" not found: %s', [MapLineNumber, LineBuffer]); 270 | var Filename := Copy(LineBuffer, n+1, n2-n-1); 271 | 272 | n := Pos('segment', LineBuffer, n2+1); 273 | if (n = 0) then 274 | raise Exception.CreateFmt('[%d] Source file segment marker "segment" not found: %s', [MapLineNumber, LineBuffer]); 275 | Inc(n, 7); 276 | while (LineBuffer[n] = ' ') do 277 | Inc(n); 278 | 279 | var SegmentName := Copy(LineBuffer, n, MaxInt); 280 | var SegmentClass := DebugInfo.SegmentClasses.FindByName(SegmentName); 281 | if (SegmentClass = nil) then 282 | raise Exception.CreateFmt('[%d] Unknown segment name: %s (%s)', [MapLineNumber, SegmentName, LineBuffer]); 283 | 284 | var Module := DebugInfo.Modules.FindByName(ModuleName, SegmentClass); 285 | if (Module <> nil) then 286 | begin 287 | var SourceFile := Module.SourceFiles.Add(Filename); 288 | 289 | // Skip empty lines and exit if no more lines 290 | if (NextLine(Reader, True).IsEmpty) then 291 | break; 292 | 293 | // " 335 0001:00004068 338 0001:00004070 343 0001:00004078 349 0001:00004080" 294 | while (not CurrentLine(Reader).IsEmpty) do 295 | begin 296 | var Ofs := 1; 297 | 298 | while (Ofs <= LineBuffer.Length) do 299 | begin 300 | // Get line number 301 | n := Pos(' ', LineBuffer, Ofs); 302 | var s := Copy(LineBuffer, Ofs, n-Ofs); 303 | var LineNumber: integer; 304 | if (not integer.TryParse(s, LineNumber)) then 305 | raise Exception.CreateFmt('[%d] Invalid line number: %s (%s)', [MapLineNumber, s, LineBuffer]); 306 | 307 | // Get segment type (we already have that info from the header) 308 | var Segment: TDebugInfoSegment := HexToInt16(LineBuffer, n); 309 | Inc(n, 4+1); 310 | 311 | // Get offset 312 | var Offset: TDebugInfoOffset := HexToInt32(LineBuffer, n); 313 | Inc(n, 8+1); 314 | 315 | if (Offset <> 0) then 316 | Module.SourceLines.Add(SourceFile, LineNumber, Offset); 317 | 318 | while (n <= LineBuffer.Length) and (LineBuffer[n] = ' ') do 319 | Inc(n); 320 | 321 | Ofs := n; 322 | end; 323 | 324 | if (NextLine(Reader).IsEmpty) then 325 | break; 326 | end; 327 | end else 328 | begin 329 | // Ignore empty modules. E.g.: 330 | // Line numbers for System.RTLConsts(System.RTLConsts.pas) segment .text 331 | // 611 0001:00000000 332 | 333 | // raise Exception.CreateFmt('[%d] Module not found: %s (%s)', [MapLineNumber, ModuleName, LineBuffer]); 334 | 335 | // Skip empty lines and exit if no more lines 336 | if (NextLine(Reader, True).IsEmpty) then 337 | break; 338 | 339 | // Skip non-empty lines 340 | while (not CurrentLine(Reader).IsEmpty) do 341 | begin 342 | if (NextLine(Reader).IsEmpty) then 343 | break; 344 | end; 345 | end; 346 | 347 | end; 348 | 349 | finally 350 | Reader.Free; 351 | end; 352 | end; 353 | 354 | end. 355 | 356 | -------------------------------------------------------------------------------- /Source/map2pdb.dpr: -------------------------------------------------------------------------------- 1 | program map2pdb; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | {$APPTYPE CONSOLE} 12 | {$WARN SYMBOL_PLATFORM OFF} 13 | {$WEAKLINKRTTI ON} 14 | 15 | {$R *.res} 16 | 17 | uses 18 | {$ifdef MADEXCEPT} 19 | madExcept, 20 | {$endif MADEXCEPT} 21 | System.SysUtils, 22 | System.IOUtils, 23 | System.Diagnostics, 24 | System.Generics.Collections, 25 | System.StrUtils, 26 | amVersionInfo, 27 | debug.info in 'debug.info.pas', 28 | debug.info.writer in 'debug.info.writer.pas', 29 | debug.info.writer.pdb in 'debug.info.writer.pdb.pas', 30 | debug.info.writer.yaml in 'debug.info.writer.yaml.pas', 31 | debug.info.reader in 'debug.info.reader.pas', 32 | debug.info.reader.map in 'debug.info.reader.map.pas', 33 | debug.info.reader.test in 'debug.info.reader.test.pas', 34 | debug.info.reader.jdbg in 'debug.info.reader.jdbg.pas', 35 | debug.info.codeview in 'debug.info.codeview.pas', 36 | debug.info.msf in 'debug.info.msf.pas', 37 | debug.info.pdb in 'debug.info.pdb.pas', 38 | debug.info.pdb.bind in 'debug.info.pdb.bind.pas', 39 | debug.info.log in 'debug.info.log.pas', 40 | debug.info.utilities in 'debug.info.utilities.pas'; 41 | 42 | var 43 | Logger: IDebugInfoModuleLogger; 44 | 45 | // Find parameter by index (zero based), ignores switches. 46 | function FindParam(Index: integer; var Value: string; const Default: string = ''): boolean; 47 | begin 48 | for var i := 1 to ParamCount do 49 | begin 50 | Value := ParamStr(i); 51 | 52 | if (CharInSet(Value[1], SwitchChars)) then 53 | continue; 54 | 55 | if (Index = 0) then 56 | Exit(True); 57 | 58 | Dec(Index); 59 | end; 60 | Value := Default; 61 | Result := False; 62 | end; 63 | 64 | procedure DisplayBanner; 65 | begin 66 | Writeln('map2pdb - Copyright (c) 2021 Anders Melander'); 67 | Writeln(Format('Version %s', [TVersionInfo.FileVersionString(ParamStr(0))])); 68 | Writeln; 69 | end; 70 | 71 | procedure DisplayHelp; 72 | begin 73 | // 1 2 3 4 5 6 7 8 74 | // 12345678901234567890123456789012345678901234567890123456789012345678901234567890 75 | // 76 | Writeln('Parses the map file produced by Delphi and writes a PDB file.'); 77 | Writeln; 78 | Writeln('Usage: map2pdb [options] '); 79 | Writeln; 80 | Writeln('Options:'); 81 | Writeln(' -v Verbose output'); 82 | Writeln(' -pdb[:] Writes a PDB file (default)'); 83 | Writeln(' -yaml[:] Writes an YAML file that can be used with'); 84 | Writeln(' llvm-pdbutil'); 85 | Writeln(' -bind[:] Patches the specified exe/dll file to include'); 86 | Writeln(' a reference to the pdb file'); 87 | Writeln(' -include: Include the specified list of modules in the pdb'); 88 | Writeln(' (semicolor separated list, wildcards supported)'); 89 | Writeln(' -include: Include the specified segment in the pdb'); 90 | Writeln(' (number must be a 4 digit decimal number)'); 91 | Writeln(' -exclude: Exclude the specified list of modules from the pdb'); 92 | Writeln(' (semicolor separated list, wildcards supported)'); 93 | Writeln(' -exclude: Exclude the specified segment from the pdb'); 94 | Writeln(' (number must be a 4 digit decimal number)'); 95 | Writeln(' -blocksize: Set MSF block size'); 96 | Writeln(' (default: 4096, valid values are 1024, 2048, 4096,'); 97 | Writeln(' 8192, etc.)'); 98 | Writeln(' -format: Specify input file format: Map or Jdbg'); 99 | Writeln(' By default auto detects from file type and falls'); 100 | Writeln(' back to map format.'); 101 | Writeln(' -pause Prompt after completion'); 102 | Writeln; 103 | Writeln('Examples:'); 104 | Writeln; 105 | Writeln('* Read from foobar.map, create foobar.pdb, patch foobar.exe to reference'); 106 | Writeln(' foobar.pdb and ignore all units starting with "system" or "dx":'); 107 | Writeln; 108 | Writeln(' map2pdb -exclude:system*;dx* -bind foobar.map'); 109 | Writeln; 110 | Writeln('* Read from mypackage.map, create mypackage.pdb, patch mypackage.bpl to'); 111 | Writeln(' reference mypackage.pdb:'); 112 | Writeln; 113 | Writeln(' map2pdb -bind:mypackage.bpl mypackage.map'); 114 | Writeln; 115 | end; 116 | 117 | procedure DisplayElapsedTime(ms: Int64); 118 | const 119 | MillisecondsPerSecond = 1000; 120 | MillisecondsPerMinute = 60 * Int64(MillisecondsPerSecond); 121 | MillisecondsPerHour = 60 * Int64(MillisecondsPerMinute); 122 | begin 123 | Logger.Info('Elapsed time: %.2d:%.2d:%.2d.%d', [ 124 | (ms div MillisecondsPerHour) mod 24, 125 | (ms div MillisecondsPerMinute) mod 60, 126 | (ms div MillisecondsPerSecond) mod 60, 127 | (ms mod MillisecondsPerSecond)]); 128 | end; 129 | 130 | type 131 | TDebugInfoConsoleLogger = class(TInterfacedObject, IDebugInfoLogger) 132 | protected 133 | // IDebugInfoLogger 134 | procedure Log(Category: TDebugInfoLogCategory; LogModule: TDebugInfoLogModule; const Msg: string); 135 | public 136 | class function New: IDebugInfoLogger; 137 | end; 138 | 139 | procedure TDebugInfoConsoleLogger.Log(Category: TDebugInfoLogCategory; LogModule: TDebugInfoLogModule; const Msg: string); 140 | const 141 | sLogCategory: array[TDebugInfoLogCategory] of string = ('Debug: ', '', 'Warning: ', 'Error: ', 'Fatal: '); 142 | begin 143 | if (Category >= DebugInfoLogLevel) then 144 | Writeln(Format('%s%s', [sLogCategory[Category], Msg])); 145 | 146 | if (Category = lcFatal) then 147 | Abort; 148 | end; 149 | 150 | class function TDebugInfoConsoleLogger.New: IDebugInfoLogger; 151 | begin 152 | Result := TDebugInfoConsoleLogger.Create; 153 | end; 154 | 155 | type 156 | TTargetType = (ttPDB, ttYAML); 157 | const 158 | sOutputFileTypes: array[TTargetType] of string = ('.pdb', '.yaml'); 159 | WriterClasses: array[TTargetType] of TDebugInfoWriterClass = (TDebugInfoPdbWriter, TDebugInfoYamlWriter); 160 | 161 | type 162 | TInputFormat = (ifMap, ifJdbg, ifTest); 163 | const 164 | sInputFileTypes: array[TInputFormat] of string = ('.map', '.jdbg', '.test'); 165 | ReaderClasses: array[TInputFormat] of TDebugInfoReaderClass = (TDebugInfoMapReader, TDebugInfoJdbgReader, TDebugInfoSyntheticReader); 166 | 167 | function TryStrToInputFormat(const AName: string; var InputFormat: TInputFormat): boolean; 168 | begin 169 | for var InFormat := Low(TInputFormat) to High(TInputFormat) do 170 | if (SameText(AName, sInputFileTypes[InFormat])) then 171 | begin 172 | InputFormat := InFormat; 173 | Exit(True); 174 | end; 175 | Result := False; 176 | end; 177 | 178 | begin 179 | var DoPause := FindCmdLineSwitch('pause'); 180 | var sw := TStopwatch.StartNew; 181 | try 182 | 183 | RegisterDebugInfoLogger(TDebugInfoConsoleLogger.New); 184 | Logger := RegisterDebugInfoModuleLogger('main'); 185 | 186 | DisplayBanner; 187 | 188 | var SourceFilename: string; 189 | var TargetFilename: string := ''; 190 | var PEFilename: string := ''; 191 | 192 | FindCmdLineSwitch('bind', PEFilename, True, [clstValueAppended]); 193 | 194 | if (not FindParam(0, SourceFilename)) or (FindCmdLineSwitch('h')) or (FindCmdLineSwitch('?')) then 195 | begin 196 | DisplayHelp; 197 | 198 | if (DoPause) then 199 | begin 200 | Writeln('Press enter to continue'); 201 | Readln; 202 | end; 203 | 204 | exit; 205 | end; 206 | 207 | if FindCmdLineSwitch('debug') then 208 | SetDebugInfoLogLevel(lcDebug) 209 | else 210 | if FindCmdLineSwitch('v') or FindCmdLineSwitch('verbose') then 211 | SetDebugInfoLogLevel(lcInfo); 212 | 213 | var TargetType: TTargetType := ttPDB; 214 | if (FindCmdLineSwitch('yaml', TargetFilename, True, [clstValueAppended])) or (FindCmdLineSwitch('yaml')) then 215 | begin 216 | 217 | TargetType := ttYAML; 218 | 219 | end else 220 | begin 221 | 222 | FindCmdLineSwitch('pdb', TargetFilename, True, [clstValueAppended]); 223 | 224 | // If we're both building a PDB and binding it in one go then we can use 225 | // a new GUID for both. 226 | if (PEFilename <> '') or (FindCmdLineSwitch('bind')) then 227 | begin 228 | PdbBuildSignature := TGUID.NewGuid; 229 | 230 | Logger.Info('Constructed a new PDB GUID: %s', [PdbBuildSignature.ToString]); 231 | end; 232 | end; 233 | 234 | if (TargetFilename = '') then 235 | begin 236 | TargetFilename := TPath.ChangeExtension(SourceFilename, sOutputFileTypes[TargetType]); 237 | 238 | Logger.Info('Output filename not specified. Defaulting to %s', [TPath.GetFileName(TargetFilename)]); 239 | end; 240 | 241 | 242 | var DebugInfo := TDebugInfo.Create; 243 | try 244 | 245 | 246 | (* 247 | ** Determine source file format 248 | *) 249 | // Default to map format 250 | var InputFormat: TInputFormat := ifMap; 251 | 252 | var FileType: string; 253 | // First try to get the format from the command line 254 | if (not FindCmdLineSwitch('format', FileType, True, [clstValueAppended])) or 255 | (not TryStrToInputFormat('.'+FileType, InputFormat)) then 256 | begin 257 | // Then try to get it from the file type 258 | FileType := TPath.GetExtension(SourceFilename); 259 | TryStrToInputFormat(FileType, InputFormat); 260 | end; 261 | 262 | 263 | (* 264 | ** Read source file 265 | *) 266 | var ReaderClass: TDebugInfoReaderClass := ReaderClasses[InputFormat]; 267 | 268 | var Reader := ReaderClass.Create; 269 | try 270 | 271 | Reader.LoadFromFile(SourceFilename, DebugInfo); 272 | 273 | finally 274 | Reader.Free; 275 | end; 276 | 277 | 278 | (* 279 | ** Apply filters 280 | *) 281 | 282 | // Eliminate modules that doesn't satisfy include filter 283 | var Filter := ''; // Include everything by default 284 | if (FindCmdLineSwitch('include', Filter, True, [clstValueAppended])) and (Filter <> '') then 285 | FilterModules(DebugInfo, Filter, True, Logger); 286 | 287 | // Eliminate modules that satisfies exclude filter 288 | Filter := ''; // Exclude nothing by default 289 | if (FindCmdLineSwitch('exclude', Filter, True, [clstValueAppended])) and (Filter <> '') then 290 | FilterModules(DebugInfo, Filter, False, Logger); 291 | 292 | 293 | if (DebugInfoLogLevel <= lcInfo) then 294 | begin 295 | var SymbolCount := 0; 296 | var LineCount := 0; 297 | for var Module in DebugInfo.Modules do 298 | begin 299 | Inc(SymbolCount, Module.Symbols.Count); 300 | Inc(LineCount, Module.SourceLines.Count); 301 | end; 302 | Logger.Info('Collected %.0n modules, %.0n symbols, %.0n lines, %.0n source files', [DebugInfo.Modules.Count * 1.0, SymbolCount * 1.0, LineCount * 1.0, DebugInfo.SourceFiles.Count * 1.0]); 303 | end; 304 | 305 | 306 | (* 307 | ** Validation 308 | *) 309 | if (DebugInfoLogLevel <= lcDebug) then 310 | PostImportValidation(DebugInfo, Logger); 311 | 312 | 313 | (* 314 | ** Write target file 315 | *) 316 | begin 317 | var BlockSize: Integer := 0; 318 | var Param: string; 319 | if (FindCmdLineSwitch('blocksize', Param, True, [clstValueAppended])) and (TryStrToInt(Param, BlockSize)) then 320 | Logger.Info('MSF block size: %.0n bytes', [BlockSize * 1.0]); 321 | 322 | var Writer := WriterClasses[TargetType].Create(BlockSize); 323 | try 324 | 325 | Writer.SaveToFile(TargetFilename, DebugInfo); 326 | 327 | finally 328 | Writer.Free; 329 | end; 330 | 331 | end; 332 | 333 | finally 334 | DebugInfo.Free; 335 | end; 336 | 337 | 338 | (* 339 | ** Bind PE file to PDB 340 | *) 341 | if (PEFilename <> '') or (FindCmdLineSwitch('bind')) then 342 | begin 343 | if (TargetType <> ttPDB) then 344 | raise EDebugInfo.Create('-bind requires PDB output'); 345 | 346 | if (PEFilename = '') then 347 | begin 348 | PEFilename := TPath.ChangeExtension(SourceFilename, '.exe'); 349 | 350 | Logger.Info('PE filename not specified. Defaulting to %s', [TPath.GetFileName(PEFilename)]); 351 | end; 352 | 353 | PatchPE(PEFilename, TargetFilename); 354 | end; 355 | 356 | except 357 | on E: Exception do 358 | begin 359 | {$ifdef MADEXCEPT} 360 | // There's no need to scare the user with a madExcept stack trace for 361 | // internally generated exceptions. Just show a simple error message. 362 | if not (E is EDebugInfo) then 363 | madExcept.HandleException 364 | else 365 | {$endif MADEXCEPT} 366 | Logger.Error('%s: %s', [E.ClassName, E.Message], False); 367 | 368 | if (DebugHook <> 0) then 369 | DoPause := True; 370 | 371 | ExitCode := 1; 372 | end; 373 | end; 374 | 375 | DisplayElapsedTime(sw.ElapsedMilliseconds); 376 | 377 | if (DoPause) then 378 | begin 379 | Writeln('Done - Press enter to continue'); 380 | Readln; 381 | end; 382 | 383 | end. 384 | -------------------------------------------------------------------------------- /Source/debug.info.writer.yaml.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.writer.yaml; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 12 | {$define WRITE_LINES} 13 | {$define WRITE_SYMBOLS} 14 | {.$define WRITE_PUBLICS} // Doesn't work and llvm-pdbutil doesn't support it properly 15 | 16 | interface 17 | 18 | uses 19 | Classes, 20 | debug.info, 21 | debug.info.writer; 22 | 23 | type 24 | // YAML writer for use with the LLVM project's llvm-pdbutil yaml2pdb 25 | TDebugInfoYamlWriter = class(TDebugInfoWriter) 26 | private 27 | protected 28 | public 29 | procedure SaveToStream(Stream: TStream; DebugInfo: TDebugInfo); override; 30 | end; 31 | 32 | 33 | implementation 34 | 35 | 36 | uses 37 | SysUtils, 38 | Types, 39 | debug.info.pdb; 40 | 41 | { TDebugInfoYamlWriter } 42 | 43 | procedure TDebugInfoYamlWriter.SaveToStream(Stream: TStream; DebugInfo: TDebugInfo); 44 | var 45 | Level: integer; 46 | Writer: TStreamWriter; 47 | 48 | procedure WriteLine(const s: string); overload; 49 | begin 50 | if (Level > 0) then 51 | Writer.Write(StringOfChar(' ', Level * 2)); 52 | Writer.WriteLine(s); 53 | end; 54 | 55 | procedure WriteLine(const Fmt: string; const Args: array of const); overload; 56 | begin 57 | WriteLine(Format(Fmt, Args)); 58 | end; 59 | 60 | procedure BeginBlock(const s: string); overload; 61 | begin 62 | WriteLine(s); 63 | Inc(Level); 64 | end; 65 | 66 | procedure BeginBlock(const Fmt: string; const Args: array of const); overload; 67 | begin 68 | BeginBlock(Format(Fmt, Args)); 69 | end; 70 | 71 | procedure EndBlock; 72 | begin 73 | Dec(Level); 74 | end; 75 | 76 | begin 77 | Logger.Info('Writing YAML file'); 78 | 79 | Writer := TStreamWriter.Create(Stream); 80 | try 81 | 82 | Level := 0; 83 | 84 | WriteLine('---'); 85 | WriteLine(Format('# generated by map2yaml %s', [DateTimeToStr(Now)])); 86 | 87 | (* 88 | ** PDB (PDB Info) stream 89 | *) 90 | BeginBlock('PdbStream:'); 91 | begin 92 | // llvm-pdbutil swaps the values in the GUID that have endianess 93 | // (this is a bug) so we need to save them "pre-swapped" in the 94 | // YAML file in order to get the correct value in the PDB file. 95 | var TweakedSignature := PdbBuildSignature; 96 | var Bytes := TweakedSignature.ToByteArray(TEndian.Little); 97 | TweakedSignature := TGUID.Create(Bytes, TEndian.Big); 98 | 99 | WriteLine('Age: %d', [PdbBuildAge]); 100 | WriteLine('Guid: ''%s''', [TweakedSignature.ToString]); 101 | WriteLine('Signature: 1537453107'); // Value doesn't matter 102 | WriteLine('Features: [ MinimalDebugInfo ]'); 103 | // WriteLine('Features: [ VC110 ]'); 104 | WriteLine('Version: VC70'); 105 | end; 106 | EndBlock; 107 | 108 | 109 | (* 110 | ** DBI (Debug Info) stream 111 | *) 112 | BeginBlock('DbiStream:'); 113 | begin 114 | WriteLine('VerHeader: V70'); 115 | WriteLine('Age: %d', [PdbBuildAge]); 116 | // WriteLine('MachineType: Amd64'); 117 | WriteLine('Flags: 0'); // 2 = private symbols were stripped 118 | 119 | BeginBlock('Modules:'); 120 | begin 121 | 122 | for var Module in DebugInfo.Modules do 123 | begin 124 | // Skip module if it doesn't contain any usable source lines 125 | if (Module.SourceLines.Empty) then 126 | continue; 127 | 128 | // Skip module if it doesn't contain code 129 | if (Module.Segment.SegClassType <> sctCODE) then 130 | continue; 131 | 132 | Logger.Info(Format('- Module: %s', [Module.Name])); 133 | 134 | BeginBlock('- Module: ''%s''', [Module.Name]); 135 | begin 136 | WriteLine('ObjFile: ''%s.dcu''', [Module.Name]); 137 | 138 | BeginBlock('SourceFiles:'); 139 | begin 140 | for var SourceFile in Module.SourceFiles do 141 | WriteLine('- ''%s''', [SourceFile.Filename]); 142 | end; 143 | EndBlock; 144 | 145 | BeginBlock('Subsections:'); 146 | begin 147 | 148 | BeginBlock('- !FileChecksums'); 149 | begin 150 | BeginBlock('Checksums:'); 151 | begin 152 | for var SourceFile in Module.SourceFiles do 153 | begin 154 | BeginBlock('- FileName: ''%s''', [SourceFile.Filename]); 155 | begin 156 | WriteLine('Kind: None'); 157 | WriteLine('Checksum: '''''); 158 | end; 159 | EndBlock; 160 | end; 161 | end; 162 | EndBlock; 163 | end; 164 | EndBlock; 165 | 166 | {$ifdef WRITE_LINES} 167 | BeginBlock('- !Lines'); 168 | begin 169 | WriteLine('CodeSize: %d', [Module.Size]); 170 | WriteLine('RelocOffset: %0:d # %0:.8X', [Module.Offset]); 171 | WriteLine('RelocSegment: %d', [Module.Segment.Index]); 172 | WriteLine('Flags: [ ]'); 173 | BeginBlock('Blocks:'); 174 | begin 175 | var LastSourceFile: TDebugInfoSourceFile := nil; 176 | for var SourceLine in Module.SourceLines do 177 | begin 178 | if (SourceLine.SourceFile <> LastSourceFile) then 179 | begin 180 | if (LastSourceFile <> nil) then 181 | begin 182 | EndBlock; 183 | WriteLine('Columns: [ ]'); 184 | EndBlock; 185 | end; 186 | BeginBlock('- FileName: ''%s''', [SourceLine.SourceFile.Filename]); 187 | BeginBlock('Lines:'); 188 | LastSourceFile := SourceLine.SourceFile; 189 | end; 190 | 191 | BeginBlock('- Offset: %d', [SourceLine.Offset]); 192 | begin 193 | WriteLine('LineStart: %d', [SourceLine.LineNumber]); 194 | WriteLine('IsStatement: true'); 195 | WriteLine('EndDelta: 0'); 196 | end; 197 | EndBlock; 198 | end; 199 | if (LastSourceFile <> nil) then 200 | begin 201 | EndBlock; 202 | WriteLine('Columns: [ ]'); 203 | EndBlock; 204 | end; 205 | end; 206 | EndBlock; 207 | end; 208 | EndBlock; 209 | {$endif WRITE_LINES} 210 | 211 | end; 212 | EndBlock; 213 | 214 | {$ifdef WRITE_SYMBOLS} 215 | (* 216 | ** Modi (Module Information) stream - inside the DBI stream 217 | *) 218 | BeginBlock('Modi:'); 219 | begin 220 | WriteLine('Signature: 4'); // 4 = Supposedly means C13 line information 221 | BeginBlock('Records:'); 222 | begin 223 | 224 | for var Symbol in Module.Symbols do 225 | begin 226 | // Ignore zero size symbols 227 | if (Symbol.Size = 0) then 228 | continue; 229 | 230 | BeginBlock('- Kind: S_GPROC32'); 231 | begin 232 | BeginBlock('ProcSym:'); 233 | begin 234 | WriteLine('Segment: %d', [Symbol.Module.Segment.Index]); 235 | WriteLine('Offset: %0:d # %0:.8X [%1:.8X]', [Symbol.Offset, Symbol.Module.Segment.Offset+Symbol.Module.Offset+Symbol.Offset]); 236 | WriteLine('CodeSize: %d', [Symbol.Size]); 237 | WriteLine('DbgStart: 0'); 238 | WriteLine('DbgEnd: %d', [Symbol.Size-1]); 239 | WriteLine('FunctionType: 4097'); // I have no clue... 240 | WriteLine('Flags: [ ]'); 241 | WriteLine('DisplayName: ''%s''', [Symbol.Name]); 242 | end; 243 | EndBlock; 244 | end; 245 | EndBlock; 246 | 247 | (* As far as I can see a S_GPROC32 must be terminated with S_END but it doesn't seem to make a difference. 248 | BeginBlock('- Kind: S_END'); 249 | begin 250 | WriteLine('ScopeEndSym: {}'); 251 | end; 252 | EndBlock; 253 | *) 254 | 255 | end; 256 | end; 257 | EndBlock; 258 | end; 259 | EndBlock; 260 | {$endif WRITE_SYMBOLS} 261 | 262 | end; 263 | EndBlock; 264 | end; 265 | 266 | (* 267 | ** Output segments as a special linker module 268 | *) 269 | // See: https://reviews.llvm.org/rG28e31ee45e63d7c195e7980c811a15f0b26118cb 270 | BeginBlock('- Module: ''%s''', ['* Linker *']); 271 | begin 272 | WriteLine('ObjFile: '''''); 273 | 274 | BeginBlock('Modi:'); 275 | begin 276 | WriteLine('Signature: 4'); 277 | 278 | BeginBlock('Records:'); 279 | begin 280 | BeginBlock('- Kind: S_OBJNAME'); 281 | begin 282 | BeginBlock('ObjNameSym:'); 283 | begin 284 | WriteLine('Signature: 0'); 285 | WriteLine('ObjectName: ''* Linker *'''); 286 | end; 287 | EndBlock; 288 | end; 289 | EndBlock; 290 | 291 | BeginBlock('- Kind: S_COMPILE3'); 292 | begin 293 | BeginBlock('Compile3Sym:'); 294 | begin 295 | WriteLine('Machine: X64'); 296 | WriteLine('Version: ''Microsoft (R) LINK'''); 297 | WriteLine('Flags: [ ]'); 298 | WriteLine('FrontendMajor: 0'); 299 | WriteLine('FrontendMinor: 0'); 300 | WriteLine('FrontendBuild: 0'); 301 | WriteLine('FrontendQFE: 0'); 302 | WriteLine('BackendMajor: 12'); 303 | WriteLine('BackendMinor: 0'); 304 | WriteLine('BackendBuild: 31101'); 305 | WriteLine('BackendQFE: 0'); 306 | end; 307 | EndBlock; 308 | end; 309 | EndBlock; 310 | 311 | for var Segment in DebugInfo.Segments do 312 | begin 313 | BeginBlock('- Kind: S_SECTION'); 314 | begin 315 | BeginBlock('SectionSym:'); 316 | begin 317 | WriteLine('SectionNumber: %d', [Segment.Index]); 318 | WriteLine('Rva: %d', [Segment.Offset]); 319 | WriteLine('Alignment: %d', [12]); // Apparently value is power of 2. Eg. 2^12 = 4096 320 | WriteLine('Length: %d', [Segment.Size]); 321 | WriteLine('Characteristics: %d', [$60000020]); // TODO 322 | WriteLine('Name: %s', [Segment.Name]); 323 | end; 324 | EndBlock; 325 | end; 326 | EndBlock; 327 | 328 | BeginBlock('- Kind: S_COFFGROUP'); 329 | begin 330 | BeginBlock('CoffGroupSym:'); 331 | begin 332 | WriteLine('Segment: %d', [Segment.Index]); 333 | WriteLine('Offset: %d', [0]); // Apparently relative to the segment 334 | WriteLine('Size: %d', [Segment.Size]); 335 | WriteLine('Name: %s', [Segment.Name]); 336 | WriteLine('Characteristics: %d', [$60000020]); // TODO 337 | end; 338 | EndBlock; 339 | end; 340 | EndBlock; 341 | end; 342 | end; 343 | EndBlock; 344 | end; 345 | EndBlock; 346 | end; 347 | EndBlock; 348 | 349 | end; 350 | EndBlock; 351 | end; 352 | EndBlock; 353 | 354 | (* 355 | ** Public stream 356 | ** 357 | ** According to the LLVM documentation the Public Stream is part of the DBI stream 358 | ** but llvm-pdbutil pdb2yaml places the PublicsStream section at the outer level, same 359 | ** as the DBI stream. 360 | ** Furthermore llvm-pdbutil yaml2pdb requires the same format but the pdb it produces 361 | ** apparently doesn't contain the Publics Stream, so it doesn't round-trip. 362 | *) 363 | {$ifdef WRITE_PUBLICS} 364 | if (Logging) then 365 | Log('- Symbols'); 366 | 367 | BeginBlock('PublicsStream:'); 368 | begin 369 | BeginBlock('Records:'); 370 | begin 371 | for var Module in DebugInfo.Modules do 372 | begin 373 | // Skip module if it doesn't contain any usable source lines 374 | if (Module.SourceLines.Empty) then 375 | continue; 376 | 377 | // Skip module if it doesn't contain code 378 | if (not (Module.Segment.SegClassType in [sctCODE, sctICODE])) then 379 | continue; 380 | 381 | for var Symbol in Module.Symbols do 382 | begin 383 | // Ignore zero size symbols 384 | if (Symbol.Size = 0) then 385 | continue; 386 | 387 | BeginBlock('- Kind: S_PUB32'); 388 | begin 389 | BeginBlock('PublicSym32:'); 390 | begin 391 | WriteLine('Flags: [ Function ]'); 392 | // var Offset := Symbol.Module.Segment.Offset+Symbol.Module.Offset+Symbol.Offset; 393 | var Offset := Symbol.Module.Offset+Symbol.Offset; 394 | WriteLine('Offset: %0:d # %0:.8X [%1:.8X]', [Offset, Symbol.Offset]); 395 | WriteLine('Segment: %d', [Symbol.Module.Segment.Value]); 396 | WriteLine('Name: ''%s''', [Symbol.Name]); 397 | end; 398 | EndBlock; 399 | end; 400 | EndBlock; 401 | 402 | end; 403 | end; 404 | 405 | end; 406 | EndBlock; 407 | end; 408 | EndBlock; 409 | {$endif WRITE_PUBLICS} 410 | 411 | WriteLine('...'); 412 | 413 | finally 414 | Writer.Free; 415 | end; 416 | end; 417 | 418 | end. 419 | 420 | -------------------------------------------------------------------------------- /Source/debug.info.pdb.bind.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.pdb.bind; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | 15 | procedure PatchPE(const Filename, PdbFilename: string); 16 | 17 | implementation 18 | 19 | uses 20 | System.Classes, 21 | System.SysUtils, 22 | System.Math, 23 | WinApi.Windows, 24 | debug.info.codeview, 25 | debug.info.pdb, 26 | debug.info.log; 27 | 28 | procedure PatchPE(const Filename, PdbFilename: string); 29 | 30 | function AlignTo(Value, Alignment: Cardinal): Cardinal; 31 | begin 32 | // Note: Alignment must be power of 2 33 | Result := (Value + Alignment - 1) and not(Alignment - 1); 34 | end; 35 | 36 | const 37 | sSectionDebug: array[0..IMAGE_SIZEOF_SHORT_NAME-1] of AnsiChar = '.debug'; 38 | begin 39 | var Logger := RegisterDebugInfoModuleLogger('bind'); 40 | Logger.Info('Patching PE file'); 41 | 42 | // Get the PDB filename as UTF-8 43 | var DebugBytes := TEncoding.UTF8.GetBytes(PdbFilename); 44 | 45 | // Calculate size of the CodeView info block, including the filename and terminating zero 46 | var DebugSize: Cardinal := SizeOf(TCodeViewInfoPDB70) + Length(DebugBytes) + 1; 47 | // And the size of the debug section that contains the CodeView block 48 | var DebugSectionSize: Cardinal := DebugSize + SizeOf(TImageDebugDirectory); 49 | 50 | var Stream: TStream := nil; 51 | try 52 | try 53 | 54 | Stream := TFileStream.Create(Filename, fmOpenReadWrite or fmShareExclusive); 55 | 56 | except 57 | on E: EFOpenError do 58 | begin 59 | Logger.Error(E.Message); 60 | Exit; 61 | end; 62 | end; 63 | 64 | (* 65 | ** DOS header 66 | *) 67 | var DosHeader: TImageDosHeader; 68 | Stream.ReadBuffer(DosHeader, SizeOf(DosHeader)); 69 | 70 | if (DosHeader.e_magic <> IMAGE_DOS_SIGNATURE) then 71 | Logger.Error('Invalid DOS file signature'); 72 | 73 | 74 | (* 75 | ** NT header 76 | *) 77 | // The DOS header gives us the offset to the NT header 78 | Stream.Seek(DosHeader._lfanew, soBeginning); 79 | 80 | var Signature: DWORD; 81 | var FileHeader: TImageFileHeader; 82 | Stream.ReadBuffer(Signature, SizeOf(Signature)); 83 | Stream.ReadBuffer(FileHeader, SizeOf(FileHeader)); 84 | 85 | 86 | // After the Signature and FileHeader follows a structure that differs 87 | // between PE32 and PE32+. 88 | // The first Word of the structure tells us what kind it is: Either 89 | // TImageOptionalHeader32 or TImageOptionalHeader64. 90 | // We start by reading the word that tells us what we're dealing with. 91 | var OptionalHeader32: TImageOptionalHeader32; 92 | var OptionalHeader64: TImageOptionalHeader64; 93 | Stream.ReadBuffer(OptionalHeader32.Magic, SizeOf(OptionalHeader32.Magic)); 94 | 95 | 96 | // Then we read the 32-/64-bit part but leave out the data directory at the end. 97 | var PE32Plus := False; 98 | var NumberOfRvaAndSizes: DWORD := 0; 99 | 100 | case OptionalHeader32.Magic of 101 | IMAGE_NT_OPTIONAL_HDR32_MAGIC: 102 | begin 103 | Logger.Info('- PE32 image (32-bit)'); 104 | PE32Plus := False; 105 | 106 | Stream.ReadBuffer(OptionalHeader32.MajorLinkerVersion, 107 | SizeOf(TImageOptionalHeader32)-SizeOf(Word)-SizeOf(OptionalHeader32.DataDirectory)); 108 | 109 | NumberOfRvaAndSizes := OptionalHeader32.NumberOfRvaAndSizes; 110 | // Clear the checksum so file doesn't appear corrupt after we have modified it. 111 | OptionalHeader32.CheckSum := 0; 112 | end; 113 | 114 | IMAGE_NT_OPTIONAL_HDR64_MAGIC: 115 | begin 116 | Logger.Info('- PE32+ image (64-bit)'); 117 | PE32Plus := True; 118 | OptionalHeader64.Magic := OptionalHeader32.Magic; 119 | 120 | Stream.ReadBuffer(OptionalHeader64.MajorLinkerVersion, 121 | SizeOf(TImageOptionalHeader64)-SizeOf(Word)-SizeOf(OptionalHeader64.DataDirectory)); 122 | 123 | NumberOfRvaAndSizes := OptionalHeader64.NumberOfRvaAndSizes; 124 | // Clear the checksum so file doesn't appear corrupt after we have modified it. 125 | OptionalHeader64.CheckSum := 0 126 | end; 127 | else 128 | Logger.Error('Invalid or unsupported PE image type: %.4X', [OptionalHeader32.Magic]); 129 | end; 130 | 131 | 132 | (* 133 | ** Data directory 134 | *) 135 | // The data directory follows and is the same for 32- and 64-bit but the size of it 136 | // is dynamic (contrary to what the header structure suggests). 137 | // Read the data directory but limit the size to something usable (and reasonable). 138 | if (NumberOfRvaAndSizes < IMAGE_DIRECTORY_ENTRY_DEBUG-1) or (NumberOfRvaAndSizes > $100) then 139 | Logger.Error('Invalid or unsupported PE directory size: %d', [NumberOfRvaAndSizes]); 140 | var DataDirectory: TArray; 141 | SetLength(DataDirectory, NumberOfRvaAndSizes); 142 | Stream.ReadBuffer(DataDirectory[0], NumberOfRvaAndSizes * SizeOf(TImageDataDirectory)); 143 | 144 | 145 | (* 146 | ** Section table 147 | *) 148 | // If the directory already contains a pointer to a .debug section, and there's 149 | // enough room in that section, then we will use the section. Otherwise we need 150 | // to add a new section. 151 | var DebugOffset := 0; // File offset of debug data 152 | var DebugVirtualAddress: Cardinal := DataDirectory[IMAGE_DIRECTORY_ENTRY_DEBUG].VirtualAddress; 153 | 154 | // Get all the existing section headers. 155 | var SectionHeaderOffset := Stream.Position; 156 | var SectionHeaders: TArray; 157 | SetLength(SectionHeaders, FileHeader.NumberOfSections); 158 | if (FileHeader.NumberOfSections > 0) then 159 | Stream.ReadBuffer(SectionHeaders[0], FileHeader.NumberOfSections * SizeOf(TImageSectionHeader)); 160 | 161 | var HasDebugSection := False; 162 | var UseExistingDebugSection := False; 163 | 164 | if (DebugVirtualAddress <> 0) and (FileHeader.NumberOfSections > 0) then 165 | begin 166 | 167 | // Iterate the section headers to locate the debug section header. 168 | for var i := 0 to High(SectionHeaders) do 169 | begin 170 | if (DebugVirtualAddress >= SectionHeaders[i].VirtualAddress) and (DebugVirtualAddress < SectionHeaders[i].VirtualAddress+SectionHeaders[i].Misc.VirtualSize) then 171 | begin 172 | // Found it. 173 | 174 | // SectionHeaderOffset now contains the file offset of the section header. 175 | // We will use that when we need to update it later. 176 | 177 | DebugOffset := DebugVirtualAddress - SectionHeaders[i].VirtualAddress + SectionHeaders[i].PointerToRawData; 178 | HasDebugSection := True; 179 | 180 | // Verify that there's room in the section for our debug directory structure 181 | // and the CodeView info. Note the existing directory structure need not be 182 | // at the start of the section and that the section could contain information 183 | // which we do not want to overwrite. 184 | // If there's no room then we overwrite the whole section, so unless the 185 | // section is the .debug section this could really mess things up. 186 | if (SectionHeaders[i].SizeOfRawData >= (DebugVirtualAddress - SectionHeaders[i].VirtualAddress) + DebugSectionSize) then 187 | UseExistingDebugSection := True; 188 | 189 | break; 190 | end; 191 | Inc(SectionHeaderOffset, SizeOf(TImageSectionHeader)); 192 | end; 193 | 194 | // If we didn't find a debug section then the PE is corrupt 195 | if (not HasDebugSection) then 196 | Logger.Error('Failed to locate debug section referenced in PE directory'); 197 | 198 | end else 199 | // There was no existing section entry. 200 | // We will be adding a new one just past the existing section table. 201 | SectionHeaderOffset := Stream.Position; 202 | 203 | // If there was no .debug section or it was too small then we need to 204 | // add a new .debug section. 205 | if (not HasDebugSection) or (not UseExistingDebugSection) then 206 | begin 207 | 208 | if (not HasDebugSection) then 209 | begin 210 | Logger.Info('- Adding .debug section.'); 211 | 212 | if (FileHeader.NumberOfSections > 0) then 213 | begin 214 | // Is there room in the section header list to add an entry? 215 | // The space available is from the current position (end of the existing section list) 216 | // to the first byte of the first section. 217 | if (SectionHeaders[0].PointerToRawData - SectionHeaderOffset < SizeOf(TImageSectionHeader)) then 218 | Logger.Error('There is no room left for an additional section header. Expansion has not been implemented'); 219 | end; 220 | 221 | // We will be adding the debug data to the end of the file. 222 | DebugOffset := Stream.Size; 223 | 224 | // Add a new section header 225 | Inc(FileHeader.NumberOfSections); 226 | 227 | // When we add a new section we also need to update the image size 228 | if (PE32Plus) then 229 | Inc(OptionalHeader64.SizeOfImage, AlignTo(DebugSectionSize, OptionalHeader64.SectionAlignment)) 230 | else 231 | Inc(OptionalHeader32.SizeOfImage, AlignTo(DebugSectionSize, OptionalHeader32.SectionAlignment)); 232 | end else 233 | Logger.Info('- Updating existing .debug section.'); 234 | 235 | var SectionHeader := Default(TImageSectionHeader); 236 | // Name: An 8-byte, null-padded UTF-8 encoded string. If the string is exactly 8 characters 237 | // long, there is no terminating null. 238 | Move(sSectionDebug, SectionHeader.Name, SizeOf (SectionHeader.Name)); 239 | 240 | // VirtualAddress: For executable images, the address of the first byte of the section 241 | // relative to the image base when the section is loaded into memory. 242 | // The VirtualAddress of our new section is located after the last of the existing sections 243 | // and must be aligned. 244 | for var i := 0 to High(SectionHeaders) do 245 | SectionHeader.VirtualAddress := Max(SectionHeader.VirtualAddress, SectionHeaders[i].VirtualAddress + SectionHeaders[i].Misc.VirtualSize); 246 | if (PE32Plus) then 247 | SectionHeader.VirtualAddress := AlignTo(SectionHeader.VirtualAddress, OptionalHeader64.SectionAlignment) 248 | else 249 | SectionHeader.VirtualAddress := AlignTo(SectionHeader.VirtualAddress, OptionalHeader32.SectionAlignment); 250 | // SizeOfRawData: The size of the initialized data on disk. For executable images, this must 251 | // be a multiple of FileAlignment from the optional header. If this is less than VirtualSize, 252 | // the remainder of the section is zero-filled. Because the SizeOfRawData field is rounded 253 | // but the VirtualSize field is not, it is possible for SizeOfRawData to be greater than 254 | // VirtualSize as well. 255 | SectionHeader.SizeOfRawData := DebugSectionSize; // Loader doesn't seem to care about aligment, so we don't either 256 | // VirtualSize: The total size of the section when loaded into memory. If this value is greater 257 | // than SizeOfRawData, the section is zero-padded. 258 | SectionHeader.Misc.VirtualSize := DebugSectionSize; 259 | // PointerToRawData: The file pointer to the first page of the section within the COFF file. 260 | // For executable images, this must be a multiple of FileAlignment from the optional header. 261 | // When a section contains only uninitialized data, this field should be zero. 262 | // Offset in file of section data (i.e. debug directory) 263 | SectionHeader.PointerToRawData := DebugOffset; // Unaligned; The loader doesn't care 264 | // Characteristics: The flags that describe the characteristics of the section. 265 | SectionHeader.Characteristics := IMAGE_SCN_CNT_INITIALIZED_DATA or IMAGE_SCN_MEM_READ or IMAGE_SCN_MEM_DISCARDABLE; 266 | 267 | DebugVirtualAddress := SectionHeader.VirtualAddress; 268 | 269 | // Update the existing section header or write a new one. 270 | Stream.Position := SectionHeaderOffset; 271 | Stream.WriteBuffer(SectionHeader, SizeOf(SectionHeader)); 272 | end; 273 | 274 | 275 | // Update data directory 276 | DataDirectory[IMAGE_DIRECTORY_ENTRY_DEBUG].VirtualAddress := DebugVirtualAddress; 277 | DataDirectory[IMAGE_DIRECTORY_ENTRY_DEBUG].Size := SizeOf(TImageDebugDirectory); // Just a single entry 278 | 279 | 280 | (* 281 | ** Debug directory 282 | *) 283 | Stream.Seek(DebugOffset, soBeginning); 284 | 285 | // We overwrite any existing entries there might be in the debug directory and replace it all with our own. 286 | { 287 | MSDN: Each debug directory entry identifies the location and size of a block of debug information. 288 | The specified RVA can be zero if the debug information is not covered by a section header (that is, 289 | it resides in the image file and is not mapped into the run-time address space). If it is mapped, 290 | the RVA is its address. 291 | } 292 | var DebugDirectory := Default(TImageDebugDirectory); 293 | // Type: The format of debugging information. 294 | DebugDirectory._Type := IMAGE_DEBUG_TYPE_CODEVIEW; 295 | // SizeOfData: The size of the debug data (not including the debug 296 | // directory itself). 297 | DebugDirectory.SizeOfData := DebugSize; 298 | // AddressOfRawData: The address of the debug data when loaded, relative 299 | // to the image base. 300 | DebugDirectory.AddressOfRawData := DebugVirtualAddress + SizeOf(DebugDirectory); 301 | // PointerToRawData: The file pointer to the debug data. 302 | DebugDirectory.PointerToRawData := Stream.Position + SizeOf(TImageDebugDirectory); 303 | Stream.WriteBuffer(DebugDirectory, SizeOf(DebugDirectory)); 304 | 305 | (* 306 | ** Debug data 307 | *) 308 | // Populate and write a CV_INFO_PDB70 block 309 | var CodeViewInfoPDB := Default(TCodeViewInfoPDB70); 310 | CodeViewInfoPDB.CvSignature := $53445352; // RSDS 311 | CodeViewInfoPDB.Signature := PdbBuildSignature; // GUID - must be the same as the one in the PDB 312 | CodeViewInfoPDB.Age := PdbBuildAge; // Generation counter - must be same value as the one in the PDB 313 | Stream.WriteBuffer(CodeViewInfoPDB, SizeOf(CodeViewInfoPDB)); 314 | Stream.WriteData(DebugBytes, Length(DebugBytes)); 315 | const Zero: Byte = 0; 316 | Stream.WriteBuffer(Zero, 1); 317 | Logger.Info('- PDB file name has been stored in debug data.'); 318 | 319 | 320 | // Write updated headers... 321 | Stream.Seek(DosHeader._lfanew + SizeOf(Signature), soBeginning); 322 | 323 | Stream.WriteBuffer(FileHeader, SizeOf(FileHeader)); 324 | 325 | if (PE32Plus) then 326 | Stream.WriteBuffer(OptionalHeader64, SizeOf(TImageOptionalHeader64)-SizeOf(OptionalHeader64.DataDirectory)) 327 | else 328 | Stream.WriteBuffer(OptionalHeader32, SizeOf(TImageOptionalHeader32)-SizeOf(OptionalHeader32.DataDirectory)); 329 | 330 | // ...and the data directory 331 | Stream.WriteBuffer(DataDirectory[0], NumberOfRvaAndSizes * SizeOf(TImageDataDirectory)); 332 | Logger.Info('- PE file has been updated.'); 333 | 334 | 335 | // TODO : Clear certificate if PE has one. Our modification renders the certificate invalid anyway. 336 | 337 | finally 338 | Stream.Free; 339 | end; 340 | end; 341 | 342 | end. 343 | 344 | -------------------------------------------------------------------------------- /Source/debug.info.reader.jdbg.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.reader.jdbg; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | 15 | uses 16 | Generics.Collections, 17 | System.Classes, 18 | debug.info, 19 | debug.info.reader; 20 | 21 | type 22 | TJDBGHeader = packed record 23 | Signature: Cardinal; 24 | Version: Byte; 25 | Units: Integer; 26 | SourceNames: Integer; 27 | Symbols: Integer; 28 | LineNumbers: Integer; 29 | Words: Integer; 30 | ModuleName: Integer; 31 | CheckSum: Integer; 32 | CheckSumValid: Boolean; 33 | end; 34 | PJDBGHeader = ^TJDBGHeader; 35 | 36 | // ----------------------------------------------------------------------------- 37 | // 38 | // TDebugInfoJdbgReader 39 | // 40 | // ----------------------------------------------------------------------------- 41 | // Debug info reader for JDBG files 42 | // ----------------------------------------------------------------------------- 43 | type 44 | TDebugInfoJdbgReader = class(TDebugInfoReader) 45 | strict private type 46 | TSourceFragment = record 47 | SourceFile: TDebugInfoSourceFile; 48 | StartOffset: TDebugInfoOffset; 49 | EndOffset: TDebugInfoOffset; 50 | end; 51 | 52 | strict private 53 | FSourceFragments: TList; 54 | private 55 | class function ReadString(const Header: PJDBGHeader; Offset: Cardinal): string; static; 56 | 57 | procedure LoadModules(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 58 | procedure LoadSourceFiles(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 59 | procedure LoadLineNumbers(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 60 | procedure LoadSymbols(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 61 | 62 | procedure LoadDebugInfo(DebugInfo: TDebugInfo; Stream: TMemoryStream); 63 | protected 64 | public 65 | procedure LoadFromStream(Stream: TStream; DebugInfo: TDebugInfo); override; 66 | end; 67 | 68 | 69 | // ----------------------------------------------------------------------------- 70 | // ----------------------------------------------------------------------------- 71 | // ----------------------------------------------------------------------------- 72 | 73 | implementation 74 | 75 | uses 76 | Generics.Defaults, 77 | System.Math, 78 | System.SysUtils, 79 | debug.info.reader.map; 80 | 81 | 82 | // JCL binary debug format string encoding/decoding routines 83 | { Strings are compressed to following 6bit format (A..D represents characters) and terminated with } 84 | { 6bit #0 char. First char = #1 indicates non compressed text, #2 indicates compressed text with } 85 | { leading '@' character } 86 | { } 87 | { 7 6 5 4 3 2 1 0 | } 88 | {--------------------------------- } 89 | { B1 B0 A5 A4 A3 A2 A1 A0 | Data byte 0 } 90 | {--------------------------------- } 91 | { C3 C2 C1 C0 B5 B4 B3 B2 | Data byte 1 } 92 | {--------------------------------- } 93 | { D5 D4 D3 D2 D1 D0 C5 C4 | Data byte 2 } 94 | {--------------------------------- } 95 | 96 | function SimpleCryptString(const S: UTF8String): UTF8String; 97 | var 98 | I: Integer; 99 | C: Byte; 100 | P: PByte; 101 | begin 102 | SetLength(Result, Length(S)); 103 | P := PByte(Result); 104 | for I := 1 to Length(S) do 105 | begin 106 | C := Ord(S[I]); 107 | if C <> $AA then 108 | C := C xor $AA; 109 | P^ := C; 110 | Inc(P); 111 | end; 112 | end; 113 | 114 | // ----------------------------------------------------------------------------- 115 | 116 | function DecodeNameString(const S: PAnsiChar): string; 117 | var 118 | I, B: Integer; 119 | C: Byte; 120 | P: PByte; 121 | Buffer: array [0..255] of AnsiChar; 122 | begin 123 | Result := ''; 124 | B := 0; 125 | P := PByte(S); 126 | case P^ of 127 | 1: 128 | begin 129 | Inc(P); 130 | Result := string(SimpleCryptString(PAnsiChar(P))); 131 | Exit; 132 | end; 133 | 2: 134 | begin 135 | Inc(P); 136 | Buffer[B] := '@'; 137 | Inc(B); 138 | end; 139 | end; 140 | I := 0; 141 | C := 0; 142 | repeat 143 | case I and $03 of 144 | 0: 145 | C := P^ and $3F; 146 | 1: 147 | begin 148 | C := (P^ shr 6) and $03; 149 | Inc(P); 150 | Inc(C, (P^ and $0F) shl 2); 151 | end; 152 | 2: 153 | begin 154 | C := (P^ shr 4) and $0F; 155 | Inc(P); 156 | Inc(C, (P^ and $03) shl 4); 157 | end; 158 | 3: 159 | begin 160 | C := (P^ shr 2) and $3F; 161 | Inc(P); 162 | end; 163 | end; 164 | case C of 165 | $00: 166 | Break; 167 | $01..$0A: 168 | Inc(C, Ord('0') - $01); 169 | $0B..$24: 170 | Inc(C, Ord('A') - $0B); 171 | $25..$3E: 172 | Inc(C, Ord('a') - $25); 173 | $3F: 174 | C := Ord('_'); 175 | end; 176 | Buffer[B] := AnsiChar(C); 177 | Inc(B); 178 | Inc(I); 179 | until B >= SizeOf(Buffer) - 1; 180 | Buffer[B] := #0; 181 | Result := UTF8ToString(@Buffer[0]); 182 | end; 183 | 184 | // ----------------------------------------------------------------------------- 185 | 186 | function ReadValue(var P: Pointer; var Value: Integer): Boolean; 187 | var 188 | N: Integer; 189 | I: Integer; 190 | B: Byte; 191 | begin 192 | N := 0; 193 | I := 0; 194 | repeat 195 | B := PByte(P)^; 196 | Inc(PByte(P)); 197 | Inc(N, (B and $7F) shl I); 198 | Inc(I, 7); 199 | until B and $80 = 0; 200 | Value := N; 201 | Result := (N <> MaxInt); 202 | end; 203 | 204 | 205 | // ----------------------------------------------------------------------------- 206 | // 207 | // TDebugInfoJdbgReader 208 | // 209 | // ----------------------------------------------------------------------------- 210 | class function TDebugInfoJdbgReader.ReadString(const Header: PJDBGHeader; Offset: Cardinal): string; 211 | begin 212 | if (Offset = 0) then 213 | Result := '' 214 | else 215 | begin 216 | var p := PAnsiChar(PByte(Header) + Header.Words + Offset - 1); 217 | Result := DecodeNameString(p); 218 | end; 219 | end; 220 | 221 | // ----------------------------------------------------------------------------- 222 | 223 | procedure TDebugInfoJdbgReader.LoadFromStream(Stream: TStream; DebugInfo: TDebugInfo); 224 | begin 225 | Logger.Info('Reading JDBG file'); 226 | 227 | var OwnedStream: TMemoryStream := nil; 228 | try 229 | 230 | var MemoryStream: TMemoryStream; 231 | 232 | if (not (Stream is TMemoryStream)) or (Stream.Position <> 0) then 233 | begin 234 | OwnedStream := TMemoryStream.Create; 235 | MemoryStream := OwnedStream; 236 | 237 | MemoryStream.CopyFrom(Stream, Stream.Size - Stream.Position); // Specify size so we can support loading from Pos>0 238 | MemoryStream.Position := 0; 239 | end else 240 | MemoryStream := TMemoryStream(Stream); 241 | 242 | LoadDebugInfo(DebugInfo, MemoryStream); 243 | 244 | finally 245 | OwnedStream.Free; 246 | end; 247 | end; 248 | 249 | // ----------------------------------------------------------------------------- 250 | 251 | procedure TDebugInfoJdbgReader.LoadModules(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 252 | begin 253 | Logger.Info('- Modules'); 254 | 255 | var Offset: TDebugInfoOffset := 0; 256 | var NameOffset: integer := 0; 257 | var i := 0; 258 | 259 | var Data: pointer := PByte(Header) + Header.Units; 260 | 261 | var Size: integer; 262 | var DoContinue := ReadValue(Data, Size); 263 | while DoContinue do 264 | begin 265 | Inc(i); 266 | Inc(Offset, Size); 267 | 268 | var NameDelta: integer; 269 | ReadValue(Data, NameDelta); 270 | Inc(NameOffset, NameDelta); 271 | 272 | var Name := ReadString(Header, NameOffset); 273 | 274 | // Get the offset to the next module. This gives us the size of this one. 275 | DoContinue := ReadValue(Data, Size); 276 | 277 | Logger.Debug(' Module[%6d]: %.8X (Size:%.4X) %s', [i, Offset, Size, Name]); 278 | 279 | if (not DoContinue) and (Size = MaxInt) then 280 | Logger.Warning('[%6d] Filler module skipped: %s at %.8X', [i, Name, Offset]) 281 | else 282 | if (Size > 0) then 283 | begin 284 | // Look for existing module 285 | var Module := DebugInfo.Modules.FindOverlap(Segment, Offset, Size); 286 | if (Module <> nil) then 287 | Logger.Error('[%6d] Modules overlap: %s and %s', [i, Module.Name, Name]); 288 | 289 | DebugInfo.Modules.Add(Name, Segment, Offset, Size); 290 | end else 291 | Logger.Warning('[%6d] Empty module skipped: %s at %.8X', [i, Name, Offset]); 292 | 293 | end; 294 | end; 295 | 296 | // ----------------------------------------------------------------------------- 297 | 298 | procedure TDebugInfoJdbgReader.LoadSourceFiles(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 299 | begin 300 | Logger.Info('- Source files'); 301 | 302 | var Offset: TDebugInfoOffset := 0; 303 | var NameOffset: integer := 0; 304 | var i := 0; 305 | 306 | var Data: pointer := PByte(Header) + Header.SourceNames; 307 | 308 | var Size: integer; 309 | var DoContinue := ReadValue(Data, Size); 310 | while DoContinue do 311 | begin 312 | Inc(i); 313 | Inc(Offset, Size); 314 | 315 | var NameDelta: integer; 316 | ReadValue(Data, NameDelta); 317 | Inc(NameOffset, NameDelta); 318 | 319 | var Name := ReadString(Header, NameOffset); 320 | 321 | // Get the offset to the next module. This gives us the size of this one. 322 | DoContinue := ReadValue(Data, Size); 323 | 324 | var Module := DebugInfo.Modules.FindByOffset(Segment, Offset); 325 | 326 | if (Module <> nil) then 327 | begin 328 | Logger.Debug(' Source[%6d]: %.8X (Size:%.4X) %s, Module: %s', [i, Offset, Size, Name, Module.Name]); 329 | 330 | if (Size > 0) then 331 | begin 332 | var FragmentSize := Size; 333 | if (Offset+Cardinal(FragmentSize) > Module.Offset+Module.Size) then 334 | begin 335 | FragmentSize := Module.Offset+Module.Size - Offset; 336 | // This problem is so common that we're logging it at debug level instead of warning level 337 | Logger.Debug('[%6d] Source fragment at %.8X (Size:%.4X) exceeds module %s at %.8X (Size:%.4X) for source file %s. Truncated to %.4X', [i, Offset, Size, Module.Name, Module.Offset, Module.Size, Name, FragmentSize]); 338 | end; 339 | 340 | var SourceFile := Module.SourceFiles.Add(Name); 341 | 342 | var SourceFragment: TSourceFragment; 343 | SourceFragment.SourceFile := SourceFile; 344 | // Offset is not relative to module because we need later on to 345 | // map line numbers (which are read with absolute offset) to 346 | // source files. 347 | SourceFragment.StartOffset := Offset; 348 | SourceFragment.EndOffset := Offset+Cardinal(FragmentSize)-1; 349 | FSourceFragments.Add(SourceFragment); 350 | end else 351 | Logger.Warning('[%6d] Zero size source file ignored: %s at %.8X', [i, Name, Offset, Name]); 352 | 353 | end else 354 | Logger.Warning('[%6d] Module not found at offset %.8X for source file: %s', [i, Offset, Name]); 355 | 356 | end; 357 | 358 | // Sort source fragments by offset. 359 | // We will use them later to map line number by offset to source file 360 | FSourceFragments.Sort( 361 | IComparer( 362 | function(const Left, Right: TSourceFragment): Integer 363 | begin 364 | Result := integer(Left.StartOffset) - integer(Right.StartOffset); 365 | Assert((Result <> 0) or (Left.SourceFile = Right.SourceFile)); 366 | end)); 367 | 368 | // Check for duplicate or overlapping fragments 369 | var PreviousSourceFragment: TSourceFragment := Default(TSourceFragment); 370 | var First := True; 371 | for var SourceFragmentX in FSourceFragments do 372 | begin 373 | if (not First) then 374 | begin 375 | if (SourceFragmentX.StartOffset <= PreviousSourceFragment.EndOffset) then 376 | Logger.Warning('Overlapping source file fragments: %s at %.8X-%.8X and %s at %.8X-%.8X', 377 | [SourceFragmentX.SourceFile.Filename, SourceFragmentX.StartOffset, SourceFragmentX.EndOffset, 378 | PreviousSourceFragment.SourceFile.Filename, PreviousSourceFragment.StartOffset, PreviousSourceFragment.EndOffset]); 379 | end; 380 | 381 | PreviousSourceFragment := SourceFragmentX; 382 | First := False; 383 | end; 384 | end; 385 | 386 | // ----------------------------------------------------------------------------- 387 | 388 | procedure TDebugInfoJdbgReader.LoadLineNumbers(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 389 | begin 390 | Logger.Info('- Line numbers'); 391 | 392 | var Offset: TDebugInfoOffset := 0; 393 | var LineNumber: integer := 0; 394 | var i := 0; 395 | 396 | var Data: pointer := PByte(Header) + Header.LineNumbers; 397 | 398 | var Delta: integer; 399 | var DoContinue := ReadValue(Data, Delta); 400 | while DoContinue do 401 | begin 402 | Inc(i); 403 | Inc(Offset, Delta); 404 | 405 | var LineDelta: integer; 406 | ReadValue(Data, LineDelta); 407 | Inc(LineNumber, LineDelta); 408 | 409 | DoContinue := ReadValue(Data, Delta); 410 | 411 | var Module := DebugInfo.Modules.FindByOffset(Segment, Offset); 412 | if (Module <> nil) then 413 | begin 414 | // Find the source file from the offset 415 | var SourceFile: TDebugInfoSourceFile := nil; 416 | // Binary search 417 | var L := 0; 418 | var H := FSourceFragments.Count-1; 419 | 420 | while (L <= H) and (SourceFile = nil) do 421 | begin 422 | var mid := L + (H - L) shr 1; 423 | 424 | var SourceFragment := FSourceFragments[mid]; 425 | 426 | if (Offset < SourceFragment.StartOffset) then 427 | H := mid - 1 428 | else 429 | if (Offset > SourceFragment.EndOffset) then 430 | L := mid + 1 431 | else 432 | SourceFile := SourceFragment.SourceFile; 433 | end; 434 | 435 | if (SourceFile <> nil) then 436 | begin 437 | Logger.Debug(' Line number[%6d]: %6d at %.8X, Module/source: %s(%s)', [i, LineNumber, Offset, Module.Name, SourceFile.Filename]); 438 | 439 | if (Module.SourceFiles.Contains(SourceFile)) then 440 | begin 441 | // Offset is relative to segment. Make it relative to module 442 | var RelativeOffset := Offset - Module.Offset; 443 | Module.SourceLines.Add(SourceFile, LineNumber, RelativeOffset); 444 | end else 445 | Logger.Warning('[%6d] Module and source file mismatched for line number %d at %8X. Module: %s, Source: %s ', [i, LineNumber, Offset, Module.Name, SourceFile.Filename]); 446 | end else 447 | Logger.Warning('[%6d] Failed to locate source file for line number %d at %.8X, module: %s', [i, LineNumber, Offset, Module.Name]); 448 | end else 449 | Logger.Warning('[%6d] Failed to locate module for line number %d at %.8X', [i, LineNumber, Offset]); 450 | end; 451 | end; 452 | 453 | // ----------------------------------------------------------------------------- 454 | 455 | procedure TDebugInfoJdbgReader.LoadSymbols(const Header: PJDBGHeader; DebugInfo: TDebugInfo; Segment: TDebugInfoSegment); 456 | begin 457 | Logger.Info('- Symbols'); 458 | 459 | var Offset: TDebugInfoOffset := 0; 460 | var FirstWordOffset: integer := 0; 461 | var SecondWordOffset: integer := 0; 462 | var i := 0; 463 | 464 | var Data: pointer := PByte(Header) + Header.Symbols; 465 | 466 | var Delta: integer; 467 | var DoContinue := ReadValue(Data, Delta); 468 | while DoContinue do 469 | begin 470 | Inc(i); 471 | Inc(Offset, Delta); 472 | 473 | var NameDelta: integer; 474 | ReadValue(Data, NameDelta); 475 | Inc(FirstWordOffset, NameDelta); 476 | ReadValue(Data, NameDelta); 477 | Inc(SecondWordOffset, NameDelta); 478 | 479 | var Name := ReadString(Header, FirstWordOffset); 480 | if (SecondWordOffset <> 0) then 481 | Name := Name + '.' + ReadString(Header, SecondWordOffset); 482 | 483 | // Get the offset to the next symbol. This gives us the size of this one. 484 | DoContinue := ReadValue(Data, Delta); 485 | Assert(Delta >= 0, 'Symbol with negative size'); 486 | 487 | var Module := DebugInfo.Modules.FindByOffset(Segment, Offset); 488 | if (Module <> nil) then 489 | begin 490 | Name := DemangleMapSymbol(Module, Name); 491 | Logger.Debug(' Symbol[%6d]: %.8X (%.4X) %s, Module: %s', [i, Offset, Delta, Name, Module.Name]); 492 | 493 | // Offset is relative to segment. Make it relative to module 494 | var RelativeOffset := Offset - Module.Offset; 495 | var Symbol := Module.Symbols.Add(Name, RelativeOffset); 496 | if (Symbol <> nil) then 497 | begin 498 | // This problem is so common that we're logging it at debug level instead of warning level 499 | var SymbolSize := Delta; 500 | if (Symbol.Offset + Cardinal(Delta) > Module.Size) then 501 | begin 502 | SymbolSize := Module.Size - Symbol.Offset; 503 | Logger.Debug('[%6d] Symbol %s at %.8X (Size:%.4X) exceeds module %s at %.8X (Size:%.4X). Truncated to %.4X', [i, Name, Offset, Delta, Module.Name, Module.Offset, Module.Size, SymbolSize]); 504 | end; 505 | 506 | // We assume that symbols are ordered by offset. Otherwise the size will be wrong. 507 | Symbol.Size := SymbolSize; 508 | end else 509 | Logger.Warning('[%6d] Symbol with duplicate offset ignored: [%.8X] %s', [i, Offset, Name]); 510 | 511 | end else 512 | Logger.Warning('[%6d] Failed to locate module for symbol %s at %.8X', [i, Name, Offset]); 513 | end; 514 | end; 515 | 516 | // ----------------------------------------------------------------------------- 517 | 518 | procedure TDebugInfoJdbgReader.LoadDebugInfo(DebugInfo: TDebugInfo; Stream: TMemoryStream); 519 | begin 520 | Logger.Debug('- Synthesizing .text segment'); 521 | var Segment := DebugInfo.Segments.Add(1, '.text', sctCODE); 522 | Segment.Offset := $00000000; 523 | Segment.Size := 0; 524 | 525 | FSourceFragments := TList.Create; 526 | try 527 | var Header := PJDBGHeader(Stream.Memory); 528 | 529 | LoadModules(Header, DebugInfo, Segment); 530 | LoadSourceFiles(Header, DebugInfo, Segment); 531 | LoadLineNumbers(Header, DebugInfo, Segment); 532 | LoadSymbols(Header, DebugInfo, Segment); 533 | 534 | finally 535 | FSourceFragments.Free; 536 | end; 537 | 538 | // Determine max size of segment 539 | var MaxSegmentSize := Segment.Size; 540 | for var Module in DebugInfo.Modules do 541 | begin 542 | // Determine max size of module 543 | Module.CalculateSize; 544 | 545 | MaxSegmentSize := Max(MaxSegmentSize, Module.Offset + Module.Size); 546 | end; 547 | Segment.Size := MaxSegmentSize; 548 | end; 549 | 550 | 551 | // ----------------------------------------------------------------------------- 552 | // ----------------------------------------------------------------------------- 553 | // ----------------------------------------------------------------------------- 554 | 555 | end. 556 | 557 | -------------------------------------------------------------------------------- /Source/debug.info.pas: -------------------------------------------------------------------------------- 1 | unit debug.info; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | 15 | uses 16 | System.Generics.Collections, 17 | System.Generics.Defaults, 18 | System.SysUtils; 19 | 20 | type 21 | TDebugInfoOffset = UInt64; 22 | 23 | type 24 | TDebugInfo = class; 25 | TDebugInfoModule = class; 26 | 27 | 28 | TDebugInfoSegmentClass = ( 29 | sctCODE, // Code 30 | sctICODE, // Initialization code 31 | sctDATA, // Data 32 | sctIDATA, // Import data 33 | sctEDATA, // Export data 34 | sctRSRC, // Resource data 35 | sctTLS, // Thread Local Storage data 36 | sctDEBUG // Debug data 37 | ); 38 | TDebugInfoSegmentClasses = set of TDebugInfoSegmentClass; 39 | // 40 | // The predefined sections are: 41 | // .text, .bss, .rdata, .data, .rsrc, .edata, .idata, .pdata and .debug 42 | // The names however are not significant. 43 | // 44 | 45 | TDebugInfoSegments = class; 46 | 47 | TDebugInfoSegment = class 48 | private 49 | FOwner: TDebugInfoSegments; 50 | FSegClassType: TDebugInfoSegmentClass; 51 | FName: string; 52 | FOffset: TDebugInfoOffset; 53 | FSize: TDebugInfoOffset; 54 | FIndex: Cardinal; 55 | FCharacteristics: Cardinal; 56 | FSegClassName: string; 57 | private 58 | procedure CheckOverlap; 59 | protected 60 | procedure SetOffset(const Value: TDebugInfoOffset); 61 | procedure SetSize(const Value: TDebugInfoOffset); 62 | public 63 | constructor Create(AOwner: TDebugInfoSegments; AIndex: Cardinal; const AName: string; AClassType: TDebugInfoSegmentClass = sctDATA); overload; 64 | 65 | class function GuessClassType(const AName: string): TDebugInfoSegmentClass; 66 | 67 | function FindOverlap(AIgnoredClassTypes: TDebugInfoSegmentClasses = []): TDebugInfoSegment; 68 | 69 | property Index: Cardinal read FIndex; // 1 based value 70 | property SegClassType: TDebugInfoSegmentClass read FSegClassType; 71 | property Name: string read FName write FName; 72 | property Offset: TDebugInfoOffset read FOffset write SetOffset; 73 | property Size: TDebugInfoOffset read FSize write SetSize; 74 | property Characteristics: Cardinal read FCharacteristics write FCharacteristics; // TODO 75 | // Class name as specified in map file. Might not correspond to SegClassType. 76 | property SegClassName: string read FSegClassName write FSegClassName; 77 | end; 78 | 79 | TDebugInfoSegments = class 80 | private 81 | FSegments: TDictionary; 82 | FNames: TDictionary; 83 | FOrdered: TList; // Segments ordered by Segment.Index 84 | protected 85 | function GetCount: integer; 86 | function GetSegment(AIndex: Cardinal): TDebugInfoSegment; 87 | public 88 | constructor Create; 89 | destructor Destroy; override; 90 | 91 | function Add(AIndex: Cardinal; const AName: string; AClassType: TDebugInfoSegmentClass = sctDATA): TDebugInfoSegment; 92 | function FindByIndex(AIndex: Cardinal): TDebugInfoSegment; 93 | function FindByName(const AName: string): TDebugInfoSegment; 94 | function FindByOffset(AOffset: TDebugInfoOffset): TDebugInfoSegment; 95 | function FindByClassName(const AClassName: string): TDebugInfoSegment; 96 | 97 | property Count: integer read GetCount; 98 | property Segments[Index: Cardinal]: TDebugInfoSegment read GetSegment; default; 99 | 100 | // The enumerator is guaranteed to return the segments in index order 101 | function GetEnumerator: TEnumerator; 102 | end; 103 | 104 | 105 | TDebugInfoSourceFile = class 106 | private 107 | FFilename: string; 108 | public 109 | constructor Create(const AFilename: string); 110 | 111 | property Filename: string read FFilename; 112 | end; 113 | 114 | TDebugInfoSourceFiles = class 115 | private type 116 | TDebugInfoSourceFileList = TObjectDictionary; 117 | private 118 | FSourceFiles: TDebugInfoSourceFileList; 119 | FOwner: TDebugInfo; 120 | protected 121 | function GetCount: integer; 122 | public 123 | constructor Create(AOwner: TDebugInfo = nil); 124 | destructor Destroy; override; 125 | 126 | function Add(const AFilename: string): TDebugInfoSourceFile; 127 | function First: TDebugInfoSourceFile; 128 | function Contains(SourceFile: TDebugInfoSourceFile): boolean; // Expensive! 129 | 130 | property Count: integer read GetCount; 131 | 132 | function GetEnumerator: TEnumerator; 133 | end; 134 | 135 | 136 | TDebugInfoSourceLine = class 137 | private 138 | FSourceFile: TDebugInfoSourceFile; 139 | FModule: TDebugInfoModule; 140 | FLineNumber: integer; 141 | FOffset: TDebugInfoOffset; 142 | protected 143 | function GetAddress: TDebugInfoOffset; 144 | public 145 | property Module: TDebugInfoModule read FModule write FModule; 146 | property SourceFile: TDebugInfoSourceFile read FSourceFile write FSourceFile; 147 | property LineNumber: integer read FLineNumber write FLineNumber; 148 | // Offset is relative to module 149 | property Offset: TDebugInfoOffset read FOffset write FOffset; 150 | 151 | // Address = Line.Offset + Line.Module.Offset + Line.Module.Segment.Offset 152 | property Address: TDebugInfoOffset read GetAddress; 153 | end; 154 | 155 | TDebugInfoSourceLines = class 156 | private 157 | FModule: TDebugInfoModule; 158 | FSourceLines: TObjectList; 159 | FComparer: IComparer; 160 | protected 161 | function GetCount: integer; 162 | function GetEmpty: boolean; 163 | public 164 | constructor Create(AModule: TDebugInfoModule); 165 | destructor Destroy; override; 166 | 167 | function Add(ASourceFile: TDebugInfoSourceFile; ALineNumber: integer; AOffset: TDebugInfoOffset): TDebugInfoSourceLine; 168 | 169 | property Count: integer read GetCount; 170 | property Empty: boolean read GetEmpty; 171 | 172 | function GetEnumerator: TEnumerator; 173 | end; 174 | 175 | 176 | TDebugInfoSymbol = class 177 | private 178 | FModule: TDebugInfoModule; 179 | FName: string; 180 | FOffset: TDebugInfoOffset; 181 | FSize: TDebugInfoOffset; 182 | protected 183 | function GetAddress: TDebugInfoOffset; 184 | public 185 | constructor Create(AModule: TDebugInfoModule; const AName: string; AOffset: TDebugInfoOffset); 186 | 187 | property Module: TDebugInfoModule read FModule write FModule; 188 | property Name: string read FName write FName; 189 | // Offset is relative to module 190 | property Offset: TDebugInfoOffset read FOffset; 191 | property Size: TDebugInfoOffset read FSize write FSize; 192 | 193 | // Address = Symbol.Offset + Symbol.Module.Offset + Symbol.Module.Segment.Offset 194 | property Address: TDebugInfoOffset read GetAddress; 195 | end; 196 | 197 | TDebugInfoSymbols = class 198 | private type 199 | TDebugInfoSymbolList = TObjectList; 200 | private 201 | FModule: TDebugInfoModule; 202 | FSymbols: TDebugInfoSymbolList; 203 | protected 204 | function GetCount: integer; 205 | public 206 | constructor Create(AModule: TDebugInfoModule); 207 | destructor Destroy; override; 208 | 209 | function Add(const AName: string; AOffset: TDebugInfoOffset): TDebugInfoSymbol; 210 | 211 | procedure CalculateSizes; 212 | 213 | property Count: integer read GetCount; 214 | 215 | function GetEnumerator: TEnumerator; 216 | end; 217 | 218 | 219 | TDebugInfoModule = class 220 | private 221 | FDebugInfo: TDebugInfo; 222 | FName: string; 223 | FObjectName: string; 224 | FSegment: TDebugInfoSegment; 225 | FOffset: TDebugInfoOffset; 226 | FSize: TDebugInfoOffset; 227 | FSourceFiles: TDebugInfoSourceFiles; 228 | FSourceLines: TDebugInfoSourceLines; 229 | FSymbols: TDebugInfoSymbols; 230 | protected 231 | function GetObjectName: string; 232 | function GetAddress: TDebugInfoOffset; 233 | public 234 | constructor Create(ADebugInfo: TDebugInfo; const AName: string; ASegment: TDebugInfoSegment; AOffset, ASize: TDebugInfoOffset); 235 | destructor Destroy; override; 236 | 237 | procedure CalculateSize; 238 | 239 | property DebugInfo: TDebugInfo read FDebugInfo; 240 | 241 | property Name: string read FName; 242 | property ObjectName: string read GetObjectName write FObjectName; 243 | property Segment: TDebugInfoSegment read FSegment; 244 | // Offset is relative to segment 245 | property Offset: TDebugInfoOffset read FOffset; 246 | property Size: TDebugInfoOffset read FSize; 247 | 248 | // Address = Module.Offset + Module.Segment.Offset 249 | property Address: TDebugInfoOffset read GetAddress; 250 | 251 | property SourceFiles: TDebugInfoSourceFiles read FSourceFiles; 252 | property SourceLines: TDebugInfoSourceLines read FSourceLines; 253 | property Symbols: TDebugInfoSymbols read FSymbols; 254 | end; 255 | 256 | TDebugInfoModules = class 257 | private type 258 | TDebugInfoModuleList = TObjectList; 259 | private 260 | FDebugInfo: TDebugInfo; 261 | FModules: TDebugInfoModuleList; 262 | FComparer: IComparer; 263 | protected 264 | function GetModule(Index: integer): TDebugInfoModule; 265 | function GetCount: integer; 266 | function GetEmpty: boolean; 267 | public 268 | constructor Create(ADebugInfo: TDebugInfo); 269 | destructor Destroy; override; 270 | 271 | function Add(const AName: string; ASegment: TDebugInfoSegment; AOffset, ASize: TDebugInfoOffset): TDebugInfoModule; 272 | procedure Remove(Module: TDebugInfoModule); 273 | 274 | function FindByName(const AName: string; ASegment: TDebugInfoSegment): TDebugInfoModule; 275 | function FindByOffset(ASegment: TDebugInfoSegment; AOffset: TDebugInfoOffset): TDebugInfoModule; 276 | function FindOverlap(ASegment: TDebugInfoSegment; AOffset, ASize: TDebugInfoOffset): TDebugInfoModule; 277 | 278 | property Modules[Index: integer]: TDebugInfoModule read GetModule; default; 279 | property Count: integer read GetCount; 280 | property Empty: boolean read GetEmpty; 281 | 282 | function GetEnumerator: TEnumerator; 283 | end; 284 | 285 | 286 | TDebugInfo = class 287 | private 288 | FSegments: TDebugInfoSegments; 289 | FModules: TDebugInfoModules; 290 | FSourceFiles: TDebugInfoSourceFiles; 291 | public 292 | constructor Create; 293 | destructor Destroy; override; 294 | 295 | property Segments: TDebugInfoSegments read FSegments; 296 | property Modules: TDebugInfoModules read FModules; 297 | property SourceFiles: TDebugInfoSourceFiles read FSourceFiles; 298 | end; 299 | 300 | type 301 | EDebugInfo = class(Exception); 302 | 303 | 304 | implementation 305 | 306 | uses 307 | Winapi.Windows, 308 | System.Math; 309 | 310 | { TDebugInfo } 311 | 312 | constructor TDebugInfo.Create; 313 | begin 314 | inherited Create; 315 | 316 | FSegments := TDebugInfoSegments.Create; 317 | FModules := TDebugInfoModules.Create(Self); 318 | FSourceFiles := TDebugInfoSourceFiles.Create; 319 | end; 320 | 321 | destructor TDebugInfo.Destroy; 322 | begin 323 | FSegments.Free; 324 | FModules.Free; 325 | FSourceFiles.Free; 326 | 327 | inherited; 328 | end; 329 | 330 | { TDebugInfoModule } 331 | 332 | constructor TDebugInfoModule.Create(ADebugInfo: TDebugInfo; const AName: string; ASegment: TDebugInfoSegment; AOffset, ASize: TDebugInfoOffset); 333 | begin 334 | inherited Create; 335 | 336 | FDebugInfo := ADebugInfo; 337 | 338 | FName := AName; 339 | FSegment := ASegment; 340 | FOffset := AOffset; 341 | FSize := ASize; 342 | 343 | FSourceFiles := TDebugInfoSourceFiles.Create(FDebugInfo); 344 | FSourceLines := TDebugInfoSourceLines.Create(Self); 345 | FSymbols := TDebugInfoSymbols.Create(Self); 346 | end; 347 | 348 | destructor TDebugInfoModule.Destroy; 349 | begin 350 | FSourceLines.Free; 351 | FSourceFiles.Free; 352 | FSymbols.Free; 353 | 354 | inherited; 355 | end; 356 | 357 | function TDebugInfoModule.GetAddress: TDebugInfoOffset; 358 | begin 359 | Result := Segment.Offset + Offset; 360 | end; 361 | 362 | function TDebugInfoModule.GetObjectName: string; 363 | begin 364 | Result := FObjectName; 365 | if (Result = '') then 366 | Result := FName;; 367 | end; 368 | 369 | procedure TDebugInfoModule.CalculateSize; 370 | begin 371 | // Determine max size of module 372 | var MaxModuleSize := FSize; 373 | for var SourceLine in FSourceLines do 374 | MaxModuleSize := Max(MaxModuleSize, SourceLine.Offset); 375 | 376 | for var Symbol in FSymbols do 377 | MaxModuleSize := Max(MaxModuleSize, Symbol.Offset + Symbol.Size); 378 | 379 | FSize := MaxModuleSize; 380 | end; 381 | 382 | { TDebugInfoSymbols } 383 | 384 | procedure TDebugInfoSymbols.CalculateSizes; 385 | begin 386 | for var i := 0 to FSymbols.Count-2 do 387 | FSymbols[i].Size := FSymbols[i+1].Offset - FSymbols[i].Offset; 388 | 389 | // Assume last symbol extends to end of module 390 | if (FSymbols.Count > 0) then 391 | FSymbols[FSymbols.Count-1].Size := FModule.Size - FSymbols[FSymbols.Count-1].Offset; 392 | end; 393 | 394 | constructor TDebugInfoSymbols.Create(AModule: TDebugInfoModule); 395 | begin 396 | inherited Create; 397 | 398 | FModule := AModule; 399 | FSymbols := TDebugInfoSymbolList.Create(True); 400 | end; 401 | 402 | destructor TDebugInfoSymbols.Destroy; 403 | begin 404 | FSymbols.Free; 405 | 406 | inherited; 407 | end; 408 | 409 | function TDebugInfoSymbols.GetCount: integer; 410 | begin 411 | Result := FSymbols.Count; 412 | end; 413 | 414 | function TDebugInfoSymbols.GetEnumerator: TEnumerator; 415 | begin 416 | Result := FSymbols.GetEnumerator; 417 | end; 418 | 419 | function TDebugInfoSymbols.Add(const AName: string; AOffset: TDebugInfoOffset): TDebugInfoSymbol; 420 | begin 421 | // Binary search 422 | var L := 0; 423 | var H := FSymbols.Count-1; 424 | 425 | while (L <= H) do 426 | begin 427 | var mid := L + (H - L) shr 1; 428 | 429 | var Symbol := FSymbols[mid]; 430 | 431 | if (AOffset < Symbol.Offset) then 432 | H := mid - 1 433 | else 434 | if (AOffset >= Symbol.Offset) then 435 | L := mid + 1 436 | else 437 | begin 438 | // Return existing if we have an exact duplicate of Name+Offset 439 | if (Symbol.Name = AName) then 440 | Exit(Symbol); 441 | 442 | // Disallow duplicate offset but don't fail 443 | Exit(nil); 444 | end; 445 | end; 446 | 447 | Result := TDebugInfoSymbol.Create(FModule, AName, AOffset); 448 | FSymbols.Insert(L, Result); 449 | end; 450 | 451 | { TDebugInfoModules } 452 | 453 | function TDebugInfoModules.Add(const AName: string; ASegment: TDebugInfoSegment; AOffset, ASize: TDebugInfoOffset): TDebugInfoModule; 454 | begin 455 | Result := TDebugInfoModule.Create(FDebugInfo, AName, ASegment, AOffset, ASize); 456 | try 457 | 458 | var Index: integer; 459 | if (FModules.BinarySearch(Result, Index, FComparer)) then 460 | raise EDebugInfo.Create('Cannot add overlapping modules'); 461 | 462 | FModules.Insert(Index, Result); 463 | 464 | except 465 | Result.Free; 466 | raise; 467 | end; 468 | end; 469 | 470 | constructor TDebugInfoModules.Create(ADebugInfo: TDebugInfo); 471 | begin 472 | inherited Create; 473 | 474 | FDebugInfo := ADebugInfo; 475 | FModules := TDebugInfoModuleList.Create(True); 476 | FComparer := IComparer( 477 | function(const Left, Right: TDebugInfoModule): Integer 478 | begin 479 | Result := integer(Left.Segment.Index) - integer(Right.Segment.Index); 480 | if (Result = 0) then 481 | Result := integer(Left.Offset) - integer(Right.Offset); // Cast to avoid integer overflow 482 | end); 483 | end; 484 | 485 | destructor TDebugInfoModules.Destroy; 486 | begin 487 | FModules.Free; 488 | 489 | inherited; 490 | end; 491 | 492 | function TDebugInfoModules.FindByName(const AName: string; ASegment: TDebugInfoSegment): TDebugInfoModule; 493 | begin 494 | for var Module in FModules do 495 | if (Module.Segment = ASegment) and (Module.Name = AName) then 496 | Exit(Module); 497 | Result := nil; 498 | end; 499 | 500 | function TDebugInfoModules.FindByOffset(ASegment: TDebugInfoSegment; AOffset: TDebugInfoOffset): TDebugInfoModule; 501 | begin 502 | // Binary search 503 | var L := 0; 504 | var H := FModules.Count-1; 505 | 506 | while (L <= H) do 507 | begin 508 | var mid := L + (H - L) shr 1; 509 | 510 | var Module := FModules[mid]; 511 | 512 | if (ASegment.Index < Module.Segment.Index) then 513 | H := mid - 1 514 | else 515 | if (ASegment.Index > Module.Segment.Index) then 516 | L := mid + 1 517 | else 518 | begin 519 | if (AOffset < Module.Offset) then 520 | H := mid - 1 521 | else 522 | if (AOffset >= Module.Offset+Module.Size) then 523 | L := mid + 1 524 | else 525 | Exit(Module); 526 | end; 527 | end; 528 | 529 | Result := nil; 530 | end; 531 | 532 | function TDebugInfoModules.FindOverlap(ASegment: TDebugInfoSegment; AOffset, ASize: TDebugInfoOffset): TDebugInfoModule; 533 | begin 534 | // Binary search 535 | var L := 0; 536 | var H := FModules.Count-1; 537 | 538 | while (L <= H) do 539 | begin 540 | var mid := L + (H - L) shr 1; 541 | 542 | var Module := FModules[mid]; 543 | 544 | if (ASegment.Index < Module.Segment.Index) then 545 | H := mid - 1 546 | else 547 | if (ASegment.Index > Module.Segment.Index) then 548 | L := mid + 1 549 | else 550 | begin 551 | if (AOffset < Module.Offset) then 552 | begin 553 | if (AOffset+ASize < Module.Offset) then 554 | H := mid - 1 555 | else 556 | Exit(Module); 557 | end else 558 | if (AOffset >= Module.Offset+Module.Size) then 559 | L := mid + 1 560 | else 561 | Exit(Module); 562 | end; 563 | end; 564 | 565 | Result := nil; 566 | end; 567 | 568 | function TDebugInfoModules.GetCount: integer; 569 | begin 570 | Result := FModules.Count; 571 | end; 572 | 573 | function TDebugInfoModules.GetEmpty: boolean; 574 | begin 575 | Result := (FModules.Count = 0); 576 | end; 577 | 578 | function TDebugInfoModules.GetEnumerator: TEnumerator; 579 | begin 580 | Result := FModules.GetEnumerator; 581 | end; 582 | 583 | function TDebugInfoModules.GetModule(Index: integer): TDebugInfoModule; 584 | begin 585 | Result := FModules[Index]; 586 | end; 587 | 588 | procedure TDebugInfoModules.Remove(Module: TDebugInfoModule); 589 | begin 590 | FModules.Remove(Module); 591 | end; 592 | 593 | { TDebugInfoSymbol } 594 | 595 | constructor TDebugInfoSymbol.Create(AModule: TDebugInfoModule; const AName: string; AOffset: TDebugInfoOffset); 596 | begin 597 | inherited Create; 598 | 599 | FModule := AModule; 600 | FName := AName; 601 | FOffset := AOffset; 602 | end; 603 | 604 | function TDebugInfoSymbol.GetAddress: TDebugInfoOffset; 605 | begin 606 | Result := Module.Address + Offset; 607 | end; 608 | 609 | { TDebugInfoSegments } 610 | 611 | constructor TDebugInfoSegments.Create; 612 | begin 613 | inherited Create; 614 | 615 | FSegments := TObjectDictionary.Create([doOwnsValues]); 616 | FNames := TDictionary.Create; 617 | FOrdered := TList.Create(TComparer.Construct( 618 | function(const A, B: TDebugInfoSegment): integer 619 | begin 620 | Result := integer(A.Index) - integer(B.Index); 621 | end)); 622 | end; 623 | 624 | destructor TDebugInfoSegments.Destroy; 625 | begin 626 | FNames.Free; 627 | FSegments.Free; 628 | FOrdered.Free; 629 | 630 | inherited; 631 | end; 632 | 633 | function TDebugInfoSegments.Add(AIndex: Cardinal; const AName: string; AClassType: TDebugInfoSegmentClass): TDebugInfoSegment; 634 | begin 635 | if (AIndex = 0) then 636 | raise EDebugInfo.CreateFmt('Invalid Segment index: %d', [AIndex]); 637 | 638 | if (FSegments.ContainsKey(AIndex)) then 639 | raise EDebugInfo.CreateFmt('Duplicate Segment index: %d', [AIndex]); 640 | 641 | if (FNames.ContainsKey(AName)) then 642 | raise EDebugInfo.CreateFmt('Duplicate Segment name: %s', [AName]); 643 | 644 | Result := TDebugInfoSegment.Create(Self, AIndex, AName, AClassType); 645 | 646 | FSegments.Add(AIndex, Result); 647 | FNames.Add(AName, Result); 648 | var Index: integer; 649 | FOrdered.BinarySearch(Result, Index); 650 | FOrdered.Insert(Index, Result); 651 | end; 652 | 653 | function TDebugInfoSegments.FindByName(const AName: string): TDebugInfoSegment; 654 | begin 655 | if (not FNames.TryGetValue(AName, Result)) then 656 | Result := nil; 657 | end; 658 | 659 | function TDebugInfoSegments.FindByIndex(AIndex: Cardinal): TDebugInfoSegment; 660 | begin 661 | if (AIndex = 0) then 662 | raise EDebugInfo.CreateFmt('Invalid Segment index: %d', [AIndex]); 663 | 664 | if (not FSegments.TryGetValue(AIndex, Result)) then 665 | Result := nil; 666 | end; 667 | 668 | function TDebugInfoSegments.GetCount: integer; 669 | begin 670 | Result := FSegments.Count; 671 | end; 672 | 673 | function TDebugInfoSegments.GetEnumerator: TEnumerator; 674 | begin 675 | Result := FOrdered.GetEnumerator; 676 | end; 677 | 678 | function TDebugInfoSegments.GetSegment(AIndex: Cardinal): TDebugInfoSegment; 679 | begin 680 | if (not FSegments.TryGetValue(AIndex, Result)) then 681 | raise EDebugInfo.CreateFmt('Segment index does not exist: %d', [AIndex]); 682 | end; 683 | 684 | function TDebugInfoSegments.FindByOffset(AOffset: TDebugInfoOffset): TDebugInfoSegment; 685 | begin 686 | for Result in FOrdered do 687 | if (AOffset >= Result.Offset) and (AOffset < Result.Offset+Result.Size) then 688 | Exit; 689 | 690 | Result := nil; 691 | end; 692 | 693 | function TDebugInfoSegments.FindByClassName(const AClassName: string): TDebugInfoSegment; 694 | begin 695 | for Result in FOrdered do 696 | if (SameText(AClassName, Result.SegClassName)) then 697 | Exit; 698 | 699 | Result := nil; 700 | end; 701 | 702 | { TDebugInfoSegment } 703 | 704 | constructor TDebugInfoSegment.Create(AOwner: TDebugInfoSegments; AIndex: Cardinal; const AName: string; AClassType: TDebugInfoSegmentClass); 705 | begin 706 | inherited Create; 707 | 708 | FOwner := AOwner; 709 | FIndex := AIndex; 710 | FName := AName; 711 | FSegClassType := AClassType; 712 | 713 | FCharacteristics := IMAGE_SCN_MEM_READ; 714 | if (AClassType = sctCODE) then 715 | FCharacteristics := FCharacteristics or IMAGE_SCN_MEM_EXECUTE or IMAGE_SCN_CNT_CODE; 716 | end; 717 | 718 | class function TDebugInfoSegment.GuessClassType(const AName: string): TDebugInfoSegmentClass; 719 | type 720 | TSectionName = record 721 | Name: string; 722 | SegmentClass: TDebugInfoSegmentClass; 723 | end; 724 | const 725 | CommonNames: array[0..5] of TSectionName = ( 726 | (Name: 'CODE'; SegmentClass: sctCODE), 727 | (Name: 'ICODE'; SegmentClass: sctICODE), 728 | (Name: 'DATA'; SegmentClass: sctDATA), 729 | (Name: 'BSS'; SegmentClass: sctDATA), 730 | (Name: 'PDATA'; SegmentClass: sctDATA), 731 | (Name: 'TLS'; SegmentClass: sctTLS) 732 | ); 733 | begin 734 | for var i := 0 to High(CommonNames) do 735 | if (SameText(CommonNames[i].Name, AName)) then 736 | Exit(CommonNames[i].SegmentClass); 737 | Result := sctDATA; 738 | end; 739 | 740 | procedure TDebugInfoSegment.SetOffset(const Value: TDebugInfoOffset); 741 | begin 742 | FOffset := Value; 743 | CheckOverlap; 744 | end; 745 | 746 | procedure TDebugInfoSegment.SetSize(const Value: TDebugInfoOffset); 747 | begin 748 | FSize := Value; 749 | CheckOverlap; 750 | end; 751 | 752 | function TDebugInfoSegment.FindOverlap(AIgnoredClassTypes: TDebugInfoSegmentClasses): TDebugInfoSegment; 753 | begin 754 | Result := nil; 755 | 756 | if (Size = 0) then 757 | Exit; 758 | 759 | if (SegClassType in AIgnoredClassTypes) then 760 | Exit; 761 | 762 | for var Segment in FOwner do 763 | begin 764 | // Ignore self and empty segments 765 | if (Segment = Self) or (Segment.Size = 0) then 766 | continue; 767 | 768 | if (Segment.SegClassType in AIgnoredClassTypes) then 769 | continue; 770 | 771 | if ((Offset >= Segment.Offset) and (Offset < Segment.Offset+Segment.Size)) or // Start is within other range 772 | ((Offset+Size <= Segment.Offset) and (Offset+Size > Segment.Offset+Segment.Size)) or // Start is within other range 773 | ((Offset <= Segment.Offset) and (Offset+Size > Segment.Offset)) then // Other is within range 774 | Exit(Segment); 775 | end; 776 | end; 777 | 778 | procedure TDebugInfoSegment.CheckOverlap; 779 | begin 780 | // Ignore overlap in .tls segment; Delphi is known to produce map files with invalid .tls segment offset. 781 | var OverlappingSegment := FindOverlap([sctTLS]); 782 | 783 | if (OverlappingSegment <> nil) then 784 | raise EDebugInfo.CreateFmt('Overlapping segments: %s [%.4X:%.16X] and %s [%.4X:%.16X]', 785 | [Self.Name, Self.Index, Self.Offset, OverlappingSegment.Name, OverlappingSegment.Index, OverlappingSegment.Offset]); 786 | end; 787 | 788 | { TDebugInfoSourceFile } 789 | 790 | constructor TDebugInfoSourceFile.Create(const AFilename: string); 791 | begin 792 | inherited Create; 793 | 794 | FFilename := AFilename; 795 | end; 796 | 797 | { TDebugInfoSourceFiles } 798 | 799 | function TDebugInfoSourceFiles.Add(const AFilename: string): TDebugInfoSourceFile; 800 | begin 801 | if (FOwner <> nil) then 802 | begin 803 | // Delegate lookup/creation to owner... 804 | Result := FOwner.SourceFiles.Add(AFilename); 805 | 806 | // ... and add result to local list 807 | FSourceFiles.AddOrSetValue(AFilename, Result); 808 | end else 809 | if (not FSourceFiles.TryGetValue(AFilename, Result)) then 810 | begin 811 | Result := TDebugInfoSourceFile.Create(AFilename); 812 | FSourceFiles.Add(AFilename, Result); 813 | end; 814 | end; 815 | 816 | function TDebugInfoSourceFiles.Contains(SourceFile: TDebugInfoSourceFile): boolean; 817 | begin 818 | Result := FSourceFiles.ContainsValue(SourceFile); 819 | end; 820 | 821 | constructor TDebugInfoSourceFiles.Create(AOwner: TDebugInfo); 822 | begin 823 | inherited Create; 824 | 825 | FOwner := AOwner; 826 | 827 | // If Owner=nil then we own the values 828 | var Ownerships: TDictionaryOwnerships; 829 | if (FOwner = nil) then 830 | Ownerships:= [doOwnsValues] 831 | else 832 | Ownerships:= []; 833 | 834 | FSourceFiles := TDebugInfoSourceFileList.Create(Ownerships); 835 | end; 836 | 837 | destructor TDebugInfoSourceFiles.Destroy; 838 | begin 839 | FSourceFiles.Free; 840 | 841 | inherited; 842 | end; 843 | 844 | function TDebugInfoSourceFiles.First: TDebugInfoSourceFile; 845 | begin 846 | // It's more efficient to create an enumerator than to access the Values array 847 | if (FSourceFiles.Count > 0) then 848 | for var Pair in FSourceFiles do 849 | Exit(Pair.Value); 850 | 851 | Result := nil; 852 | end; 853 | 854 | function TDebugInfoSourceFiles.GetCount: integer; 855 | begin 856 | Result := FSourceFiles.Count; 857 | end; 858 | 859 | function TDebugInfoSourceFiles.GetEnumerator: TEnumerator; 860 | begin 861 | Result := FSourceFiles.Values.GetEnumerator; 862 | end; 863 | 864 | { TDebugInfoSourceLines } 865 | 866 | function TDebugInfoSourceLines.Add(ASourceFile: TDebugInfoSourceFile; ALineNumber: integer; 867 | AOffset: TDebugInfoOffset): TDebugInfoSourceLine; 868 | begin 869 | Result := TDebugInfoSourceLine.Create; 870 | 871 | Result.Module := FModule; 872 | Result.SourceFile := ASourceFile; 873 | Result.LineNumber := ALineNumber; 874 | Result.Offset := AOffset; 875 | 876 | // Note that multiple offsets can map to the same Source File+Line Number. 877 | // This can for example be caused by include files, inlining and generics 878 | // expansion. 879 | 880 | var Index: integer; 881 | if (not FSourceLines.BinarySearch(Result, Index, FComparer)) then 882 | FSourceLines.Insert(Index, Result) 883 | else 884 | Result.Free; 885 | end; 886 | 887 | constructor TDebugInfoSourceLines.Create(AModule: TDebugInfoModule); 888 | begin 889 | inherited Create; 890 | 891 | FModule := AModule; 892 | FSourceLines := TObjectList.Create(True); 893 | 894 | // Order lines by SourceFile, LineNumber, Offset 895 | FComparer := IComparer( 896 | function(const Left, Right: TDebugInfoSourceLine): integer 897 | begin 898 | Result := NativeInt(Left.SourceFile)-NativeInt(Right.SourceFile); 899 | 900 | if (Result = 0) then 901 | Result := Left.LineNumber - Right.LineNumber; 902 | 903 | if (Result = 0) then 904 | Result := integer(Left.Offset) - integer(Right.Offset); 905 | end); 906 | end; 907 | 908 | destructor TDebugInfoSourceLines.Destroy; 909 | begin 910 | FSourceLines.Free; 911 | 912 | inherited; 913 | end; 914 | 915 | function TDebugInfoSourceLines.GetCount: integer; 916 | begin 917 | Result := FSourceLines.Count; 918 | end; 919 | 920 | function TDebugInfoSourceLines.GetEmpty: boolean; 921 | begin 922 | Result := (FSourceLines.Count = 0); 923 | end; 924 | 925 | function TDebugInfoSourceLines.GetEnumerator: TEnumerator; 926 | begin 927 | Result := FSourceLines.GetEnumerator; 928 | end; 929 | 930 | { TDebugInfoSourceLine } 931 | 932 | function TDebugInfoSourceLine.GetAddress: TDebugInfoOffset; 933 | begin 934 | Result := Offset + Module.Offset + Module.Segment.Offset 935 | end; 936 | 937 | end. 938 | 939 | -------------------------------------------------------------------------------- /Source/debug.info.msf.pas: -------------------------------------------------------------------------------- 1 | unit debug.info.msf; 2 | 3 | (* 4 | * Copyright (c) 2021 Anders Melander 5 | * 6 | * This Source Code Form is subject to the terms of the Mozilla Public 7 | * License, v. 2.0. If a copy of the MPL was not distributed with this 8 | * file, You can obtain one at http://mozilla.org/MPL/2.0/. 9 | *) 10 | 11 | interface 12 | 13 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 14 | {$SCOPEDENUMS ON} 15 | 16 | {-$define MSF_OFFSET_ROUNDTRIP} // Define to verify that Logical/Physical offset calculations can roundtrip 17 | {-$define MSF_POISON} // Define to write MSF poison padding 18 | 19 | uses 20 | System.Generics.Collections, 21 | System.Classes, 22 | debug.info.pdb; 23 | 24 | 25 | // ----------------------------------------------------------------------------- 26 | // 27 | // TBinaryBlockWriter 28 | // 29 | // ----------------------------------------------------------------------------- 30 | // A binary writer with block knowledge. 31 | // ----------------------------------------------------------------------------- 32 | type 33 | TBinaryBlockWriter = class 34 | private type 35 | TBlockWriterBookmark = record 36 | private 37 | FWriter: TBinaryBlockWriter; 38 | FPosition: Int64; // Physical position 39 | function GetPosition: Int64; 40 | public 41 | // Return a new bookmark for the current position and restore the saved position 42 | function Restore: TBlockWriterBookmark; 43 | // Logical position 44 | property Position: Int64 read GetPosition; 45 | end; 46 | strict private 47 | FBlockSize: Cardinal; 48 | FIntervalSize: Cardinal; 49 | FStream: TStream; 50 | FStreamSize: Int64; // Cached/calculated Stream.Size to avoid flushing TBufferedFileStream buffers 51 | strict private 52 | function GetBlockCount: Cardinal; 53 | function GetIntervalIndex: Cardinal; 54 | function GetBlockIndex: Cardinal; 55 | procedure SetBlockIndex(const Value: Cardinal); 56 | function GetPosition: Int64; 57 | procedure SetPosition(const Value: Int64); 58 | protected 59 | procedure WriteBlockMap; 60 | {$ifdef MSF_OFFSET_ROUNDTRIP} 61 | class function DoLogicalToPhysicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; 62 | class function DoPhysicalToLogicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; 63 | {$endif MSF_OFFSET_ROUNDTRIP} 64 | class function LogicalToPhysicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; overload; 65 | function LogicalToPhysicalOffset(Offset: Int64): Int64; overload; 66 | class function PhysicalToLogicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; overload; 67 | function PhysicalToLogicalOffset(Offset: Int64): Int64; overload; 68 | public 69 | constructor Create(AStream: TStream; ABlockSize: Cardinal); 70 | 71 | // Logical seek 72 | function Seek(Offset: Int64; Origin: TSeekOrigin): Int64; 73 | 74 | // Write Bytes, Words and DWords 75 | procedure Write(Value: Byte); overload; 76 | procedure Write(Value: Word); overload; 77 | procedure Write(Value: Cardinal); overload; 78 | // Writes strings as zero terminated ansi strings. Does not write the length byte/word 79 | procedure Write(const Str: string); overload; 80 | procedure Write(const Str: AnsiString); overload; 81 | // Write a record (or any other typed value) 82 | procedure Write(const Value: T); overload; 83 | // Write a dynamic array 84 | procedure WriteArray(const Values: TArray); 85 | // Write arbitrary untyped data 86 | procedure WriteBuffer(const Buffer; Count: NativeInt); 87 | 88 | function BeginBlock(Poison: boolean = False): Cardinal; 89 | procedure EndBlock(Expand: boolean = False); 90 | 91 | function PadToAligment(Alignment: Cardinal; Poison: boolean = False): Int64; // Returns amount written 92 | function WritePadding(DesiredPos: Int64; Poison: boolean = False): Int64; // Returns amount written 93 | 94 | function SaveBookmark: TBlockWriterBookmark; 95 | 96 | property BlockSize: Cardinal read FBlockSize; 97 | property BlockCount: Cardinal read GetBlockCount; 98 | property BlockIndex: Cardinal read GetBlockIndex write SetBlockIndex; 99 | property IntervalIndex: Cardinal read GetIntervalIndex; 100 | // Logical position 101 | property Position: Int64 read GetPosition write SetPosition; 102 | end; 103 | 104 | 105 | // ----------------------------------------------------------------------------- 106 | // 107 | // TMSFStream 108 | // 109 | // ----------------------------------------------------------------------------- 110 | // Encapsulates a MSF stream 111 | // ----------------------------------------------------------------------------- 112 | type 113 | TMSFFile = class; 114 | 115 | // Take care when writing stream index values as some places we write the values 116 | // as DWORDs (e.g. hash tables). 117 | TMSFStreamIndex = Word; 118 | 119 | TMSFStreamState = ( 120 | ssAllocated, // Stream has been allocated 121 | ssIndex, // A stream index has been assigned 122 | ssOpen, // Stream has been opened 123 | ssClosed // Stream has been closed 124 | ); 125 | 126 | TMSFStream = class 127 | public 128 | const NullBlockIndex = $FFFFFFFF; 129 | const NullStreamIndex: TMSFStreamIndex = $FFFF; 130 | strict private 131 | FMSFFile: TMSFFile; 132 | FWriter: TBinaryBlockWriter; 133 | FState: TMSFStreamState; 134 | FIndex: TMSFStreamIndex; 135 | FBlockIndex: Cardinal; 136 | FLength: Cardinal; 137 | FOffset: Int64; 138 | strict private 139 | function GetIsFixed: boolean; 140 | function GetIsValid: boolean; 141 | function GetIndex: TMSFStreamIndex; 142 | function GetWriter: TBinaryBlockWriter; 143 | function GetHasIndex: boolean; 144 | public 145 | constructor Create(AMSFFile: TMSFFile); 146 | 147 | // Opens the stream. 148 | // Returns the start block index of the stream (same as the BlockIndex property). 149 | function BeginStream(Poison: boolean = False): Cardinal; 150 | 151 | // Closes the stream. 152 | // Returns the size of data written to the stream (same as the Length property). 153 | function EndStream: Cardinal; 154 | 155 | // Mark the stream in-use. 156 | // This ensures that the stream index is allocated and that the stream 157 | // will be persisted in the directory even if the stream hasn't been opened 158 | // or written to. 159 | procedure Touch; 160 | 161 | property Writer: TBinaryBlockWriter read GetWriter; 162 | 163 | // Stream index 164 | property Index: TMSFStreamIndex read GetIndex; 165 | 166 | // Logical start byte offset within MSF file 167 | property Offset: Int64 read FOffset; 168 | // Logical length of stream in bytes 169 | property Length: Cardinal read FLength; 170 | // Physical start MSF block index 171 | property BlockIndex: Cardinal read FBlockIndex; 172 | 173 | // IsFixed: True if stream is one of the fixed streams 174 | property IsFixed: boolean read GetIsFixed; 175 | // IsValid: True if stream has been opened or the Index value referenced 176 | property IsValid: boolean read GetIsValid; 177 | 178 | property HasIndex: boolean read GetHasIndex; 179 | property State: TMSFStreamState read FState; 180 | end; 181 | 182 | 183 | // ----------------------------------------------------------------------------- 184 | // 185 | // TMSFFile 186 | // 187 | // ----------------------------------------------------------------------------- 188 | // Encapsulates a MSF container file 189 | // ----------------------------------------------------------------------------- 190 | TMSFFile = class 191 | public 192 | const DefaultBlockSize = 4096; 193 | strict private type 194 | TFileState = (fsInit, fsOpen, fsClosed); 195 | strict private 196 | FState: TFileState; 197 | FStreams: TList; 198 | FWriter: TBinaryBlockWriter; 199 | FBlockSize: Cardinal; 200 | FCurrentStream: TMSFStream; 201 | FNextStreamIndex: TMSFStreamIndex; 202 | strict private 203 | procedure WriteSuperBlock(var MSFSuperBlock: TMSFSuperBlock; IndexStream, DirectoryStream: TMSFStream); 204 | procedure WriteStreamBlockList(Writer: TBinaryBlockWriter; Stream: TMSFStream); 205 | procedure WriteDirectoryIndex(IndexStream, DirectoryStream: TMSFStream); 206 | procedure WriteDirectory(DirectoryStream: TMSFStream); 207 | procedure WriteFreeBlockMap(const MSFSuperBlock: TMSFSuperBlock); 208 | 209 | function GetCount: integer; 210 | function GetStream(Index: TMSFStreamIndex): TMSFStream; 211 | function GetFixedStream(Index: PDBStreamIndex): TMSFStream; 212 | protected 213 | 214 | function BeginStream(Stream: TMSFStream): TBinaryBlockWriter; 215 | procedure EndStream(Stream: TMSFStream); 216 | 217 | function AllocateStreamIndex: TMSFStreamIndex; 218 | public 219 | constructor Create(AStream: TStream; ABlockSize: Cardinal); 220 | destructor Destroy; override; 221 | 222 | procedure BeginFile; 223 | procedure EndFile; 224 | 225 | function AllocateStream: TMSFStream; 226 | 227 | property Writer: TBinaryBlockWriter read FWriter; 228 | property CurrentStream: TMSFStream read FCurrentStream; 229 | 230 | property Count: integer read GetCount; 231 | property Streams[Index: TMSFStreamIndex]: TMSFStream read GetStream; default; 232 | property FixedStreams[Index: PDBStreamIndex]: TMSFStream read GetFixedStream; 233 | 234 | function GetEnumerator: TEnumerator; 235 | end; 236 | 237 | 238 | // ----------------------------------------------------------------------------- 239 | // ----------------------------------------------------------------------------- 240 | // ----------------------------------------------------------------------------- 241 | 242 | implementation 243 | 244 | uses 245 | System.Generics.Defaults, 246 | System.Math; 247 | 248 | 249 | // ----------------------------------------------------------------------------- 250 | // 251 | // TMSFFile 252 | // 253 | // ----------------------------------------------------------------------------- 254 | constructor TMSFFile.Create(AStream: TStream; ABlockSize: Cardinal); 255 | begin 256 | inherited Create; 257 | 258 | FBlockSize := ABlockSize; 259 | FStreams := TObjectList.Create(True); 260 | FWriter := TBinaryBlockWriter.Create(AStream, FBlockSize); 261 | end; 262 | 263 | destructor TMSFFile.Destroy; 264 | begin 265 | FWriter.Free; 266 | FStreams.Free; 267 | 268 | inherited; 269 | end; 270 | 271 | function TMSFFile.AllocateStreamIndex: TMSFStreamIndex; 272 | begin 273 | Result := FNextStreamIndex; 274 | Inc(FNextStreamIndex); 275 | end; 276 | 277 | procedure TMSFFile.BeginFile; 278 | begin 279 | Assert(FState = TFileState.fsInit); 280 | FState := TFileState.fsOpen; 281 | 282 | 283 | // Preallocate the fixed streams so their indices aren't used by other streams 284 | for var StreamIndex := Low(PDBStreamIndex) to High(PDBStreamIndex) do 285 | // Allocate and touch the stream so the stream index is assigned 286 | AllocateStream.Touch; 287 | 288 | 289 | // The MSF Superblock occupies block #0 - we write that last so skip it now 290 | FWriter.BlockIndex := 1; 291 | 292 | 293 | // Write the two Free Block Maps (FBM). Block #1 and #2 294 | FWriter.WriteBlockMap; 295 | Assert(FWriter.BlockIndex = 2); 296 | 297 | FWriter.WriteBlockMap; 298 | Assert(FWriter.BlockIndex = 3); 299 | 300 | // FPM (or FBM) = Free Page Map (or Free Block Map) 301 | // 302 | // The FPM exists either at block 1 or block 2 of the MSF. However, this 303 | // allows for a maximum of BlockSize * 8 blocks bits in the FPM, and 304 | // thusly an equal number of total blocks in the file. For a block size 305 | // of 4Kb (very common), this would yield 32Kb total blocks in file, for a 306 | // maximum file size of 32Kb * 4Kb = 128Mb. Obviously this won't do, so 307 | // the FPM is split across the file at `BlockSize` intervals. As a 308 | // result, every block whose index is of the form |{1,2} + BlockSize * k| 309 | // for any non-negative integer k is an FPM block. In theory, we only really 310 | // need to reserve blocks of the form |{1,2} + BlockSize * 8 * k|, but 311 | // current versions of the MSF format already expect the FPM to be arranged 312 | // at BlockSize intervals, so we have to be compatible. 313 | // See the function fpmPn() for more information: 314 | // https://github.com/Microsoft/microsoft-pdb/blob/master/PDB/msf/msf.cpp#L489 315 | 316 | end; 317 | 318 | procedure TMSFFile.EndFile; 319 | begin 320 | Assert(FState = TFileState.fsOpen); 321 | 322 | Assert(FCurrentStream = nil); 323 | 324 | // Create streams directly so they do not appear in the stream list 325 | var IndexStream := TMSFStream.Create(Self); 326 | var DirectoryStream := TMSFStream.Create(Self); 327 | try 328 | 329 | // Sort streams in Index order for the directory 330 | FStreams.Sort(IComparer( 331 | function(const A, B: TMSFStream): integer 332 | begin 333 | if (A.HasIndex) then 334 | begin 335 | if (not B.HasIndex) then 336 | Exit(-1); 337 | end else 338 | if (not B.HasIndex) then 339 | Exit(1); 340 | 341 | // Both indices are valid 342 | Result := integer(A.Index) - integer(B.Index); 343 | end)); 344 | 345 | 346 | // Now that all other streams have been written we can write the MSF directory stream. 347 | WriteDirectory(DirectoryStream); 348 | 349 | 350 | // Write a pointer to the directory stream. 351 | // The MSF Superblock will point to this stream. 352 | WriteDirectoryIndex(IndexStream, DirectoryStream); 353 | 354 | 355 | // The above was the last block so make sure file is physically padded. 356 | FWriter.BeginBlock; 357 | FWriter.EndBlock(True); 358 | 359 | 360 | // Rewind and write the MSF Superblock at block #0. 361 | // At this point all streams, and the directory, must have been written. 362 | Writer.BlockIndex := 0; 363 | var MSFSuperBlock: TMSFSuperBlock; 364 | WriteSuperBlock(MSFSuperBlock, IndexStream, DirectoryStream); 365 | 366 | 367 | // Finally update the Free Block Map 368 | WriteFreeBlockMap(MSFSuperBlock); 369 | 370 | finally 371 | IndexStream.Free; 372 | DirectoryStream.Free; 373 | end; 374 | 375 | FState := TFileState.fsClosed; 376 | end; 377 | 378 | function TMSFFile.AllocateStream: TMSFStream; 379 | begin 380 | Assert(FState = TFileState.fsOpen); 381 | 382 | Result := TMSFStream.Create(Self); 383 | 384 | FStreams.Add(Result); 385 | end; 386 | 387 | function TMSFFile.BeginStream(Stream: TMSFStream): TBinaryBlockWriter; 388 | begin 389 | Assert(FState = TFileState.fsOpen); 390 | Assert(FCurrentStream = nil); 391 | 392 | FCurrentStream := Stream; 393 | 394 | Result := FWriter; 395 | end; 396 | 397 | procedure TMSFFile.EndStream(Stream: TMSFStream); 398 | begin 399 | Assert(FState = TFileState.fsOpen); 400 | Assert(FCurrentStream = Stream); 401 | 402 | FCurrentStream := nil; 403 | end; 404 | 405 | function TMSFFile.GetCount: integer; 406 | begin 407 | Result := FStreams.Count; 408 | end; 409 | 410 | function TMSFFile.GetEnumerator: TEnumerator; 411 | begin 412 | Result := FStreams.GetEnumerator; 413 | end; 414 | 415 | function TMSFFile.GetFixedStream(Index: PDBStreamIndex): TMSFStream; 416 | begin 417 | Result := nil; 418 | // The list contains streams in allocation order, not Index order. 419 | for var i := 0 to FStreams.Count-1 do 420 | if (FStreams[i].HasIndex) and (FStreams[i].Index = Word(Ord(Index))) then 421 | Exit(FStreams[i]); 422 | Assert(False); 423 | end; 424 | 425 | function TMSFFile.GetStream(Index: TMSFStreamIndex): TMSFStream; 426 | begin 427 | Result := nil; 428 | // The list contains streams in allocation order, not Index order. 429 | for var i := 0 to FStreams.Count-1 do 430 | if (FStreams[i].HasIndex) and (FStreams[i].Index = Index) then 431 | Exit(FStreams[i]); 432 | Assert(False); 433 | end; 434 | 435 | procedure TMSFFile.WriteStreamBlockList(Writer: TBinaryBlockWriter; Stream: TMSFStream); 436 | begin 437 | // Assert(Stream.BlockIndex <> TMSFStream.NullBlockIndex); 438 | 439 | // We take advantage of the fact that in our case all blocks within a stream are 440 | // contiguous (except where the stream straddles an interval boundary). That is, 441 | // blocks from different streams do not interleave. 442 | 443 | var BlockCount := Ceil(Stream.Length / FBlockSize); 444 | var Offset := Stream.Offset; 445 | while (BlockCount > 0) do 446 | begin 447 | // Convert the logical offset to a physical offset, and then the 448 | // physical offset to a block index. 449 | var PhysicalOffset: Cardinal := TBinaryBlockWriter.LogicalToPhysicalOffset(Offset, FBlockSize); 450 | var BlockIndex: Cardinal := PhysicalOffset div FBlockSize; 451 | 452 | Writer.Write(BlockIndex); 453 | 454 | Dec(BlockCount); 455 | Inc(Offset, FBlockSize); 456 | end; 457 | end; 458 | 459 | procedure TMSFFile.WriteSuperBlock(var MSFSuperBlock: TMSFSuperBlock; IndexStream, DirectoryStream: TMSFStream); 460 | begin 461 | MSFSuperBlock := Default(TMSFSuperBlock); 462 | MSFSuperBlock.Magic := MSFMagic; 463 | MSFSuperBlock.BlockSize := FBlockSize; 464 | MSFSuperBlock.FreeBlockMapBlock := 1; // 1 or 2. In our case it's always block #1 465 | MSFSuperBlock.NumBlocks := FWriter.BlockCount; 466 | MSFSuperBlock.NumDirectoryBytes := DirectoryStream.Length; 467 | MSFSuperBlock.Unknown := 0; 468 | MSFSuperBlock.BlockMapAddr := IndexStream.BlockIndex; 469 | 470 | FWriter.Write(MSFSuperBlock); 471 | end; 472 | 473 | procedure TMSFFile.WriteFreeBlockMap(const MSFSuperBlock: TMSFSuperBlock); 474 | begin 475 | 476 | // Rewind and update all FBMs so all blocks (essentially all blocks "inside" 477 | // the file) are marked as allocated. 478 | // See: WriteBlockMap 479 | 480 | var BlockCount := MSFSuperBlock.NumBlocks; 481 | var FreeBlockMapIndex := MSFSuperBlock.FreeBlockMapBlock; 482 | 483 | while (BlockCount > 0) do 484 | begin 485 | // Seek to update FBM 486 | FWriter.BlockIndex := FreeBlockMapIndex; 487 | 488 | var SpaceInFreeBlockMap := MSFSuperBlock.BlockSize; 489 | 490 | // Write chunks of 8 blocks allocated 491 | while (SpaceInFreeBlockMap > 0) and (BlockCount > 8) do 492 | begin 493 | FWriter.Write($00); // No bits set = 8 blocks allocated 494 | Dec(BlockCount, 8); 495 | Dec(SpaceInFreeBlockMap); 496 | end; 497 | 498 | // Still space left in FBM and more blocks to allocate? 499 | if (SpaceInFreeBlockMap > 0) and (BlockCount > 0) then 500 | begin 501 | // We must have less than 8 blocks remaining. Write it as an actual bit mask. 502 | var Mask: Byte := $FF; 503 | var BitMask: Word := 1; // Word to avoid overflow if BlockCount=8 504 | while (BlockCount > 0) do 505 | begin 506 | Mask := Mask and (not BitMask); 507 | BitMask := BitMask shl 1; 508 | Dec(BlockCount); 509 | end; 510 | FWriter.Write(Mask); 511 | end; 512 | 513 | // Move to next interval. There are blocks between the FPMs. 514 | Inc(FreeBlockMapIndex, FBlockSize); 515 | end; 516 | end; 517 | 518 | procedure TMSFFile.WriteDirectoryIndex(IndexStream, DirectoryStream: TMSFStream); 519 | begin 520 | IndexStream.BeginStream; 521 | 522 | // Write list of blocks of where the directory actually lives 523 | WriteStreamBlockList(IndexStream.Writer, DirectoryStream); 524 | 525 | IndexStream.EndStream; 526 | end; 527 | 528 | procedure TMSFFile.WriteDirectory(DirectoryStream: TMSFStream); 529 | begin 530 | DirectoryStream.BeginStream; 531 | 532 | // Disregard streams that has been allocated but not opened (except fixed streams). 533 | 534 | // Number of streams 535 | var Count: Cardinal := 0; 536 | for var Stream in FStreams do 537 | if (Stream.IsValid) or (Stream.IsFixed) then 538 | begin 539 | Assert(Stream.State in [TMSFStreamState.ssIndex, TMSFStreamState.ssClosed]); 540 | Inc(Count); 541 | end; 542 | DirectoryStream.Writer.Write(Cardinal(Count)); 543 | 544 | // Stream sizes 545 | for var Stream in FStreams do 546 | if (Stream.IsValid) or (Stream.IsFixed) then 547 | DirectoryStream.Writer.Write(Stream.Length); 548 | 549 | // Stream blocks 550 | for var Stream in FStreams do 551 | if (Stream.IsValid) then 552 | WriteStreamBlockList(DirectoryStream.Writer, Stream); 553 | 554 | DirectoryStream.EndStream; 555 | end; 556 | 557 | 558 | // ----------------------------------------------------------------------------- 559 | // 560 | // TMSFStream 561 | // 562 | // ----------------------------------------------------------------------------- 563 | constructor TMSFStream.Create(AMSFFile: TMSFFile); 564 | begin 565 | inherited Create; 566 | 567 | FMSFFile := AMSFFile; 568 | FIndex := NullStreamIndex; 569 | FBlockIndex := NullBlockIndex; 570 | end; 571 | 572 | function TMSFStream.BeginStream(Poison: boolean): Cardinal; 573 | begin 574 | Assert(FWriter = nil); 575 | Assert(FState in [TMSFStreamState.ssAllocated, TMSFStreamState.ssIndex]); 576 | 577 | Touch; 578 | 579 | FWriter := FMSFFile.BeginStream(Self); 580 | 581 | FBlockIndex := FWriter.BeginBlock(Poison); 582 | FOffset := FWriter.Position; 583 | FState := TMSFStreamState.ssOpen; 584 | 585 | Result := FBlockIndex; 586 | end; 587 | 588 | function TMSFStream.EndStream: Cardinal; 589 | begin 590 | Assert(FWriter <> nil); 591 | Assert(FState = TMSFStreamState.ssOpen); 592 | 593 | FLength := Cardinal(FWriter.Position - FOffset); 594 | FWriter.EndBlock; 595 | 596 | FMSFFile.EndStream(Self); 597 | FWriter := nil; 598 | FState := TMSFStreamState.ssClosed; 599 | 600 | Result := FLength; 601 | end; 602 | 603 | function TMSFStream.GetHasIndex: boolean; 604 | begin 605 | Result := (FIndex <> NullStreamIndex); 606 | end; 607 | 608 | function TMSFStream.GetIndex: TMSFStreamIndex; 609 | begin 610 | Touch; 611 | 612 | Result := FIndex; 613 | end; 614 | 615 | function TMSFStream.GetIsFixed: boolean; 616 | begin 617 | Result := (integer(FIndex) <= Ord(High(PDBStreamIndex))); 618 | end; 619 | 620 | function TMSFStream.GetIsValid: boolean; 621 | begin 622 | Result := (FState > TMSFStreamState.ssAllocated); 623 | end; 624 | 625 | function TMSFStream.GetWriter: TBinaryBlockWriter; 626 | begin 627 | Assert(FState = TMSFStreamState.ssOpen); 628 | Assert(FIndex <> NullStreamIndex); 629 | Assert(FBlockIndex <> NullBlockIndex); 630 | 631 | Result := FWriter; 632 | end; 633 | 634 | procedure TMSFStream.Touch; 635 | begin 636 | // Stream has now been referenced. Allocate a stream index to ensure the stream will 637 | // be written to the directory. 638 | if (FIndex = NullStreamIndex) then 639 | begin 640 | Assert(FState = TMSFStreamState.ssAllocated); 641 | 642 | FIndex := FMSFFile.AllocateStreamIndex; 643 | FState := TMSFStreamState.ssIndex; 644 | end; 645 | 646 | Assert(FState >= TMSFStreamState.ssIndex); 647 | end; 648 | 649 | 650 | // ----------------------------------------------------------------------------- 651 | // 652 | // TBinaryBlockWriter 653 | // 654 | // ----------------------------------------------------------------------------- 655 | 656 | (* 657 | MSF Block and Interval layout 658 | 659 | Interval | 0 | 1 660 | ------------+------------+------+------+------+------+------+------+------+------+------+------+------+- - - 661 | Block index | 0 | 1 | 2 | 3 | 4 | ... | 4095 | 4096 | 4097 | 4095 | 4096 | 4097 | ... 662 | ------------+------------+------+------+------+------+------+------+------+------+------+------+------+- - - 663 | Log block | 0 (N/A) | N/A | N/A | 1 | 2 | ... | ... | 4094 | N/A | N/A | 4095 | ... | ... 664 | ------------+------------+------+------+------+------+------+------+------+------+------+------+------+- - - 665 | Phys offset | 0 | 4096 | 8192 |12288 |16384 | ... | ... |4096^2|+4096 |+8192 | ... | ... | ... 666 | ------------+------------+------+------+------+------+------+------+------+------+------+------+------+- - - 667 | Content | Superblock | FPM1 | FPM2 | Data | Data | Data | Data | Data | FPM1 | FPM2 | Data | Data | Data 668 | *) 669 | 670 | constructor TBinaryBlockWriter.Create(AStream: TStream; ABlockSize: Cardinal); 671 | begin 672 | inherited Create; 673 | 674 | FStream := AStream; 675 | FBlockSize := ABlockSize; 676 | FIntervalSize := FBlockSize * FBlockSize; 677 | end; 678 | 679 | {$ifdef MSF_OFFSET_ROUNDTRIP} 680 | class function TBinaryBlockWriter.DoLogicalToPhysicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; 681 | begin 682 | Result := Offset + 2 * BlockSize * ((Offset - BlockSize) div (BlockSize * (BlockSize - 2)) + 1); 683 | end; 684 | 685 | class function TBinaryBlockWriter.DoPhysicalToLogicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; 686 | begin 687 | Result := Offset - 2 * BlockSize * ((Offset - BlockSize) div (BlockSize * BlockSize) + 1); 688 | end; 689 | {$endif MSF_OFFSET_ROUNDTRIP} 690 | 691 | class function TBinaryBlockWriter.LogicalToPhysicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; 692 | begin 693 | (* 694 | For each logical Interval (4096-2 blocks), add the two FPM blocks. 695 | Shift the offset 1 block before calculating Interval to account for the block at the start of the interval. 696 | 697 | OfsLog - Block 698 | OfsPhys = OfsLog + [ --------------------- +1 ] * Block * 2 699 | Block * (Block - 2) 700 | *) 701 | 702 | Assert(Offset >= BlockSize, 'Invalid logical offset'); 703 | {$ifdef MSF_OFFSET_ROUNDTRIP} 704 | 705 | Result := DoLogicalToPhysicalOffset(Offset, BlockSize); 706 | 707 | Assert(Offset = DoPhysicalToLogicalOffset(Result, BlockSize), 'LogicalToPhysicalOffset roundtrip failed'); 708 | 709 | // Physical offsets within the two FPMs have no logical mapping 710 | Assert((Result - BlockSize) and (BlockSize*BlockSize-1) >= 2*BlockSize); 711 | 712 | {$else MSF_OFFSET_ROUNDTRIP} 713 | 714 | Result := Offset + 2 * BlockSize * ((Offset - BlockSize) div (BlockSize * (BlockSize - 2)) + 1); 715 | 716 | {$endif MSF_OFFSET_ROUNDTRIP} 717 | Assert(Result >= 0); 718 | end; 719 | 720 | function TBinaryBlockWriter.LogicalToPhysicalOffset(Offset: Int64): Int64; 721 | begin 722 | Result := LogicalToPhysicalOffset(Offset, FBlockSize); 723 | end; 724 | 725 | class function TBinaryBlockWriter.PhysicalToLogicalOffset(Offset: Int64; BlockSize: Cardinal): Int64; 726 | begin 727 | (* 728 | For each physical Interval (4096 blocks), subtract the two FPM blocks. 729 | Shift the offset 1 block before calculating Interval to account for the block at the start of the interval. 730 | 731 | OfsPhys - Block 732 | OfsLog = OfsPhys - [ ----------------- +1 ] * Block * 2 733 | Block * Block 734 | *) 735 | 736 | Assert(Offset >= BlockSize*3, 'Physical offset out of logical bounds'); 737 | {$ifdef MSF_OFFSET_ROUNDTRIP} 738 | 739 | // Physical offsets within the two FPMs have no logical mapping 740 | Assert((Offset - BlockSize) and (BlockSize*BlockSize-1) >= 2*BlockSize); 741 | 742 | Result := DoPhysicalToLogicalOffset(Offset, BlockSize); 743 | 744 | Assert(Offset = DoLogicalToPhysicalOffset(Result, BlockSize), 'PhysicalToLogicalOffset roundtrip failed'); // Roundtrip 745 | 746 | {$else MSF_OFFSET_ROUNDTRIP} 747 | 748 | Result := Offset - 2 * BlockSize * ((Offset - BlockSize) div (BlockSize * BlockSize) + 1); 749 | 750 | {$endif MSF_OFFSET_ROUNDTRIP} 751 | Assert(Result >= 0); 752 | end; 753 | 754 | function TBinaryBlockWriter.PhysicalToLogicalOffset(Offset: Int64): Int64; 755 | begin 756 | Result := PhysicalToLogicalOffset(Offset, FBlockSize); 757 | end; 758 | 759 | function TBinaryBlockWriter.WritePadding(DesiredPos: Int64; Poison: boolean): Int64; 760 | begin 761 | Result := DesiredPos - Position; 762 | Assert(Result >= 0); 763 | 764 | if (Result = 0) then 765 | Exit; 766 | 767 | // CodeView leaf records are either padded to 4 bytes (if this type stream appears in a TPI/IPI stream 768 | // of a PDB) or not padded at all (if this type stream appears in the .debug$T section of an object 769 | // file). Padding is implemented by inserting a decreasing sequence of bytes (LF_PAD15..LF_PAD0) that 770 | // terminates with LF_PAD0. 771 | 772 | {$ifdef MSF_POISON} 773 | if (Poison) then 774 | begin 775 | Assert(Result <= $0F); 776 | var Count := Result; 777 | while (Count > 0) do 778 | begin 779 | Dec(Count); 780 | Write(Byte((Count and $0F) or $F0)); // http://moyix.blogspot.com/2007/10/types-stream.html 781 | end; 782 | end else 783 | {$endif MSF_POISON} 784 | // We're allowed to seek past EOF. File will be physically expanded once we 785 | // actually write something or explicitly set the size. 786 | // Note however that if we expand the file this way and the close it with out 787 | // writing anything, then the file is truncated to the point where we last wrote 788 | // something. EndBlock(Expand=True) can be used to force the stream to be 789 | // expanded to the current position. 790 | Seek(Result, soCurrent); 791 | FStreamSize := Max(FStreamSize, FStream.Position); 792 | end; 793 | 794 | procedure TBinaryBlockWriter.WriteBlockMap; 795 | const 796 | AllVacancies: Byte = $FF; 797 | begin 798 | BeginBlock; 799 | Assert((BlockIndex mod FBlockSize) in [1, 2]); 800 | 801 | // Mark all BlockSize*8 blocks free 802 | for var i := 0 to FBlockSize-1 do 803 | FStream.WriteBuffer(AllVacancies, 1); 804 | 805 | FStreamSize := Max(FStreamSize, FStream.Position); 806 | 807 | EndBlock(True); 808 | end; 809 | 810 | procedure TBinaryBlockWriter.Write(Value: Byte); 811 | begin 812 | WriteBuffer(Value, SizeOf(Value)); 813 | end; 814 | 815 | procedure TBinaryBlockWriter.Write(Value: Word); 816 | begin 817 | WriteBuffer(Value, SizeOf(Value)); 818 | end; 819 | 820 | procedure TBinaryBlockWriter.Write(Value: Cardinal); 821 | begin 822 | WriteBuffer(Value, SizeOf(Value)); 823 | end; 824 | 825 | procedure TBinaryBlockWriter.Write(const Value: T); 826 | begin 827 | WriteBuffer(Value, SizeOf(T)); 828 | end; 829 | 830 | procedure TBinaryBlockWriter.WriteArray(const Values: TArray); 831 | begin 832 | if (Length(Values) = 0) then 833 | Exit; 834 | 835 | WriteBuffer(Values[0], Length(Values) * SizeOf(T)); 836 | end; 837 | 838 | procedure TBinaryBlockWriter.Write(const Str: string); 839 | begin 840 | // TODO : Handle UTF8 here 841 | if (Str <> '') then 842 | Write(AnsiString(Str)) 843 | else 844 | Write(Byte(0)); 845 | end; 846 | 847 | procedure TBinaryBlockWriter.Write(const Str: AnsiString); 848 | begin 849 | if (Str <> '') then 850 | WriteBuffer(Str[1], Length(Str)+1) // Include terminating zero 851 | else 852 | Write(Byte(0)); 853 | end; 854 | 855 | procedure TBinaryBlockWriter.WriteBuffer(const Buffer; Count: NativeInt); 856 | type 857 | TByteArray = array[0..MaxInt-1] of Byte; 858 | PByteArray = ^TByteArray; 859 | begin 860 | // Find start interval of this piece of data. 861 | // Disregard the first block so intervals start with the two FPM blocks 862 | var Interval := (FStream.Position - FBlockSize) div FIntervalSize; 863 | 864 | while (Count > 0) do 865 | begin 866 | // How many bytes from current position to end of current interval 867 | var BytesInThisInterval := (Interval+1) * FIntervalSize + FBlockSize - FStream.Position; 868 | // ...but no more than what we need 869 | BytesInThisInterval := Min(Count, BytesInThisInterval); 870 | 871 | // Write part 872 | FStream.WriteBuffer(Buffer, BytesInThisInterval); 873 | Dec(Count, BytesInThisInterval); 874 | 875 | // More to write or end of interval? 876 | if (Count >= 0) then 877 | begin 878 | // We have either written all the data, we are at the end of the 879 | // current interval, or both. 880 | var NewInterval := (FStream.Position - FBlockSize) div FIntervalSize; 881 | 882 | // If we are at a new interval... 883 | if (NewInterval <> Interval) then 884 | begin 885 | // ...write the two FPM blocks to start a new interval 886 | WriteBlockMap; 887 | WriteBlockMap; 888 | 889 | Interval := NewInterval; 890 | end; 891 | end; 892 | end; 893 | end; 894 | 895 | function TBinaryBlockWriter.BeginBlock(Poison: boolean): Cardinal; 896 | begin 897 | // Move up to next block. Return block index. 898 | PadToAligment(FBlockSize, Poison); 899 | Result := BlockIndex; 900 | end; 901 | 902 | procedure TBinaryBlockWriter.EndBlock(Expand: boolean); 903 | begin 904 | // In case we have used Seek to align the position then the physical 905 | // size can be smaller than the current position in which case we will 906 | // need to move the position back and write something to actually 907 | // expand then stream. 908 | // Note that we're testing against the real stream size here. Not the 909 | // cached one. 910 | if (Expand) then 911 | begin 912 | FStreamSize := FStream.Size; 913 | if (FStream.Position > FStream.Size) then 914 | begin 915 | Assert(FStreamSize - FStream.Position < FBlockSize); 916 | FStream.Position := FStreamSize; 917 | end; 918 | end; 919 | 920 | var Padding := FBlockSize - (FStream.Position and (FBlockSize-1)); 921 | 922 | // Move up to nearest whole block 923 | if (Padding <> FBlockSize) then 924 | begin 925 | if (Expand) then 926 | begin 927 | if (Padding > 1) then 928 | Position := Position + Padding - 1; 929 | // Physically expand file 930 | Write(Byte($00)); 931 | end else 932 | // Just do a seek. File will be automatically expanded if we write anything 933 | Position := Position + Padding; 934 | end; 935 | Assert(FStream.Position and (FBlockSize-1) = 0); 936 | FStreamSize := Max(FStreamSize, FStream.Position); 937 | end; 938 | 939 | function TBinaryBlockWriter.GetBlockCount: Cardinal; 940 | begin 941 | Result := (FStreamSize + FBlockSize - 1) div FBlockSize; 942 | end; 943 | 944 | function TBinaryBlockWriter.GetBlockIndex: Cardinal; 945 | begin 946 | Result := FStream.Position div FBlockSize; 947 | end; 948 | 949 | function TBinaryBlockWriter.GetIntervalIndex: Cardinal; 950 | begin 951 | Result := FStream.Position div FIntervalSize; 952 | end; 953 | 954 | function TBinaryBlockWriter.GetPosition: Int64; 955 | begin 956 | Result := PhysicalToLogicalOffset(FStream.Position); 957 | end; 958 | 959 | function TBinaryBlockWriter.PadToAligment(Alignment: Cardinal; Poison: boolean): Int64; 960 | begin 961 | Result := Alignment - (FStream.Position and (Alignment - 1)); 962 | if (Result <> Alignment) then 963 | Result := WritePadding(Position + Result, Poison) 964 | else 965 | Result := 0; 966 | Assert(FStream.Position and (Alignment - 1) = 0); 967 | end; 968 | 969 | function TBinaryBlockWriter.SaveBookmark: TBlockWriterBookmark; 970 | begin 971 | Result.FWriter := Self; 972 | Result.FPosition := FStream.Position; 973 | end; 974 | 975 | function TBinaryBlockWriter.Seek(Offset: Int64; Origin: TSeekOrigin): Int64; 976 | begin 977 | Assert(Origin <> soEnd); // Not supported. No need for it. 978 | 979 | // Make offset absolute 980 | case Origin of 981 | 982 | soBeginning: 983 | Result := Offset; 984 | 985 | soCurrent: 986 | Result := Position + Offset; 987 | 988 | else 989 | Result := 0; 990 | end; 991 | 992 | Position := Result; 993 | end; 994 | 995 | procedure TBinaryBlockWriter.SetBlockIndex(const Value: Cardinal); 996 | begin 997 | FStream.Position := Value * FBlockSize; 998 | FStreamSize := Max(FStreamSize, FStream.Position); 999 | end; 1000 | 1001 | procedure TBinaryBlockWriter.SetPosition(const Value: Int64); 1002 | begin 1003 | var NewPosition := LogicalToPhysicalOffset(Value); 1004 | 1005 | // If we're expanding the stream then we need to take intervals into account and 1006 | // write the FPMs when we cross an interval boundary. 1007 | // If we're not expanding then they have already been handled. 1008 | if (NewPosition > FStreamSize) then 1009 | begin 1010 | 1011 | var OldInterval := (FStream.Position - FBlockSize) div FIntervalSize; 1012 | var NewInterval := (NewPosition - FBlockSize) div FIntervalSize; 1013 | Assert(OldInterval <= NewInterval); 1014 | 1015 | if (OldInterval <> NewInterval) then 1016 | begin 1017 | Assert(OldInterval = NewInterval-1); 1018 | 1019 | // Move up to the start of the FPMs in the next interval 1020 | var StartOfInterval := NewInterval * FIntervalSize + FBlockSize; 1021 | // Dec(NewPosition, StartOfInterval - FStream.Position); 1022 | // Assert(NewPosition >= 0); 1023 | FStream.Position := StartOfInterval; 1024 | 1025 | // Write the two FPM blocks 1026 | WriteBlockMap; 1027 | WriteBlockMap; 1028 | 1029 | // Seek into the new interval. Adjust for the two FPMs just written. 1030 | // Dec(NewPosition, 2 * FBlockSize); 1031 | // Assert(NewPosition >= 0); 1032 | // FStream.Seek(NewPosition, soCurrent); 1033 | FStream.Position := NewPosition; 1034 | Assert(PhysicalToLogicalOffset(FStream.Position) = Value); 1035 | end else 1036 | FStream.Position := NewPosition; 1037 | end else 1038 | FStream.Position := NewPosition; 1039 | FStreamSize := Max(FStreamSize, FStream.Position); 1040 | end; 1041 | 1042 | 1043 | // ----------------------------------------------------------------------------- 1044 | // 1045 | // TBlockWriterBookmark 1046 | // 1047 | // ----------------------------------------------------------------------------- 1048 | function TBinaryBlockWriter.TBlockWriterBookmark.GetPosition: Int64; 1049 | begin 1050 | Result := FWriter.PhysicalToLogicalOffset(FPosition); 1051 | end; 1052 | 1053 | function TBinaryBlockWriter.TBlockWriterBookmark.Restore: TBlockWriterBookmark; 1054 | begin 1055 | Result.FWriter := FWriter; 1056 | Result.FPosition := FWriter.FStream.Position; 1057 | 1058 | FWriter.FStream.Position := FPosition; 1059 | end; 1060 | 1061 | end. 1062 | 1063 | --------------------------------------------------------------------------------