Delphi JclCompressedDebug-1

CrashingApp.dpr

program CrashingApp;

uses
  SysUtils,
  Dialogs,
  JclDebug,
  JclCompressedDebug;

function CrashString: String;
begin
  raise Exception.Create('Bang');

  Result := 'Poof';
end;

procedure Crash;
begin
  ShowMessage(CrashString)
end;

begin
  TJclDebugInfoList.RegisterDebugInfoSourceFirst(TJclDebugInfoCompressedBinary);

  try
    Crash;
  except
    on e: Exception do
      ShowMessage(e.ClassName + ' ' + e.Message + sLineBreak + e.StackTrace);
  end;
end.

DebugInfoTool.dpr

program DebugInfoTool;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  JclCompressedDebug;

function InsertCompressedJclDebugInfoInExe(const ExeFileName, MapFileName: TFileName): Boolean;
var
  LinkerBugUnit: String;
  LineNumberErrors, MapFileSize, JclDebugDataSize, CompressedJclDebugDataSize: Integer;
begin
  Result := InsertCompressedDebugDataIntoExecutableFile(
    ExeFileName,
    MapFileName,
    LinkerBugUnit,
    MapFileSize,
    JclDebugDataSize,
    CompressedJclDebugDataSize,
    LineNumberErrors);

  if Result then
  begin
    WriteLn('LinkerBugUnit:              ', LinkerBugUnit);
    WriteLn('LineNumberErrors:           ', Format('%12d', [LineNumberErrors]));
    WriteLn('MapFileSize:                ', Format('%12d', [MapFileSize]));
    WriteLn('JclDebugDataSize:           ', Format('%12d', [JclDebugDataSize]));
    WriteLn('CompressedJclDebugDataSize: ', Format('%12d', [CompressedJclDebugDataSize]));
  end;
end;

begin
  ExitCode := 1;
  try
    if InsertCompressedJclDebugInfoInExe(ParamStr(1), ChangeFileExt(ParamStr(1), '.map')) then
      ExitCode := 0
  except
    on e: Exception do
      WriteLn(e.ClassName, ' ', e.Message);
  end;
end.

JclCompressedDebug.pas

unit JclCompressedDebug;

interface

uses
  System.SysUtils,
  System.RTLConsts,
  WinApi.Windows,
  Classes,
  JclWin32,
  JclPeImage,
  JclSysUtils,
  JclDebug,
  JclCompression,
  JclStreams;

type
  TSectionName = array[1..IMAGE_SIZEOF_SHORT_NAME] of AnsiChar;

const
  CompressedDebugSection = AnsiString('JclCmpDb');

function InsertDataIntoExecutableFile(
  const ExecutableFileName: TFileName;
  const SectionName: TSectionName;
  Data: TStream): Boolean;

function InsertCompressedDebugDataIntoExecutableFile(
  const ExecutableFileName, MapFileName: TFileName;
  out LinkerBugUnit: string;
  out MapFileSize, JclDebugDataSize, CompressedJdbgFileSize, LineNumberErrors: Integer): Boolean;

type
  TJclDebugInfoCompressedBinary = class(TJclDebugInfoSource)
  private
    FScanner: TJclBinDebugScanner;
    FStream: TCustomMemoryStream;
  public
    destructor Destroy; override;
    function InitializeSource: Boolean; override;
    function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;
  end;

implementation

function InsertDataIntoExecutableFile(
  const ExecutableFileName: TFileName;
  const SectionName: TSectionName;
  Data: TStream): Boolean;
var
  ImageStream: TStream;
  NtHeaders32: TImageNtHeaders32;
  NtHeaders64: TImageNtHeaders64;
  ImageSectionHeaders: TImageSectionHeaderArray;
  NtHeadersPosition, ImageSectionHeadersPosition, DataSectionPosition: Int64;
  ImageSection: TImageSectionHeader;
  LastSection: PImageSectionHeader;
  VirtualAlignedSize: DWORD;
  I, X, NeedFill: Integer;
  DataSize: Int64;

  procedure RoundUpToAlignment(var Value: DWORD; Alignment: DWORD);
  begin
    if (Value mod Alignment) <> 0 then
      Value := ((Value div Alignment) + 1) * Alignment;
  end;

begin
  Result := Data <> nil;
  if not Result then
    Exit;

  ImageStream := TFileStream.Create(ExecutableFileName, fmOpenReadWrite or fmShareExclusive);
  try
    try
      DataSize := Data.Size;
      VirtualAlignedSize := DataSize;

      // ImageSection
      ResetMemory(ImageSection, SizeOf(ImageSection));
      // ImageSection Virtual Size
      ImageSection.Misc.VirtualSize := DataSize;
      // ImageSection Raw data size
      ImageSection.SizeOfRawData := DataSize;
      // ImageSection Section name
      Move(SectionName, ImageSection.Name, IMAGE_SIZEOF_SHORT_NAME);
      // ImageSection Characteristics flags
      ImageSection.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;

      case PeMapImgTarget(ImageStream, 0) of
        taWin32:
          begin
            NtHeadersPosition := PeMapImgNtHeaders32(ImageStream, 0, NtHeaders32);
            Assert(NtHeadersPosition <> -1);
            ImageSectionHeadersPosition := PeMapImgSections32(ImageStream, NtHeadersPosition, NtHeaders32, ImageSectionHeaders);
            Assert(ImageSectionHeadersPosition <> -1);
            // Check whether there is not a section with the name already. If so, return True (0000069)
            if PeMapImgFindSection(ImageSectionHeaders, String(SectionName)) <> -1 then
            begin
              Result := True;
              Exit;
            end;

            DataSectionPosition := ImageSectionHeadersPosition + (SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders));
            LastSection := @ImageSectionHeaders[High(ImageSectionHeaders)];

            // Increase the number of sections
            Inc(NtHeaders32.FileHeader.NumberOfSections);

            // ImageSection Virtual Address
            ImageSection.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;
            // ImageSection Physical Offset
            ImageSection.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;

            // ImageSection section rounding :
            RoundUpToAlignment(ImageSection.VirtualAddress, NtHeaders32.OptionalHeader.SectionAlignment);
            RoundUpToAlignment(ImageSection.PointerToRawData, NtHeaders32.OptionalHeader.FileAlignment);
            RoundUpToAlignment(ImageSection.SizeOfRawData, NtHeaders32.OptionalHeader.FileAlignment);

            // Size of virtual data area
            RoundUpToAlignment(VirtualAlignedSize, NtHeaders32.OptionalHeader.SectionAlignment);
            // Update Size of Image
            Inc(NtHeaders32.OptionalHeader.SizeOfImage, VirtualAlignedSize);
            // Update Initialized data size
            Inc(NtHeaders32.OptionalHeader.SizeOfInitializedData, ImageSection.SizeOfRawData);

            // write NT Headers 32
            if (ImageStream.Seek(NtHeadersPosition, soBeginning) <> NtHeadersPosition) or
              (ImageStream.Write(NtHeaders32, SizeOf(NtHeaders32)) <> SizeOf(NtHeaders32)) then
              raise EJclPeImageError.CreateRes(@SWriteError);
          end;

        taWin64:
          begin
            NtHeadersPosition := PeMapImgNtHeaders64(ImageStream, 0, NtHeaders64);
            Assert(NtHeadersPosition <> -1);
            ImageSectionHeadersPosition := PeMapImgSections64(ImageStream, NtHeadersPosition, NtHeaders64, ImageSectionHeaders);
            Assert(ImageSectionHeadersPosition <> -1);
            // Check whether there is not a section with the name already. If so, return True (0000069)
            if PeMapImgFindSection(ImageSectionHeaders, String(SectionName)) <> -1 then
            begin
              Result := True;
              Exit;
            end;

            DataSectionPosition := ImageSectionHeadersPosition + (SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders));
            LastSection := @ImageSectionHeaders[High(ImageSectionHeaders)];

            // Increase the number of sections
            Inc(NtHeaders64.FileHeader.NumberOfSections);

            // ImageSection Virtual Address
            ImageSection.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;
            // ImageSection Physical Offset
            ImageSection.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;

            // ImageSection section rounding :
            RoundUpToAlignment(ImageSection.VirtualAddress, NtHeaders64.OptionalHeader.SectionAlignment);
            RoundUpToAlignment(ImageSection.PointerToRawData, NtHeaders64.OptionalHeader.FileAlignment);
            RoundUpToAlignment(ImageSection.SizeOfRawData, NtHeaders64.OptionalHeader.FileAlignment);

            // Size of virtual data area
            RoundUpToAlignment(VirtualAlignedSize, NtHeaders64.OptionalHeader.SectionAlignment);
            // Update Size of Image
            Inc(NtHeaders64.OptionalHeader.SizeOfImage, VirtualAlignedSize);
            // Update Initialized data size
            Inc(NtHeaders64.OptionalHeader.SizeOfInitializedData, ImageSection.SizeOfRawData);

            // write NT Headers 64
            if (ImageStream.Seek(NtHeadersPosition, soBeginning) <> NtHeadersPosition) or
              (ImageStream.Write(NtHeaders64, SizeOf(NtHeaders64)) <> SizeOf(NtHeaders64)) then
              raise EJclPeImageError.CreateRes(@SWriteError);
          end;
      else
        Result := False;
        Exit;
      end;

      // write section header
      if (ImageStream.Seek(DataSectionPosition, soBeginning) <> DataSectionPosition) or
        (ImageStream.Write(ImageSection, SizeOf(ImageSection)) <> SizeOf(ImageSection)) then
        raise EJclPeImageError.CreateRes(@SWriteError);

      // Fill data to alignment
      NeedFill := INT_PTR(ImageSection.SizeOfRawData) - DataSize;

      // Note: Delphi linker seems to generate incorrect (unaligned) size of
      // the executable when adding TD32 debug data so the position could be
      // behind the size of the file then.
      ImageStream.Seek({0 +} ImageSection.PointerToRawData, soBeginning);
      ImageStream.CopyFrom(Data, 0);
      X := 0;
      for I := 1 to NeedFill do
        ImageStream.WriteBuffer(X, 1);
    except
      Result := False;
    end;
  finally
    ImageStream.Free;
  end;
end;

function InsertCompressedDebugDataIntoExecutableFile(
  const ExecutableFileName, MapFileName: TFileName;
  out LinkerBugUnit: string;
  out MapFileSize, JclDebugDataSize, CompressedJdbgFileSize, LineNumberErrors: Integer): Boolean;
var
  JDbgFileName: TFileName;
  Generator: TJclBinDebugGenerator;
  CompressedDebugInfo: TMemoryStream;
  Compressor: TStream;
begin
  JDbgFileName := ChangeFileExt(MapFileName, JclDbgFileExtension);
  Generator := TJclBinDebugGenerator.Create(MapFileName, 0);
  try
    MapFileSize := Generator.Stream.Size;
    JclDebugDataSize := Generator.DataStream.Size;
    CompressedJdbgFileSize := 0;
    Result := (Generator.DataStream.Size > 0) and Generator.CalculateCheckSum;
    if Result then
    begin
      CompressedDebugInfo := TMemoryStream.Create;
      try
        Compressor := TJclZLibCompressStream.Create(CompressedDebugInfo);
        try
          Compressor.CopyFrom(Generator.DataStream, 0);
        finally
          Compressor.Free;
        end;
        CompressedJdbgFileSize := CompressedDebugInfo.Size;
        Result := InsertDataIntoExecutableFile(ExecutableFileName, CompressedDebugSection, CompressedDebugInfo);
      finally
        CompressedDebugInfo.Free;
      end;
    end;
    LinkerBugUnit := Generator.LinkerBugUnitName;
    LineNumberErrors := Generator.LineNumberErrors;
  finally
    Generator.Free;
  end;
end;

{ TJclDebugInfoCompressedBinary }

destructor TJclDebugInfoCompressedBinary.Destroy;
begin
  FreeAndNil(FScanner);
  FreeAndNil(FStream);
  inherited Destroy;
end;

function TJclDebugInfoCompressedBinary.GetLocationInfo(const Addr: Pointer;
  out Info: TJclLocationInfo): Boolean;
var
  VA: DWORD;
begin
  VA := VAFromAddr(Addr);
  with FScanner do
  begin
    Info.UnitName := ModuleNameFromAddr(VA);
    Result := Info.UnitName <> '';
    if Result then
    begin
      Info.Address := Addr;
      Info.ProcedureName := ProcNameFromAddr(VA, Info.OffsetFromProcName);
      Info.LineNumber := LineNumberFromAddr(VA, Info.OffsetFromLineNumber);
      Info.SourceName := SourceNameFromAddr(VA);
      Info.DebugInfo := Self;
      Info.BinaryFileName := FileName;
    end;
  end;
end;

function TJclDebugInfoCompressedBinary.InitializeSource: Boolean;
var
  Stream, Decompressor: TStream;
begin
  Result := (PeMapImgFindSectionFromModule(Pointer(Module), CompressedDebugSection) <> nil);

  if Result then
  begin
    Stream := TJclPeSectionStream.Create(Module, CompressedDebugSection);
    try
      FStream := TMemoryStream.Create;

      Decompressor := TJclZLibDecompressStream.Create(Stream);
      try
        StreamCopy(Decompressor, FStream);
      finally
        Decompressor.Free;
      end;
    finally
      Stream.Free;
    end;

    FScanner := TJclBinDebugScanner.Create(FStream, True);
    Result := FScanner.ValidFormat;
  end;
end;

end.