home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / VMUNZIP.ZIP / VMUNZIP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-08-05  |  37.4 KB  |  1,361 lines
  1. %margins 1 80
  2. %check on
  3. (*
  4.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  5.  *
  6.  * This is a component of the ProDoor System.
  7.  * Do not distribute modified versions without my permission.
  8.  * Do not remove or alter this notice or any other copyright notice.
  9.  * If you use this in your own program you must distribute source code.
  10.  * Do not use any of this in a commercial product.
  11.  *
  12.  * Modifications to run under VM/CMS made by John McKown
  13.  * CompuServe Id: 72325,1705
  14.  * Last Modified date: July, 1989
  15.  *)
  16. (*
  17.  * UnZip - A simple zipfile extract utility
  18.  *
  19.  *)
  20.  
  21.  
  22. program VmUnZip;
  23.  
  24. %include CMS
  25.  
  26. const
  27.    version = 'UnZip:  Zipfile Extract v1.1. of 03-06-89;  (C) 1989 S.H.Smith';
  28.  
  29. (*
  30.  * ProZip2.int - ZIP file interface library      (2-15-89 shs)
  31.  * Data declarations for the archive text-view functions.
  32.  *)
  33.  
  34. (*
  35.  * ZIPfile layout declarations
  36.  *
  37.  *)
  38.  
  39. const
  40.    local_file_header_signature = '04034b50'x;
  41.    central_file_header_signature = '02014b50'x;
  42.    end_central_dir_signature = '06054b50'x;
  43.    def_string_size = 3000;
  44.  
  45. (*
  46.  * defines for turbo pascal datatypes
  47.  *)
  48. type
  49.  pcint = packed -32768..32767;
  50.  byte = packed 0..255;
  51.  shortint = packed -128..127;
  52.  UPCINT = PACKED 0..65535;
  53.  LONGINT = ARRAY(.0..3.) OF BYTE ;
  54.  WORD = ARRAY(.0..1.) OF BYTE;
  55.  
  56. type
  57.    zipfile = record
  58.          filename: string(20);
  59.          realfile: file of byte;
  60.          end;
  61.    outfile = record
  62.          filename: string(20);
  63.          realfile: file of byte;
  64.          end;
  65.    signature_type = longint;
  66.    local_file_header = record
  67.      $version_needed_to_extract:    word;
  68.      $general_purpose_bit_flag:     word;
  69.      $compression_method:           word;
  70.      $last_mod_file_time:           word;
  71.      $last_mod_file_date:           word;
  72.      $crc32:                        longint;
  73.      $compressed_size:              longint;
  74.      $uncompressed_size:            longint;
  75.      $filename_length:              word;
  76.      $extra_field_length:           word;
  77.    end;
  78.    central_directory_file_header = record
  79.      $version_made_by:                 word;
  80.      $version_needed_to_extract:       word;
  81.      $general_purpose_bit_flag:        word;
  82.      $compression_method:              word;
  83.      $last_mod_file_time:              word;
  84.      $last_mod_file_date:              word;
  85.      $crc32:                           longint;
  86.      $compressed_size:                 longint;
  87.      $uncompressed_size:               longint;
  88.      $filename_length:                 word;
  89.      $extra_field_length:              word;
  90.      $file_comment_length:             word;
  91.      $disk_number_start:               word;
  92.      $internal_file_attributes:        word;
  93.      $external_file_attributes:        longint;
  94.      $relative_offset_local_header:    longint;
  95.    end;
  96.    end_central_dir_record = record
  97.      $number_this_disk:                         word;
  98.      $number_disk_with_start_central_directory: word;
  99.      $total_entries_central_dir_on_this_disk:   word;
  100.      $total_entries_central_dir:                word;
  101.      $size_central_directory:                   longint;
  102.      $offset_start_central_directory:           longint;
  103.      $zipfile_comment_length:                   word;
  104.    end;
  105.  
  106.  
  107.  
  108. (* ----------------------------------------------------------- *)
  109. (*
  110.  * input file variables
  111.  *
  112.  *)
  113.  
  114. const
  115.    uinbufsize = 512;    /*input buffer size*/
  116.  
  117. type
  118.  uinbufarray = array(.1..uinbufsize.) of byte;
  119.  outbufarray = array(.0..4096.) of byte;
  120.  
  121. var
  122.    Crc32Val:    Integer;
  123.    InCrc:       Integer;
  124.    zipname:     string(8);
  125.    zipeof:      boolean;
  126.    csize:       integer;
  127.    cusize:      integer;
  128.    cmethod:     pcint;
  129.    ctime:       integer;
  130.    cdate:       integer;
  131.    inbuf:       uinbufarray;
  132.    inpos:       pcint;
  133.    incnt:       pcint;
  134.    pc:          byte;
  135.    pcbits:      byte;
  136.    pcbitv:      byte;
  137.    zipfn:       zipfile;
  138.    myparms:     string(120);
  139.    i:           integer;
  140.    filename_length:integer;
  141.    extra_field_length:integer;
  142.    zipfile_comment_length:integer;
  143.    file_comment_length:integer;
  144.    coptions : (PROMPT, REPLACE, BYPASS);
  145.    optstr : ALPHA;
  146.  
  147. (*
  148.  * output stream variables
  149.  *
  150.  *)
  151.  
  152. var
  153.    outbuf:      outbufarray;            /*for rle look-back*/
  154.    outpos:      integer;                /*absolute position in outfile*/
  155.    outcnt:      pcint;
  156.    outfd:       outfile;
  157.    filename:    string(def_string_size);
  158.    extra:       string(def_string_size);
  159.    out_zip:     file of byte;
  160.  
  161. (* ----------------------------------------------------------- *)
  162.  
  163. type
  164.    Sarray = array(.0..255.) of string(64);
  165.  
  166. var
  167.    factor:     pcint;
  168.    followers:  Sarray;
  169.    ExState:    pcint;
  170.    C:          pcint;
  171.    V:          pcint;
  172.    Len:        pcint;
  173.  
  174. const
  175.    hsize =     8192;
  176.  
  177. type
  178.    hsize_array_integer = array(.0..hsize.) of pcint;
  179.    hsize_array_byte    = array(.0..hsize.) of byte;
  180.  
  181. var
  182.    prefix_of:  hsize_array_integer;
  183.    suffix_of:  hsize_array_byte;
  184.    stack:      hsize_array_byte;
  185.    stackp:     pcint;
  186.  
  187. (*
  188.  * Zipfile input/output handlers
  189.  *
  190.  *)
  191.  
  192. /* Converted to IBM VS Pascal 1.0 July, 1989 by John McKown                  */
  193. /* Converted to Turbo Pascal (tm) V4.0 March, 1988 by J.R.Louvau             */
  194. /* COPYRIGHT (C) 1986 Gary S. Brown. You may use this program, or            */
  195. /* code or tables extracted from it, as desired without restriction.         */
  196. /*                                                                           */
  197. /* First, the polynomial itself and its table of feedback terms. The         */
  198. /* polynomial is                                                             */
  199. /* X@32+X@26+X@23+X@22+X@16+X@12+X@11+X@10+X@8+X@7+X@5+X@4+X@2+X@1+X@0       */
  200. /*                                                                           */
  201. /* Note that we take it "backwards" and put the highest-order term in        */
  202. /* the lowest-order bit. The X@32 term is "implied"; the LSB is the          */
  203. /* X@31 term, etc. The X@0 term (usually shown as "+1") results in           */
  204. /* the MSB being 1.                                                          */
  205. /*                                                                           */
  206. /* Note that the usual hardware shift register implementation, which         */
  207. /* is what we're using (we're merely optimizing it by doing eight-bit        */
  208. /* chunks at a time) shifts bits into the lowest-order term. In our          */
  209. /* implementation, that means shifting towards the right. Why do we          */
  210. /* do it this way? Because the calculated CRC must be transmitted in         */
  211. /* order from highest-order term to lowest-order term. UARTs transmit        */
  212. /* characters in order from LSB to MSB. By storing the CRC this way,         */
  213. /* we hand it to the UART in the order low-byte to high-byte; the UART       */
  214. /* sends each low-bit to hight-bit; and the result is transmission bit       */
  215. /* by bit from highest- to lowest-order term without requiring any bit       */
  216. /* shuffling on our part. Reception works similarly.                         */
  217. /*                                                                           */
  218. /* The feedback terms table consists of 256, 32-bit entries. Notes:          */
  219. /*                                                                           */
  220. /*    The table can be generated at runtime if desired; code to do so        */
  221. /*    is shown later.  It might not be obvious, but the feedback             */
  222. /*    terms simply represent the results of eight shift/xor opera-           */
  223. /*    tions for all combinations of data and CRC register values.            */
  224. /*                                                                           */
  225. /*    The values must be right-shifted by eight bits by the "updcrc"         */
  226. /*    logic; the shift must be unsigned (bring in zeroes).  On some          */
  227. /*    hardware you could probably optimize the shift in assembler by         */
  228. /*    using byte-swap instructions.                                          */
  229. /*    polynomial 'edb88320'x                                                 */
  230. /*                                                                           */
  231.  
  232.  
  233. Function UpdC32(Octet: Byte; Crc: Integer) : Integer;
  234. (*
  235.  Note that the Crc needs to be initialized to -1 (all bits on)
  236.  Thereafter, this function is called as follows:
  237.  NewCrcVal := UpdC32(InputByte,OldCrcVal);
  238. *)
  239. type
  240.  Int256 = Array(.0..255.) of Integer;
  241. Static
  242.  CRC_32_TAB : Int256;
  243. Value
  244.    CRC_32_TAB := Int256 (
  245. '00000000'x, '77073096'x, 'ee0e612c'x, '990951ba'x, '076dc419'x,
  246. '706af48f'x, 'e963a535'x, '9e6495a3'x, '0edb8832'x, '79dcb8a4'x,
  247. 'e0d5e91e'x, '97d2d988'x, '09b64c2b'x, '7eb17cbd'x, 'e7b82d07'x,
  248. '90bf1d91'x, '1db71064'x, '6ab020f2'x, 'f3b97148'x, '84be41de'x,
  249. '1adad47d'x, '6ddde4eb'x, 'f4d4b551'x, '83d385c7'x, '136c9856'x,
  250. '646ba8c0'x, 'fd62f97a'x, '8a65c9ec'x, '14015c4f'x, '63066cd9'x,
  251. 'fa0f3d63'x, '8d080df5'x, '3b6e20c8'x, '4c69105e'x, 'd56041e4'x,
  252. 'a2677172'x, '3c03e4d1'x, '4b04d447'x, 'd20d85fd'x, 'a50ab56b'x,
  253. '35b5a8fa'x, '42b2986c'x, 'dbbbc9d6'x, 'acbcf940'x, '32d86ce3'x,
  254. '45df5c75'x, 'dcd60dcf'x, 'abd13d59'x, '26d930ac'x, '51de003a'x,
  255. 'c8d75180'x, 'bfd06116'x, '21b4f4b5'x, '56b3c423'x, 'cfba9599'x,
  256. 'b8bda50f'x, '2802b89e'x, '5f058808'x, 'c60cd9b2'x, 'b10be924'x,
  257. '2f6f7c87'x, '58684c11'x, 'c1611dab'x, 'b6662d3d'x, '76dc4190'x,
  258. '01db7106'x, '98d220bc'x, 'efd5102a'x, '71b18589'x, '06b6b51f'x,
  259. '9fbfe4a5'x, 'e8b8d433'x, '7807c9a2'x, '0f00f934'x, '9609a88e'x,
  260. 'e10e9818'x, '7f6a0dbb'x, '086d3d2d'x, '91646c97'x, 'e6635c01'x,
  261. '6b6b51f4'x, '1c6c6162'x, '856530d8'x, 'f262004e'x, '6c0695ed'x,
  262. '1b01a57b'x, '8208f4c1'x, 'f50fc457'x, '65b0d9c6'x, '12b7e950'x,
  263. '8bbeb8ea'x, 'fcb9887c'x, '62dd1ddf'x, '15da2d49'x, '8cd37cf3'x,
  264. 'fbd44c65'x, '4db26158'x, '3ab551ce'x, 'a3bc0074'x, 'd4bb30e2'x,
  265. '4adfa541'x, '3dd895d7'x, 'a4d1c46d'x, 'd3d6f4fb'x, '4369e96a'x,
  266. '346ed9fc'x, 'ad678846'x, 'da60b8d0'x, '44042d73'x, '33031de5'x,
  267. 'aa0a4c5f'x, 'dd0d7cc9'x, '5005713c'x, '270241aa'x, 'be0b1010'x,
  268. 'c90c2086'x, '5768b525'x, '206f85b3'x, 'b966d409'x, 'ce61e49f'x,
  269. '5edef90e'x, '29d9c998'x, 'b0d09822'x, 'c7d7a8b4'x, '59b33d17'x,
  270. '2eb40d81'x, 'b7bd5c3b'x, 'c0ba6cad'x, 'edb88320'x, '9abfb3b6'x,
  271. '03b6e20c'x, '74b1d29a'x, 'ead54739'x, '9dd277af'x, '04db2615'x,
  272. '73dc1683'x, 'e3630b12'x, '94643b84'x, '0d6d6a3e'x, '7a6a5aa8'x,
  273. 'e40ecf0b'x, '9309ff9d'x, '0a00ae27'x, '7d079eb1'x, 'f00f9344'x,
  274. '8708a3d2'x, '1e01f268'x, '6906c2fe'x, 'f762575d'x, '806567cb'x,
  275. '196c3671'x, '6e6b06e7'x, 'fed41b76'x, '89d32be0'x, '10da7a5a'x,
  276. '67dd4acc'x, 'f9b9df6f'x, '8ebeeff9'x, '17b7be43'x, '60b08ed5'x,
  277. 'd6d6a3e8'x, 'a1d1937e'x, '38d8c2c4'x, '4fdff252'x, 'd1bb67f1'x,
  278. 'a6bc5767'x, '3fb506dd'x, '48b2364b'x, 'd80d2bda'x, 'af0a1b4c'x,
  279. '36034af6'x, '41047a60'x, 'df60efc3'x, 'a867df55'x, '316e8eef'x,
  280. '4669be79'x, 'cb61b38c'x, 'bc66831a'x, '256fd2a0'x, '5268e236'x,
  281. 'cc0c7795'x, 'bb0b4703'x, '220216b9'x, '5505262f'x, 'c5ba3bbe'x,
  282. 'b2bd0b28'x, '2bb45a92'x, '5cb36a04'x, 'c2d7ffa7'x, 'b5d0cf31'x,
  283. '2cd99e8b'x, '5bdeae1d'x, '9b64c2b0'x, 'ec63f226'x, '756aa39c'x,
  284. '026d930a'x, '9c0906a9'x, 'eb0e363f'x, '72076785'x, '05005713'x,
  285. '95bf4a82'x, 'e2b87a14'x, '7bb12bae'x, '0cb61b38'x, '92d28e9b'x,
  286. 'e5d5be0d'x, '7cdcefb7'x, '0bdbdf21'x, '86d3d2d4'x, 'f1d4e242'x,
  287. '68ddb3f8'x, '1fda836e'x, '81be16cd'x, 'f6b9265b'x, '6fb077e1'x,
  288. '18b74777'x, '88085ae6'x, 'ff0f6a70'x, '66063bca'x, '11010b5c'x,
  289. '8f659eff'x, 'f862ae69'x, '616bffd3'x, '166ccf45'x, 'a00ae278'x,
  290. 'd70dd2ee'x, '4e048354'x, '3903b3c2'x, 'a7672661'x, 'd06016f7'x,
  291. '4969474d'x, '3e6e77db'x, 'aed16a4a'x, 'd9d65adc'x, '40df0b66'x,
  292. '37d83bf0'x, 'a9bcae53'x, 'debb9ec5'x, '47b2cf7f'x, '30b5ffe9'x,
  293. 'bdbdf21c'x, 'cabac28a'x, '53b39330'x, '24b4a3a6'x, 'bad03605'x,
  294. 'cdd70693'x, '54de5729'x, '23d967bf'x, 'b3667a2e'x, 'c4614ab8'x,
  295. '5d681b02'x, '2a6f2b94'x, 'b40bbe37'x, 'c30c8ea1'x, '5a05df1b'x,
  296. '2d02ef8d'x
  297. );
  298.  
  299. Var
  300.  Temp:record
  301.    case boolean of
  302.    true:(L:Integer;);
  303.    false:(W:Array(.1..4.) of Byte;);
  304.    end;
  305. Begin
  306.  
  307.    Temp.L := 0;
  308.    Temp.W(.4.) := Octet;
  309. (* the above two lines convert a byte to an integer *)
  310.    Temp.L := Crc XOR Temp.L;
  311.    UpdC32 := CRC_32_TAB(.Temp.W(.4.).) XOR (Crc >> 8);
  312.  
  313. end /*UpdC32*/;
  314.  
  315. Function a2e(in_char:char):char;
  316. type
  317.  a2edata = array(.0..255.) of char;
  318. static
  319.  a2evalue:a2edata;
  320. value
  321.  a2evalue := a2edata (
  322.    '00'xc,'01'xc,'02'xc,'03'xc,'37'xc,'2D'xc,'2E'xc,'2F'xc,
  323.    '16'xc,'05'xc,'25'xc,'0B'xc,'0C'xc,'0D'xc,'0E'xc,'0F'xc,
  324.    '10'xc,'11'xc,'12'xc,'13'xc,'3C'xc,'3D'xc,'32'xc,'26'xc,
  325.    '18'xc,'19'xc,'3F'xc,'27'xc,'1C'xc,'1D'xc,'1E'xc,'1F'xc,
  326.    '40'xc,'5A'xc,'7F'xc,'7B'xc,'5B'xc,'6C'xc,'50'xc,'7D'xc,
  327.    '4D'xc,'5D'xc,'5C'xc,'4E'xc,'6B'xc,'60'xc,'4B'xc,'61'xc,
  328.    'F0'xc,'F1'xc,'F2'xc,'F3'xc,'F4'xc,'F5'xc,'F6'xc,'F7'xc,
  329.    'F8'xc,'F9'xc,'7A'xc,'5E'xc,'4C'xc,'7E'xc,'6E'xc,'6F'xc,
  330.    '7C'xc,'C1'xc,'C2'xc,'C3'xc,'C4'xc,'C5'xc,'C6'xc,'C7'xc,
  331.    'C8'xc,'C9'xc,'D1'xc,'D2'xc,'D3'xc,'D4'xc,'D5'xc,'D6'xc,
  332.    'D7'xc,'D8'xc,'D9'xc,'E2'xc,'E3'xc,'E4'xc,'E5'xc,'E6'xc,
  333.    'E7'xc,'E8'xc,'E9'xc,'AD'xc,'E0'xc,'BD'xc,'5F'xc,'6D'xc,
  334.    '79'xc,'81'xc,'82'xc,'83'xc,'84'xc,'85'xc,'86'xc,'87'xc,
  335.    '88'xc,'89'xc,'91'xc,'92'xc,'93'xc,'94'xc,'95'xc,'96'xc,
  336.    '97'xc,'98'xc,'99'xc,'A2'xc,'A3'xc,'A4'xc,'A5'xc,'A6'xc,
  337.    'A7'xc,'A8'xc,'A9'xc,'8B'xc,'4F'xc,'9B'xc,'A1'xc,'07'xc,
  338.    '00'xc,'01'xc,'02'xc,'03'xc,'37'xc,'2D'xc,'2E'xc,'2F'xc,
  339.    '16'xc,'05'xc,'25'xc,'0B'xc,'0C'xc,'0D'xc,'0E'xc,'0F'xc,
  340.    '10'xc,'11'xc,'12'xc,'13'xc,'3C'xc,'3D'xc,'32'xc,'26'xc,
  341.    '18'xc,'19'xc,'3F'xc,'27'xc,'1C'xc,'1D'xc,'1E'xc,'1F'xc,
  342.    '40'xc,'5A'xc,'7F'xc,'7B'xc,'5B'xc,'6C'xc,'50'xc,'7D'xc,
  343.    '4D'xc,'5D'xc,'5C'xc,'4E'xc,'6B'xc,'60'xc,'4B'xc,'61'xc,
  344.    'F0'xc,'F1'xc,'F2'xc,'F3'xc,'F4'xc,'F5'xc,'F6'xc,'F7'xc,
  345.    'F8'xc,'F9'xc,'7A'xc,'5E'xc,'4C'xc,'7E'xc,'6E'xc,'6F'xc,
  346.    '7C'xc,'C1'xc,'C2'xc,'C3'xc,'C4'xc,'C5'xc,'C6'xc,'C7'xc,
  347.    'C8'xc,'C9'xc,'D1'xc,'D2'xc,'D3'xc,'D4'xc,'D5'xc,'D6'xc,
  348.    'D7'xc,'D8'xc,'D9'xc,'E2'xc,'E3'xc,'E4'xc,'E5'xc,'E6'xc,
  349.    'E7'xc,'E8'xc,'E9'xc,'AD'xc,'E0'xc,'BD'xc,'5F'xc,'6D'xc,
  350.    '79'xc,'81'xc,'82'xc,'83'xc,'84'xc,'85'xc,'86'xc,'87'xc,
  351.    '88'xc,'89'xc,'91'xc,'92'xc,'93'xc,'94'xc,'95'xc,'96'xc,
  352.    '97'xc,'98'xc,'99'xc,'A2'xc,'A3'xc,'A4'xc,'A5'xc,'A6'xc,
  353.    'A7'xc,'A8'xc,'A9'xc,'8B'xc,'4F'xc,'9B'xc,'A1'xc,'07'xc
  354.   );
  355. begin
  356.  a2e := a2evalue(.ord(in_char).);
  357. end;
  358.  
  359. Procedure UpCase(var x:char);
  360. Var
  361.  y: integer;
  362. begin
  363.  y := ord(x);
  364.  if (y>128) and (y<138) then y := y + 64;
  365.  if (y>144) and (y<154) then y := y + 64;
  366.  if (y>161) and (y<170) then y := y + 64;
  367.  x := chr(y);
  368. end;
  369.  
  370. Procedure valid_name(var x:string(8));
  371.   Var
  372.     i : integer;
  373.     t : char;
  374.   begin
  375.     for i:= 1 to length(x) do
  376.       begin
  377.         t := x(.i.);
  378.         UpCase(t);
  379.         x(.i.) := t;
  380.         case x(.i.) of
  381.           'A'..'I',
  382.           'J'..'R',
  383.           'S'..'Z',
  384.           '0'..'9',
  385.           '@', '#', '$': ;
  386.           otherwise x(.i.) := '#';
  387.         end;
  388.       end;
  389.   end;
  390.  
  391.  
  392. procedure vm_write(var x:outfile;
  393.           oarea:outbufarray;
  394.           outcnt:pcint);
  395. var
  396.  i:integer;
  397. begin
  398.  for i := 0 to outcnt-1 do
  399.   Write(x.realfile,oarea(.i.));
  400.  
  401. end;
  402.  
  403. function vm_create(fn:string(def_string_size);
  404.          var x:outfile):boolean;
  405. var
  406.     ftype    : string(8);
  407.     fname    : string(8);
  408.     filename : string(20);
  409.     cmdline   : string(100);
  410.     i        : integer;
  411.     Ans      : Char;
  412. begin
  413.   begin
  414.     i := rindex(fn,'\');
  415.     if i <> 0
  416.     then filename := substr(fn,i+1)
  417.     else filename := fn;
  418.     i := index(filename,'.');
  419.     if i<> 0
  420.     then begin
  421.          fname := trim(ltrim(substr(filename,1,i-1)));
  422.          ftype := trim(ltrim(substr(filename,i+1)));
  423.          end
  424.     else begin
  425.          fname := ltrim(trim(filename));
  426.          ftype := '$extract';
  427.          end;
  428.     if ftype = '' then ftype := '$extract';
  429.     valid_name(fname);
  430.     valid_name(ftype);
  431.     filename := fname || '.' || ftype || '.A1';
  432. (*
  433.     I use a REXX program to check for the existance of the output
  434.     file. I do this because invoking STATE directly can cause a
  435.     return code of 88 if the file exists and has more that 65536
  436.     records. This is because the Pascal CMS routine uses the old,
  437.     non extended version of the PLIST. Using the REXX exec avoids this
  438.     problem.
  439. *)
  440.     Ans := 'Y';
  441.     if coptions <> REPLACE
  442.     then begin
  443.          cmdline := 'EXEC CHECK '||fname|| ' ' || ftype || ' A';
  444.          CMS(cmdline,i);
  445.          if i=0
  446.          then begin
  447.               if coptions = BYPASS then Ans := 'N'
  448.               else begin
  449.                    WriteLn('Warning! File:',fname,' ',ftype,
  450.                        ' A already exists. Overwrite?');
  451.                    ReadLn(Ans);
  452.                    UpCase(Ans);
  453.                    end
  454.               end
  455.          else if i<> 28
  456.               then begin
  457.                    Ans := 'N';
  458.                    WriteLn('Unsupported return code from STATE =',i:3,
  459.                      ' file:',fn,' bypassed.');
  460.                    end;
  461.          end;
  462.     if Ans = 'Y'
  463.     then begin
  464.          x.filename := filename;
  465.          ReWrite(x.realfile,'name=' || x.filename);
  466.          vm_create := true;
  467.          end
  468.     else vm_create := false;
  469.   end;
  470. end;
  471.  
  472. procedure vm_close(var x:outfile);
  473. begin
  474.  close(x.realfile);
  475.  
  476. end;
  477.  
  478. function vm_read_string(var x:zipfile;
  479.          var iarea:string(def_string_size);
  480.          inpos:pcint):pcint;
  481. var
  482.  i:integer;
  483.  j:integer;
  484.  in_data:record
  485.     case boolean of
  486.     false:(in_byte:byte;);
  487.     true:(in_char:char;);
  488.     end;
  489. begin
  490.  
  491.  iarea := '';
  492.  j:=0;
  493.  for i := 1 to inpos do
  494.   begin
  495.   read(x.realfile,in_data.in_byte);
  496.   in_data.in_char := a2e(in_data.in_char);
  497.   j:=i;
  498.   iarea := iarea || str(in_data.in_char);
  499.   if eof(x.realfile)
  500.   then begin WriteLn('vm_read_string eof'); leave; end;
  501.   end;
  502.  vm_read_string := j;
  503. end;
  504.  
  505. function vm_read_bytes(var x:zipfile;
  506.          var iarea:uinbufarray;
  507.          inpos:pcint):pcint;
  508. Var
  509.  i:integer;
  510.  j:integer;
  511. begin
  512.  j := 0;
  513.  for i := 1 to inpos do
  514.   begin
  515.   read(x.realfile,iarea(.i.));
  516.   j := i;
  517.   if eof(x.realfile) then leave;
  518.   end;
  519.  vm_read_bytes := j;
  520. end;
  521.  
  522. function vm_read_local(var x:zipfile;
  523.          var iarea:local_file_header;
  524.          inpos:pcint):pcint;
  525. var
  526.  i:integer;
  527.  j:integer;
  528.  temp:record
  529.       case boolean of
  530.       true:(temp_hdr:local_file_header;);
  531.       false:(temp_byte:array (.1..sizeof(local_file_header).) of byte;);
  532.       end;
  533. begin
  534.  j := 0;
  535.  for i := 1 to inpos do begin
  536.   read(x.realfile,temp.temp_byte(.i.));
  537.   j := i;
  538.   if eof(x.realfile) then leave;
  539.   end;
  540.  iarea := temp.temp_hdr;
  541.  vm_read_local := j;
  542. end;
  543.  
  544. function vm_read_central(var x:zipfile;
  545.          var iarea:central_directory_file_header;
  546.          inpos:pcint):pcint;
  547. var
  548.  i:integer;
  549.  j:integer;
  550.  temp:record
  551.   case boolean of
  552.   true:(temp_hdr:central_directory_file_header;);
  553.   false:(temp_byte:array (.1..sizeof(central_directory_file_header).)
  554.                    of byte;);
  555.   end;
  556. begin
  557.  j := 0;
  558.  for i := 1 to inpos do begin
  559.   read(x.realfile,temp.temp_byte(.i.));
  560.   j := i;
  561.   if eof(x.realfile) then leave;
  562.   end;
  563.  iarea := temp.temp_hdr;
  564.  vm_read_central := j;
  565. end;
  566.  
  567. function vm_read_ecent(var x:zipfile;
  568.          var iarea:end_central_dir_record;
  569.          inpos:pcint):pcint;
  570. var
  571.  i:integer;
  572.  j:integer;
  573.  temp:record
  574.       case boolean of
  575.       true:(temp_hdr:end_central_dir_record;);
  576.       false:(temp_byte:array (.1..sizeof(end_central_dir_record).)
  577.                        of byte;);
  578.       end;
  579. begin
  580.  j := 0;
  581.  for i := 1 to inpos do begin
  582.   read(x.realfile,temp.temp_byte(.i.));
  583.   j := i;
  584.   if eof(x.realfile) then leave;
  585.   end;
  586.  iarea := temp.temp_hdr;
  587.  vm_read_ecent := j;
  588. end;
  589.  
  590. function vm_read_sig(var x:zipfile;
  591.          var iarea:longint;
  592.          inpos:pcint):pcint;
  593. var
  594.  i:integer;
  595.  j:integer;
  596.  temp:record
  597.       case boolean of
  598.       true:(temp_data:longint;);
  599.       false:(temp_byte:array (.1..sizeof(longint).) of byte;);
  600.       end;
  601. begin
  602.  j:=0;
  603.  for i := 1 to inpos do begin
  604.   read(x.realfile,temp.temp_byte(.i.));
  605.   j := i;
  606.   if eof(x.realfile) then leave;
  607.   end;
  608.  iarea := temp.temp_data;
  609.  vm_read_sig := j;
  610. end;
  611.  
  612. function val_word(word_val:word):integer;
  613. var
  614.  hold:byte;
  615.  temp:record
  616.     case integer of
  617.     1:(x1,x2:byte;);
  618.     2:(x:word;);
  619.     3:(y:pcint;);
  620.     end;
  621. begin
  622.  temp.x := word_val ;
  623.  hold:=temp.x1;
  624.  temp.x1:=temp.x2;
  625.  temp.x2:=hold;
  626.  val_word := temp.y;
  627. end;
  628.  
  629. function val_longint(longint_val:longint):integer;
  630. var
  631.  temp:record
  632.      case integer of
  633.      1:(x1,x2,x3,x4:byte;);
  634.      2:(x:longint;);
  635.      3:(y:integer;);
  636.      end;
  637.  hold:byte;
  638. begin
  639.  temp.x := longint_val;
  640.  hold := temp.x1;
  641.  temp.x1 := temp.x4;
  642.  temp.x4 := hold;
  643.  hold := temp.x2;
  644.  temp.x2 := temp.x3;
  645.  temp.x3 := hold;
  646.  val_longint := temp.y;
  647. end;
  648.  
  649. (* ------------------------------------------------------------- *)
  650. procedure skip_csize;
  651. var
  652.  i:integer;
  653. begin
  654.    for i:= 1 to csize do get(zipfn.realfile);
  655.    zipeof := true;
  656.    csize := 0;
  657.    incnt := 0;
  658. end;
  659.  
  660.  
  661. (* ------------------------------------------------------------- *)
  662. procedure ReadByte(var x: byte);
  663. begin
  664.    if incnt = 0 then
  665.    begin
  666.       if csize = 0 then
  667.       begin
  668.          zipeof := true;
  669.          return;
  670.       end;
  671.  
  672.       inpos := sizeof(inbuf);
  673.       if inpos > csize then
  674.          inpos := csize;
  675.       incnt := vm_read_bytes(zipfn,inbuf,inpos);
  676.  
  677.       inpos := 1;
  678. (*    pred(csize,incnt);  *)
  679.       csize := csize - incnt;
  680.    end;
  681.  
  682.    x := inbuf(.inpos.);
  683. (* succ(inpos);  *)
  684.    inpos := inpos + 1;
  685. (* pred(incnt); *)
  686.    incnt := incnt - 1;
  687. end;
  688.  
  689.  
  690. (*
  691.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  692.  *
  693.  * This is a component of the ProDoor System.
  694.  * Do not distribute modified versions without my permission.
  695.  * Do not remove or alter this notice or any other copyright notice.
  696.  * If you use this in your own program you must distribute source code.
  697.  * Do not use any of this in a commercial product.
  698.  *
  699.  *)
  700.  
  701. (******************************************************
  702.  *
  703.  * Procedure:  itoh
  704.  *
  705.  * Purpose:    converts an integer into a string of hex digits
  706.  *
  707.  * Example:    s := itoh(i);
  708.  *
  709.  *)
  710.  
  711.  
  712. (* ------------------------------------------------------------- *)
  713. procedure ReadBits(bits: pcint; var result: pcint);
  714.    /*read the specified number of bits*/
  715. var
  716.    bit:     pcint ;
  717.    bitv:    pcint ;
  718.    x:       pcint ;
  719. (*
  720. value
  721.    bit := 0;
  722.    bitv := 0;
  723.    x := 0;
  724. *)
  725. begin
  726.    x := 0;
  727.    bitv := 1;
  728.  
  729.    for bit := 0 to bits-1 do
  730.    begin
  731.  
  732.       if pcbits > 0 then
  733.       begin
  734.          pcbits := pcbits - 1;
  735.          pcbitv := pcbitv << 1;
  736.       end
  737.       else
  738.  
  739.       begin
  740.          ReadByte(pc);
  741.          pcbits := 7;
  742.          pcbitv := 1;
  743.       end;
  744.  
  745.       if (pc and pcbitv) <> 0 then
  746.          x := x or bitv;
  747.  
  748.       bitv := bitv << 1;
  749.    end;
  750.  
  751. (* WriteLn(bits,'-',itohs(x)); *)
  752.    result := x;
  753. end;
  754.  
  755.  
  756. (* ---------------------------------------------------------- *)
  757. procedure get_string(ln: integer; var s: string(def_string_size));
  758. var
  759.    n: integer;
  760. begin
  761.    s := '';
  762.    if ln = 0 then return;
  763.    if ln > 255 then
  764.       ln := 255;
  765.    n := vm_read_string(zipfn,s,ln);
  766.    if n<>ln then WriteLn('get_string n=',n,' ln=',ln);
  767. end;
  768.  
  769.  
  770. (* ------------------------------------------------------------- *)
  771. procedure OutByte (c: byte);
  772.    (* output each character from archive to screen *)
  773. begin
  774.    Crc32Val := UpdC32(c,Crc32Val);
  775.    outbuf(.outcnt.) := c;
  776.    outpos := outpos + 1;
  777.    outcnt := outcnt + 1;
  778.    if outcnt = sizeof(outbuf) then
  779.    begin
  780.       vm_write(outfd,outbuf,outcnt);
  781.       outcnt := 0;
  782.    end;
  783. end;
  784.  
  785.  
  786. (*
  787.  * expand 'reduced' members of a zipfile
  788.  *
  789.  * The Reducing algorithm is actually a combination of two
  790.  * distinct algorithms.  The first algorithm compresses repeated
  791.  * byte sequences, and the second algorithm takes the compressed
  792.  * stream from the first algorithm and applies a probabilistic
  793.  * compression method.
  794.  *
  795.  *)
  796.  
  797. function reduce_L(x: byte): byte;
  798. type
  799.   byte4 = array(.1..4.) of byte;
  800. static
  801.   values : byte4;
  802. value
  803.   values := byte4 ('7f'x,'3f'x,'1f'x,'0f'x);
  804. begin
  805.   reduce_L := x and values(.factor.);
  806. end;
  807.  
  808. function reduce_F(x: byte): byte;
  809. begin
  810.    case factor of
  811.       1: if x = 127 then reduce_F := 2 else reduce_F := 3;
  812.       2: if x = 63  then reduce_F := 2 else reduce_F := 3;
  813.       3: if x = 31  then reduce_F := 2 else reduce_F := 3;
  814.       4: if x = 15  then reduce_F := 2 else reduce_F := 3;
  815.    end;
  816. end;
  817.  
  818. function reduce_D(x,y: byte): pcint;
  819. var
  820.  result:pcint;
  821. begin
  822. result := x;
  823. result := ((result << factor) and '0f00'x) +y+1;
  824. reduce_D := result;
  825. end;
  826.  
  827. function reduce_B(x: byte): pcint;
  828.    /*number of bits needed to encode the specified number*/
  829. begin
  830.    case x-1 of
  831.       0..1:    reduce_B := 1;
  832.       2..3:    reduce_B := 2;
  833.       4..7:    reduce_B := 3;
  834.       8..15:   reduce_B := 4;
  835.      16..31:   reduce_B := 5;
  836.      32..63:   reduce_B := 6;
  837.      64..127:  reduce_B := 7;
  838.    otherwise   reduce_B := 8;
  839.    end;
  840. end;
  841.  
  842. procedure Expand(c: byte);
  843. const
  844.    DLE = 144;
  845. var
  846.    op:   integer;
  847.    i:    pcint;
  848.  
  849. begin
  850.  
  851.    case ExState of
  852.         0:  if C <> DLE then
  853.                 OutByte(C)
  854.             else
  855.                 ExState := 1;
  856.  
  857.         1:  if C <> 0 then
  858.             begin
  859.                 V := C;
  860.                 Len := reduce_L(V);
  861.                 ExState := reduce_F(Len);
  862.             end
  863.             else
  864.             begin
  865.                 OutByte(DLE);
  866.                 ExState := 0;
  867.             end;
  868.  
  869.         2:  begin
  870.                Len := Len + C;
  871.                ExState := 3;
  872.             end;
  873.  
  874.         3:  begin
  875.                op := outpos-reduce_D(V,C);
  876.                for i := 0 to Len+2 do
  877.                begin
  878.                   if op < 0 then
  879.                      OutByte(0)
  880.                   else
  881.                      OutByte(outbuf(.(op mod sizeof(outbuf)).));
  882.                   op := op + 1;
  883.                end;
  884.  
  885.                ExState := 0;
  886.             end;
  887.    end;
  888. end;
  889.  
  890.  
  891. procedure LoadFollowers;
  892. var
  893.    x: pcint;
  894.    i: pcint;
  895.    b: pcint;
  896. begin
  897.    for x := 255 downto 0 do
  898.    begin
  899.       ReadBits(6,b);
  900.       followers(.x.) := '';
  901.       for i := 1 to b do
  902.       begin
  903.          ReadBits(8,b);
  904.          followers(.x.) := followers(.x.) || str(chr(b));
  905.       end;
  906.    end;
  907. end;
  908.  
  909.  
  910. (* ----------------------------------------------------------- *)
  911. procedure unReduce;
  912.    /*expand probablisticly reduced data*/
  913.  
  914. var
  915.    lchar:   pcint;
  916.    lout:    pcint;
  917.    I:       pcint;
  918.  
  919. begin
  920.    factor := cmethod - 1;
  921.    if (factor < 1) or (factor > 4) then
  922.    begin
  923.       skip_csize;
  924.       return;
  925.    end;
  926.  
  927.    ExState := 0;
  928.    LoadFollowers;
  929.    lchar := 0;
  930.  
  931.    while (not zipeof) and (outpos < cusize) do
  932.    begin
  933.  
  934.       if followers(.lchar.) = '' then
  935.          ReadBits( 8,lout )
  936.       else
  937.  
  938.       begin
  939.          ReadBits(1,lout);
  940.          if lout <> 0 then
  941.             ReadBits( 8,lout )
  942.          else
  943.          begin
  944.             ReadBits( reduce_B(length(followers(.lchar.))), I );
  945.             lout := ord( followers(.lchar.)(.I+1.) );
  946.          end;
  947.       end;
  948.  
  949.       if zipeof then
  950.          return;
  951.  
  952.       Expand( lout );
  953.       lchar := lout;
  954.    end;
  955. end;
  956.  
  957.  
  958.  
  959. (*
  960.  * expand 'shrunk' members of a zipfile
  961.  *
  962.  * UnShrinking
  963.  * -----------
  964.  *
  965.  * Shrinking is a Dynamic Ziv-Lempel-Welch compression algorithm
  966.  * with partial clearing.  The initial code size is 9 bits, and
  967.  * the maximum code size is 13 bits.  Shrinking differs from
  968.  * conventional Dynamic Ziv-lempel-Welch implementations in several
  969.  * respects:
  970.  *
  971.  * 1)  The code size is controlled by the compressor, and is not
  972.  *     automatically increased when codes larger than the current
  973.  *     code size are created (but not necessarily used).  When
  974.  *     the decompressor encounters the code sequence 256
  975.  *     (decimal) followed by 1, it should increase the code size
  976.  *     read from the input stream to the next bit size.  No
  977.  *     blocking of the codes is performed, so the next code at
  978.  *     the increased size should be read from the input stream
  979.  *     immediately after where the previous code at the smaller
  980.  *     bit size was read.  Again, the decompressor should not
  981.  *     increase the code size used until the sequence 256,1 is
  982.  *     encountered.
  983.  *
  984.  * 2)  When the table becomes full, total clearing is not
  985.  *     performed.  Rather, when the compresser emits the code
  986.  *     sequence 256,2 (decimal), the decompressor should clear
  987.  *     all leaf nodes from the Ziv-Lempel tree, and continue to
  988.  *     use the current code size.  The nodes that are cleared
  989.  *     from the Ziv-Lempel tree are then re-used, with the lowest
  990.  *     code value re-used first, and the highest code value
  991.  *     re-used last.  The compressor can emit the sequence 256,2
  992.  *     at any time.
  993.  *
  994.  *)
  995.  
  996. procedure unShrink;
  997.  
  998. const
  999.    max_bits =  13;
  1000.    init_bits = 9;
  1001.    first_ent = 257;
  1002.    clear =     256;
  1003.  
  1004. var
  1005.    cbits:      pcint;
  1006.    i:          pcint;
  1007.    maxcode:    pcint;
  1008.    free_ent:   pcint;
  1009.    maxcodemax: pcint;
  1010.    offset:     pcint;
  1011.    sizex:      pcint;
  1012.    finchar:    pcint;
  1013.    code:       pcint;
  1014.    oldcode:    pcint;
  1015.    incode:     pcint;
  1016.  
  1017.  
  1018. (* ------------------------------------------------------------- *)
  1019. procedure partial_clear;
  1020. var
  1021.    pr:   pcint;
  1022.    cd:   pcint;
  1023.  
  1024. begin
  1025.    /*mark all nodes as potentially unused*/
  1026.    for cd := first_ent to free_ent-1 do
  1027.       if prefix_of(.cd.) >= 0
  1028.       then prefix_of(.cd.) := -32768 + prefix_of(.cd.) ;
  1029.  
  1030.    for cd := first_ent to free_ent-1 do
  1031.       begin
  1032.    /*unmark those that are used by other nodes*/
  1033.       pr := prefix_of(.cd.) and '7fff'x; /*reference to another node?*/
  1034.       if pr >= first_ent then           /*flag node as referenced*/
  1035.          prefix_of(.pr.) := prefix_of(.pr.) and '7fff'x;
  1036.       end;
  1037.  
  1038.    /*clear the ones that are still marked*/
  1039.    for cd := first_ent to free_ent-1 do
  1040.       if (prefix_of(.cd.) < 0)  then
  1041.          prefix_of(.cd.) := -1;
  1042.  
  1043.    /*find first cleared node as next free_ent*/
  1044.    free_ent := first_ent;
  1045.    while (free_ent < maxcodemax) and (prefix_of(.free_ent.) <> -1) do
  1046.       free_ent := free_ent + 1;
  1047. end;
  1048.  
  1049.  
  1050. (* ------------------------------------------------------------- *)
  1051. begin
  1052.    (* decompress the file *)
  1053.    maxcodemax := 1 << max_bits;
  1054.    cbits := init_bits;
  1055.    maxcode := (1 << cbits)- 1;
  1056.    free_ent := first_ent;
  1057.    offset := 0;
  1058.    sizex := 0;
  1059.  
  1060.    for i :=1 to hsize do prefix_of(.i.) := -1;
  1061.    for code := 255 downto 0 do
  1062.    begin
  1063.       prefix_of(.code.) := 0;
  1064.       suffix_of(.code.) := code;
  1065.    end;
  1066.  
  1067.    ReadBits(cbits,oldcode);
  1068.    if zipeof then
  1069.       return;
  1070.    finchar := oldcode;
  1071.  
  1072.    OutByte(finchar);
  1073.  
  1074.    stackp := 0;
  1075.  
  1076.    while (not zipeof) do
  1077.    begin
  1078.       ReadBits(cbits,code);
  1079.       if zipeof then
  1080.          return;
  1081.  
  1082.       while (code = clear) do
  1083.       begin
  1084.          ReadBits(cbits,code);
  1085.  
  1086.          case code of
  1087.             1: begin
  1088.                   cbits := cbits + 1;
  1089.                   if cbits = max_bits then
  1090.                      maxcode := maxcodemax
  1091.                   else
  1092.                      maxcode := (1 << cbits) - 1;
  1093.                end;
  1094.  
  1095.             2: partial_clear;
  1096.          end;
  1097.  
  1098.          ReadBits(cbits,code);
  1099.          if zipeof then
  1100.             return;
  1101.       end;
  1102.  
  1103.  
  1104.       /*special case for KwKwK string*/
  1105.       incode := code;
  1106.       if prefix_of(.code.) = -1 then
  1107.       begin
  1108.          stack(.stackp.) := finchar;
  1109.          stackp := stackp + 1;
  1110.          code := oldcode;
  1111.       end;
  1112.  
  1113.  
  1114.       /*generate output characters in reverse order*/
  1115.       while (code >= first_ent) do
  1116.       begin
  1117.          stack(.stackp.) := suffix_of(.code.);
  1118.          stackp := stackp + 1;
  1119.          code := prefix_of(.code.);
  1120.       end;
  1121.  
  1122.       finchar := suffix_of(.code.);
  1123.       stack(.stackp.) := finchar;
  1124.       stackp := stackp + 1;
  1125.  
  1126.  
  1127.       /*and put them out in forward order*/
  1128.       while (stackp > 0) do
  1129.       begin
  1130.          stackp := stackp - 1;
  1131.          OutByte(stack(.stackp.));
  1132.       end;
  1133.  
  1134.  
  1135.       /*generate new entry*/
  1136.       code := free_ent;
  1137.       if code < maxcodemax then
  1138.       begin
  1139.          prefix_of(.code.) := oldcode;
  1140.          suffix_of(.code.) := finchar;
  1141.          while (free_ent < maxcodemax) and (prefix_of(.free_ent.) <> -1)
  1142.             do free_ent := free_ent + 1;
  1143.       end;
  1144.  
  1145.  
  1146.       /*remember previous code*/
  1147.       oldcode := incode;
  1148.    end;
  1149. end;
  1150.  
  1151.  
  1152.  
  1153. (*
  1154.  * ProZip2.int - ZIP file interface library      (2-15-89 shs)
  1155.  *
  1156.  * This procedure displays the text contents of a specified archive
  1157.  * file.  The filename must be fully specified and verified.
  1158.  *
  1159.  *)
  1160.  
  1161.  
  1162. (* ---------------------------------------------------------- *)
  1163. procedure extract_member;
  1164. var
  1165.    b: byte;
  1166.  
  1167. begin
  1168.    pcbits := 0;
  1169.    incnt := 0;
  1170.    outpos := 0;
  1171.    outcnt := 0;
  1172.    zipeof := false;
  1173.    Crc32Val := -1;
  1174.  
  1175.    if not vm_create(filename,outfd)
  1176.    then begin
  1177.         WriteLn(' Bypassing: ',filename);
  1178.         skip_csize;
  1179.         return;
  1180.         end;
  1181.  
  1182.    case cmethod of
  1183.       0:    /*stored*/
  1184.             begin
  1185.                WriteLn(' Extracting: ',filename,' to ',outfd.filename);
  1186.                while (not zipeof) do
  1187.                begin
  1188.                   ReadByte(b);
  1189.                   OutByte(b);
  1190.                end;
  1191.             end;
  1192.  
  1193.       1:    begin
  1194.                WriteLn('UnShrinking: ',filename,' to ',outfd.filename);
  1195.                UnShrink;
  1196.             end;
  1197.  
  1198.       2..5: begin
  1199.                WriteLn('  Expanding: ',filename,' to ',outfd.filename);
  1200.                UnReduce;
  1201.             end;
  1202.  
  1203.       otherwise Write('Unknown compression method.');
  1204.    end;
  1205.  
  1206.    if outcnt > 0 then
  1207.       vm_write(outfd,outbuf,outcnt);
  1208.  
  1209.    vm_close(outfd);
  1210.    Crc32Val := NOT Crc32Val;
  1211.    If Crc32Val <> InCrc
  1212.    then begin
  1213.         WriteLn('WARNING - preceeding file fails CRC check.');
  1214.         WriteLn('Stored CRC=',InCrc);
  1215.         WriteLn('Calculated CRC=',Crc32Val)
  1216.         end;
  1217.  
  1218. end;
  1219.  
  1220. procedure process_local_file_header;
  1221. var
  1222.    n:             integer;
  1223.    rec:           local_file_header;
  1224.  
  1225. begin
  1226.    n := vm_read_local(zipfn,rec,sizeof(rec));
  1227.    filename_length := val_word(rec.$filename_length);
  1228.    get_string(filename_length,filename);
  1229.    extra_field_length := val_word(rec.$extra_field_length);
  1230.    get_string(extra_field_length,extra);
  1231.    csize := val_longint(rec.$compressed_size);
  1232.    cusize := val_longint(rec.$uncompressed_size);
  1233.    cmethod := val_word(rec.$compression_method);
  1234.    ctime := val_word(rec.$last_mod_file_time);
  1235.    cdate := val_word(rec.$last_mod_file_date);
  1236.    InCrc := val_longint(rec.$crc32);
  1237.    extract_member;
  1238. end;
  1239.  
  1240. procedure process_central_file_header;
  1241. var
  1242.    n:             integer;
  1243.    rec:           central_directory_file_header;
  1244.    filename:      string(def_string_size);
  1245.    extra:         string(def_string_size);
  1246.    comment:       string(def_string_size);
  1247.  
  1248. begin
  1249.    n := vm_read_central(zipfn,rec,sizeof(rec));
  1250.    filename_length := val_word(rec.$filename_length);
  1251.    get_string(filename_length,filename);
  1252.    extra_field_length := val_word(rec.$extra_field_length);
  1253.    get_string(extra_field_length,extra);
  1254.    file_comment_length := val_word(rec.$file_comment_length);
  1255.    get_string(file_comment_length,comment);
  1256. end;
  1257.  
  1258. procedure process_end_central_dir;
  1259. var
  1260.    n:             integer;
  1261.    rec:           end_central_dir_record;
  1262.    comment:       string(def_string_size);
  1263.  
  1264. begin
  1265.    n := vm_read_ecent(zipfn,rec,sizeof(rec));
  1266.    zipfile_comment_length := val_word(rec.$zipfile_comment_length);
  1267.    get_string(zipfile_comment_length,comment);
  1268. end;
  1269.  
  1270. procedure process_headers;
  1271. var
  1272.    sig:  longint;
  1273.  
  1274. begin
  1275.    close(zipfn.realfile);
  1276.    reset(zipfn.realfile,'name='||zipfn.filename);
  1277.  
  1278.    while true do
  1279.    begin
  1280.       if vm_read_sig(zipfn,sig,sizeof(sig)) <> sizeof(sig) then
  1281.          return
  1282.       else
  1283.  
  1284.       if val_longint(sig) = local_file_header_signature then
  1285.          process_local_file_header
  1286.       else
  1287.  
  1288.       if val_longint(sig) = central_file_header_signature then
  1289.          process_central_file_header
  1290.       else
  1291.  
  1292.       if val_longint(sig) = end_central_dir_signature then
  1293.       begin
  1294.          process_end_central_dir;
  1295.          return;
  1296.       end
  1297.  
  1298.       else
  1299.       begin
  1300.          WriteLn('Invalid Zipfile Header',val_longint(sig));
  1301.          return;
  1302.       end;
  1303.    end;
  1304.  
  1305. end;
  1306.  
  1307. procedure extract_zipfile;
  1308. begin
  1309.  reset(zipfn.realfile,'name='||zipfn.filename);
  1310.  process_headers;
  1311.  close(zipfn.realfile);
  1312. end;
  1313.  
  1314. (*
  1315.  * main program
  1316.  *
  1317.  *)
  1318.  
  1319. begin
  1320.    myparms := parms;
  1321.    termout(output);
  1322.    termin(input);
  1323.    WriteLn(myparms);
  1324.    writeln;
  1325.    WriteLn(version);
  1326.    WriteLn('Courtesy of:  S.H.Smith  and  The Tool Shop BBS,  (602) 279-2673.');
  1327.    writeln;
  1328.    WriteLn('Converted to VM/CMS operation by John McKown.');
  1329.    WriteLn(' Email address: CompuServe Id: 72325,1705');
  1330.    writeln;
  1331.    if length(myparms) = 0 then
  1332.    begin
  1333.       WriteLn('Usage:  VMUNZIP file');
  1334.       WriteLn('  NOTICE - the filetype is always PCZIP.');
  1335.       WriteLn('  It MUST be fixed with an lrecl of 1.');
  1336.       halt;
  1337.    end;
  1338.  
  1339.    i := 1;
  1340.    ltoken(i,myparms,zipname);
  1341.    zipfn.filename := zipname||'.pczip.a';
  1342.  
  1343.    coptions := PROMPT;
  1344.    repeat
  1345.      token(i,myparms,optstr);
  1346.    until (optstr='(') or (optstr=' ');
  1347.    while (optstr <> ' ') do
  1348.      begin
  1349.        token(i,myparms,optstr);
  1350.        if optstr <> ' ' then
  1351.          if optstr = 'PROMPT' then coptions := PROMPT
  1352.          else
  1353.            if optstr = 'REPLACE' then coptions := REPLACE
  1354.          else
  1355.            if optstr = 'BYPASS' then coptions := BYPASS
  1356.          else
  1357.            WriteLn('Warning - Invalid option:',optstr,' ignored.');
  1358.      end;
  1359.    extract_zipfile;
  1360. end.
  1361.