Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/DEARC.ZIP/DEARC.PAS

Pascal/Delphi Source File | 1985-12-08 | 18.3 KB | 686 lines

{$R-}
{$U-}
{$C-}
{$K-}

program dearc;

{ DEARC.PAS - Program to extract all files from an archive created by version
  4.30 or earlier of the ARC utility.

  ARC is COPYRIGHT 1985 by System Enhancement Associates.

  This program requires Turbo Pascal Version 3.01A. It should work in all
  supported environments (PCDOS, CPM, etc.) but I have only tested it on
  an IBM PC running PC DOS version 3.10.

  Usage:

    DEARC arcname

    arcname is the path/file name of the archive file. All files contained
    in the archive will be extracted into the current directory.

  Version 1.01 - 10/19/85. Changed end-of-file processing to, hopefully, be
                           more compatible with CPM (whatever that is).
}

const BLOCKSIZE = 128;
      arcmarc   = 26;              { special archive marker }
      arcver    = 6;               { archive header version code }
      strlen    = 100;             { standard string length }
      fnlen     = 12;              { file name length - 1 }

const crctab : array [0..255] of integer =
  ( $0000, $C0C1, $C181, $0140, $C301, $03C0, $0280, $C241,
    $C601, $06C0, $0780, $C741, $0500, $C5C1, $C481, $0440,
    $CC01, $0CC0, $0D80, $CD41, $0F00, $CFC1, $CE81, $0E40,
    $0A00, $CAC1, $CB81, $0B40, $C901, $09C0, $0880, $C841,
    $D801, $18C0, $1980, $D941, $1B00, $DBC1, $DA81, $1A40,
    $1E00, $DEC1, $DF81, $1F40, $DD01, $1DC0, $1C80, $DC41,
    $1400, $D4C1, $D581, $1540, $D701, $17C0, $1680, $D641,
    $D201, $12C0, $1380, $D341, $1100, $D1C1, $D081, $1040,
    $F001, $30C0, $3180, $F141, $3300, $F3C1, $F281, $3240,
    $3600, $F6C1, $F781, $3740, $F501, $35C0, $3480, $F441,
    $3C00, $FCC1, $FD81, $3D40, $FF01, $3FC0, $3E80, $FE41,
    $FA01, $3AC0, $3B80, $FB41, $3900, $F9C1, $F881, $3840,
    $2800, $E8C1, $E981, $2940, $EB01, $2BC0, $2A80, $EA41,
    $EE01, $2EC0, $2F80, $EF41, $2D00, $EDC1, $EC81, $2C40,
    $E401, $24C0, $2580, $E541, $2700, $E7C1, $E681, $2640,
    $2200, $E2C1, $E381, $2340, $E101, $21C0, $2080, $E041,
    $A001, $60C0, $6180, $A141, $6300, $A3C1, $A281, $6240,
    $6600, $A6C1, $A781, $6740, $A501, $65C0, $6480, $A441,
    $6C00, $ACC1, $AD81, $6D40, $AF01, $6FC0, $6E80, $AE41,
    $AA01, $6AC0, $6B80, $AB41, $6900, $A9C1, $A881, $6840,
    $7800, $B8C1, $B981, $7940, $BB01, $7BC0, $7A80, $BA41,
    $BE01, $7EC0, $7F80, $BF41, $7D00, $BDC1, $BC81, $7C40,
    $B401, $74C0, $7580, $B541, $7700, $B7C1, $B681, $7640,
    $7200, $B2C1, $B381, $7340, $B101, $71C0, $7080, $B041,
    $5000, $90C1, $9181, $5140, $9301, $53C0, $5280, $9241,
    $9601, $56C0, $5780, $9741, $5500, $95C1, $9481, $5440,
    $9C01, $5CC0, $5D80, $9D41, $5F00, $9FC1, $9E81, $5E40,
    $5A00, $9AC1, $9B81, $5B40, $9901, $59C0, $5880, $9841,
    $8801, $48C0, $4980, $8941, $4B00, $8BC1, $8A81, $4A40,
    $4E00, $8EC1, $8F81, $4F40, $8D01, $4DC0, $4C80, $8C41,
    $4400, $84C1, $8581, $4540, $8701, $47C0, $4680, $8641,
    $8201, $42C0, $4380, $8341, $4100, $81C1, $8081, $4040 );

type long    = record           { used to simulate long (4 byte) integers }
                 l, h : integer
               end;

type strtype = string[strlen];
     fntype  = array [0..fnlen] of char;
     buftype = array [1..BLOCKSIZE] of byte;
     heads   = record
                 name   : fntype;
                 size   : long;
                 date   : integer;
                 time   : integer;
                 crc    : integer;
                 length : long
               end;

var hdrver   : byte;
    arcfile  : file;
    arcbuf   : buftype;
    arcptr   : integer;
    arcname  : strtype;
    endfile  : boolean;

    extfile  : file;
    extbuf   : buftype;
    extptr   : integer;
    extname  : strtype;

{ definitions for unpack }

const DLE = $90;

var state  : (NOHIST, INREP);
    crcval : integer;
    size   : real;
    lastc  : integer;

{ definitions for unsqueeze }

const ERROR   = -1;
      SPEOF   = 256;
      NUMVALS = 256;               { 1 less than the number of values }

type nd = record
            child : array [0..1] of integer
          end;

var node     : array [0..NUMVALS] of nd;
    bpos     : integer;
    curin    : integer;
    numnodes : integer;

{ definitions for uncrunch }

const TABSIZE   = 4096;
      TABSIZEM1 = 4095;
      NO_PRED   = $FFFF;
      EMPTY     = $FFFF;

type entry = record
               used         : boolean;
               next         : integer;
               predecessor  : integer;
               follower     : byte
             end;

var stack       : array [0..TABSIZEM1] of byte;
    sp          : integer;
    string_tab  : array [0..TABSIZEM1] of entry;

var code_count : integer;
    code       : integer;
    firstc     : boolean;
    oldcode    : integer;
    finchar    : integer;
    inbuf      : integer;
    outbuf     : integer;

procedure abort(s : strtype);
{ terminate the program with an error message }
  begin
    writeln('ABORT: ', s);
    halt;
  end;

function fn_to_str(var fn : fntype) : strtype;
{ convert strings from C format (trailing 0) to Turbo Pascal format (leading
    length byte). }
  var s : strtype;
      i : integer;
  begin
    s := '';
    i := 0;
    while fn[i] <> #0 do begin
      s := s + fn[i];
      i := i + 1
    end;
    fn_to_str := s
  end;

function unsigned_to_real(u : integer) : real;
{ convert unsigned integer to real }
{ note: INT is a function that returns a REAL!!!}
  begin
    if u >= 0 then unsigned_to_real := Int(u)
    else if u = $8000 then unsigned_to_real := 32768.0
    else unsigned_to_real := 65536.0 + u
  end;

function long_to_real(l : long) : real;
{ convert long integer to a real }
{ note: INT is a function that returns a REAL!!! }
  var r : real;
      s : (POS, NEG);
  const rcon = 65536.0;
  begin
    if l.h >= 0 then begin
      r := Int(l.h) * rcon;
      s := POS
    end else begin
      s := NEG;
      if l.h = $8000 then r := rcon * rcon
      else r := Int(-l.h) * rcon
    end;
    r := r + unsigned_to_real(l.l);
    if s = NEG then long_to_real := -r
    else long_to_real := r
  end;

procedure Read_Block;
{ read a block from the archive file }
  begin
    if EOF(arcfile) then endfile := TRUE
    else BlockRead(arcfile, arcbuf, 1);
    arcptr := 1
  end;

procedure Write_Block;
{ write a block to the extracted file }
  begin
    BlockWrite(extfile, extbuf, 1);
    extptr := 1
  end;

procedure open_arc;
{ open the archive file for input processing }
  begin
    {$I-} assign(arcfile, arcname); {$I+}
    if ioresult <> 0 then abort('Cannot open archive file.');
    {$I-} reset(arcfile); {$I+}
    if ioresult <> 0 then abort('Cannot open archive file.');
    endfile := FALSE;
    Read_Block
  end;

procedure open_ext;
{ open the extracted file for writing }
  begin
    {$I-} assign(extfile, extname); {$I+}
    if ioresult <> 0 then abort('Cannot open extract file.');
    {$I-} rewrite(extfile); {$I+}
    if ioresult <> 0 then abort('Cannot open extract file.');
    extptr := 1;
  end;

function get_arc : byte;
{ read 1 character from the archive file }
  begin
    if endfile then get_arc := 0
    else begin
      get_arc := arcbuf[arcptr];
      if arcptr = BLOCKSIZE then Read_Block
      else arcptr := arcptr + 1
    end
  end;

procedure put_ext(c : byte);
{ write 1 character to the extracted file }
  begin
    extbuf[extptr] := c;
    if extptr = BLOCKSIZE then Write_Block
    else extptr := extptr + 1
  end;

procedure close_arc;
{ close the archive file }
  begin
    close(arcfile)
  end;

procedure close_ext;
{ close the extracted file }
  begin
    while extptr <> 1 do put_ext(Ord(^Z));  { pad last block w/ Ctrl-Z (EOF) }
    close(extfile)
  end;

procedure fseek(offset : real; base : integer);
{ re-position the current pointer in the archive file }
  var b           : real;
      i, ofs, rec : integer;
      c           : byte;
  begin
    case base of
      0 : b := offset;
      1 : b := offset + (unsigned_to_real(FilePos(arcfile)) - 1.0) * BLOCKSIZE
                + arcptr - 1.0;
      2 : b := offset + unsigned_to_real(FileSize(arcfile)) * BLOCKSIZE - 1.0
    else
      abort('Invalid parameters to fseek')
    end;
    rec := Trunc(b / BLOCKSIZE);
    ofs := Trunc(b - (Int(rec) * BLOCKSIZE));  { Int converts to Real }
    seek(arcfile, rec);
    Read_Block;
    for i := 1 to ofs do c := get_arc
  end;

procedure fread(var buf; reclen : integer);
{ read a record from the archive file }
  var i : integer;
      b : array [1..MaxInt] of byte absolute buf;
  begin
    for i := 1 to reclen do b[i] := get_arc
  end;

procedure GetArcName;
{ get the name of the archive file }
  var i : integer;
  begin
    if ParamCount > 1 then abort('Too many parameters');
    if ParamCount = 1 then arcname := ParamStr(1)
    else begin
      write('Enter archive filename: ');
      readln(arcname);
      if arcname = '' then abort('No file name entered');
      writeln;
      writeln;
    end;
    for i := 1 to length(arcname) do
      arcname[i] := UpCase(arcname[i]);
    if pos('.', arcname) = 0 then arcname := arcname + '.ARC'
  end;

function readhdr(var hdr : heads) : boolean;
{ read a file header from the archive file }
{ FALSE = eof found; TRUE = header found }
  var name : fntype;
      try  : integer;
  begin
    try := 10;
    if endfile then begin
      readhdr := FALSE;
      exit
    end;
    while get_arc <> arcmarc do begin
      if try = 0 then abort(arcname + ' is not an archive');
      try := try - 1;
      writeln(arcname, ' is not an archive, or is out of sync');
      if endfile then abort('Archive length error')
    end;

    hdrver := get_arc;
    if hdrver < 0 then abort('Invalid header in archive ' + arcname);
    if hdrver = 0 then begin   { special end of file marker }
      readhdr := FALSE;
      exit
    end;
    if hdrver > arcver then begin
      fread(name, fnlen);
      writeln('I dont know how to handle file ', fn_to_str(name),
        ' in archive ', arcname);
      writeln('I think you need a newer version of DEARC.');
      halt;
    end;

    if hdrver = 1 then begin
      fread(hdr, sizeof(heads) - sizeof(long));
      hdrver := 2;
      hdr.length := hdr.size
    end else
      fread(hdr, sizeof(heads));

    readhdr := TRUE
  end;

procedure putc_unp(c : integer);
  begin
    crcval := ((crcval shr 8) and $00FF) xor crctab[(crcval xor c) and $00FF];
    put_ext(c)
  end;

procedure putc_ncr(c : integer);
  begin
    case state of
      NOHIST : if c = DLE then state := INREP
               else begin
                 lastc := c;
                 putc_unp(c)
               end;
      INREP  : begin
                 if c = 0 then putc_unp(DLE)
                 else begin
                   c := c - 1;
                   while (c <> 0) do begin
                     putc_unp(lastc);
                     c := c - 1
                   end
                 end;
                 state := NOHIST
               end
    end
  end;

function getc_unp : integer;
  begin
    if size = 0.0 then getc_unp := -1
    else begin
      size := size - 1.0;
      getc_unp := get_arc
    end
  end;

procedure init_usq;
{ initialize for unsqueeze }
  var i : integer;
  begin
    bpos := 99;
    fread(numnodes, sizeof(numnodes));
    if (numnodes < 0) or (numnodes > NUMVALS) then
      abort('File has an invalid decode tree');
    node[0].child[0] := -(SPEOF + 1);
    node[0].child[1] := -(SPEOF + 1);
    for i := 0 to numnodes-1 do begin
      fread(node[i].child[0], sizeof(integer));
      fread(node[i].child[1], sizeof(integer))
    end
  end;

function getc_usq : integer;
{ unsqueeze }
  var i : integer;
  begin
    i := 0;
    while i >= 0 do begin
      bpos := bpos + 1;
      if bpos > 7 then begin
        curin := getc_unp;
        if curin = ERROR then begin
          getc_usq := ERROR;
          exit
        end;
        bpos := 0;
        i := node[i].child[1 and curin]
      end else begin
        curin := curin shr 1;
        i := node[i].child[1 and curin]
      end
    end;
    i := - (i + 1);
    if i = SPEOF then getc_usq := -1
    else getc_usq := i
  end;

function h(pred, foll : integer) : integer;
{ calculate hash value }
{ thanks to Bela Lubkin }
  var Local : Real;
      S     : String[20];
      I, V  : integer;
      C     : char;
  begin
    Local := (pred + foll) or $0800;
    if Local < 0.0 then Local := Local + 65536.0;
    Local := (Local * Local) / 64.0;

{ convert Local to an integer, truncating high order bits. }
{ there ***MUST*** be a better way to do this!!! }
    Str(Local:15:5, S);
    V := 0;
    I := 1;
    C := S[1];
    while C <> '.' do begin
      if (C >= '0') and (C <= '9') then V := V * 10 + (Ord(C) - Ord('0'));
      I := I + 1;
      C := S[I]
    end;
    h := V and $0FFF
  end;

function eolist(index : integer) : integer;
  var temp : integer;
  begin
    temp := string_tab[index].next;
    while temp <> 0 do begin
      index := temp;
      temp := string_tab[index].next
    end;
    eolist := index
  end;

function hash(pred, foll : integer) : integer;
  var local     : integer;
      tempnext  : integer;
  begin
    local := h(pred, foll);
    if not string_tab[local].used then hash := local
    else begin
      local := eolist(local);
      tempnext := (local + 101) and $0FFF;
      while string_tab[tempnext].used do begin
        tempnext := tempnext + 1;
        if tempnext = TABSIZE then tempnext := 0
      end;
      string_tab[local].next := tempnext;
      hash := tempnext
    end
  end;

procedure upd_tab(pred, foll : integer);
  begin
    with string_tab[hash(pred, foll)] do begin
      used := TRUE;
      next := 0;
      predecessor := pred;
      follower := foll
    end
  end;

function getcode : integer;
  var localbuf  : integer;
      returnval : integer;
  begin
    if inbuf = EMPTY then begin
      localbuf := getc_unp;
      if localbuf = -1 then begin
        getcode := -1;
        exit
      end;
      localbuf := localbuf and $00FF;
      inbuf := getc_unp;
      if inbuf = -1 then begin
        getcode := -1;
        exit
      end;
      inbuf := inbuf and $00FF;
      returnval := ((localbuf shl 4) and $0FF0) + ((inbuf shr 4) and $000F);
      inbuf := inbuf and $000F
    end else begin
      localbuf := getc_unp;
      if localbuf = -1 then begin
        getcode := -1;
        exit
      end;
      localbuf := localbuf and $00FF;
      returnval := localbuf + ((inbuf shl 8) and $0F00);
      inbuf := EMPTY
    end;
    getcode := returnval
  end;

procedure push(c : integer);
  begin
    stack[sp] := c;
    sp := sp + 1;
    if sp >= TABSIZE then abort('Stack overflow')
  end;

function pop : integer;
  begin
    if sp > 0 then begin
      sp := sp - 1;
      pop := stack[sp]
    end else
      pop := EMPTY
  end;

procedure init_tab;
  var i : integer;
  begin
    FillChar(string_tab, sizeof(string_tab), 0);
    for i := 0 to 255 do upd_tab(NO_PRED, i);
    inbuf := EMPTY;
    outbuf := EMPTY
  end;

procedure init_ucr;
  begin
    sp := 0;
    init_tab;
    code_count := TABSIZE - 256;
    firstc := TRUE
  end;

function getc_ucr : integer;
  var c       : integer;
      code    : integer;
      newcode : integer;
  begin
    if firstc then begin
      firstc := FALSE;
      oldcode := getcode;
      finchar := string_tab[oldcode].follower;
      getc_ucr := finchar;
      exit
    end;
    if sp = 0 then begin
      newcode := getcode;
      code := newcode;
      if code = -1 then begin
        getc_ucr := -1;
        exit
      end;
      if not string_tab[code].used then begin
        code := oldcode;
        push(finchar)
      end;
      while string_tab[code].predecessor <> NO_PRED do
        with string_tab[code] do begin
          push(follower);
          code := predecessor
        end;
      finchar := string_tab[code].follower;
      push(finchar);
      if code_count <> 0 then begin
        upd_tab(oldcode, finchar);
        code_count := code_count - 1
      end;
      oldcode := newcode
    end;
    getc_ucr := pop
  end;

procedure unpack(var hdr : heads);
  var c : integer;
  begin
    crcval := 0;
    size := long_to_real(hdr.size);
    state := NOHIST;
    case hdrver of
      1, 2 : begin
               c := getc_unp;
               while c <> -1 do begin
                 putc_unp(c);
                 c := getc_unp
               end
             end;
      3    : begin
               c := getc_unp;
               while c <> -1 do begin
                 putc_ncr(c);
                 c := getc_unp
               end
             end;
      4    : begin
               init_usq;
               c := getc_usq;
               while c <> -1 do begin
                 putc_ncr(c);
                 c := getc_usq
               end
             end;
      5    : begin
               init_ucr;
               c := getc_ucr;
               while c <> -1 do begin
                 putc_unp(c);
                 c := getc_ucr
               end
             end;
      6    : begin
               init_ucr;
               c := getc_ucr;
               while c <> -1 do begin
                 putc_ncr(c);
                 c := getc_ucr
               end
             end
    else
      writeln('I dont know how to unpack file ', fn_to_str(hdr.name));
      writeln('I think you need a newer version of DEARC');
      fseek(long_to_real(hdr.size), 1);
      exit
    end;
    if crcval <> hdr.crc then
      writeln('WARNING: File ', fn_to_str(hdr.name), ' fails CRC check')
  end;

procedure extract_file(var hdr : heads);
  begin
    extname := fn_to_str(hdr.name);
    writeln('Extracting file : ', extname);
    open_ext;
    unpack(hdr);
    close_ext
  end;

procedure extarc;
  var hdr : heads;
  begin
    open_arc;
    while readhdr(hdr) do extract_file(hdr);
    close_arc
  end;

procedure PrintHeading;
  begin
    writeln;
    writeln('Turbo Pascal DEARC Utility');
    writeln('Version 1.01, 10/19/85');
    writeln
  end;

begin
  PrintHeading; { print a heading }
  GetArcName;   { get the archive file name }
  extarc        { extract all files from the archive }
end.