home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / t_power / pack.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-11-17  |  10.6 KB  |  322 lines
  1. {$S-,I-,R-}
  2. {$M 3000, 30000, 200000}
  3.  
  4. program Pack;
  5.   {-Packs EXE file header structure}
  6.  
  7.   function StUpcase(S : string) : string;
  8.     {-Return uppercase of string}
  9.   var
  10.     I : integer;
  11.   begin
  12.     for I := 1 to length(S) do
  13.       S[I] := upcase(S[I]);
  14.     StUpcase := S;
  15.   end;
  16.  
  17.   function HasExtension(Name : string; var DotPos : Word) : Boolean;
  18.     {-Return whether and position of extension separator dot in a pathname}
  19.   var
  20.     I : Word;
  21.   begin
  22.     DotPos := 0;
  23.     for I := Length(Name) downto 1 do
  24.       if (Name[I] = '.') and (DotPos = 0) then
  25.         DotPos := I;
  26.     HasExtension := (DotPos > 0) and (Pos('\', Copy(Name, Succ(DotPos), 64)) = 0);
  27.   end;
  28.  
  29.   function ForceExtension(Name, Ext : string) : string;
  30.     {-Return a pathname with the specified extension attached}
  31.   var
  32.     DotPos : Word;
  33.   begin
  34.     if HasExtension(Name, DotPos) then
  35.       ForceExtension := Copy(Name, 1, DotPos)+Ext
  36.     else
  37.       ForceExtension := Name+'.'+Ext;
  38.   end;
  39.  
  40.   procedure Error(Msg : string);
  41.     {-Write error message and halt}
  42.   begin
  43.     if Msg <> '' then
  44.       WriteLn(^M^J, Msg);
  45.     Halt(1);
  46.   end;
  47.  
  48.   function BlkRead(var F : file; var Buffer; Size : Word) : Boolean;
  49.     {-Convenient shell around BlockRead}
  50.   var
  51.     BytesRead : Word;
  52.   begin
  53.     BlockRead(F, Buffer, Size, BytesRead);
  54.     BlkRead := (IoResult = 0) and (BytesRead = Size);
  55.   end;
  56.  
  57.   function BlkWrite(var F : file; var Buffer; Size : Word) : Boolean;
  58.     {-Convenient shell around BlockWrite}
  59.   var
  60.     BytesWritten : Word;
  61.   begin
  62.     BlockWrite(F, Buffer, Size, BytesWritten);
  63.     BlkWrite := (IoResult = 0) and (BytesWritten = Size);
  64.   end;
  65.  
  66.   procedure PackExe(ExeName, OutName : string);
  67.     {-Squeeze an EXE file by packing fixups into segment groups}
  68.   const
  69.     MaxRWbufSize = $8000;    {Max size of read/write buffer for EXE copying}
  70.     FlagWord = $FFFF;        {Flag segment changes in packed relocation table}
  71.     OrigIPofs = 3;           {Position of first patch word in NewLoader}
  72.     ShowRLEeffect = False;   {True to show value of run length encoding}
  73.     Threshold = 4;           {Bytes of overhead per RLE block}
  74.     MaxReloc = $3FFC;        {Maximum allowable relocation items}
  75.  
  76.     NewLoaderSize = 82;
  77.     NewLoader : array[1..NewLoaderSize] of Byte =
  78.     (
  79.      $EB, $08, $00, $00, $00, $00, $00, $00, $00, $00, $2E, $8C, $1E, $06, $00, $2E,
  80.      $8C, $06, $08, $00, $8C, $C3, $83, $C3, $10, $8C, $C8, $8E, $D8, $BE, $52, $00,
  81.      $FC, $AD, $3D, $FF, $FF, $75, $0B, $AD, $3D, $FF, $FF, $74, $0C, $03, $C3, $8E,
  82.      $C0, $AD, $8B, $F8, $26, $01, $1D, $EB, $E8, $2E, $8E, $06, $08, $00, $2E, $8E,
  83.      $1E, $06, $00, $8B, $C3, $2E, $03, $06, $04, $00, $50, $2E, $A1, $02, $00, $50,
  84.      $CB, $90
  85.      );
  86.  
  87.   type
  88.     ExeHeaderRec =           {Information describing EXE file}
  89.     record
  90.       Signature : Word;      {EXE file signature}
  91.       LengthRem : Word;      {Number of bytes in last page of EXE image}
  92.       LengthPages : Word;    {Number of 512 byte pages in EXE image}
  93.       NumReloc : Word;       {Number of relocation items}
  94.       HeaderSize : Word;     {Number of paragraphs in EXE header}
  95.       MinHeap, MaxHeap : Word; {Paragraphs to keep beyond end of image}
  96.       StackSeg, StackPtr : Word; {Initial SS:SP, StackSeg relative to image base}
  97.       CheckSum : Word;       {EXE file check sum, not used}
  98.       IpInit, CodeSeg : Word; {Initial CS:IP, CodeSeg relative to image base}
  99.       RelocOfs : Word;       {Bytes into EXE for first relocation item}
  100.       OverlayNum : Word;     {Overlay number, not used here}
  101.     end;
  102.     RelocRec =
  103.     record
  104.       Offset : Word;
  105.       Segment : Word;
  106.     end;
  107.     RelocArray = array[1..MaxReloc] of RelocRec;
  108.     PackedTable = array[1..$7FF0] of Word;
  109.     ReadWriteBuffer = array[1..MaxRWbufSize] of Byte;
  110.  
  111.   var
  112.     ExeF, OutF : file;
  113.     BytesRead, BytesWritten, RWbufSize,
  114.     I, TableSize, TablePos, LastSeg,
  115.     BlockSize, OldNumReloc, OldHeaderSize : Word;
  116.     OldExeSize, ExeSize, RLEbytes : LongInt;
  117.     LastByte : Byte;
  118.     ExeHeader : ExeHeaderRec;
  119.     RA : ^RelocArray;        {Old relocation table from input file}
  120.     PT : ^PackedTable;       {New relocation table after packing}
  121.     RWbuf : ^ReadWriteBuffer; {Read/write buffer for file copy}
  122.  
  123.     procedure SetTable(var TA : PackedTable; var TablePos : Word; Value : Word);
  124.       {-Put a value into packed table and increment the index}
  125.     begin
  126.       TA[TablePos] := Value;
  127.       Inc(TablePos);
  128.     end;
  129.  
  130.   begin
  131.  
  132.     {Make sure we don't overwrite the input}
  133.     if StUpcase(ExeName) = StUpcase(OutName) then
  134.       Error('Input and output files must differ');
  135.  
  136.     {Open the existing EXE file}
  137.     Assign(ExeF, ExeName);
  138.     Reset(ExeF, 1);
  139.     if IoResult <> 0 then
  140.       Error(ExeName+' not found');
  141.  
  142.     {Read the existing EXE header}
  143.     if not BlkRead(ExeF, ExeHeader, SizeOf(ExeHeaderRec)) then
  144.       Error('Error reading EXE file');
  145.  
  146.     with ExeHeader do begin
  147.  
  148.       {Assure it's a real EXE file}
  149.       if Signature <> $5A4D then
  150.         Error('File is not in EXE format');
  151.  
  152.       {Check the number of relocation items}
  153.       if NumReloc = 0 then
  154.         Error('No packing can be done. No output written');
  155.       if NumReloc > MaxReloc then
  156.         Error('Number of relocation items exceeds capacity of PACK');
  157.       if NumReloc shl 2 > MaxAvail then
  158.         Error('Insufficient memory');
  159.  
  160.       {Read the relocation items into memory}
  161.       GetMem(RA, NumReloc shl 2);
  162.       Seek(ExeF, RelocOfs);
  163.       if not BlkRead(ExeF, RA^, NumReloc shl 2) then
  164.         Error('Error reading EXE file');
  165.  
  166.       {Determine size of packed relocation table in bytes}
  167.       LastSeg := $FFFF;
  168.       TableSize := 0;
  169.       for I := 1 to NumReloc do
  170.         with RA^[I] do begin
  171.           if Segment <> LastSeg then begin
  172.             LastSeg := Segment;
  173.             {Table will hold FFFF as a flag, followed by new segment}
  174.             Inc(TableSize, 4);
  175.           end;
  176.           {Space for the offset in this record}
  177.           Inc(TableSize, 2);
  178.         end;
  179.       {Termination record}
  180.       Inc(TableSize, 4);
  181.  
  182.       {Build the packed relocation table in memory}
  183.       if TableSize > MaxAvail then
  184.         Error('Insufficient memory');
  185.  
  186.       GetMem(PT, TableSize);
  187.       LastSeg := $FFFF;
  188.       TablePos := 1;
  189.       for I := 1 to NumReloc do
  190.         with RA^[I] do begin
  191.           if Segment <> LastSeg then begin
  192.             LastSeg := Segment;
  193.             {Flag that the segment is changing}
  194.             SetTable(PT^, TablePos, FlagWord);
  195.             {Write the new segment}
  196.             SetTable(PT^, TablePos, Segment);
  197.           end;
  198.           {Write the offset in the segment}
  199.           SetTable(PT^, TablePos, Offset);
  200.         end;
  201.       {Write a termination record}
  202.       for I := 1 to 2 do
  203.         SetTable(PT^, TablePos, FlagWord);
  204.  
  205.       {Deallocate space for the old relocation array}
  206.       FreeMem(RA, NumReloc shl 2);
  207.  
  208.       {Allocate space for the read/write buffer}
  209.       if MaxAvail > MaxRWbufSize then
  210.         RWbufSize := MaxRWbufSize
  211.       else
  212.         RWbufSize := MaxAvail;
  213.       GetMem(RWbuf, RWbufSize);
  214.  
  215.       {Save some items we'll need later}
  216.       OldNumReloc := NumReloc; {items}
  217.       OldHeaderSize := HeaderSize; {paragraphs}
  218.       if LengthRem = 0 then
  219.         OldExeSize := LongInt(LengthPages) shl 9
  220.       else
  221.         OldExeSize := (LongInt(Pred(LengthPages)) shl 9)+LongInt(LengthRem);
  222.  
  223.       {Change the header to accomodate the packing}
  224.       {No fixups remain after packing}
  225.       NumReloc := 0;
  226.       {Headersize shrinks to size of header record, rounded to para boundary}
  227.       HeaderSize := (SizeOf(ExeHeaderRec)+15) shr 4; {paragraphs}
  228.       {Patch initial CS:IP into the new loader}
  229.       Move(IpInit, NewLoader[OrigIPofs], 4);
  230.       {Set up so our loader executes first}
  231.       IpInit := 0;
  232.       CodeSeg := Succ(OldExeSize shr 4)-OldHeaderSize; {paragraphs}
  233.  
  234.       {Compute new exesize}
  235.       ExeSize := (LongInt(HeaderSize)+LongInt(CodeSeg)) shl 4
  236.       +LongInt(NewLoaderSize)+LongInt(TableSize); {bytes}
  237.       if ExeSize >= OldExeSize then
  238.         Error('Packed size exceeds original. No output written');
  239.  
  240.       if (ExeSize and 511) = 0 then begin
  241.         {An exact number of pages}
  242.         LengthPages := ExeSize shr 9;
  243.         LengthRem := 0;
  244.       end else begin
  245.         LengthPages := Succ(ExeSize shr 9);
  246.         LengthRem := ExeSize-LongInt(Pred(LongInt(LengthPages)) shl 9);
  247.       end;
  248.  
  249.       {Create the new EXE file}
  250.       Assign(OutF, OutName);
  251.       Rewrite(OutF, 1);
  252.       if IoResult <> 0 then
  253.         Error('Could not create '+OutName);
  254.  
  255.       {Write the new header}
  256.       if not BlkWrite(OutF, ExeHeader, (HeaderSize shl 4)) then
  257.         Error('Error writing EXE file');
  258.  
  259.       {Transfer the code from old to new program}
  260.       Seek(ExeF, OldHeaderSize shl 4);
  261.  
  262.       {Initialize parameters for run length encoding}
  263.       LastByte := 0;
  264.       BlockSize := 0;
  265.       RLEbytes := 00;
  266.  
  267.       repeat
  268.         BlockRead(ExeF, RWbuf^, RWbufSize, BytesRead);
  269.         if IoResult <> 0 then
  270.           Error('Error reading EXE file');
  271.         if BytesRead <> 0 then begin
  272.           if not BlkWrite(OutF, RWbuf^, BytesRead) then
  273.             Error('Error writing EXE file');
  274.  
  275.           if ShowRLEeffect then
  276.             {Check to see how much run length packing would save}
  277.             for I := 1 to BytesRead do
  278.               if RWbuf^[I] = LastByte then
  279.                 Inc(BlockSize)
  280.               else begin
  281.                 LastByte := RWbuf^[I];
  282.                 if BlockSize > Threshold then
  283.                   Inc(RLEbytes, BlockSize-Threshold);
  284.                 BlockSize := 0;
  285.               end;
  286.         end;
  287.       until BytesRead = 0;
  288.  
  289.       if ShowRLEeffect then
  290.         if BlockSize > Threshold then
  291.           Inc(RLEbytes, BlockSize-Threshold);
  292.  
  293.       {Write the loader to the new program}
  294.       Seek(OutF, (LongInt(HeaderSize)+LongInt(CodeSeg)) shl 4);
  295.       if not BlkWrite(OutF, NewLoader, NewLoaderSize) then
  296.         Error('Error writing EXE file');
  297.  
  298.       {Write the packed loader table to the program}
  299.       if not BlkWrite(OutF, PT^, TableSize) then
  300.         Error('Error writing EXE file');
  301.  
  302.       if ShowRLEeffect then
  303.         WriteLn('Run length packing would save ', RLEbytes, ' bytes');
  304.  
  305.     end;
  306.  
  307.     {Release heap space we allocated}
  308.     FreeMem(PT, TableSize);
  309.     FreeMem(RWbuf, RWbufSize);
  310.  
  311.     {Close up the files}
  312.     Close(ExeF);
  313.     Close(OutF);
  314.   end;
  315.  
  316. begin
  317.   if ParamCount < 2 then
  318.     Error('Usage: PACK OldExeName NewExeName');
  319.   {Modify the EXE file}
  320.   PackExe(ForceExtension(ParamStr(1), 'EXE'), ForceExtension(ParamStr(2), 'EXE'));
  321. end.
  322.