home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DEARC7.ZIP / DEARC7.PAS
Encoding:
Pascal/Delphi Source File  |  1988-02-11  |  37.7 KB  |  1,261 lines
  1. {
  2. ==============================================================================
  3. DEARC.PAS - Program to extract all files from an archive created by version
  4.              5.12 or earlier of the ARC utility.
  5.  
  6.              ARC is COPYRIGHT 1985 by System Enhancement Associates.
  7.  
  8.   This program requires Turbo Pascal Version 4.01. It should work in all
  9.   supported environments (PCDOS, CPM, etc.) but it has only been tested on
  10.   an IBM PC running PC DOS version 3.10.
  11.  
  12. Usage:  DEARC arcname
  13.  
  14.     arcname      : path/file name of the archive file.
  15.  
  16.     All files will be extracted into the current directory.
  17.  
  18. Modification History:
  19.  
  20.   *** ORIGINAL AUTHOR UNKNOWN ***
  21.  
  22.   Version 1.01 - 10/19/85. Changed end-of-file processing to, hopefully, be
  23.                            more compatible with CPM (whatever that is).
  24.  
  25.   Version 1.01A - 12/19/85 By Roy Collins
  26.                            Mail: TechMail BBS @ 703-430-2535
  27.                                  - or -
  28.                                  P.O.Box 1192, Leesburg, Va 22075
  29.                            Modified V1.01 to work with Turbo Pascal Version 2
  30.                            Added functions ARGC (argument count) and ARGV
  31.                            (argument value)
  32.                            Modified all references to "EXIT" command to be
  33.                            GOTO EXIT, with EXIT defined as a LABEL, at the
  34.                            end of the function/procedure involved.
  35.                            Will not accept path names - archives must be in
  36.                            the current directory.
  37.  
  38.   Version 2.00 - 6/11/86   By David W. Carroll
  39.                            Mail: High Sierra RBBS-PC @ 209/296-3534
  40.                            Now supports ARC version 5.12 files, compression
  41.                            types 7 and 8.
  42.  
  43.   Version 3.00 - 7/30/87   By Richard P. Byrne
  44.                            UN*X E-Mail:  ...!ihnp4!mduxf!rpb
  45.                            BBS Mail:     Software Society BBS @ (201) 729-7410
  46.                            Modified Version 2.00 to handle compression type
  47.                            9 (ie. Squashed ).
  48.  
  49.   Version 3.01 - 11/23/87  By Robert D. Tolz
  50.                            Compuserve 70475,1071
  51.                            BBS (914) 762-8150
  52.                            Modified Version 3.00 solely to comment how to
  53.                            obtain extracted files which are precisely the
  54.                            same length as the files which were archived.
  55.                            Prior versions would extract in 128-byte
  56.                            multiples.  Problem with precise extraction is
  57.                            that it increases extraction time (already
  58.                            quite slow compared to PKXARC and ARC-E) by
  59.                            several times.  Search for the term "PRECISE"
  60.                            to see the 3 changes necessary to the code.
  61.                            I invite the next person who tries their hand
  62.                            at this code to try (1) to increase speed
  63.                            and/or (2) to find a method to extract precisely
  64.                            only specific files that need it and leave the
  65.                            faster 128-byte block method for other files.
  66.  
  67.   Version 4.0  -  1/23/88  By Jim North
  68.                            Compuserve 70357,2701
  69.                            Changes are as follows:
  70.                             - Convert to TP version 4.0
  71.                             - Rewrote file I/O to make use of large
  72.                               file buffering in heap while still
  73.                               maintaining precise size of extracted
  74.                               files. This resulted in dramatic speed
  75.                               improvements.
  76.                             - Program now skips files it can't de-arc
  77.                               (because of new compression method) instead
  78.                               of aborting. Will extract all files it can
  79.                               de-arc.
  80.                             - Added check for the extract file already
  81.                               existing. If it does, a warning is issued
  82.                               with an "Overwrite(Y/N)" option.
  83.                             - Beefed up I/O error reporting.
  84.                             - Edited and re-organized source. Added some
  85.                               comments.
  86.                            No functional changes were made to the actual
  87.                            de-arc routines.
  88.  
  89. ==============================================================================
  90. }
  91. Program DEARC;
  92.  
  93. {$R-}    {Range checking off}
  94. {$B+}    {Boolean complete evaluation on}
  95. {$S-}    {Stack checking off}
  96. {$I+}    {I/O checking on}
  97. {$N-}    {No numeric coprocessor}
  98. {$M 65500,16384,655360} {Turbo 3 default stack and heap}
  99.  
  100. Const BLOCKSIZE = $D000;           { size of file buffers in heap }
  101.       ARCMARC   = 26;              { special archive marker }
  102.       ARCVER    = 9;               { max archive header version code }
  103.       STRLEN    = 100;             { standard string length }
  104.       FNLEN     = 12;              { file name length - 1 }
  105.       { ---  crc table --- }
  106.       CRCTAB : array [0..255] of word =
  107.                ( $0000, $C0C1, $C181, $0140, $C301, $03C0, $0280, $C241,
  108.                  $C601, $06C0, $0780, $C741, $0500, $C5C1, $C481, $0440,
  109.                  $CC01, $0CC0, $0D80, $CD41, $0F00, $CFC1, $CE81, $0E40,
  110.                  $0A00, $CAC1, $CB81, $0B40, $C901, $09C0, $0880, $C841,
  111.                  $D801, $18C0, $1980, $D941, $1B00, $DBC1, $DA81, $1A40,
  112.                  $1E00, $DEC1, $DF81, $1F40, $DD01, $1DC0, $1C80, $DC41,
  113.                  $1400, $D4C1, $D581, $1540, $D701, $17C0, $1680, $D641,
  114.                  $D201, $12C0, $1380, $D341, $1100, $D1C1, $D081, $1040,
  115.                  $F001, $30C0, $3180, $F141, $3300, $F3C1, $F281, $3240,
  116.                  $3600, $F6C1, $F781, $3740, $F501, $35C0, $3480, $F441,
  117.                  $3C00, $FCC1, $FD81, $3D40, $FF01, $3FC0, $3E80, $FE41,
  118.                  $FA01, $3AC0, $3B80, $FB41, $3900, $F9C1, $F881, $3840,
  119.                  $2800, $E8C1, $E981, $2940, $EB01, $2BC0, $2A80, $EA41,
  120.                  $EE01, $2EC0, $2F80, $EF41, $2D00, $EDC1, $EC81, $2C40,
  121.                  $E401, $24C0, $2580, $E541, $2700, $E7C1, $E681, $2640,
  122.                  $2200, $E2C1, $E381, $2340, $E101, $21C0, $2080, $E041,
  123.                  $A001, $60C0, $6180, $A141, $6300, $A3C1, $A281, $6240,
  124.                  $6600, $A6C1, $A781, $6740, $A501, $65C0, $6480, $A441,
  125.                  $6C00, $ACC1, $AD81, $6D40, $AF01, $6FC0, $6E80, $AE41,
  126.                  $AA01, $6AC0, $6B80, $AB41, $6900, $A9C1, $A881, $6840,
  127.                  $7800, $B8C1, $B981, $7940, $BB01, $7BC0, $7A80, $BA41,
  128.                  $BE01, $7EC0, $7F80, $BF41, $7D00, $BDC1, $BC81, $7C40,
  129.                  $B401, $74C0, $7580, $B541, $7700, $B7C1, $B681, $7640,
  130.                  $7200, $B2C1, $B381, $7340, $B101, $71C0, $7080, $B041,
  131.                  $5000, $90C1, $9181, $5140, $9301, $53C0, $5280, $9241,
  132.                  $9601, $56C0, $5780, $9741, $5500, $95C1, $9481, $5440,
  133.                  $9C01, $5CC0, $5D80, $9D41, $5F00, $9FC1, $9E81, $5E40,
  134.                  $5A00, $9AC1, $9B81, $5B40, $9901, $59C0, $5880, $9841,
  135.                  $8801, $48C0, $4980, $8941, $4B00, $8BC1, $8A81, $4A40,
  136.                  $4E00, $8EC1, $8F81, $4F40, $8D01, $4DC0, $4C80, $8C41,
  137.                  $4400, $84C1, $8581, $4540, $8701, $47C0, $4680, $8641,
  138.                  $8201, $42C0, $4380, $8341, $4100, $81C1, $8081, $4040 );
  139.       { --- constants for unpack --- }
  140.       DLE = $90;
  141.       { --- constants for unsqueeze --- }
  142.       ERROR   = -1;
  143.       SPEOF   = 256;
  144.       NUMVALS = 256;               { 1 less than the number of values }
  145.       { --- constants for uncrunch --- }
  146.       TABSIZE   = 4096;
  147.       TABSIZEM1 = 4095;
  148.       NO_PRED   = -1;
  149.       EMPTY     = -1;
  150.       { --- constants for dynamic uncrunch --- }
  151.       CRUNCH_BITS = 12;
  152.       SQUASH_BITS = 13;
  153.       HSIZE = 8192;
  154.       INIT_BITS = 9;
  155.       FIRST = 257;
  156.       CLEAR = 256;
  157.       HSIZEM1 = 8191;
  158.       BITSM1 = 12;
  159.       RMASK : array[0..8] of byte =
  160.               ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);
  161.  
  162. Type  strtype = string[strlen];                { general string definition }
  163.       fntype  = array [0..fnlen] of char;      { file name definition }
  164.       buftype = array [1..BLOCKSIZE] of byte;  { file buffer def. (in heap) }
  165.       bufptr  = ^buftype;                      { pointer type for file buffer }
  166.       heads   = record                         { ARC file header record def }
  167.                   name   : fntype;
  168.                   size   : longint;
  169.                   date   : word;
  170.                   time   : word;
  171.                   crc    : word;
  172.                   length : longint;
  173.                 end;
  174.       { --- type definitions for unsqueeze --- }
  175.       nd      = record
  176.                   child : array [0..1] of integer;
  177.                 end;
  178.       { --- type definitions for uncrunch --- }
  179.       entry   = record
  180.                   used         : boolean;
  181.                   next         : integer;
  182.                   predecessor  : integer;
  183.                   follower     : byte;
  184.                 end;
  185.  
  186. Var   hdrver     : byte;        { holds header version (compression type) }
  187.       arcfile    : file;        { file variable for input (archive) file }
  188.       arcbuf     : bufptr;      { heap pointer for archive file buffer }
  189.       arcptr     : word;        { archive buffer location pointer }
  190.       arccount   : word;        { holds # of valid bytes in archive buffer }
  191.       arcname    : string[79];  { holds path & name of file being de-arced }
  192.       endfile    : boolean;     { end-of-file flag for archive file }
  193.       extfile    : file;        { file variable for output (de-arced) file }
  194.       extbuf     : bufptr;      { heap pointer for output file buffer }
  195.       extptr     : word;        { output file buffer location pointer }
  196.       extname    : strtype;     { holds name of current output file }
  197.       { --- variables for unpack --- }
  198.       state      : (NOHIST, INREP);
  199.       crcval     : word;
  200.       size       : longint;
  201.       lastc      : integer;
  202.       { --- variables for unsqueeze --- }
  203.       node       : array [0..NUMVALS] of nd;
  204.       bpos       : integer;
  205.       curin      : integer;
  206.       numnodes   : integer;
  207.       { --- variables for uncrunch --- }
  208.       stack      : array [0..TABSIZEM1] of byte;
  209.       sp         : integer;
  210.       string_tab : array [0..TABSIZEM1] of entry;
  211.       code_count : integer;
  212.       code       : integer;
  213.       firstc     : boolean;
  214.       oldcode    : integer;
  215.       finchar    : integer;
  216.       inbuf      : integer;
  217.       outbuf     : integer;
  218.       newhash    : boolean;
  219.       { --- variables for dynamic uncrunch --- }
  220.       bits,
  221.       n_bits,
  222.       maxcode    : integer;
  223.       prefix     : array[0..HSIZEM1] of integer;
  224.       suffix     : array[0..HSIZEM1] of byte;
  225.       buf        : array[0..BITSM1]  of byte;
  226.       clear_flg  : integer;
  227.       stack1     : array[0..HSIZEM1] of byte;
  228.       free_ent   : integer;
  229.       maxcodemax : integer;
  230.       offset,
  231.       sizex      : integer;
  232.       firstch    : boolean;
  233.  
  234.  
  235. {----------------------------------------------------------------------
  236.  PROCEDURE: Abort
  237.    Action         : Display error message [s] and terminate.
  238. ----------------------------------------------------------------------}
  239. Procedure Abort(s:strtype);
  240.   begin
  241.     writeln(s);
  242.     writeln('Returning to DOS');
  243.     halt;
  244.   end;
  245.  
  246.  
  247. {----------------------------------------------------------------------
  248.  FUNCTION: Fn_To_Str
  249.    Action         : Converts (fntype) parameter from C format (trailing
  250.                     0) to TP string format.
  251.    Parameters     : var (fntype)
  252.    Returns        : var converted to str
  253. ----------------------------------------------------------------------}
  254. Function Fn_To_Str(var fn: fntype): strtype;
  255.   Var s : strtype;
  256.       i : integer;
  257.   begin
  258.     s := '';
  259.     i := 0;
  260.     while fn[i] <> #0 do
  261.       begin
  262.         s := s + fn[i];
  263.         i := i + 1;
  264.       end;
  265.     fn_to_str := s;
  266.   end;
  267.  
  268.  
  269. {----------------------------------------------------------------------
  270.  PROCEDURE: IO_Test
  271.    Action         : Test ioresult. Reports fatal errors and terminates
  272. ----------------------------------------------------------------------}
  273. Procedure IO_Test;
  274.   var ec: word;
  275.   begin
  276.     ec:=ioresult;
  277.     if ec<>0 then
  278.       begin
  279.         case ec of
  280.           2   : writeln('File Not Found');
  281.           3   : writeln('Path Not Found');
  282.           5   : writeln('Directory Full');
  283.           101 : writeln('Disk Full');
  284.         else
  285.           writeln('IO Error # ',ec);
  286.         end;
  287.         writeln('Returning to DOS');
  288.         halt;
  289.     end;
  290.   end;
  291.  
  292.  
  293. {----------------------------------------------------------------------
  294.  PROCEDURE: Read_Arc_Block
  295.    Action         : Read a block of archive file into "arcbuf"
  296.    Globals Altered: arcptr, arccount, endfile
  297. ----------------------------------------------------------------------}
  298. Procedure Read_Arc_Block;
  299.   begin
  300.     if eof(arcfile) then
  301.       endfile := TRUE
  302.     else
  303.       BlockRead(arcfile, arcbuf^, BLOCKSIZE, arccount);
  304.     arcptr := 1;
  305.   end;
  306.  
  307.  
  308. {----------------------------------------------------------------------
  309.  PROCEDURE: Write_Ext_Block
  310.    Action         : Write a [extptr-1] bytes from "extbuf" to disk.
  311.    Globals Altered: extptr
  312. ----------------------------------------------------------------------}
  313. Procedure Write_Ext_Block;
  314.   begin
  315.     if extptr > 1 then
  316.       begin
  317.         {$I-}
  318.         BlockWrite(extfile, extbuf^, extptr-1);
  319.         {$I+}
  320.         IO_Test;
  321.         extptr := 1;
  322.       end;
  323.   end;
  324.  
  325.  
  326. {----------------------------------------------------------------------
  327.  PROCEDURE: Open_Arc
  328.    Action         : Open archive file [arcname] for input.
  329.    Globals Altered: arcfile,endfile
  330. ----------------------------------------------------------------------}
  331. Procedure Open_Arc;
  332.   begin
  333.     assign(arcfile, arcname);
  334.     {$I-}
  335.     reset(arcfile,1);
  336.     {$I+}
  337.     IO_Test;
  338.     endfile := FALSE;
  339.     Read_Arc_Block;                            { pre-load buffer }
  340.   end;
  341.  
  342.  
  343. {----------------------------------------------------------------------
  344.  FUNCTION: Open_Ext
  345.    Action         : Create & open new destination file for extract.
  346.                     If file exists, asks user to verify overwrite.
  347.    Returns        : TRUE to proceed, FALSE if user says to skip.
  348.    Globals Altered: extfile,extptr
  349. ----------------------------------------------------------------------}
  350. Function Open_Ext:boolean;
  351.   label
  352.     exit;
  353.   var
  354.     yn : char;
  355.   begin
  356.     assign(extfile, extname);
  357.     {$I-}
  358.     reset(extfile,1);        { see if file exists }
  359.     {$I+}
  360.     if ioresult=0 then
  361.       begin
  362.         close(extfile);
  363.         write('WARNING: ',extname,' already exists. Overwrite(Y/N)?');
  364.         readln(yn);
  365.         if upcase(yn)<>'Y' then
  366.           begin
  367.             open_ext:=FALSE;
  368.             goto exit;
  369.           end;
  370.       end;
  371.     open_ext:=TRUE;
  372.     {$I-}
  373.     rewrite(extfile,1);
  374.     {$I+}
  375.     IO_Test;
  376.     extptr:=1;
  377.     exit:
  378.   end;
  379.  
  380.  
  381. {----------------------------------------------------------------------
  382.  FUNCTION: Get_Arc
  383.    Action         : Get next byte from "arcbuf". Calls Read_Arc_Block
  384.                     if buffer is empty.
  385.    Returns        : next byte or 0 if end of file
  386.    Globals Altered: arcptr
  387. ----------------------------------------------------------------------}
  388. Function Get_Arc: byte;
  389.   begin
  390.     if endfile then
  391.       Get_Arc := 0
  392.     else
  393.       begin
  394.         Get_Arc := arcbuf^[arcptr];
  395.         if arcptr = arccount then
  396.           Read_Arc_Block
  397.         else
  398.           arcptr := arcptr + 1
  399.       end;
  400.   end;
  401.  
  402.  
  403. {----------------------------------------------------------------------
  404.  PROCEDURE: Put_Ext
  405.    Action         : Write byte into "extbuf". Calls Write_Ext_Block
  406.                     if buffer is full.
  407.    Parameters     : byte to be written
  408.    Globals Altered: extptr
  409. ----------------------------------------------------------------------}
  410. Procedure Put_Ext(c : byte);
  411.   begin
  412.     extbuf^[extptr] := c;
  413.     extptr := extptr + 1;
  414.     if extptr > BLOCKSIZE then Write_Ext_Block;
  415.   end;
  416.  
  417.  
  418. {----------------------------------------------------------------------
  419.  PROCEDURE: Close_Arc
  420.    Action         : Close archive file.
  421. ----------------------------------------------------------------------}
  422. Procedure Close_Arc;
  423.   begin
  424.     {$I-}
  425.     close(arcfile);
  426.     {$I+}
  427.     IO_Test;
  428.   end;
  429.  
  430.  
  431. {----------------------------------------------------------------------
  432.  PROCEDURE: Close_Ext
  433.    Action         : Close extract file.
  434. ----------------------------------------------------------------------}
  435. Procedure Close_Ext;
  436.   begin
  437.     Write_Ext_Block;             { flush buffer }
  438.     {$I-}
  439.     close(extfile);
  440.     {$I+}
  441.     IO_Test;
  442.   end;
  443.  
  444.  
  445. {----------------------------------------------------------------------
  446.  PROCEDURE: FSkip
  447.    Action         : Skip over [offset] bytes of archive file
  448.    Parameters     : # of bytes to skip
  449.    Globals Altered: arcptr
  450. ----------------------------------------------------------------------}
  451. Procedure FSkip(offset: longint);
  452.   Var rec: longint;
  453.   begin
  454.     if (offset+arcptr)<=arccount then
  455.       arcptr:=arcptr+offset
  456.     else
  457.       begin
  458.         rec:=filepos(arcfile)+(offset-(arccount-arcptr)-1);
  459.         {$I-}
  460.         seek(arcfile,rec);
  461.         {$I+}
  462.         IO_Test;
  463.         Read_Arc_Block;
  464.       end;
  465.   end;
  466.  
  467.  
  468. {----------------------------------------------------------------------
  469.  PROCEDURE: FRead
  470.    Action         : Read variable length record from archive file
  471.    Parameters     : buf: destination buffer, reclen: length
  472.    Globals Altered:
  473. ----------------------------------------------------------------------}
  474. Procedure FRead(var buf; reclen : integer);
  475.   Var i : integer;
  476.       b : array [1..MaxInt] of byte absolute buf;
  477.   begin
  478.     for i := 1 to reclen do
  479.       b[i] := get_arc
  480.   end;
  481.  
  482.  
  483. {----------------------------------------------------------------------
  484.  FUNCTION: Read_Hdr
  485.    Action         : Read next header into [hdr] buffer.
  486.    Returns        : TRUE if ok, FALSE if end of file
  487.    Globals Altered: arcptr
  488. ----------------------------------------------------------------------}
  489. Function Read_Hdr(var hdr: heads): boolean;
  490.   label exit;
  491.   var name: fntype;
  492.   begin
  493.     if endfile then
  494.       begin
  495.         read_hdr:=FALSE; { end of file }
  496.         goto exit;
  497.       end;
  498.     if Get_Arc<>ARCMARC then Abort('Missing or invalid header in '+arcname);
  499.     hdrver:=Get_Arc;
  500.     if hdrver<0 then Abort ('Missing or invalid header in '+arcname);
  501.     if hdrver=0 then
  502.       begin
  503.         read_hdr:=FALSE; { end of file }
  504.         goto exit;
  505.       end;
  506.     if hdrver=1 then
  507.       begin
  508.         Fread(hdr,sizeof(heads)-sizeof(longint));
  509.         hdrver:=2;
  510.         hdr.length:=hdr.size;
  511.       end
  512.     else
  513.       fread(hdr,sizeof(heads));
  514.     read_hdr:=TRUE;
  515.     exit:
  516.   end;
  517.  
  518.  
  519. {----------------------------------------------------------------------
  520.  PROCEDURE: Putc_Unp
  521. ----------------------------------------------------------------------}
  522. Procedure Putc_Unp(c:integer);
  523.   begin
  524.     crcval:=((crcval shr 8) and $00FF) xor crctab[(crcval xor c) and $00FF];
  525.     put_ext(c)
  526.   end;
  527.  
  528.  
  529. {----------------------------------------------------------------------
  530.  PROCEDURE: Putc_Ncr
  531. ----------------------------------------------------------------------}
  532. Procedure Putc_Ncr(c:integer);
  533.   begin
  534.     case state of
  535.       NOHIST : if c=DLE then
  536.                  state:=INREP
  537.                else
  538.                  begin
  539.                    lastc:= c;
  540.                    putc_unp(c);
  541.                  end;
  542.       INREP  : begin
  543.                  if c=0 then
  544.                    putc_unp(DLE)
  545.                  else
  546.                    begin
  547.                      c:=c-1;
  548.                      while (c<>0) do
  549.                        begin
  550.                          putc_unp(lastc);
  551.                          c:=c-1;
  552.                        end;
  553.                    end;
  554.                  state:=NOHIST
  555.                end;
  556.     end;
  557.   end;
  558.  
  559.  
  560. {----------------------------------------------------------------------
  561.  FUNCTION: Getc_Unp
  562. ----------------------------------------------------------------------}
  563. Function Getc_Unp:integer;
  564.   begin
  565.     if size=0.0 then
  566.       getc_unp:=-1
  567.     else
  568.       begin
  569.         size:=size-1;
  570.         getc_unp:=get_arc;
  571.       end;
  572.   end;
  573.  
  574.  
  575. {----------------------------------------------------------------------
  576.  PROCEDURE: Init_Usq
  577.    Action   : Initialize for Unsqueeze
  578. ----------------------------------------------------------------------}
  579. Procedure Init_Usq;
  580.   var
  581.    i : integer;
  582.   begin
  583.     bpos:=99;
  584.     fread(numnodes,sizeof(numnodes));
  585.     if (numnodes<0) or (numnodes>NUMVALS) then
  586.       Abort(extname+' has an invalid decode tree');
  587.     node[0].child[0]:=-(SPEOF+1);
  588.     node[0].child[1]:=-(SPEOF+1);
  589.     for i:=0 to numnodes-1 do
  590.       begin
  591.         fread(node[i].child[0],sizeof(integer));
  592.         fread(node[i].child[1],sizeof(integer));
  593.       end;
  594.   end;
  595.  
  596.  
  597. {----------------------------------------------------------------------
  598.  FUNCTION: Getc_Usq
  599.    Action   : Unsqueeze a byte
  600. ----------------------------------------------------------------------}
  601. Function Getc_Usq:integer;
  602.   label exit;
  603.   var
  604.     i : integer;
  605.   begin
  606.     i:=0;
  607.     while i >= 0 do
  608.       begin
  609.         bpos:=bpos+1;
  610.         if bpos>7 then
  611.           begin
  612.             curin:=getc_unp;
  613.             if curin=ERROR then
  614.               begin
  615.                 getc_usq:=ERROR;
  616.                 goto exit;
  617.               end;
  618.             bpos:=0;
  619.             i:=node[i].child[1 and curin];
  620.           end
  621.         else
  622.           begin
  623.             curin:=curin shr 1;
  624.             i:=node[i].child[1 and curin];
  625.           end;
  626.       end;
  627.     i:=-(i + 1);
  628.     if i=SPEOF then
  629.       getc_usq:=-1
  630.     else
  631.       getc_usq:=i;
  632.     exit:
  633.   end;
  634.  
  635.  
  636. {----------------------------------------------------------------------
  637.  FUNCTION: H
  638.    Action   : Calculate hash value (thanks to Bella Lubkin)
  639. ----------------------------------------------------------------------}
  640. Function H(pred,foll: integer): integer;
  641.   var
  642.     Local : Real;
  643.     S     : String[20];
  644.     I, V  : integer;
  645.     C     : char;
  646.   begin
  647.     if not newhash then
  648.       begin
  649.         Local:=(pred+foll) or $0800;
  650.         if Local<0.0 then
  651.           Local:=Local+65536.0;
  652.         Local:=(Local*Local)/64.0;
  653.         { convert Local to an integer, truncating high order bits. }
  654.         { there ***MUST*** be a better way to do this!!! }
  655.         Str(Local:15:5,S);
  656.         V:=0;
  657.         I:=1;
  658.         C:=S[1];
  659.         while C<>'.' do
  660.           begin
  661.             if (C>='0') and (C<='9') then
  662.               V:=V*10+(Ord(C)-Ord('0'));
  663.             I:=I+1;
  664.             C:=S[I];
  665.           end;
  666.         h:=V and $0FFF;
  667.       end
  668.     else
  669.       begin
  670.         Local:=(pred+foll)*15073;
  671.         { convert Local to an integer, truncating high order bits. }
  672.         { there ***MUST*** be a better way to do this!!! }
  673.         Str(Local:15:5,S);
  674.         V:=0;
  675.         I:=1;
  676.         C:=S[1];
  677.         while C<>'.' do
  678.           begin
  679.             if (C>='0') and (C<='9') then
  680.               V:=V*10+(Ord(C)-Ord('0'));
  681.             I:=I+1;
  682.             C:=S[I];
  683.           end;
  684.         h:=V and $0FFF;
  685.       end;
  686.   end;
  687.  
  688.  
  689. {----------------------------------------------------------------------
  690.  FUNCTION: Eolist
  691. ----------------------------------------------------------------------}
  692. Function Eolist(index:integer):integer;
  693.   var
  694.     temp:integer;
  695.   begin
  696.     temp:=string_tab[index].next;
  697.     while temp<>0 do
  698.       begin
  699.         index:=temp;
  700.         temp:=string_tab[index].next;
  701.       end;
  702.     eolist:=index;
  703.   end;
  704.  
  705.  
  706. {----------------------------------------------------------------------
  707.  FUNCTION: Hash
  708. ----------------------------------------------------------------------}
  709. Function Hash(pred,foll:integer):integer;
  710.   var
  711.     local     : integer;
  712.     tempnext  : integer;
  713.   begin
  714.     local:=h(pred,foll);
  715.     if not string_tab[local].used then
  716.       hash:=local
  717.     else
  718.       begin
  719.         local:=eolist(local);
  720.         tempnext:=(local+101) and $0FFF;
  721.         while string_tab[tempnext].used do
  722.           begin
  723.             tempnext:=tempnext+1;
  724.             if tempnext=TABSIZE then
  725.               tempnext:=0;
  726.           end;
  727.         string_tab[local].next:=tempnext;
  728.         hash:=tempnext;
  729.       end;
  730.   end;
  731.  
  732. {----------------------------------------------------------------------
  733.  PROCEDURE: Upd_Tab
  734. ----------------------------------------------------------------------}
  735. Procedure Upd_Tab(pred,foll:integer);
  736.   begin
  737.     with string_tab[hash(pred, foll)] do
  738.       begin
  739.         used:=TRUE;
  740.         next:=0;
  741.         predecessor:=pred;
  742.         follower:=foll;
  743.       end;
  744.   end;
  745.  
  746. {----------------------------------------------------------------------
  747.  FUNCTION: Gocode
  748. ----------------------------------------------------------------------}
  749. Function Gocode:integer;
  750.   label exit;
  751.   var
  752.     localbuf  : integer;
  753.     returnval : integer;
  754.   begin
  755.     if inbuf=EMPTY then
  756.       begin
  757.         localbuf:=getc_unp;
  758.         if localbuf=-1 then
  759.           begin
  760.             gocode:=-1;
  761.             goto exit;
  762.           end;
  763.         localbuf:=localbuf and $00FF;
  764.         inbuf:=getc_unp;
  765.         if inbuf=-1 then
  766.           begin
  767.             gocode:=-1;
  768.             goto exit;
  769.           end;
  770.         inbuf:=inbuf and $00FF;
  771.         returnval:=((localbuf shl 4) and $0FF0)+((inbuf shr 4) and $000F);
  772.         inbuf:=inbuf and $000F;
  773.       end
  774.     else
  775.       begin
  776.         localbuf:=getc_unp;
  777.         if localbuf=-1 then
  778.           begin
  779.             gocode:=-1;
  780.             goto exit;
  781.           end;
  782.         localbuf:=localbuf and $00FF;
  783.         returnval:=localbuf+((inbuf shl 8) and $0F00);
  784.         inbuf:=EMPTY;
  785.       end;
  786.     gocode:=returnval;
  787.     exit:
  788.   end;
  789.  
  790.  
  791. {----------------------------------------------------------------------
  792.  FUNCTION: Push
  793. ----------------------------------------------------------------------}
  794. Procedure Push(c:integer);
  795.   begin
  796.     stack[sp]:=c;
  797.     sp:=sp+1;
  798.     if sp>=TABSIZE then
  799.       Abort('Stack overflow');
  800.   end;
  801.  
  802.  
  803. {----------------------------------------------------------------------
  804.  FUNCTION: Pop
  805. ----------------------------------------------------------------------}
  806. Function Pop:integer;
  807.   begin
  808.     if sp>0 then
  809.       begin
  810.         sp:=sp-1;
  811.         pop:=stack[sp];
  812.       end
  813.     else
  814.       pop:=EMPTY;
  815.   end;
  816.  
  817.  
  818. {----------------------------------------------------------------------
  819.  PROCEDURE: Init_Tab
  820. ----------------------------------------------------------------------}
  821. Procedure Init_Tab;
  822.   var
  823.     i : integer;
  824.   begin
  825.     FillChar(string_tab, sizeof(string_tab), 0);
  826.     for i := 0 to 255 do
  827.       upd_tab(NO_PRED, i);
  828.     inbuf := EMPTY;
  829.   { outbuf := EMPTY }
  830.   end;
  831.  
  832.  
  833. {----------------------------------------------------------------------
  834.  PROCEDURE: Init_Ucr
  835. ----------------------------------------------------------------------}
  836. Procedure Init_Ucr(i:integer);
  837.   begin
  838.     newhash:=(i=1);
  839.     sp:=0;
  840.     init_tab;
  841.     code_count:=TABSIZE-256;
  842.     firstc:=TRUE;
  843.   end;
  844.  
  845.  
  846. {----------------------------------------------------------------------
  847.  FUNCTION: Getc_Ucr
  848. ----------------------------------------------------------------------}
  849. Function Getc_Ucr:integer;
  850.   label exit;
  851.   var
  852.     c       : integer;
  853.     code    : integer;
  854.     newcode : integer;
  855.   begin
  856.     if firstc then
  857.       begin
  858.         firstc:=FALSE;
  859.         oldcode:=gocode;
  860.         finchar:=string_tab[oldcode].follower;
  861.         getc_ucr:=finchar;
  862.         goto exit;
  863.       end;
  864.     if sp=0 then
  865.       begin
  866.         newcode:=gocode;
  867.         code:=newcode;
  868.         if code=-1 then
  869.           begin
  870.             getc_ucr:=-1;
  871.             goto exit;
  872.           end;
  873.         if not string_tab[code].used then
  874.           begin
  875.             code:=oldcode;
  876.             push(finchar);
  877.           end;
  878.         while string_tab[code].predecessor <> NO_PRED do
  879.           with string_tab[code] do
  880.             begin
  881.               push(follower);
  882.               code:=predecessor;
  883.             end;
  884.         finchar:=string_tab[code].follower;
  885.         push(finchar);
  886.         if code_count<>0 then
  887.           begin
  888.             upd_tab(oldcode, finchar);
  889.             code_count:=code_count-1;
  890.           end;
  891.         oldcode:=newcode;
  892.       end;
  893.     getc_ucr:=pop;
  894.     exit:
  895.   end;
  896.  
  897.  
  898. {----------------------------------------------------------------------
  899.  FUNCTION: Getcode
  900. ----------------------------------------------------------------------}
  901. Function Getcode:integer;
  902.   label
  903.     next, exit;
  904.   var
  905.     code,
  906.     r_off,
  907.     bitsx : integer;
  908.     bp    : byte;
  909.   begin
  910.     if firstch then
  911.       begin
  912.         offset:=0;
  913.         sizex:=0;
  914.         firstch:=false;
  915.       end;
  916.     bp:=0;
  917.     if (clear_flg>0) or (offset>=sizex) or (free_ent>maxcode) then
  918.       begin
  919.         if free_ent>maxcode then
  920.           begin
  921.             n_bits:=n_bits+1;
  922.             if n_bits=BITS then
  923.               maxcode:=maxcodemax
  924.             else
  925.               maxcode:=(1 shl n_bits)-1;
  926.           end;
  927.         if clear_flg > 0 then
  928.           begin
  929.             n_bits:=INIT_BITS;
  930.             maxcode:=(1 shl n_bits)-1;
  931.             clear_flg:=0;
  932.           end;
  933.         for sizex := 0 to n_bits-1 do
  934.           begin
  935.             code:=getc_unp;
  936.             if code=-1 then
  937.               goto next
  938.             else
  939.               buf[sizex]:=code;
  940.           end;
  941.         sizex:=sizex+1;
  942.         next:
  943.         if sizex<=0 then
  944.           begin
  945.             getcode:=-1;
  946.             goto exit;
  947.           end;
  948.         offset:=0;
  949.         sizex:=(sizex shl 3)-(n_bits-1);
  950.       end;
  951.     r_off:=offset;
  952.     bitsx:=n_bits;
  953.     { get first byte }
  954.     bp:=bp+(r_off shr 3);
  955.     r_off:=r_off and 7;
  956.  
  957.     { get first parft (low order bits) }
  958.     code:=buf[bp] shr r_off;
  959.     bp:=bp+1;
  960.     bitsx:=bitsx-(8-r_off);
  961.     r_off:=8-r_off;
  962.  
  963.     if bitsx>=8 then
  964.       begin
  965.         code:=code or (buf[bp] shl r_off);
  966.         bp:=bp+1;
  967.         r_off:=r_off+8;
  968.         bitsx:=bitsx-8;
  969.       end;
  970.     code:=code or ((buf[bp] and rmask[bitsx]) shl r_off);
  971.     offset:=offset+n_bits;
  972.     getcode:=code;
  973.     exit:
  974.   end;
  975.  
  976.  
  977. {----------------------------------------------------------------------
  978.  PROCEDURE: Decomp
  979. ----------------------------------------------------------------------}
  980. Procedure Decomp(squashflag:integer);
  981.   label
  982.     next,exit;
  983.   var
  984.     stackp,
  985.     finchar  :integer;
  986.     code,
  987.     oldcode,
  988.     incode   :integer;
  989.   begin
  990.     if squashflag=0 then
  991.       bits:=crunch_BITS
  992.     else
  993.       bits:=squash_BITS;
  994.  
  995.     if firstch then
  996.       maxcodemax:=1 shl bits;
  997.  
  998.     if squashflag=0 then
  999.       begin
  1000.         code:=getc_unp;
  1001.         if code<>BITS then
  1002.           begin
  1003.             writeln(extname,' packed with ',Code,' bits, I can only handle ',Bits);
  1004.             halt;
  1005.           end;
  1006.       end;
  1007.     clear_flg:=0;
  1008.     n_bits:=INIT_BITS;
  1009.     maxcode:=(1 shl n_bits )-1;
  1010.     for code:=255 downto 0 do
  1011.       begin
  1012.         prefix[code]:=0;
  1013.         suffix[code]:=code;
  1014.       end;
  1015.  
  1016.     free_ent:=FIRST;
  1017.     oldcode:=getcode;
  1018.     finchar:=oldcode;
  1019.     if oldcode=-1 then
  1020.       goto exit;
  1021.     if squashflag=0 then
  1022.       putc_ncr(finchar)
  1023.     else
  1024.       putc_unp(finchar);
  1025.     stackp:=0;
  1026.  
  1027.     code:=getcode;
  1028.     while (code>-1) do
  1029.       begin
  1030.         if code=CLEAR then
  1031.           begin
  1032.             for code:=255 downto 0 do
  1033.               prefix[code]:=0;
  1034.             clear_flg:=1;
  1035.             free_ent:=FIRST-1;
  1036.             code:=getcode;
  1037.             if code=-1 then
  1038.               goto next;
  1039.           end;
  1040.         next:
  1041.         incode:=code;
  1042.         if code>=free_ent then
  1043.           begin
  1044.             stack1[stackp]:=finchar;
  1045.             stackp:=stackp+1;
  1046.             code:=oldcode;
  1047.           end;
  1048.         while (code>=256) do
  1049.           begin
  1050.             stack1[stackp]:=suffix[code];
  1051.             stackp:=stackp+1;
  1052.             code:=prefix[code];
  1053.           end;
  1054.         finchar:=suffix[code];
  1055.         stack1[stackp]:=finchar;
  1056.         stackp:=stackp+1;
  1057.         repeat
  1058.           stackp:=stackp-1;
  1059.           if squashflag=0 then
  1060.             putc_ncr(stack1[stackp])
  1061.           else
  1062.             putc_unp(stack1[stackp]);
  1063.         until stackp<=0;
  1064.         code:=free_ent;
  1065.         if code<maxcodemax then
  1066.           begin
  1067.             prefix[code]:=oldcode;
  1068.             suffix[code]:=finchar;
  1069.             free_ent:=code+1;
  1070.           end;
  1071.         oldcode:=incode;
  1072.         code:=getcode;
  1073.       end;
  1074.     exit:
  1075.   end;
  1076.  
  1077.  
  1078. {----------------------------------------------------------------------
  1079.  PROCEDURE: Unpack
  1080.    Action         : Unpack according to [hdrver] format.
  1081. ----------------------------------------------------------------------}
  1082. Procedure Unpack(var hdr:heads);
  1083.   label exit;
  1084.   var
  1085.     c:  integer;
  1086.   begin
  1087.     crcval  := 0;
  1088.     size    := hdr.size;
  1089.     state   := NOHIST;
  1090.     FirstCh := TRUE;
  1091.     case hdrver of
  1092.       1, 2 : begin
  1093.                c:=getc_unp;
  1094.                while c<>-1 do
  1095.                  begin
  1096.                    putc_unp(c);
  1097.                    c:=getc_unp;
  1098.                  end;
  1099.              end;
  1100.       3    : begin
  1101.                c:=getc_unp;
  1102.                while c<>-1 do
  1103.                  begin
  1104.                    putc_ncr(c);
  1105.                    c:=getc_unp;
  1106.                  end;
  1107.              end;
  1108.       4    : begin
  1109.                init_usq;
  1110.                c:=getc_usq;
  1111.                while c<>-1 do
  1112.                  begin
  1113.                    putc_ncr(c);
  1114.                    c:=getc_usq;
  1115.                  end;
  1116.              end;
  1117.       5    : begin
  1118.                init_ucr(0);
  1119.                c:=getc_ucr;
  1120.                while c<>-1 do
  1121.                  begin
  1122.                    putc_unp(c);
  1123.                    c:=getc_ucr;
  1124.                  end;
  1125.              end;
  1126.       6    : begin
  1127.                init_ucr(0);
  1128.                c:=getc_ucr;
  1129.                while c <> -1 do
  1130.                  begin
  1131.                    putc_ncr(c);
  1132.                    c:=getc_ucr;
  1133.                  end;
  1134.              end;
  1135.       7    : begin
  1136.                init_ucr(1);
  1137.                c:=getc_ucr;
  1138.                while c<>-1 do
  1139.                  begin
  1140.                    putc_ncr(c);
  1141.                    c:=getc_ucr;
  1142.                  end;
  1143.              end;
  1144.       8    : begin
  1145.                decomp(0);
  1146.              end;
  1147.       9    : begin
  1148.                decomp(1);
  1149.              end;
  1150.     end;
  1151.     if crcval<>hdr.crc then
  1152.       writeln('WARNING: File ',extname,' fails CRC check');
  1153.     exit:
  1154.   end;
  1155.  
  1156.  
  1157. {----------------------------------------------------------------------
  1158.  PROCEDURE: Extract_File
  1159.    Action         : Extract file specified in [hdr].
  1160. ----------------------------------------------------------------------}
  1161. Procedure Extract_File(var hdr:heads);
  1162.   begin
  1163.     writeln('Extracting: '+extname);
  1164.     if Open_Ext then
  1165.       begin
  1166.         Unpack(hdr);
  1167.         Close_Ext;
  1168.       end
  1169.     else
  1170.       begin
  1171.         writeln('Skipping: '+extname);
  1172.         FSkip(hdr.size);
  1173.       end;
  1174.   end;
  1175.  
  1176.  
  1177. {----------------------------------------------------------------------
  1178.  FUNCTION: Verify_File
  1179.    Action         : Verify that program can decompress file.
  1180.    Returns        : TRUE for proceed, FALSE for skip.
  1181. ----------------------------------------------------------------------}
  1182. Function Verify_File(var hdr:heads):boolean;
  1183.   begin
  1184.     verify_file:=TRUE; { default case }
  1185.     extname:= fn_to_str(hdr.name);
  1186.     if hdrver>ARCVER then
  1187.       begin
  1188.         writeln('Skipping: '+extname+' -- Try a newer version of DEARC');
  1189.         verify_file:=FALSE;
  1190.       end;
  1191.   end;
  1192.  
  1193.  
  1194. {----------------------------------------------------------------------
  1195.  PROCEDURE: Initialize
  1196.    Action         : Perform one-time initialization --
  1197.                       -- allocate file buffers in heap
  1198.                       -- print heading
  1199.    Globals Altered: arcbuf, extbuf
  1200. ----------------------------------------------------------------------}
  1201. Procedure Initialize;
  1202.   begin
  1203.     writeln;
  1204.     writeln('Turbo Pascal v4 De-ARC Utility');
  1205.     writeln('Version 4.0, 1/23/88');
  1206.     writeln('Supports Phil Katz "squashed" files');
  1207.     writeln;
  1208.     New(arcbuf);
  1209.     New(extbuf);
  1210.   end;
  1211.  
  1212. {----------------------------------------------------------------------
  1213.  PROCEDURE: Load_Parms
  1214.    Action         : Read Command-Line Parameters
  1215.    Globals Altered: arcname
  1216. ----------------------------------------------------------------------}
  1217. Procedure Load_Parms;
  1218.   var
  1219.     i   : integer;
  1220.   begin
  1221.     i:=ParamCount;
  1222.     if i>=1 then
  1223.       arcname:=ParamStr(1)
  1224.     else
  1225.       begin
  1226.         write('Enter archive filename: ');
  1227.         readln(arcname);
  1228.         if arcname='' then Abort('');
  1229.       end;
  1230.     for i:=1 to length(arcname) do
  1231.       arcname[i]:=UpCase(arcname[i]);
  1232.     if pos('.',arcname)=0 then
  1233.       arcname:=arcname+'.ARC';
  1234.   end;
  1235.  
  1236.  
  1237. {----------------------------------------------------------------------
  1238.  PROCEDURE: Extract_Arc
  1239.    Action         : Extract files from target archive file.
  1240.                      Skips files it can't decompress.
  1241. ----------------------------------------------------------------------}
  1242. Procedure Extract_Arc;
  1243.   var
  1244.     hdr: heads;
  1245.   begin
  1246.     Open_Arc;
  1247.     while Read_Hdr(hdr) do
  1248.       if Verify_File(hdr) then
  1249.         Extract_File(hdr)
  1250.       else
  1251.         FSkip(hdr.size);
  1252.     Close_Arc;
  1253.   end;
  1254.  
  1255.  
  1256. begin
  1257.   Initialize;   { one-time initialization }
  1258.   Load_Parms;   { get command line parameters }
  1259.   Extract_Arc;  { de-arc the file }
  1260. end.
  1261.