;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.138
;;; Reason:
;;;  Telnet Server input process now catches telnet Interrupt Process command and
;;;  sends an abort to the lisp listener.  Telnet Server now does proper option
;;;  negotiation -- you can successfully toggle remote echo.
;;; Written 3-Dec-87 16:29:08 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.136, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, 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#36 at 3-Dec-87 16:29:08
#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 :subtyi) ()
  (if need-force-output (send global:self :force-output))
  (do ((c))
      ((not (setq c (send input :tyi)))
       nil)
    (setq c (or (cadr (assoc c *special-ascii-lispm-translations* :test #'eq)) c))
    (cond ((= c (get 'iac 'telnet-sym))
	   (setq flush-next-lf nil)
	   (let (action option)
	     (setq c (send input :tyi))
	     (setq action (cadr (assoc c *telsyms* :test #'eq)))
	     (case action
	       (nil)
	       (do
		(setq c (send input :tyi))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		(push (list action option) telnet-commands-received)
		(case option
		  (telopt_echo
		   (unless (send self :echo-p)
		     (send self :set-echo-p t)
		     (send-iac output 'will option)))
		  (telopt_sga)
		  (telopt_logout
		   (return nil))
		  (t
		   (send-iac output 'wont option))))
	       (dont
		(setq c (send input :tyi))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		(push (list action option) telnet-commands-received)
		(case option
		  (telopt_echo
		   (when (send self :echo-p)
		     (send self :set-echo-p nil)
		     (send-iac output 'wont option)))
		  (telopt_sga
		   (send-iac output 'wont option))))
	       (will
		(setq c (send input :tyi))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		(push (list action option) telnet-commands-received)
		(case option
		  (telopt_sga
		   (send-iac output 'do option))
		  (t
		   (send-iac output 'dont option))))
	       (wont
		(setq c (send input :tyi))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		(push (list action option) telnet-commands-received)
		(case option
		  (telopt_sga
		   (send-iac output 'dont option))))
	       (sb
		(do ()
		    ((= (send input :tyi) (get 'se 'telnet-sym))))
		(push action telnet-commands-received))
	       (t
		(push action telnet-commands-received)))))
	  ((= c #\Return)
	   (setq flush-next-lf t)
	   (return #\Return))
	  ((and (= c #\Line) flush-next-lf)
	   (setq flush-next-lf nil))
	  ((= c #\Altmode)
	   (return (set-char-bit (send global:self :subtyi) :meta t)))
	  ((= c (glass-tty-ascii-code #\Control-\\))
	   (setq c (send global:self :subtyi))
	   (return (set-char-bit (make-char (global:char-flipcase (char-code c))
					    (char-bits c))
				 :super t)))
	  ((< c #o40)
	   (setq flush-next-lf nil)
	   (return (set-char-bit (logior #o100 c) :control 1)))
	  ('else
	   (setq flush-next-lf nil)
	   (return c)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#89 at 3-Dec-87 16:41:53
#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))
	 (terminal (make-stream-terminal nil remote-stream safe-input-stream))
	 (si:user-id nil)
	 (telnet-user:*term* nil)
	 (cvars '(telnet-user:*term* si:user-id)))
    (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)
      (telnet-user-login terminal)
      (global:print-herald terminal)
      (terpri terminal)
      (send terminal :force-output)
      (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
					   (global:progw (append *telnet-user-process-bindings* si:*break-bindings*)
					     (catch 'telnet-server-logout
					       (si:lisp-top-level1 terminal))
					     (send (network-server-process *server*)
						   :interrupt #'telnet-user:logout)))
			       buffer
			       remote-stream))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#89 at 3-Dec-87 16:41:54
#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)
  (do (c int)
      ((null (setq c (send remote-stream :tyi))))
    (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 'telnet-user:abortion-interrupt))
		   (t
		    (simple-io-buffer-put buffer c)
		    (simple-io-buffer-put buffer c1)))))
	  ((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
	   (simple-io-buffer-put buffer c)))))

))