;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.166
;;; Reason:
;;;  TCP SUPDUP Server.
;;; Written 21-Dec-87 16:06:25 by pld at site Gigamos Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.163, 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.IP-TCP.SERVER; TERMCAP.LISP#86 at 21-Dec-87 16: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 :tab) ()
  (let ((stops (termcap.tab-stops termcap)))
    (cond ((null stops)
	   (send self :string-out "        "))
	  ((numberp stops)
	   (let ((spaces (mod (pixels-to-chars tv:cursor-x) stops)))
	     (dotimes (i (or (plusp spaces) stops))
	       (send self :tyo #\Space))))
	  ('else
	   ;; a list of tab stops. write this some other time
	   nil
	   ))))

(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 ((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 :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)
			   (let ((x (mod end-x stops)))
			     (if (zerop x) stops x)))
			  (t 0))))
	    ((= c #\Backspace)
	     (inc-x -1))
	    ((graphic-char-p c)
	     (inc-x 1))
	    (t)))))

(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)
			   (let ((x (mod end-x stops)))
			     (if (zerop x) stops x)))
			  (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 modified file DJ: L.NETWORK.IP-TCP.SERVER; TERMCAP.LISP#86 at 21-Dec-87 16:06:26
#10R TELNET#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TELNET")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; SERVER; TERMCAP  "

(defflavor supdup-server
	 (who-string)
	 (simple-ascii-stream-terminal)
  (:settable-instance-variables who-string)
  :initable-instance-variables)

(defvar *ascii-supdup-translations*
	'((#o00 #\Null)
	  (#o10 #\Backspace)
	  (#o11 #\Tab)
	  (#o12 #\Line)
	  (#o14 #\FF)
	  (#o15 #\Return)
	  (#o32 #\Call)
	  (#o33 #\Altmode)
	  (#o177 #\Rubout)
	  (#o233 #\End)
	  (#o310 #\Resume)
	  (#o323 #\Hold-Output)
	  (#o4101 #\Escape)
	  (#o4102 #\Break)
	  (#o4103 #\Clear-Input)
	  (#o4110 #\Help)
	  (#o4177 #\Integral)))

(defmethod (supdup-server :subtyi) (&aux c bits code)
  (loop
    (setq c (send input :tyi))
    (cond ((null c)
	   (return nil))
	  ((= c #o300)
	   (case (setq c (send input :tyi))
	     (#o301				;Logout
	      (telnet-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)
		  (format self "~&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 (logior (ash bits 7) (logand #o177 code)))
	   (return (or (cadr (assoc c *ascii-supdup-translations* :test #'eq))
		       (and (= bits #o20) code)
		       (make-char (global:char-flipcase code) bits))))
	  (t
	   (return (or (cadr (assoc c *ascii-supdup-translations* :test #'eq)) c))))))

(defmethod (supdup-server :any-tyi) (&optional ignore &aux idx)
  (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))
	   (send self :subtyi))
	  (t
	   ;;Rubout handler (will call us for new characters)
	   (funcall (or tv:stream-rubout-handler 'tv:default-rubout-handler))))))

(defmethod (supdup-server :tyo-unlocked) (c)
  (when (plusp (tv:sheet-more-flag self))
    (case (send self :more-exception)
      ((#.(char-int #\Clear-Input) #.(char-int #\Abort))
	 (telnet-user:abortion-interrupt))
      (#.(char-int #\Break)
	 (telnet-user:break-interrupt))))
  (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 (supdup-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 #\Return)
	     (setq end-x 0)
	     (inc-y 1))
	    ((= c #\Tab)
	     (inc-x (cond ((null stops) 8)
			  ((numberp stops)
			   (let ((x (mod end-x stops)))
			     (if (zerop x) stops x)))
			  (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))))))))

(defmethod (supdup-server :clear-between-cursorposes) (x1 y1 x2 y2)
  (supdup-clear-between-cursorposes x1 y1 x2 y2))

(defmethod (supdup-server :supdup-greeting) (format-string &rest args)
  (start-supdup-output :supdup)
  (apply #'format self format-string args)
  (send output :tyo %tdnop)
  (send self :terpri)
  (force-output output))

(compile-flavor-methods supdup-server)

))

; From modified file DJ: L.NETWORK; SUPDUP.LISP#309 at 21-Dec-87 16:47:56
#8R SUPDUP#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SUPDUP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; SUPDUP  "

(defmethod (basic-nvt :new-connection) (host protocol contact contact-p window
					&aux label-spec conn)
  (multiple-value-setq (host contact label-spec)
    (expand-path tv:name host contact contact-p))
  (when host
    (dotimes (i 2)
      (setq conn (condition-case (error)
		     (ecase protocol
		       (:chaos
			(chaos:connect host contact window))
		       (:internet
			(open (format nil "TCP-HOST:~D.~D" host contact) :keyword tv:name :optimistic nil)))
		   (error error)))
      (unless (errorp conn)
	(send self :set-label label-spec)
	(send self :set-connection conn)
	(return conn))
      (setq protocol (if (eq protocol :chaos) :internet :chaos))
      conn)))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; GENERIC-SERVER.LISP#24 at 21-Dec-87 17:59:28
#10R TCP-APPLICATION#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; GENERIC-SERVER  "

(defun *define-network-service (name protocol-name transport-protocol documentation
				&key toplevel-function listen-port auto-enable? stream-flavor)
  (when (global:record-source-file-name name 'define-network-service)
    (proclaim `(special ,name))
    (setf (documentation name 'network-service) (or documentation name))
    (let ((service (set name (make-network-service))))
      (pushnew name *network-services*)
      (setf (network-service-name service) protocol-name)
      (setf (network-service-transport-protocol service) transport-protocol)
      (setf (network-service-listen-port service) (eval listen-port))
      (setf (network-service-toplevel-function service) toplevel-function)
      (setf (network-service-auto-enable? service) auto-enable?)
      (setf (network-service-stream-flavor service) stream-flavor)
      (setf (network-service-active-servers service) nil)
      (setf (network-service-listening-server service) nil)
      (setf (network-service-lock service) nil))
    name))

))

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

(define-network-service *tcp-supdup-service* :supdup :tcp "SUPDUP Terminal Capability"
  :listen-port (sym tcp-application:ipport-supdup)
  :toplevel-function 'supdup-server-function
  :auto-enable? t)

(global:defresource supdup-server (&optional ascii-output-stream ascii-input-stream)
  :constructor (make-instance 'supdup-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)
			(send object :termcap :default)))

(defun supdup-server-function (remote-stream)
  (let* ((safe-input-stream (make-eof-throwing-stream remote-stream))
	 (si:user-id nil)
	 (telnet-user:*term* nil)
	 (cvars '(telnet-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)
	(telnet-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 *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)))))))

(defun supdup-server-input (user-process buffer remote-stream terminal)
  (declare (ignore user-process))
  (declare (ignore terminal))
  (do (c)
      ((null (setq c (send remote-stream :tyi))))
    (simple-io-buffer-put buffer c)))
))

(tcpa:enable-one-network-service telnet:*tcp-supdup-service*)