;1;; -*-* Mode:LISP; Package:LASER2; Fonts:(CPTFONT HL12B); Base:8; Readtable:ZL 1-*-*
;1;; Copyright (c) 1985, LISP Machine, Inc.*

;1;; Description: Laser2 server*
;1;; Programmer: James M. Turner*
;1;; Last Modification: 11-Jan-1985*
;1;;*
;1;; Change History:*
;1;;*

;1;; Abandon ship!*

(defmethod (laser2-stream :reset-laser2) ()
  (send server-process :reset))

(defun reset-laser2 (&optional (save-current nil))
  (send *laser2-stream* :reset-laser2)
  (if save-current
      (push (send *laser2-stream* :current-job) (send *laser2-stream* :printer-queue))))

(defun start-laser2-processes-if-needed ()
  (if *laser2-stream*
      (progn
	(if (not (equal (send (send *laser2-stream* :server-process) :name)
			"Laser2 Server Process"))
	    (start-laser2-server)))
    (setq *laser2-stream* (make-instance 'laser2-stream))
    (start-laser2-server)))

(defun start-laser2-server ()
  (send *laser2-stream*
	:set-server-process
	(process-run-restartable-function "Laser2 Server Process"
					  #'laser2-server)))
(defun laser2-server ()
  (send *laser2-stream* :run-server))


;1;; Checks queue for jobs waiting, then prints them.*

(defmethod (laser2-stream :run-server) ()
  ;1; So we can open files*
  (setq tcp-stream nil)
  (let ((user-id "LASER2") rmname fndname)
    (do-forever
      ;1; Wait for job.*
      (process-wait "No Jobs" #'(lambda (x) (send x :printer-queue)) self)
      (setq current-job (pop printer-queue))
      (unwind-protect
	  (*catch 'no-printer
	    (cond 
	      ((get-site-option :arpa-gateways)
	       (setq rmname (apply 'circular-list (get-site-option :arpa-gateways)))
	       (*catch 'open
		 (do-forever
		   (setq fndname (car rmname))
		   (setq tcp-stream (catch-error
				      (chaos:connect
					      fndname
					      (format nil "TCP ~A"
						      (string-subst-char
							#/space #\#
							(cadr (cadr current-job))))) nil))
		   (if tcp-stream (*throw 'open nil))
		   (setq rmname (cdr rmname))
		   (process-sleep 600. "No Printers Available")))
	       (setq tcp-stream (chaos:make-stream tcp-stream)))
	      (t (*throw 'no-printer t)))
	    (tv:background-notify "Now Printing ~A on ~A" (car current-job)
				  (second (second current-job)))
	    (cond
	      ((equal (car current-job) :FILE)
	       (apply self :print-file (cddr current-job)))
	      ((equal (car current-job) :STREAM)
	       (apply self :print-stream (cddr current-job)))
	      ((equal (car current-job) :ARRAY)
	       (apply self :print-bit-array (cddr (butlast current-job)))
	       (if (not (last current-job))
		   (deallocate-resource 'tv:hardcopy-bit-array-resource (caddr current-job))))))
	(if tcp-stream
	    (close tcp-stream))
	(setq tcp-stream nil))
      (setq current-job nil))))

(defun print-laser2-queue (&optional (stream terminal-io) (count 1))
  (dolist (item (reverse (send *laser2-stream* :printer-queue)))
    (selectq (car item)
      (:FILE
       (format stream "~%Item ~D: File ~A" count (cadr item)))
      (:STREAM
       (format stream "~%Item ~D: Stream ~A" count (cadr item)))
      (:DPRINT
       (format stream "~%Item ~D: Raw Laser2 File ~A" count (cadr item)))
      (:ARRAY
       (format stream "~%Item ~D: A bit array" count)))
    (incf count)))

(defun remove-queue-item (n &aux queue)
  (setq queue (send *laser2-stream* :printer-queue))
  (setq n (- (length queue) n))
  (if (or (minusp n) ( n (length queue))) ()
    (if (= n 0)
	(send *laser2-stream* :set-printer-queue (cdr queue))
      (rplacd (nthcdr (1- n) queue)
	      (nthcdr (1+ n) queue))))
  (print-laser2-queue))

;1;; Get things running.*

(defun laser2-start-processes ()
  (start-laser2-processes-if-needed))