Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ARCTV26B.ZIP/PROUNSQ.INC

Text File | 1993-01-04 | 30.8 KB | 1,387 lines

(*
 * prounsq.inc - PCB ProDOOR view-archive text library (low-level)
 *              (uses 25k of heap)
 *
 * 9-sep-87 (rev. 14-Dec-87)
 *
 * This function displays the text contents of a specified archive
 * file.  The filename must be fully specified and verified.
 *
 * Processes archive view and extract functions.
 *
 *)

{$R-}   {some but fiddling causes range errors; this is okay}

(*
  *** 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 modified by Roy Collins
     mail: techmail bbs @ 703-430-2535

  version 2.00 - 6/11/86   modified by David W. Carroll
     mail: high sierra rbbs-pc @ 209/296-3534

  version 3.00 - 7/30/87   modified by Richard P. Byrne
     bbs mail: software society bbs @ [phone]

  version 3.01 - 8/08/87   modified by Samuel H. Smith
     mail: the tool shop @ 602-279-2673

  *** integration with ProDOOR ***

  version 4.0 (2.4) - 9/10/87  by Samuel H. Smith
     integrated with pcb prodoor as a text view
     function.  rewrote all i/o calls for door
     library calls.  removed crc calculation for speed.
     added user interface that lists archive member information
     and allows view or extract on selected files.
*)



(* ------------------------------------------------------------- *)

procedure resync;
   (* flush input buffer and force re-synchronization *)
begin
   dos_lseek(arcfile,ufilepos,seek_start);
   uinpos := 0;
end;

procedure skip_rest;
   (* skip to the end of the current archive entry *)
begin
   inc(ufilepos,fsize);
   resync;
   fsize := 0;
end;


(* ------------------------------------------------------------- *)

procedure putc_unp (c:                  integer);
   (* output each character from archive to screen *)

   procedure flushbuf;
   begin
      disp(uoutbuf);
      uoutbuf := '';
   end;

   procedure addchar;
   begin
      inc(uoutbuf[0]);
      uoutbuf[length(uoutbuf)] := chr(c);
   end;

   procedure not_text;
   begin
      newline;
      displn('This is not a text file!');
      skip_rest;
   end;

begin

   case c of
   13:  begin
           if linenum < 1000 then
           begin
              flushbuf;
              newline;
           end;

           if nomore then
              skip_rest;
        end;

   10: ;

   26: skip_rest;         {jump to nomore mode on ^z}

   8,9,32..255:
       begin
          if length(uoutbuf) >= max_linelen then
          begin
             flushbuf;
             if fsize > 10 then
                not_text;
          end;

          if linenum < 1000 then   {stop display on nomore}
             addchar;
       end;

   else
      begin
         if binary_count < max_binary then
            inc(binary_count)
         else
         if fsize > 10 then
            not_text;
      end;
   end;

end;


(* ------------------------------------------------------------- *)

procedure abortme;
   { terminate the program with an error message }
begin
   displn('Abort: Invalid archive');
   arc_eof := true;
end;


(* ------------------------------------------------------------- *)

function fn_to_str (fn:             fntype): string;
                           { convert strings from c format (trailing 0)
                             to turbo pascal format (leading length byte). }
var
   s:                  string;
   i:                  integer;

begin
   s := '';
   i := 0;

   while fn [i]<> #0 do
   begin
      s := s + fn [i];
      inc(i);
   end;

   fn_to_str := s
end;



(* ------------------------------------------------------------- *)

procedure get_arc(var i: integer);  { read 1 byte from the archive file }
begin
   if arc_eof then
      i := 0
   else
   begin
      if (uinpos < 1) or (uinpos > uinmax) then
      begin
         uinmax := dos_read(arcfile,uinbuf,uinbufsize);
         uinpos := 1;
         if uinmax < 1 then
         begin
            i := 0;
            arc_eof := true;
            exit;
         end;
      end;

      i := uinbuf[uinpos];
      inc(uinpos);
      inc(ufilepos);
   end;
end;

procedure bread(var buffer; size: integer);
   {block read from buffered file}
var
   buf:  array[1..maxint] of byte absolute buffer;
   c,i:  integer;
begin
   for i := 1 to size do
   begin
      get_arc(c);
      if arc_eof then
         exit;
      buf[i] := c;
   end;
end;


(* ------------------------------------------------------------- *)

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


(* ------------------------------------------------------------- *)

function read_header: boolean;
                           { read a file header from the archive file }
                           { false = eof found; true = header found }
var
   name:               fntype;
   try:                integer;
   c:                  integer;

begin
   read_header := false;

   if arc_eof then
      exit;

   resync;
   try := 100;
   get_arc(c);
   while (c <> arcmarc) and (try > 0) do
   begin
      get_arc(c);
      dec(try);
   end;

   get_arc(hdrver);
   if (try = 0) or (hdrver < 0) then
   begin
      abortme;
      exit;
   end;

   if hdrver = 0 then         { special end of file marker }
      exit;

   if hdrver > arcver then
   begin
      bread(name,fnlen);
      abortme;
      exit;
   end;

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

   read_header := true;
end;


(* ------------------------------------------------------------- *)

procedure putc_unrle (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
                  dec(c);
                  while (c <> 0) do
                  begin
                     putc_unp(lastc);
                     dec(c);
                  end
               end;

               state := nohist;
            end;
   end;
end;


(* ------------------------------------------------------------- *)

procedure getc_unp(var i: integer);
begin
   if fsize = 0 then
      i := -1
   else
   begin
      dec(fsize);
      get_arc(i);
   end;
end;


(********************************************************************)

procedure unsqueeze;

{ 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;

   procedure init_usq;        { initialize for unsqueeze }
   var
      i:                integer;

   begin
      bpos := 99;
      bread(numnodes,sizeof(numnodes));
      if (numnodes < 0) or (numnodes > numvals) then
      begin
         abortme;
         exit;
      end;

      node[0].child [0]:=-(speof + 1);
      node[0].child [1]:=-(speof + 1);

      for i := 0 to numnodes - 1 do
      begin
         bread(node [i].child [0], sizeof (integer));
         bread(node [i].child [1], sizeof (integer));
      end;
   end;


(* ------------------------------------------------------------- *)

   procedure getc_usq(var i: integer);
                              { unsqueeze }
   begin
      i := 0;

      while i >= 0 do
      begin
         inc(bpos);

         if bpos > 7 then
         begin
            getc_unp(curin);

            if curin = error then
            begin
               i := 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
         i := -1;
   end;

var
   c: integer;
begin
   init_usq;
   getc_usq(c);

   while c <> -1 do
   begin
      putc_unrle(c);
      getc_usq(c);
   end;
end;


(********************************************************************)

procedure old_uncrunch;

{ definitions for uncrunch }

const
   tabsize =           4096;
   tabsizem1 =         4095;
   no_pred =           -1;
   empty =             -1;

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

   string_tab_rec      = array [0..tabsizem1] of entry;
   stack_rec           = array [0.. tabsizem1] of byte;

var
   sp:                 integer;
   string_tab:         ^string_tab_rec;
   stack:              ^stack_rec;

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


(* ------------------------------------------------------------- *)

   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;
                              { calculate hash value }
                              { thanks to bela lubkin }
   var
      local2:             longint;
      h:                  integer;
      tempnext:           integer;
   begin

      if newhash then
         local2 := longint(pred + foll) * 15073
      else
      begin
         local2 := word( (pred + foll) or $0800) and $FFFF;
         local2 := local2 * local2;
         local2 := (local2 shr 6) and $0FFF;
      end;

      h := local2 mod tabsize;

      if string_tab^ [h].used then
      begin
         h := eolist (h);
         tempnext :=(h + 101) mod tabsize;

         while string_tab^ [tempnext].used do
         begin
            inc(tempnext);
            if tempnext = tabsize then
               tempnext := 0;
         end;

         string_tab^ [h].next := tempnext;
         h := tempnext;
      end;

      hash := h;
   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;


(* ------------------------------------------------------------- *)

   procedure gocode(var i: integer);
   var
      localbuf:           integer;
      returnval:          integer;

   begin

      if inbuf = -1 then
      begin
         getc_unp(localbuf);
         if localbuf = -1 then
         begin
            i := -1;
            exit;
         end;

         localbuf := localbuf and $00ff;

         getc_unp(inbuf);
         if inbuf = -1 then
         begin
            i := -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
         getc_unp(localbuf);
         if localbuf = -1 then
         begin
            i := -1;
            exit;
         end;

         localbuf := localbuf and $00ff;
         returnval := localbuf +((inbuf shl 8) and $0f00);
         inbuf := -1;
      end;

      i := returnval;
   end;


(* ------------------------------------------------------------- *)

   procedure push (c:                  integer);
   begin
      stack^[sp] := c;
      inc(sp);

      if sp >= tabsize then
         abortme;
   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 := -1;
   end;


(* ------------------------------------------------------------- *)

   procedure init_ucr (i:                  integer);
   begin
      newhash := i = 1;
      sp := 0;
      init_tab;
      code_count := tabsize - 256;
      firstc := true;
   end;


(* ------------------------------------------------------------- *)

   procedure getc_ucr(var i: integer);
   var
      c:                  integer;
      code:               integer;
      newcode:            integer;

   begin

      if firstc then
      begin
         firstc := false;
         gocode(oldcode);
         finchar := string_tab^ [oldcode].follower;
         i := finchar;
         exit;
      end;

      if sp = 0 then
      begin
         gocode(newcode);
         code := newcode;

         if code = -1 then
         begin
            i := -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);
            dec(code_count);
         end;

         oldcode := newcode
      end;

      if sp > 0 then
      begin
         dec(sp);
         i := stack^ [sp]
      end
      else
         i := -1;
   end;


(* ------------------------------------------------------------- *)

{ old_uncrunch }
var
   c: integer;

begin
   new(string_tab);
   new(stack);

   case hdrver of
      5:    begin   {old crunch 1}
               init_ucr(0);
               getc_ucr(c);

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

      6:    begin  {crunch 2}
               init_ucr(0);
               getc_ucr(c);

               while c <> -1 do
               begin
                  putc_unrle(c);
                  getc_ucr(c);
               end;
            end;

      7:    begin  {new crunch 1}
               init_ucr(1);
               getc_ucr(c);

               while c <> -1 do
               begin
                  putc_unrle(c);
                  getc_ucr(c);
               end;
            end;
   end;

   dispose(string_tab);
   dispose(stack);
end;



(************************************************************)

procedure uncrunch(squash: integer);

{ definitions for dynamic uncrunch }

const
   crunch_bits =       12;
   squash_bits =       13;
   hsize =             8192;
   hsizem1 =           8191;
   init_bits =         9;
   first =             257;
   clear =             256;
   bitsm1 =            12;
   rmask : array [0..8] of byte =
      ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);

type
   hsize_array_integer = array [0..hsizem1] of integer;
   hsize_array_byte    = array [0..hsizem1] of byte;

var
   bits,
   n_bits,
   maxcode:            integer;
   buf:                array [0.. bitsm1] of byte;
   clear_flg:          integer;
   free_ent:           integer;
   maxcodemax:         integer;
   offset,
   sizex:              integer;
   firstch:            boolean;
   prefix:             ^hsize_array_integer;
   suffix:             ^hsize_array_byte;
   stack1:             ^hsize_array_byte;


(* ------------------------------------------------------------- *)

   procedure getcode(var res: integer);

   label next;
   var
      code,
      r_off,
      bitsx:              integer;
      bp:                 byte;
      ii:                 integer;

   begin

      if firstch then
      begin
         offset := 0;
         sizex := 0;
         firstch := false;
      end;

      bp := 0;

      if (clear_flg > 0) or (offset >= sizex) or (free_ent > maxcode) then
      begin

         if free_ent > maxcode then
         begin
            inc(n_bits);

            if n_bits = bits then
               maxcode := maxcodemax
            else
               maxcode :=(1 shl n_bits)- 1;
         end;

         if clear_flg > 0 then
         begin
            n_bits := init_bits;
            maxcode :=(1 shl n_bits)- 1;
            clear_flg := 0;
         end;

         for ii := 0 to n_bits - 1 do
         begin
            sizex := ii;
            getc_unp(code);
            if code = -1 then
               goto next
            else
               buf[sizex] := code;
         end;

         inc(sizex);

   next :;
         if sizex <= 0 then
         begin
            res := -1;
            exit;
         end;

         offset := 0;
         sizex :=(sizex shl 3)-(n_bits - 1);
      end;

      r_off := offset;
      bitsx := n_bits;           { get first byte }

      bp := bp +(r_off shr 3);
      r_off := r_off and 7;      { get first parft (low order bits) }
      code := buf [bp] shr r_off;
      inc(bp);
      bitsx := bitsx -(8 - r_off);
      r_off := 8 - r_off;

      if bitsx >= 8 then
      begin
         code := code or (buf [bp] shl r_off);
         inc(bp);
         r_off := r_off + 8;
         bitsx := bitsx - 8;
      end;

      code := code or ((buf [bp] and rmask [bitsx]) shl r_off);
      offset := offset + n_bits;
      res := code;
   end;


(* ------------------------------------------------------------- *)

   procedure decomp (squashflag:         integer);
   label next;
   var
      stackp,
      finchar:            integer;
      code,
      oldcode,
      incode:             integer;

   begin                         { init var }
      if squashflag = 0 then
         bits := crunch_bits
      else
         bits := squash_bits;

      if firstch then
         maxcodemax := 1 shl bits;

      if squashflag = 0 then
      begin
         getc_unp(code);
         if code <> bits then
         begin
            abortme;
            exit;
         end;
      end;

      clear_flg := 0;
      n_bits := init_bits;
      maxcode :=(1 shl n_bits)- 1;

      for code := 255 downto 0 do
      begin
         prefix^[code]:= 0;
         suffix^[code]:= code;
      end;

      free_ent := first;
      getcode(oldcode);
      finchar := oldcode;

      if oldcode = -1 then
         exit;

      if squashflag = 0 then
         putc_unrle(finchar)
      else
         putc_unp(finchar);

      stackp := 0;
      getcode(code);

      while (code > -1) do
      begin
         if code = clear then
         begin
            for code := 255 downto 0 do
               prefix^[code]:= 0;

            clear_flg := 1;
            free_ent := first - 1;
            getcode(code);

            if code = -1 then
               goto next;
         end;

   next:
         incode := code;

         if code >= free_ent then
         begin
            stack1^[stackp]:= finchar;
            inc(stackp);
            code := oldcode;
         end;

         while (code >= 256) do
         begin
            stack1^[stackp]:= suffix^ [code];
            inc(stackp);
            code := prefix^ [code];
         end;

         finchar := suffix^ [code];
         stack1^[stackp]:= finchar;
         inc(stackp);

         repeat
            dec(stackp);
            if squashflag = 0 then
               putc_unrle(stack1^ [stackp])
            else
               putc_unp(stack1^ [stackp]);
         until stackp <= 0;

         code := free_ent;

         if code < maxcodemax then
         begin
            prefix^[code]:= oldcode;
            suffix^[code]:= finchar;
            free_ent := code + 1;
         end;

         oldcode := incode;
         getcode(code);
      end;
   end;

(* ------------------------------------------------------------- *)

begin
   {allocate heap storage}
   new(stack1);
   new(suffix);
   new(prefix);

   firstch := true;
   decomp(squash);

   {release heap storage}
   dispose(prefix);
   dispose(suffix);
   dispose(stack1);
end;

(**************************************************************)


procedure viewfile;
var
   c:                  integer;
   filestart:          longint;

begin
   disp(WHITE);

   binary_count := 0;
   uoutbuf := '';
   fsize := hdr.size;
   state := nohist;
   filestart := ufilepos;

   case hdrver of
      1, 2: begin   {store 1, store 2}
               getc_unp(c);
               while c <> -1 do
               begin
                  putc_unp(c);
                  getc_unp(c);
               end
            end;

      3:    begin  {packed}
               getc_unp(c);
               while c <> -1 do
               begin
                  putc_unrle(c);
                  getc_unp(c);
               end;
            end;

      4:    unsqueeze;

      5..7: old_uncrunch;

      8:    uncrunch(0);  {new crunch 2}

      9:    uncrunch(1);  {squash}

      else  begin
               displn('I dont know how to unpack file '+ fn_to_str (hdr.name));
               displn('I think you need a newer version of '+comfile);
            end;
   end;

   newline;

   {rewind to start of viewed file}
   ufilepos := filestart;
   resync;
end;


(* ------------------------------------------------------------- *)

{$IFNDEF DISABLE_EXTRACT}

   procedure xtract;
      (* extract the current member into a scratch file *)

   const
      bufmax = $F000;  {maximum buffer size in bytes}
      extra = $1000;   {extra heap to leave free}
   var
      bufsize: word;   {actual buffer size}
      ifd:     dos_handle;
      ofd:     dos_handle;
      buf:     ^byte;
      n,w:     word;
      ver:     byte;
      ulspace: real;

   begin

{$IFNDEF IN_ARCTV}
      (* see if enough space is free on the upload directory *)
      if disk_space(upload_dir[1]) < pcbsetup.min_upload_free then
      begin
         newline;
         make_log_entry('Sorry, no space for '+remove_path(scratchfile),true);
         exit;
      end;
{$ENDIF}

      (* see if enough RAM space is free for copy buffer *)
      bufsize := bufmax;
      if bufsize > maxavail-extra then
         bufsize := maxavail-extra;

      if bufsize < extra then
      begin
         displn('?ram');
         exit;
      end;


      (* create SCRATCH archive if needed, otherwise position for append *)
      if exists(scratchfile) then
      begin
         ofd := dos_open(scratchfile,open_update);
         dos_lseek(ofd,-2,seek_end);               {rewrite eof header}

{$IFNDEF IN_ARCTV}
         inc(user.downloads);    {charge for all files after the first
                                  (which will be counted by the actual d/l}
{$ENDIF}
      end
      else

      begin
{$IFNDEF IN_ARCTV}
         display_file(extract_help_file);
         header_present := false;
{$ENDIF}
         ofd := dos_create(scratchfile);           {else create file if needed}
      end;

      if ofd = dos_error then
      begin
         displn('?create');
         dos_close(ifd);
         exit;
      end;


      (* write the header for this new member *)
      ver := arcmarc;
      dos_write(ofd,ver,1);
      ver := hdrver;
      dos_write(ofd,ver,1);
      dos_write(ofd,hdr,sizeof(hdr));


      (* copy the member file to the scratchfile *)
      fsize := hdr.size;
      getmem(buf,bufsize);

      resync;

      repeat
         if fsize > bufsize then
            n := bufsize
         else
            n := fsize;
         fsize := fsize - n;

         disp('.');
         n := dos_read(arcfile,buf^,n);
         inc(ufilepos,n);

         disp(^H' '^H);
         dos_write(ofd,buf^,n);
         w := dos_regs.ax;
      until w < bufsize;


      (* write an eof marker (header with method=0) *)
      ver := arcmarc;
      dos_write(ofd,ver,1);
      ver := 0;
      dos_write(ofd,ver,1);
      dos_close(ofd);

      if n <> w then
      begin
         displn('?write');
         dos_unlink(scratchfile);
      end;

      freemem(buf,bufsize);
      resync;
   end;

{$ENDIF}


(* ------------------------------------------------------------- *)

procedure describe;
   (* print a verbose description of the current archive header *)

   function itoa2(i: integer): anystring;
   begin
      itoa2 := chr(ord('0') + i div 10) +
               chr(ord('0') + i mod 10);
   end;

   function format_date(bin: integer): anystring;
       (* format archive member date *)
   begin
      if bin = 0 then
         format_date := '        '
      else
         format_date := itoa2( (bin shr 5) and  15)      + '-' + {month}
                        itoa2( (bin      ) and  31)      + '-' + {day}
                        itoa2( (bin shr 9) and 127 + 80);        {year}
   end;

   function format_time(bin: integer): anystring;
       (* format archive member time *)
   begin
      if bin = 0 then
         format_time := '        '
      else
         format_time := itoa2( (bin shr 11) and 31) + ':' +  {hour}
                        itoa2( (bin shr  5) and 63) + ':' +  {minute}
                        itoa2( (bin shl  1) and 63);         {second}
   end;

begin
   if not header_present then
   begin
      displn(WHITE);

    {$IFNDEF DISABLE_EXTRACT}
      displn('File Name     Length    Date     Time    (Enter) or (S)kip, (V)iew, (X)tract');
      displn('---------     ------   ------   ------   -----------------------------------');
    {$ELSE}
      displn('File Name     Length    Date     Time    (Enter) or (S)kip, (V)iew');
      displn('---------     ------   ------   ------   -------------------------');
    {$ENDIF}

      header_present := true;
   end;

   with hdr do
   disp( MAGENTA + extname+ copy('             ',1,12-ord(extname[0]) )+
         RED     + ftoa(length,8,0)+'  '+
         GREEN   + format_date(date)+' '+
         CYAN    + format_time(time)+'   ');
end;


(* ------------------------------------------------------------- *)
procedure view_archive_text(arcname: anystring);

(* ------------------------------------------------------------- *)

procedure open_arc;        { open the archive file for input processing }

begin
   arcfile := dos_open(arcname,open_read);
   arc_eof := arcfile = dos_error;
   ufilepos := 0;
   uinpos := 0;
end;


(* ------------------------------------------------------------- *)

procedure process_file;
var
   ext:      anystring;
   i:        integer;
   view:     anystring;
   istext:   boolean;
   done:     boolean;

begin

(* skip the file if it does not match the selection wildcard *)
   extname := fn_to_str (hdr.name);
   if not wildcard_match(pattern,extname) then
   begin
      inc(ufilepos,hdr.size);
      resync;
      exit;
   end;

(* find out if it is a non-text file based on extention *)
   ext := ext_only(extname);
   istext := true;
   for i := 1 to nexclude do
      if copy(ext,1,length(exclude[i])) = exclude[i] then
         istext := false;

(* ask user what to do with the file *)
   repeat
      describe;
      disp(YELLOW+'Action? ');
      view := 'S';
      input(view,1);
      done := false;

      case upcase(view[1]) of
      'Y','V','D':                (* view/display file *)
         begin
            if istext then
            begin
               displn(' [View]');
               newline;

               linenum := 1;
               viewfile;        (* view file and rewind to see it again *)

               header_present := false;
               make_log_entry('View ARC member ('+extname
                                        +') from ('+remove_path(arcname)
                                        +')',false);
               done := false;
            end
            else
               displn(' [Not a textfile!]');
         end;

    {$IFNDEF DISABLE_EXTRACT}
      'X','E':                  (* extract to scratch.arc *)
         begin
            if arcname = scratchfile then
               displn(' [Cant!]')
            else
            begin
               disp(' [Extract]');
               xtract;
               newline;
               make_log_entry('Extract ARC member ('+extname
                                        +') from ('+remove_path(arcname)
                                        +')',false);
               done := true;
            end;
         end;
    {$ENDIF}

      'S':                      (* skip to next entry *)
         begin
            displn(' [Skip]');
            inc(ufilepos,hdr.size);
            resync;
            done := true;
         end;

      'Q':                      (* quit, skip rest of arc *)
         begin
            displn(' [Quit]');
            arc_eof := true;
            done := true;
         end;

      else
          {$IFNDEF DISABLE_EXTRACT}
            displn(' [Type Q, S, V or X!]');
          {$ELSE}
            displn(' [Type Q, S, or V!]');
          {$ENDIF}
      end;

   until done or dump_user;

end;

(* ------------------------------------------------------------- *)

   { extract and view text files in the archive - main entry }

begin

{$IFNDEF DISABLE_EXTRACT}
   disp(YELLOW+'Text extract/view filespec: (wildcards are OK) (Enter)='+
                                    default_pattern+'? ');
{$ELSE}
   disp(YELLOW+'Text view filespec: (wildcards are OK) (Enter)='+
                                    default_pattern+'? ');
  {$ENDIF}
   input(pattern,13);
   newline;

   if length(pattern) = 0 then
      pattern := default_pattern;
   stoupper(pattern);

   open_arc;
   if arc_eof then
      exit;

   header_present := false;
   while read_header do
      process_file;

   close_arc;
end;

{ $R+}