;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.176
;;; Reason:
;;;  Telnet and Supdup Servers now use standard tv:io-buffer functions.
;;;  Thus, the debugger, which has its own buffer-output-function which
;;;  doesn't treat Abort as an interrupt character, works as on the console.
;;; Written 5-Jan-88 14:51:51 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.175, 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.SERVER; TERMCAP.LISP#91 at 5-Jan-88 14:52:02
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defmethod (simple-ascii-stream-terminal :after :init) (&rest ignored)
  (or termcap (send self :termcap term))
  (setq tv:superior nil)			;We are a screen
  (setq tv:line-height 1)
  (setq tv:char-width 1)
  (setq tv:width (termcap.number-of-columns termcap))
  (setq tv:height (termcap.number-of-lines termcap))
  (setf (tv:sheet-output-hold-flag self) 0)
  (send self :set-more-p t))

))

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

(defun make-io-buffer-stream (buffer &aux stream)
  (declare (values stream buffer))
  (setq stream #'(lambda (op &optional arg1 &rest args)
		   (si:selectq-with-which-operations op
		     (:tyi
		       (tv:io-buffer-get buffer))
		     (:tyo
		       (apply 'tv:io-buffer-put buffer arg1 args))
		     (:listen
		       (not (tv:io-buffer-empty-p buffer)))
		     (:clear-input
		       (tv:io-buffer-clear buffer))
		     (:buffer-full-p
		       (tv:io-buffer-full-p buffer))
		     (t
		       ;; no other operations are expected but might as well
		       ;; allow for them.
		       (global:stream-default-handler stream op arg1 args)))))
  (values stream buffer))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#111 at 5-Jan-88 15:18:08
#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*)))
	(let ((buffer-stream (make-io-buffer-stream (global:symeval-in-instance terminal 'tv:io-buffer))))
	  (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-stream
				 remote-stream
				 terminal)))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#111 at 5-Jan-88 15:18:21
#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-stream remote-stream terminal)
  (declare (ignore terminal))
  (do (c bits code)
      ((null (setq c (send remote-stream :tyi))))
    (when (= c #o34)
      (setq bits (send remote-stream :tyi))
      (cond ((null bits)
	     (setq c nil))
	    ((= bits #o34))
	    (t
	     (setq bits (logand bits #o37))
	     (setq code (send remote-stream :tyi))
	     (cond ((null code)
		    (setq c 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
       (send buffer-stream :tyo (char-int c))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#91 at 5-Jan-88 15:19:15
#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)
  (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))
	     (return (send self :subtyi)))
	    (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#111 at 5-Jan-88 15:20:09
#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*)))
	(let ((buffer-stream (make-io-buffer-stream (global:symeval-in-instance terminal 'tv:io-buffer))))
	  (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-stream
				 remote-stream
				 terminal)))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#111 at 5-Jan-88 15:29:36
#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-stream 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
		    (send buffer-stream :tyo c)
		    (send buffer-stream :tyo c1)))))
	  ((and extended (= c #o34))
	   (let ((bits (send remote-stream :tyi)))
	     (cond ((= bits #o034)
		    (send buffer-stream :tyo 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
		       (send buffer-stream :tyo (char-int 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)))))
	  ((send buffer-stream :buffer-full-p)
	   ;; 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
	     (send buffer-stream :tyo *telnet-ascii-quote-character*)
	     (setq quote nil))
	   (send buffer-stream :tyo c)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#91 at 5-Jan-88 15:29:46
#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))
		     (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)))))))))

))