;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.167
;;; Reason:
;;;  Various fixes to SUPDUP and Telnet servers:
;;;    - SUPDUP passes Abort, Resume, Status keys
;;;    - There is a network-user: package instead of a telnet-user: package
;;;    - Servers now deal with Control-Abort, Control-Break, Abort, and Break
;;;      similarly to keyboard process
;;;    - :string-length method required for :insert-string and :delete-string
;;; Written 22-Dec-87 10:26:58 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.166, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.3, 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; SUPDUP.LISP#310 at 22-Dec-87 10:29:52
#8R SUPDUP#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SUPDUP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; SUPDUP  "

(FILLARRAY SUPDUP-KEYS '(4177			;integral
			 0    4102 4103 32	;null, break, clear, call
			 4101 37   4110 177	;esc, backnext, help, rubout
			 10   11   12   13	;bs, tab, lf, vt
			 14   15   4102 4113	;form, cr, quote, hold-output
			 37   4111 4112 4115	;stop-output, abort, resume, status
			 4114 0    0    0    0	;end, I, II, III, IV
			 0    0    0    0    0	;up, down, left, right, system, network
			 4102))			;system

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#87 at 22-Dec-87 10:30:06
#10R TELNET#: #!:CL
(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 &aux idx c)
  (char-int-if-any
    (cond ((> (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 (or untyi-char (send input :listen))
	     (send self :notice :input-wait))
	   (setq c (if untyi-char
		       (prog1 untyi-char (setq untyi-char nil))
		     (send input :tyi)))
	   (cond ((null c) nil)
		 ((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))))))

(defvar *ascii-supdup-translations*
	'((#o00 #\Null)
	  (#o10 #\Backspace)
	  (#o11 #\Tab)
	  (#o12 #\Line)
	  (#o14 #\FF)
	  (#o15 #\Return)
	  (#o32 #\Call)
	  (#o33 #\Altmode)
	  (#o177 #\Rubout)
	  (#o4101 #\Escape)
	  (#o4102 #\Break)
	  (#o4103 #\Clear-Input)
	  (#o4110 #\Help)
	  (#o4111 #\Abort)			;Non-standard
	  (#o4112 #\Resume)
	  (#o4113 #\Hold-Output)
	  (#o4114 #\End)
	  (#o4115 #\Status)
	  (#o4177 #\Integral)))

))

; From modified file DJ: L.NETWORK; PACKAGES.LISP#26 at 22-Dec-87 10:38:18
#10R USER#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "USER")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; PACKAGES  "

(defpackage network-user
  ;;Like USER, but has a few functions shadowed...
  (:shadow "LOGOUT" "ED" "FED" "INSPECT" "KERMIT" "PEEK" "SUPDUP" "TELNET" "ZMAIL")
  (:use "GLOBAL"))

))

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

(defun 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

Quote character:
    Control-V <x>    <x>
")
  (cond ((eq 'tv:alternate-rubout-handler (global:symeval-in-instance *terminal-io* 'tv:stream-rubout-handler))
	 (format t "
Your terminal is smart enough to use the full Lisp Machine Rubout handler
for editing input.
"))
	(t
	 (format t "
Your terminal is smart enough only to provide minimal rubout handling.

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
")))
  (cond ((telnet:termcap.extended-keyboard (global:symeval-in-instance *terminal-io* 'telnet:termcap))
	 (format t "
Your terminal can send Control, Meta, Super, and Hyper bits with its characters.
"))
	(t
	 (format t "
Ascii Keys for the rubout handler:
    Control-U        Delete all input (Clear-Input)
    Control-L        Clear screen and refresh input (Clear-Screen)

Prefix keys to modify characters:
    Escape <x>       Meta-<x>
    Control-\\ <x>    Super-<x>
")))
  (format t "
Useful programs in the TELNET-USER package:
    (logout)         Close the Telnet connection
    (help)           Print this message
")
  )

(defun logout ()
  "Close the telnet connection"
  (throw 'telnet:telnet-server-logout nil))

(defun ed (&rest ignored)
  (no-window-calls))

(defun fed (&rest ignored)
  (no-window-calls))

(defun inspect (&rest ignored)
  (no-window-calls))

(defun kermit (&rest ignored)
  (no-window-calls))

(defun peek (&rest ignored)
  (no-window-calls))

(defun supdup (&rest ignored)
  (no-window-calls))

(defun telnet (&rest ignored)
  (no-window-calls))

(defun zmail (&rest ignored)
  (no-window-calls))

(defun no-window-calls ()
  "You can't call a function that switches windows")

(defun abortion-interrupt ()
  (global:signal-condition eh:abort-object))

(defun status-interrupt (s)
  (format *terminal-io*
	  "~&~A: ~A ~$ cpu, ~$ disk ~D faults, ~1$% ~A~%"
	  (getf s :hostname)
	  (getf s :state)
	  (getf s :cpu-time)
	  (getf s :disk-wait-time)
	  (getf s :page-faults)
	  (getf s :percent-utilization)
	  (time:print-universal-time (getf s :current-time) ()))
  (send *terminal-io* :force-output))

(defun break-interrupt ()
  (global:signal-condition (global:make-condition 'break :format-string
						  "Keyboard break.")
			   '(:no-action) t))

))

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

(defvar network-user:*term* nil "The terminal type, as a keyword, eg. :H19")

(defvar *network-user-process-bindings*
	'((*package* (find-package "NETWORK-USER"))
	  (*print-base* 10.)
	  (base 10.)
	  (*read-base* 10.)
	  (ibase 10.)
	  (*error-output* (make-synonym-stream '*terminal-io*)))
  "These are used in addition to *BREAK-BINDINGS*")

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

(defun telnet-server-function (remote-stream)
  (let* ((safe-input-stream (make-eof-throwing-stream remote-stream))
	 (si:user-id nil)
	 (network-user:*term* nil)
	 (cvars '(network-user:*term* si:user-id)))
    (global:using-resource (terminal telnet-server remote-stream safe-input-stream)
      (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)
	(network-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 *network-user-process-bindings* si:*break-bindings*)
					       (catch 'telnet-server-logout
						 (si:lisp-top-level1 terminal))
					       (send (network-server-process *server*)
						     :interrupt #'network-user:logout)))
				 buffer
				 remote-stream
				 terminal)))))))

(defun telnet-server-input (user-process buffer remote-stream terminal)
  (do (c int quote extended)
      ((null (setq c (send remote-stream :tyi))))
    (setq extended (termcap.extended-keyboard (global:symeval-in-instance terminal 'termcap)))
    (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 'network-user:abortion-interrupt))
		   (t
		    (simple-io-buffer-put buffer c)
		    (simple-io-buffer-put buffer c1)))))
	  ((and extended (= c #o34))
	   (let ((bits (send remote-stream :tyi)))
	     (cond ((= bits #o034)
		    (simple-io-buffer-put buffer c))
		   (t
		    (setq c (make-char (global:char-flipcase (send remote-stream :tyi))
				       (logand bits #o77)))
		    (case c
		      (#\Control-Abort
		       (send user-process :interrupt 'network-user:abortion-interrupt))
		      (#\Control-Break
		       (send user-process :interrupt 'network-user:break-interrupt))
		      (otherwise
		       (simple-io-buffer-put buffer c)))))))
	  ((and (not quote) (= c *telnet-ascii-quote-character*))
	   (setq quote t))
	  ((and (not quote) (= c *telnet-ascii-stop-output-character*))
	   (unless (eq (global:symeval-in-instance terminal 'output-lock) global:current-process)
	     (global:process-lock (locf (global:symeval-in-instance terminal 'output-lock)))))
	  ((and (not quote) (= c *telnet-ascii-resume-output-character*))
	   (when (eq (global:symeval-in-instance terminal 'output-lock) global:current-process)
	     (global:process-unlock (locf (global:symeval-in-instance terminal 'output-lock)))))
	  ((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)))))

(defvar *network-user-login-punt* 3)

(defun network-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 *network-user-login-punt* (>= j *network-user-login-punt*))
      (format terminal "Autologout after ~D tries~%" j)
      (throw 'eof nil)))
  (setq si:user-id user)
  (unless (member (global:symeval-in-instance terminal 'term) '(:supdup :supdup-output))
    (loop
      (setq network-user:*term* (read-command-line terminal "Terminal-type: "))
      (and (null network-user:*term*) (return nil))
      (setq network-user:*term* (intern (string-upcase network-user:*term*) ""))
      (and (get network-user:*term* 'termcap)
	   (return (send terminal :termcap network-user:*term*)))
      (format terminal "~&Unknown terminal type: ~S (hit <RETURN> to punt)~%"
	      network-user:*term*))))

(defun supdup-server-function (remote-stream)
  (let* ((safe-input-stream (make-eof-throwing-stream remote-stream))
	 (si:user-id nil)
	 (network-user:*term* nil)
	 (cvars '(network-user:*term* si:user-id)))
    (global:using-resource (terminal supdup-server remote-stream safe-input-stream)
      (catch 'eof
	(send terminal :supdup-greeting "Welcome to ~A SUPDUP Server." (send si:local-host :name))
	(send terminal :initialize-terminal)
	(network-user-login terminal)
	(send terminal :terpri)
	(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
	    (supdup-server-input (subprocess :closure-variables cvars
					     (global:progw (append *network-user-process-bindings* si:*break-bindings*)
					       (catch 'telnet-server-logout
						 (si:lisp-top-level1 terminal))
					       (send (network-server-process *server*)
						     :interrupt #'network-user:logout)))
				 buffer
				 remote-stream
				 terminal)))))))

(defun supdup-server-input (user-process buffer remote-stream terminal)
  (declare (ignore terminal))
  (do (c bits code)
      ((null (setq c (send remote-stream :tyi))))
    (cond ((= c #o34)
	   (setq bits (send remote-stream :tyi))
	   (cond ((null bits)
		  (simple-io-buffer-put buffer nil))
		 ((= bits #o34)
		  (simple-io-buffer-put buffer c))
		 (t
		  (setq bits (logand bits #o37))
		  (setq code (send remote-stream :tyi))
		  (cond ((null code)
			 (simple-io-buffer-put buffer nil))
			(t
			 (setq c (dpb (logand bits #o20) (byte 5 7) (logand #o177 code)))
			 (setq c (make-char (cond ((cadr (assoc c *ascii-supdup-translations* :test #'eq)))
						  ((= bits #o20) code)
						  (t (global:char-flipcase code)))
					    (logand bits #o17)))
			 (case c
			   (#\Control-Abort
			    (send user-process :interrupt 'network-user:abortion-interrupt))
			   (#\Control-Break
			    (send user-process :interrupt 'network-user:break-interrupt))
			   (otherwise
			    (simple-io-buffer-put buffer c))))))))
	  (t
	   (simple-io-buffer-put buffer c)))))
))

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

(defmethod (supdup-server :subtyi) (&aux c bits code)
  (loop
    (setq c (if untyi-char
		(prog1 untyi-char (setq untyi-char nil))
	      (send input :tyi)))
    (cond ((null c)
	   (return nil))
	  ((characterp c)
	   (return c))
	  ((= c #o300)
	   (case (setq c (send input :tyi))
	     (#o301				;Logout
	      (network-user:logout))
	     (#o302
	      (setq who-string (make-string 64 :fill-pointer 0))
	      (loop
		(setq c (send input :tyi))
		(when (or (null c) (zerop c))
		  (return))
		(vector-push-extend c who-string)))))
	  ((= c #o34)
	   (setq bits (send input :tyi))
	   (cond ((null bits)
		  (return nil))
		 ((= bits #o34)
		  (return c)))
	   (setq bits (logand bits #o37))
	   (setq code (send input :tyi))
	   (when (null code)
	     (return nil))
	   (setq c (dpb (logand bits #o20) (byte 5 7) (logand #o177 code)))
	   (return (make-char (cond ((cadr (assoc c *ascii-supdup-translations* :test #'eq)))
				    ((= bits #o20) code)
				    (t (global:char-flipcase code)))
			      (logand bits #o17))))
	  (t
	   (return (or (cadr (assoc c *ascii-supdup-translations* :test #'eq)) c))))))

(defmethod (supdup-server :any-tyi) (&optional ignore &aux idx c)
  (char-int-if-any
    (loop
      (cond ((> (tv:rhb-fill-pointer) (setq idx (tv:rhb-scan-pointer)))
	     ;;untyi'd characters...
	     (incf (tv:rhb-scan-pointer))
	     (return (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 (or untyi-char (send input :listen))
	       (send self :notice :input-wait))
	     (case (setq c (send self :subtyi))
	       ((#\Abort #.(char-int #\Abort))
		(network-user:abortion-interrupt))
	       ((#\Break #.(char-int #\Break))
		(network-user:break-interrupt))
	       (otherwise
		(return c))))
	    (t
	     ;;Rubout handler (will call us for new characters)
	     (return (funcall (or tv:stream-rubout-handler 'tv:default-rubout-handler))))))))

(defmethod (supdup-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))
	((= 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 :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)
	 (extended (termcap.extended-keyboard termcap)))
	((not (setq c (or untyi-char (getc input self))))
	 nil)
      (cond (untyi-char
	     (return (prog1 untyi-char (setq untyi-char nil))))
	    ((characterp c)
	     (return c))
	    ((= c iac)
	     (multiple-value-bind (done value)
		 (receive-iac)
	       (when done
		 (return value))))
	    ((and (not quote) (= c *telnet-ascii-quote-character*))
	     (setq quote t))
	    ((and (not extended) (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 (extended
		    (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))))))

(defmethod (telnet-server :any-tyi) (&optional ignore)
  (let ((extended (termcap.extended-keyboard termcap))
	idx c quote)
    (char-int-if-any
      (loop
	(cond ((> (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))
		     (extended
		      (return c))
		     (t
		      (return c))))
	      ((not (eq tv:rubout-handler self))
	       (setq c (send self :subtyi))
	       (cond ((null c)
		      (return nil))
		     ((and (not quote) (= c *telnet-quote-character*))
		      (setq quote t))
		     ((eq c #\Abort)
		      (network-user:abortion-interrupt))
		     ((eq c #\Break)
		      (network-user:break-interrupt))
		     (extended
		      (return c))
		     (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)))))))))

))

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

(defmethod (simple-ascii-stream-terminal :string-length) (string start end x)
  (do ((stops (termcap.tab-stops termcap))
       (index start (1+ index))
       (count 0)
       c)
      ((eql index end) count)
    (setq c (char string index))
    (when (null c)
      (return count))
    (cond ((< c #o40))
	  ((= c #\Return))			;hmm
	  ((= c #\Tab)
	   (incf count (cond ((null stops) 8)
			     ((numberp stops)
			      (let ((x (mod (+ x count) stops)))
				(if (zerop x) stops x)))
			     (t 0))))
	  ((= c #\Backspace)
	   (decf count))
	  ((graphic-char-p c)
	   (incf count))
	  (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)))
  (multiple-value-bind (x y)
      (send self :read-cursorpos)
    (setq count (send self :string-length string start end x))
    (cond ((setq insert (termcap.multiple-character-insert termcap))
	   (dolist (elt insert)
	     (send self :output-control-sequence (eval-multiple-item count elt)))
	   (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)))
  (multiple-value-bind (x ignore)
      (send self :read-cursorpos)
    (setq count (send self :string-length string start end x))
    (cond ((setq delete (termcap.multiple-character-delete termcap))
	   (dolist (elt delete)
	     (send self :output-control-sequence (eval-multiple-item count elt))))
	  ((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 (supdup-server :string-length) (string start end x)
  (do ((stops (termcap.tab-stops termcap))
       (index start (1+ index))
       (count 0)
       c)
      ((eql index end) count)
    (setq c (char string index))
    (when (null c)
      (return count))
    (cond ((= c #\Return))			;hmm
	  ((= c #\Tab)
	   (incf count (cond ((null stops) 8)
			     ((numberp stops)
			      (let ((x (mod (+ x count) stops)))
				(if (zerop x) stops x)))
			     (t 0))))
	  ((= c #\Backspace)
	   (decf count))
	  ((graphic-char-p c)
	   (incf count))
	  ((and (zerop (char-bits c)) (> c #\Network))
	   (incf count (cond ((< c #o10) 3)
			     ((< c #o100) 4)
			     (t 5))))
	  ('else
	   (incf count (string-length (format nil "~:C" c)))))))

(defmethod (telnet-server :string-length) (string start end x)
  (do ((stops (termcap.tab-stops termcap))
       (index start (1+ index))
       (count 0)
       c)
      ((eql index end)	count)
    (setq c (char string index))
    (when (null c)
      (return count))
    (cond ((< c #o40)
	   (incf count (string-length (aref *telnet-graphic-translations* c))))
	  ((= c #\Return))			;hmm
	  ((= c #\Tab)
	   (incf count (cond ((null stops) 8)
			((numberp stops)
			 (let ((x (mod (+ x count) stops)))
			   (if (zerop x) stops x)))
			(t 0))))
	  ((= c #\Backspace)
	   (decf count))
	  ((graphic-char-p c)
	   (incf count))
	  ((and (zerop (char-bits c)) (> c #\Network))
	   (incf count (cond ((< c #o10) 3)
			((< c #o100) 4)
			(t 5))))
	  ('else
	   (incf count (string-length (format nil "~:C" c)))))))

))

(kill-package "TELNET-USER")