;;; -*- Mode:Common-Lisp; Package:Yes-Way; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

;-------------------------------------------------------------------------------

(defun find-longest-matching-substring (substrings &optional (index 0))
"Returns the longest substring of substrings that is common to each of them.
Index is the point to which we have counted so far.
"
  (declare (optimize (speed 3) (safety 0)))
  (if (rest substrings)
      (loop for substring in (rest substrings)
	    when (>= index (length substring))
	    do (return substring :1)
	    when (>= index (length (first substrings)))
	    do (return (first substrings) :2)
	    when (not (char-equal
			(aref (first substrings) index)
			(aref substring index)
		      )
		 )
	    do (return (subseq (first substrings) 0 index) :3)
	    finally
	     (return (find-longest-matching-substring substrings (+ 1 index)))
      )
      (first substrings)
  )
)

(defmethod Simple-Completer
	   (string completions (type (eql :Recognition)) &optional (start-at 0))
"Performs :recognition type completion, trying to match String in the list of
strings Completions.
Returns the values:
  a) Either the initial string or the string it completed to.
  b) A list of all of the matching completion strings.
  c) A flag that is true if we completed successfully.
  d) The initial string we tried to complete.
  e) The string we completed to.
"
  (declare (values completed-or-initial-string completions completed-p
		   initial-string completed-string
	   )
  )
  (let ((matches
	  (remove-if-not
	    #'(lambda (x)
		(string-equal string x :Start2 start-at
			      :End2 (+ start-at (length string))
		)
	      )
	    completions
	  )
	)
       )
       (values (if (equal 1 (length matches))
		   (first matches)
		   (if matches
		       (Find-Longest-Matching-Substring matches)
		       nil
		   )
	       )
	       matches (equal 1 (length matches)) string
	       (if (equal 1 (length matches))
		   (first matches)
		   nil
	       )
       )
  )
)

(defmethod Simple-Completer
	   (string completions (type (eql :Apropos)) &optional (start-at 0))
"Performs :apropos type completion, trying to match String in the list of
strings Completions.
Returns the values:
  a) Either the initial string or the string it completed to.
  b) A list of all of the matching completion strings.
  c) A flag that is true if we completed successfully.
  d) The initial string we tried to complete.
  e) The string we completed to.
"
  (declare (values completed-or-initial-string completions completed-p
		   initial-string completed-string
	   )
  )
  (let ((matches
	  (remove-if-not
	    #'(lambda (x) (search string x :Start2 start-at :Test #'char-equal))
	    completions
          )
	)
       )
       (if matches
	   (let ((selected (w:menu-choose matches)))
	        (if selected
		    (values selected (list selected) t string nil)
		        ;(list selected))
		    (values string nil nil string nil)
		)
	   )
	   (values string nil nil string nil)
      )
  )
)

(defmethod simple-completer (string completions (type t) &optional (start-at 0))
"Pretends to perform completion of a type we don't understand.
Returns the values:
  a) The initial stringo.
  b) A list of all of the matching completion strings, i.e. nil.
  c) A flag that is true if we completed successfully, i.e. nil.
  d) The initial string we tried to complete.
  e) The string we completed to, i.e. nil.
"
  (declare (values completed-or-initial-string completions completed-p
		   initial-string completed-string
	   )
  )
  (ignore string completions start-at)
  (values string nil nil string nil)
)

;-------------------------------------------------------------------------------
(defflavor string-parsing-stream
	   ((string nil) ;; the string from which to parse.
	    (char-pointer 0) ;; the poit that we've read to
	   )
	   (sys:input-stream)
  (:Documentation
   "A flavor of string stream that we use when parsing commands from a string."
  )
  :Initable-Instance-Variables
  :Gettable-Instance-Variables
  :Settable-Instance-Variables
)

(defmethod (String-Parsing-Stream :Print-Self) (stream &rest ignore)
"A print method for string parsing streams that displays the string that we've
read in, the read pointer and the whose string.
"
  (format stream "#<SPS ")
  (multiple-value-bind (ignore error-p)
      (catch-error
	(progn
	  (if (stringp string)
	      (format stream "~S, ~D, ~S" (subseq string 0 char-pointer)
		      char-pointer string
	      )
	      (format stream "??? (no string)")
	  )
	  nil
	)
	nil
      )
    (if error-p
	(format stream "???? (error)")
	nil
    )
  )
  (format stream ">")
)

(defmethod (string-parsing-stream :After :Init) (ignore)
"Sets up the string in the stream so that it is adjustable and big enough that
if we do some completing in it we won't blow up.
"
  (assert string (string))
  (let ((old-string string))
       (setq string
	     (make-array (+ 50 (length string))
			 :Fill-Pointer t
			 :Adjustable t
			 :Element-Type 'sys:fat-char
	     )
       )
       (copy-array-portion old-string 0 (length old-string)
			   string 0 (length old-string)
       )
       (setf (fill-pointer string) (length old-string))
  )
)
			   
(defmethod (string-parsing-stream :Tyi) (&rest ignore)
"Reads a char from the stream."
  (if (>= char-pointer (length string))
      nil
      (prog1 (aref string char-pointer)
	     (setq char-pointer (+ 1 char-pointer))
      )
  )
)


(defmethod (string-parsing-stream :UnTyi) (char)
"Unreads a char from the stream."
  (if (char= char (aref string (- char-pointer 1)))
      (setq char-pointer (- char-pointer 1))
      (ferror nil "Attempt to unread a char that was not read in, ~S." char)
  )
)

;-------------------------------------------------------------------------------

(defun yw-lookup-key-command (ch)
"Looks up CH as a key command character.  We shadow the default key char lookup
so that we can circumvent some of the RH commands.
"
  (declare (values rubout-handler-command-instance-or-nil))
  (declare (special *top-level-command-table*))
  (loop with keys-so-far = (list ch)
	for command-or-flag
	  = (send (or (first (send self :all-command-tables))
		      *top-level-command-table*)
		  :lookup-keys keys-so-far)
	if (eq command-or-flag :fetch-more-keys)
	do (push-end (let ((rubout-handler nil))
		        (ucl:read-next-key keys-so-far))
		      keys-so-far)
	else
	return (values command-or-flag keys-so-far)
  )
)


(defun maybe-try-yw-for-key-command (ch continuation)
"Looks to see whether we have a key command by calling continuation.  If we
have a command then we execute it.  This probably needs a bit of a rewrite.
We probably don't want to throw back out to the top. {!!!!}.
"
  (declare (special *top-level-command-table*))
  (multiple-value-bind (command-or-flag keys-so-far) (funcall continuation ch)
    (if (or command-or-flag
	    (and (not *top-level-command-table*)
		 (not (send self :all-command-tables))
	    )
	)
	(values command-or-flag keys-so-far)
	(multiple-value-bind (command-or-flag-2 keys-so-far-2)
	    (yw-lookup-key-command ch)
	  (ignore keys-so-far-2)
	  (if (typep command-or-flag-2 'ucl:command)
	      (throw :Top-Level-Command
		     (send command-or-flag-2 :Execute *mailer*
			   :Arguments-Override nil
		     )
	      ) ;;; {!!!!}
	      (values command-or-flag keys-so-far)
	  )
	)
    )
  )
)
	      
;-------------------------------------------------------------------------------

;;; Record the legal types for the arguments to these operators.
(putprop :Through '(or number keyword) :first-arg-type)
(putprop :Through '(or number keyword) :second-arg-type)
(putprop :+       '(or number keyword) :first-arg-type)
(putprop :+       '(number)            :second-arg-type)
(putprop :-       '(or number keyword) :first-arg-type)
(putprop :-       '(number)            :second-arg-type)

(defun check-number (key arg1 arg2)
"Checks the numbers supplied as arguments to the operator KEY.  We barf unless
they are legal.
"
  (if (get key :first-arg-type)
      (if (typep arg1 (get key :first-arg-type))
	  nil
	  (Barf "~&~A is not a legal sequence specifier in this place [~A~A~A]."
		arg1 arg1 key arg2
	  )
      )
      nil
  )
  (if (get key :second-arg-type)
      (if (typep arg2 (get key :second-arg-type))
	  nil
	  (Barf "~&~A is not a legal sequence specifier in this place [~A~A~A]."
		arg2 arg1 key arg2
	  )
      )
      nil
  )
)


(defun Clean-Up-Numbers (numbers)
"Is passed a list of numbers specs.  These are validated and a cleaned up
version is returned for the construction of message sequences.
"
  (if numbers
      (if (keywordp (first numbers))
	  (if (rest numbers)
	      (let ((item (list (first numbers)
				(second numbers) (third numbers)
			  )
		    )
		   )
		   (apply 'check-number item)
		   (cons item (Clean-Up-Numbers (rest (rest (rest numbers)))))
	      )
	      (list (first numbers)) ;;; Things like :>
	  )
	  (cons (first numbers) (Clean-Up-Numbers (rest numbers)))
      )
      nil
  )
)

;-------------------------------------------------------------------------------

(defun specifier-equal (a b)
"Is true if A and B represent equivalent sequences."
;;; Note this should probably use set-difference because equivalent sequences
;;; can have different orders.
  (if (consp a)
      (if (consp b)
	  (and (specifier-equal (first a) (first b))
	       (specifier-equal (rest a) (rest b))
	  )
	  nil
      )
      (or (and (typep a 'message-sequence)
	       (typep b 'message-sequence)
	       (Sequence-Equal a b)
	  )
	  (equalp a b)
      )
  )
)

(defun sequence-equal-2 (existing flavor sequence-specifier user-filter-name)
"An internal function used by sequence-equal.  Is true if the existing sequence
Existing is equivalent to new Sequence-Specifier.  flavors must match too, so
we check the type of existing against the flavor we propose for the new one.
If they are both user filter sequences then they must represent the same
user filter.
"
  (and (equal (type-of existing) flavor)
       (or (not (typep existing 'user-filter-sequence))
	   (equal user-filter-name (send existing :user-filter-name))
       )
       (specifier-equal (send existing :Sequence-Specifier)
			sequence-specifier
       )
  )
)

(defun sequence-equal (a b)
"Is true if two message-sequences are equivalent, i.e. really represent
 the same predicate.
"
  (Sequence-Equal-2 a (type-of b) (send b :sequence-speficier)
		    (and (typep b 'user-filter-sequence)
			 (send b :user-filter-name)
		    )
  )
)

(defun validate-sequence (sequence-specifier &optional (null-seq-allowed t))
"Validates a sequence-specifier, generating parse errors if anything
is wrong with is.
"
  (if (consp sequence-specifier)
      (let ((key (if (consp (first Sequence-Specifier))
		     (first Sequence-Specifier)
		     Sequence-Specifier
		 )
	    )
	   )
	   (if (and (not null-seq-allowed) (equal '(nil) sequence-specifier))
	       (parse-error
		 "You were expected to type in a sequence specification~
                 ~%and none was found.  This is illegal in this ~
                 ~%context.  Please use Help for more information ~
                 ~%about message sequences."
               )
	       nil
	   )
	   (if (member (first Sequence-Specifier) '(symbol fixnum))
	       (yw-error "Mailer error.  Please report this to JPR.")
	       nil
	   )
	   (If key
	       (if (keywordp (first key))
		   (if (and (funcall (get :Method 'si:function-spec-handler)
				     'si:fdefinedp
				     `(:Method message-sequence ,(first key))
			    )
			    (or (not (get (first key) :Valid-P-Function))
				(apply (get (first key) :Valid-P-Function)
				       (rest key)
				)
			    )
		       )
		       nil
		       (if (get (first key) :Valid-P-Function)
			   (parse-error
			     (second (multiple-value-list
				       (apply (get (first key)
						   :Valid-P-Function
					      )
					      (rest key)
				       )
				     )
			      )
			   )
			   (parse-error
			     "You were expected to type in~
			     ~%a message sequence specification but instead~
			     ~%I read in ~S, which is illegal as a~
			     ~%message sequence keyword.  Please use Help ~
			     ~%for more information about message ~
			     sequences."
			     (first key)
			   )
		       )
		   )
		   nil
	       )
	       (parse-error
		 "You were expected to type in a message sequence ~
                 ~%specification but instead I read in ~S, ~
                 ~%which I cannot interpret as a message sequence.  ~
                 ~%Please use Help for more information about message ~
                 ~%sequences."
		 sequence-specifier
	       )
	   )
      )
      (validate-sequence (list sequence-specifier) null-seq-allowed)
  )
  sequence-specifier
)

(defun simplify-sequence (spec)
"Given a sequence specifier simplifies it.  This is the case if we have
a specifier of the form ((42)) -> (42).
"
  (if (and (consp spec) (consp (first spec)) (equal (length spec) 1))
      (first spec)
      spec
  )
)

;-------------------------------------------------------------------------------
;;; The actual parser stuff.

(defun eol-p (char)
"Is true if CHAR is an end of line char."
  (and (or (characterp char) (fixnump char))
       (member char *Eol-Chars* :Test #'char=)
  )
)

(defun shortest-of (strings &optional (current nil))
"Returns the shortest of a list of strings.  Current is the current
shortest string.
"
  (if strings
      (if current
	  (shortest-of (rest strings)
		       (if (<= (length current) (length (first strings)))
			   current
			   (first strings)
		       )
          )
	  (shortest-of (rest strings) (first strings))
      )
      current
  )
)

(tv:defun-rh Maybe-Complete-1
	     (stream string completed-p completions-found command)
"An internal function called by Maybe-Complete.  We have already tried to
complete the string.  Completed-p is true if we completed, command is the
command we found and completions-found is the list of possible completions
to the string.
"
  (cond ((not string) nil) ;;; No string was found so do nothing.
	((and (not completed-p)
	      (assoc string *named-sequence-alist*
		     :Test #'string-equal
	      )
	 )
	 ;;; We have failed to complete but the string actually names a named
	 ;;; sequence.  Given that this is the case we throw out to where
	 ;;; the named sequences are handled.
	 (throw 'named-sequence-found
		(second (assoc string *named-sequence-alist*
			       :Test #'string-equal
			)
		)
	 )
	)
	((and *Completion-Compulsory-P* (Not completed-p))
	 ;;; Completion was compulsory but we didn't complete so barf.  If we
	 ;;; were ambiguous then say so.
	 (if completions-found
	     (parse-error
	       "Ambiguous completion ~S could be ~{~S~^, ~} or ~S."
	       string (butlast completions-found)
	       (first (last completions-found))
	     )
	     (parse-error "Unrecognized completion")
	 )
	)
	((Not completed-p) nil) ;;; If we didn't complete then do nothing.
	(t (if (not (typep stream 'string-parsing-stream))
	       ;;; We aren't parsing from a string so make sure the RHB is ok
	       (tv:rh-set-position (tv:rh-scan-pointer))
	       nil
	   )
	   ;;; We found a command or an argument so throw out to the appropriate
	   ;;; command/arg handler.
	   (throw (if *complete-to-command-p*
		      'read-command
		      'read-argument
		  )
		  command
	   )
	)		   
  )
)

(defun maybe-complete (char stream)
"This is the kernel of the command completing stuff for YW.  It is called
when we TYI a char and mayy want to complete on it.
Char is the character we just read in.
Stream is the stream we read it off.
Note:  Stream may not be *standard-input*, it may be a string stream or some
such.
"
  (declare (special *eof-chars* *this-application*))
  (setq ucl:this-application (sys:follow-syn-stream *this-application*))
  (if (and *enable-completion-on-eof-chars-p*
	   (or (and (characterp char)
		    (member char yw:*completion-characters* :test #'char-equal)
		    user:auto-complete?
		    (not (boundp '*inside-maybe-complete*))
	       )
	       (and (boundp '*eof-chars*)
		    (characterp char)
		    (member char *eof-chars* :Test #'char-equal)
	       )
	       (not char) ;;; Nil is an eof char sometimes.
	   )
      )
      ;;; We have hit some sort of completion char so give completion a go.
      (let ((*inside-maybe-complete* t))
	   (declare (special *inside-maybe-complete*))
	   (multiple-value-bind (result completed-p completions-found string
				 command
				)
	       ;;; actually call the completer.
	       (tv:yw-rh-complete-word
		 stream :recognition
		 (list *completion-function* :auto-complete-p) t
	       )
	     (ignore result completions-found)
	     ;;; If we completed then we want to make sure that we have the
	     ;;; command, just in case we failed to pick it up in the
	     ;;; completion code.  Note: we look only for matching commands
	     ;;; on the shortest of the completions found.
	     (if (and completed-p (not command))
		 (if *complete-to-command-p*
		     (setq command
			 (send (symbol-value (first (send self :Typein-Modes)))
			       :Get-Command-For-String
			       (shortest-of completions-found)
			 )
		     )
		     (setq command (first completions-found))
		 )
		 nil
	     )
	     (Maybe-Complete-1
	       Stream string completed-p completions-found command
	     )
	   )
      )
      nil
  )
)


(defadvise tv:rh-cursor-motion (:always-force-motion) ()
  ;;; Makes sure that we always update the RH cursor motion on MCWs.
  (if (typep self 'yw-prompt-window)
      (progn (setq arglist (list (first arglist) nil (third arglist)))
	     :Do-It
      )
      :Do-It
  )
)

(defun maybe-historise-input-line (&optional (reset-pointers-p nil))
"If we completed a command ok then it's probably worth remembering the
command line in the history.  Do this and if reset-pointers-p then reset
the rhb so that we are really starting afresh.
"
  (declare (special *prompt-window*))
  (let ((rhb (symeval-in-instance *prompt-window* 'tv:rubout-handler-buffer)))
       (let ((array (subseq rhb 0 (tv:rhb-typein-pointer rhb))))
	    (let ((string (make-string (array-active-length array))))
	         (loop for i from 0 below (length string) do
		       (setf (aref string i) (Simple-Char (aref array i)))
		 )
		 (let ((short-string (string-trim *whitespace-chars* string)))
		      (if (equal "" short-string)
			  nil
			  (zwei:push-on-history short-string
			    (tv:rhb-input-ring rhb)
			  )
		      )
		 )
	    )
       )
       (if reset-pointers-p
	   (progn (setf (tv:rhb-typein-pointer rhb) 0)
		  (setf (tv:rhb-fill-pointer   rhb) 0)
		  (setf (tv:rhb-scan-pointer   rhb) 0)
	   )
	   nil
       )
  )
)

(defun Parse-Command-Line
       (&optional (stream *standard-input*) (parser 'read-and-execute-command)
	(reset-p t) (funcall-closures-p t)
       )
"Parses a command line from Stream, using Parser as its command parsing
function.  If Reset-p is true then it resets the command handler by
signaling an abort.  The contract of the parser function is that it
should return a closure that represents the continuation for the commmand
to be executed.  If funcall-closures-p is true then we invoke the command
continuation, otherwise we returns the closure to be handled later on.
"
  (declare (special ucl:key-sequence *prompt-window*))
  (let ((*this-application* (sys:follow-syn-stream *prompt-window*))
	(rhb (symeval-in-instance *prompt-window* 'tv:rubout-handler-buffer))
       )
       (declare (special *this-application*))
       (letf (((symeval-in-instance (sys:follow-syn-stream *prompt-window*)
				    'ucl:typein-modes)
	       '(YW-Top-Level-Command-Names)
	      )
	     )
	     (let ((result
		     (catch :Top-Level-Command
		       (unwind-protect
			 (Parse-Command-Line-1 parser stream)
			 (if (typep stream 'string-parsing-stream)
			     nil
			     (Maybe-Historise-Input-Line)
			 )
		       )
		     )
		   )
		  )
	          ;;; We've now done our parsing.  Validate the command and
	          ;;; maybe return or execute it.
		  (if (typep result 'closure)
		      (if (typep stream 'string-parsing-stream)
			  (if funcall-closures-p
			      (funcall result)
			      result
			  )
			  (with-carriage-return  (*mailer*)
			    (send self :Set-Command-Entry nil)
			    (setq ucl:key-sequence nil)
			    (setf (tv:rhb-typein-pointer rhb) 0)
			    (setf (tv:rhb-fill-pointer   rhb) 0)
			    (setf (tv:rhb-scan-pointer   rhb) 0)
			    (multiple-value-prog1
			      (if funcall-closures-p
				  (funcall result)
				  result
			      )
			      (if reset-p
				  (signal 'sys:abort 'sys:abort)
				  nil
			      )
			    )
			  )
		      )
		      (parse-error "Illegal command line.")
		  )
	     )
       )
  )
)

(defun execute-command-from-string
       (string mailer &optional (parser 'read-and-execute-command)
	(funcall-closures-p t)
       )
"Parses an YW command line from s string, using Mailer as an MCW for
any context that it might need.  Parser is a command parser function
compatible with Parse-Command-Line.  Funcall-closures-p is the same as
the arg of the same name for Parse-Command-Line.
"
  (let ((*end-of-line-found-p* nil))
       (let-if (boundp '*eof-found*)
	       ((*eof-found* nil))
	 (loop for result
	       = (catch 'tv:string-rubout-handler
		   (send (send mailer :Prompt-Window) :eval-inside-yourself
			 (Execute-Command-From-String-1
			   string mailer parser funcall-closures-p
			 )
		   )
		 )
	       while (and (consp result)
			  (equal (first result) 'tv:string-rubout-handler)
		     )
	       do (setq string (second result))
	       finally (return result)
	 )
       )
  )
)

(defun execute-command-from-string-1
       (string mailer &optional (parser 'read-and-execute-command)
	(funcall-closures-p t))
"An internal function used by execute-command-from-string.  Parses an YW
command line from s string, using Mailer as an MCW for any context that it
might need.  Parser is a command parser function compatible with
Parse-Command-Line.  Funcall-closures-p is the same as the arg of the
same name for Parse-Command-Line.
"
  (let ((*mailer* mailer)
	(*this-application* mailer)
	(*prompt-window* (send mailer :prompt-window))
	(ucl:this-application (send mailer :prompt-window))
	(ucl:Read-Type 'symbol)
	(ucl:previous-args nil)
       )
       (declare (special *prompt-window* *this-application*
			 ucl:Read-Type ucl:previous-args
		)
       )
       (letf (((symeval-in-instance *prompt-window* 'ucl:typein-modes)
	       '(YW-Top-Level-Command-Names)
	      )
	     )
	     (with-open-stream
	       (stream (make-instance 'string-parsing-stream :String string))
	       (let ((*standard-input* stream))
		    (parse-command-line stream parser t funcall-closures-p)
	       )
             )
       )
  )
)

(defun parse-a-sequence-from-string (string mailer)
"Is passed a string and a mail control window.  Parses the string to deliver a
message sequence.  For example the string might be \"From rice And To Acuff\".
It is not necessary for the string to have command names completed or anything
like that.
Returns a closure that, when called, will deliver the message sequence we want.
"
  (declare (values closure-that-will-deliver-a-message-sequence))
  (Execute-Command-From-String
    string mailer 'Parse-A-Message-Sequence-As-Command nil
  )
)

(defun parse-a-message-sequence-as-command (&rest args)
"A parser function used by parse-a-sequence-from-string to parse a message
sequence without a command line from a string.
"
  (declare (values message-sequence-encapsulated-within-a-closure))
  (let ((result (apply 'parse-a-message-sequence args)))
       (throw :Top-Level-Command #'(lambda () result))
  )
)

(defun yw-internal-read-char
       (stream &optional (errorp t) eofval ignore)
"YW's equivalent to the sys:internal-read-char function.  We LETF sys:internal-
read-char to point to this function.  We bind *old-internal-read-char* so that
we still have access to reading chars.  We bind this function so that we can
insert our own completion handler and deal with our own version of the EOF
concept.  We use read to read along the command line but we want to be able to
have a pretent EOF after each command or arg so that parse correctly.  This is
handled by binding *eof-chars* and *eof-found* to true when we find an eof char.
"
  (declare (special *eof-chars* *eof-found* *prompt-window*))
  (let ((ch (funcall *old-internal-read-char* stream errorp eofval nil)))
       (setq ch (Simple-Char ch nil))
       (if (Eol-P ch)
	   (setq *End-Of-Line-Found-P* t)
	   nil
       )
       ;;; Make sure we start from scratch when ewe have just a CR typed.
       (if (and *end-of-line-found-p* (typep stream 'tv:sheet)
		(equal 1 (tv:rhb-fill-pointer
			   (symeval-in-instance
			     stream 'tv:rubout-handler-buffer
			   )
			 )
		)
	   )
	   (signal 'sys:abort 'sys:abort)
	   nil
       )
       (If (or (and (boundp '*eof-found*)
		    *eof-found*
	       )
	       (and (boundp '*eof-chars*)
		    (characterp ch)
		    (member ch *eof-chars* :Test #'char-equal)
	       )
	   )
	   (If errorp
	       (parse-error "EOF found on stream.")
	       (progn (if (boundp '*eof-found*)
			  (setq *eof-found* ch)
			  nil
		      )
		      (send *prompt-window* :Send-If-Handles
			    :Eval-Inside-Yourself
			    `(Maybe-Complete ,ch ,stream)
		      )
		      (unread-char ch *standard-input*)
		      eofval
	       )
	   )
	   (progn (send *prompt-window* :Send-If-Handles :Eval-Inside-Yourself
			`(Maybe-Complete ,ch ,stream)
		  )
		  ch
	   )
       )
  )
)

(defun parse-command-line-1
       (function stream &optional (eof-errorp t) (eof-value ()))
"An internal function for Parse-command-line.  It is passed a parsing function
and a stream on which to do the parsing.  It binds up sundry read buffer stuff
so that the recursive read and rubout handler stuff works ok.
"
;;; The new changes to the rubout handler stuff should obviate this.
;  (if (not *read-buffer-bound-p*)
;      (setf (tv:rhb-typein-pointer
;	      (symeval-in-instance (sys:follow-syn-stream stream)
;				   'tv:rubout-handler-buffer))
;	    0)
;      nil
;  )
  (let-if (not *read-buffer-bound-p*)
	  ((Sys:*real-eof-value* eof-value)
	   (sys:*real-eof-errorp* eof-errorp)
	   (sys:sharp-equal-alist nil)
	   (sys:sharp-sharp-alist nil)
	   (*read-buffer-bound-p* t)
	   (*end-of-line-found-p* nil)
	   (Sys:read-buffer
	     (sys:allocate-buffer
	       sys:read-buffer-pool
	       (make-array 512 :element-type 'string-char
			   :fill-pointer 512))))
       (let ((sys:read-buffer-length (length sys:read-buffer))
	     (sys:ouch-ptr 0)
	     (sys:inch-ptr 0)
	     (sys:top-level-list t))
	 (unwind-protect
	     (let-if (not *old-internal-read-char*)
		     ((*old-internal-read-char* #'sys:internal-read-char))
	        (ticl:letf
		  ((#'sys:internal-read-char 'Yw-internal-read-char))
		  (funcall function stream)
		)
	     )
	   (sys:deallocate-buffer sys:read-buffer-pool sys:read-buffer)
	 )
       )
  )
)

(defun read-and-execute-command (stream)
"The command line parser.  Parses a command off Stream and then executes it."
  (declare (special *prompt-window*))
    (let ((command (catch 'read-command
		     (with-these-command-tables ('(*top-level-command-table*))
						*prompt-window*
		       (read stream)
		     )
		   )
	  )
	 )
	 (if (typep command 'ucl:command) ;yw-command)
	     (without-universal-command-tables *prompt-window*
	       (let ((ucl:Read-Type
		       (if (boundp 'ucl:Read-Type) ucl:Read-Type 'symbol)))
		 (declare (special ucl:Read-Type))
		 (send command :Execute *mailer* :arguments-override nil)
	       )
	     )
	     (parse-error "~S is not a command name." command)
	 )
    )
)

(defun read-and-execute-command-from-different-tables (stream tables)
"The command line parser.  Parses a command off Stream and then executes it."
  (declare (special *prompt-window*))
    (let ((command (catch 'read-command
		     (with-these-command-tables (tables) *prompt-window*
		       (read stream)
		     )
		   )
	  )
	 )
	 (if (typep command 'ucl:command)
	     (without-universal-command-tables *prompt-window*
	       (let ((ucl:Read-Type
		       (if (boundp 'ucl:Read-Type) ucl:Read-Type 'symbol)))
		 (declare (special ucl:Read-Type))
		 (send command :Execute *mailer* :arguments-override nil)
	       )
	     )
	     (parse-error "~S is not a command name." command)
	 )
    )
)



;-------------------------------------------------------------------------------

(defun simple-char (char &optional (error-p t))
"Coerces char into a simple (unfontified) character).  If it cannot be and
if error-p is true then barfs.
"
  (typecase char
    (character (int-char (char-code char)))
    (fixnum (code-char (char-code (int-char char))))
    (otherwise (if error-p (check-type char (or character fixnum)) char))
  )
)

(defun eol-found-p (stream)
"Is true if an end of line or end of file has been found on Stream."
  (declare (special *eof-found*))
  (ignore stream)
  (if (or *end-of-line-found-p*
	  (and (boundp '*eof-found*) *eof-found*)
      )
      :Eof
      nil
  )
)

(Defun skip-whitespace (stream &optional (last-char nil))
"Skips whitespace on stream.  Last char is the last char that was read in.
If we have an end of file condition then it returns :eof.
"
  (declare (special *eof-chars*))
  (or (eol-found-p stream)
      (and (characterp last-char)
	   (boundp '*eof-chars*)
	   (member last-char *eof-chars* :Test #'char=)
	   :Eof
      )
      (let ((char (Without-Whitespace-As-Eof
		    (let ((yw:*completion-characters* nil))
		         (sys:internal-read-char stream nil :Eof t)
		    )
		  )
	    )
	   )
	   (if (equal char :Eof)
	       char
	       (let ((char (Simple-Char char)))
		    (if (member char *whitespace-chars*)
			(skip-whitespace stream char)
			(values char last-char)
		    )
	       )
	   )
      )
  )
)

(defun cannot-be-zero (number)
"Barfs if number is zero or out of range, otherwise returns number."
  (cond ((equal 0 number)
	 (parse-error "Zero is an illegal message number/number expected here.")
	)
	((not number) (parse-error "A number is expected here."))
	((and (boundp '*mailer*) *mailer*
	      (send *mailer* :Current-Mailbox)
	      (> number (send (send *mailer* :Current-Mailbox) :Messagecnt))
	 )
	 (parse-error "~D is out of range for mailbox ~A" number
	      (print-short-mailbox-name (send *mailer* :Current-Mailbox))
	 )
	)
	(t number)
  )
)

(defun number-char-p (char)
  "Is true if char is a numeric."
  (and (characterp char) (member char *number-chars* :Test #'char-equal))
)

(defun read-simple-number (so-far stream)
"Reads a decimal number from Stream.  So-far is an accumulating result.
The number cannot be zero.
"
  (declare (special *eof-found*))
  (let ((char (With-Whitespace-As-Eof
		(sys:internal-read-char stream nil :Eof t)
	      )
	)
       )
       (if (equal :Eof char)
	   (Cannot-Be-Zero so-far)
	   (if (number-char-p char)
	       (read-simple-number
		 (+ (* 10 so-far) (- (char-code char) (char-code #\0))) stream
	       )
	       (progn (unread-char char stream)
		      (Cannot-Be-Zero so-far)
	       )
	   )
       )
  )
)

(defun as-number (char)
"Given a char out of the set {#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9} returns
the number 0, 1, 2, 3, 4, 5, 6, 7, 8 or 9.
"
  (if (number-char-p char)
      (- (char-code char) (char-code #\0))
      (parse-error "Number expected here.")
  )
)

(defun clean-up-rh (stream)
"Makes sure that the rubout handler's cursor is pointing to the scan pointer."
  (if (typep stream 'string-parsing-stream)
      nil
      (send stream :Eval-Inside-Yourself
	    '(tv:rh-set-position (tv:rh-scan-pointer))
      )
  )
)

(defun read-a-token (stream &optional (first-char (read-char stream t nil t)))
"Like sys:read-token, only reads a token from Stream with a special readtable."
  (Clean-Up-Rh stream)
  (let ((*package* (find-package 'keyword))
	(*readtable* *imap-readtable*)
       )
       (sys:read-token stream first-char)
  )
)

(defun read-sequence-in-parens (opening-char stream)
"Parses a sequence from stream that is inside parens.  We have already read in
the opening paren char.  The sort of thing that we might read in is
  (From rice And To Acuff)
We do this by reading a sequence in the normal way but with the matching
closing paren char being an EOF char.  When we have read in the sequence
inside the parens we carry on reading like normal
(parse-message-sequence-operators).
"
  (let-if (boundp 'zwei:*atom-word-syntax-table*)
	  ((zwei:*word-syntax-table* zwei:*atom-word-syntax-table*))
    (let ((closing-char (second (assoc opening-char *parenthesis-chars*))))
	 (letf-globally
	   (((aref zwei:*atom-word-syntax-table* (char-code opening-char))
	     zwei:word-delimiter
	    )
	    ((aref zwei:*atom-word-syntax-table* (char-code closing-char))
	     zwei:word-delimiter
	    )
	   )
	   (let ((paren-expr
		   (let ((*eof-found* nil))
			(declare (special *eof-found*))
			(catch :Sequence
			  (With-Paren-As-Eof opening-char
			    (parse-a-message-sequence stream nil)
			  )
			)
		   )
		 )
		)
		(without-whitespace-as-eof
		  (if (char-equal (peek-char nil *standard-input* t nil t)
				  closing-char
		      )
		      (read-char *standard-input* t nil t)
		      nil
		  )
		)
		(Clean-Up-Rh stream)
		(parse-message-sequence-operators stream paren-expr)
	   )
	 )
    )
  )
)

(defun read-simple-sequence (char stream number-so-far sequence-so-far)
"Reads a message sequence from Stream.  Char is the initial char that we
have already read in.  Number-so-far is a number if we are in the midst
of reading something like 42:200.  Sequence-so-far is defined if we are
reading something line >-42.
"
  (let ((seq
	  (case char
	    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
	     (Read-Simple-Number (as-number char) stream)
	    )
	    ((#\< #\> #\% #\*)
	     (if number-so-far
		 (parse-error "\"~C\" is an illegal here." char)
		 nil
	     )
	     (intern (string char) 'keyword)
	    )
	    (parse-error "\"~C\" is an illegal here." char)
	  )
	)
       )
       (if sequence-so-far
	   seq
	   (let ((new-char (Skip-Whitespace stream)))
	        (if (equal :Eof new-char)
		    (list seq)
		    (Read-Sequence-Of-Numbers-1 new-char stream nil seq)
		)
	   )
       )
  )
)

(defun Read-Sequence-Of-Numbers-No-Match
       (char stream number-so-far sequence-so-far)
"Reads a from Stream if we found a char which is not one of the obvious ones
that would be a simple message sequence specification.  If we get here we're
probably trying to read a sequence command like \"From rice\".  The command
itself should be able to take care of all of the necessary reading (completion
happens in the completing reader.  Thus, all we have to handle is the case
of named sequences, which are plucked out of the named sequence alist.
"
  (cond (number-so-far
	 (parse-error
	   "\"~C\" is an illegal message sequence character." char
	 )
	)
	(sequence-so-far
	 (throw 'read-command (Simple-Sequence sequence-so-far))
	)
	(t (let ((*Completion-Compulsory-P* t)
		 (*expecting-blip-from-mailbox-selector* t)
		 (*reading-a-filter* t)
		)
		(declare (special *expecting-blip-from-mailbox-selector*
				  *reading-a-filter*
			 )
		)
		(let ((result (catch 'named-sequence-found
				;; catch any named sequences.
				(read-a-token stream char)
			      )
		      )
		     )
		     (let ((entry (assoc (string result) *named-sequence-alist*
					 :Test #'string-equal
				  )
			   )
			  )
			  (if entry
			      (if (consp (second entry))
				  (apply 'Simple-Sequence (second entry))
				  (Simple-Sequence (second entry))
			      )
			      result
			  )
		     )
		)
	   )
	)
  )
)

(defun read-sequence-of-numbers-1 (char stream number-so-far sequence-so-far)
"Reads a sequence of numbers from Stream.  Char is the inital char that we
have already read in.  Number-so-far is a number if we are in the midst of
reading something like 42:200.  Sequence-so-far is defined if we are reading
something line >-42.
This function knows how to handle all of the different types of sequences items;
    Number chars -> a number
    <, >, %, * -> a canonical position
    :, +, - -> a relativised sequence
    (, {, [ -> a sequence in parens
    , -> a sequence is numbers in a comma separated list
"
  (case char
    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
     (Read-Sequence-Of-Numbers
       stream (Read-Simple-Number (as-number char) stream)
     )
    )
    ((#\< #\> #\% #\*)
     (read-simple-sequence char stream number-so-far sequence-so-far)
    )
    ((#\: #\+ #\-)
     (if (xor number-so-far sequence-so-far)
	 (Read-Sequence-Of-Numbers stream nil
	   (list (case char (#\: :Through) (#\+ :+) (#\- :-))
		 (or number-so-far sequence-so-far)
		 (Read-simple-sequence (Skip-Whitespace stream) stream nil
				       (xor number-so-far sequence-so-far)
		 )
	   )
	 )
	 (parse-error "\"~C\" is an illegal message sequence character." char)
     )
    )
    ((#\( #\{ #\[) (Read-Sequence-In-Parens char stream))
    (#\,
     (cond (number-so-far
	    (cons number-so-far
		  (Read-Sequence-Of-Numbers-1
		    (Skip-Whitespace stream) stream nil nil
		  )
	    )
	   )
	   (sequence-so-far
	    (cons sequence-so-far
		  (Read-Sequence-Of-Numbers-1
		    (Skip-Whitespace stream) stream nil nil
		  )
	    )
	   )
	   (t (parse-error
		"\"~C\" is an illegal message sequence character." char
	      )
	   )
     )
    )
    (otherwise (Read-Sequence-Of-Numbers-No-Match
		 char stream number-so-far sequence-so-far
	       )
    )
  )
)

(Defun Read-Sequence-Of-Numbers
       (stream &optional (number-so-far nil) (sequence-fo-far nil))
"Reads a message sequence of the form \"42, 200, 100:132\".  The sequence
may also contain command arguments like \"From acuff\".  We are not, however,
considering the case reading full boolean intermingled sequences (unless we have
parens).
"
  (let ((*Completion-Compulsory-P* nil)
	(*expecting-blip-for-message-number* t)
       )
       (declare (special *expecting-blip-for-message-number* *eof-found*))
       (Let ((char (if number-so-far
		       (With-Whitespace-As-Eof
			 (sys:internal-read-char stream nil :Eof t)
		       )
		       (let ((char (Skip-Whitespace stream)))
			    (if (equal :Eof char)
				char
				(progn (unread-char char stream)
				       (With-Non-Space-Whitespace-As-Eof
					 (sys:internal-read-char
					   stream nil :Eof t
					 )
				       )
				)
			    )
		       )
		   )
	     )
	    )
	    (if (equal char :Eof)
		(if number-so-far
		    (list number-so-far)
		    (if sequence-fo-far
			(list sequence-fo-far)
			nil
		    )
		)
		(let ((*reading-a-filter* nil))
		     (declare (special *reading-a-filter*))
		     (Read-Sequence-Of-Numbers-1
		       (simple-char char) stream number-so-far sequence-fo-far
		     )
		)
	    )
       )
  )
)

(defun Read-Token-Using-Completions
       (stream completions &optional (must-complete-p t))
"Reads in a token from Stream that could be one of the completions mentioned
in the list of completions Completions.  If must-complete-p is true then the
token must be an entry in Completions or we barf.
"
  (let ((*completion-function*
	  #'(lambda (string complete-type &optional (prefered-mode nil)
		     (complete-p-method :complete-p)
		    )
	      (ignore prefered-mode complete-p-method)
	      (Simple-Completer string completions complete-type)
	    )
	)
	(*completion-compulsory-p* must-complete-p)
	(*complete-to-command-p* nil)
       )
       (catch 'read-argument (Read-A-Token stream))
  )
)

(defun read-symbol-from-alist (stream alist)
"Reads a name which has a mapping in AList from Stream with respect."
  (let ((result (Read-Token-Using-Completions stream (mapcar #'second alist))))
       (let ((entry
	       (find-if #'(lambda (x) (string-equal (second x) result)) alist)
	     )
	    )
	    (if entry
		(first entry)
		(parse-error "The token ~S may only be one of ~{~A~^, ~}"
			     result (mapcar #'second alist)
		)
	    )
       )
  )
)

	      
(defun read-keyword (stream mailbox &optional (create-ok-p nil))
"Reads an IMAP keyword from Stream with respect to the keywords in Mailbox."
  (let ((keywords (and mailbox (Keyword-Names mailbox))))
       (let ((result (Read-Token-Using-Completions
		       stream (mapcar #'second keywords)
		     )
	     )
	    )
	    (let ((entry
		    (find-if #'(lambda (x) (string-equal (second x) result))
			     keywords
		    )
		  )
		 )
	         (if entry
		     (third entry)
		     (if (and create-ok-p (at-least-imap-3-p mailbox))
			 (if (yw-y-or-n-p
			       "~&Keyword ~S not defined for this mailbox.~%~
                                  Create it? "
			       result
			     )
			     result
			     (parse-error
			       "Keyword ~S not defined for this mailbox."
			       result
			     )
			 )
			 (parse-error "Keyword ~S not defined for this mailbox."
				      result
			 )
		     )
		 )
	    )
       )
  )
)

	      
(defun read-string (stream &optional (null-string-ok-p nil))
"Reads in a string from Stream.  If null-string-ok-p is true then it is ok for
the string to be empty.  If the user types in a quote delimited string then
we read a string, otherwise we just read in an atom (token).
"
  (declare (special *prompt-window* *eof-found*))
  (with-these-command-tables (nil) *prompt-window*
    (let ((char (Skip-Whitespace stream)))
         (if (equal :Eof char)
	     (if null-string-ok-p
		 ""
		 (parse-error "String expected.")
	     )
	     (case (Simple-Char char)
	       (#\" (unread-char char stream)
		    (Without-Whitespace-As-Eof (read stream))
	       )
	       (otherwise
		(format nil "~A"
		  (string-trim *whitespace-chars*
		    (format nil "~A"
		      (With-Whitespace-As-Eof (read-a-token stream char))
		    )
		  )
		)
	       )
	     )
	 )
    )
  )
)

(defun read-string-maybe-with-blip
       (stream null-string-ok-p mailbox-selector message-window)
"Reads a string from Stream.  Null-string-ok-p will allow null strings are
the reply if provided.  If the user blips on the mailbox selector window
then the function mailbox-selector will be called to process the blip,
if he clicks on a message window then message-window will be called
to process the blip.
"
  (let ((*expecting-blip-from-mailbox-selector*  mailbox-selector)
	(*expecting-blip-from-message-window*    message-window)
	(*expecting-blip-for-message-number*     nil)
       )
       (declare (special *expecting-blip-from-mailbox-selector*
			 *expecting-blip-from-message-window*
			 *expecting-blip-for-message-number*
		)
       )
       (remove-quoted-quotes (read-string stream null-string-ok-p))
  )
)

(defun parse-message-sequence-operators (stream first-arg)
"Parses a sequence of operator cennected message sequences.  This is called
when we have already successfully read in a simple message-sequence, which
is first-arg.  We now look for an operator like And or Or and, if we find
one, look for the second argument.  If there is no operator then we just
return the first arg.
"
  (declare (special *prompt-window*))
  (With-these-command-tables
    ((send *mailer* :operator-command-tables)) *prompt-window*
    (let ((char (skip-whitespace stream)))
         (if (equal :Eof char)
	     first-arg
	     (let ((result (catch 'read-command (read-a-token stream char))))
		  (if (equal result :Eof)
		      first-arg
		      (typecase result
			(ucl:command
			 (let ((*first-argument* first-arg))
			      (declare (special *first-argument*))
			      (catch :Sequence
				(send result :Execute *mailer*
				      :Arguments-Override nil
				)
			      )
			 )
			)
			(otherwise
			 (parse-error "Illegal message sequence.")
			)
		      )
		  )
	     )
	 )
    )
  )
)

(defun insert-rh-string (string stream &optional (backup-p nil))
"Inserts String into the rubout handler of Stream at the current typein point.
If backup-p is true then we back up by one char.
"
  (if backup-p
      (send stream :Eval-Inside-Yourself
	    `(decf (tv:rh-typein-pointer) ,backup-p)
      )
      nil
  )
  (send stream :Eval-Inside-Yourself `(tv:rh-insert-string ,string))
  string
)

(defun insert-sequence (seq stream)
"Inserts the printed representation of a message sequence Seq into the
rubout handler of Stream at the current typein point.
"
  (if (typep stream 'yw:string-parsing-stream)
      (progn (Insert-String-in-string " " stream 1)
	     (Insert-String-in-string
	       (make-label-from-filter
		 (send seq :Sequence-Specifier)
	       )
	       stream nil
	     )
      )
      (progn (Insert-Rh-String " " stream 1)
	     (Insert-Rh-String
	       (make-label-from-filter
		 (send seq :Sequence-Specifier)
	       )
	       stream nil
	     )
      )
  )
)


(defun parse-a-message-sequence-1 (stream default)
"An internal function of parse-a-message-sequence, which parses a message
sequence from the stream Stream.  If no sequence is found then a sequence
built from the default Default is returned.  If we have a prefix arg at this
point then we interst it at the appropriate typein point.
"
  (declare (special *prompt-window*))
  (multiple-value-bind (result sequence-so-far)
      (if (send *mailer* :Prefix-Argument)
	  (let ((sequence
		  (Simple-Sequence (send *mailer* :Prefix-Argument))
		)
	       )
	       ;;; Insert the prefix arg into the RHB.
	       (send *mailer* :set-prefix-argument nil)
	       (parallel-force-string-input
		 *prompt-window*
		 (make-label-from-filter
		   (send sequence :Sequence-Specifier)
		 )
		 nil
		 t
	       )
	       (catch 'read-command (Read-Sequence-Of-Numbers stream))
	  )
	  (catch 'read-command (Read-Sequence-Of-Numbers stream))
      )
      ;; We believe that we have successfully read in a sequence now.
    (let ((seq
	    (typecase result
	      (ucl:command
	       ;; just a command so execute it.
	       (catch :Sequence
		 (send result :Execute *mailer* :Arguments-Override nil)
	       )
	      )
	      (cons ;;; Just a sequence specifier so build a sequence object.
		    (make-a-sequence 'message-sequence :Owner *mailer*
		       :Mailbox (send *mailer* :Current-Mailbox)
		       :Sequence-Specifier (clean-up-numbers result)
		    )
	      )
	      (message-sequence result) ; We already have the sequence so ok.
	      (null (let ((def (Simple-Sequence default)))
			 ;;; We are going to take the default so make sure
			 ;;; it is a valid sequence.
			 (insert-sequence def stream)
			 def
		    )
	      )
	      (otherwise
	       (if sequence-so-far
		   (parse-error "Illegal message sequence: ~S." sequence-so-far)
		   (parse-error "Illegal message sequence: ~A." result)
	       )
	      )
	    )
	  )
	 )
	 (let ((next-result
		 ;;; Ok, we have a sequence now but there may be more
		 ;;; sequences after an operator command so try for this.
		 (if result
		     (parse-message-sequence-operators stream seq)
		     seq
		 )
	       )
	      )
	      (Clean-Up-Rh stream)
	      next-result
	 )
    )
  )
)

(defun Parse-A-Message-Sequence
       (stream &optional (default nil) (new-command-tables-p t))
"This is the top-level message sequence parsing function.  It parses a message
sequence from Stream.  If the user just hits a return then a sequence object
denoting Default is returned and its preinted representation is inserted into
the typein.  If new-command-tables-p is true then we bind up the special
message sequence command tables.  If it is not then we assume that someone
else has already (e.g. Reply.
"
  (declare (special *prompt-window*))
 (let ((*reading-a-sequence* t))
      (declare (special *reading-a-sequence*))
      (without-universal-command-tables *prompt-window*
       (with-these-command-tables
	 ((send *mailer* :message-sequence-command-tables) new-command-tables-p)
	 *prompt-window*
	 (if (eol-found-p stream)
	     (let ((seq (if (send *mailer* :Prefix-Argument)
			    (prog1 (simple-sequence
				     (send *mailer* :Prefix-Argument)
				   )
				   (send *mailer* :Set-Prefix-Argument nil)
			    )
			    (if default (Simple-Sequence default) nil)
			)
		   )
		  )
		  (if seq (Insert-Sequence seq stream) nil)
		  seq
	     )
	     (parse-a-message-sequence-1 stream default)
	 )
       )
      )
  )
)
  
;-------------------------------------------------------------------------------

(defun string-subst (new old in)
"Substitute the string New for Old in the string In.  Old and New do not have
to be of the same length.  This is not desctructive.
"
  (let ((index (search old in :Test #'string-equal)))
       (if index
	   (string-append
	     (subseq in 0 index)
	     new
	     (string-subst new old (subseq in (+ index (length old))))
	   )
	   in
       )
  )
)

(defun remove-spaces (string)
"Removes all spaces from String."
  (String-Subst "" " " string)
)

(defun merge-with-host (string defaults host)
"Merges a pathname for String using the host Host and defaults Defaults.  Thus,
String does not have to be a string refering to a host as it notmally has to
for defaulting.
"
  (if (find #\: string :Test #'char=)
      (fs:merge-pathname-defaults string defaults)
      (fs:merge-pathname-defaults
	(make-pathname :Host host
		       :Directory
		         (typecase defaults
			   (cons (second (assoc :Directory defaults)))
			   (pathname (pathname-directory defaults))
			   (otherwise nil)
			 )
		       :Defaults string
        )
	defaults
      )
  )
)

(defun Yw-Complete-Path
       (string char &optional
	(default `((:Host ,*User-Host*)
		   (:Directory ,(default-mailbox-directory))
		  )
	)
	(file-type *default-mailbox-file-type*)
       )
"Completes a pathname from String.  Default is used in pathname merging.
File type is the default type for the file.
"
  (ignore char)
  (let ((path (merge-with-host (string-downcase string) default *user-host*)))
       (multiple-value-bind (new-path status)
	   (letf ((#'tv:notify #'(lambda (&rest ignore))))
		 (let ((*cache-directory-lists-p* t))
		      ;;; but still only if the user says so. (default yes).
		      (fs:complete-pathname
			path
			(string-downcase (send path :String-For-printing))
			file-type :Newest :Old
		      )
		 )
	   )
	 (ignore status)
	 (let ((real-path
		 (if (equal (net:parse-host *user-host*) (send path :Host))
		     (send (fs:default-pathname new-path) :String-For-Host)
		     (send (fs:default-pathname new-path)
			   :Short-String-For-Printing
		     )
		 )
	       )
	      )
	      (if (equal new-path path)
		  string
		  (remove-spaces real-path)
	      )
	 )
       )
  )
)

(defun complete-pathname (substring type default file-type)
"Completes a Substring into a pathname using Type as the completion type.
Default is a pathname default to use for pathname merging.  File type is the
default file type for the file to complete to.
"
  (if (not (equal type :Recognition))
      (beep)
      (let ((result (yw-complete-path substring nil default file-type)))
	   (values result (list result) t nil nil)
      )
  )
)


(defun complete-pathname-initially-trying-streams
       (substring type default file-type)
"Completes a substring into a pathname using Type as the completion type.
First of all, however, it tries to achieve a completion out of the set of
open mailstream names.  Default is a pathname default to use for pathname
merging.  File type is the default file type for the file to complete to.
"
  (if (not (equal type :Recognition))
      (beep)
      (let ((names (loop for str in *all-open-imap-streams*
			 when (send str :Open-P)
			 collect (send str :Mailbox-name)
		   )
	    )
	   )
	   (multiple-value-bind
	     (string completions completed-p initial-string completed-string)
	       (Simple-Completer substring names type)
	     (ignore initial-string completions string)
	     (if completed-p
		 (values completed-string completions t nil nil)
		 (if string
		     (values string completions nil nil nil)
		     ;;; We failed to complete from a mailstrem name so try a
		     ;;; file instead.
		     (let ((result
			     (let ((fs:*merge-unix-types* nil))
				  (yw-complete-path substring nil
				    (or default
				       `((:Host ,*User-Host*)
					 (:Directory
					   ,(yw:default-mailbox-directory)
					 )
					)
				    )
				    (or file-type *default-mailbox-file-type*)
				  )
			     )
			   )
			  )
			  (values result (list result) t nil nil)
		     )
		 )
	     )
	   )
      )
  )
)


(defun Read-Mailbox-Name-String
       (stream last-arg-p completion-defaults file-type completion-function)
"Reads in a string from Stream which denotes the name of a mailbox.  This could
be either the name of an open mailbox or a filename.    Completion-Defaults
is a pathname default to use for pathname merging.  File-type is the default 
file type for the file to complete to.
If last-arg-p is true then NL is alowed to end the string, otherwise whitespace
is the EOF specifier.
"
  (let ((*completion-function*
	  (or completion-function 'Complete-Pathname-Initially-Trying-Streams)
	)
	(*enable-completion-on-eof-chars-p* nil)
	(*reading-a-mailbox* t)
	(function
	  (or completion-function
	    #'(lambda (substring type &rest ignore)
		(Complete-Pathname substring type completion-defaults
				   file-type
		)
	      )
	  )
	)
       )
       (declare (special *reading-a-mailbox*))
       (letf (((first (tv:completion-function tv:rh-completion-handler))
	       function
	      )
	     )
	     (if last-arg-p
		 (with-nl-as-eof
		   (Read-string-Maybe-With-Blip stream t t nil)
		 )
		 (with-whitespace-as-eof
		   (Read-string-Maybe-With-Blip stream t t nil)
		 )
	     )
       )
  )
)

(defun Read-Mailbox-Name
       (stream &optional (last-arg-p nil) (default *default-mailbox-name*)
	(completion-defaults `((:Host ,*User-Host*)
			       (:Directory ,(yw:default-mailbox-directory))
			      )
        )
	(file-type *default-mailbox-file-type*)
	(completion-function nil)
       )
"Reads in a string from Stream which denotes the name of a mailbox.  This could
be either the name of an open mailbox or a filename.    Completion-Defaults
is a pathname default to use for pathname merging.  File-type is the default 
file type for the file to complete to.
If last-arg-p is true then NL is alowed to end the string, otherwise whitespace
is the EOF specifier.
"
  (declare (special *eof-found*))
  (if *End-Of-Line-Found-P*
      (progn (Insert-Rh-String " " stream 1)
	     (Insert-Rh-String (string default) stream nil)
	     (string default)
      )
      (let ((string (Read-Mailbox-Name-String
		      stream last-arg-p completion-defaults file-type
		      completion-function
		    )
	    )
	   )
	   (let ((real-string
		   (and string (string-trim *whitespace-chars* string))
		 )
		)
	        (if (and real-string (not (equal "" real-string)))
		    real-string
		    (if default
			(progn (Insert-Rh-String (string default) stream nil)
			       (string default)
			)
			""
		    )
		)
	   )
      )
  )
)

;-------------------------------------------------------------------------------

(defun read-in-a-mailbox-name (&optional (default nil))
"Reads in a mailbox name to return a mailbox.
 Default is the default mailbox name.
"
  (declare (values mailbox-name string-read-in))
  (declare (special *line-ended*))
  (if *line-ended*
      (progn (if default
		 (format *query-io* "~A"
			 (print-short-mailbox-name default)
		 )
		 nil
	     )
	     (values default nil)
      )
      (let ((string (string-trim *whitespace-chars*
				 (Read-Mailbox-Name *standard-input* t default)
		    )
	    )
	   )
	   (let ((mailbox
		   (or (Find-Mailbox-From-Name (Check-User-Mailbox string))
		       (and (equal string "") default)
		       (find-if #'(lambda (x)
				    (let ((match
					    (or
					      (search
						(the string string)
						(the string
						     (send x :Pretty-String)
						)
						:Test #'char-equal
					      )
					      (search (the string string)
						      (the string
							   (send x :mailbox)
						      )
						      :Test #'char-equal
					      )
					    )
					  )
					 )
					 (and match
					      (or (equal
						    (length
						    (All-Open-Imap-Streams-Safe)
						    )
						    1
						  )
						  (yw-y-or-n-p
						    "~&Do you mean ~A"
						    (send x :Pretty-String)
						  )
					      )
					 )
				    )
				  )
				  (All-Open-Imap-Streams-Safe)
		       )
		   )
		 )
		)
		(values mailbox string)
	   )
      )
  )
)

;-------------------------------------------------------------------------------

(defun read-rule (stream &optional (must-complete-p t))
"Reads in the name of a rule.  Used by rule editing commands."
  (declare (values rule-or-string found-rule-p))
  (let ((rule-names (mapcar #'rule-name *all-rules*)))
       (let ((result (read-token-using-completions
		       stream rule-names must-complete-p
		     )
	     )
	    )
	    (let ((entry (Rule-Named result)))
	         (if entry
		     (values entry t)
		     (if must-complete-p
			 (parse-error "Undefined rule name.")
			 (values result nil)
		     )
		 )
	    )
       )
  )
)

(defun read-rule-set (stream &optional (must-complete-p t))
"Reads in the name of a rule-set.  Used by rule set editing commands."
  (declare (values rule-or-string found-rule-p))
  (let ((rule-set-names (mapcar #'rule-set-name *all-rule-sets*)))
       (let ((result (read-token-using-completions
		       stream rule-set-names must-complete-p
		     )
	     )
	    )
	    (let ((entry (Rule-Set-Named result)))
	         (if entry
		     (values entry t)
		     (if must-complete-p
			 (parse-error "Undefined rule set name.")
			 (values result nil)
		     )
		 )
	    )
       )
  )
)

;-------------------------------------------------------------------------------