;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.150
;;; Reason:
;;;  Control-V is now the quote character for all levels of input editing in Server Telnet:
;;;   - Control-V Control-B --> Control-B, not break interrupt
;;;   - Control-V Control-G --> Control-G, not abort interrupt
;;;   - Control-V Control-T --> Control-T, not status interrupt
;;;   - Control-V Altmode --> Altmode, not meta-bit on next character
;;;   - Control-V Control-\ --> Control-\, not super-bit on next character
;;;   - Control-V Rubout --> Rubout, not rubout one character
;;;   - Control-V Control-U --> Control-U, not rubout all characters
;;;   - Control-V Control-L --> Control-L, not clear screen and refresh
;;;   - Control-V Control-T --> Control-T, not fresh-line and refresh
;;;   - Control-V <anything> --> <anything>
;;; Written 7-Dec-87 16:13:30 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.148, 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; TELNET.LISP#91 at 7-Dec-87 16:13:31
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "

(defvar *telnet-ascii-quote-character* (glass-tty-ascii-code #\Control-V))
(defvar *telnet-quote-character* #\Control-V)

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#91 at 7-Dec-87 16:30:29
#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 quote)
      ((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)))))
	  ((and (not quote) (= c *telnet-ascii-quote-character*))
	   (setq quote t))
	  ((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#44 at 7-Dec-87 16:34:19
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defvar *special-ascii-lispm-translations*
	'((#o10 #\Bs)
	  (#o11 #\Tab)
	  (#o12 #\Line)
	  (#o14 #\FF)
	  (#o15 #\Return)
	  (#o33 #\Altmode)
	  (#o177 #\Rubout)))

))

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

(defun translate-char (c)
  (let ((meta-bit nil))
    (unless (zerop (logand c #o200))
      (setq meta-bit t)
      (setq c (logand c #o177)))
    (setq c (or (cadr (assoc c *special-ascii-lispm-translations* :test #'eq)) c))
    (unless (characterp c)
      (when (< c #o40)
	(setq c (set-char-bit (logior c #o100) :control t))))
    (when meta-bit
      (setq c (set-char-bit (global:char-flipcase c) :meta t)))
    (int-char c)))

))

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

  
(defflavor simple-ascii-stream-terminal
	   (original-capabilities
	    (telnet-commands-received nil)
	    (flush-next-lf nil)
	    (cursor-x 0)
	    (cursor-y 0)
	    (echo-p t)
	    input
	    output
	    (output-lock nil)
	    (need-force-output nil)
	    (status nil)
	    (buffer nil)
	    (peek-chars nil)
	    (untyi-char nil)
	    (term nil)
	    (termcap nil)
	    (more-p t))
	   (si:stream)
  :initable-instance-variables
  (:settable-instance-variables more-p echo-p flush-next-lf))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#44 at 7-Dec-87 17:13:14
#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 self :force-output))
  (do ((c) (action) (option) (quote))
      ((not (setq c (or untyi-char (send input :tyi))))
       nil)
    (cond (untyi-char
	   (return (prog1 untyi-char (setq untyi-char nil))))
	  ((= c (get 'iac 'telnet-sym))
	   (setq flush-next-lf nil)
	   (setq c (send input :tyi))
	   (case (setq action (cadr (assoc c *telsyms* :test #'eq)))
	     (nil)
	     (iac
	      (return #\Meta-Rubout))
	     (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))))
	  ((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#44 at 7-Dec-87 17:13:17
#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 :clear-input) ()
  (setq peek-chars nil)
  (setq untyi-char nil)
  (send input :clear-input))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#44 at 7-Dec-87 17:13:19
#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 :listen) ()
  (or (not (null untyi-char))
      (not (null peek-chars))
      (send input :listen)))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#44 at 7-Dec-87 17:13:24
#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 :any-tyi) (&optional ignore)
  (char-int-if-any
    (cond (peek-chars
	   (pop peek-chars))
	  ((not tv:rubout-handler)
	   (let ((c (send self :subtyi)))
	     (if (eq c *telnet-quote-character*)
		 (send self :subtyi)
	       c)))
	  ('else
	   (when (member status '(:restored :initial-entry) :test #'eq)
	     (setq status nil)
	     (send self :do-rubout-handler-prompting nil))
	   (do ((ch) (quote)
		(rubout? nil)
		(activation-handler (assoc :activation tv:rubout-handler-options :test #'eq)))
	       (nil)
	     (setq ch (send self :subtyi))
	     (cond ((null ch)
		    (return nil))
		   ((and (not quote) (eq ch *telnet-quote-character*))
		    (setq quote t))
		   ((and (not quote) (eq ch #\Rubout))
		    (when buffer
		      (let ((x (pop buffer)))
			(dotimes (i (send self :tyo-print-length x))
			  (send self :tyo #\Overstrike)
			  (send self :tyo #\Space)
			  (send self :tyo #\Overstrike)))
		      (setq rubout? t)))
		   ((and (not quote) (eq ch #\Control-U))
		    (when buffer
		      (format self "<RUBOUT-ALL>~%")
		      (send self :force-output)
		      (setq buffer nil)
		      (setq peek-chars nil)
		      (send self :do-rubout-handler-prompting t)
		      (throw 'tv:rubout-handler t)))
		   ((and (not quote) (eq ch #\Form))
		    (send self :clear-screen)
		    (send self :redisplay ch))
		   ((and (not quote) (eq ch #\Control-R))
		    (send self :fresh-line)
		    (send self :redisplay ch))
		   (t
		    (push ch buffer)
		    (cond ((and activation-handler
				(apply (cadr activation-handler) (char-int-if-any ch) (cddr activation-handler)))
			   (setq ch `(:activation ,(char-int-if-any ch) 1))
			   (setq tv:rubout-handler-activation-character ch))
			  (echo-p
			   (send self :tyo ch)))
		    (when rubout?
		      (setq peek-chars (reverse buffer))
		      (throw 'tv:rubout-handler t))
		    (setq tv:rubout-handler-activation-character nil)
		    (return ch)))
	     )))))

))