#!/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: ***
syntax highlighted by Code2HTML, v. 0.9.1