Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DARC31.ZIP/DEARC.PAS

Pascal/Delphi Source File | 1993-01-04 | 10.1 KB | 422 lines

Program Dearc;
(*
 DEARC.PAS - Program to extract all files from an archive created by version
             5.12 or earlier of the ARC utility.

             ARC is COPYRIGHT 1985-1988 by System Enhancement Associates.
             PKARC/PKXARC are Copyright 1986-1988 by PKWARE, Inc.


    This program requires Turbo Pascal Version 4.0 or higher.

 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.

 HISTORY:

   *** ORIGINAL AUTHOR UNKNOWN ***

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

  Version 1.01A - 12/19/85 By Roy Collins
                           Mail: TechMail BBS @ 703-430-2535
                                 - or -
                                 P.O.Box 1192, Leesburg, Va 22075
                           Modified V1.01 to work with Turbo Pascal Version 2
                           Added functions ARGC (argument count) and ARGV
                           (argument value)
                           Modified all references to "EXIT" command to be
                           GOTO EXIT, with EXIT defined as a LABEL, at the
                           end of the function/procedure involved.
                           Will not accept path names - archives must be in
                           the current directory.

  Version 2.00 - 6/11/86   By David W. Carroll
                           Mail: High Sierra RBBS-PC @ 209/296-3534
                           Now supports ARC version 5.12 files, compression
                           types 7 and 8.

  Version 3.00 - 7/30/87   By Richard P. Byrne
                           UN*X E-Mail:  ...!ihnp4!mduxf!rpb
                           BBS Mail:     Software Society BBS @ [phone]
                           Modified Version 2.00 to handle compression type
                           9 (ie. Squashed ).

  Version 3.10 - 7/26/88   By Paul Roub
                           BBS Mail: Society BBS (407)-773-2831
                                     FIDONET Programming Echo
                                     FIDONET C Echo
                           Compuserve EasyPlex to [71131,157]
                           Modified Version 3.00:
                             Ported to Turbo Pascal v4.0
                             Added Time/Date stamping of extracted files
                             Removed all floating point
                             Added confirmation when overwriting existing file
                             Display type of decompression being done
                             Updated docs
                             Removed CP/M style end-of-file padding (do you
                               really want a bunch of Control-Z's at the
                               end of a .COM file?)
                             By the way,  argc and argv are gone,  and of
                               COURSE you can use pathnames...
*)


(*
 *  other units involved
 *)
uses
  dearcabt,                           (* abort() routine                    *)
  dearcglb,                           (* global variables,  types           *)
  dearcio,                            (* input/output routines              *)
  dearcunp,                           (* unPacking stuff                    *)
  dearcusq,                           (* unSqueezing routines               *)
  dearclzw;                           (* LZW (unCrunching and unSquashing   *)


(**
 *
 *  Name:         function fn_to_str
 *  Description:  convert strings from C format (trailing 0) to Turbo Pascal
 *                format (leading length byte).
 *  Parameters:   var -
 *                  fn : fntype : filename to convert
 *  Returns:      converted filename
 *
**)
function fn_to_str(var fn : fntype) : strtype;
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; (* func fn_to_str *)


(**
 *
 *  Name:         procedure GetArcName
 *  Description:  get the name of the archive file
 *  Parameters:   none
 *
**)
procedure GetArcName;
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; (* proc GetArcName *)


(**
 *
 *  Name:         function readhdr
 *  Description:  read a file header from the archive file
 *  Parameters:   var -
 *                  hdr : heads - header to read
 *  Returns:      FALSE : eof found
 *                TRUE  : header found
 *
**)
function readhdr(var hdr : heads) : boolean;
label
  exit;
var
  name : fntype;
  try  : integer;
begin
  try := 10;

  if endfile then
    begin
      readhdr := FALSE;
      goto exit               (******** was "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; (* while *)

  hdrver := get_arc;

  if hdrver < 0 then
    abort('Invalid header in archive ' + arcname);

  if hdrver = 0 then         { special end of file marker }
    begin
      readhdr := FALSE;
      goto exit               (******** was "exit" ************)
    end;

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

  readhdr := TRUE;

exit:

end; (* func readhdr *)


(**
 *
 *  Name:         procedure unpack
 *  Description:  unpack one file
 *  Parameters:   var -
 *                  hdr : heads - header of file to unpack
 *
**)
procedure unpack(var hdr : heads);
label
  exit;
var
  c : integer;
begin
  crcval  := 0;
  size    := hdr.size;
  state   := NOHIST;
  FirstCh := TRUE;

  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(0);
        c := getc_ucr;

        while c <> -1 do
          begin
            putc_unp(c);
            c := getc_ucr
          end
      end;

    6    :
      begin
        init_ucr(0);
        c := getc_ucr;

        while c <> -1 do
          begin
            putc_ncr(c);
            c := getc_ucr
          end
      end;

    7    :
      begin
        init_ucr(1);
        c := getc_ucr;

        while c <> -1 do
          begin
            putc_ncr(c);
            c := getc_ucr
          end
      end;

    8    :
      decomp(0);

    9    :
      decomp(1);

    else
      begin
        writeln('I dont know how to unpack file ', fn_to_str(hdr.name));
        writeln('I think you need a newer version of DEARC');
        fseek(hdr.size, 1);
        goto exit                         (******** was "exit" ************)
      end
  end; (* case *)

  if crcval <> hdr.crc then
    writeln('WARNING: File ', fn_to_str(hdr.name), ' fails CRC check');

exit:

end; (* proc unpack *)


(**
 *
 *  Name:         procedure extract_file
 *  Description:  extract one file from archive
 *  Parameters:   var -
 *                  hdr : heads - header for file to extract
 *
**)
procedure extract_file(var hdr : heads);
var
  st : strtype;
  ch : char;
  fil : file;
begin
  extname := fn_to_str(hdr.name);

  assign(fil, extname);
  {$I-}
  reset(fil);
  {$I+}

  if (ioresult = 0) then
    begin
      close(fil);

      repeat
        write('  File ', extname, ' exists.  Overwrite (y/n)? ');
        readln(st);
        ch := upcase(st[1]);
      until ((ch = 'Y') or (ch = 'N'));

      if (ch = 'N') then
        begin
          fseek(hdr.size, 1);
          writeln('  ', extname, ' skipped.');
          exit;
        end;
    end;

  case hdrver of
    1, 2    : write('Extracting ');
    3       : write('unPacking  ');
    4       : write('unSqueezing');
    5, 6, 7 : write('uncrunching');
    8       : write('unCrunching');
    9       : write('unSquashing');
  end;

  writeln(' : ', extname);

  open_ext;
  unpack(hdr);
  close_ext(hdr);
end; (* proc extract *)


(**
 *
 *  Name:         procedure extarc
 *  Description:  extract all files from an archive
 *  Parameters:   none
 *
**)
procedure extarc;
var
  hdr : heads;
begin
  open_arc;

  while readhdr(hdr) do
    extract_file(hdr);

  close_arc;
end; (* proc extarc *)


(**
 *
 *  Name:         procedure PrintHeading
 *  Description:  print DEARC header info
 *  Parameters:   none
 *
**)
procedure PrintHeading;
begin
  writeln;
  writeln('Turbo Pascal DEARC Utility');
  writeln('Version 3.1, 7/26/88');
  writeln('Supports Phil Katz "squashed" files');
  writeln;
end; (* proc PrintHeading *)


(**
 *
 *  Name:         (main routine)
 *  Description:  print header information
 *                get the archive file name
 *                do the extraction
 *
**)
begin
  PrintHeading;
  GetArcName;   { get the archive file name }
  extarc        { extract all files from the archive }
end.