;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.160
;;; Reason:
;;;  Ta da!  Server Telnet has full support for either tv:default-rubout-handler
;;;  or (if your terminal does cursor motion and insert and delete characters)
;;;  tv:alternate-rubout-handler.  telnet:simple-ascii-stream-terminal now
;;;  is a tv:sheet, and there is a network-terminal resource, allowing them
;;;  to be reused.
;;; Written 9-Dec-87 17:26:24 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.158, 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#53 at 10-Dec-87 14:29:09
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "


(defstruct (termcap
	     (:conc-name termcap.)
	     (:print-function (lambda (termcap stream ignore)
				(sys:printing-random-object
				  (termcap stream :type :no-pointer)
				  (format stream "of ~A"
					  (termcap.name termcap))))))
  name
  nicknames
  documentation
  add-blank-line
  (back-space #o10)
  clear-to-end-of-display
  clear-to-end-of-line
  clear-to-beginning-of-line
  clear-screen
  cursor-motion
  (number-of-columns 256)
  (number-of-lines 1000000)
  (carriage-return #o15)
  change-scrolling-region
  cursor-horizontal-motion
  cursor-vertical-motion
  delete-character
  delete-line
  enter-delete-mode
  down-one-line
  end-delete-mode
  enter-insert-mode
  end-insert-mode
  (form-feed #o14)
  hardcopy-p
  home-cursor
  insert-character
  initialization-string
  cursor-right
  (line-feed #o12)
  (tab-stops 8)
  (tab #o11)
  cursor-up
  visible-bell
  (audible-bell #o7)
  (linewrap-indicator #\!)
  auto-new-line
  cursor-down
  cursor-left
  (cursor-motion-characters 0)
  )


(define-termcap default "the default terminal capabilities"
  )


(define-termcap h19 "Now manufactured by Zenith Data Systems. For Zenith-Mode functions"
  :nicknames '(h-19 z29 z-29 heath zenith)
  :add-blank-line '(*esc* "L")
  :clear-to-end-of-display '(*esc* "J")
  :clear-to-end-of-line '(*esc* "K")
  :clear-to-beginning-of-line '(*esc* "l")
  :clear-screen '(*esc* "E")
  :cursor-motion '(*esc* "Y" (+ y 32) (+ x 32))
  :cursor-motion-characters 4
  :number-of-columns 80
  :number-of-lines 24 
  :delete-character '(*esc* "N")
  :delete-line '(*esc* "M")
  :enter-insert-mode '(*esc* "@")
  :end-insert-mode '(*esc* "O")
  :home-cursor '(*esc* "H")
  :cursor-up '(*esc* "A")
  :cursor-down '(*esc* "B")
  :cursor-right '(*esc* "C")
  :cursor-left '(*esc* "D")
  :tab nil
  :auto-new-line t
  )

(define-termcap vt-100 "Another commonly used terminal"
  :nicknames '(vt100)
  :clear-to-end-of-display '(*esc* "[J")
  :clear-to-end-of-line '(*esc* "[K")
  :clear-screen '(*esc* "[;H" *esc* "[2J")
  :cursor-motion '(*esc* "[" y ";" x "H")
  :cursor-motion-characters 6
  :number-of-columns 80
  :number-of-lines 24 
  :home-cursor '(*esc* "[H")
  )

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#53 at 10-Dec-87 14:28:56
#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
	 (input
	  output
	  (output-lock nil)
	  (need-force-output nil)
	  (untyi-char nil)
	  (term nil)
	  (termcap nil))
	 (si:stream tv:stream-mixin tv:sheet tv:essential-window)
  (:default-init-plist :blinker-p nil :deexposed-typeout-action :permit)
  :initable-instance-variables)

(defmethod (simple-ascii-stream-terminal :termcap) (type)
  (cond ((get type 'termcap)
	 (setq term type)
	 (setq termcap (get type 'termcap))
	 (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))
  (send self :set-more-p t))

(defmethod (simple-ascii-stream-terminal :more-p) ()
  (not (null tv:more-vpos)))

(defmethod (simple-ascii-stream-terminal :set-more-p) (enable)
  (setq tv:more-vpos (and enable (1- (termcap.number-of-lines termcap))))
  enable)

(defmethod (simple-ascii-stream-terminal :activate) ()
  t)

(defmethod (simple-ascii-stream-terminal :deactivate) ()
  t)

(defmethod (simple-ascii-stream-terminal :expose) ()
  t)

(defmethod (simple-ascii-stream-terminal :deexpose) ()
  t)

(defmethod (simple-ascii-stream-terminal :print-self) (stream ignore ignore)
  (if *print-escape*
      (si:printing-random-object (self stream :type :no-pointer)
	(format stream "~A: ~A" tv:name term))
    (send stream :string-out (string (or (send self :name-for-selection) tv:name)))))

(defmethod (simple-ascii-stream-terminal :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)
     t)
    (:error			;Error in process using this window as its *TERMINAL-IO*.
     t)
    (otherwise nil)))

(defmethod (simple-ascii-stream-terminal :read-cursorpos) (&optional ignore)
  (values tv:cursor-x tv:cursor-y))

(defmethod (simple-ascii-stream-terminal :set-cursorpos) (x y &optional ignore)
  (Let ((cursor-motion (termcap.cursor-motion termcap)))
    (cond (cursor-motion			;Terminal can move cursor
	   (dolist (item cursor-motion)
	     (send self :output-control-sequence (eval-cursorpos-item x 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 (- x tv:cursor-x))
		 (send self :tyo #\Space))
	     (dotimes (i (- tv:cursor-x x))
	       (send self :tyo #\Backspace))))
	  (t					;Different line.  Sorry....
	   ))))

(defmethod (simple-ascii-stream-terminal :increment-cursorpos) (dx dy &optional ignore)
  (when (plusp (tv:sheet-more-flag self))
    (send self :more-exception))
  (send self :set-cursorpos (+ tv:cursor-x dx) (+ tv:cursor-y dy)))

(defmethod (simple-ascii-stream-terminal :clear-between-cursorposes) (x1 y1 x2 y2)
  (let ((clear-to-bol (termcap.clear-to-beginning-of-line termcap))
	(clear-to-eol (termcap.clear-to-end-of-line termcap))
	(number-of-lines (termcap.number-of-lines termcap)))
    (cond ((null (termcap.cursor-motion termcap))
	   ;;No cursor motion
	   (cond ((= y1 y2)			;clear in same line
		  (erase-chars (- x2 x1)))
		 ((= y2 tv:cursor-y)		;multiple lines, but end on current line
		  (erase-chars x2))
		 (t				;sorry...
		  )))
	  ((= y1 y2)				;Erase within line
	   (let ((delete (- 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
	   (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 x2)
		    (send self :tyo #\Space))))
	   (dotimes (i (- (+ y2 (if (> y2 y1) 0 number-of-lines))
			  y1
			  1))
	     (send self :set-cursorpos 0 (mod (+ y1 i 1) number-of-lines))
	     (send self :output-control-sequence clear-to-eol))
	   (send self :set-cursorpos x1 y1)
	   (send self :output-control-sequence clear-to-eol)))))

(defun erase-chars (x)
  (do ()
      ((not (plusp x)))
    (decf x)
    (send self :tyo #\Backspace)
    (send self :tyo #\Space)
    (send self :tyo #\Backspace)))

(defmethod (simple-ascii-stream-terminal :initialize-terminal) ()
  (send self :output-control-sequence (termcap.initialization-string termcap))
  (send self :clear-window))

(defmethod (simple-ascii-stream-terminal :force-output) ()
  (when output
    (with-lock (output-lock)
      (setq need-force-output nil)
      (send output :force-output))))

(defmethod (simple-ascii-stream-terminal :tyo-unlocked) (c)
  (when (plusp (tv:sheet-more-flag self))
    (send self :more-exception))
  (when (= tv:cursor-y (termcap.number-of-lines termcap))
    (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)))
	((graphic-char-p c)
	 (let ((number-columns (termcap.number-of-columns termcap)))
	   (cond ((= tv:cursor-x (1- number-columns))
		  (send self :end-of-line-exception c))
		 (t
		  (send output :tyo c)
		  (incf tv:cursor-x))))
	 (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 :tyi))
      (send output :tyo (termcap.carriage-return termcap))
      (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))
	(number-lines (termcap.number-of-lines termcap))
	(auto (termcap.auto-new-line termcap)))
    (cond (auto
	   (cond ((= tv:cursor-y (1- number-lines))
		  (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)
		  (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)
		  (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 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)
    (cond ((= tv:cursor-y (termcap.number-of-lines termcap))
	   (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) ()
  (let ((s (termcap.clear-to-end-of-line termcap)))
    (when s
      (send self :output-control-sequence s))))

(defmethod (simple-ascii-stream-terminal :beep) (&optional ignore)
  (let ((beep (termcap.audible-bell termcap)))
    (when beep
      (send self :output-control-sequence beep))))

(defmethod (simple-ascii-stream-terminal :clear-window) ()
  (let ((s (termcap.clear-screen termcap)))
    (cond ((null s)
	   (send self :fresh-line))
	  ('else
	   (send self :output-control-sequence s)
	   (setq tv:cursor-x 0)
	   (setq tv:cursor-y 0))))
  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.
  (do* ((end-x x)
	(end-y y)
	(stops (termcap.tab-stops termcap))
	(lines (termcap.number-of-lines termcap))
	(columns (- (termcap.number-of-columns termcap) (if (termcap.linewrap-indicator termcap) 1 0)))
	(index start (1+ index))
	c)
       ((eql index end)
	(values end-x 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 end-x 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)
  (when (null end)
    (setq end (string-length string)))
  (multiple-value-bind (x y)
      (send self :read-cursorpos)
    (cond ((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 (- end start))
	     (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)
  (when (null end)
    (setq end (string-length string)))
  (cond ((setq delete (termcap.delete-character termcap))
	 (dotimes (i (- end start))
	   (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 :untyi) (ch)
  (if (and (eq tv:rubout-handler self)
	   ;; RUBOUT-HANDLER added as conjunct 6/1/83
	   ;; to avoid lossage entering editor rubout handler
	   ;; by typing (= 1 2) then stray ) while inside BREAK.
	   (<= 1 (tv:rhb-scan-pointer) (tv:rhb-fill-pointer))
	   (eq ch (aref tv:rubout-handler-buffer (1- (tv:rhb-scan-pointer)))))
      (decf (tv:rhb-scan-pointer))
    (setq untyi-char ch))
  ch)

(defmethod (simple-ascii-stream-terminal :clear-input) ()
  (setf (tv:rhb-fill-pointer) 0)
  (setf (tv:rhb-scan-pointer) 0)
  (setq untyi-char nil)
  (send input :clear-input))

(defmethod (simple-ascii-stream-terminal :listen) ()
  (or (not (null untyi-char))
      (> (tv:rhb-scan-pointer) (tv:rhb-fill-pointer))
      (send input :listen)))

(defmethod (simple-ascii-stream-terminal :any-tyi) (&optional ignore &aux idx c)
  (char-int-if-any
    (cond (untyi-char
	   (prog1 untyi-char
		  (setq untyi-char nil)))
	  ((> (tv:rhb-fill-pointer) (setq idx (tv:rhb-scan-pointer)))
	   ;;untyi'd characters...
	   (incf (tv:rhb-scan-pointer))
	   (aref tv:rubout-handler-buffer idx))
	  ((not (eq tv:rubout-handler self))
	   ;;rubout handling not in effect...
	   (when need-force-output
	     (send self :force-output))
	   (unless (send input :listen)
	     (send self :notice :input-wait))
	   (setq c (send input :tyi))
	   (cond ((eq c #\Control-U)
		  #\Clear-Input)
		 ((eq c #\Control-R)
		  #\Delete)
		 (t
		  c)))
	  (t
	   ;;Rubout handler (will call us for new characters)
	   (funcall (or tv:stream-rubout-handler 'tv:default-rubout-handler))))))

(defmethod (simple-ascii-stream-terminal :fresh-line) ()
  (or (zerop tv:cursor-x)
      (send self :terpri)))

(defmethod (simple-ascii-stream-terminal :home-cursor) ()
  (let ((s (termcap.home-cursor termcap)))
    (cond ((null s)
	   (send self :set-cursorpos 0 0 :character))
	  ('else
	   (setq tv:cursor-x 0)
	   (setq tv:cursor-y 0)
	   (send self :output-control-sequence s)))))

))

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

(defvar *telnet-interrupt-characters*
	`((,(glass-tty-ascii-code #\Control-g) telnet-user:abortion-interrupt)
	  (,(glass-tty-ascii-code #\Control-t) telnet-user:status-interrupt process-status-info)
	  (,(glass-tty-ascii-code #\Control-z) telnet-user:break-interrupt)))

))

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

(defun telnet-user:help ()
  (format t "~&You are logged into a Lisp Machine Telnet Server.

Interrupt Keys:
    Control-G        Abort Interrupt
    Control-T        Status Interrupt
    Control-S        Stop Output
    Control-Q        Resume Output
    Control-Z        Break Interrupt

Prefix keys to modify characters:
    Escape <x>       Meta-<x>
    Control-\\ <x>    Super-<x>

Keys to Edit Input:
    Rubout           Delete one character
    Meta-Rubout      Delete one word
    Control-U        Delete all input
    Control-L        Clear screen and refresh input
    Control-R        Fresh Line and refresh input

Quote character:
    Control-V <x>    <x>

Useful programs in the TELNET-USER package:
    (logout)         Close the Telnet connection
    (help)           Print this message
")
  )

))

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

(defflavor telnet-server
	 ((telnet-options-received nil)
	  (telnet-options-sent nil)
	  (flush-next-lf nil))
	 (simple-ascii-stream-terminal)
  (:settable-instance-variables flush-next-lf)
  :initable-instance-variables)

(defmethod (telnet-server :send-initial-telnet-frobs) ()
  (send-iac output 'will 'telopt_echo)
  (send-iac output 'will 'telopt_sga))

(defmethod (telnet-server :subtyi) ()
  (if need-force-output (send self :force-output))
  (flet ((getc (tcp stream)
	   (unless (send tcp :listen)
	     (when stream
	       (send stream :notice :input-wait)))
	   (send tcp :tyi)))
    (do ((c) (action) (option) (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))
	     (setq flush-next-lf nil)
	     (setq c (getc input nil))
	     (case (setq action (cadr (assoc c *telsyms* :test #'eq)))
	       (nil)
	       (iac
		(return c))
	       (do
		(setq c (getc input nil))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		 (push (list action option) telnet-options-received)
		 (case option
		   (telopt_echo
		    (send-iac output 'will option))
		   (telopt_sga)
		   (telopt_logout
		    (return nil))
		   (t
		    (send-iac output 'wont option))))
	       (dont
		(setq c (getc input nil))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		(push (list action option) telnet-options-received)
		(case option
		  (telopt_echo
		   (send-iac output 'wont option))
		  (telopt_sga
		   (send-iac output 'wont option))))
	       (will
		(setq c (getc input nil))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		(push (list action option) telnet-options-received)
		(case option
		  (telopt_sga
		   (send-iac output 'do option))
		  (t
		   (send-iac output 'dont option))))
	       (wont
		(setq c (getc input nil))
		(setq option (cadr (assoc c *telopts* :test #'eq)))
		(push (list action option) telnet-options-received)
		(case option
		  (telopt_sga
		   (send-iac output 'dont option))))
	       (sb
		(do ()
		    ((= (getc input nil) (get 'se 'telnet-sym))))
		(push action telnet-options-received))
	       (t
		(push action telnet-options-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))))))

(defmethod (telnet-server :any-tyi) (&optional ignore &aux idx c quote)
  (char-int-if-any
    (loop
      (cond (untyi-char
	     (return (prog1 untyi-char
			    (setq untyi-char nil))))
	    ((> (tv:rhb-fill-pointer) (setq idx (tv:rhb-scan-pointer)))
	     (incf (tv:rhb-scan-pointer))
	     (setq c (aref tv:rubout-handler-buffer idx))
	     (cond ((and (not quote) (= c *telnet-quote-character*))
		    (setq quote t))
		   (t
		    (return c))))
	    ((not (eq tv:rubout-handler self))
	     (setq c (send self :subtyi))
	     (cond ((and (not quote) (= c *telnet-quote-character*))
		    (setq quote t))
		   (quote
		    (return c))
		   ((eq c #\Control-U)
		    (return #\Clear-Input))
		   ((eq c #\Control-R)
		    (return #\Delete))
		   (t
		    (return c))))
	    (t
	     (return (funcall (or tv:stream-rubout-handler 'tv:default-rubout-handler))))))))

(defmethod (telnet-server :tyo-unlocked) (c)
  (when (plusp (tv:sheet-more-flag self))
    (send self :more-exception))
  (when (= tv:cursor-y (termcap.number-of-lines termcap))
    (send self :home-cursor)
    (send self :clear-rest-of-line))
  (cond ((null 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)))
	((graphic-char-p c)
	 (let ((number-columns (termcap.number-of-columns termcap)))
	   (cond ((= tv:cursor-x (1- number-columns))
		  (send self :end-of-line-exception c))
		 (t
		  (send output :tyo c)
		  (incf tv:cursor-x))))
	 (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))
  ;;Returns where cursor will be after buffer has been output.
  (do* ((end-x x)
	(end-y y)
	(stops (termcap.tab-stops termcap))
	(lines (termcap.number-of-lines termcap))
	(columns (- (termcap.number-of-columns termcap) (if (termcap.linewrap-indicator termcap) 1 0)))
	(index start (1+ index))
	c)
       ((eql index end)
	(values end-x 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 end-x 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))))))))

(compile-flavor-methods telnet-server)

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#100 at 16-Dec-87 12:37:58
#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)
		      (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)))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#100 at 16-Dec-87 12:38:13
#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 (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)
  (do ()
      (nil)
    (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#60 at 10-Dec-87 19:37:25
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(global:undefmethod (simple-ascii-stream-terminal :set-cursor-x))
(global:undefmethod (simple-ascii-stream-terminal :send-initial-telnet-frobs))
(global:undefmethod (simple-ascii-stream-terminal :subtyi))
(global:undefmethod (simple-ascii-stream-terminal :clear-eol))
(global:undefmethod (simple-ascii-stream-terminal :rubout-handler))
(global:undefmethod (simple-ascii-stream-terminal :tyipeek))
(global:undefmethod (simple-ascii-stream-terminal :tab-length))
(global:undefmethod (simple-ascii-stream-terminal :tyo-print-length))

))