Shareware Overload/ShartewareOverload.cdr/utils/ziptv20.zip/ZIPTV.PAS

Pascal/Delphi Source File | 1989-09-09 | 36KB | 1,505 lines

(*
 * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
 *
 * This is a component of the ProDoor System.
 * Do not distribute modified versions without my permission.
 * Do not remove or alter this notice or any other copyright notice.
 * If you use this in your own program you must distribute source code.
 * Do not use any of this in a commercial product.
 *
 *)

(*
 * ZipTV - zipfile text view utility/door
 *
 *)

{$I prodef.inc}
{$M 5000,0,0} {minstack,minheap,maxheap}
{$D+}    {Global debug information}
{$L+}    {Local debug information}
{ $r+,s+}

program ZipTV;

Uses
   Dos, DosMem, MiniCrt, Mdosio, Tools, CInput;

const
   version = 'ZipTV:  Zipfile Text Viewer v2.0 of 09-09-89;  (C) 1989 S.H.Smith';


(* ----------------------------------------------------------- *)
(*
 * ZIPfile layout declarations
 *
 *)

type
   signature_type = longint;

const
   local_file_header_signature = $04034b50;

type
   local_file_header = record
      version_needed_to_extract:    word;
      general_purpose_bit_flag:     word;
      compression_method:           word;
      last_mod_file_time:           word;
      last_mod_file_date:           word;
      crc32:                        longint;
      compressed_size:              longint;
      uncompressed_size:            longint;
      filename_length:              word;
      extra_field_length:           word;
   end;

const
   central_file_header_signature = $02014b50;

type
   central_directory_file_header = record
      version_made_by:                 word;
      version_needed_to_extract:       word;
      general_purpose_bit_flag:        word;
      compression_method:              word;
      last_mod_file_time:              word;
      last_mod_file_date:              word;
      crc32:                           longint;
      compressed_size:                 longint;
      uncompressed_size:               longint;
      filename_length:                 word;
      extra_field_length:              word;
      file_comment_length:             word;
      disk_number_start:               word;
      internal_file_attributes:        word;
      external_file_attributes:        longint;
      relative_offset_local_header:    longint;
   end;

const
   end_central_dir_signature = $06054b50;

type
   end_central_dir_record = record
      number_this_disk:                         word;
      number_disk_with_start_central_directory: word;
      total_entries_central_dir_on_this_disk:   word;
      total_entries_central_dir:                word;
      size_central_directory:                   longint;
      offset_start_central_directory:           longint;
      zipfile_comment_length:                   word;
   end;

const
   compression_methods: array[0..7] of string[8] =
      (' Stored ',
       ' Shrunk ',
       'Reduce-1', 'Reduce-2', 'Reduce-3', 'Reduce-4',
       'Imploded',
       '    ?   ');


(* ----------------------------------------------------------- *)
(*
 * input file variables
 *
 *)

const
   uinbufsize = 512;    {input buffer size}

var
   zipeof:     boolean;

   csize:      longint;
   cusize:     longint;
   cmethod:    integer;
   cflags:     word;

   inbuf:      array[1..uinbufsize] of byte;
   inpos:      integer;
   incnt:      integer;
   pc:         byte;
   pcbits:     byte;
   pcbitv:     byte;
   zipfd:      dos_handle;
   zipfn:      dos_filename;



(* ----------------------------------------------------------- *)
(*
 * output stream variables
 *
 *)

const
   hsize =     8192;    {must be 8192 for 13 bit shrinking}

   max_binary = 50;     {non-printing count before binary file trigger}
   max_linelen = 200;   {line length before binary file triggered}

var
   uoutbuf:             string[max_linelen];    {disp line buffer}
   binary_count:        integer;                {non-text chars so far}

   outbuf:              array[0..hsize] of byte; {must be >= 8192 for look-back}
   outpos:              longint;                 {absolute position in outfile}


(* ----------------------------------------------------------- *)
(*
 * other working storage
 *
 *)

var
   expand_files:        boolean;
   header_present:      boolean;
   default_pattern:     string20;
   pattern:             string20;
   action:              string20;



(* ----------------------------------------------------
 *
 *  Zipfile input/output handlers
 *
 *)

procedure skip_rest;
begin
   dos_lseek(zipfd,csize-incnt,seek_cur);
   zipeof := true;
   csize := 0;
   incnt := 0;
end;

procedure skip_csize;
begin
   incnt := 0;
   skip_rest;
end;


(* ------------------------------------------------------------- *)
procedure ReadByte(var x: byte);
begin
   if incnt = 0 then
   begin
      if csize = 0 then
      begin
         zipeof := true;
         exit;
      end;

      inpos := sizeof(inbuf);
      if inpos > csize then
         inpos := csize;
      incnt := dos_read(zipfd,inbuf,inpos);

      inpos := 1;
      dec(csize,incnt);
   end;

   x := inbuf[inpos];
   inc(inpos);
   dec(incnt);
end;


(* ------------------------------------------------------------- *)
procedure ReadBits(bits: integer; var x: integer);
   {read the specified number of bits}
var
   bit:     integer;
   bitv:    integer;

begin

(****
write('readbits n=',bits,' b=');
****)

   x := 0;
   bitv := 1;

   for bit := 0 to bits-1 do
   begin

      if pcbits > 0 then
      begin
         dec(pcbits);
         pcbitv := pcbitv shl 1;
      end
      else

      begin
         ReadByte(pc);
         pcbits := 7;
         pcbitv := 1;
      end;

      if (pc and pcbitv) <> 0 then
         x := x or bitv;

      bitv := bitv shl 1;
   end;

(****
writeln(' -> ',x,' = ',binary(x));
*****)

end;


(* ---------------------------------------------------------- *)
procedure get_string(len: integer; var s: string);
var
   n: integer;
begin
   if len <= 255 then
      n := dos_read(zipfd,s[1],len)
   else
   begin
      n := dos_read(zipfd,s[1],255);
      dos_lseek(zipfd,len-255,seek_cur);
      len := 255;
   end;

   s[0] := chr(len);
end;


(* ------------------------------------------------------------- *)
procedure OutByte (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
   outbuf[outpos mod sizeof(outbuf)] := c;
   inc(outpos);

(********
if debug then
begin
if c = 13 then
else
if c = 10 then
begin
   if nomore then
      skip_rest
   else
      newline;
end
else
   write(chr(c));
writeln(' [outbyte c=',c:3,' outpos=',outpos-1:5,']');
if keypressed and (readkey=#27) then halt;
exit;
end;
********)

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

           if nomore or dump_user then
              skip_rest;
        end;

   10: ;

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

   8,9,32..255:
       begin
          if length(uoutbuf) >= max_linelen then
          begin
             flushbuf;
             if csize > 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 csize > 10 then
            not_text;
      end;
   end;

end;


(* ------------------------------------------------------------- *)
(*
 * The Reducing algorithm is actually a combination of two
 * distinct algorithms.  The first algorithm compresses repeated
 * byte sequences, and the second algorithm takes the compressed
 * stream from the first algorithm and applies a probabilistic
 * compression method.
 *
 *)

procedure unReduce;
   {expand probablisticly reduced data}

   type
      Sarray = array[0..255] of string[64];

   var
      factor:     integer;
      followers:  ^Sarray;
      ExState:    integer;
      C:          integer;
      V:          integer;
      Len:        integer;

   const
      Lmask:   array[1..4] of integer = ($7f,$3f,$1f,$0f);
      Fcase:   array[1..4] of integer = (127, 63, 31, 15);
      Dshift:  array[1..4] of integer = (7,6,5,4);
      Dand:    array[1..4] of integer = ($01,$03,$07,$0f);


   procedure Expand(c: byte);
   const
      DLE = 144;
   var
      op:   longint;
      i:    integer;

   begin

      case ExState of
           0:  if C <> DLE then
                   OutByte(C)
               else
                   ExState := 1;

           1:  if C <> 0 then
               begin
                   V := C;
                   Len := V and Lmask[factor];
                   if Len = Fcase[factor] then
                     ExState := 2
                   else
                     ExState := 3;
               end
               else
               begin
                   OutByte(DLE);
                   ExState := 0;
               end;

           2:  begin
                  inc(Len,C);
                  ExState := 3;
               end;

           3:  begin
                  op := outpos - C - 1 - ((V shr Dshift[factor]) and
                                          Dand[factor]) * 256;

                  for i := 0 to Len+2 do
                  begin
                     if op < 0 then
                        OutByte(0)
                     else
                        OutByte(outbuf[op mod sizeof(outbuf)]);
                     inc(op);
                  end;

                  ExState := 0;
               end;
      end;
   end;


   procedure LoadFollowers;
   var
      x: integer;
      i: integer;
      b: integer;
   begin
      for x := 255 downto 0 do
      begin
         ReadBits(6,b);
         followers^[x][0] := chr(b);

         for i := 1 to length(followers^[x]) do
         begin
            ReadBits(8,b);
            followers^[x][i] := chr(b);
         end;
      end;
   end;


   function B(x: byte): word;
      {number of bits needed to encode the specified number}
   begin
      case x-1 of
         0..1:    B := 1;
         2..3:    B := 2;
         4..7:    B := 3;
         8..15:   B := 4;
        16..31:   B := 5;
        32..63:   B := 6;
        64..127:  B := 7;
      else        B := 8;
      end;
   end;


(* ----------------------------------------------------------- *)
var
   lchar:   integer;
   lout:    integer;
   I:       integer;
   mem:     longint;

begin
   mem := (sizeof(followers^)+100) - dos_maxavail;
   if mem > 0 then
   begin
      displn(ltoa(mem)+' more bytes of RAM needed to UnReduce!');
      skip_csize;
      exit;
   end;

   factor := cmethod - 1;
   if (factor < 1) or (factor > 4) then
   begin
      skip_csize;
      exit;
   end;

   dos_getmem(followers,sizeof(followers^));
   ExState := 0;
   LoadFollowers;
   lchar := 0;

   while (not zipeof) and (outpos < cusize) and (not dump_user) do
   begin

      if followers^[lchar] = '' then
         ReadBits( 8,lout )
      else

      begin
         ReadBits(1,lout);
         if lout <> 0 then
            ReadBits( 8,lout )
         else
         begin
            ReadBits( B(length(followers^[lchar])), I );
            lout := ord( followers^[lchar][I+1] );
         end;
      end;

      Expand( lout );
      lchar := lout;
   end;

   dos_freemem(followers);
end;



(* ------------------------------------------------------------- *)
(*
 * UnShrinking
 * -----------
 *
 * Shrinking is a Dynamic Ziv-Lempel-Welch compression algorithm
 * with partial clearing.  The initial code size is 9 bits, and
 * the maximum code size is 13 bits.  Shrinking differs from
 * conventional Dynamic Ziv-lempel-Welch implementations in several
 * respects:
 *
 * 1)  The code size is controlled by the compressor, and is not
 *     automatically increased when codes larger than the current
 *     code size are created (but not necessarily used).  When
 *     the decompressor encounters the code sequence 256
 *     (decimal) followed by 1, it should increase the code size
 *     read from the input stream to the next bit size.  No
 *     blocking of the codes is performed, so the next code at
 *     the increased size should be read from the input stream
 *     immediately after where the previous code at the smaller
 *     bit size was read.  Again, the decompressor should not
 *     increase the code size used until the sequence 256,1 is
 *     encountered.
 *
 * 2)  When the table becomes full, total clearing is not
 *     performed.  Rather, when the compresser emits the code
 *     sequence 256,2 (decimal), the decompressor should clear
 *     all leaf nodes from the Ziv-Lempel tree, and continue to
 *     use the current code size.  The nodes that are cleared
 *     from the Ziv-Lempel tree are then re-used, with the lowest
 *     code value re-used first, and the highest code value
 *     re-used last.  The compressor can emit the sequence 256,2
 *     at any time.
 *
 *)

procedure unShrink;

const
   max_bits =  13;
   init_bits = 9;
   first_ent = 257;
   clear =     256;

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

var
   cbits:      integer;
   maxcode:    integer;
   free_ent:   integer;
   maxcodemax: integer;
   offset:     integer;
   sizex:      integer;
   prefix_of:  ^hsize_array_integer;
   suffix_of:  ^hsize_array_byte;
   stack:      hsize_array_byte absolute outbuf;
   stackp:     integer;
   finchar:    integer;
   code:       integer;
   oldcode:    integer;
   incode:     integer;


   (* ------------------------------------------------------------- *)
   procedure partial_clear;
   var
      pr:   integer;
      cd:   integer;

   begin
      {mark all nodes as potentially unused}
      for cd := first_ent to free_ent-1 do
         word(prefix_of^[cd]) := prefix_of^[cd] or $8000;


      {unmark those that are used by other nodes}
      for cd := first_ent to free_ent-1 do
      begin
         pr := prefix_of^[cd] and $7fff;    {reference to another node?}
         if pr >= first_ent then            {flag node as referenced}
            prefix_of^[pr] := prefix_of^[pr] and $7fff;
      end;


      {clear the ones that are still marked}
      for cd := first_ent to free_ent-1 do
         if (prefix_of^[cd] and $8000) <> 0 then
            prefix_of^[cd] := -1;


      {find first cleared node as next free_ent}
      free_ent := first_ent;
      while (free_ent < maxcodemax) and (prefix_of^[free_ent] <> -1) do
         inc(free_ent);
   end;



(* ------------------------------------------------------------- *)
var
   mem:  longint;
begin
   mem := (sizeof(prefix_of^)+sizeof(suffix_of^)+ 100) - dos_maxavail;

   if mem > 0 then
   begin
      displn(ltoa(mem)+' more bytes of RAM needed to UnShrink!');
      skip_csize;
      exit;
   end;


   {allocate heap storage}
   dos_getmem(prefix_of,sizeof(prefix_of^));
   dos_getmem(suffix_of,sizeof(suffix_of^));


   {decompress the file}
   maxcodemax := 1 shl max_bits;
   cbits := init_bits;
   maxcode := (1 shl cbits)- 1;
   free_ent := first_ent;
   offset := 0;
   sizex := 0;

   fillchar(prefix_of^,sizeof(prefix_of^),$FF);
   for code := 255 downto 0 do
   begin
      prefix_of^[code] := 0;
      suffix_of^[code] := code;
   end;

   ReadBits(cbits,oldcode);
   finchar := oldcode;
   if zipeof then
      exit;

   OutByte(finchar);

   stackp := 0;

   while (not zipeof) and (not dump_user) do
   begin
      ReadBits(cbits,code);

      while code = clear do
      begin
         ReadBits(cbits,code);

         case code of
            1: begin
                  inc(cbits);
                  if cbits = max_bits then
                     maxcode := maxcodemax
                  else
                     maxcode := (1 shl cbits) - 1;
               end;

            2: partial_clear;
         end;

         ReadBits(cbits,code);
      end;


      {special case for KwKwK string}
      incode := code;
      if prefix_of^[code] = -1 then
      begin
         stack[stackp] := finchar;
         inc(stackp);
         code := oldcode;
      end;


      {generate output characters in reverse order}
      while (code >= first_ent) do
      begin
         stack[stackp] := suffix_of^[code];
         inc(stackp);
         code := prefix_of^[code];
      end;

      finchar := suffix_of^[code];
      stack[stackp] := finchar;
      inc(stackp);


      {and put them out in forward order}
      while (stackp > 0) do
      begin
         outpos := stackp; {required to preserve shared buffer/stack}
         dec(stackp);
         OutByte(stack[stackp]);
      end;


      {generate new entry}
      code := free_ent;
      if code < maxcodemax then
      begin
         prefix_of^[code] := oldcode;  {previous code}
         suffix_of^[code] := finchar;  {final character from this code}
         while (free_ent < maxcodemax) and (prefix_of^[free_ent] <> -1) do
            inc(free_ent);
      end;


      {remember previous code}
      oldcode := incode;
   end;


   {release heap storage}
   dos_freemem(suffix_of);
   dos_freemem(prefix_of);
end;


(* ------------------------------------------------------------- *)
(*
 * Imploding
 * ---------
 *
 * The Imploding algorithm is actually a combination of two distinct
 * algorithms.  The first algorithm compresses repeated byte sequences
 * using a sliding dictionary.  The second algorithm is used to compress
 * the encoding of the sliding dictionary ouput, using multiple
 * Shannon-Fano trees.
 *
 *)

procedure unImplode;
   {expand imploded data}

   const
      maxSF = 256;

   type
      sf_entry = record
                    Code:       word;
                    Value:      byte;
                    BitLength:  byte;
                 end;

      sf_tree = record  {a shannon-fano tree}
         entry:         array[0..maxSF] of sf_entry;
         entries:       integer;
         MaxLength:     integer;
      end;

      sf_treep = ^sf_tree;

   var
      lit_tree:               sf_treep;
      length_tree:            sf_treep;
      distance_tree:          sf_treep;
      lit_tree_present:       boolean;
      eightK_dictionary:      boolean;
      minimum_match_length:   integer;
      dict_bits:              integer;


   (* ----------------------------------------------------------- *)
   procedure LoadTree(var tree: sf_treep;
                      treesize: integer);
      {allocate and load a shannon-fano tree from the compressed file}

      procedure SortLengths;
         {Sort the Bit Lengths in ascending order, while retaining the order
          of the original lengths stored in the file}
      var
         x:       integer;
         gap:     integer;
         t:       sf_entry;
         noswaps: boolean;
         a,b:     word;

      begin
         gap := treesize div 2;

         with tree^ do
         repeat
            repeat
               noswaps := true;
               for x := 0 to (treesize-1)-gap do
               begin
                  a := entry[x].BitLength;
                  b := entry[x+gap].BitLength;
                  if (a > b) or
                     ((a = b) and (entry[x].Value > entry[x+gap].Value)) then
                  begin
                     t := entry[x];
                     entry[x] := entry[x+gap];
                     entry[x+gap] := t;
                     noswaps := false;
                  end;
               end;
            until noswaps;

            gap := gap div 2;
         until gap < 1;
      end;


      procedure ReadLengths;
      var
         treeBytes:  integer;
         i:          integer;
         num,len:    integer;
      begin
         {get number of bytes in compressed tree}
         ReadBits(8,treeBytes);
         inc(treeBytes);
         i := 0;
         with tree^ do
         begin
            MaxLength := 0;

            {High 4 bits: Number of values at this bit length + 1. (1 - 16)
             Low  4 bits: Bit Length needed to represent value + 1. (1 - 16)}
            while treeBytes > 0 do
            begin
               ReadBits(4,len);  inc(len);
               ReadBits(4,num);  inc(num);

               while num > 0 do
               with entry[i] do
               begin
                  if len > MaxLength then
                     MaxLength := len;
                  BitLength := len;
                  Value := i;
                  inc(i);
                  dec(num);
               end;

               dec(treeBytes);
            end;
         end;
      end;

      procedure GenerateTrees;
         {Generate the Shannon-Fano trees}
      var
         Code:          word;
         CodeIncrement: integer;
         LastBitLength: integer;
         i:             integer;
      begin
         Code := 0;
         CodeIncrement := 0;
         LastBitLength := 0;

         i := treesize - 1;   {either 255 or 63}
         with tree^ do
         while i >= 0 do
         begin
            inc(Code,CodeIncrement);
            if entry[i].BitLength <> LastBitLength then
            begin
               LastBitLength := entry[i].BitLength;
               CodeIncrement := 1 shl (16 - LastBitLength);
            end;

            entry[i].Code := Code;
            dec(i);
         end;
      end;

      procedure ReverseBits;
         {Reverse the order of all the bits in the above ShannonCode[]
          vector, so that the most significant bit becomes the least
          significant bit. For example, the value 0x1234 (hex) would become
          0x2C48 (hex).}
      var
         i:    integer;
         mask: word;
         revb: word;
         v:    word;
         o:    word;
         b:    integer;

      begin
         for i := 0 to treesize-1 do
         begin
            {get original code}
            o := tree^.entry[i].Code;

            {reverse each bit}
            mask := $0001;
            revb := $8000;
            v := 0;
            for b := 0 to 15 do
            begin
               {if bit set in mask, then substitute reversed bit}
               if (o and mask) <> 0 then
                  v := v or revb;

               {advance to next bit}
               revb := revb shr 1;
               mask := mask shl 1;
            end;

            {store reversed bits}
            tree^.entry[i].Code := v;
         end;
      end;

   begin
      dos_getmem(tree,sizeof(tree^));
      tree^.entries := treesize;
      ReadLengths;
      SortLengths;
      GenerateTrees;
      ReverseBits;
   end;


   (* ----------------------------------------------------------- *)
   procedure LoadTrees;
   begin
      eightK_dictionary := (cflags and $02) <> 0; {bit 1}
      lit_tree_present := (cflags and $04) <> 0; {bit 2}

      if eightK_dictionary then
         dict_bits := 7
      else
         dict_bits := 6;

      if lit_tree_present then
      begin
         minimum_match_length := 3;
         LoadTree(lit_tree,256);
      end
      else
         minimum_match_length := 2;

      LoadTree(length_tree,64);
      LoadTree(distance_tree,64);
   end;


   (* ----------------------------------------------------------- *)
   procedure ReadTree(tree: sf_treep;
                      var dest: integer);
      {read next byte using a shannon-fano tree}
   var
      bits: integer;
      cv:   word;
      b:    integer;
      cur:  integer;

   begin
      bits := 0;
      cv := 0;
      cur := 0;
      dest := -1; {in case of error}

      with tree^ do
      while true do
      begin
         ReadBits(1,b);
         cv := cv or (b shl bits);
         inc(bits);

         while entry[cur].BitLength < bits do
         begin
            inc(cur);
            if cur >= entries then
               exit;
         end;

         while entry[cur].BitLength = bits do
         begin
            if entry[cur].Code = cv then
            begin
               dest := entry[cur].Value;
               exit;
            end;

            inc(cur);
            if cur >= entries then
               exit;
         end;
      end;

   end;


(* ----------------------------------------------------------- *)
var
   lout:       integer;
   mem:        longint;
   op:         longint;
   Length:     integer;
   Distance:   integer;
   i:          integer;

begin
   mem := (sizeof(sf_tree)*3+100) - dos_maxavail;
   if mem > 0 then
   begin
      displn(ltoa(mem)+' more bytes of RAM needed to UnImplode!');
      skip_csize;
      exit;
   end;

   LoadTrees;

   while (not zipeof) and (outpos < cusize) and (not dump_user) do
   begin
      ReadBits(1,lout);

      if lout <> 0 then    {encoded data is literal data}
      begin
         if lit_tree_present then
            ReadTree(lit_tree,lout)   {use Literal Shannon-Fano tree}
         else
            ReadBits(8,lout);

         OutByte(lout);
      end
      else

      begin          {encoded data is sliding dictionary match}
         readBits(dict_bits,lout);
         Distance := lout;

         ReadTree(distance_tree,lout);
         Distance := Distance or (lout shl dict_bits);
         {using the Distance Shannon-Fano tree, read and decode the
            upper 6 bits of the Distance value}

         ReadTree(length_tree,Length);
         {using the Length Shannon-Fano tree, read and decode the Length value}

         inc(Length,Minimum_Match_Length);
         if Length = (63 + Minimum_Match_Length) then
         begin
            ReadBits(8,lout);
            inc(Length,lout);
         end;

         {move backwards Distance+1 bytes in the output stream, and copy
          Length characters from this position to the output stream.
          (if this position is before the start of the output stream,
          then assume that all the data before the start of the output
          stream is filled with zeros)}

         op := outpos - Distance - 1;
         for i := 1 to Length do
         begin
            if op < 0 then
               OutByte(0)
            else
               OutByte(outbuf[op mod sizeof(outbuf)]);
            inc(op);
         end;
      end;
   end;

   if lit_tree_present then
      dos_freemem(lit_tree);
   dos_freemem(distance_tree);
   dos_freemem(length_tree);
end;



(* ---------------------------------------------------------- *)
(*
 * This procedure displays the text contents of a specified archive
 * file.  The filename must be fully specified and verified.
 *
 *)
procedure viewfile;
var
   b: byte;

begin
   newline;
   default_color;
   binary_count := 0;
   pcbits := 0;
   incnt := 0;
   outpos := 0;
   uoutbuf := '';
   zipeof := false;

   case cmethod of
      0:    {stored}
            while (not zipeof) and (not dump_user) do
            begin
               ReadByte(b);
               OutByte(b);
            end;

      1:    UnShrink;

      2..5: UnReduce;

      6:    UnImplode;

      else  displn('Unknown compression method.');
   end;

   if nomore=false then
      newline;

   linenum := 1;
end;


(* ---------------------------------------------------------- *)
procedure _itoa(i: integer; var sp);
var
   s: array[1..2] of char absolute sp;
begin
   s[1] := chr( (i div 10) + ord('0'));
   s[2] := chr( (i mod 10) + ord('0'));
end;

function format_date(date: word): string8;
const
   s:       string8 = 'mm-dd-yy';
begin
   _itoa(((date shr 9) and 127)+80, s[7]);
   _itoa( (date shr 5) and 15,  s[1]);
   _itoa( (date      ) and 31,  s[4]);
   format_date := s;
end;

function format_time(time: word): string8;
const
   s:       string8 = 'hh:mm:ss';
begin
   _itoa( (time shr 11) and 31, s[1]);
   _itoa( (time shr  5) and 63, s[4]);
   _itoa( (time shl  1) and 63, s[7]);
   format_time := s;
end;


(* ---------------------------------------------------------- *)
procedure process_local_file_header;
var
   n:             word;
   rec:           local_file_header;
   filename:      string;
   extra:         string;
   fpos:          longint;

begin
   dos_lseek(zipfd,0,seek_cur);
   fpos := dos_tell;

   while (dump_user = false) do
   begin
      set_function(fun_arcview);

      dos_lseek(zipfd,fpos,seek_start);
      n := dos_read(zipfd,rec,sizeof(rec));
      get_string(rec.filename_length,filename);
      filename := remove_path(filename);
      stoupper(filename);
      get_string(rec.extra_field_length,extra);
      csize := rec.compressed_size;
      cusize := rec.uncompressed_size;
      cmethod := rec.compression_method;
      cflags := rec.general_purpose_bit_flag;


      (* exclude the file if outside current pattern *)
      if nomore or (not wildcard_match(pattern,filename)) then
      begin
         skip_csize;
         exit;
      end;

      (* display file information headers if needed *)
      if not header_present then
      begin
         header_present := true;

         newline;
         disp(' File Name    Length   Method     Date      Time');
         if expand_files then disp('    (Enter) or (S)kip, (V)iew');
         newline;

         disp('------------  ------  --------  --------  --------');
         if expand_files then disp('  -------------------------');
         newline;
      end;


      (* display file information *)
      disp(ljust(filename,12)+' '+
           rjust(ltoa(rec.uncompressed_size),7)+'  '+
           compression_methods[rec.compression_method]+'  '+
           format_date(rec.last_mod_file_date)+'  '+
           format_time(rec.last_mod_file_time));

      if not expand_files then
      begin
         skip_csize;
         newline;
         exit;
      end;


      (* determine action to perform on this member file *)
      action := 'S';
      disp('  Action? ');
      input(action,1);
      stoupper(action);

      case action[1] of
         'S':
            begin
               displn(' [Skip]');
               skip_csize;
               exit;
            end;

         'V','R':
            begin
               displn(' [View]');
               viewfile;

               header_present := false;

            {  make_log_entry('View archive member ('+extname
                                        +') from ('+remove_path(arcname)
                                        +')',true); }
            end;

         'Q':
            begin
               displn(' [Quit]');
               dos_lseek(zipfd,0,seek_end);
               exit;
            end;

         else
            displn(' [Type S, V or Q!]');
      end;
   end;
end;


(* ---------------------------------------------------------- *)
procedure process_central_file_header;
var
   n:             word;
   rec:           central_directory_file_header;
   filename:      string;
   extra:         string;
   comment:       string;

begin
   n := dos_read(zipfd,rec,sizeof(rec));
   get_string(rec.filename_length,filename);
   get_string(rec.extra_field_length,extra);
   get_string(rec.file_comment_length,comment);
  {dos_lseek(zipfd,rec.compressed_size,seek_cur);}
end;


(* ---------------------------------------------------------- *)
procedure process_end_central_dir;
var
   n:             word;
   rec:           end_central_dir_record;
   comment:       string;

begin
   n := dos_read(zipfd,rec,sizeof(rec));
   get_string(rec.zipfile_comment_length,comment);
end;


(* ---------------------------------------------------------- *)
procedure process_headers;
var
   sig:  longint;

begin
   dos_lseek(zipfd,0,seek_start);
   header_present := false;

   while (not dump_user) do
   begin
      if nomore or (dos_read(zipfd,sig,sizeof(sig)) <> sizeof(sig)) then
         exit
      else

      if sig = local_file_header_signature then
         process_local_file_header
      else

      if sig = central_file_header_signature then
         process_central_file_header
      else

      if sig = end_central_dir_signature then
      begin
         process_end_central_dir;
         exit;
      end

      else
      begin
         displn('Invalid Zipfile Header');
         exit;
      end;
   end;

end;


(* ---------------------------------------------------------- *)
procedure select_pattern;
begin
   default_pattern := '*.*';

   while true do
   begin
      newline;
      disp(remove_path(zipfn));
      get_def(': View member filespec:', enter_eq+default_pattern+'? ');

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

      if (pattern = 'none') or (pattern = 'Q') or dump_user then
         exit;

      process_headers;

      default_pattern := 'none';
   end;
end;


(* ---------------------------------------------------------- *)
procedure view_zipfile;
begin
   zipfd := dos_open(zipfn,open_read);
   if zipfd = dos_error then
      exit;

   if expand_files then
      select_pattern
   else
   begin
      pattern := '*.*';
      process_headers;
   end;

   dos_close(zipfd);
end;



(* ---------------------------------------------------------- *)
procedure process_zipfile(name: filenames);
var
   mem:    longint;

begin
   linenum := 1;
   cmdline := '';
   expand_files := false;
   zipfn := name;
   view_zipfile;

   newline;
   get_def('View text files in this zipfile:','(Enter)=yes? ');

   (* process text viewing if desired *)
   get_nextpar;
   if par[1] <> 'N' then
   begin
      expand_files := true;
      view_zipfile;
   end;
end;


(*
 * main program
 *
 *)

var
   i:      integer;
   par:    anystring;

begin
   gotoxy(60,scroll_line+1);
   reverseVideo;
   disp(' ZipTV ');

   SetScrollPoint(scroll_line);
   gotoxy(1,23);  lowVideo;
   linenum := 1;

   if paramcount = 0 then
   begin
{     newline;
      displn(version);
      displn('Courtesy of:  S.H.Smith  and  The Tool Shop BBS,  [phone].');
      newline;  }

      displn('Usage:  ziptv [-Pport] [-Tminutes] [-Llines] FILE[.zip]');

{     newline;
      displn('-Pn   enables com port COMn and monitors carrier');
      displn('-Tn   allows user to stay in program for n minutes');
      displn('-Ln   sets lines per screen');
}
      halt;
   end;

   for i := 1 to paramcount do
   begin
      par := paramstr(i);

      if par[1] = '-' then
         case upcase(par[2]) of
            'P':  opencom(ord(par[3]) - ord('0'));
            'T':  tlimit := atoi(copy(par,3,5));
            'L':  user.pagelen := atoi(copy(par,3,5));
         end
      else

      begin
        if pos('.',par) = 0 then
            par := par + '.ZIP';

        if dos_exists(par) then
            process_zipfile(par)
        else
            displn('File not found: '+par);
      end;
   end;

   newline;
   displn(version);
   closecom;
end.