Power-Programmierung/CD1.mdf/pascal/library/dos/tug__002/dearc.pas

Pascal/Delphi Source File | 1988-08-08 | 12.0 KB | 478 lines

{TUG PDS CERT 1.01 (Pascal)

==========================================================================

                  TUG PUBLIC DOMAIN SOFTWARE CERTIFICATION

The Turbo User Group (TUG) is recognized by Borland International as the
official support organization for Turbo languages.  This file has been
compiled and verified by the TUG library staff.  We are reasonably certain
that the information contained in this file is public domain material, but
it is also subject to any restrictions applied by its author.

This diskette contains PROGRAMS and/or DATA determined to be in the PUBLIC
DOMAIN, provided as a service of TUG for the use of its members.  The
Turbo User Group will not be liable for any damages, including any lost
profits, lost savings or other incidental or consequential damages arising
out of the use of or inability to use the contents, even if TUG has been
advised of the possibility of such damages, or for any claim by any
other party.

To the best of our knowledge, the routines in this file compile and function
properly in accordance with the information described below.

If you discover an error in this file, we would appreciate it if you would
report it to us.  To report bugs, or to request information on membership
in TUG, please contact us at:

             Turbo User Group
             PO Box 1510
             Poulsbo, Washington USA  98370

--------------------------------------------------------------------------
                       F i l e    I n f o r m a t i o n

* DESCRIPTION
Turbo Pascal 4.0 program to extract all files from an archive created by
version 5.12 or earlier of the ARC utility.

* ASSOCIATED FILES
DEARC.PAS
DEARCABT.PAS
DEARCGLB.PAS
DEARCIO.PAS
DEARCLZW.PAS
DEARCUNP.PAS
DEARCUSQ.PAS
DEARC.TXT

* CHECKED BY
DRM 08/08/88

* KEYWORDS
TURBO PASCAL V4.0

==========================================================================
}
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.