Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/BONUS40.ZIP/EXEUTIL.ZIP/EXEINFO.PAS

Pascal/Delphi Source File | 1988-01-27 | 9.9 KB | 332 lines

{$R-,S-,I-}

program ExeInfo;
  {-Write information about a Turbo Pascal 4.0 EXE file}
  {-Offer quick patches to heap and stack size}

type
  ExeHeaderRec =             {Information describing EXE file}
  record
    Signature : Word;        {EXE file signature}
    LengthRem : Word;        {Number of bytes in last page of EXE image}
    LengthPages : Word;      {Number of 512 byte pages in EXE image}
    NumReloc : Word;         {Number of relocation items}
    HeaderSize : Word;       {Number of paragraphs in EXE header}
    MinHeap, MaxHeap : Word; {Paragraphs to keep beyond end of image}
    StackSeg, StackPtr : Word; {Initial SS:SP, StackSeg relative to image base}
    CheckSum : Word;         {EXE file check sum, not used}
    IpInit, CodeSeg : Word;  {Initial CS:IP, CodeSeg relative to image base}
    RelocOfs : Word;         {Bytes into EXE for first relocation item}
    OverlayNum : Word;       {Overlay number, not used here}
  end;

  RelocRec =
  record
    Offset : Word;
    Segment : Word;
  end;

var
  Patch : Boolean;
  ShowFixups : Boolean;
  ExeName : string[64];

const
  Digits : array[0..$F] of Char = '0123456789ABCDEF';

  function HexW(W : Word) : string;
    {-Return hex string for word}
  begin
    HexW[0] := #4;
    HexW[1] := Digits[hi(W) shr 4];
    HexW[2] := Digits[hi(W) and $F];
    HexW[3] := Digits[lo(W) shr 4];
    HexW[4] := Digits[lo(W) and $F];
  end;

  function StUpcase(S : string) : string;
    {-Return uppercase of string}
  var
    I : integer;
  begin
    for I := 1 to length(S) do
      S[I] := upcase(S[I]);
    StUpcase := S;
  end;

  function HasExtension(Name : string; var DotPos : Word) : Boolean;
    {-Return whether and position of extension separator dot in a pathname}
  var
    I : Word;
  begin
    DotPos := 0;
    for I := Length(Name) downto 1 do
      if (Name[I] = '.') and (DotPos = 0) then
        DotPos := I;
    HasExtension := (DotPos > 0) and (Pos('\', Copy(Name, Succ(DotPos), 64)) = 0);
  end;

  function ForceExtension(Name, Ext : string) : string;
    {-Return a pathname with the specified extension attached}
  var
    DotPos : Word;
  begin
    if HasExtension(Name, DotPos) then
      ForceExtension := Copy(Name, 1, DotPos)+Ext
    else
      ForceExtension := Name+'.'+Ext;
  end;

  procedure Error(Msg : string);
    {-Report error and halt}
  begin
    if Msg <> '' then
      WriteLn(^M^J, Msg);
    Halt(1);
  end;

  procedure WriteHelp;
    {-Show a brief help screen}
  begin
    WriteLn;
    WriteLn('Usage: EXEINFO [Options] ExeName');
    WriteLn('Options:');
    WriteLn('  /P    Prompt for new stack and heap sizes');
    WriteLn('  /F    Show a detailed list of relocation fixups');
    Halt(1);
  end;

  procedure ParseCommandLine;
    {-Analyze the command line from DOS}
  var
    I : Integer;
    Arg : string;
  begin
    Patch := False;
    ShowFixups := False;
    ExeName := '';
    I := 1;
    while I <= ParamCount do begin
      Arg := stupcase(ParamStr(I));
      if (Arg = '/P') or (Arg = '-P') then
        Patch := True
      else if (Arg = '/F') or (Arg = '-F') then
        ShowFixups := True
      else if Length(ExeName) = 0 then
        ExeName := ForceExtension(Arg, 'EXE')
      else
        Error('Invalid command line');
      Inc(I);
    end;
    if Length(ExeName) = 0 then
      WriteHelp;
  end;

  function PtrDiff(HiPt, LoPt : Pointer) : LongInt;
    {-Return the number of bytes between point HiPt^ and point LoPt^}
  var
    HiVal, LoVal : LongInt;
  begin
    HiVal := LongInt(Seg(HiPt^)) shl 4+LongInt(Ofs(HiPt^));
    LoVal := LongInt(Seg(LoPt^)) shl 4+LongInt(Ofs(LoPt^));
    PtrDiff := HiVal-LoVal;
  end;

  function BlkRead(var F : file; var Buffer; Size : Word) : Boolean;
    {-Convenient shell around BlockRead}
  var
    BytesRead : Word;
  begin
    BlockRead(F, Buffer, Size, BytesRead);
    BlkRead := (IoResult = 0) and (BytesRead = Size);
  end;

  function BlkWrite(var F : file; var Buffer; Size : Word) : Boolean;
    {-Convenient shell around BlockWrite}
  var
    BytesWritten : Word;
  begin
    BlockWrite(F, Buffer, Size, BytesWritten);
    BlkWrite := (IoResult = 0) and (BytesWritten = Size);
  end;

  function GetDataSeg(var ExeF : file; ExeHeader : ExeHeaderRec) : Word;
    {-Return the data segment of a Turbo EXE file}
  type
    FirstCallRec =
    record
      CallInstr : Byte;
      Offset : Word;
      Segment : Word;
    end;
    SetupDsRec =
    record
      MovInstr : Byte;
      Segment : Word;
    end;
  var
    Fcall : FirstCallRec;
    SetupDs : SetupDsRec;
    BaseCodeSeg : LongInt;
    BytesRead : Word;
  begin
    Reset(ExeF, 1);

    with ExeHeader do begin
      BaseCodeSeg := (LongInt(HeaderSize)+LongInt(CodeSeg)) shl 4;
      Seek(ExeF, BaseCodeSeg+IpInit);
      if IoResult <> 0 then
        Error('Error during file seek');
    end;
    if not BlkRead(ExeF, Fcall, SizeOf(FirstCallRec)) then
      Error('Error reading EXE file');

    {Interpret the first far call to the SYSTEM library initialization block}
    with Fcall do begin
      if CallInstr <> $9A then
        Error('Not a Turbo Pascal 4.0 EXE file');
      Seek(ExeF, BaseCodeSeg+(LongInt(Segment) shl 4)+LongInt(Offset));
      if IoResult <> 0 then
        Error('Error during file seek');
    end;
    if not BlkRead(ExeF, SetupDs, SizeOf(SetupDsRec)) then
      Error('Error reading EXE file');

    {Interpret a MOV DX,dataseg instruction}
    with SetupDs do begin
      if MovInstr <> $BA then
        Error('Not a Turbo Pascal 4.0 EXE file');
      GetDataSeg := Segment;
    end;
  end;

  function ReadLongInt(Msg : string; default, min, max : LongInt) : LongInt;
    {-Prompt for and get a long integer value}
  var
    s : string;
    value : LongInt;
    code : Word;
  begin
    repeat
      Write(Msg, ' [', default, '] ');
      ReadLn(s);
      if s = '' then begin
        ReadLongInt := default;
        Exit;
      end;
      Val(s, value, code);
      if code <> 0 then
        WriteLn('Invalid integer')
      else if (value < min) or (value > max) then
        WriteLn('Value must be in range ', min, ' to ', max)
      else begin
        ReadLongInt := value;
        Exit;
      end;
    until False;
  end;

  procedure DumpExeHeader(ExeName : string);
    {-Dump the EXE file header and relocation records}
  var
    ExeF : file;
    ExeHeader : ExeHeaderRec;
    BytesRead, I, LastSeg, ItemCount, DataSeg,
    InitDataParas, UninitDataParas, StackAndStatic : Word;
    ExeSize : LongInt;
    MnHeap : LongInt;
    MxHeap : LongInt;
    L : LongInt;
    Rel : RelocRec;
  begin

    Assign(ExeF, ExeName);
    Reset(ExeF, 1);
    if IoResult <> 0 then
      Error(ExeName+' not found');

    if not BlkRead(ExeF, ExeHeader, SizeOf(ExeHeaderRec)) then
      Error('Error reading EXE file');

    with ExeHeader do begin

      if Signature <> $5A4D then
        Error('File is not in EXE format');

      if LengthRem = 0 then
        ExeSize := LongInt(LengthPages) shl 9
      else
        ExeSize := (LongInt(Pred(LengthPages)) shl 9)+LongInt(LengthRem);

      DataSeg := GetDataSeg(ExeF, ExeHeader);
      InitDataParas := (ExeSize shr 4)-HeaderSize-DataSeg;
      UninitDataParas := StackSeg-DataSeg-InitDataParas;
      StackAndStatic := (StackPtr shr 4)+UninitDataParas;
      MnHeap := LongInt(MinHeap-StackAndStatic) shl 4;
      MxHeap := LongInt(MaxHeap-StackAndStatic) shl 4;

      WriteLn;
      WriteLn('Code size:        ', PtrDiff(Ptr(DataSeg, 0), Ptr(CodeSeg, 0)), ' bytes');
      WriteLn('Init data:        ', LongInt(InitDataParas) shl 4, ' bytes');
      WriteLn('Uninit data:      ', LongInt(UninitDataParas) shl 4, ' bytes');
      WriteLn('Stack:            ', StackPtr, ' bytes');
      WriteLn('Min heap:         ', MnHeap, ' bytes');
      WriteLn('Max heap:         ', MxHeap, ' bytes');
      WriteLn;
      WriteLn('EXE file size:    ', ExeSize, ' bytes');
      WriteLn('Size of header:   ', LongInt(HeaderSize) shl 4, ' bytes');
      WriteLn('Number of fixups: ', NumReloc);
      WriteLn('Code start:       ', HexW(CodeSeg), ':', HexW(IpInit));
      WriteLn('Data segment:     ', HexW(DataSeg), ':', HexW(0));
      WriteLn('Initial stack:    ', HexW(StackSeg), ':', HexW(StackPtr));

      if Patch then begin
        WriteLn;
        StackPtr := ReadLongInt('Enter stack size in bytes', StackPtr, 0, 65500);
        L := ReadLongInt('Enter minimum heap size in bytes', MnHeap, 0, 1048576);
        StackAndStatic := (StackPtr shr 4)+UninitDataParas;
        MinHeap := StackAndStatic+(L shr 4);
        L := ReadLongInt('Enter maximum heap size in bytes', MxHeap, MnHeap, 1048576);
        MaxHeap := StackAndStatic+(L shr 4);
        Reset(ExeF, 1);
        if not BlkWrite(ExeF, ExeHeader, SizeOf(ExeHeaderRec)) then
          Error('Error writing EXE file');
      end else if ShowFixups then begin
        {Provide a detailed dump of segment fixups}
        WriteLn;
        {        123456789012345678901234567890}
        {        ssss     nnnn   }
        WriteLn('Segment  Fixups');

        Seek(ExeF, RelocOfs);
        if IoResult <> 0 then
          Error('Error during file seek');

        LastSeg := $FFFF;
        ItemCount := 0;

        for I := 1 to NumReloc do begin
          if not BlkRead(ExeF, Rel, SizeOf(RelocRec)) then
            Error('Error reading EXE file');
          with Rel do begin
            if Segment <> LastSeg then begin
              if ItemCount <> 0 then
                WriteLn('     ', ItemCount);
              Write(HexW(Segment));
              LastSeg := Segment;
              ItemCount := 0;
            end;
            Inc(ItemCount);
          end;
        end;
        WriteLn('     ', ItemCount);
      end;
    end;
    Close(ExeF);
  end;

begin
  ParseCommandLine;
  DumpExeHeader(ExeName);
end.