;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.175
;;; Reason:
;;;  Our Supdup Server and Telnet Servers now treat interrupt characters
;;;  (Abort, M-Abort, C-Abort, C-M-Abort, Break, M-Break, C-Break, C-M-Break)
;;;  the same way the keyboard process does.
;;; Written 5-Jan-88 12:17:35 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.174, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; GENERIC-SERVER.LISP#25 at 5-Jan-88 12:17:56
#10R TCP-APPLICATION#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; GENERIC-SERVER  "

(defun *subprocess (function &optional &key closure-variables restart-after-reset &allow-other-keys)
  "Does a PROCESS-RUN-FUNCTION but keeps track of the process with the NETWORK-SERVER so that
it will get killed at the right time, etc."
  (process-run-function (list :name (format nil
					    "Sub#~D: ~A"
					    (1+ (length (network-server-subprocesses *server*)))
					    (network-server-process-name *server*))
			      :restart-after-reset restart-after-reset)
			(global:closure (append closure-variables
						*subprocess-closure-variables*)
					#'tcp-generic-server-subprocess-function)
			function))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; GENERIC-SERVER.LISP#25 at 5-Jan-88 12:18:02
#10R TCP-APPLICATION#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; GENERIC-SERVER  "

(defun tcp-generic-server-subprocess-function (f)
  (unwind-protect
      (progn
	(with-network-server-lock (*server*)
	  (push sys:current-process (network-server-subprocesses *server*)))
	(global:condition-case-if (not *tcp-generic-server-toplevel-debug*) ()
	    (funcall f)
	  (tcp::tcp-error
	    (tcp-generic-server-subprocess-error))
	  (tcp::exos-error
	    (tcp-generic-server-subprocess-error))))
    (with-network-server-lock (*server*)
      (setf (network-server-subprocesses *server*)
	    (remove sys:current-process (network-server-subprocesses *server*))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET-UTILITIES.LISP#14 at 5-Jan-88 12:22:55
#10R NETWORK-USER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "NETWORK-USER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET-UTILITIES  "

(defun handle-abort (&rest ignore)
  (setq inhibit-scheduling-flag nil)		;It was T in the IO-BUFFER-OUTPUT-FUNCTION
  (send *terminal-io* :clear-rest-of-line)
  (send *terminal-io* :string-out "[Abort]")
  (signal-condition eh:abort-object))

(defun handle-abort-all (&rest ignore)
  (setq inhibit-scheduling-flag nil)		;It was T in the IO-BUFFER-OUTPUT-FUNCTION
  (send *terminal-io* :clear-rest-of-line)
  (send *terminal-io* :string-out "[Abort all]")
  (send current-process :reset :always))

(defun handle-break (&optional char &rest ignore)
  (setq inhibit-scheduling-flag nil)		;It was T in the IO-BUFFER-OUTPUT-FUNCTION
  (break "BREAK")
  (values char t))

(defun handle-error-break (&optional char &rest ignore)
  (declare (dbg:error-reporter))
  (setq inhibit-scheduling-flag nil)		;It was T in the IO-BUFFER-OUTPUT-FUNCTION
  (multiple-value-bind (buffer position)
      (send *standard-input* :send-if-handles :save-rubout-handler-buffer)
    (unwind-protect
	(signal-condition
	  (make-condition 'break :format-string "Keyboard break.")
	  '(:no-action) t)
      (if buffer (send *standard-input* :restore-rubout-handler-buffer buffer position))))
  (values char t))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#110 at 5-Jan-88 12:23:14
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defun supdup-server-function (remote-stream)
  (let* ((safe-input-stream (make-eof-throwing-stream remote-stream))
	 (si:user-id nil)
	 (network-user:*term* nil)
	 (cvars '(network-user:*term* si:user-id)))
    (global:using-resource (terminal supdup-server remote-stream safe-input-stream)
      (catch 'eof
	(send terminal :supdup-greeting "Welcome to ~A SUPDUP Server." (send si:local-host :name))
	(send terminal :initialize-terminal)
	(network-user-login terminal)
	(send terminal :terpri)
	(global:print-herald terminal)
	(format terminal "~%Type (help) for keyboard help~%~%")
	(send terminal :force-output)
	(subprocess :closure-variables cvars
		    (loop
		      (send terminal :force-output)
		      (sys:process-sleep *telnet-asynchronous-force-output-period*)))
	(multiple-value-bind (buffer-stream buffer)
	    (make-simple-io-buffer-stream)
	  (send terminal :set-input-stream buffer-stream)
	  (send terminal :set-more-p t)
	  (send sys:current-process :set-priority 1)
	  (catch 'telnet-server-logout
	    (supdup-server-input (subprocess :closure-variables cvars
					     :restart-after-reset t
					     (global:progw (append *network-user-process-bindings* si:*break-bindings*)
					       (catch 'telnet-server-logout
						 (si:lisp-top-level1 terminal))
					       (send (network-server-process *server*)
						     :interrupt #'network-user:logout)))
				 buffer
				 remote-stream
				 terminal)))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#110 at 5-Jan-88 12:23:22
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defun supdup-server-input (user-process buffer remote-stream terminal)
  (declare (ignore terminal))
  (do (c bits code)
      ((null (setq c (send remote-stream :tyi))))
    (cond ((= c #o34)
	   (setq bits (send remote-stream :tyi))
	   (cond ((null bits)
		  (simple-io-buffer-put buffer nil))
		 ((= bits #o34)
		  (simple-io-buffer-put buffer c))
		 (t
		  (setq bits (logand bits #o37))
		  (setq code (send remote-stream :tyi))
		  (cond ((null code)
			 (simple-io-buffer-put buffer nil))
			(t
			 (setq c (dpb (logand bits #o20) (byte 5 7) (logand #o177 code)))
			 (setq c (make-char (cond ((cadr (assoc c *ascii-supdup-translations* :test #'eq)))
						  ((= bits #o20) code)
						  (t (global:char-flipcase code)))
					    (logand bits #o17)))
			 (case c
			   (#\Control-Abort
			    (send user-process :interrupt 'network-user:handle-abort))
			   (#\Control-Meta-Abort
			    (send user-process :interrupt 'network-user:handle-abort-all))
			   (#\Control-Break
			    (send user-process :interrupt 'network-user:handle-break))
			   (#\Control-Meta-Break
			    (send user-process :interrupt 'network-user:handle-error-break))
			   (otherwise
			    (simple-io-buffer-put buffer c))))))))
	  (t
	   (simple-io-buffer-put buffer c)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#90 at 5-Jan-88 12:28:32
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defmethod (supdup-server :any-tyi) (&optional ignore &aux idx c)
  (char-int-if-any
    (loop
      (cond ((> (tv:rhb-fill-pointer) (setq idx (tv:rhb-scan-pointer)))
	     ;;untyi'd characters...
	     (incf (tv:rhb-scan-pointer))
	     (return (aref tv:rubout-handler-buffer idx)))
	    ((not (eq tv:rubout-handler self))
	     ;;rubout handling not in effect...
	     (when need-force-output
	       (send self :force-output))
	     (unless (or untyi-char (send input :listen))
	       (send self :notice :input-wait))
	     (case (setq c (send self :subtyi))
	       ((#\Abort #.(char-int #\Abort))
		(network-user:handle-abort))
	       ((#\Meta-Abort #.(char-int #\Meta-Abort))
		(network-user:handle-abort-all))
	       ((#\Break #.(char-int #\Break))
		(network-user:handle-break))
	       ((#\Meta-Break #.(char-int #\Meta-Break))
		(network-user:handle-error-break))
	       (otherwise
		(return c))))
	    (t
	     ;;Rubout handler (will call us for new characters)
	     (return (funcall (or tv:stream-rubout-handler 'tv:default-rubout-handler))))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#110 at 5-Jan-88 12:29:22
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defvar *telnet-interrupt-characters*
	`((,(glass-tty-ascii-code #\Control-g) network-user:handle-abort)
	  (,(glass-tty-ascii-code #\Control-t) network-user:status-interrupt process-status-info)
	  (,(glass-tty-ascii-code #\Control-z) network-user:handle-error-break)))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#110 at 5-Jan-88 12:30:02
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defun telnet-server-function (remote-stream)
  (let* ((safe-input-stream (make-eof-throwing-stream remote-stream))
	 (si:user-id nil)
	 (network-user:*term* nil)
	 (cvars '(network-user:*term* si:user-id)))
    (global:using-resource (terminal telnet-server remote-stream safe-input-stream)
      (catch 'eof
	(send terminal :send-if-handles :send-initial-telnet-frobs)
	(format terminal "~%Welcome to ~A Server Telnet.~%" (send si:local-host :name))
	(send terminal :force-output)
	(network-user-login terminal)
	(send terminal :initialize-terminal)
	(global:print-herald terminal)
	(format terminal "~%Type (help) for keyboard help~%~%")
	(send terminal :force-output)
	(subprocess :closure-variables cvars
		    (loop
		      (send terminal :force-output)
		      (sys:process-sleep *telnet-asynchronous-force-output-period*)))
	(multiple-value-bind (buffer-stream buffer)
	    (make-simple-io-buffer-stream)
	  (send terminal :set-input-stream buffer-stream)
	  (send terminal :set-more-p t)
	  (send sys:current-process :set-priority 1)
	  (catch 'telnet-server-logout
	    (telnet-server-input (subprocess :closure-variables cvars
					     :restart-after-reset t
					     (global:progw (append *network-user-process-bindings* si:*break-bindings*)
					       (catch 'telnet-server-logout
						 (si:lisp-top-level1 terminal))
					       (send (network-server-process *server*)
						     :interrupt #'network-user:logout)))
				 buffer
				 remote-stream
				 terminal)))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#110 at 5-Jan-88 12:31:11
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defun telnet-server-input (user-process buffer remote-stream terminal)
  (do (c int quote extended)
      ((null (setq c (send remote-stream :tyi))))
    (setq extended (termcap.extended-keyboard (global:symeval-in-instance terminal 'termcap)))
    (cond ((= c (get 'iac 'telnet-sym))
	   (let* ((c1 (send remote-stream :tyi))
		  (action (cadr (assoc c1 *telsyms* :test #'eq))))
	     (cond ((eq action 'ip)
		    (send user-process :interrupt 'network-user:handle-abort-all))
		   (t
		    (simple-io-buffer-put buffer c)
		    (simple-io-buffer-put buffer c1)))))
	  ((and extended (= c #o34))
	   (let ((bits (send remote-stream :tyi)))
	     (cond ((= bits #o034)
		    (simple-io-buffer-put buffer c))
		   (t
		    (setq c (make-char (global:char-flipcase (send remote-stream :tyi))
				       (logand bits #o77)))
		    (case c
		      (#\Control-Abort
		       (send user-process :interrupt 'network-user:handle-abort))
		      (#\Control-Meta-Abort
		       (send user-process :interrupt 'network-user:handle-abort-all))
		      (#\Control-Break
		       (send user-process :interrupt 'network-user:handle-break))
		      (#\Control-Meta-Break
		       (send user-process :interrupt 'network-user:handle-error-break))
		      (otherwise
		       (simple-io-buffer-put buffer c)))))))
	  ((and (not quote) (= c *telnet-ascii-quote-character*))
	   (setq quote t))
	  ((and (not quote) (= c *telnet-ascii-stop-output-character*))
	   (unless (eq (global:symeval-in-instance terminal 'output-lock) global:current-process)
	     (global:process-lock (locf (global:symeval-in-instance terminal 'output-lock)))))
	  ((and (not quote) (= c *telnet-ascii-resume-output-character*))
	   (when (eq (global:symeval-in-instance terminal 'output-lock) global:current-process)
	     (global:process-unlock (locf (global:symeval-in-instance terminal 'output-lock)))))
	  ((and (not quote) (setq int (assoc c *telnet-interrupt-characters* :test #'eq)))
	   (cond ((third int)
		  (send user-process :interrupt 
			(second int)
			(funcall (third int) user-process)))
		 (t
		  (send user-process :interrupt (second int)))))
	  ((simple-io-buffer-full-p buffer)
	   ;; GOOD QUESTION. LETS JUST THROW AWAY CHARACTERS, OTHERWISE
	   ;; WE WILL MISS ANY #\CONTROL-G'S COMING DOWN.
	   (send remote-stream :tyo (glass-tty-ascii-code #\Control-g)))
	  (t
	   (when quote
	     (simple-io-buffer-put buffer *telnet-ascii-quote-character*)
	     (setq quote nil))
	   (simple-io-buffer-put buffer c)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#90 at 5-Jan-88 12:34:54
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defmethod (telnet-server :any-tyi) (&optional ignore)
  (let ((extended (termcap.extended-keyboard termcap))
	idx c quote)
    (char-int-if-any
      (loop
	(cond ((> (tv:rhb-fill-pointer) (setq idx (tv:rhb-scan-pointer)))
	       (incf (tv:rhb-scan-pointer))
	       (setq c (aref tv:rubout-handler-buffer idx))
	       (cond ((and (not quote) (= c *telnet-quote-character*))
		      (setq quote t))
		     (extended
		      (return c))
		     (t
		      (return c))))
	      ((not (eq tv:rubout-handler self))
	       (setq c (send self :subtyi))
	       (cond ((null c)
		      (return nil))
		     ((and (not quote) (= c *telnet-quote-character*))
		      (setq quote t))
		     ((eq c #\Abort)
		      (network-user:handle-abort))
		     ((eq c #\Meta-Abort)
		      (network-user:handle-abort-all))
		     ((eq c #\Break)
		      (network-user:handle-break))
		     ((eq c #\Meta-Break)
		      (network-user:handle-error-break))
		     (extended
		      (return c))
		     (quote
		      (return c))
		     ((eq c #\Control-U)
		      (return #\Clear-Input))
		     ((eq c #\Control-R)
		      (return #\Delete))
		     (t
		      (return c))))
	      (t
	       (return (funcall (or tv:stream-rubout-handler 'tv:default-rubout-handler)))))))))

))