;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 123.181 ;;; Reason: ;;; If your Imagen printer sometimes messes up a page in the middle of a long ;;; listing, you will enjoy this: you can now selectively re-print such pages. ;;; (hardcopy-file xxx :page-list '(3 4 71 72)) ;;; Written 11-Jan-88 13:40:13 by pld at site Gigamos Cambridge ;;; while running on Jack Flanders from band 2 ;;; with Experimental System 123.180, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8. ; From modified file DJ: L.NETWORK.IP-TCP.USER; IMAGEN.LISP#69 at 11-Jan-88 13:40:23 #10R TCP-APPLICATION#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; IMAGEN  " (defun imagen-status-ok-to-print (address &optional (verbose t)) (udp:using-udp-socket address (sym ipport-imagen) "Imagen Status" #'(lambda (socket header) (if *imagen-status-ok-wait* (do ((j 0 (1+ j))) ((imagen-status-ok-to-print-1 address socket header verbose) t) (if (= (1- *imagen-status-ok-wait-tries*) (mod j *imagen-status-ok-wait-tries*)) (cerror "continue waiting for it" "Imagen printer at ~S may be wedged" address)) (global:process-sleep (floor (* *imagen-status-ok-wait* 60) 1) "Imagen Queue Wait")) (imagen-status-ok-to-print-1 address socket header verbose))) #'(lambda () (format *error-output* "~&UDP is down.")))) (defun get-imagen-status (address socket header &key (tries 1) (try-pause 1) (wait-pause 1)) "Returns a plist describing the status of the imagen at the internet ADDRESS" (check-type socket udp:udp-socket) (check-type header (satisfies ip:ip-header-p)) (check-type tries (fixnum 1)) (check-type try-pause number) (check-type wait-pause number) (let (result) (dotimes (j tries) (if (setq result (get-imagen-status-1 address socket header (ROUND (* wait-pause 60)))) (return-from get-imagen-status result)) (global:process-sleep (ROUND (* try-pause 60)) "Imagen Status Sleep")))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; IMAGEN.LISP#69 at 11-Jan-88 14:09:51 #10R TCP-APPLICATION#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; IMAGEN  " (defun make-paginating-stream (stream page-header header-length line-numbers form-length form-width line-wrapping left-margin &optional (ascii t) page-list) (let* ((current-line 0) ;line number on page (current-column 0) ;column number on page (chars-per-line (- form-width left-margin)) (lines-per-page (- form-length header-length)) (page-number 0) ;The page number we are printing (line-number 1) ;The line of the file we are printing (crlf (make-string 2))) (labels ((on-page () (or (null page-list) (member page-number page-list))) (crlf () (when (on-page) (if ascii (send stream :string-out crlf) (send stream :tyo #\RETURN))) (setq current-column 0) (when (> (incf current-line) lines-per-page) (setq current-line 0))) (set-item (item) (cond ((null item) nil) ((eq item t) (format nil "~D" page-number)) (t item))) (check-header (continuation) (when (zerop current-column) (when (zerop current-line) (incf page-number) (when (and (plusp header-length) (on-page)) (let* ((left (set-item (first page-header))) (left-length (if left (length left) 0)) (center (set-item (second page-header))) (center-length (if center (length center) 0)) (right (set-item (third page-header))) (right-length (if right (length right) 0)) (total-length (+ left-length center-length right-length)) (pad-length (- chars-per-line total-length))) (format stream "~V@A~V@A~V@A" left-length left (+ (floor pad-length 2) center-length) center (+ (ceiling pad-length 2) right-length) right)) (dotimes (i header-length) (crlf))) (setq current-line 1)) (when line-numbers (when (on-page) (format stream "~6D~:[ ~;*~] " line-number continuation)) (setq current-column 8)))) (output-character (char) (check-header nil) (case char ((#\RETURN #\LINE) (incf line-number) (crlf)) (#\TAB (incf current-column (- 8 (mod current-column 8))) (if (and line-wrapping (>= current-column chars-per-line)) (let ((overflow (rem current-column chars-per-line))) (crlf) (check-header t) (when (on-page) (dotimes (i overflow) (send stream :tyo (if ascii #o40 #\SPACE))))) (when (on-page) (send stream :tyo (if ascii #o11 #\TAB))))) (#\OVERSTRIKE (decf current-column) (when (on-page) (send stream :tyo (if ascii #o10 #\OVERSTRIKE)))) (#\PAGE (unless (= current-line 1) (setq current-line 0) (setq current-column 0) (when (on-page) (send stream :tyo (if ascii #o14 #\PAGE))))) (otherwise (when (and line-wrapping (= current-column chars-per-line)) (crlf) (check-header t)) (incf current-column) (when (on-page) (send stream :tyo char)))))) (setf (char crlf 0) #o15) ;ASCII CR (setf (char crlf 1) #o12) ;ASCII LF #'(lambda (operation &optional arg1 &rest args) (case operation (:tyo (output-character (int-char arg1))) (:string-out (do* ((start (or (first args) 0)) (end (or (second args) (string-length arg1))) (i start (1+ i))) ((>= i end)) (output-character (char arg1 i)))) (:which-operations '(:tyo :string-out))))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; IMAGEN.LISP#69 at 11-Jan-88 14:10:00 #10R TCP-APPLICATION#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; IMAGEN  " (defun print-stream-to-imagen (file-stream address &optional options) (check-type address string) (with-open-file (tcp-stream (string-append "TCP-HOST:" address ".IMAGEN") :direction :output :output-buffers *imagen-writes-out* :keyword "Imagen Printer") (let* ((format (getf options :format :text)) (copies (getf options :copies *imagen-default-copies*)) (form-length (getf options :form-length *imagen-default-form-length*)) (form-width (getf options :form-width *imagen-default-form-width*)) (line-wrapping (getf options :line-wrapping *imagen-default-line-wrapping*)) (forms-per-page (getf options :forms-per-page *imagen-default-forms-per-page*)) ;;forms-per-page = 1, form-width = 80 --> normal PORTRAIT ;;forms-per-page = 1, form-width = 132 --> normal LANDSCAPE ;;forms-per-page = 2, form-width = 80 --> two pages per page, side by side, LANDSCAPE ;;forms-per-page = 2, form-width = 132 --> two pages per page, one above other, PORTRAIT (left-margin (getf options :left-margin *imagen-default-left-margin*)) (line-numbers (getf options :line-numbers *imagen-default-line-numbers*)) (name (send (global:send-if-handles file-stream :truename) :string-for-editor)) (spool-date (time:print-current-time nil :dd-mmm-yyyy)) (file-date (getf options :file-date spool-date)) (page-headings (getf options :page-headings *imagen-default-page-headings*)) (page-list (getf options :page-list)) (stream nil)) (setq stream (ftp:make-ascii-translating-output-stream tcp-stream nil)) (format stream "@document(language ~A,jamresistance on,host ~S~ ,jobheader on,name ~S,spooldate ~S,owner ~S~:[~*~;,copies ~D,pagecollation on~],pagereversal on~ ,formlength ~D,formwidth ~D,formsperpage ~D,leftmargin ~D)" (case format (:impress "Impress") (:tek "Tektronix") (otherwise "Printer")) (send si:local-host :name) ;Local host name ;Name for Job Header and Page Header spool-date ;Date for Job Header (string si:user-id) ;Owner for Job Header (> copies 1) ;Conditional for multiple-copy options copies ;Number of copies form-length ;lines per logical page form-width ;columns per logical page forms-per-page ;logical pages per physical pages left-margin ;blank columns at left edge of each logical page ) (ecase format ((:text nil) (global:stream-copy-until-eof file-stream (make-paginating-stream tcp-stream (and page-headings (list name t file-date)) (if page-headings 2 0) line-numbers form-length form-width line-wrapping left-margin t page-list))) (:ascii (global:stream-copy-until-eof file-stream stream)) ((:impress :tek) (global:stream-copy-until-eof file-stream tcp-stream)))))) ))