home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / progs / press.icn < prev    next >
Text File  |  2000-07-29  |  25KB  |  897 lines
  1. ############################################################################
  2. #
  3. #    File:     press.icn
  4. #
  5. #    Subject:  Program to archive files
  6. #
  7. #    Author:   Robert J. Alexander
  8. #
  9. #    Date:     November 14, 1991
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  Besides being a useful file archiving utility, this program can be
  18. #  used to experiment with the LZW compression process, as it contains
  19. #  extensive tracing facilities that illustrate the process in detail.
  20. #
  21. #  Compression can be turned off if faster archiving is desired.
  22. #
  23. #  The LZW compression procedures in this program are general purpose
  24. #  and suitable for reuse in other programs.
  25. #
  26. ############################################################################
  27. #
  28. #  Instructions for use are summarized in "help" procedures that follow.
  29. #
  30. ############################################################################
  31. #
  32. #  Links: options, colmize, wildcard
  33. #
  34. ############################################################################
  35.  
  36. link options, colmize, wildcard
  37.  
  38. procedure Usage(s)
  39.    /s := ""
  40.    stop("\nUsage:_
  41. \n      Compress: press -c <archive file> [<options>] [<file to compress>...]_
  42. \n      Archive:  press -a <archive file> [<options>] [<file to archive>...]_
  43. \n      Extract:  press -x <archive file> [<options>] [<file to extract>...]_
  44. \n      Print:    press -p <archive file> [<options>] [<file to print>...]_
  45. \n      List:     press -l <archive file> [<options>] [<file to list>...]_
  46. \n      Delete:   press -d <archive file> [<options>] <file to delete>..._
  47. \n_
  48. \n      Help:     press         (prints this message)_
  49. \n      More help:press -h      (prints more details)_
  50. \n_
  51. \n      -c  perform compression into <archive file>_
  52. \n      -a  add file(s) to <archive file> in uncompressed format_
  53. \n      -x  extract (& decompress) file(s) from <archive file>_
  54. \n      -p  extract (& decompress) from <archive file> to standard output_
  55. \n      -l  list file names in <archive file>_
  56. \n      -d  delete file(s) from <archive file>_
  57. \n          (produces new file -- old file saved with \".bak\" suffix)_
  58. \n_
  59. \n      Options:_
  60. \n      -q  work quietly_
  61. \n      -t  text file(s) (retrieves with correct line end format)_
  62. \n    -n  process all files in archive *except* specified files_
  63. \n_
  64. \n      LZW Experimentor Options:_
  65. \n      -T  produce detailed compression trace info (to standard error file)_
  66. \n      -S  maximum compression string table size_
  67. \n          (for -c only -- default = 1024)_
  68. \n"
  69.       ,s)
  70. end
  71.  
  72. procedure MoreHelp()
  73.    return "\n _
  74.   The archive (-a) option means to add the file without compression._
  75. \n_
  76. \n If no files are specified to extract, print, or list, then all files_
  77. \n in the archive are used._
  78. \n_
  79. \n UNIX-style filename wildcard conventions can be used to express_
  80. \n the archived file names for extract, print, list, and delete_
  81. \n operations.  Be sure to quote names containing wildcard characters_
  82. \n so that they aren't expanded by the shell (if applicable)._
  83. \n_
  84. \n If a <file to compress> or <file to archive> is \"-\", or if no files_
  85. \n are specified, standard input is archived._
  86. \n_
  87. \n If <archive file> for extract, print, or list is \"-\", standard input_
  88. \n is the archive file._
  89. \n_
  90. \n If <archive file> for compress or archive is \"-\", archive is written_
  91. \n to standard output._
  92. \n_
  93. \n New files archived to an existing archive file are always appended,_
  94. \n deleting any previously archived version of the same file name._
  95. \n_
  96. \n Archive files can be simply concatenated to create their union._
  97. \n However, if the same file exists in both archives, only the first_
  98. \n in the resulting file will be able to be accessed._
  99. \n_
  100. \n If a \"compressed\" file turns out to be longer than the uncompressed_
  101. \n file (rare but possible, usually for very short files), the file will_
  102. \n automatically be archived in uncompressed format._
  103. \n_
  104. \n A default file name suffix of \".prx\" is assumed for <archive file>_
  105. \n names that are specified without a suffix._
  106. \n_
  107. \n_
  108. \n LZW \"internals\" option:_
  109. \n_
  110. \n If the specified maximum table size is positive, the string table is_
  111. \n discarded when the maximum size is reached and rebuilt (usually the_
  112. \n better choice).  If negative, the original table is not discarded,_
  113. \n which might produce better results in some circumstances.  This_
  114. \n option was provided primarily for experimentors._
  115. \n"
  116. end
  117.  
  118. #
  119. #  Global variables.
  120. #
  121. #  Note:  additional globals that contain option values are defined near
  122. #  Options(), below.
  123. #
  124. global inchars,outchars,tinchars,toutchars,lzw_recycles,
  125.       lzw_stringTable,rf,wf,magic,rline,wline
  126.  
  127. #
  128. #  Main procedure.
  129. #
  130. procedure main(arg)
  131.    local arcfile
  132.    #
  133.    #  Initialize.
  134.    #
  135.    Options(arg)
  136.    inchars := outchars := tinchars := toutchars := lzw_recycles := 0
  137.    magic := "\^p\^r\^e\^s\^s\^i\^c\^n"
  138.    #
  139.    #  Do requested operation.
  140.    #
  141.    arcfile :=
  142.          DefaultSuffix(\(compr | archive | extract | print | lister | deleter),
  143.          "prx") | Usage()
  144.    if \(compr | archive) then Archive(arcfile,arg)
  145.    else if \(extract | print) then Extract(arcfile,arg)
  146.    else if \lister then List(arcfile,arg)
  147.    else if \deleter then Delete(arcfile,arg)
  148.    return
  149. end
  150.  
  151.  
  152. #
  153. #  Option global variables.
  154. #
  155. global lzw_trace,maxTableSpecified,maxTableSize,print,quiet,tmode,WildMatch
  156. global extract,compr,archive,lister,deleter
  157.  
  158. #
  159. #  Options() -- Handle command line options.
  160. #
  161. procedure Options(arg)
  162.    local opt,n,x
  163.    opt := options(arg,"hc:a:x:p:l:d:qtTS+n")
  164.    if \opt["h"] then Usage(MoreHelp())
  165.    extract := opt["x"]
  166.    print := opt["p"]
  167.    compr := opt["c"]
  168.    archive := opt["a"]
  169.    lister := opt["l"]
  170.    deleter := opt["d"]
  171.    quiet := opt["q"]
  172.    tmode := if \opt["t"] then "t" else "u"
  173.    WildMatch := if \opt["n"] then not_wild_match else whole_wild_match
  174.    lzw_trace := opt["T"]
  175.    maxTableSpecified := opt["S"]
  176.    maxTableSize := \maxTableSpecified | 1024    # 10 bits default
  177.    n := 0
  178.    every x := compr | archive | extract | print | lister | deleter do
  179.          if \x then n +:= 1
  180.    if n ~= 1 then Usage()
  181.    return
  182. end
  183.  
  184.  
  185. #
  186. #  Archive() -- Do archiving.
  187. #
  188. procedure Archive(arcfile,arg)
  189.    local fn,addr,realLen,maxT,length,addr2,deleteFiles,new_data_start
  190.    #
  191.    #  Confirm options and open the archive file.
  192.    #
  193.    if *arg = 0 | WildMatch === not_wild_match then Usage()
  194.    if ("" | "-") ~== arcfile then {
  195.       if wf := open(arcfile,"ru") then {
  196.          if not (reads(wf,*magic) == magic) then {
  197.             stop("Invalid archive file ",arcfile)
  198.             }
  199.          close(wf)
  200.          }
  201.       wf := open(arcfile,"bu" | "wu") | stop("Can't open archive file ",arcfile)
  202.       if tmode == "t" then rline := "\n"
  203.       seek(wf,0)
  204.       if where(wf) = 1 then writes(wf,magic)
  205.       }
  206.    else {
  207.       wf := &output
  208.       arcfile := "stdout"
  209.       }
  210.    new_data_start := where(wf)
  211.    ## if /quiet then 
  212.    ##    write(&errout,"New data starting at byte ",new_data_start," of ",arcfile)
  213.    #
  214.    #  Loop to process files on command line.
  215.    #
  216.    if *arg = 0 then arg := ["-"]
  217.    deleteFiles := []
  218.    every fn := !arg do {
  219.       if fn === arcfile then next
  220.       if /quiet then
  221.          writes(&errout,"File \"",fn,"\" -- ")
  222.       rf := if fn ~== "-" then open(fn,tmode) | &null else &input
  223.       if /rf then {
  224.          if /quiet then
  225.             write(&errout,"Can't open input file \"",fn,"\" -- skipped")
  226.          next
  227.          }
  228.       put(deleteFiles,fn)
  229.       WriteString(wf,Tail(fn))
  230.       addr := where(rf)
  231.       seek(rf,0)
  232.       realLen := where(rf) - 1
  233.       WriteInteger(wf,realLen)
  234.       seek(rf,addr)
  235.       if /quiet then
  236.          writes(&errout,"Length: ",realLen)
  237.       addr := where(wf)
  238.       WriteInteger(wf,0)
  239.       writes(wf,"\1")    # write a compression version string
  240.       if \compr then {
  241.          WriteInteger(wf,maxTableSize)
  242.          maxT := Compress(R,W,maxTableSize)
  243.          length := outchars + 4
  244.          if /quiet then
  245.             writes(&errout,"  Compressed: ",length,"  ",
  246.                   Percent(realLen - outchars,realLen))
  247.          }
  248.       #
  249.       #  If compressed file is larger than original, just copy the original.
  250.       #
  251.       if \archive | length > realLen then {
  252.          if /quiet then
  253.             writes(&errout," -- Archived uncompressed")
  254.          seek(wf,addr + 4)
  255.          writes(wf,"\0") # write a zero version string for uncompressed
  256.          seek(rf,1)
  257.          CopyFile(rf,wf)
  258.          inchars := outchars := length := realLen
  259.          maxT := 0
  260.          lzw_stringTable := ""
  261.          }
  262.       if /quiet then
  263.          write(&errout)
  264.       close(rf)
  265.       addr2 := where(wf)
  266.       seek(wf,addr)
  267.       WriteInteger(wf,length)
  268.       seek(wf,addr2)
  269.       if /quiet then
  270.          Stats(maxT)
  271.       }
  272.    close(wf)
  273.    if /quiet then
  274.       if *arg > 1 then FinalStats()
  275.    Delete(arcfile,deleteFiles,new_data_start)
  276.    return
  277. end
  278.  
  279.  
  280. #
  281. #  Extract() -- Extract a file from the archive.
  282. #
  283. procedure Extract(arcfile,arg)
  284.    local fileSet,wfn,realLen,cmprLen,maxT,version,theArg
  285.    if \maxTableSpecified then Usage()
  286.    rf := OpenReadArchive(arcfile)
  287.    arcfile := rf[2]
  288.    rf := rf[1]
  289.    if *arg > 0 then fileSet := set(arg)
  290.    #
  291.    #  Process input file.
  292.    #
  293.    while wfn := ReadString(rf) do {
  294.       (realLen := ReadInteger(rf) &
  295.             cmprLen := ReadInteger(rf) &
  296.             version := ord(reads(rf))) |
  297.             stop("Bad format in compressed file")
  298.       if /quiet then
  299.          writes(&errout,"File \"",wfn,"\" -- length: ",realLen,
  300.                "  compressed: ",cmprLen," bytes -- ")
  301.       if /fileSet | WildMatch(theArg := !arg,wfn) then {
  302.          delete(\fileSet,theArg)
  303.          if not version = (0 | 1) then {
  304.          if /quiet then
  305.                write(&errout,"can't handle this compression type (",version,
  306.                      ") -- skipped")
  307.             seek(rf,where(rf) + cmprLen)
  308.             }
  309.          else {
  310.             if /quiet then
  311.                write(&errout,"extracted")
  312.             if /print then {
  313.                wf := open(wfn,"w" || tmode) | &null
  314.                if /wf then {
  315.                   if /quiet then
  316.                      write(&errout,"Can't open output file \"",wfn,
  317.                            "\" -- quitting")
  318.                   exit(1)
  319.                   }
  320.                }
  321.             else wf := &output
  322.             if version = 1 then {
  323.                maxT := ReadInteger(rf) |
  324.                      stop("Error in archive file format: ","table size missing")
  325.                Decompress(R,W,maxT)
  326.                }
  327.             else {
  328.                maxT := 0
  329.                CopyFile(rf,wf,cmprLen)
  330.                outchars := inchars := realLen
  331.                }
  332.             close(&output ~=== wf)
  333.             if /quiet then
  334.                Stats(maxT)
  335.             }
  336.          }
  337.       else {
  338.          if /quiet then
  339.             write(&errout,"skipped")
  340.          seek(rf,where(rf) + cmprLen)
  341.          }
  342.       }
  343.    close(rf)
  344.    FilesNotFound(fileSet)
  345.    return
  346. end
  347.  
  348.  
  349. #
  350. #  List() -- Skip through the archive, extracting info about files,
  351. #  then list in columns.
  352. #
  353. procedure List(arcfile,arg)
  354.    local fileSet,flist,wfn,realLen,cmprLen,version,theArg
  355.    if \maxTableSpecified then Usage()
  356.    rf := OpenReadArchive(arcfile)
  357.    arcfile := rf[2]
  358.    rf := rf[1]
  359.    write(&errout,"Archive file ",arcfile,":")
  360.    if *arg > 0 then fileSet := set(arg)
  361.    #
  362.    #  Process input file.
  363.    #
  364.    flist := []
  365.    while wfn := ReadString(rf) do {
  366.       (realLen := ReadInteger(rf) &
  367.             cmprLen := ReadInteger(rf) &
  368.             version := ord(reads(rf))) |
  369.             stop("Bad format in compressed file")
  370.       if /fileSet | WildMatch(theArg := !arg,wfn) then {
  371.          delete(\fileSet,theArg)
  372.          put(flist,"\"" || wfn || "\" " || realLen || "->" || cmprLen)
  373.          tinchars +:= realLen
  374.          toutchars +:= cmprLen
  375.          }
  376.       seek(rf,where(rf) + cmprLen)
  377.       }
  378.    close(rf)
  379.    every write(&errout,colmize(sort(flist)))
  380.    FilesNotFound(fileSet)
  381.    FinalStats()
  382.    return
  383. end
  384.  
  385.  
  386. #
  387. #  Delete() -- Delete a file from the archive.
  388. #
  389. procedure Delete(arcfile,arg,new_data_start)
  390.    local workfn,workf,fileSet,wfn,realLen,cmprLen,bakfn,deletedFiles,
  391.          head,version,hdrLen,theArg
  392.    if *arg = 0 | (\deleter & \maxTableSpecified) then Usage()
  393.    rf := OpenReadArchive(arcfile)
  394.    arcfile := rf[2]
  395.    rf := rf[1]
  396.    workfn := Root(arcfile) || ".wrk"
  397.    workf := open(workfn,"wu") | stop("Can't open work file ",workfn)
  398.    writes(workf,magic)
  399.    fileSet := set(arg)
  400.    #
  401.    #  Process input file.
  402.    #
  403.    deletedFiles := 0
  404.    head := if \deleter then "File" else "Replaced file"
  405.    while not (\new_data_start <= where(rf)) & wfn := ReadString(rf) do {
  406.       (realLen := ReadInteger(rf) &
  407.             cmprLen := ReadInteger(rf) &
  408.             version := ord(reads(rf))) |
  409.             stop("Bad format in compressed file")
  410.       if /quiet then
  411.          writes(&errout,head," \"",wfn,"\" -- length: ",realLen,
  412.                "  compressed: ",cmprLen," bytes -- ")
  413.       if WildMatch(theArg := !arg,wfn) then {
  414.          deletedFiles +:= 1
  415.          delete(fileSet,theArg)
  416.          if /quiet then
  417.             write(&errout,"deleted")
  418.          seek(rf,where(rf) + cmprLen)
  419.          }
  420.       else {
  421.          if /quiet then
  422.             write(&errout,"kept")
  423.          hdrLen := *wfn + 10
  424.          seek(rf,where(rf) - hdrLen)
  425.          CopyFile(rf,workf,cmprLen + hdrLen)
  426.          }
  427.       }
  428.    if deletedFiles > 0 then {
  429.       CopyFile(rf,workf)
  430.       every close(workf | rf)
  431.       if (rf ~=== &input) then {
  432.          bakfn := Root(arcfile) || ".bak"
  433.          remove(bakfn)
  434.          rename(arcfile,bakfn) | stop("Couldn't rename ",arcfile," to ",bakfn)
  435.          }
  436.       rename(workfn,arcfile) | stop("Couldn't rename ",workfn," to ",arcfile)
  437.       }
  438.    else {
  439.       every close(workf | rf)
  440.       remove(workfn)
  441.       }
  442.    if \deleter then FilesNotFound(fileSet)
  443.    return
  444. end
  445.  
  446.  
  447. #
  448. #  OpenReadArchive() -- Open an archive for reading.
  449. #
  450. procedure OpenReadArchive(arcfile)
  451.    local rf
  452.    rf := if ("" | "-") ~== arcfile then
  453.          open(arcfile,"ru") | stop("Can't open archive file ",arcfile)
  454.    else {
  455.       arcfile := "stdin"
  456.       &input
  457.       }
  458.    if reads(rf,*magic) ~== magic then stop("Invalid archive file ",arcfile)
  459.    if tmode == "t" then wline := "\x0a"
  460.    return [rf,arcfile]
  461. end
  462.  
  463.  
  464. #
  465. #  FilesNotFound() -- List the files remaining in "fileSet".
  466. #
  467. procedure FilesNotFound(fileSet)
  468.    return if *\fileSet > 0 then {
  469.       write(&errout,"\nFiles not found:")
  470.       every write(&errout," ",colmize(sort(fileSet),78))
  471.       &null
  472.       }
  473. end
  474.  
  475.  
  476. #
  477. #  Stats() -- Print stats after a file.
  478. #
  479. procedure Stats(maxTableSize)
  480.    #
  481.    #  Write statistics
  482.    #
  483.    if \lzw_trace then write(&errout,
  484.          "  table size = ",*lzw_stringTable,"/",maxTableSize,
  485.          " (recycles: ",lzw_recycles,")")
  486.    tinchars +:= inchars
  487.    toutchars +:= outchars
  488.    inchars := outchars := lzw_recycles := 0
  489.    return
  490. end
  491.  
  492.  
  493. #
  494. #  FinalStats() -- Print final stats.
  495. #
  496. procedure FinalStats()
  497.    #
  498.    #  Write final statistics
  499.    #
  500.    write(&errout,"\nTotals: ",
  501.          "\n  input: ",tinchars,
  502.          "\n  output: ",toutchars,
  503.          "\n  compression: ",Percent(tinchars - toutchars,tinchars) | "",
  504.          "\n")
  505.    return
  506. end
  507.  
  508.  
  509. #
  510. #  WriteInteger() -- Write a 4-byte binary integer to "f".
  511. #
  512. procedure WriteInteger(f,i)
  513.    local s
  514.    s := ""
  515.    every 1 to 4 do {
  516.       s := char(i % 256) || s
  517.       i /:= 256
  518.       }
  519.    return writes(f,s)
  520. end
  521.  
  522.  
  523. #
  524. #  ReadInteger() -- Read a 4-byte binary integer from "f".
  525. #
  526. procedure ReadInteger(f)
  527.    local s,v
  528.    s := reads(f,4) | fail
  529.    if *s < 4 then
  530.          stop("Error in archive file format: ","bad integer")
  531.    v := 0
  532.    s ? while v := v * 256 + ord(move(1))
  533.    return v
  534. end
  535.  
  536.  
  537. #
  538. #  WriteString() -- Write a string preceded by a length byte to "f".
  539. #
  540. procedure WriteString(f,s)
  541.    return writes(f,char(*s),s)
  542. end
  543.  
  544.  
  545. #
  546. #  ReadString() -- Read a string preceded by a length byte from "f".
  547. #
  548. procedure ReadString(f)
  549.    local len,s
  550.    len := ord(reads(f)) | fail
  551.    s := reads(f,len)
  552.    if *s < len then
  553.          stop("Error in archive file format: ","bad string")
  554.    return s
  555. end
  556.  
  557.  
  558. #
  559. #  CopyFile() -- Copy a file.
  560. #
  561. procedure CopyFile(rf,wf,len)
  562.    local s
  563.    if /len then {
  564.       while writes(wf,s := reads(rf,1000))
  565.       }
  566.    else {
  567.       while len > 1000 & writes(wf,s := reads(rf,1000)) do len -:= *s
  568.       writes(wf,s := reads(rf,len)) & len -:= *s
  569.       }
  570.    return len
  571. end
  572.  
  573.  
  574. #
  575. #  Percent() -- Format a rational number "n"/"d" as a percentage.
  576. #
  577. procedure Percent(n,d)
  578.    local sign,whole,fraction
  579.    n / (0.0 ~= d) ? {
  580.       sign := ="-" | ""
  581.       whole := tab(find("."))
  582.       move(1)
  583.       fraction := tab(0)
  584.       }
  585.    return (\sign || ("0" ~== whole | "") ||
  586.          (if whole == "0" then integer else 1)(left(fraction,2,"0")) | "--") ||
  587.          "%"
  588. end
  589.  
  590.  
  591. #
  592. #  R() -- Read-a-character procedure.
  593. #
  594. procedure R()
  595.    local c
  596.  
  597.    c := reads(rf) | fail
  598.    inchars +:= 1
  599.    if c === rline then c := "\x0a"
  600.    return c
  601. end
  602.  
  603.  
  604. #
  605. #  W() -- Write-characters procedure.
  606. #
  607. procedure W(s)
  608.    local i
  609.  
  610.    every i := find(\wline,s) do s[i] := "\n"
  611.    outchars +:= *s
  612.    return writes(wf,s)
  613. end
  614.  
  615.  
  616. #
  617. #  Tail() -- Return the file name portion (minus the path) of a
  618. #  qualified file name.
  619. #
  620. procedure Tail(fn)
  621.    local i
  622.    i := 0
  623.    every i := upto('/\\:',fn)
  624.    return .fn[i + 1:0]
  625. end
  626.  
  627.  
  628. #
  629. #  Root() -- Return the root portion (minus the suffix) of a file name.
  630. #
  631. procedure Root(fn)
  632.    local i
  633.    i := 0
  634.    every i := find(".",fn)
  635.    return .fn[1:i]
  636. end
  637.  
  638.  
  639. procedure DefaultSuffix(fn,suf)
  640.    local i
  641.    return fn || "." || suf
  642. end
  643.  
  644.  
  645. ############################################################################
  646. #
  647. #  Compress() -- LZW compression
  648. #
  649. #  Arguments:
  650. #
  651. #       inproc  a procedure that returns a single character from
  652. #               the input stream.
  653. #
  654. #       outproc a procedure that writes a single character (its
  655. #               argument) to the output stream.
  656. #
  657. #       maxTableSize    the maximum size to which the string table
  658. #               is allowed to grow before something is done about it.
  659. #               If the size is positive, the table is discarded and
  660. #               a new one started.  If negative, it is retained, but
  661. #               no new entries are added.
  662. #
  663.  
  664. procedure Compress(inproc,outproc,maxTableSize)
  665.    local EOF,c,charTable,junk1,junk2,outcode,s,t,tossTable,x
  666.    #
  667.    #  Initialize.
  668.    #
  669.    /maxTableSize := 1024        # default 10 "bits"
  670.    tossTable := maxTableSize
  671.    /lzw_recycles := 0
  672.    if maxTableSize < 0 then maxTableSize := -maxTableSize
  673.    charTable := table()
  674.    every c := !&cset do charTable[c] := ord(c)
  675.    EOF := charTable[*charTable] := *charTable    # reserve code=256 for EOF
  676.    lzw_stringTable := copy(charTable)
  677.    #
  678.    #  Compress the input stream.
  679.    #
  680.    s := inproc() | return maxTableSize
  681.    if \lzw_trace then {
  682.       write(&errout,"\nInput string\tOutput code\tNew table entry")
  683.       writes(&errout,"\"",image(s)[2:-1])
  684.       }
  685.    while c := inproc() do {
  686.       if \lzw_trace then
  687.             writes(&errout,image(c)[2:-1])
  688.       if \lzw_stringTable[t := s || c] then s := t
  689.       else {
  690.          Compress_output(outproc,junk2 := lzw_stringTable[s],
  691.                junk1 := *lzw_stringTable)
  692.          if *lzw_stringTable < maxTableSize then
  693.                lzw_stringTable[t] := *lzw_stringTable
  694.          else if tossTable >= 0 then {
  695.                lzw_stringTable := copy(charTable)
  696.                lzw_recycles +:= 1
  697.             }
  698.          if \lzw_trace then
  699.                writes(&errout,"\"\t\t",
  700.                      image(char(*&cset > junk2) | junk2),
  701.                      "(",junk1,")\t\t",lzw_stringTable[t]," = ",image(t),"\n\"")
  702.          s := c
  703.          }
  704.       }
  705.       Compress_output(outproc,junk2 := lzw_stringTable[s],
  706.         junk1 := *lzw_stringTable)
  707.       if *lzw_stringTable < maxTableSize then
  708.         {}
  709.       else if tossTable >= 0 then {
  710.         lzw_stringTable := copy(charTable)
  711.         lzw_recycles +:= 1
  712.      }
  713.       if \lzw_trace then
  714.         writes(&errout,"\"\t\t",
  715.           image(char(*&cset > junk2) | junk2),"(",junk1,")\n")
  716.    Compress_output(outproc,EOF,*lzw_stringTable)
  717.    if \lzw_trace then write(&errout,"\"\t\t",EOF)
  718.    Compress_output(outproc)
  719.    return maxTableSize
  720. end
  721.  
  722.  
  723. procedure Compress_output(outproc,code,stringTableSize)
  724.    local outcode
  725.    static max,bits,buffer,bufferbits,lastSize
  726.    #
  727.    #  Initialize.
  728.    #
  729.    initial {
  730.       lastSize := 1000000
  731.       buffer := bufferbits := 0
  732.       }
  733.    #
  734.    #  If this is "close" call, flush buffer and reinitialize.
  735.    #
  736.    if /code then {
  737.       outcode := &null
  738.       if bufferbits > 0 then
  739.             outproc(char(outcode := ishift(buffer,8 - bufferbits)))
  740.       lastSize := 1000000
  741.       buffer := bufferbits := 0
  742.       return outcode
  743.       }
  744.    #
  745.    #  Expand output code size if necessary.
  746.    #
  747.    if stringTableSize < lastSize then {
  748.       max := 1
  749.       bits := 0
  750.       }
  751.    while stringTableSize > max do {
  752.       max *:= 2
  753.       bits +:= 1
  754.       }
  755.    lastSize := stringTableSize
  756.    #
  757.    #  Merge new code into buffer.
  758.    #
  759.    buffer := ior(ishift(buffer,bits),code)
  760.    bufferbits +:= bits
  761.    #
  762.    #  Output bits.
  763.    #
  764.    while bufferbits >= 8 do {
  765.       outproc(char(outcode := ishift(buffer,8 - bufferbits)))
  766.       buffer := ixor(buffer,ishift(outcode,bufferbits - 8))
  767.       bufferbits -:= 8
  768.       }
  769.    return outcode
  770. end
  771.  
  772.  
  773. ############################################################################
  774. #
  775. #  Decompress() -- LZW decompression of compressed stream created
  776. #                  by Compress()
  777. #
  778. #  Arguments:
  779. #
  780. #       inproc  a procedure that returns a single character from
  781. #               the input stream.
  782. #
  783. #       outproc a procedure that writes a single character (its
  784. #               argument) to the output stream.
  785. #
  786.  
  787. procedure Decompress(inproc,outproc,maxTableSize)
  788.    local EOF,c,charSize,code,i,new_code,old_strg,
  789.          strg,tossTable
  790.    #
  791.    #  Initialize.
  792.    #
  793.    /maxTableSize := 1024        # default 10 "bits"
  794.    tossTable := maxTableSize
  795.    /lzw_recycles := 0
  796.    if maxTableSize < 0 then maxTableSize := -maxTableSize
  797.    maxTableSize -:= 1
  798.    lzw_stringTable := list(*&cset)
  799.    every i := 1 to *lzw_stringTable do lzw_stringTable[i] := char(i - 1)
  800.    put(lzw_stringTable,EOF := *lzw_stringTable)  # reserve code=256 for EOF
  801.    charSize := *lzw_stringTable
  802.    if \lzw_trace then
  803.          write(&errout,"\nInput code\tOutput string\tNew table entry")
  804.    #
  805.    #  Decompress the input stream.
  806.    #
  807.    while old_strg :=
  808.          lzw_stringTable[Decompress_read_code(inproc,
  809.          *lzw_stringTable,EOF) + 1] do {
  810.       if \lzw_trace then
  811.             write(&errout,image(old_strg),"(",*lzw_stringTable,")",
  812.                   "\t",image(old_strg))
  813.       outproc(old_strg)
  814.       c := old_strg[1]
  815.       (while new_code := Decompress_read_code(inproc,
  816.             *lzw_stringTable + 1,EOF) do {
  817.          strg := lzw_stringTable[new_code + 1] | old_strg || c
  818.          outproc(strg)
  819.          c := strg[1]
  820.          if \lzw_trace then
  821.                write(&errout,image(char(*&cset > new_code) \ 1 | new_code),
  822.                      "(",*lzw_stringTable + 1,")","\t",
  823.                      image(strg),"\t\t",
  824.                      *lzw_stringTable," = ",image(old_strg || c))
  825.          if *lzw_stringTable < maxTableSize then
  826.                put(lzw_stringTable,old_strg || c)
  827.          else if tossTable >= 0 then {
  828.             lzw_stringTable := lzw_stringTable[1:charSize + 1]
  829.             lzw_recycles +:= 1
  830.             break
  831.             }
  832.          old_strg := strg
  833.          }) | break  # exit outer loop if this loop completed
  834.       }
  835.    Decompress_read_code()
  836.    return maxTableSize
  837. end
  838.  
  839.  
  840. procedure Decompress_read_code(inproc,stringTableSize,EOF)
  841.    local code
  842.    static max,bits,buffer,bufferbits,lastSize
  843.  
  844.    #
  845.    #  Initialize.
  846.    #
  847.    initial {
  848.       lastSize := 1000000
  849.       buffer := bufferbits := 0
  850.       }
  851.    #
  852.    #  Reinitialize if called with no arguments.
  853.    #
  854.    if /inproc then {
  855.       lastSize := 1000000
  856.       buffer := bufferbits := 0
  857.       return
  858.       }
  859.    #
  860.    #  Expand code size if necessary.
  861.    #
  862.    if stringTableSize < lastSize then {
  863.       max := 1
  864.       bits := 0
  865.       }
  866.    while stringTableSize > max do {
  867.       max *:= 2
  868.       bits +:= 1
  869.       }
  870.    #
  871.    #  Read in more data if necessary.
  872.    #
  873.    while bufferbits < bits do {
  874.       buffer := ior(ishift(buffer,8),ord(inproc())) |
  875.             stop("Premature end of file")
  876.       bufferbits +:= 8
  877.       }
  878.    #
  879.    #  Extract code from buffer and return.
  880.    #
  881.    code := ishift(buffer,bits - bufferbits)
  882.    buffer := ixor(buffer,ishift(code,bufferbits - bits))
  883.    bufferbits -:= bits
  884.    return EOF ~= code
  885. end
  886.  
  887.  
  888. procedure whole_wild_match(p,s)
  889.    return wild_match(p,s) > *s
  890. end
  891.  
  892.  
  893. procedure not_wild_match(p,s)
  894.    return not (wild_match(p,s) > *s)
  895. end
  896.  
  897.