;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.214
;;; Reason:
;;;  Make Imagen printer work when given an FTP Raw stream as file input.
;;; Written 8-Mar-88 17:35:40 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.213, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tape 21.1, microcode 1755, SDU Boot Tape 3.12, SDU ROM 8.


; From modified file DJ: L.NETWORK.IP-TCP.USER; IMAGEN.LISP#72 at 8-Mar-88 17:40:48
#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 (int-char 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)))))))

))