[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]

    (*
     * Copyright 1987, 1990 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:  ZIP Text Viewer v2.1 of 04-22-90;  (C) 1990 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
       {general_purpose_bit_flag bit values}
       GP_encrypted   = 1;     {file is encrypted}
       GP_8K_dict     = 2;     {8k implode dictionary}
       GP_lit_tree    = 4;     {literal implode tree is present}

    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}

       maxlines: integer = 500;
                            {maximum lines per session}

    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!');
          linenum := 1000;
          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
       10:  begin
               if linenum < 1000 then
               begin
                  flushbuf;
                  newline;

                  dec(maxlines);
                  if (maxlines < 1) and (not dump_user) then
                  begin
                      newline;
                      displn('You''ve seen enough.  Please download this file if you want to see more.');
                      dump_user := true;
                  end;
               end;

               if nomore or dump_user then
                  skip_rest;
            end;

       13:   ;

       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) and (stackp < sizeof(stack)-1) 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 GP_8k_dict)  <> 0;
          lit_tree_present  := (cflags and GP_lit_tree) <> 0;

          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;

       if (cflags and GP_encrypted) <> 0 then
       begin
          displn('File is encrypted.');
          skip_csize;
          exit;
       end;

       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  begin
                   displn('Unknown compression method.');
                   skip_csize;
                end;
       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;
       n:    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
          displn(version);
    {     newline;
          displn('Courtesy of:  S.H.Smith  and  The Tool Shop BBS,  (602) 279-2673.');
          newline;  }

          displn('Usage:  ziptv [-Pport] [-Tminutes] [-Llines] [-Mlines] 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');
          displn('-Mn   sets maximum lines per session');
    }
          halt;
       end;

       for i := 1 to paramcount do
       begin
          par := paramstr(i);
          n := atoi(copy(par,3,5));

          if par[1] = '-' then
             case upcase(par[2]) of
                'P':  opencom(n);
                'T':  tlimit := n;      {time limit}
                'L':  user.pagelen := n;
                'M':  maxlines := n;
             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.

[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]