;;; -*- Mode:LISP; Package:USER; Base:8; Readtable:ZL -*-
; Simple stuff for printing text files on angel (default).
; Instructions for use:
; type (load "dj:bobp;unix-print.qfasl")
;
; Then use the normal zmacs (or other) text-printing commands:
; -X print buffer
; -X print region
; -X print file
; To print in landscape mode, print without page headings,
; or select a different printer, type:
; (set-unix-print-options)
; This was printed by marking this region and typing -X print region
;to-do:
; n-copies
; no imagen header page
(DEFUN (:PROPERTY :unix-printer si:PRINT-FILE) (PRINTER FILE-NAME
&OPTIONAL &KEY (FORMAT ':TEXT)
&ALLOW-OTHER-KEYS)
(IF (EQ FORMAT ':TEXT)
(WITH-OPEN-FILE-CASE (FILE-STREAM FILE-NAME ':DIRECTION ':INPUT)
(FS:FILE-ERROR
(SEND ERROR-OUTPUT ':FRESH-LINE)
(SEND ERROR-OUTPUT ':STRING-OUT "unix printer error in opening file: ")
(SEND FILE-STREAM ':REPORT ERROR-OUTPUT))
(:NO-ERROR (unix-print-stream PRINTER FILE-STREAM)))
(FORMAT ERROR-OUTPUT "~&unix systems only know about the TEXT format, not ~S." FORMAT)))
(DEFUN (:PROPERTY :unix-printer si:PRINT-STREAM) (PRINTER STREAM
&OPTIONAL &KEY (FORMAT ':TEXT)
file-name
&ALLOW-OTHER-KEYS)
(IF (EQ FORMAT ':TEXT)
(unix-print-stream PRINTER STREAM :file-name file-name)
(FORMAT ERROR-OUTPUT "~&unix systems only now about the TEXT format, not ~S." FORMAT)))
(defvar unix-print-landscape nil) ;use to be :unknown
(defvar unix-print-header t)
(defvar unix-print-host-name "angel")
(defvar unix-print-printer-name "im1")
;(add-initialization "unix-print-landscape" '(setq unix-print-landscape :unknown))
(defun set-unix-print-options (&optional &key
(landscape unix-print-landscape l-supplied)
(header unix-print-header he-supplied)
(host unix-print-host-name ho-supplied)
(printer unix-print-printer-name p-supplied))
(if (or l-supplied he-supplied ho-supplied p-supplied)
(setq unix-print-landscape landscape
unix-print-header header
unix-print-host-name host
unix-print-printer-name printer)
(tv:choose-variable-values '((unix-print-landscape "Landscape mode" :boolean)
(unix-print-header "Include page headings" :boolean)
(unix-print-host-name "Host name" :string)
(unix-print-printer-name "Printer name" :string))
:label "Unix IMPRINT parameters"
))
nil)
;; By this point, the FORMAT had darn well better be :TEXT...
(DEFUN unix-print-stream (PRINTER FROM-STREAM &key file-name)
(if (eq unix-print-landscape :unknown)
(set-unix-print-options))
(let ((host (if (listp printer)
(SI:PARSE-HOST (SECOND PRINTER))
unix-print-host-name))
(contact-name
(format nil
"EVAL imprint ~:[~;-P~:*~a~] ~
~:[~*~;~a~] ~
~:[~*~;~a~] ~
~:[~*~;-I '/"-Dfor ~:@(~a~)/"'~] ~
~:[~*~;-I '/"-Dserver ~:@(~a~)/"'~] ~
~:[~*~;-I '/"-Ddirectory ~:@(~a~)/"'~] ~
~:[~*~;-h '~a'~] ~
~:[~*~;-I '/"-Dversion ~:@(~a~)/"'~]"
unix-print-printer-name
unix-print-landscape "-L"
(null unix-print-header) "-n" ;use "cat" instead of "pr"
user-id user-id
file-name (extract-server-name file-name)
file-name (extract-directory-name file-name)
(and unix-print-header file-name)
(extract-file-name file-name) ;can only give this to "pr"
file-name (extract-version-name file-name)
))
)
(with-open-stream-case (stream
(chaos:open-stream
host
contact-name
; (substring contact-name 0 (min 125. (length contact-name)))
:direction :output))
(FS:FILE-ERROR
(SEND ERROR-OUTPUT ':FRESH-LINE)
(SEND ERROR-OUTPUT ':STRING-OUT "unix printer error in opening file: ")
(SEND STREAM ':REPORT ERROR-OUTPUT))
(:NO-ERROR
(do ((c (send from-stream ':tyi) (send from-stream ':tyi)))
((null c))
(selectq c
(#\epsilon (send from-stream ':tyi))
(#\newline (send stream ':tyo 12))
(#\tab (send stream ':tyo 11))
(#\overstrike (send stream ':tyo 10))
(#\page (send stream ':tyo 14))
(t (send stream ':tyo c))))))))
(defun extract-server-name (name)
(let* ((colon-position (position #/: name))
(preceding-space-position (string-reverse-search-char #/space name colon-position))
(start-position (1+ preceding-space-position)))
(lobotomize-string (substring name start-position colon-position))))
(defun extract-directory-name (name)
(let ((colon-position (position #/: name))
(semicolon-position (position #/; name))
(first-slash-position (position #// name))
(last-slash-position (position #// name :from-end t)))
(lobotomize-string
(cli:remove
#/space
(cond
(first-slash-position
(substring name first-slash-position last-slash-position))
((and colon-position semicolon-position)
(substring name (1+ colon-position) semicolon-position))
(t
"???"))))))
(defun extract-file-name (name)
(let* ((semicolon-position (string-search-char #/; name))
(last-slash-position (position #// name :from-end t))
(sharp-position (position #/# name)))
(lobotomize-string
(cli:remove
#/space
(cond
(semicolon-position
(substring name (1+ semicolon-position) sharp-position))
(last-slash-position
(substring name (1+ last-slash-position) sharp-position))
(t
"???"))))))
(defun extract-version-name (name)
(let* ((sharp-position (position #/# name))
(open-paren-position (position #/( name :start (if sharp-position sharp-position 0)))
(close-paren-position (position #/) name :start (if open-paren-position open-paren-position 0))))
(cond
(open-paren-position
(substring name (1+ open-paren-position) close-paren-position))
(t
""))))
(defun lobotomize-string (string)
(substring string (max 0 (- (length string) 25.))))
(setq si:*default-printer* ':unix-printer)