;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.162
;;; Reason:
;;;  Server Telnet now offers to do Supdup Output.  If the User Telnet accepts that,
;;;  we do it.  Our Telnet program is willing to do Supdup output -- and now talks
;;;  nicely to our Server Telnet.
;;; Written 18-Dec-87 15:39:44 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.161, 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 file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#105 at 18-Dec-87 15:40:13
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TELNET  "


(global:defresource telnet-server (&optional ascii-output-stream ascii-input-stream)
  :constructor (make-instance 'telnet-server
			      :output ascii-output-stream
			      :input ascii-input-stream)
  :matcher (progn object)
  :initializer (progn (setf (global:symeval-in-instance object 'output) ascii-output-stream)
		      (setf (global:symeval-in-instance object 'input) ascii-input-stream)
		      (setf (global:symeval-in-instance object 'output-lock) nil)
		      (send object :termcap :default))
  :deinitializer (progn (setf (global:symeval-in-instance object 'output) nil)
			(setf (global:symeval-in-instance object 'input) nil)
			(setf (global:symeval-in-instance object 'telnet-options-received) nil)
			(setf (global:symeval-in-instance object 'telnet-options-sent) nil)
			(send object :termcap :default)))

(defun telnet-server-function (remote-stream)
  (let* ((safe-input-stream (make-eof-throwing-stream remote-stream))
	 (terminal (global:allocate-resource 'telnet-server remote-stream safe-input-stream))
	 (si:user-id nil)
	 (telnet-user:*term* nil)
	 (cvars '(telnet-user:*term* si:user-id)))
    (unwind-protect
	(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)
	  (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*)))
	  (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
				   terminal))))
      (global:deallocate-resource 'telnet-server terminal))))


(defun read-command-line (stream format &rest args)
  (let ((st (read-line stream t nil nil `((:prompt ,(apply #'format nil format args))))))
    (cond ((null st) nil)
	  ((zerop (length st)) nil)
	  (t st))))

(defun read-command-line-unechoed (stream format &rest args)
  (apply #'format stream format args)
  (do ((char (send stream :tyi) (send stream :tyi))
       (line (make-string 30 :fill-pointer 0)))
      ((null char) nil)
    (cond ((= char #\Rubout)
	   (when (plusp (fill-pointer line))
	     (vector-pop line)))
	  ((= char #\Clear-Input)
	   (setf (fill-pointer line) 0))
	  ((= char #\Return)
	   (fresh-line stream)
	   (return (if (plusp (fill-pointer line)) line nil)))
	  ((/= 0 (char-bits char)) (send stream :beep))
	  (t 
	   (vector-push-extend char line)))))

(defun telnet-user-login (terminal &aux user pass)
  (do ((j 1 (1+ j)))
      (nil)
    (setq user (read-command-line terminal "Username: "))
    (setq pass (read-command-line-unechoed terminal "Password: "))
    (if (validate-network-server-password user pass si:local-host) (return nil))
    (format terminal "%ERROR: Invalid Username or Password~%")
    (when (and *telnet-user-login-punt* (>= j *telnet-user-login-punt*))
      (format terminal "Autologout after ~D tries~%" j)
      (throw 'eof nil)))
  (setq si:user-id user)
  (unless (eq (global:symeval-in-instance terminal 'term) :supdup-output)
    (loop
      (setq telnet-user:*term* (read-command-line terminal "Terminal-type: "))
      (and (null telnet-user:*term*) (return nil))
      (setq telnet-user:*term* (intern (string-upcase telnet-user:*term*) ""))
      (and (get telnet-user:*term* 'termcap)
	   (return (send terminal :termcap telnet-user:*term*)))
      (format terminal "~&Unknown terminal type: ~S (hit <RETURN> to punt)~%"
	      telnet-user:*term*))))

))

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


(defconstant %tdeof #o202 "Erase to end of screen")
(defconstant %tdeol #o203 "Erase to end of line")
(defconstant %tddlf #o204 "Clear character")
(defconstant %tdcrl #o207 "Go to next line and clear or scroll")
(defconstant %tdnop #o210 "NOP")
(defconstant %tdmv0 #o217 "Move to <y><x>")
(defconstant %tdfs  #o216 "Non-destructive forward space")
(defconstant %tdclr #o220 "Clear screen and home cursor")
(defconstant %tdilp #o223 "Insert <n> lines")
(defconstant %tddlp #o224 "Delete <n> lines")
(defconstant %tdicp #o225 "Insert <n> characters")
(defconstant %tddcp #o226 "Delete <n> characters")

(define-termcap supdup "Supdup"
  :add-blank-line '(%tdilp 1)
  :clear-to-end-of-display '(%tdeof)
  :clear-to-end-of-line '(%tdeol)
  :clear-screen '(%tdclr)
  :cursor-motion '(%tdmv0 y x)
  :delete-character '(%tddcp 1)
  :delete-line '(%tddlp 1)
  :insert-character '(%tdicp 1)
  )

(define-termcap supdup-output "Telnet Supdup Output"
  :add-blank-line '(supdup-sb 2 %tdilp 1 supdup-se)
  :clear-to-end-of-display '(supdup-sb 1 %tdeof supdup-se)
  :clear-to-end-of-line '(supdup-sb 1 %tdeol supdup-se)
  :clear-screen '(supdup-sb 1 %tdclr supdup-se)
  :cursor-motion '(supdup-sb 3 %tdmv0 y x supdup-se)
  :delete-character '(supdup-sb 2 %tddcp 1 supdup-se)
  :delete-line '(supdup-sb 2 %tddlp 1 supdup-se)
  :insert-character '(supdup-sb 2 %tdicp 1 supdup-se)
  )

(defmethod (simple-ascii-stream-terminal :termcap) (type)
  (cond ((get type 'termcap)
	 (setq term type)
	 (setq termcap (get type 'termcap))
	 (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:rhb-input-history) nil)
	 (setf (tv:rhb-typein-pointer) nil)
	 (setf (tv:rhb-scan-pointer) 0)
	 (setf (tv:rhb-fill-pointer) 0)
	 (setq tv:stream-rubout-handler
	       (if (and (termcap.cursor-motion termcap)
			(or (termcap.enter-insert-mode termcap)
			    (termcap.insert-character termcap))
			(termcap.delete-character termcap))
		   'tv:alternate-rubout-handler
		 nil)))
	('else
	 (send self :termcap :default))))

(defmethod (simple-ascii-stream-terminal :after :init) (&rest ignored)
  (or termcap (send self :termcap term))
  (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))
  (send self :set-more-p t))

(defmethod (simple-ascii-stream-terminal :set-more-p) (enable)
  (setq tv:more-vpos (and enable (- tv:height tv:line-height)))
  enable)


(defsubst pixels-to-chars (x)
  (truncate x tv:char-width))

(defsubst chars-to-pixels (x)
  (* x tv:char-width))

(defsubst pixels-to-lines (y)
  (truncate y tv:line-height))

(defsubst lines-to-pixels (y)
  (* y tv:line-height))


(defmethod (simple-ascii-stream-terminal :output-control-sequence-unlocked) (s)
  (cond ((null s))
	((symbolp s)
	 (cond ((boundp s)
		(send output :tyo (symbol-value s)))
	       ((fboundp s)
		(funcall s output))))
	((stringp s)
	 (send output :string-out s))
	((listp s)
	 (dolist (z s)
	   (send self :output-control-sequence-unlocked z)))
	((integerp s)
	 (send output :tyo s))
	('else
	 (funcall s output))))

(defmethod (simple-ascii-stream-terminal :tyo-unlocked) (c)
  (when (plusp (tv:sheet-more-flag self))
    (send self :more-exception))
  (when (= tv:cursor-y tv:height)
    (send self :home-cursor)
    (send self :clear-rest-of-line))
  (cond ((null c))
	((< c #o40))				;Ignore non-ASCII graphics
	((= c #\Return)
	 (send self :terpri))
	((= c #\Tab)
	 (send self :tab))
	((= c #\Backspace)
	 (when (plusp tv:cursor-x)
	   (send self :output-control-sequence (termcap.back-space termcap))
	   (decf tv:cursor-x tv:char-width)))
	((graphic-char-p c)
	 (cond ((= tv:cursor-x (- tv:width tv:char-width))
		(send self :end-of-line-exception c))
	       (t
		(send output :tyo c)
		(incf tv:cursor-x tv:char-width)))
	 (setq need-force-output t))
	((and (zerop (char-bits c)) (> c #\Network)))
	(t))
  (and (zerop tv:cursor-x)
       (eql tv:cursor-y tv:more-vpos)
       (setf (tv:sheet-more-flag self) 1)))

(defmethod (simple-ascii-stream-terminal :more-exception) ()
  (when (plusp (tv:sheet-more-flag self))
    (setf (tv:sheet-more-flag self) 0)
    (unwind-protect
	(progn (princ "**MORE**" output)
	       (send self :clear-rest-of-line)
	       (force-output output)
	       (send input :clear-input)
	       (send input :tyi))
      (send output :tyo (termcap.carriage-return termcap))
      (send output :tyo 0)
      (send self :clear-rest-of-line)
      (send self :home-cursor)
      (send self :clear-rest-of-line))))

(defmethod (simple-ascii-stream-terminal :end-of-line-exception) (c)
  (let ((linewrap (termcap.linewrap-indicator termcap))
	(auto (termcap.auto-new-line termcap)))
    (cond (auto
	   (cond ((= tv:cursor-y (- tv:height tv:line-height))
		  (send self :home-cursor)
		  (send self :clear-rest-of-line)
		  (send self :tyo c))
		 (linewrap
		  (send output :tyo linewrap)
		  (setq tv:cursor-x 0)
		  (incf tv:cursor-y tv:line-height)
		  (send self :clear-rest-of-line)
		  (when (eql tv:cursor-y tv:more-vpos)
		    (setf (tv:sheet-more-flag self) 1))
		  (send self :tyo c))
		 (t
		  (send output :tyo c)
		  (setq tv:cursor-x 0)
		  (incf tv:cursor-y tv:line-height)
		  (send self :clear-rest-of-line))))
	  (linewrap
	   (send output :tyo linewrap)
	   (send self :terpri)
	   (send self :tyo c))
	  (t
	   (send output :tyo c)
	   (send self :terpri)))))

(defmethod (simple-ascii-stream-terminal :tab) ()
  (let ((stops (termcap.tab-stops termcap)))
    (cond ((null stops)
	   (send self :string-out "        "))
	  ((numberp stops)
	   (dotimes (i (mod (pixels-to-chars tv:cursor-x) stops))
	     (send self :tyo #\Space)))
	  ('else
	   ;; a list of tab stops. write this some other time
	   nil
	   ))))

(defmethod (simple-ascii-stream-terminal :terpri) ()
  (with-lock (output-lock)
    (setq tv:cursor-x 0)
    (incf tv:cursor-y tv:line-height)
    (cond ((= tv:cursor-y tv:height)
	   (send self :home-cursor)
	   (send self :clear-rest-of-line))
	  (t
	   (send output :tyo (termcap.carriage-return termcap))
	   (send output :tyo (termcap.line-feed termcap))
	   (send self :clear-rest-of-line)
	   (setq need-force-output t)
	   (when (eql tv:cursor-y tv:more-vpos)
	     (setf (tv:sheet-more-flag self) 1))))))

(defmethod (simple-ascii-stream-terminal :clear-rest-of-line) (&aux clear)
  (cond ((member term '(:supdup :supdup-output))
	 (with-lock (output-lock)
	   (when (eq term :supdup-output)
	     (supdup-sb output)
	     (send output :tyo 1))
	   (send output :tyo %tdeol)
	   (when (eq term :supdup-output)
	     (supdup-se output))
	   (setq need-force-output t)))
	((setq clear (termcap.clear-to-end-of-line termcap))
	 (send self :output-control-sequence clear))
	(t
	 ;;Too bad
	 )))

(defmethod (simple-ascii-stream-terminal :clear-window) (&aux clear)
  (cond ((member term '(:supdup :supdup-output))
	 (with-lock (output-lock)
	   (when (eq term :supdup-output)
	     (supdup-sb output)
	     (send output :tyo 1))
	   (send output :tyo %tdclr)
	   (when (eq term :supdup-output)
	     (supdup-se output))
	   (setq tv:cursor-x 0)
	   (setq tv:cursor-y 0)
	   (setq need-force-output t)))
	((setq clear (termcap.clear-screen termcap))
	 (send self :output-control-sequence clear)
	 (send self :home-cursor))
	(t
	 (send self :fresh-line)))
  t)

(defmethod (simple-ascii-stream-terminal :compute-motion) (string &optional (start 0) (end (string-length string))
							   (x tv:cursor-x) (y tv:cursor-y))
  (declare (values end-x end-y))
  ;;Returns where cursor will be after buffer has been output.
  (setq x (pixels-to-chars x))
  (setq y (pixels-to-lines y))
  (do* ((end-x x)
	(end-y y)
	(stops (termcap.tab-stops termcap))
	(lines (truncate tv:height tv:line-height))
	(columns (- (truncate tv:width tv:char-width) (if (termcap.linewrap-indicator termcap) 1 0)))
	(index start (1+ index))
	c)
       ((eql index end)
	(values (chars-to-pixels end-x) (lines-to-pixels end-y)))
    (labels ((inc-y (dy)
	       (incf end-y dy)
	       (when (> end-y (- lines 2))
		 (setq end-y (mod end-y lines))))
	     (inc-x (dx)
	       (incf end-x dx)
	       (when (> end-x columns)
		 (setq end-x (mod end-x columns))
		 (inc-y 1))))
      (setq c (char string index))
      (when (null c)
	(return (values (chars-to-pixels end-x) (lines-to-pixels end-y))))
      (cond ((< c #o40))
	    ((= c #\Return)
	     (setq end-x 0)
	     (inc-y 1))
	    ((= c #\Tab)
	     (inc-x (cond ((null stops) 8)
			  ((numberp stops) (mod end-x stops))
			  (t 0))))
	    ((= c #\Backspace)
	     (inc-x -1))
	    ((graphic-char-p c)
	     (inc-x 1))
	    (t)))))

(defmethod (simple-ascii-stream-terminal :insert-string) (string &optional (start 0) end (type-too t) &aux insert count)
  (when (null end)
    (setq end (string-length string)))
  (setq count (- end start))
  (multiple-value-bind (x y)
      (send self :read-cursorpos)
    (cond ((member term '(:supdup :supdup-output))
	   (with-lock (output-lock)
	     (when (eq term :supdup-output)
	       (supdup-sb output)
	       (send output :tyo 2))
	     (send output :tyo %tdicp)
	     (send output :tyo count)
	     (when (eq term :supdup-output)
	       (supdup-se output))
	     (send self :string-out string start end)))
	  ((setq insert (termcap.enter-insert-mode termcap))
	   (send self :output-control-sequence insert)
	   (send self :string-out string start end)
	   (send self :output-control-sequence (termcap.end-insert-mode termcap)))
	  ((setq insert (termcap.insert-character termcap))
	   (dotimes (i count)
	     (send self :output-control-sequence insert))
	   (send self :set-cursorpos x y)
	   (send self :string-out string start end))
	  (t					;Sorry...
	   ))
    (unless type-too
      (send self :set-cursorpos x y))))

(defmethod (simple-ascii-stream-terminal :delete-string) (string &optional (start 0) end &aux delete count)
  (when (null end)
    (setq end (string-length string)))
  (setq count (- end start))
  (cond  ((member term '(:supdup :supdup-output))
	  (with-lock (output-lock)
	    (when (eq term :supdup-output)
	      (supdup-sb output)
	      (send output :tyo 2))
	    (send output :tyo %tddcp)
	    (send output :tyo count)
	    (when (eq term :supdup-output)
	      (supdup-se output))
	    (setq need-force-output t)))
	 ((setq delete (termcap.delete-character termcap))
	  (dotimes (i count)
	    (send self :output-control-sequence delete)))
	 ((setq delete (termcap.enter-delete-mode termcap))
	  ;;I don't known how to use this...
	  )
	 (t					;Sorry....
	  )))

(defmethod (simple-ascii-stream-terminal :read-cursorpos) (&optional (type :pixel))
  (ecase type
    (:pixel
     (values tv:cursor-x tv:cursor-y))
    (:character
     (values (pixels-to-chars tv:cursor-x) (pixels-to-lines tv:cursor-y)))))

(defmethod (simple-ascii-stream-terminal :set-cursorpos) (x y &optional (type :pixel))
  (ecase type
    (:pixel
     (let ((cursor-motion (termcap.cursor-motion termcap)))
       (cond ((member term '(:supdup :supdup-output))
	      (with-lock (output-lock)
		(when (eq term :supdup-output)
		  (supdup-sb output)
		  (send output :tyo 3))
		(send output :tyo %tdmv0)
		(send output :tyo (pixels-to-lines y))
		(send output :tyo (pixels-to-chars x))
		(when (eq term :supdup-output)
		  (supdup-se output))
		(setq tv:cursor-x x)
		(setq tv:cursor-y y)
		(setq need-force-output t)))
	     (cursor-motion			;Terminal can move cursor
	      (dolist (item cursor-motion)
		(send self :output-control-sequence (eval-cursorpos-item (pixels-to-chars x) (pixels-to-lines y) item)))
	      (setq tv:cursor-x x)
	      (setq tv:cursor-y y))
	     ((= tv:cursor-y y)			;Same line
	      (if (> x tv:cursor-x)
		  (dotimes (i (pixels-to-chars (- x tv:cursor-x)))
		    ;;***Probably destructive....
		    (send self :tyo #\Space))
		(dotimes (i (pixels-to-chars (- tv:cursor-x x)))
		  (send self :tyo #\Backspace))))
	     (t					;Different line.  Sorry....
	      ))))
    (:character
     (send self :set-cursorpos (chars-to-pixels x) (lines-to-pixels y)))))

(defmethod (simple-ascii-stream-terminal :increment-cursorpos) (dx dy &optional (type :pixel))
  (when (plusp (tv:sheet-more-flag self))
    (send self :more-exception))
  (multiple-value-bind (x y)
      (send self :read-cursorpos type)
    (send self :set-cursorpos (+ x dx) (+ y dy) type)))

(defmethod (simple-ascii-stream-terminal :clear-between-cursorposes) (x1 y1 x2 y2)
  (cond ((member term '(supdup :supdup-output))
	 (supdup-clear-between-cursorposes x1 y1 x2 y2))
	((null (termcap.cursor-motion termcap))
	 ;;No cursor motion
	 (cond ((= y1 y2)			;clear in same line
		(erase-chars (pixels-to-chars (- x2 x1))))
	       ((= y2 tv:cursor-y)		;multiple lines, but end on current line
		(erase-chars (pixels-to-chars x2)))
	       (t				;sorry... 
		)))
	((= y1 y2)				;Erase within line
	 (let ((delete (pixels-to-chars (- x2 x1))))
	   (cond ((= tv:cursor-x x1)
		  (dotimes (i delete)
		    (send self :tyo #\Space))
		  (send self :set-cursorpos x1 y1))
		 ((or (/= tv:cursor-x x2)
		      (< (+ (* 2 (termcap.cursor-motion-characters termcap)) delete)
			 (* 3 delete)))
		  (send self :set-cursorpos x1 y1)
		  (dotimes (i delete)
		    (send self :tyo #\Space))
		  (send self :set-cursorpos x1 y1))
		 (t
		  (erase-chars delete)))))
	(t
	 (let ((clear-to-bol (termcap.clear-to-beginning-of-line termcap))
	       (clear-to-eol (termcap.clear-to-end-of-line termcap)))
	   (cond (clear-to-bol
		  (send self :set-cursorpos x2 y2)
		  (send self :output-control-sequence clear-to-bol))
		 (t
		  (send self :set-cursorpos 0 y2)
		  (dotimes (i (pixels-to-chars x2))
		    (send self :tyo #\Space))))
	   (dotimes (i (- (pixels-to-lines (+ y2 (if (> y2 y1) 0 tv:height)))
			  (pixels-to-lines y1)
			  1))
	     (send self :set-cursorpos 0 (mod (+ y1 (* (1+ i) tv:line-height)) tv:height))
	     (send self :output-control-sequence clear-to-eol))
	   (send self :set-cursorpos x1 y1)
	   (send self :output-control-sequence clear-to-eol)))))

(defun supdup-clear-between-cursorposes (x1 y1 x2 y2)
  (declare (:self-flavor simple-ascii-stream-terminal))
  (with-lock (output-lock)
    (cond ((= y1 y2)				;Same line
	   (let ((delete (pixels-to-chars (- x2 x1))))
	     (when (eq term :supdup-output)
	       (supdup-sb output)
	       (send output :tyo (+ (if (= tv:cursor-x x1) 0 3)
				    (if (= delete 1) 1 4))))
	     (unless (= tv:cursor-x x1)
	       (send output :tyo %tdmv0)
	       (send output :tyo (pixels-to-lines y1))
	       (send output :tyo (pixels-to-chars x1)))
	     (cond ((= delete 1)
		    (send output :tyo %tddlf))
		   (t
		    (send output :tyo %tddcp)
		    (send output :tyo delete)
		    (send output :tyo %tdicp)
		    (send output :tyo delete)))
	     (when (eq term :supdup-output)
	       (supdup-se output))))
	  (t
	   (let ((nlines (- (pixels-to-lines (+ y2 (if (> y2 y1) 0 tv:height)))
			    (pixels-to-lines y1)
			    1)))
	     (when (eq term :supdup-output)
	       (supdup-sb output)
	       (send output :tyo (+ (if (plusp x2) 7 0)
				    (* nlines 4)
				    4)))
	     (when (plusp x2)
	       (send output :tyo %tdmv0)
	       (send output :tyo (pixels-to-lines y2))
	       (send output :tyo 0)
	       (send output :tyo %tddcp)
	       (send output :tyo (pixels-to-chars x2))
	       (send output :tyo %tdicp)
	       (send output :tyo (pixels-to-chars x2)))
	     (dotimes (i nlines)
	       (send output :tyo %tdmv0)
	       (send output :tyo (mod (+ (pixels-to-lines y1) i 1) tv:height))
	       (send output :tyo 0)
	       (send output :tyo %tdeol))
	     (send output :tyo %tdmv0)
	     (send output :tyo (pixels-to-lines y1))
	     (send output :tyo (pixels-to-chars x1))
	     (send output :tyo %tdeol)
	     (when (eq term :supdup-output)
	       (supdup-se output)))))
    (setq tv:cursor-x x1)
    (setq tv:cursor-y y1)
    (setq need-force-output t)))

(defun erase-chars (x)
  (dotimes (i x)
    (send self :tyo #\Backspace)
    (send self :tyo #\Space)
    (send self :tyo #\Backspace)))

(defun eval-cursorpos-item (x y item)
  (cond ((eq item 'x)
	 x)
	((eq item 'y)
	 y)
	((and (symbolp item) (boundp item))
	 (symbol-value item))
	((atom item)
	 item)
	('else
	 (apply (car item) (mapcar #'(lambda (z) (eval-cursorpos-item x y z)) (cdr item))))))


(dolist (x *telsyms*)
  (proclaim `(special ,(cadr x)))
  (set (cadr x) (car x))
  (setf (get (cadr x) 'telnet-sym) (car x)))

(dolist (x *telopts*)
  (proclaim `(special ,(cadr x)))
  (set (cadr x) (car x))
  (setf (get (cadr x) 'telnet-opt) (car x)))


(defmethod (telnet-server :send-initial-telnet-frobs) ()
  (send-option 'will 'telopt_supdup-output)
  (send-option 'will 'telopt_echo)
  (send-option 'will 'telopt_sga)
  (send-option 'do 'telopt_sga)
  (do (c)
      ((eq term :supdup-output)		;Quit when we've set up our termcap
       (send self :clear-window))
    (setq c (when (process-wait-with-timeout "Telnet Options"
					     60
					     #'(lambda (x)
						 (listen x))
					     input)
	      (send input :tyi)))
    (cond ((null c)				;Timeout on TCP stream
	   (return))
	  ((= c iac)				;Telnet command
	   (receive-iac)
	   (when (eq (cdr (find-option telnet-options-received 'telopt_supdup-output '(do dont))) 'dont)
	     (return)))				;He said not to do supdup-output
	  (t
	   (send self :untyi c)
	   (return)))))

(defun send-iac (&rest commands)
  (declare (:self-flavor telnet-server))
  (send output :tyo iac)
  (dolist (char commands)
    (send output :tyo (if (symbolp char)
			  (symbol-value char)
			char)))
  (send output :force-output))

(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 iac)
	     (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-\\)))
	     (cond ((eq term :supdup-output)
		    (let ((bits (send input :tyi)))
		      (when (= bits #o034)
			(return c))
		      (setq c (send input :tyi))
		      (return (make-char (global:char-flipcase c) (logand bits #o77)))))
		   (t
		    (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))))))


(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 telopt_supdup-output)
	(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 telopt_supdup-output)
	(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
     (handle-subnegotiation)
     nil)
    (t
     nil)))

(defun handle-subnegotiation ()
  (declare (:self-flavor telnet-server))
  (let* ((c (send input :tyi))
	 (option (cadr (assoc c *telopts* :test #'eq))))
    (case option
      (telopt_supdup-output
       (when (= (send input :tyi) 1)
	 (start-supdup-output))))
    ;;Here to skip to end of subnegotiation
    (do ((iac-seen nil))
	((and iac-seen (= (send input :tyi) se)))
      (setq iac-seen (= (send input :tyi) iac)))))

(defun start-supdup-output ()
  (declare (:self-flavor telnet-server))
  (let ((nwords (dpb (get-18-bits input) (byte 18. 0) -1))
	(ttyopt-left 0)
	(ttyopt-right 0)
	(ttyrol 0))
    (when (or (< nwords -16.) (> nwords 0))
      (return-from start-supdup-output nil))
    (get-18-bits input)
    (when (not (zerop nwords))
      (get-18-bits input)
      (unless (= (get-18-bits input) 7)
	(return-from start-supdup-output nil))
      (incf nwords))
    (send self :termcap :supdup-output)
    (when (not (zerop nwords))
      (setq ttyopt-left (get-18-bits input))
      (setq ttyopt-right (get-18-bits input))
      (incf nwords))
    (when (not (zerop nwords))
      (get-18-bits input)
      (setq tv:height (get-18-bits input))	;height in lines
      (setf (termcap.number-of-lines termcap) tv:height)
      (incf nwords))
    (when (not (zerop nwords))
      (get-18-bits input)
      (setq tv:width (get-18-bits input))	;width in characters
      (setf (termcap.number-of-columns termcap) tv:width)
      (incf nwords))
    (when (not (zerop nwords))
      ;;scroll glitch
      (get-18-bits input)
      (setq ttyrol (get-18-bits input))
      (incf nwords))
    (when (not (zerop nwords))
      ;;TTYSMT
      (let ((x (get-18-bits input)))
	(setq tv:line-height (ldb (byte 8 10) x))
	(setq tv:height (* tv:height tv:line-height))
	(setq tv:char-width (ldb (byte 4 6) x))
	(setq tv:width (* tv:width tv:char-width)))
      (get-18-bits input)
      (incf nwords))
    (do ()
	((zerop nwords))
      (get-18-bits input)
      (get-18-bits input)
      (incf nwords))
    ))

(defun get-18-bits (stream)
  (let* ((b2 (send stream :tyi))
	 (b1 (send stream :tyi))
	 (b0 (send stream :tyi)))
    (dpb b2
	 (byte 6 12.)
	 (dpb b1
	      (byte 6 6)
	      b0))))


(defun supdup-sb (stream)
  (send stream :tyo iac)
  (send stream :tyo sb)
  (send stream :tyo telopt_supdup-output)
  (send stream :tyo 2))

(defun supdup-se (stream)
  (declare (:self-flavor telnet-server))
  (send stream :tyo (pixels-to-chars tv:cursor-x))
  (send stream :tyo (pixels-to-lines tv:cursor-y))
  (send stream :tyo iac)
  (send stream :tyo se))


(defmethod (telnet-server :tyo-unlocked) (c)
  (when (plusp (tv:sheet-more-flag self))
    (send self :more-exception))
  (when (= tv:cursor-y tv:height)
    (send self :home-cursor)
    (send self :clear-rest-of-line))
  (cond ((null c))
	((and (plusp c) (< c #o40))
	 (send self :string-out (aref *telnet-graphic-translations* c)))
	((= c #\Return)
	 (send self :terpri))
	((= c #\Tab)
	 (send self :tab))
	((= c #\Backspace)
	 (when (plusp tv:cursor-x)
	   (send self :output-control-sequence (termcap.back-space termcap))
	   (decf tv:cursor-x tv:char-width)))
	((graphic-char-p c)
	 (cond ((= tv:cursor-x (- tv:width tv:char-width))
		(send self :end-of-line-exception c))
	       (t
		(send output :tyo c)
		(incf tv:cursor-x tv:char-width)))
	 (setq need-force-output t))
	((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)))
  (and (zerop tv:cursor-x)
       (eql tv:cursor-y tv:more-vpos)
       (setf (tv:sheet-more-flag self) 1)))

(defmethod (telnet-server :compute-motion) (string &optional (start 0) (end (string-length string))
							   (x tv:cursor-x) (y tv:cursor-y))
  (declare (values end-x end-y))
  (setq x (pixels-to-chars x))
  (setq y (pixels-to-lines y))
  ;;Returns where cursor will be after buffer has been output.
  (do* ((end-x x)
	(end-y y)
	(stops (termcap.tab-stops termcap))
	(lines (truncate tv:height tv:line-height))
	(columns (- (truncate tv:width tv:char-width) (if (termcap.linewrap-indicator termcap) 1 0)))
	(index start (1+ index))
	c)
       ((eql index end)
	(values (chars-to-pixels end-x) (lines-to-pixels end-y)))
    (labels ((inc-y (dy)
	       (incf end-y dy)
	       (when (> end-y (- lines 2))
		 (setq end-y (mod end-y lines))))
	     (inc-x (dx)
	       (incf end-x dx)
	       (when (> end-x columns)
		 (setq end-x (mod end-x columns))
		 (inc-y 1))))
      (setq c (char string index))
      (when (null c)
	(return (values (chars-to-pixels end-x) (lines-to-pixels end-y))))
      (cond ((< c #o40)
	     (inc-x (string-length (aref *telnet-graphic-translations* c))))
	    ((= c #\Return)
	     (setq end-x 0)
	     (inc-y 1))
	    ((= c #\Tab)
	     (inc-x (cond ((null stops) 8)
			  ((numberp stops) (mod end-x stops))
			  (t 0))))
	    ((= c #\Backspace)
	     (inc-x -1))
	    ((graphic-char-p c)
	     (inc-x 1))
	    ((and (zerop (char-bits c)) (> c #\Network))
	     (inc-x (cond ((< c #o10) 3)
			  ((< c #o100) 4)
			  (t 5))))
	    ('else
	     (inc-x (string-length (format nil "~:C" c))))))))

))

; From file DJ: L.NETWORK; SUPDUP.LISP#307 at 18-Dec-87 15:51:50
#8R SUPDUP#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SUPDUP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; SUPDUP  "

(DEFMETHOD (BASIC-TELNET :HANDLE-IAC) (&AUX COMMAND OPTION)
  (SETQ COMMAND (NVT-NETI))
  (AND ( COMMAND NVT-WILL) ( COMMAND NVT-DONT)
       (SETQ OPTION (NVT-NETI)))
  (when verbose-flag
    (send self :force-output)
    (format self
	    "~&Received IAC~@[ ~A~]~@[ ~A~]~%"
	    (cadr (assq command telnet:*telsyms*))
	    (and option 
		 (let ((name (cadr (assq option telnet:*telopts*))))
		   (and name (substring (symbol-name name) 7))))))
  (SELECT COMMAND
    (NVT-WILL
     (SELECT OPTION
       (NVT-SUPPRESS-GO-AHEAD)		;ignore things we requested
       (NVT-ECHO
	(telnet-echo t))
       (NVT-TRANSMIT-BINARY
	(SETQ BINARY-OUTPUT-FLAG T)
	(TELNET-SEND-OPTION NVT-DO OPTION))
       (NVT-SUPDUP-OUTPUT
	(TELNET-START-SUPDUP-OUTPUT))
       (nvt-logout
	(telnet-send-option nvt-do option))
       (OTHERWISE
	(TELNET-SEND-OPTION NVT-DONT OPTION))))
    (NVT-DO
     (select option
       ((NVT-SUPPRESS-GO-AHEAD NVT-TIMING-MARK NVT-TRANSMIT-BINARY)
	(TELNET-SEND-OPTION NVT-WILL OPTION))
       (T (TELNET-SEND-OPTION NVT-WONT OPTION))))
    (NVT-DONT
     (TELNET-SEND-OPTION NVT-WONT OPTION))
    (NVT-WONT
     (select option
       (NVT-ECHO
	(telnet-echo nil))
       (NVT-TRANSMIT-BINARY
	(SETQ BINARY-OUTPUT-FLAG NIL)
	(TELNET-SEND-OPTION NVT-DONT OPTION))))
    (NVT-SUBNEGOTIATION-BEGIN
     (TELNET-HANDLE-SUBNEGOTIATION))))

(defun telnet-echo (on-p)
  (declare (:self-flavor basic-telnet))
  (unless (eq echo-flag on-p) ;If not the right way already
    (telnet-send-option (if on-p nvt-do nvt-dont) nvt-echo)
    (setq echo-flag on-p)
    (when verbose-flag
      (send self :force-output)
      (format self "~&Setting ~:[local~;remote~] echo~%" on-p))))

(defun telnet-send-command (command)
  (declare (:self-flavor basic-telnet))
  (when verbose-flag
    (send self :force-output)
    (format self
	    "~&Sending IAC~@[ ~A~]~%"
	    (cadr (assq command telnet:*telsyms*))))
  (lock-output
    (send stream :tyo nvt-iac)
    (send stream :tyo command)
    (send stream :force-output)))

(defun telnet-send-option (command option)
  (declare (:self-flavor basic-telnet))
  (when verbose-flag
    (send self :force-output)
    (format self
	    "~&Sending IAC~@[ ~A~]~@[ ~A~]~%"
	    (cadr (assq command telnet:*telsyms*))
	    (let ((name (cadr (assq option telnet:*telopts*))))
	      (and name (substring (symbol-name name) 7)))))
  (lock-output
    (send stream :tyo nvt-iac)
    (send stream :tyo command)
    (send stream :tyo option)
    (send stream :force-output)))

(defmethod (basic-telnet :net-output-translated) (ch)
  (cond ((consp ch)
	 ;;Mouse click?
	 )
	(supdup-output-flag
	 (let ((char (char-code ch))
	       (bits (char-bits ch)))
	   (cond ((= ch #o34)
		  (send self :net-output #o34)
		  (send self :net-output ch))
		 ((not (zerop bits))
		  (cond ((and (= bits char-control-bit)	;only control bit
			      (<= #o140 char #o177))	;And upper case
			 (send self :net-output (logand char #o37)))
			(t
			 (send self :net-output #o34)
			 (send self :net-output (logior #o100 bits))
			 (send self :net-output char))))
		 (t (send self :net-output ch)))))
	(t
	 (let ((char (ldb %%kbd-char ch)))
	   (unless echo-flag
	     ;; Echo the character.
	     (if (ldb-test %%kbd-control ch)
		 (send self :tyo #/))
	     (send self :tyo char))
	   (when (> char #o200)
	     (setq char (aref telnet-keys (- char #o200))))
	   (when (plusp char)
	     (and (ldb-test %%kbd-control ch) (setq char (ldb (byte 5 0) ch)))	;controlify
	     (and (ldb-test %%kbd-super ch) (send self :net-output #o34))	;control-\
	     (and (ldb-test %%kbd-meta ch) (send self :net-output #o33))	;escape
	     (send self :net-output char))))))

(DEFMETHOD (BASIC-TELNET :WHO-LINE-DOCUMENTATION-STRING) ()
  "Click right twice for System Menu.")

))