path: root/ipl/progs/mszip.icn

############################################################################
#
#	File:     mszip.icn
#
#	Subject:  Program to ZIP a directory for MS-DOS use
#
#	Author:   Gregg M. Townsend
#
#	Date:     June 23, 2000
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#  usage:  mszip [options] root-directory zip-file
#	-n	no action: just report; zip-file may be omitted
#	-v	verbose commentary: list individual file types
#	-i	check filenames for ISO 9660 (CD-ROM) legality
#
#  Mszip stuffs the contents of a directory into a ZIP archive file,
#  translating text files to CRLF form.  Pipes are opened that
#  require find, sort, and zip in the search path.
#
#  The default report gives an inventory of files by extension.  This
#  can be useful even without creating a ZIP file ("mszip -n dir").
#  
#  File types on the verbose report are:
#	x	unreadable file
#	e	empty file
#	b	binary file
#	c	text file with CRLFs
#	n	text file with newlines
#  A file is "binary" if it contains more than 1% unexpected characters.
#
#  Symlinks, FIFOs, device files etc. are reported and not archived.
#  Files with illegal MS-DOS names are reported but still archived.
#
############################################################################
#
#  Requires:  UNIX, zip program
#
############################################################################



$define USAGE "[-n] [-v] [-i] root-directory zip-file"

$define BTHRESH 0.01		# allowed fraction of wild bytes in text file

$define BUFSIZ 65536		# size of buffer for checking binary/text
				# (bytes beyond this many are not checked)

$define ZIPOPTS "-9 -X"		# best compression; omit uid/gid


link options



global verbose
global errorcount
global allfiles, binlist, txtlist
global extns



procedure main(args)
   local opts, root, zipopts, zipname
   local pwd, pipe, fname, errmsg
   local nmproc

   # process options
   opts := options(args, "nvi")
   verbose := opts["v"]
   if \opts["i"] then
      nmproc := isoname
   else
      nmproc := msname

   root := args[1] | stop("usage: ", &progname, " ", USAGE)

   # get current directory name and prepend to zip file if necessary
   if /opts["n"] then {
      zipname := args[2] | stop("usage: ", &progname, USAGE)
      pipe := popen("pwd")
      pwd := read(pipe) | stop("can't read current directory")
      close(pipe)
      if not zipname ? ="/" then
         zipname := pwd || "/" || zipname
   }

   # change to source directory
   chdir(root) | stop("can't change to directory: ", root)

   # verify that zip file is writable
   if \zipname then {
      if not close(open(zipname, "w")) then
         stop(zipname, ": cannot write")
      remove(zipname)
      }

   # initialize
   errorcount := 0
   extns := table("")
   allfiles := []
   binlist := []
   txtlist := []

   # check for "bad" files: symlinks, fifos, etc.
   write(&errout, "finding files...")
   pipe := popen("find . ! -type d ! -type f -print | sort")
   while report(read(pipe), "bad file type")
   close(pipe)

   # get list of the rest
   pipe := popen("find . -type f -print | sort")
   while fname := read(pipe) do {
      put(allfiles, fname)
      if not nmproc(fname) then
         report(fname, "illegal filename")
      }
   close(pipe)

   # inspect files
   write(&errout, "inspecting files...")
   while inspect(get(allfiles))

   # summarize file types by extension
   summary()

   # write zip file, if -n was not specified
   if \zipname then {

      zipopts := ZIPOPTS
      if /verbose then
         zipopts := ZIPOPTS || " -q"

      # create zip file and fill with text files
      write(&errout, "storing text files...")
      pipe := popen("zip -l " || zipopts || " " || zipname || " -@", "w")
      every write(pipe, !txtlist)
      close(pipe)

      # add binary files to zip file
      write()
      write(&errout, "storing binary files...")
      pipe := popen("zip -g " || zipopts || " " || zipname || " -@", "w")
      every write(pipe, !binlist)
      close(pipe)
      }

   # exit
   if errorcount > 0 then
      stop("\t", errorcount, " error(s)")
   else
      write("done.")
end



#  popen(cmd, mode) -- open pipe, and abort on error

procedure popen(cmd, mode)
   local f

   mode := "p" || (\mode | "r")
   f := open(cmd, mode) | stop("can't open pipe: ", cmd)
   return f
end



#  census(s, c, lim) -- count occurrences of members of c in string s
#
#  If lim is given, counting can stop early.

procedure census(s, c, lim)
   local n

   /lim := *s
   n := 0
   s ? {
      while n < lim & tab(upto(c)) do
         n +:= *tab(many(c))
      }
   n >:= lim
   return n
end



#  msname(fname) -- check filename for MS-DOS legality

procedure msname(fname)
   local dir, base, ext 
   static forbid
   initial forbid := &cset -- &letters -- &digits -- '/._^$~!#%&-{}()@\'`'

   fname ? {
      if upto(forbid) then fail			# forbidden char
      while dir := tab(upto('/') + 1) do 
         if *dir > 9 then fail			# dir component too long
      if base := tab(upto('.')) then {
         move(1)
         if upto('.') then fail			# two periods
         ext := tab(0)
         }
      else {
         base := tab(0)
         ext := ""
         }
      if (*base > 8) | (*ext > 3) then fail	# component too long
      }
   return
end



#  isoname(fname) -- check for ISO-9660 (CD-ROM) filename legality
#
#  (disallows explicit version numbers)

procedure isoname(fname)
   static legal
   initial legal := &lcase ++ &ucase ++ &digits ++ '_.'

   fname ? {
      while tab(upto('/') + 1)
      tab(many(legal))
      if pos(0) then
         return msname(fname)
      else
         fail
   }
end



#  inspect(fname) -- inspect one file and update lists

procedure inspect(fname)
   local c

   fname ? {
      if ="./" then
         fname := tab(0)
   }

   c := ftype(fname)
   count(fname, c)
   if \verbose then write(c, " ", fname)

   if c == "x" then {
      report(fname, "unreadable file")
      return
      }

   if c == "n" then
      put(txtlist, fname)
   else
      put(binlist, fname)

   return
end



#  ftype(fname) -- return file type character

procedure ftype(fname)
   local f, s, lim
   static bset
   initial bset :=		# allows \a\b\t\n\v\f\r\^Z
      '\0\1\2\3\4\5\6\16\17\20\21\22\23\24\25\26\27\30\31\33\34\35\36\37' ++
      &cset[128+:33]

   f := open(fname, "ru") | return "x"
   s := reads(f, BUFSIZ)
   close(f)

   if /s | (*s = 0) then return "e"
   lim := BTHRESH * *s
   if census(s, bset, lim) >= lim then return "b"
   else if census(s, '\l') > census(s, '\r') then return "n"
   else return "c"
end



#   count(fname, typechar) -- count file extension

procedure count(fname, tchar)
   local extn

   fname ? {
      while tab(upto('/') + 1)
      if tab(upto('.') + 1) then {
         while tab(upto('.') + 1)
         extn := tab(0)
         }
      else
         extn := ""
      }
   extns[extn] ||:= tchar
   return
end



#  report(fname, errmsg) -- report error

procedure report(fname, errmsg)
   write(&errout, "\t", errmsg, ": ", fname)
   errorcount +:= 1
   return
end



#  summary() -- generate summary of extension counts

procedure summary()
   local tlist, ext, s, b, c, e, n, x, tb, tc, te, tn, tx

   write()
   write(" unrd empty bin crlf newln  extension")
   tb := tc := te := tn := tx := 0

   tlist := sort(extns, 3)
   while ext := get(tlist) do {
      s := get(tlist)
      tb +:= (b := census(s, 'b'))
      tc +:= (c := census(s, 'c'))
      te +:= (e := census(s, 'e'))
      tn +:= (n := census(s, 'n'))
      tx +:= (x := census(s, 'x'))
      write(r5(x), r5(e), r5(b), r5(c), r5(n), "   .", ext)
      }

   write()
   write(r5(tx), r5(te), r5(tb), r5(tc), r5(tn), "   TOTAL: ", tx+te+tb+tc+tn)
   write()
   return
end



#  r5(n) -- show integer in 5-char field, if nonzero

procedure r5(n)
   local s

   if n = 0 then return "     "
   s := integer(n)
   if *s < 5 then
      return right(s, 5)
   else
      return " " || s
end