;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.161
;;; Reason:
;;;  Server Telnet now does option negotiation per spec: all options assumed initially
;;;  OFF, if command received to change to a state we are already in, no response is
;;;  sent.  Unless Go-aheads are suppressed, we now send one when enter :input-wait.
;;; Written 17-Dec-87 11:46:52 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.160, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.2, 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#75 at 17-Dec-87 11:47:29
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defmethod (telnet-server :send-initial-telnet-frobs) ()
  (send-option 'will 'telopt_echo)
  (send-option 'will 'telopt_sga)
  (send-option 'do 'telopt_sga))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 11:47:31
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defun send-option (command option)
  (declare (:self-flavor telnet-server))
  (let ((item (find-option telnet-options-sent option (case command
							((do dont) '(do dont))
							((will wont) '(will wont))))))
    (cond ((null item)
	   (unless (member command '(dont wont))
	     (push (cons option command) telnet-options-sent)
	     (send-iac command option)))
	  ((eq (cdr item) command))
	  (t
	   (setf (cdr item) command)
	   (send-iac command option)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 11:47:32
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defun receive-option (command option)
  (declare (:self-flavor telnet-server))
  (let ((item (find-option telnet-options-received option (case command
							     ((do dont) '(do dont))
							     ((will wont) '(will wont))))))
    (unless (eq (cdr item) command)
      (if (null item)
	  (push (cons option command) telnet-options-received)
	(setf (cdr item) command))
      (case command
	(do
	 (send-option 'will option))
	(dont
	 (send-option 'wont option))
	(will
	 (send-option 'do option))
	(wont
	 (send-option 'dont option))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 11:47:34
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defun find-option (list option commands)
  (loop
    (setq list (member option list :key #'car :test #'eq))
    (cond ((null list)
	   (return nil))
	  ((member (cdar list) commands)
	   (return (car list)))
	  (t
	   (setq list (cdr list))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 11:47:35
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defun send-iac (&rest commands)
  (declare (:self-flavor telnet-server))
  (send output :tyo (get 'iac 'telnet-sym))
  (dolist (char commands)
    (send output :tyo (cond ((not (symbolp char)) char)
			    ((string-equal char "TELOPT_" :end1 7)
			     (get char 'telnet-opt))
			    ('else
			     (get char 'telnet-sym)))))
  (send output :force-output))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 11:47:41
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defmethod (telnet-server :subtyi) ()
  (if need-force-output (send self :force-output))
  (flet ((getc (tcp stream)
	   (unless (send tcp :listen)
	     (send stream :notice :input-wait))
	   (send tcp :tyi)))
    (do ((c) (quote))
	((not (setq c (or untyi-char (getc input self))))
	 nil)
      (cond (untyi-char
	     (return (prog1 untyi-char (setq untyi-char nil))))
	    ((= c (get 'iac 'telnet-sym))
	     (multiple-value-bind (return value)
		 (receive-iac)
	       (when return
		 (return value))))
	    ((and (not quote) (= c *telnet-ascii-quote-character*))
	     (setq quote t))
	    ((and (not quote) (= c (glass-tty-ascii-code #\Altmode)))
	     (setq c (send self :subtyi))
	     (return (set-char-bit (make-char (if (plusp (char-bits c)) c (global:char-flipcase (char-code c)))
					      (char-bits c))
				   :meta t)))
	    ((and (not quote) (= c (glass-tty-ascii-code #\Control-\\)))
	     (setq c (send self :subtyi))
	     (return (set-char-bit (make-char (if (plusp (char-bits c)) c (global:char-flipcase (char-code c)))
					      (char-bits c))
				   :super t)))
	    ((= (setq c (translate-char c)) #\Return)
	     (setq flush-next-lf t)
	     (return #\Return))
	    ((and (= c #\Line) flush-next-lf)
	     (setq flush-next-lf nil))
	    ('else
	     (setq flush-next-lf nil)
	     (when quote
	       (setq untyi-char c)
	       (setq c *telnet-quote-character*))
	     (return c))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 11:47:44
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defun receive-iac (&aux c action option)
  (declare (:self-flavor telnet-server))
  (setq flush-next-lf nil)
  (setq c (send input :tyi))
  (case (setq action (cadr (assoc c *telsyms* :test #'eq)))
    (iac
     (values t c))
    (do
     (setq c (send input :tyi))
     (setq option (cadr (assoc c *telopts* :test #'eq)))
     (case option
       ((telopt_echo telopt_sga)
	(receive-option action option))
       (telopt_logout
	(receive-option action option)
	(return-from receive-iac (values t nil)))
       (t
	(send-option 'wont option)))
     nil)
    (dont
     (setq c (send input :tyi))
     (setq option (cadr (assoc c *telopts* :test #'eq)))
     (case option
       ((telopt_echo telopt_sga)
	(receive-option action option)))
     nil)
    (will
     (setq c (send input :tyi))
     (setq option (cadr (assoc c *telopts* :test #'eq)))
     (case option
       (telopt_sga
	(receive-option action option))
       (t
	(send-option 'dont option)))
     nil)
    (wont
     (setq c (send input :tyi))
     (setq option (cadr (assoc c *telopts* :test #'eq)))
     (case option
       (telopt_sga
	(receive-option action option)))
     nil)
    (sb
     (do ((se (get 'se 'telnet-sym)))
	 ((= (send input :tyi) se)))
     nil)
    (t
     nil)))


))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 12:02:03
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defmethod (telnet-server :notice) (event &rest args)
  (declare (ignore args))
  (case event
    ((:input :output)		;Deexposed window needs some attention
     t)
    (:input-wait		;Hanging up waiting for input.
     (setf (tv:sheet-more-flag self) 0)
     (unless (find-option telnet-options-received 'telopt_sga '(do))
       ;;Unless remote side said Do Suppress Go-aheads, send a Go-ahead
       (send-iac 'ga))
     t)
    (:error			;Error in process using this window as its *TERMINAL-IO*.
     t)
    (otherwise nil)))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#75 at 17-Dec-87 12:17:31
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defvar *telopts*
	'(
	  (  0	telopt_binary	"8-bit data path")
	  (  1	telopt_echo	"echo")
	  ( 	2	telopt_rcp	"prepare to reconnect")
	  ( 	3	telopt_sga	"suppress go ahead")
	  ( 	4	telopt_nams	"approximate message size")
	  ( 	5	telopt_status	"give status")
	  ( 	6	telopt_tm	"timing mark")
	  ( 	7	telopt_rcte	"remote controlled transmission and echo")
	  (  8 	telopt_naol	"negotiate about output line width")
	  (  9 	telopt_naop	"negotiate about output page size")
	  (  10	telopt_naocrd	"negotiate about CR disposition")
	  (  11	telopt_naohts	"negotiate about horizontal tabstops")
	  (  12	telopt_naohtd	"negotiate about horizontal tab disposition")
	  (  13	telopt_naoffd	"negotiate about formfeed disposition")
	  (  14	telopt_naovts	"negotiate about vertical tab stops")
	  (  15	telopt_naovtd	"negotiate about vertical tab disposition")
	  (  16	telopt_naolfd	"negotiate about output LF disposition")
	  (  17	telopt_xascii	"extended ascic character set")
	  (  18	telopt_logout	"force logout")
	  (  19	telopt_bm	"byte macro")
	  (  20	telopt_det	"data entry terminal")
	  (  21	telopt_supdup	"supdup protocol")
	  (  22 telopt_supdup-output "supdup output allowed")
	  (  255	telopt_exopl	"extended-options-list")))

(dolist (x *telopts*)
  (setf (get (cadr x) 'telnet-opt) (car x)))
))