;;; -*- Mode:LISP; Readtable:CL; Base:10 -*-

(defvar *timeout* 10.)

(defun wait-and-listen(stream
		       &optional (timeout *timeout*))
  (let*((sleep-a-second 60.0)
	(got-it))
    (dotimes (j timeout)
      (when (setq got-it (send stream :listen))
	(return-from wait-and-listen got-it))
      (process-sleep sleep-a-second "listening"))
    nil))

;;; Ascii translation stuff

(defvar *default-newline-mode* :crlf
  "Determines default new-line handling; whether new-line is
      :CR   = <carriage-return>, Ascii 13.
      :LF   = <line-feed>, Ascii 10.
      :CRLF = <carriage-return> / <line-feed>")

(defun translate-from-ascii(string
			    &key (newline *default-newline-mode*)
			    &aux ch)
  "NEWLINE can be :CR, :LF, or :CRLF to indicate how the ascii
stream represents 'newline'."
  (unless string (return-from translate-from-ascii ""))
  (with-input-from-string (in string)
    (with-output-to-string(out)
      (do-forever
	(setq ch
	      (SELECTQ (setq ch (send in :tyi))
		(nil (return nil))
		(8 #\BS)
		(9 #\TAB)
		(10				;LF
		 (if (eq newline :LF) #\CR #\LINE))
		(12 #\FF)
		(13				;CR
		 (case newline
		   (:cr #\cr)
		   (:lf #\cr)
		   (:crlf
		    (LET ((CH1 (send in :tyi)))
		      (OR (null ch1) (= CH1 10) (send in :untyi ch1)))
		    #\CR)))
		(127 #\RUBOUT)
		(T CH)))
	(if ch (send out :tyo ch) (return nil))))))

(defun translate-from-ascii(string
			    &key (newline *default-newline-mode*)
			    &aux ch)
  "NEWLINE can be :CR, :LF, or :CRLF to indicate how the ascii
stream represents 'newline'."
  (typecase string
    (null (return-from translate-from-ascii ""))
    (string)
    (character (setq string (string-append string)))
    (symbol (setq string (string string))))
  (with-input-from-string (in string)
    (with-output-to-string(out)
      (do-forever
	(setq ch
	      (SELECTQ (setq ch (send in :tyi))
		(nil (return nil))
		(8 #\BS)
		(9 #\TAB)
		(10				;LF
		 (if (eq newline :LF) #\CR #\LINE))
		(12 #\FF)
		(13				;CR
		 (case newline
		   (:cr #\cr)
		   (:lf #\cr)
		   (:crlf
		    (LET ((CH1 (send in :tyi)))
		      (OR (null ch1) (= CH1 10) (send in :untyi ch1)))
		    #\CR)))
		(127 #\RUBOUT)
		(T CH)))
	(if ch (send out :tyo ch) (return nil))))))

(defun translate-to-ascii(string
			  &key (newline *default-newline-mode*)
			  &aux ch)
  (with-input-from-string (in string)
    (with-output-to-string(out)
      (do-forever
	(setq ch
	   (SELECTQ (setq CH (send in :tyi))
	     (#\BS 8)
	     (#\TAB 9)
	     (#\LINE 10)
	     (#\FF 12)
	     (#\CR
	      (case newline
		(:crlf (send out :tyo 13) 10)
		(:cr 13)
		(:lf 10)))
	     (#\RUBOUT 127)
	     (T CH)))
	(if ch (send out :tyo ch) (return nil))))))

;;; Copying blocks of text to and from ascii stream

(defun flush-from-ascii-stream(from-stream
			      &optional
			      (timeout *timeout*))
  (copy-from-ascii-stream from-stream :flush timeout))

(defun copy-from-ascii-stream(from-stream
			      &optional
			      (to-stream standard-output)
			      (timeout *timeout*)
			      &aux gotit flushing)
  (cond
    ((streamp to-stream))
    ((eq to-stream :flush) (setq flushing t))
    (t (ferror nil "TO-STREAM is not :FLUSH or a valid stream")))
  (when (wait-and-listen from-stream timeout)
    (setq gotit
	  (translate-from-ascii
	    (with-output-to-string(str)
	      (do-forever
		(setq gotit (send from-stream :tyi))
		(send str :tyo gotit)
		(unless (wait-and-listen from-stream timeout)
		  (return))))))
    (unless flushing
      (send to-stream :string-out gotit)
      (send to-stream :force-output))
    ))

(defun copy-to-ascii-stream(to-stream
			    &optional
			    (from-stream standard-input)
			    &aux ch)
  (do-forever
    (if (eq (setq ch (send from-stream :tyi)) #\end)
	(return nil))
    (send from-stream :untyi ch)
    (let ((line (readline from-stream)))
	(send to-stream :line-out (translate-to-ascii line))
	(send to-stream :force-output))))

;;; Preset command lists:

(defvar *cmd-list*
	'("(print 'hello)"
	  "(print (* 10 11))"))

(defvar *s* nil "Last stream opened (for debugging)")

(defvar *default-do-sequence*
	'(:flush :login :copy-from :commands :copy-to))

(defvar host-contact-alist
	'((tish :server "TELNET" :login #\return)
	  (lurch :server "EVAL /bin/csh"
		 :newline :lf
		 :do-sequence (:copy-from :commands))))

(defun telnet-with-hooks(&optional (host 'TISH) (cmd-list *cmd-list*))
  (let*((contact-list (assoc host host-contact-alist))
	(server-cmd (get contact-list :server))
	(login-seq (get contact-list :login))
	(*default-newline-mode*
	  (or (get contact-list :newline)
	      *default-newline-mode*))
	(sequence (or (get contact-list :do-sequence)
		      *default-do-sequence*)))
    (declare(special *default-newline-mode*))
    (check-type server-cmd string "a contact in the HOST-CONTACT-ALIST")
    (with-open-stream (s (chaos:open-stream
			   (si:parse-host host)
			   server-cmd
			   :ASCII-TRANSLATION nil))
      (setq *s* s)
      (dolist (do sequence)
	(case do
	  ;;E.g. get past herald, login prompt
	  (:flush (flush-from-ascii-stream s))
	  ;;Host-specific login sequence
	  (:login
	   (beep)
	   (format t "~%>>> Logging in...")
	   (cond
	     ((stringp login-seq)
	      (send s :string-out login-seq)
	      (send s :force-output))
	     ((typep login-seq '(or character fixnum))
	      (send s :tyo login-seq)
	      (send s :force-output))
	     ((eq login-seq t)
	      (copy-to-ascii-stream s))
	     ((null login-seq) t)
	     (t (ferror nil "Invalid login sequence ~s" login-seq))))
	  (:copy-from (copy-from-ascii-stream s))
	  (:copy-to (copy-to-ascii-stream s))
	  ;;Run user's pre-set command list
	  (:commands
	   (dolist (cmd cmd-list)
	     (format t "~%>>> Doing ~s..." cmd)
	     (send s :line-out cmd)
	     (send s :force-output)
	     (copy-from-ascii-stream s)))
	  ))
      )))