;;; -*- Mode:LISP; Package:TELNET; Base:8; Patch-File:T -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (c) 1986, Texas Instruments Incorporated.  All rights reserved.
;;; Copyright (c) 1986, Sperry Corporation.  All rights reserved.

;;; NOTES:
;;;   This code will need review and possibly reimplementation for
;;;   Release 3.0 because of GENI's release.

;;; To eliminate compilation warnings, create required packages
;;; if they don't already exist ;; BAC
(EVAL-WHEN (EVAL COMPILE)
  (PKG-FIND-PACKAGE "KERMIT" T)
  (PKG-FIND-PACKAGE "IP" T))

;;; MAKE-SERIAL-STREAM-FROM-CVV
;;;

(DEFVAR  *BAUD*                  #10r1200    "Baud rate.")
(DEFVAR  *FORCE-OUTPUT*          T           "Force output.")
(DEFVAR  *NUMBER-OF-DATA-BITS*   #10r8       "Number of data bits.")
(DEFVAR  *NUMBER-OF-STOP-BITS*   #10r2       "Number of stop bits.")
(DEFVAR  *PARITY*                :NONE       "Parity.")
(DEFVAR  *XON-XOFF-PROTOCOL*     NIL         "XON-XOFF protocol.")
(DEFVAR  *ASCII-CHARACTERS*      NIL         "Ascii-characters.")
(DEFVAR  *INPUT-BUFFER-SIZE*     #10r180     "Input buffer.")
(DEFVAR  *OUTPUT-BUFFER-SIZE*    #10r180     "Output buffer.")

(DEFUN MAKE-SERIAL-STREAM-FROM-CVV ()
  "Produces a CVV to select serial stream parameters, then creates a stream
using SI:MAKE-SERIAL-STREAM.  Returns the created stream."
  (DECLARE (SPECIAL *BAUD* *FORCE-OUTPUT* *NUMBER-OF-DATA-BITS*
		    *NUMBER-OF-STOP-BITS* *PARITY* *XON-XOFF-PROTOCOL*
		    *ASCII-CHARACTERS* *INPUT-BUFFER-SIZE* *OUTPUT-BUFFER-SIZE*))

  (TV:CHOOSE-VARIABLE-VALUES
    '((*BAUD* "Baud rate"
	      :DOCUMENTATION "Line speed.  (Most asynchronous modems use 1200 or 300)"
	      :CHOOSE (#10r300 #10r1200 #10r2400 #10r4800 #10r9600 #10r19200))
      (*FORCE-OUTPUT* "Force output"
		      :DOCUMENTATION "YES: send characters immediately.  NO: send characters when buffer is full."
		      :BOOLEAN)
      (*NUMBER-OF-DATA-BITS* "Data Bits"
			     :DOCUMENTATION "Number of data bits."
			     :CHOOSE (#10r5 #10r6 #10r7 #10r8))
      (*NUMBER-OF-STOP-BITS* "Stop Bits"
			     :DOCUMENTATION "Number of stop bits."
			     :CHOOSE (1 2))
      (*PARITY* "Parity"
		:DOCUMENTATION "Type of parity to use."
		:CHOOSE (:NONE :EVEN :ODD))
      (*XON-XOFF-PROTOCOL* "XON-XOFF"
			   :DOCUMENTATION "YES: use XON-XOFF characters.  NO: don't implement XON-XOFF characters."
			   :BOOLEAN)
      (*ASCII-CHARACTERS* "Translate ASCII"
			  :DOCUMENTATION "YES: Automatically translate between ASCII and LISPM characters.  NO: don't translate."
			  :BOOLEAN)
      (*INPUT-BUFFER-SIZE* "Input Buffer size"
			   :DOCUMENTATION "Size (in words) to allocate for the input buffers."
			   :NUMBER)
      (*OUTPUT-BUFFER-SIZE* "Output Buffer size"
			    :DOCUMENTATION "Size (in words) to allocate for the output buffers."
			    :NUMBER))
    :NEAR-MODE '(:POINT 500 400)
    :LABEL "Choose Serial Stream Parameters"
    :MARGIN-CHOICES '("Do It"))
 
  (SI:MAKE-SERIAL-STREAM
    :BAUD *BAUD*
    :FORCE-OUTPUT *FORCE-OUTPUT*
    :NUMBER-OF-DATA-BITS *NUMBER-OF-DATA-BITS*
    :NUMBER-OF-STOP-BITS *NUMBER-OF-STOP-BITS*
    :PARITY *PARITY*
    :XON-XOFF-PROTOCOL *XON-XOFF-PROTOCOL*
    :ASCII-CHARACTERS *ASCII-CHARACTERS*
    :INPUT-BUFFER-SIZE *INPUT-BUFFER-SIZE*
    :OUTPUT-BUFFER-SIZE *OUTPUT-BUFFER-SIZE*))


;;; Autodial
;;;

(DEFVAR  *AUTODIAL-PREFIX*  "ATDT"            "Prefix to send to autodialer modem")
(DEFVAR  *AUTODIAL-NUMBER*  "8,8005551212"    "Number to dial")

(DEFUN AUTODIAL (&KEY
		 (PREFIX *AUTODIAL-PREFIX*)
		 (NUMBER *AUTODIAL-NUMBER*)
		 STREAM				; could bind this to *SERIAL-PORT-OWNER*
		 MENU
		 VERBOSE)
  "Dial a number using an autodialer.  If :NUMBER is not specified,
use the last number dialed.  If :MENU is specified, display a menu
to select the number to dial."
 
  (LET
    ((PRE PREFIX)
     (NUM NUMBER)
     (CONTINUE T))
    (DECLARE (SPECIAL PRE NUM))
    (WHEN MENU
      (SETQ CONTINUE
	    (*CATCH 'END-CVV
	      (TV:CHOOSE-VARIABLE-VALUES
		'((PRE
		    "Prefix"
		    :DOCUMENTATION "Modem's autodial prefix (e.g., ATDT)."
		    :STRING)
		  (NUM
		    "Number"
		    :DOCUMENTATION "Telephone number to dial.  A comma <,> causes a 2 second wait."
		    :STRING))
		:NEAR-MODE '(:POINT 500 400)
		:LABEL "Serial Port Autodial"
		:MARGIN-CHOICES '("Do It" ("Quit" (*THROW 'END-CVV NIL))))
	      T)))

    (WHEN CONTINUE
      (IF (NOT (STREAMP STREAM))
	  (WHEN VERBOSE
	    (FORMAT T "~&Stream <~A> is not a valid stream." STREAM))
	  (PROGN
	    (SETQ *AUTODIAL-PREFIX* PRE)
	    (SETQ *AUTODIAL-NUMBER* NUM)
	    (SEND STREAM :CLEAR-INPUT)
	    (SEND STREAM :CLEAR-OUTPUT)
	    (SEND STREAM :LINE-OUT (FORMAT NIL "~A~A" *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*))
	    (PROCESS-WAIT-WITH-TIMEOUT
	      "Dialing..."
	      3600
	      (FUNCTION (LAMBDA (STREAM)
			  (SEND STREAM :GET :DATA-CARRIER-DETECT)))
	      STREAM)
	    (SEND STREAM :CLEAR-INPUT)
	    (SEND STREAM :CLEAR-OUTPUT)
	    T)))))


;;; RUN-SCRIPT
;;;

(DEFUN RUN-SCRIPT (script &KEY (stream *TERMINAL-IO*) (debug-stream *DEBUG-IO*)
		   &AUX (response (make-array 5000. :type art-string :fill-pointer 0))
		        (return-value nil))
  "Simulate an interactive user session with a script.
SCRIPT is a list of the form ((SEND RECEIVE ACTION)...).
SEND is a list of a format control string and its arguments that specify the output to be sent to STREAM.
RECEIVE is a list of a format control string and its arguments that specify the input expected from STREAM.
ACTION specifies what to do if the data received doesn't contain the string specified by RECEIVE.
  It can be :L (loop forever), :Q (quit,the default), a number indicating the number of times to loop and
  before quitting, or a list of a format control string and its arguments that specify an alternative output
  to be sent to STREAM.
For each element of SCRIPT, first SEND is sent to STREAM, then STREAM is checked for input that matches
  RECEIVE, if it is found, the next form is processed, else, the ACTION is processed, and STREAM is again
  checked for input that matches RECEIVE.
STREAM is an I/O stream.
When DEBUG-STREAM is specified, it should be an I/O stream where debug info is sent.
RUN-SCRIPT returns :SUCCESSFUL if the last RECEIVE in SCRIPT was successful, :UNSUCCESSFUL otherwise."
 
  (CHECK-ARG SCRIPT LISTP "a list")
  (CHECK-ARG STREAM STREAMP "a stream")
  (CHECK-ARG DEBUG-STREAM STREAMP "a stream")
  (DOLIST (item script return-value)
    (SETQ return-value
	  (LET* ((send (FIRST item))
		 (receive (SECOND item))
		 (action (THIRD item)))
	    (DO ()
		(NIL)
	      (WHEN send
		(LET ((formatted-string (APPLY #'FORMAT NIL (CAR send) (CDR send))))
		  (SEND stream :STRING-OUT formatted-string)
		  (WHEN debug-stream (FORMAT debug-stream "~%Sending:~A" formatted-string))))
	      (IF receive
		  (PROGN
		    (SETF (FILL-POINTER response) 0)
		    (WHEN debug-stream (FORMAT debug-stream "~%Receiving:"))
		    (DO ((char (SEND stream :TYI-WITH-TIMEOUT 1800.)(SEND stream :TYI-WITH-TIMEOUT 1800.)))
			((NULL char) T)
		      (WHEN (> char 0)
			(SETF (AREF response (FILL-POINTER response)) (LOGAND char #o177))
			(INCF (FILL-POINTER response))
			(WHEN debug-stream (FORMAT debug-stream "~C" (LOGAND char #o177)))))
		    (WHEN debug-stream (FORMAT debug-stream "~%Searching:~A" (APPLY #'FORMAT NIL (CAR receive) nil)))
		    (SEND stream :CLEAR-INPUT)
		    (IF (STRING-SEARCH (APPLY #'FORMAT NIL (CAR receive) (CDR receive)) response)
			(RETURN :SUCCESSFUL)
			(IF action
			    (IF (EQ action :Q)
				(RETURN :UNSUCCESSFUL)
				(IF (INTEGERP action)
				    (IF (< action 1)
					(RETURN :UNSUCCESSFUL)
					(DECF action))
				    (IF (LISTP action)
					(SETQ send action)
					(UNLESS (EQ action :L)
					  (FERROR t "The third element, ACTION, of an element of SCRIPT, ~A, was ~A, which is not :Q, :L, an integer, or a list." ITEM ACTION)))))
			    (RETURN :UNSUCCESSFUL))))
		  (RETURN :SUCCESSFUL)))))))


;;; Serial stream flavor addition: TYI-WITH-TIMEOUT

SI:(DEFMETHOD (SERIAL-STREAM-MIXIN :TYI-WITH-TIMEOUT) (INTERVAL-IN-60THS)
     (IF (SI:PROCESS-WAIT-WITH-TIMEOUT
	   "Serial Waiting"
	   INTERVAL-IN-60THS
	   (FUNCTION (LAMBDA (STREAM) (SEND STREAM :INPUT-CHARS-AVAILABLE-P)))
	   SELF)
	 (SEND SELF :TYI)))


;;;  From sys:telnet;basic-telnet (sort of):
;;;
;;;  This method is almost identical to (:method basic-telnet :net-output),
;;;  which vt100-frame inherits, except that this version doesn't
;;;  automatically send a linefeed after a carriage-return unless the
;;;  connection is a chaos connection.  Thus, it preserves the existing
;;;  behavior for normal connections (and it seems to be the right thing)
;;;  while removing the spurious linefeed from serial-port connections.
;;;  There may well be a better way to do it.  - pf, Sept 11, 1985
(DEFMETHOD (vt100-frame :NET-OUTPUT) (ch)
  (lock-output
    (when (ldb-test 1701 ch)			;An NVT char from TELNET-KEYS
      (if new-telnet-p
	  (send stream ':tyo NVT-IAC))
      (setq ch (ldb 0010 ch)))
    (send stream ':tyo ch)
    (cond ((and (typep connection 'chaos:conn) (= ch 15))
	   (send stream ':tyo 12))		;CR is two chars, CR LF
	  ((and (= ch NVT-IAC) new-telnet-p)
	   (send stream ':tyo NVT-IAC)))))  	;IAC's must be quoted


;;; Autodial command method
;;;

(DEFCOMMAND (VT100-FRAME :AUTODIAL) ()
  '(:DESCRIPTION "Display a pop-up menu with commands to use an auto dialer."
		 :NAMES ("Autodial"))
  (DECLARE (SPECIAL *AUTODIAL-PREFIX* *AUTODIAL-NUMBER*))
  (COND (CONNECTION
	 (IF (NOT (FUNCTIONP 'AUTODIAL))
	     (FORMAT T "~&AUTODIAL not loaded. Can't Autodial."))
	     (FUNCALL 'AUTODIAL :STREAM STREAM :MENU T))
	(T
	 (FORMAT T "~&Not connected.  Can't Autodial.")
	 (WHEN (NOT UCL:PREEMPTING?)
	   (SEND SELF ':HANDLE-PROMPT)))))


;;; Kermit command method
;;;

(DEFCOMMAND (VT100-FRAME :KERMIT) ()
  '(:DESCRIPTION "Display a pop-up menu of KERMIT file-transfer commands."
		 :Names ("Kermit"))
  (COND (CONNECTION
	 (IF (NOT (FUNCTIONP 'KERMIT:INTERACTIVE-KERMIT))
	     (FORMAT T "~&KERMIT not loaded. Can't run KERMIT.")
	     (LET
	       ((VT100-SUBSTITUTE (SEND SELF :SELECTION-SUBSTITUTE))
		(KERMIT-SUPERIOR (SEND KERMIT:*KERMIT-FRAME* :SUPERIOR))
		(MENU-PANE (SEND SELF :GET-PANE 'MENU-TELNET)))
	       (UNWIND-PROTECT
		   (LET
		     ((FORM NIL))
		     (SEND TYPEOUT-PROCESS :ARREST-REASON 'KERMIT)	; Stop the vt100 process from using serial stream
		     (SETQ FORM (KERMIT:INTERACTIVE-KERMIT STREAM NIL)) ; Get the Kermit arguments
		     (WHEN FORM
		       (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) T)	; Make the vt100 menu items non-mousable
		       (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR SELF)
		       (SEND SELF :SET-SELECTION-SUBSTITUTE KERMIT:*KERMIT-FRAME*)	; Attach the kermit frame to vt100
		       (EVAL FORM)))		; Call Kermit
		 (SEND TYPEOUT-PROCESS :REVOKE-ARREST-REASON 'KERMIT)	; Reallow vt100 to use serial
		 (SETF (SEND MENU-PANE :INVISIBLE-TO-MOUSE-P) NIL)	; Make menu items mousable
		 (SEND SELF :SET-SELECTION-SUBSTITUTE VT100-SUBSTITUTE)
		 (SEND KERMIT:*KERMIT-FRAME* :SET-SUPERIOR KERMIT-SUPERIOR)))))
	(T
	 (FORMAT T "~&Not connected.  Can't run KERMIT.")
	 (WHEN (NOT UCL:PREEMPTING?)
	   (SEND SELF ':HANDLE-PROMPT)))))


;;; Local echo command method
;;;

(DEFCOMMAND (vt100-frame :LOCAL-ECHO-COMMAND) ()
  '(:DESCRIPTION "Toggle local echo mode of Vt100 screen pane."
		 :NAMES ("Local Echo"))
  (SETF ECHO-FLAG (IF ECHO-FLAG NIL T))
  (FORMAT T "~&Local echo now ~A.~%"
	  (IF ECHO-FLAG "off" "on"))                  ; echo-flag=T means local echo is off!
  (WHEN (AND (NULL CONNECTION) (NOT UCL:PREEMPTING?))
      (SEND SELF ':HANDLE-PROMPT)))


;;; Redefine the VT100 layout and menu
;;;

(DEFFLAVOR VT100-TELNET-MENU
	   (TV:INVISIBLE-TO-MOUSE-P)
	   (TV:DYNAMIC-ITEM-LIST-MIXIN TV:COMMAND-MENU)
  (:SETTABLE-INSTANCE-VARIABLES TV:INVISIBLE-TO-MOUSE-P)
  (:DEFAULT-INIT-PLIST
    :LABEL (LIST :TOP :FONT FONTS:HL12B :STRING "VT100 & Telnet Commands")
    :ROWS 3                       ; BAC changed from 2
    :COLUMNS 7                    ; BAC changed from 7
    :VSP 8.
    :FONT-MAP (list fonts:MEDFNT)
    :LABEL-BOX-P nil
    :ITEM-LIST nil)
  (:DOCUMENTATION :COMBINATION
    "Command menu needs dynamic-item-list-mixin for UCL."))

(BUILD-COMMAND-TABLE 'VT100-TELNET-CMD-TABLE 'VT100-FRAME
  '((:method telnet-frame :exit-command)		
    (:method telnet-frame :disconnect-command)
    (:method telnet-frame :interrupt-process-command)
    :send-answerback-command
    :reverse-video-command
    :reset-command
    :escape-processing-command
    (:method telnet-frame :quit-and-disconnect-command)
    (:method telnet-frame :status-command)
    (:method telnet-frame :abort-output-command)
    :column-command
    :truncate-command
    :set-vt100-lines
    :network-help-command
    (:method telnet-frame :clear-input-command)
    (:method vt100-frame :autodial)                   ; BAC
    (:method vt100-frame :kermit)                     ; BAC
    :local-echo-command                               ; BAC
    )
  :INIT-OPTIONS
  '(:NAME "Vt100 & Telnet Commands"
	  :DOCUMENTATION "The Vt100 & Telnet commands."))

(BUILD-MENU 'UCL-VT100-TELNET-MENU 'VT100-FRAME
  :DEFAULT-ITEM-OPTIONS
  '(:FONT FONTS:MEDFNT)
  :ITEM-LIST-ORDER
    '( ;Row 1
      (:method telnet-frame :exit-command)		
      (:method telnet-frame :disconnect-command)
      (:method telnet-frame :interrupt-process-command)
      :send-answerback-command
      :reverse-video-command
      :reset-command
      :escape-processing-command
       ;Row 2
      (:method telnet-frame :quit-and-disconnect-command)
      (:method telnet-frame :status-command)
      (:method telnet-frame :abort-output-command)
      :column-command
      :truncate-command
      :set-vt100-lines
      :network-help-command
       ;Row 3                                           ; BAC
      (:method vt100-frame :autodial)                   ; BAC
      (:method vt100-frame :kermit)                     ; BAC
      :local-echo-command                               ; BAC
      ))


;;; The following add Serial streams to the TELNET and VT100 base system.
;;;

(DEFVAR telnet:file NIL)
 
(DEFMETHOD (vt100-frame :TYPEOUT-TOP-LEVEL) (&aux (terminal-io vt100-pane))
  "Redefines (:METHOD BASIC-NVT :TYPOUT-TOP-LEVEL) to use :PROCESS-ESCAPE"
  (declare (special telnet:file))
  (process-wait "Never-open" #'car (locate-in-instance self 'connection))
  (ucl:ignore-errors-query-loop
    (condition-bind (((sys:remote-network-error
		       ip:illegal-connection
		       ip:connection-reset) 'typeout-net-error self))
      (do-forever
	(do ((ch (nvt-neti) (send stream :tyi-no-hang)))
	    ((null ch) (if output-buffer (send self :force-output)))
	  (when (not (null telnet:file))
	    (send telnet:file :tyo ch))
	  (send self :process-escape
		(IF (EQ CONNECTION T)
		    (logand #b01111111 ch)   ; if we don't strip parity we get an error ;; BAC
		    ch)))))))


;;; This method should return the network connection. This can
;;; be a stream or a connection object depending on the network type.
;;;
;;; The method :NETWORK-NEW-CONNECTION is not needed for serial telnet.
(DEFMETHOD (basic-nvt :case :network-new-connection :serial)
	   (host &optional (contact "TELNET") (window nil) )
  window contact host nil)                                       ; BAC to eliminate compile warnings

(RECOMPILE-FLAVOR 'vt100-frame :NETWORK-NEW-CONNECTION)

;;; Return nil if the connection is not connected.
(DEFMETHOD (basic-nvt :case :network-connected-p :serial)()
  (and stream connection))

(RECOMPILE-FLAVOR 'vt100-frame :NETWORK-CONNECTED-P)

;;; The method :NETWORK-NEW-CONNECTION passes the arguement which we
;;; ignore for the serial implementation.
;;;
;;; Set stream to be the serial stream.
;;; Connection should be something non nil, but does not need to be a connection.
;;; The connection instance variable is used by CHAOSNET.
(DEFMETHOD (basic-nvt :case :set-connection :serial) (ignore)
  (SEND typein-process :reset)
  (SEND typeout-process :reset)
  (SETF stream (MAKE-SERIAL-STREAM-FROM-CVV))
;;  (SEND self :gobble-greeting)
  (SETF connection t)
  (SETQ black-on-white nil))

(RECOMPILE-FLAVOR 'vt100-frame :SET-CONNECTION)

;;; This method should close the serial TELNET connection.
;;; Make sure to set both instance variables, STREAM and CONNECTION,
;;; to nil.
(DEFMETHOD (basic-nvt :case :network-disconnect :serial)()
  (WHEN stream
    (SEND stream :close)
    (SETF stream nil
	  connection nil)))

(RECOMPILE-FLAVOR 'vt100-frame :NETWORK-DISCONNECT)

;;; This method should indicate the connection state.
;;; It would be nice if you could signal errors in the connection
;;; state by throwing 'NVT-DONE because TELNET will try to eloquently
;;; close the connection.
(defmethod (basic-nvt :case :check-connection-state :serial)()
  (unless stream
      (*THROW 'TELNET:NVT-DONE "Stream never opened.")))

(RECOMPILE-FLAVOR 'vt100-frame :CHECK-CONNECTION-STATE)

;;; Send the TELNET command interrupt process (IP) to the remote host.
;;; (Note: IP should not be confused with the acronym for a well known
;;; network type.)
;;; An IP command is defined to be the following two bytes: NVT-IAC NVT-IP.
;;; Many implementations send the IP in urgent mode as the following sequence of bytes
;;; NVT-IAC, NVT-IP, NVT-IAC, NVT-DM.  This is technically a SYNC signal but
;;; most systems handle no differently. The TCP/IP network sends a SYNC signal
;;; in urgent mode, the CHAOS network sends a SYNC signal not in urgent mode
;;; because there is no concept of urgent data, Wollongong sends just an IP command
;;; and the MIT PC software sends a SYNC signal in urgent mode.
;;;
;;; You may choose to send a SYNC signal or just IP command I think it makes little
;;; difference (except with Wollongong which can't handle SYNC signals successfully).
;;; However, since serial streams do not have a concept of
;;; urgent mode I choose to send a SYNC signal.
(DEFMETHOD (basic-telnet :case :network-send-ip :serial)()
  (lock-output
    (SEND stream :tyo NVT-IAC)
    (SEND stream :tyo NVT-IP)
    (SEND stream :tyo NVT-IAC)
    (SEND stream :tyo NVT-DM)
    ))

(RECOMPILE-FLAVOR 'vt100-frame :NETWORK-SEND-IP)

(UNLESS (MEMBER :serial protocols-supporting-telnet)
  (PUSH :serial protocols-supporting-telnet))

;;; This is a kludge to make serial telnet work correctly.
;;; If there were serial host objects then this would not
;;; be necessary.
(setq default-network-type :serial)