;;; -*- Mode:Common-Lisp; Package:PRINTER; Fonts:(COURIER TR12I TR12BI TR12 MEDFNTB); Base:10; Patch-file:T -*-

;1 File name: SERVER.LISP*
;1 Redefines and adds methods to Print Requests for the LPD protocol.*
;1 Started 3-24-1989 by Eric Karlson, UC-Berkeley under Robert Wilensky*
;1 Phone: (415) 642-9076, E-mail Address: karlson@ucbarpa.berkeley.edu*

;1-------------------------------*
;1 Define some top level functions.*
;1-------------------------------*

(defun 4cancel-printer-request* (request-no &optional (printer (get-default-printer)))
"2Request for cancelling a print request on a particular printer on any host.*"
  (declare (function cancel-print-request-on-remote-host (STRING FIXNUM) NULL)
	   (values NIL))
  ;1 Check args.*
  (check-arg printer (not (equal '(nil) (get-printer-device printer)))
	     "3a known printer*")
  (format T "3~%~&~A*"
	  (send (net:parse-host (get (get-printer-device printer) :HOST)) :lpd :cancel printer request-no)))

(defun 4printer-queue* (&optional (printer (get-default-printer)) (type :SHORT))
"2Shows the queue on the given printer. The TYPE indicates what sort of information
is desired from the queue status and can be one of SIMPLE, SHORT or LONG.*"
  (declare (function printer-queue (STRING &optional KEYWORD) NULL)
	   (values NIL))
  ;1 Check args.*
  (check-arg printer (not (equal '(nil) (get-printer-device printer)))
	     "3a known printer*")
  (check-arg type (member type '(:SIMPLE :SHORT :LONG) :test #'string-equal)
	     "3one of SIMPLE, SHORT or LONG*")
  (format T "3~%~&~A*"
	  (send (net:parse-host (get (get-printer-device printer) :HOST))
		:lpd :status printer (sys:force-to-keyword-symbol type))))

;1--------------------------------------------------*
;1 Redefine the remote-print-spooling for print requests*
;1--------------------------------------------------*

(defmethod 4(file-print-request :send-remote-print-file-request*) (printer-host)
"2Send to a remote Print Server on host the print request's filename, printer name,
and printer options*"
;1 This is set up to work with both the old print spooling software and my new and improved stuff.*
;1 This works by checking to see if the host has an LPD service. If so, use my stuff, otherwise use*
;1 the existing crummy stuff.*
  (declare (function (:METHOD file-print-request :send-remote-print-file-request) (net:HOST) T))
  (if (assoc :LPD (send printer-host :service-list))
      (send printer-host :lpd :spool self)
      (case (send printer-host :system-type)
	(:LISPM (send self :lispm-remote-print-file-request printer-host))
	((:VAX :VMS :VMS4 :VMS5) (send self :vax-remote-print-file-request printer-host))
	(:LMFS (send self :symbolics-remote-print-file-request printer-host))
	( T (send self :foreign-remote-print-file-request printer-host)))))

(defmethod 4(file-print-request :print-file*) ()
"2Copy file in print request to printer. Prints regular text file (withwithout fonts) or array image file.
The file being printed is deleted (and expunged) ONLY if the print was successful.*"
  (declare (function (:METHOD file-print-request :print-file) () SYMBOL)
	   (values PRINTED?))
  (catch 'Print-Error
    (with-open-stream (printer-stream (apply #'get-printer-stream (cdr print-device)))
      (declare (STREAM printer-stream))

      ;1 Make the printer device.*
      (let ((printer (send self :make-printer-device printer-stream)))
	(declare (type BASIC-PRINTER printer))
	(with-open-file (file-stream file-name :character T :direction :input :error nil)
	  (declare (STREAM file-stream))

	  ;1 See if we openned the file and then try to print it.*
	  (cond ((errorp file-stream) (notify-user-at-host
					(format nil "Error: ~A~%in print request ~A" file-stream self)
					sender-host)
				      (throw 'Print-Error nil))
		((not (let ((p-state (send printer :current-printer-state (get print-device :stream))))
			(getf p-state :online))) ;1Returns list of condition states. If offline report error and de-queue request.*
		 (notify-user-at-host
		   (format nil "Error: Printer ~A in print request ~A is offline or out of paper."
			   (first print-device) file-name)
		   sender-host)
		 (throw 'Print-Error nil))
		( T (dotimes (n (if (send printer :prints-multiple-copies-p) 1 copies))
		      (declare (FIXNUM n))
		      (if (plusp n)
			  (send file-stream :set-pointer 0))   ;1 Reset file stream*
		      (send printer :start-document
			    (if header
				(or header-name file-name))
			    (if sender-host
				(format nil "3~A@~A*" user-name sender-host)
				user-name)
			    copies)
		      ;1 Decide what type of file it is and then print it accordingly.*
		      (if (send printer :screen-image-file-p file-name)
			  (send printer :print-raw-file file-stream)
			  (send printer :print-text-file file-stream font-list))
		      (send printer :end-document)))))))
    ;1 Delete file *
    (when delete-after
      (delete-file file-name :error nil)
      (send (pathname file-name) :expunge :error nil))

    ;1 Return PRINTED status.*
    T ))

(defmethod 4(array-print-request :handle-remote-request*) (printer-host)
"2Printer is on a remote host. Copy the screen image into a temporary file
and send its file request to the print server for remote printer.*"
  (declare (function (:METHOD array-print-request :handle-remote-request) (net:HOST) T))
  (cond ((not *ALLOW-SENDING-OF-REMOTE-PRINT-REQUESTS*)
	 (notify-user-at-host (format nil "3Spooling of ~A to printer ~A on ~A not allowed*"
				      screen-name (car print-device) (get print-device :host))
			      sender-host))
	((and (typep bitmap-array 'ARRAY) (eq (array-type bitmap-array) 'ART-1B))
	 (notify-user-at-host (format nil "3Spooling ~A print request to printer ~A on ~A*"
				      screen-name (car print-device) (get print-device :host))
			      sender-host)
	 (let ((temp-file (send self :copy-array-into-temp-file)))
	   (declare (type (or PATHNAME ERROR) temp-file))
	   (unless (errorp temp-file)
	     (send (make-instance 'FILE-PRINT-REQUEST
				  :print-device print-device
				  :file-name temp-file
				  :header-name screen-name
				  :header header
				  :user-name user-name
				  :sender-host sender-host
				  :copies copies
				  :lines nil
				  :delete-after T
				  :request-no request-no)
		   :send-remote-print-file-request printer-host))))
	( T (notify-user-at-host (format nil "3~A not a bit array in print request queue entry: ~A*"
					 bitmap-array self)
				 sender-host))))

;1-----------------------------------------*
;1 Define the Server Side of the LPD protocol*
;1-----------------------------------------*

(defun 4receive-chaos-print-request *(stream)
"2Reads a Print-Request from the stream and puts it into the queue.*"
  (declare (function receive-chaos-print-request (STREAM) T))
  (let ((request (eval (read stream nil ()))))
    (declare (T request))
    (cond ((null request) (format stream "3-Print Request garballed in transmission~%*")
			  (send stream :eof))
	  ( T (without-interrupts
		(setq *PRINT-QUEUE* (nconc *PRINT-QUEUE* (list request)))
		(send request :save-self-in-file))
	      (send stream :tyo #\+)
	      (send stream :eof)))))

(defun 4return-chaos-queue-info *(stream)
"2Returns the status of the queue on this machine for print jobs being sent to
a particular printer.*"
  (declare (function return-chaos-queue-info (stream) T))
  (let ((printer (read-line stream nil "")))
    (send stream :tyo #\+)
    (format stream "3~:[No Entries on ~A: ~A~%~;~A: ~A~%~0@*~{~@[~A~]~}~]*"
	    (mapcar #'(lambda (entry)
			(declare (T entry))
			(if (and (typep entry 'BASIC-PRINT-REQUEST)
				 (string-equal printer (get (send entry :printer-device) :remote-name)))
			    (send entry :show-print-request)
			    nil))
		    *PRINT-QUEUE*)
	    (send sys:LOCAL-HOST :name)
	    printer)
    (send stream :eof)))