#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH

;;; list of printers: p-list name and 
;;; (reverse? x-offset y-offset space-between-colums use_-h)
;;; defaults is for the ()  printer

(setq printers '(
    nwcroap (t 600 100 380 ())
    lwcroap (() 650 -500 380 ())
    () (() 650 0 380 t)
))

;;; options

(setq files (getopts
    "lpt [options] files...          - print text files on a postscript printer
uses enscript to get a prettyfied output.
~/.lpt-printers can be defined to hold printer descriptions in lisp, as
lines written as:
    printer-name (reverse? x-offset y-offset separation use-h?)
where flags are t or () and numbers in points
    - reverse? is t if pages must be printed lasr first
    - x-offset and y-offset are horizontal and vertical margins
    - separation is the magin between columns (recommended: 380)
    - use-h? if t then lpr -h is used, lpr alone otherwise to send to printer
for instance: 
    nwcroap (t 600 100 380 ())
    lwcroap (() 650 0 380 t)"
    ("-P" printer printer-name "printer on which to print")
    ("-r" () reverse "reverse the pages")
    ("-n" () no-print "do not send postscript to printer but to stdout")
    ("-g" () garbage "prints file even if it contains lots of non-ASCII chars")
    ("-c" number (columns 2) "prints in \"number\" columns (defaults to 2)")
    ("-l" number (lines 66) "number of lines per page (default 66)")
    ("-w" () wrap-lines "wraps wide lines (default is to truncate)")
    ("-a" () print-name-on-all 
      "prints user name and date on all pages (default only on first)")
    ("-T" () test-file "prints a test page for calibrating on new printers")
    ("-v" () verbose "verbose")
))

(setq enscript-command '(
    "enscript"  "-2r" "-k" "-L66" "-FHelvetica-Bold7" "-fCourier7" "-p"
))

(setq print-command '(
    "lpr"
))

(setq user-printers (list))
(if (setq fd (open "~/.lpt-printers" :error ())) (progn
    (while (setq item (read fd ()))
      (lappend user-printers item)
    )
    (setq printers (+ user-printers printers))      
))

(setq second-column-start 7920)

(defun main ()
  
  (if (typep columns String) (progn
      (setq columns (Int columns))
      (put enscript-command 1 (+ "-" (String columns) "r")))
  )

  (if (/= lines 66) (progn
      (setq lines (+ "-L" (String lines)))
      (with (pos (seek enscript-command "-L66"))
	(put enscript-command pos lines)
  )))
  
  (if (not wrap-lines) (insert enscript-command 1 "-c"))

  (if test-file (with (fd (open "/tmp/lpt_test" :direction :output 
	  :if-exists :supersede
      ))
      (print-test-file fd)
      (close fd)
      (setq files (list "/tmp/lpt_test"))
  ))    
  
  (setq temp-file (+ "/tmp/lpt" (String *current-process-id*)))
  (dolist (file files) 
    (nconc temp-file ",_" (match "(.*[/]|^)(.*)$" file 2)))
  (if (> (length temp-file) 80) (setq temp-file (subseq temp-file 0 79)))
  
  (nconc enscript-command (list temp-file))
  (if garbage (nconc enscript-command (list "-g")))
  
  (dolist (file files) (nconc enscript-command (list file)))
  
  (if (not printer-name) 
    (if (getenv "PRINTER") (setq printer-name (getenv "PRINTER")))
  )
  (if printer-name (nconc print-command (list (+ "-P" printer-name))))
  (nconc print-command (list temp-file))
  
  (setq printer-props (get printers printer-name 
      '(get printers () '(() 0 0))))
  (if (getn printer-props 0) (setq reverse (not reverse)))
  (setq offsets (subseq printer-props 1 3))
  (setq space-between-columns (get printer-props 3 380))
  (if (getn printer-props 4) (insert print-command 1 "-h"))
  
;;; do enscript
  
  (if (/= 0 (setq code (wait (system enscript-command)))) (progn
      (print-format *standard-error* 
	"lpt: enscript error (code %0), nothing sent!\n" code
      )
      (exit 1)
  ))
  
;;; post-process file
  
  (setq fd (open temp-file))
  (file-position fd 0)
  
  (setq re-header-font (regcomp "^[0-9]+ [0-9]+ [/]Helvetica-Bold$"))
  (setq re-body-font (regcomp "^[0-9]+ [0-9]+ [/]Courier$"))
  (setq re-offset (regcomp 
      "^([/]Landscape *[{] *90 +rotate +)(-?[0-9]+) +(-?[0-9]+)( +translate[}] *def)$"
  ))
  (setq re-endprolog (regcomp "^[%][%]EndProlog$"))
  (setq re-fontdict-decl (regcomp "^2 SetUpFonts$"))
  
  (setq lines (list))
  
;;; treat prolog
  
  (setq prolog t)
  (while (and prolog (setq line (read-line fd ())))
    (if (regexec re-header-font line) (progn
	(lappend lines "2 250 /Helvetica-Bold\n1 400 /Helvetica-Bold")
      )
      (regexec re-body-font line) (progn
	(lappend lines "0 160 /Courier") ;bigger (8pt) body font
      )
      (regexec re-fontdict-decl line) (progn
	(lappend lines "3 SetUpFonts")
      )
      (regexec re-offset line) (progn
	(setq x-offset (Int (regsub re-offset 2)))
	(setq y-offset (Int (regsub re-offset 3)))
	(incf x-offset (get offsets 0))
	(incf y-offset (get offsets 1))
	(lappend lines (+ (regsub re-offset 1) (String x-offset) " "
	    (String y-offset) (regsub re-offset 4)
      )))
      (regexec re-endprolog line) (progn
	(lappend lines line)
	(setq prolog ())
      )
      (lappend lines line)
  ))
  
;;; treat body
  
  (setq re-header-decl (regcomp "^1 F$"))
  (setq re-second-column (regcomp (+ "^([0-9]+) +( .*[)]B)$")))
  
  (with (pos 0) (catch 'EOF (while t
	(setq line (read-line fd))
	(if 
	  (and (regexec re-second-column line)
	    (>= (setq pos (Int (regsub re-second-column 1)))
	      second-column-start
	  ))	      
	  (lappend lines (+ (String (+ space-between-columns pos))
	      (regsub re-second-column 1)
	  ))
	  
	  (regexec re-header-decl line) (progn
	    (lappend lines line)
	    (lappend lines (process-header (read-line fd ())))
	  )
	  
	  (lappend lines line)
  ))))
  (close fd)
  
  (setq fd (open temp-file :direction :output :if-exists :supersede))
  (dolist (line lines) (write-line line fd))
  (close fd)
  
;;; reverse?
  
  (if reverse (progn
      (setq system-command (+ "mv " temp-file " " temp-file ".bak; "  
	  "pstops -q -0 < " temp-file ".bak > " temp-file "; "
	  "rm -f " temp-file ".bak; "
      ))
      (wait (system system-command))
  ))
  
;;; print
  
  (if no-print
    (wait (system  (list "cat" temp-file)))
    (wait (system print-command))
  )
  
;;; clean
  
  (wait (system (list "rm" "-f" temp-file)))
)

 
(setq ps-quotable-chars "()\\")
(setq re-ps-quotable (regcomp (+ "[" ps-quotable-chars "]")))
(defun postscript-quote (s &aux res)
  (if (regexec re-ps-quotable s) (progn
      (setq res (copy ""))
      (dolist (c s)
	(if (seek ps-quotable-chars c)
	  (put res -1 #\\)
	)
	(put res -1 c)
      )
    )
    s
))
 
;;; treat page header
  
(setq re-header (regcomp 
    "^[0-9]+ [0-9]+ [(]([^ ]+)[ ]+([^ ].*[^ ])[ ]+([0-9]+)[)]B$"
))
(and (not (setq username (getenv "NAME")))
  (not (setq username (getenv "USER")))
  (setq username "")
)
(setq username (postscript-quote username))

(defun process-header (line &aux
    (res (Stream ""))
  )
  (if (regexec re-header line) (with (
	name (relative-name (regsub re-header 1))
	date (regsub re-header 2)
	page (regsub re-header 3)
      )
      (print-format res "360 15000 (%0)B\n" (postscript-quote name))
      (print-format res "15000 15000 (%0)B\n" page)
      (if (or print-name-on-all (= "1" page))
	(print-format res "2 F\n10000 15000 (%0)B\n10000 15250 (%1)B" 
	  (postscript-quote date) username)
      )
      (String res)
    )
    line				;unrecognized?
  )
)

(setq homedir (expand-filename "~"))
(setq homedir-len (length homedir))

(defun relative-name (name)
  (if (= (subseq name 0 homedir-len) homedir)
    (+ "~" (subseq name homedir-len))
    name
  )
)

;; prints a test page (2 x 66 lines of 80 chars) on fd

(defun print-test-file (fd)
  (dotimes (i 132) 
    (print-format fd "#[%0]#  " (expand-num i 3 :filler #\ )) 
    (dotimes (j 7) 
      (print-format fd ".%00  56789" (+ 1 j))) 
    (print-format fd "\n")
))

(main)

;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***