;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 124.52 ;;; Reason: ;;; More TCP Whostate changes. ;;; Written 13-Jun-88 16:57:15 by pld (Peter L. DeWolf) at site Gigamos Cambridge ;;; while running on Azathoth from band 1 ;;; with Experimental System 124.49, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1758, SDU Boot Tape 3.14, SDU ROM 8. ; From modified file DJ: L.NETWORK.IP-TCP.USER; IMAGEN.LISP#77 at 13-Jun-88 16:57:29 #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) (let ((tcp:*tcp-stream-whostate* "Imagen Close")) (with-open-stream (tcp-stream (let ((tcp:*tcp-stream-whostate* "Imagen Open")) (open-easy-tcp-stream address (sym-value 'IPPORT-IMAGEN) nil :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*)) (truename (global:send-if-handles file-stream :truename)) (directory (when truename (send (send truename :new-pathname :name nil :type nil :version nil) :string-for-printing))) (header-name (if truename (send (send truename :new-directory nil) :string-for-host) "Unnamed Stream")) (name (if truename (send truename :string-for-printing) "Unnamed Stream")) (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) (tcp:*tcp-stream-whostate* "Imagen Output")) (setq stream (ftp:make-ascii-translating-output-stream tcp-stream nil)) (format stream "@document(language ~A,jamresistance on,owner ~S,host ~S~@[,directory ~S~],name ~S~ ,jobheader on,spooldate ~S~:[~*~;,copies ~D,pagecollation on~],pagereversal on~ ,formlength ~D,formwidth ~D,formsperpage ~D,leftmargin ~D)" (case format (:impress "Impress") (:tek "Tektronix") (otherwise "Printer")) (print-owner) (send si:local-host :name) ;Local host directory ;Host and directory for Job Header header-name ;Name for Job Header spool-date ;Date 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))))))) ;;;Here is a function that wraps a stream that paginates around an OUTPUT stream )) ; From modified file DJ: L.NETWORK.IP-TCP.USER; IMAGEN.LISP#77 at 13-Jun-88 16:57:38 #10R TCP-APPLICATION#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; USER; IMAGEN  " (defun transmit-imagen-data-bytes (address) (let ((tcp:*tcp-stream-whostate* "Imagen Close")) (with-open-stream (imagen-stream (let ((tcp:*tcp-stream-whostate* "Imagen Open")) (open-easy-tcp-stream address (sym-value 'IPPORT-IMAGEN) nil :direction :output :output-buffers *imagen-writes-out* :keyword "Imagen Screen Dump"))) (let* ((landscape-p (eval *imagen-landscape-p*)) (magnification 0) (horizontal-magnification 0) (horizontal-available (getf *imagen-paper* (if landscape-p :landscape-h-available :portrait-h-available))) (horizontal-size 0) (horizontal-offset 0) (vertical-magnification 0) (vertical-available (getf *imagen-paper* (if landscape-p :landscape-v-available :portrait-v-available))) (vertical-size 0) (vertical-offset 0) (tcp:*tcp-stream-whostate* "Imagen Output")) (multiple-value-setq (horizontal-magnification horizontal-size) (imagen-magnification (third *imagen-data-size*) horizontal-available)) (multiple-value-setq (vertical-magnification vertical-size) (imagen-magnification (fourth *imagen-data-size*) vertical-available)) (setq magnification (max 0 (min horizontal-magnification vertical-magnification))) (unless (= magnification horizontal-magnification) (setq horizontal-size (* magnification (/ horizontal-size horizontal-magnification))) (setq horizontal-magnification magnification)) (unless (= magnification vertical-magnification) (setq vertical-size (* magnification (/ vertical-size vertical-magnification))) (setq vertical-magnification magnification)) (setq horizontal-offset (/ (- horizontal-available horizontal-size) 2.0)) (setq vertical-offset (/ (- vertical-available vertical-size) 2.0)) (when landscape-p (setq horizontal-offset (- horizontal-available horizontal-offset))) (format imagen-stream "@document(language impress,jobheader on,host ~S,name ~:[portrait~;landscape~]~D-~D-~D,spooldate ~S,owner ~S)" (send si:local-host :name) landscape-p (expt 2 magnification) (nth 2 *imagen-data-size*) (nth 3 *imagen-data-size*) (time:print-current-time nil :dd-mmm-yyyy) (print-owner)) (if landscape-p (impress imagen-stream 'SET_MAGNIFICATION magnification 'SET_ABS_H (inches-to-points vertical-offset) 'SET_ABS_V (inches-to-points horizontal-offset) 'SET_HV_SYSTEM (list :byte 0 ; pad 1 1 ; ORIGIN: physical 1 0 ; AXES: +90 deg (regular) 1 1 1 ; Orientation: 270 from X. )) (impress imagen-stream 'SET_MAGNIFICATION magnification 'SET_ABS_H (inches-to-points horizontal-offset) 'SET_ABS_V (inches-to-points vertical-offset))) (impress imagen-stream 'BITMAP 'OPAQUE (nth 0 *imagen-data-size*) (nth 1 *imagen-data-size*)) (send imagen-stream :string-out *imagen-data-bytes* 0 (* 128 (nth 0 *imagen-data-size*) (nth 1 *imagen-data-size*))) (impress imagen-stream 'ENDPAGE 'EOF))))) ))