;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.147
;;; Reason:
;;;  Much enhanced rubout handler for Server Telnet: Rubout erases one character,
;;;  Control-U erases all, Control-R Redisplays current input, Control-L clears
;;;  screen and redisplays current input.
;;; Written 7-Dec-87 13:54:50 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.144, 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#43 at 7-Dec-87 13:55:09
#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)
	    (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#43 at 7-Dec-87 13:55:31
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defvar *telnet-graphic-translations* #("." "v" "a" "b" "^" "~" "e" "p"
					"l" "g" "d" "^" "+-" "+" "infty" "d"
					"<" ">" "^" "v" "A" "E" "x" "<->"
					"<-" "->" "//=" "$" "<=" "=>" "=" "v")
  "Array of ASCII translations for Lisp Machine characters")

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 13:55:36
#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 :tyo-print-length) (c)
  (cond ((< c #o40)
	 (string-length (aref *telnet-graphic-translations* c)))
	((= c #\Return)
	 0)
	((= c #\Tab)
	 (send self :tab-length))
	((= c #\Overstrike)
	 -1)
	((graphic-char-p c)
	 1)
	((and (zerop (char-bits c)) (> c #\Network))
	 (cond ((< c #o10) 3)
	       ((< c #o100) 4)
	       (t 5)))
	('else
	 (string-length (format nil "~:C" c)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 13:56: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))
    (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#43 at 7-Dec-87 13:56:39
#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 :untyi) (c)
  (push c peek-chars))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 13:57:09
#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)
  (send input :clear-input))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 13:57:11
#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 :tyipeek) ()
  (when (null peek-chars)
    (push (send self :tyi) peek-chars))
  (car peek-chars))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 13:57:12
#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 peek-chars))
      (send input :listen)))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 13:57:38
#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 :rubout-handler) (options function &rest args)
  (declare (arglist rubout-handler-options function &rest args))
  (if (and (eq global:rubout-handler self) (not (cdr (assoc :nonrecursive options :test #'eq))))
      (let ((tv:rubout-handler-options (append options tv:rubout-handler-options)))
	(apply function args))
    (let ((tv:rubout-handler-options options))
      (setq buffer nil status :initial-entry)
      (catch 'return-from-rubout-handler
	(let (tv:prompt-starting-x tv:prompt-starting-y
	      tv:rubout-handler-starting-x tv:rubout-handler-starting-y
	      (tv:rubout-handler self)
	      (tv:rubout-handler-inside self)
	      (tv:rubout-handler-re-echo-flag nil)
	      (tv:rubout-handler-activation-character nil))
	  (setq tv:prompt-starting-x cursor-x
		tv:prompt-starting-y cursor-y)
	  (setq tv:rubout-handler-starting-x tv:prompt-starting-x
		tv:rubout-handler-starting-y tv:prompt-starting-y)
	  (loop
	    (setq tv:rubout-handler-re-echo-flag nil)
	    (catch 'tv:rubout-handler			;throw here when rubbing out
	      (global:condition-case (error)
		  (return
		    (multiple-value-prog1 (apply function args)
					  (send self :force-output)))
		(sys:parse-error
		  (send self :fresh-line)
		  (princ ">>error: " self)
		  (send error :report self)
		  (send self :fresh-line)
		  (setq tv:rubout-handler-re-echo-flag t)
		  (loop (send self :tyi)))))			;if error, force user to rub out
	    ;;maybe return when user rubs all the way back
	    (and (null peek-chars)
		 (let ((full-rubout-option (assoc :full-rubout tv:rubout-handler-options :test #'eq)))
		   (when full-rubout-option
		     ;; Get rid of the prompt, if any.
		     (send self :fresh-line)
		     (return (values nil (cadr full-rubout-option))))))))))))


))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 13:57:50
#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 :do-rubout-handler-prompting) (&optional reprompt? char)
  (let ((prompt-option (or (and reprompt?
				(assoc :reprompt tv:rubout-handler-options :test #'eq))
			   (assoc :prompt tv:rubout-handler-options :test #'eq))))
    (when prompt-option
      (tv:rubout-handler-prompt (cadr prompt-option) self char)))
  (setq tv:rubout-handler-starting-x cursor-x tv:rubout-handler-starting-y cursor-y))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 14:00: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 :tyo-unlocked) (c)
  (incf cursor-x (send self :tyo-print-length c))
  (cond ((< c #o40)
	 (send self :string-out
	       (aref *telnet-graphic-translations* c)))
	((= c #\Return)
	 (send self :terpri))
	((= c #\Tab)
	 (send self :tab))
	((= c #\Overstrike)
	 (send self :output-control-sequence (termcap.back-space termcap)))
	((graphic-char-p c)
	 (cond
	   ;;((= CURSOR-X (- (TERMCAP.NUMBER-OF-COLUMNS TERMCAP) 1))
	   ;;(SEND OUTPUT :TYO (termcap.linewrap-indicator termcap))
	   ;;(SEND SELF :TERPRI)
	   ;;(SEND SELF :TYO C))
	   ('else
	    (setq need-force-output t)
	    (send output :tyo c))))
	((and (zerop (char-bits c)) (> c #\Network))
	 ;; otherwise there will be a recursive call to this :TYO from FORMAT below.
	 (format self "<~O>" c))
	('else
	 (format self "~:C" c))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 14:01:36
#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 :tab) ()
  (let ((stops (termcap.tab-stops termcap)))
    (cond ((null stops)
	   (send self :string-out "        "))
	  ((numberp stops)
	   (setq need-force-output t)
	   (incf cursor-x (- stops (mod cursor-x stops)))
	   (send output :tyo (termcap.tab termcap)))
	  ('else
	   ;; a list of tab stops. write this some other time
	   nil
	   ))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 14:05:49
#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 :tab-length) ()
  ;;***hmm.
  8)

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 14:06:11
#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)
	   (send self :subtyi))
	  ('else
	   (when (member status '(:restored :initial-entry) :test #'eq)
	     (setq status nil)
	     (send self :do-rubout-handler-prompting nil))
	   (do ((ch)
		(rubout? nil)
		(activation-handler (assoc :activation tv:rubout-handler-options :test #'eq)))
	       (nil)
	     (setq ch (send self :subtyi))
	     (case ch
	       (nil (return nil))
	       (#\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)))
	       (#\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)))
	       (#\Form
		(send self :clear-screen)
		(send self :redisplay 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)))
	     )))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#43 at 7-Dec-87 14:20:16
#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 :redisplay) (ch)
  (send self :do-rubout-handler-prompting t ch)
  (when echo-p
    (dolist (c (reverse buffer))
      (send self :tyo c))))

))