;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.159
;;; Reason:
;;;  Really make Server Telnet's H19 etc. support work.
;;; Written 9-Dec-87 15:13:12 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.157, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TELNET.LISP#94 at 9-Dec-87 15:13:12
#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 (make-stream-terminal nil remote-stream safe-input-stream))
	 (si:user-id nil)
	 (telnet-user:*term* nil)
	 (cvars '(telnet-user:*term* si:user-id)))
    (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))))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:14:35
#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)

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:14: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 :tyo-unlocked) (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)
	 (when (plusp cursor-x)
	   (send self :output-control-sequence (termcap.back-space termcap))
	   (decf cursor-x)))
	((graphic-char-p c)
	 (cond ((= cursor-x (- (termcap.number-of-columns termcap) 2))
		(send output :tyo (termcap.linewrap-indicator termcap))
		(send self :terpri)
		(send self :tyo c))
	       ('else
		(setq need-force-output t)
		(send output :tyo c)
		(incf cursor-x))))
	((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#48 at 9-Dec-87 15:14:48
#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)
	   (dotimes (i (mod cursor-x stops))
	     (send self :tyo #\Space)))
	  ('else
	   ;; a list of tab stops. write this some other time
	   nil
	   ))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:14:53
#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 :terpri) ()
  (with-lock (output-lock)
    (cond ((= cursor-y (- (termcap.number-of-lines termcap) 2))
	   (cond ((not more-p)
		  (send self :home-cursor)
		  (send self :clear-eol))
		 ('else
		  (send output :tyo (termcap.carriage-return termcap))
		  (send output :tyo (termcap.line-feed termcap))
		  (princ "**MORE**" output)
		  (force-output output)
		  (send input :tyi)
		  (send output :tyo (termcap.carriage-return termcap))
		  (send self :clear-eol)
		  (send self :home-cursor)
		  (send self :clear-eol))))
	  ('else
	   (setq cursor-x 0)
	   (incf cursor-y)
	   (send output :tyo (termcap.carriage-return termcap))
	   (send output :tyo (termcap.line-feed termcap))
	   (send self :clear-eol)
	   (setq need-force-output t)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:14:58
#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-eol) ()
  (let ((s (termcap.clear-to-end-of-line termcap)))
    (when s
      (send self :output-control-sequence s))))


))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:15: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 :subtyi) ()
  (if need-force-output (send self :force-output))
  (do ((c) (action) (option) (quote))
      ((not (setq c (or untyi-char (send input :tyi))))
       nil)
    (cond (untyi-char
	   (return (prog1 untyi-char (setq untyi-char nil))))
	  ((= c (get 'iac 'telnet-sym))
	   (setq flush-next-lf nil)
	   (setq c (send input :tyi))
	   (case (setq action (cadr (assoc c *telsyms* :test #'eq)))
	     (nil)
	     (iac
	      (return c))
	     (do
	      (setq c (send input :tyi))
	      (setq option (cadr (assoc c *telopts* :test #'eq)))
	       (push (list action option) telnet-commands-received)
	       (case option
		 (telopt_echo
		  (unless (send self :echo-p)
		    (send self :set-echo-p t)
		    (send-iac output 'will option)))
		 (telopt_sga)
		 (telopt_logout
		  (return nil))
		 (t
		  (send-iac output 'wont option))))
	     (dont
	      (setq c (send input :tyi))
	      (setq option (cadr (assoc c *telopts* :test #'eq)))
	      (push (list action option) telnet-commands-received)
	      (case option
		(telopt_echo
		 (when (send self :echo-p)
		   (send self :set-echo-p nil)
		   (send-iac output 'wont option)))
		(telopt_sga
		 (send-iac output 'wont option))))
	     (will
	      (setq c (send input :tyi))
	      (setq option (cadr (assoc c *telopts* :test #'eq)))
	      (push (list action option) telnet-commands-received)
	      (case option
		(telopt_sga
		 (send-iac output 'do option))
		(t
		 (send-iac output 'dont option))))
	     (wont
	      (setq c (send input :tyi))
	      (setq option (cadr (assoc c *telopts* :test #'eq)))
	      (push (list action option) telnet-commands-received)
	      (case option
		(telopt_sga
		 (send-iac output 'dont option))))
	     (sb
	      (do ()
		  ((= (send input :tyi) (get 'se 'telnet-sym))))
	      (push action telnet-commands-received))
	     (t
	      (push action telnet-commands-received))))
	  ((and (not quote) (= c *telnet-ascii-quote-character*))
	   (setq quote t))
	  ((and (not quote) (= c (glass-tty-ascii-code #\Altmode)))
	   (setq c (send self :subtyi))
	   (return (set-char-bit (make-char (if (plusp (char-bits c)) c (global:char-flipcase (char-code c)))
					    (char-bits c))
				 :meta t)))
	  ((and (not quote) (= c (glass-tty-ascii-code #\Control-\\)))
	   (setq c (send self :subtyi))
	   (return (set-char-bit (make-char (if (plusp (char-bits c)) c (global:char-flipcase (char-code c)))
					    (char-bits c))
				 :super t)))
	  ((= (setq c (translate-char c)) #\Return)
	   (setq flush-next-lf t)
	   (return #\Return))
	  ((and (= c #\Line) flush-next-lf)
	   (setq flush-next-lf nil))
	  ('else
	   (setq flush-next-lf nil)
	   (when quote
	     (setq untyi-char c)
	     (setq c *telnet-quote-character*))
	   (return c)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:15:15
#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 :read-cursorpos) (&optional (type :pixel))
  (ecase type
    (:pixel
     (values (* cursor-x 10) (* cursor-y 10)))
    (:character
     (values cursor-x cursor-y))))

))

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


(defmethod (simple-ascii-stream-terminal :set-cursorpos) (x y &optional (type :pixel))
  (ecase type
    (:pixel
     (send self :set-cursorpos (floor x 10) (floor y 10) :character)) 
    (:character
     (setq cursor-x x)
     (setq cursor-y y)
     (dolist (item (termcap.cursor-motion termcap))
       (send self :output-control-sequence (eval-cursorpos-item x y item)))
     )))

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:15:23
#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 :set-cursor-x) (x)
  (send self :set-cursorpos x cursor-y :character))

))

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


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

))

; From modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#48 at 9-Dec-87 15:15:29
#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-screen) ()
  (let ((s (termcap.clear-screen termcap)))
    (cond ((null s)
	   (send self :fresh-line))
	  ('else
	   (send self :output-control-sequence s)
	   (setq cursor-x 0)
	   (setq cursor-y 0))))
  t)

))

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


(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-screen '(*esc* "E")
  :cursor-motion '(*esc* "Y" (+ y 32) (+ x 32))
  :number-of-columns 80
  :number-of-lines 24 
  :cursor-horizontal-motion nil
  :cursor-vertical-motion nil
  :delete-character '(*esc* "N")
  :delete-line '(*esc* "M")
  :enter-delete-mode nil
  :end-delete-mode nil
  :enter-insert-mode '(*esc* "@")
  :end-insert-mode '(*esc* "O")
  :home-cursor '(*esc* "H")
  :insert-character nil
  :initialization-string nil
  :cursor-up '(*esc* "A")
  :cursor-down '(*esc* "B")
  :cursor-right '(*esc* "C")
  :cursor-left '(*esc* "D")
  :tab nil
  :auto-new-line t
  )


))

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

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

))

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

(define-termcap vt-100 "Another commonly used terminal"
  :nicknames '(vt100)
  :add-blank-line nil
  :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")
  :number-of-columns 80
  :number-of-lines 24 
  :cursor-horizontal-motion nil
  :cursor-vertical-motion nil
  :delete-character nil
  :delete-line nil
  :enter-delete-mode nil
  :down-one-line nil
  :end-delete-mode nil
  :enter-insert-mode nil
  :end-insert-mode nil
  :home-cursor '(*esc* "[H")
  :insert-character nil
  :initialization-string nil
  :cursor-right nil
  :cursor-up nil
  )

))

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

))