;;; -*- 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 message-sequence-chars-p (list)
  (declare (optimize (safety 0)))
  (if list
      (and (member (first list) '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\:)
		   :Test #'char-equal
	   )
	   (message-sequence-chars-p (rest list))
      )
      t
  )
)

(defun string-search-1 (for in start end length)
  (declare (optimize (speed 3) (safety 0)))
  (let ((index (si:%string-search-char (aref for 0) in start end)))
       (if index
	   (if (si:%string-equal for 0 in index length)
	       index
	       (string-search-1 for in (+ 1 index) end length)
	   )
	   nil
       )
  )
)

(defun String-Search (for in &optional (start2 0))
  (declare (optimize (speed 3) (safety 0)))
  (declare (inline String-Search-1))
  (let ((sys:alphabetic-case-affects-string-comparison nil)
	(for-length (length (the string for)))
	(in-length (length (the string in)))
       )
       (if (> for-length (- in-length start2))
	   nil
	   (if (> for-length 0)
	       (String-Search-1 for in start2 (- in-length for-length -1)
				for-length
               )
	       start2
	   )
       )
  )
)

(defun maybe-wild-string-search (for in mailstream &optional (start2 0))
  "Searches for For in the string In starting at Start2 in the string In.
If we have wild searching enabled then we wild search."
  (if (feature-enabled-p :Wildcard.Searches mailstream)
      (fs:Compare-String-Full (fs:parse-search-string for '(#\* #\%) 0 0)
			      nil in (length in) 0
      )
      (String-Search for in start2)
  )
)

(defun find-one (separators text index mailstream)
"Finds on of a list of separators in Text, starting from Index.  Returns the
closest index to Index.
"
  (if index
      (let ((results
	      (remove nil
		(mapcar #'(lambda (sep)
			    (let ((new-index (Maybe-Wild-String-Search
					       sep text mailstream index
					     )
				  )
				 )
			         (if new-index
				     (Maybe-Wild-String-Search
				       (string-trim *whitespace-chars* sep)
				       text mailstream new-index
				     )
				     nil
				 )
			    )
			   )
			   separators
		)
	      )
	    )
	   )
	   (if results (apply #'min results) nil) 
      )
      nil
  )
)

(defun Split-Up-Text
       (text separators mailstream
	&optional (start-of-message 0) (index 0) (result nil)
       )
"Splits up Text into separate messages such that messages are delimitted by
the separators enumerated in Separators.
"
  ;; Start-of-message is the start of the message we're looking at.
  ;; Index is the place to look from.  Can be ahead of Start-of-message so
  ;;   that we don't find the current message again.
  ;; Result is an accumulating parameter. 
  (if index
      (let ((next-index (find-one separators text (+ 1 index) mailstream)))
	   (split-up-text text separators mailstream next-index
			  (find-one (list (string #\newline)) text next-index
				    mailstream
			  )
			  (cons (nsubstring text start-of-message next-index)
				result
			  )
	   )
      )
      (reverse result)
  )
)

(defun make-stream-and-headers-from-digest (name strings source-stream)
"Given a new name for our digested mailbox and the list of strings for the
 messages that have been chopped out of the original message and the stream
 that the original message came from, makes a new fale stream that pretends
 to be an IMAP stream looking at the messages denoted by Strings.  It then
 makes a window for the undigest as appropriate.
"
  (let ((stream
	  (make-instance 'fake-stream :Stream source-stream :Messages strings
			 :mailbox name
			 :Messagecnt (length strings)
			 :Recentcnt 0
			 :Read-Only-P t
          )
	)
       )
       (send *mailer* :Initialize-Mailstream stream)
       (send stream :parse-messages)
       (send *mailer* :open-mailbox-for name stream nil t)
  )
)

(defun make-digest-window-name (message)
"Given a message, makes a name for a mailbox for the undigested form."
  (let ((subject
	  (map-fetch-subject (send message :Mailstream) (number-of message))
	)
       )
       (format nil "UnDigestified ~A" subject)
  )
)

(defun post-process-digested-message (message mailstream)
"Given a digested message fixes it up so that it's more like a normal message."
  (loop for (from to) in *digest-lines-to-modify*
	for index = (Maybe-Wild-String-Search
		      (the string from) (the string message) mailstream
		    )
	when index do
	(loop for i from 0 to (- (length to) 1) do
	      (setf (aref message (+ index i)) (aref to i))
	)
  )
  message
)

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

;;; Sequences...

(defflavor message-sequence
	   ((sequence-specifier nil)
	    mailbox
	    owner
	    (location-of-current-message :Unbound)
	    (messages-selected nil)
	    (computed-order :undefined)
	    (superior nil)
	    (should-be-invalidated nil)
	    (canonical-specifier nil)
	    (associated-p nil)
	   )
	   ()
  :Initable-Instance-Variables
  :Gettable-Instance-Variables
  :Settable-Instance-Variables
)

(defmethod (message-sequence :reconstruction-init-plist) ()
  `(:Sequence-Specifier ,sequence-specifier
    :location-of-current-message :Unbound
    :messages-selected nil
    :computed-order :Undefined
    :superior ,superior
    :should-be-invalidated nil
    :canonical-specifier nil
    :Associated-P nil
   )
)

(defun associated-p (sequence)
  (send sequence :associated-p)
)

(defun inverse-of-key (key mailstream)
"Returns the inverse operator for Key."
  (if (At-Least-Imap-3-P mailstream)
      (or (get key :Sequence-Inverse)
	  (get key :Sequence-Inverse-Old)
      )
      (get key :Sequence-Inverse-Old)
  )
)

(defun inverse-of-term (term mailstream)
  (if (and (consp term) (keywordp (first term)))
      (let ((result (inverse-of-key (first term) mailstream)))
	   (if result
	       (cons result (rest term))
	       nil
	   )
      )
      nil
  )
)

(setf (get :Sequence-Since	:Sequence-Inverse) :Sequence-Before)
(setf (get :Sequence-Before 	:Sequence-Inverse) :Sequence-Since)

(setf (get :Sequence-Old        :Sequence-Inverse) :Sequence-Recent)
(setf (get :Sequence-Recent     :Sequence-Inverse) :Sequence-Old)

(setf (get :Sequence-Seen       :Sequence-Inverse) :Sequence-~Seen)
(setf (get :Sequence-~Seen      :Sequence-Inverse) :Sequence-Seen)

(setf (get :Sequence-Keyword    :Sequence-Inverse) :Sequence-~Keyword)
(setf (get :Sequence-~Keyword   :Sequence-Inverse) :Sequence-Keyword)

(setf (get :Sequence-Flagged    :Sequence-Inverse) :Sequence-~Flagged)
(setf (get :Sequence-~Flagged   :Sequence-Inverse) :Sequence-Flagged)

(setf (get :Sequence-Deleted    :Sequence-Inverse) :Sequence-~Deleted)
(setf (get :Sequence-~Deleted   :Sequence-Inverse) :Sequence-Deleted)

(setf (get :Sequence-Answered   :Sequence-Inverse) :Sequence-~Answered)
(setf (get :Sequence-~Answered  :Sequence-Inverse) :Sequence-Answered)

(setf (get :Sequence-All        :Sequence-Inverse) :Sequence-~All)
(setf (get :Sequence-~All       :Sequence-Inverse) :Sequence-All)

(setf (get :Sequence-New        :Sequence-Inverse) :Sequence-~New)
(setf (get :Sequence-~New       :Sequence-Inverse) :Sequence-New)

(setf (get :Sequence-~Since     :Sequence-Inverse) :Sequence-Since)

(setf (get :Sequence-~Before    :Sequence-Inverse) :Sequence-Before)

(setf (get :Sequence-~Old       :Sequence-Inverse) :Sequence-Old)

(setf (get :Sequence-~Recent    :Sequence-Inverse) :Sequence-Recent)

(setf (get :Sequence-BCC        :Sequence-Inverse) :Sequence-~BCC)
(setf (get :Sequence-~BCC       :Sequence-Inverse) :Sequence-BCC)

(setf (get :Sequence-Body       :Sequence-Inverse) :Sequence-~Body)
(setf (get :Sequence-~Body      :Sequence-Inverse) :Sequence-Body)

(setf (get :Sequence-CC         :Sequence-Inverse) :Sequence-~CC)
(setf (get :Sequence-~CC        :Sequence-Inverse) :Sequence-CC)

(setf (get :Sequence-Field      :Sequence-Inverse) :Sequence-~Field)
(setf (get :Sequence-~Field     :Sequence-Inverse) :Sequence-Field)

(setf (get :Sequence-From       :Sequence-Inverse) :Sequence-~From)
(setf (get :Sequence-~From      :Sequence-Inverse) :Sequence-From)

(setf (get :Sequence-On         :Sequence-Inverse) :Sequence-~On)
(setf (get :Sequence-~On        :Sequence-Inverse) :Sequence-On)

(setf (get :Sequence-Subject    :Sequence-Inverse) :Sequence-~Subject)
(setf (get :Sequence-~Subject   :Sequence-Inverse) :Sequence-Subject)

(setf (get :Sequence-Text       :Sequence-Inverse) :Sequence-~Text)
(setf (get :Sequence-Text~      :Sequence-Inverse) :Sequence-Text)

(setf (get :Sequence-To         :Sequence-Inverse) :Sequence-~To)
(setf (get :Sequence-~To        :Sequence-Inverse) :Sequence-To)



(setf (get :Sequence-Seen       :Sequence-Inverse-Old) :Sequence-UnSeen)
(setf (get :Sequence-UnSeen     :Sequence-Inverse-Old) :Sequence-Seen)

(setf (get :Sequence-Keyword    :Sequence-Inverse-Old) :Sequence-UnKeyword)
(setf (get :Sequence-UnKeyword  :Sequence-Inverse-Old) :Sequence-Keyword)

(setf (get :Sequence-Flagged    :Sequence-Inverse-Old) :Sequence-UnFlagged)
(setf (get :Sequence-UnFlagged  :Sequence-Inverse-Old) :Sequence-Flagged)

(setf (get :Sequence-Deleted    :Sequence-Inverse-Old) :Sequence-UnDeleted)
(setf (get :Sequence-UnDeleted  :Sequence-Inverse-Old) :Sequence-Deleted)

(setf (get :Sequence-Answered   :Sequence-Inverse-Old) :Sequence-UnAnswered)
(setf (get :Sequence-UnAnswered :Sequence-Inverse-Old) :Sequence-Answered)

(setf (get :Sequence-And :Polyadic-P) t) 
(setf (get :Sequence-Or  :Polyadic-P) t) 

(defun merge-operators (expr)
  (if (and (consp expr) (keywordp (first expr)) (get (first expr) :Polyadic-P))
      (let ((op (first expr)))
	   (cons op (loop for arg in (rest expr)
			  append (if (and (consp arg) (equal (first arg) op))
				     (mapcar 'Merge-Operators (rest arg))
				     (list (Merge-Operators arg))
				 )
		    )
	   )
      )
      (if (consp expr)
	  (cons (first expr) (mapcar 'Merge-Operators (rest expr)))
	  expr
      )
  )
)

(defun simple-term-p (x mailstream)
  (and (consp x)
       (or (assoc (first x) *simple-term-specifiers* :Test #'eq)
	   (assoc (Inverse-Of-Key (first x) mailstream)
		  *simple-term-specifiers* :Test #'eq
           )
       )
  )
)

(defun conjunct-lessp (x y mailstream)
  (let ((pointx (Simple-Term-P x mailstream))
	(pointy (Simple-Term-P y mailstream))
       )
       (if pointx
	   (or (not pointy)
	       (> (length pointx) (length pointy))
	   )
	   (if pointy
	       nil
	       (string-lessp (format nil "~S" x) (format nil "~S" y))
	   )
       )
  )
)

(defun reorder-conjuncts (expr mailstream)
  (if (consp expr)
      (if (member (first expr) '(:Sequence-And :Sequence-Or))
	  (cons (first expr)
		(sort (loop for x in (rest expr)
			    collect (Reorder-Conjuncts x mailstream)
		      )
		      #'(lambda (x y) (Conjunct-Lessp x y mailstream))
		)
	  )
	  (cons (first expr)
		(loop for x in (rest expr)
		      collect (Reorder-Conjuncts x mailstream)
		)
	  )
      )
      expr
  )
)

(defun Canonicalise-Expr (expr mailstream)
"Canonicalises a search expression with respect to the mailstream."
  (let ((result (Canonicalise-Expr-1 (merge-operators expr) mailstream)))
       (let ((merged (Reorder-Conjuncts (merge-operators result) mailstream)))
	    (if (equalp merged result)
		(map-tree #'(lambda (x) (if (typep x 'closure) (funcall x) x))
			  result
		)
		(Canonicalise-Expr merged mailstream)
	    )
       )
  )
)

(defun canonicalise-expr-1 (expr mailstream)
  (if (consp expr)
      (case (first expr)
	(:Sequence-Or
	 `(:Sequence-Not
	    (:Sequence-And
	      ,@(loop for x in (rest expr)
		      collect (Canonicalise-Expr-1
				`(:Sequence-Not ,x) mailstream
			      )
		)
	    )
	  )
	)
	(:Sequence-Not
	 (let ((canonicalised (canonicalise-expr-1 (second expr) mailstream)))
	      (if (and (consp canonicalised)
		       (equal :Sequence-Not (first canonicalised))
		  )
		  (second canonicalised)
		  (let ((inverse (Inverse-Of-Term canonicalised mailstream)))
		       (if inverse
			   inverse
			  `(:Sequence-Not ,canonicalised)
		       )
		  )
	      )
	 )
	)
	(otherwise
	 (cons (first expr)
	       (loop for x in (rest expr)
		     collect (Canonicalise-expr-1 x mailstream)
	       )
	 )
	)
      )
      (if (typep expr 'Message-Sequence)
	  (Canonicalise-Expr-1 (send expr :Sequence-Specifier) mailstream)
	  expr
      )
  )
)

(defmethod (Message-Sequence :canonicalise-specifier) (&optional (force-p nil))
  (if (and (not force-p) canonical-specifier)
      canonical-specifier
      (progn (setq canonical-specifier
		   (Canonicalise-Expr sequence-specifier
				      (if (boundp-in-instance self 'mailbox)
					  mailbox
					  nil
				      )
		   )
	     )
	     canonical-specifier
      )
  )
)

(defun server-searchable-subset (of-sequence-args)
  (loop for yes? in of-sequence-args
	while (assoc (first yes?) *simple-term-specifiers* :Test #'eq)
	collect yes? into yes
	finally (return yes (set-difference of-sequence-args yes))
  )
)

(defmethod (message-sequence :UnDigestify) (message)
"Given a message, generates an undigestified form of it and puts it into a new
 window.
"
  (let ((message (descriptor-of message (send self :Mailstream))))
       (let ((name (make-digest-window-name message)))
	    (if (send *mailer* :Find-Mailbox name)
		nil
	        (multiple-value-bind (body header)
		    (map-fetch-message
		      (send message :Mailstream) (number-of message)
		    )
		  (let ((messages
			  (split-up-text body *digest-separators* mailbox
					 0 0 nil
			  )
			)
		       )
		       (Make-Stream-And-Headers-From-Digest
			 name
			 (cons (string-append header (first messages))
			       (mapcar #'Post-Process-Digested-Message
				       (rest messages)
			       )
			 )
			 (send message :Mailstream)
		       )
		  )
		)
	    )
	    (send *mailer* :Make-Window-Current
		  (assoc name (send *mailer* :All-Summary-Windows)
			 :Test #'equal
		  )
	    )
	    (send *mailer* :Set-Current-Mailbox
		  (send *mailer* :Find-Mailbox name)
	    )
	    (send *mailer* :Set-Current-Sequence nil)
       )
  )
)

(defun make-digest-buffer-name (sequence)
  (format nil "Digest of \"~A\""
	  (make-label-from-filter (send sequence :sequence-specifier))
  )
)

(defmethod (message-sequence :Digestify) ()
"Generates a digestified form of the sequence into zmacs."
  (multiple-value-bind (frame zwei:*window*) (find-zmacs-frame)
    (declare (special zwei:*window*))
    (let ((buffer-name (Make-Digest-Buffer-Name self)))
	 (if (Find-Mail-Buffer buffer-name)
	     (inside-zmacs (frame zwei:*window*)
	       (zwei:make-buffer-current (Find-Mail-Buffer buffer-name))
	       (send zwei:*window* :Mouse-Select)
	     )
	     (inside-zmacs (frame zwei:*window*)
	       (let ((buffer
		       (yw-zwei:Open-digest-Buffer
			 (Make-Digest-Buffer-Name self) self
		       )
		     )
		     (*really-dont-query* t)
		    )
		    (declare (special *really-dont-query*))
		    (pushnew buffer zwei:*sent-message-list*)
		    (putprop buffer owner :Source-Mailer)
		    (putprop buffer self :message-sequence)
		    (putprop buffer :Digest :buffer-type)
		    (send buffer :activate t)
		    (zwei:make-buffer-current buffer)
		    (yw-zwei:do-any-necessary-redisplays
		      frame zwei:*window* nil buffer
		    )
	       )
	     )
	 )
    )
  )
)

(defmethod (Message-Sequence :Invalidate-Computed-Order) ()
  (setq computed-order :Undefined)
  (setq should-be-invalidated nil)
)

(defmethod (Message-Sequence :Maybe-Invalidate-Computed-Order) ()
  (if should-be-invalidated
      (send self :Invalidate-Computed-Order)
      nil
  )
)

(defmethod (Message-Sequence :Maybe-Add-To-Computed-Order) (descriptor)
  (if (equal computed-order :Undefined)
      nil ;;; We'll get this message the next time around if need be.
      (if (and
	    (not (member descriptor computed-order))
	    (send self :Accept-Message-P descriptor)
	  )
	  (send self :graft-in-message descriptor)
	  nil ;;; we've already got the message.
      )
  )
)

(defmethod (Message-Sequence :Mark-Computed-Order-For-Invalidation) (descriptor)
  (if (equal computed-order :Undefined)
      nil ;;; We're already invalidated.
      (if (member descriptor computed-order)
	  (setq should-be-invalidated t)
	  nil ;;; we've already got the message.
      )
  )
)

(defmethod (Message-Sequence :Graft-In-Message) (descriptor)
  (setq should-be-invalidated t)
  (setq computed-order (append computed-order (list descriptor)))
)

(defmethod (Message-Sequence :associated-buffers) ()
  (loop for buffer in zwei:*zmacs-buffer-list*
	when (equal self (get buffer :Message-Sequence))
	collect buffer
  )
)

(defmethod (Message-Sequence :After :Init) (ignore)
  (if (not (listp sequence-specifier))
      (setq sequence-specifier (list sequence-specifier))
      nil
  )
  (if (boundp-in-instance self 'mailbox)
      (send self :canonicalise-specifier)
      nil
  )
)

(defmethod (Message-Sequence :Print-Self) (stream depth slashify)
  (ignore depth)
  (multiple-value-bind (ignore error-p)
    (catch-error
      (if (and (boundp-in-instance self 'owner)
	       (boundp-in-instance self 'mailbox)
	  )
	  (if (and owner mailbox)
	      (if (or slashify *dbg*)
		  (if (not sequence-specifier)
		      (format stream "#<Seq ~>"
			(list mailbox nil (send self :short-name))
		      )
		      (format stream "#<Seq ~, ~>"
			(list sequence-specifier nil
			      (make-label-from-filter sequence-specifier)
			)
			(list mailbox nil (send self :short-name))
		      )
		  )
		  (if (not sequence-specifier)
		      (format stream "All Messages")
		      (format stream "~A"
			(make-label-from-filter sequence-specifier)
		      )
		  )
	      )
	      (if (or slashify *dbg*)
		  (if (not sequence-specifier)
		      (format stream "#<Seq {UnAssigned to mailbox}>")
		      (format stream "#<Seq ~, {UnAssigned to mailbox}>"
			(list sequence-specifier nil
			      (make-label-from-filter sequence-specifier)
			)
		      )
		  )
		  (if (not sequence-specifier)
		      (format stream "All Messages {UnAssigned to mailbox}")
		      (format stream "~A"
			(make-label-from-filter sequence-specifier)
		      )
		  )
	      )
	  )
	  (format stream "#<Seq {Uninitialised}>")
      )
      nil
    )
    (if error-p
	(format stream "<Sequence ????>")
	nil
    )
  )
)

(defmethod (message-sequence :keyword-data-for) (number)
  (let ((all (keyword-names (send self :mailstream))))
       (let ((for-message
	       (loop for key in all
		     when (send self :Flag-Seen number
				:\\keyword (first key))
		     collect key
	       )
	     )
	    )
	    (let ((not-set (set-difference all for-message)))
		 (values for-message not-set all)
	    )
       )
  )
)

(defmethod (Message-Sequence :Through) (message from to)
  (let ((message-number (Decanonicalise-Number message))
	(real-from (Decanonicalise-Number from))
	(real-to (Decanonicalise-Number to))
       )
       (and (>= message-number real-from) (<= message-number real-to))
  )
)

(defmethod (Message-Sequence :+) (message from increment)
  (let ((message-number (Decanonicalise-Number message))
	(from (Decanonicalise-Number from))
       )
       (and (>= message-number from) (<= message-number (+ from increment)))
  )
)

(defmethod (Message-Sequence :-) (message from increment)
  (let ((message-number (Decanonicalise-Number message))
	(from (Decanonicalise-Number from))
       )
       (and (<= message-number from) (>= message-number (- from increment)))
  )
)

(defmethod (Message-Sequence :Mailstream) ()
  mailbox
)

(defmethod (Message-Sequence :Short-Name) ()
  (Print-Short-Mailbox-Name (send self :mailstream))
)

(defmethod (Message-Sequence :Mailbox-name) ()
  (send mailbox :Mailbox)
)

(defun after-backslash (thing)
  (etypecase thing
    (symbol (after-backslash (symbol-name thing)))
    (string (let ((index (position #\\ (the string thing) :Test #'char=)))
	         (if index (after-backslash (subseq thing (+ 1 index))) thing)
	    )
    )
  )
)
	
(defun in-yw (string)
  (intern string 'yw)
)
	
(defmethod (Message-Sequence :Search-For) (class &optional (text nil))
  (let ((ip:*tcp-stream-whostate* (format nil "IMAP Search for ~A" class)))
       (apply 'map-search (send self :Mailstream)
	      (if text
		  (list (In-Yw (After-Backslash class))(format nil "~A" text))
		  (list (In-Yw (After-Backslash class)))
	      )
       )
  )
)

(defmethod (Message-Sequence :Search-For-conjunction) (items)
  (let ((imap-items
	  (loop for (x . args) in items
		collect
		  (cons (second (assoc x *simple-term-specifiers* :Test #'eq))
			args
		  )
	  )
	)
       )
       (let ((string (with-output-to-string (*standard-output*)
		       (format t "IMAP Search for ")
		       (loop for (command . args) in imap-items do
			     (if args
				 (format t "~A ~{~A~^, ~}" command args)
				 (format t "~A" command)
			     )
			     (format t " ")
		       )
		     )
	     )
	    )
	    (let ((ip:*tcp-stream-whostate* string))
		 (apply 'map-search (send self :Mailstream)
			(apply #'append imap-items)
		 )
	    )
       )
  )
)

(defmethod (Message-Sequence :actually-get-field)
	   (name cache-function field-function message-number preemptions)
 (let ((ip:*tcp-stream-whostate* (string-append "Get " name)))
      (funcall field-function (send self :Mailstream)
	       (if preemptions
		   (let ((total
			   (getstreamprop (send self :Mailstream) :Messagecnt)
			 )
			)
			(loop for i from 0
			      to (min preemptions (- total message-number))
			      unless (send self :Cache-Entry-Present-For
					   (+ i message-number)
					   cache-function
				     )
			      collect (+ i message-number)
			)
		   )
		   message-number
	       )
      )
 )
)

(defun message-cache-for (message-number stream &optional (error-p t))
  (map-elt (getstreamprop stream :messagearray) message-number stream error-p)
)

(defmethod (Message-Sequence :record-for) (message-number)
  (Message-Cache-For message-number (send self :Mailstream))
)

(defmethod (Message-Sequence :cache-entry-for) (message-number cache-function)
  (let ((msg-record (send self :Record-For message-number)))
       (if cache-function
	   (let ((result (funcall cache-function msg-record)))
		(if (equal :Unbound result)
		    (values nil nil)
		    (values result t)
		)
	   )
	   (values nil nil)
       )
  )
)

(defmethod (Message-Sequence :cache-entry-present-for)
	   (message-number cache-function)
  (let ((msg-record (send self :Record-For message-number)))
       (not (equal :unbound (funcall cache-function msg-record)))
  )
)

(defmethod (Message-Sequence :Add-Search-Cache-Entry) (entry)
  (send (send self :Mailstream) :Add-Search-Cache-Entry entry)
)

(defmethod (Message-Sequence :Matching-Search-Cache-Entry)
	   (search-class search-string &optional (conjunction nil))
  (send (send self :Mailstream) :Matching-Search-Cache-Entry
	search-class search-string conjunction
  )
)

(defmethod (Message-Sequence :Perform-Search-For-Conjunction) (specifiers)
  (let ((entry (send self :Matching-Search-Cache-Entry nil nil specifiers)))
       (if entry
	   (Search-Cache-Entry-Numbers entry)
	   (let ((new-values (send self :Search-For-Conjunction specifiers)))
		(send self :add-search-cache-entry
		      (make-search-cache-entry
			:Search-Conjunction specifiers
			:Search-Class nil
			:Search-String nil
			:Numbers new-values
			:Mailstream (send self :Mailstream)
		      )
		)
		new-values
	   )
       )
  )
)

(defmethod (Message-Sequence :perform-search)
	   (message-number cache-function search-class search-string
	    go-ahead-and-cache-p value-to-cache
	   )
  (let ((msgrecord (send self :Record-For message-number))
	(entry (send self :Matching-Search-Cache-Entry
		     search-class search-string
	       )
	)
       )
       (if entry
	   (values
	     nil (member message-number (Search-Cache-Entry-Numbers entry))
	   )
	   (let ((new-values
		   (send self :Search-For search-class search-string)
		 )
		)
		(send self :add-search-cache-entry
		      (make-search-cache-entry
			:Search-Class search-class
			:Search-String search-string
			:Numbers new-values
			:Mailstream (send self :Mailstream)
		      )
		)
		(if go-ahead-and-cache-p
		    (loop for elt in new-values do
		     (eval `(setf (,cache-function ,msgrecord)
				  ,value-to-cache
			    )
		     )
		    )
		    nil
		)
		(values nil (member message-number new-values))
	   )
       )
  )
)

(defmethod (Message-Sequence :get-field)
  (name message-number cache-function field-function
   &key (search-class nil) (search-string nil)
        (go-ahead-and-cache-p nil) (value-to-cache nil)
	(preemptions nil) (can-be-got-from-envelope nil)
  )
  (declare (values result-or-nil search-used-p))
  (multiple-value-bind (cache present-p)
      (send self :Cache-Entry-For message-number cache-function)
    (let ((cache-entry (send self :Record-For message-number)))
	 (let ((envelope
		 (and can-be-got-from-envelope
		      (cache-envelope cache-entry)
		 )
	       )
	      )
	      (if present-p
		  (if (and envelope can-be-got-from-envelope)
		      (funcall can-be-got-from-envelope
			       cache-entry envelope
		      )
		      (values cache nil)
		  )
		  (if (and can-be-got-from-envelope
			   (not (equal :Unbound envelope))
		      )
		      (progn (eval `(setf (,cache-function ,envelope)
					 ,(funcall can-be-got-from-envelope
						   cache-entry envelope
					  )
				    )
			     )
			     (values (funcall cache-function envelope) nil)
		      )
		      (if search-class
			  (multiple-value-bind (result-or-nil search-used-p)
			      (catch :Try-Locally
				(send self :Perform-Search message-number
				      cache-function search-class search-string
				      go-ahead-and-cache-p value-to-cache
			        )
			      )
			    (if (equal result-or-nil :Try-Locally)
				(send self :Get-Field name message-number
				      cache-function field-function
				      :search-class search-class
				      :search-string search-string
				      :Go-Ahead-And-Cache-P
				        go-ahead-and-cache-p
				      :value-to-cache value-to-cache
				      :preemptions preemptions
				      :Can-Be-Got-From-Envelope
				        can-be-got-from-envelope
                                )
				(values result-or-nil search-used-p)
			    )
			  )
			  (values (send self :Actually-Get-Field name
					cache-function field-function
					message-number preemptions
				  )
				  nil
			  )
		      )
		  )
	     )
	 )
    )
  )
)

(defun search-for-name-in-address (string address mailstream)
  (declare (optimize (speed 3) (safety 0)))
  (declare (type string string))
  (or (and (stringp (address-personalname address))
	   (Maybe-Wild-String-Search
	     string (address-personalname address) mailstream
	   )
      )
      (and (stringp (address-mailbox address))
	   (Maybe-Wild-String-Search
	     string (address-mailbox address) mailstream
	   )
      )
      (and (stringp (address-host address))
	   (Maybe-Wild-String-Search
	     string (the string (address-host address)) mailstream
	   )
      )
      (let ((formatted (format-name-1 nil address)))
	   (and (stringp formatted)
		(Maybe-Wild-String-Search
		  string (the string formatted) mailstream
		)
	   )
      )
  )
)

(defun search-for-name-in-addresses (string addresses mailstream)
  (find-if #'(lambda (x) (Search-For-Name-In-Address string x mailstream))
	   addresses
  )
)

(defmethod (Message-Sequence :Sequence-Not) (message-number seq)
  (not (send self :Accept-Message-P-Given-Sequence message-number seq))
)

(defmethod (Message-Sequence :Sequence-reverse) (message-number seq)
  (send self :Accept-Message-P-Given-Sequence message-number seq)
)

(defmethod (Message-Sequence :Sequence-Sorted-by) (message-number sequence key)
  (ignore key)
  (send self :Accept-Message-P-Given-Sequence message-number sequence)
)

(defmethod (Message-Sequence :Sequence-then) (message-number &rest sequences)
  (if sequences
      (or (send self :Accept-Message-P-Given-Sequence message-number
		(first sequences)
	  )
	  (lexpr-send self :Sequence-Then message-number (rest sequences))
      )
      nil
  )
)

(defmethod (Message-Sequence :Sequence-Or) (message-number &rest seqs)
  (if seqs
      (or (send self :Accept-Message-P-Given-Sequence message-number
		 (first seqs)
	   )
	   (lexpr-send self :Sequence-Or message-number (rest seqs))
      )
      t
  )
)

(defmethod (Message-Sequence :Sequence-XOr) (message-number &rest seqs)
 (if seqs
      (xor (send self :Accept-Message-P-Given-Sequence message-number
		 (first seqs)
	   )
	   (lexpr-send self :Sequence-Xor message-number (rest seqs))
      )
      nil
  )
)

(defmethod (Message-Sequence :Sequence-And-1) (message-number &rest seqs)
  (if seqs
      (and (send self :Accept-Message-P-Given-Sequence message-number
		 (first seqs)
	   )
	   (lexpr-send self :Sequence-And-1 message-number (rest seqs))
      )
      t
  )
)

(defmethod (Message-Sequence :Search-For-And-Expression-Maybe-On-Server)
	   (message-number specifiers)
  (if specifiers
      (let ((numbers (send self :Perform-Search-For-Conjunction specifiers)))
	   (member message-number numbers :Test #'eql)
      )
      t
  )
)

(defmethod (Message-Sequence :Sequence-And) (message-number &rest seqs)
  (multiple-value-bind (servable not-servable) (server-searchable-subset seqs)
    (and (send self :Search-For-And-Expression-Maybe-On-Server 
	       message-number servable
	 )
	 (or (not not-servable)
	     (lexpr-send self :Sequence-And-1 message-number not-servable)
	 )
    )
  )
)

(defmethod (Message-Sequence :Flag-Seen)
   (message-number search-class &optional flag-name (true-if-not-found-p nil))
"I think that this is the right thing to do.  Search class is in fact the name
 of the flag we're searching for.  Flag-Name should be the variable field for
 the search request. ?????"
  (if (consp message-number)
      (mapcar #'(lambda (mess)
		  (send self :Flag-Seen mess search-class flag-name
			true-if-not-found-p
		  )
		)
	        message-number
      )
      (let ((ip:*tcp-stream-whostate* "Get Flags"))
	   (multiple-value-bind (flags-field search-succeeded-p)
	       (send self :Get-Field "Flags" message-number
		     'cache-flags 'map-fetch-flags
		     :Search-Class search-class
		     :Search-String (if (equal :\\Keyword search-class)
					flag-name
					nil
				    )
		     :Preemptions *flags-field-preemptions*
	       )
	     (let ((result (if flags-field
			       ;;; Already cached locally
			       (member (if flag-name flag-name search-class)
				       flags-field
			       )
			       search-succeeded-p
			   )
		   )
		  )
		  (if true-if-not-found-p (not result) result)
	     )
	   )
      )
  )
)

(defun just-the-date (date)
  (let ((trimmed (string-trim " " date)))
       (subseq trimmed 0 (position #\space trimmed :Test #'char=))
  )
)

(defun fetch-just-date (mailstream numbers)
  (just-the-date (map-fetch-internaldate mailstream numbers))
)

(defmethod (Message-Sequence :get-date) (message-number)
  (send self :Get-Field "Date" message-number
	'cache-internaldate 'maybe-preempt-envelopes
	:Preemptions *to-field-preemptions*
	:Search-Class nil :Search-String nil
  )
)

(defun validate-date-time (date-time)
  (multiple-value-bind (results error-p)
      (catch-error
	(multiple-value-list (time:parse-universal-time date-time))
	nil
      )
    (ignore results)
    (if error-p
	(parse-error "~S is an illegal date string." date-time)
	nil
    )
  )
)

(defmethod (Message-Sequence :Sequence-date)
	   (message-number date-time search-class function)
  ;;; Make sure that we're just dealing with dates here.
  (let ((the-date (subseq date-time 0
			  (position #\space date-time :Test #'char=)
		  )
	)
       )
       (multiple-value-bind (date search-succeeded-p)
	    (send self :Get-Field "Date" message-number
		  'cache-internaldate 'maybe-preempt-envelopes
		  :Preemptions *to-field-preemptions*
		  :Search-Class search-class :Search-String the-date
	    )
	  (if date
	      (funcall function
		       (time:parse-universal-time (just-the-date date))
		       (time:parse-universal-time the-date)
	      )
	      search-succeeded-p
	  )
       )
  )
)

(defmethod (Message-Sequence :Sequence-All) (message-number)
  (ignore message-number)
  t
)

(defmethod (Message-Sequence :Sequence-Answered) (message-number)
  (send self :Flag-Seen message-number :\\Answered)
)

(defmethod (Message-Sequence :get-bcc) (message-number)
  (envelope-bcc
    (send self :Get-Field "bcc" message-number
	  'cache-envelope 'maybe-preempt-envelopes
	  :Preemptions *to-field-preemptions*
    )
  )
)

(defmethod (Message-Sequence :Sequence-bcc) (message-number bcc)
   (multiple-value-bind (envelope search-succeeded-p)
       (send self :Get-Field "bcc" message-number
	     'cache-envelope 'maybe-preempt-envelopes
	     :Preemptions *to-field-preemptions*
       )
     (if envelope
	 (search-for-name-in-addresses bcc (envelope-bcc envelope) mailbox)
	 search-succeeded-p
     )
  )
)

(defmethod (Message-Sequence :Sequence-before) (message-number date-time)
  (send self :Sequence-Date message-number date-time :Before #'<)
)

(defmethod (Message-Sequence :get-cc) (message-number)
  (envelope-cc
    (send self :Get-Field "cc" message-number
	  'cache-envelope 'maybe-preempt-envelopes
	  :Preemptions *to-field-preemptions*
    )
  )
)

(defmethod (Message-Sequence :Sequence-cc) (message-number cc)
   (multiple-value-bind (envelope search-succeeded-p)
       (send self :Get-Field "cc" message-number
	     'cache-envelope 'maybe-preempt-envelopes
	     :Preemptions *to-field-preemptions*
       )
     (if envelope
	 (search-for-name-in-addresses cc (envelope-cc envelope) mailbox)
	 search-succeeded-p
     )
  )
)

(defmethod (Message-Sequence :Sequence-Deleted) (message-number)
  (send self :Flag-Seen message-number :\\Deleted :\\deleted)
)

(defmethod (Message-Sequence :Sequence-Flagged) (message-number)
  (send self :Flag-Seen message-number :\\Flagged)
)

(defmethod (Message-Sequence :get-from) (message-number)
  (send self :Get-Field "From" message-number
	'cache-fromtext 'map-fetch-from
	:Preemptions *From-Field-Preemptions*
  )
)

(defun search-maybe-addresses (for in mailstream)
  (if (stringp in)
      (Maybe-Wild-string-search for in mailstream)
      (Search-For-Name-In-Addresses for (zwei:list-if-not in) mailstream)
  )
)

(defun (:Property :Sequence-Field :Valid-P-Function) (&rest ignore)
  (if (boundp '*mailer*)
      (if (send *mailer* :Current-Mailbox)
	  (if (version-less-p
		(send (send *mailer* :Current-Mailbox) :Selected-Version)
		3.0
	      )
	      (values nil "Sadly, the server you are using is unable to support
  operations on arbitrary fields.
  Thus, this command is illegal in this context."
	      )
	      t
	  )
	  t
      )
      t
  )
)

(defmethod (Message-Sequence :Sequence-Field) (message-number key string)
  (send self :Get-Field (string key) message-number nil nil
	:Search-Class key :Search-String string
  )
)

(defmethod (Message-Sequence :Sequence-From) (message-number from)
  (multiple-value-bind (from-field search-succeeded-p)
;	  (send self :Get-Field "From" message-number
;		'cache-fromtext 'map-fetch-from
;		:Search-Class :From :Search-String from
;		:Preemptions *From-Field-Preemptions*
;	  )
	  (send self :Get-Field "From" message-number
		'cache-envelope 'maybe-preempt-envelopes
		:Search-Class :From :Search-String from
		:Preemptions *from-field-preemptions*
		:Can-Be-Got-From-Envelope
	       #'(lambda (cache envelope)
		   (ignore cache)
		   (funcall 'envelope-from envelope)
		 )
	  )
       (if from-field
	   (Search-Maybe-Addresses from from-field mailbox)
	   search-succeeded-p
       )
;	   (let ((cache-entry (send self :Record-For message-number)))
;	        (let ((sender
;			(if (equal :Unbound (cache-sendertext cache-entry))
;			    (let ((envelope (cache-envelope cache-entry)))
;				 (if (and (not (equal envelope :Unbound))
;					  (envelope-sender envelope)
;				     )
;				     (progn (setf (cache-sendertext cache-entry)
;						  (format-name 'envelope-sender
;							       cache-entry
;						  )
;					    )
;					    (cache-sendertext cache-entry)
;				     )
;				     ""
;				 )
;			    )
;			    (cache-sendertext cache-entry)
;			)
;		      )
;		     )
;		     (Maybe-Wild-string-search from sender mailstream)
;		)
;	   )
;       )
  )
)

(defmethod (Message-Sequence :get-id) (message-number)
  (envelope-messageid
    (send self :Get-Field "Message Id" message-number
	  'cache-envelope 'maybe-preempt-envelopes
	  :Preemptions *From-Field-Preemptions*
    )
  )
)

(defmethod (Message-Sequence :Sequence-id) (message-number id)
  (let ((envelope
	  (send self :Get-Field "Message Id" message-number
		'cache-envelope 'maybe-preempt-envelopes
		:Preemptions *From-Field-Preemptions*
	  )
	)
       )
       (Maybe-Wild-string-Search id (envelope-messageid envelope) mailbox)
  )
)

(defmethod (Message-Sequence :Sequence-Keyword) (message-number keyword)
  (if (equal :* Keyword)
      (loop for key in (send (send self :Mailstream) :Keywords)
	    when (send self :Flag-Seen message-number :\\Keyword key)
	    return t
	    finally (return nil)
      )
      (send self :Flag-Seen message-number :\\Keyword keyword)
  )
)

(defmethod (Message-Sequence :Sequence-Last) (message-number last-n)
  (let ((total-messages (send (send self :Mailstream) :Messagecnt)))
       (> message-number (- total-messages last-n))
  )
)

(defmethod (Message-Sequence :Sequence-length) (message-number op length)
  (let ((*daemon-header-read-grain-size* (send mailbox :messagecnt)))
       ;;; Bind *daemon-header-read-grain-size* because we know that we want to
       ;;; preempt the whole mailbox for this.
       (funcall op (map-fetch-length (send self :Mailstream) message-number)
		length
       )
  )
)

(defmethod (Message-Sequence :Sequence-Mailbox-is) (message-number name)
  (ignore message-number)
  (Maybe-Wild-string-search name (send self :Mailbox-Name) mailbox)
)

(defmethod (Message-Sequence :Sequence-New) (message-number)
  (and (send self :Sequence-Recent message-number)
       (send self :sequence-unseen message-number)
  )
)

(defmethod (Message-Sequence :Sequence-Old) (message-number)
  (send self :Flag-Seen message-number :\\Recent nil t)
)

(defmethod (Message-Sequence :Sequence-On) (message-number date-time)
  (send self :Sequence-Date message-number date-time :On #'=)
)

(defmethod (Message-Sequence :Sequence-Recent) (message-number)
  (send self :Flag-Seen message-number :\\Recent)
)

(defmethod (Message-Sequence :Sequence-Seen) (message-number)
  (send self :Flag-Seen message-number :\\Seen)
)

(defmethod (Message-Sequence :Sequence-Since) (message-number date-time)
  (send self :Sequence-Date message-number date-time :Since #'>)
)

(defmethod (Message-Sequence :get-subject) (message-number)
  (send self :Get-Field "Subject" message-number
	'cache-subjecttext 'map-fetch-subject
	:Search-Class nil :Search-String nil
	:Preemptions *subject-field-preemptions*
  )
)

(defmethod (Message-Sequence :Sequence-Subject) (message-number subject)
  (multiple-value-bind (subject-field search-succeeded-p)
      (send self :Get-Field "Subject" message-number
	    'cache-subjecttext 'map-fetch-subject
	    :Search-Class :Subject :Search-String subject
	    :Preemptions *subject-field-preemptions*
      )
    (if subject-field
	;;; Already cached locally
	(Maybe-Wild-string-search subject subject-field mailbox)
	search-succeeded-p
    )
  )
)

(defmethod (Message-Sequence :get-text) (message-number)
  (send self :Get-Field "Text" message-number
	'Cache-RFC822Text 'map-fetch-message
	:Search-Class nil :Search-String nil
	:Preemptions *text-field-preemptions*
  )
)

(defmethod (Message-Sequence :Sequence-Text) (message-number text)
  (multiple-value-bind (text-field search-succeeded-p)
      (send self :Get-Field "Text" message-number
	    'Cache-RFC822Text 'map-fetch-message
	    :Search-Class :Text :Search-String text
	    :Preemptions *text-field-preemptions*
      )
    (if text-field
	;;; Already cached locally
	(Maybe-Wild-string-search text text-field mailbox)
	search-succeeded-p
    )
  )
)

(defmethod (Message-Sequence :get-to) (message-number)
  (envelope-to
    (send self :Get-Field "To" message-number
	  'cache-envelope 'maybe-preempt-envelopes
	  :Preemptions *to-field-preemptions*
    )
  )
)

(defmethod (Message-Sequence :Sequence-to) (message-number to)
  (multiple-value-bind (to-field search-succeeded-p)
       (send self :Get-Field "To" message-number
	     'cache-envelope 'maybe-preempt-envelopes
	     :Search-Class :To :Search-String to
	     :Preemptions *to-field-preemptions*
	     :Can-Be-Got-From-Envelope
	       #'(lambda (cache envelope)
		   (ignore cache)
		   (envelope-to envelope)
		 )
       )
     (if to-field
	 (Search-Maybe-Addresses to to-field mailbox)
	 search-succeeded-p
     )
  )
)

(defmethod (Message-Sequence :Sequence-~Answered) (message-number)
  (send self :Flag-Seen message-number :\\Answered nil t)
)

(defmethod (Message-Sequence :Sequence-~Deleted) (message-number)
  (send self :Flag-Seen message-number :\\Deleted nil t)
)

(defmethod (Message-Sequence :Sequence-~Flagged) (message-number)
  (send self :Flag-Seen message-number :\\Flagged nil t)
)

(defmethod (Message-Sequence :Sequence-~Keyword) (message-number keyword)
  (if (equal :* Keyword)
      (loop for key in (send (send self :Mailstream) :Keywords)
	    when (send self :Flag-Seen message-number :\\Keyword key)
	    return nil
	    finally (return t)
      )
      (send self :Flag-Seen message-number :\\Keyword keyword)
  )
)

;-------------------------------------------------------------------------------
;;; Obsolete syntax

(defmethod (Message-Sequence :Sequence-UnAnswered) (message-number)
  (send self :sequence-~answered message-number)
)

(defmethod (Message-Sequence :Sequence-UnDeleted) (message-number)
  (send self :sequence-~deleted message-number)
)

(defmethod (Message-Sequence :Sequence-UnFlagged) (message-number)
  (send self :sequence-~flagged message-number)
)

(defmethod (Message-Sequence :Sequence-UnKeyword) (message-number keyword)
  (send self :sequence-~keyword message-number keyword)
)

(defmethod (Message-Sequence :Sequence-UnSeen) (message-number)
  (send self :Flag-Seen message-number :\\Seen nil t)
)

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

(defmethod (Message-Sequence :>) (message-number &rest ignore)
  (equal (number-of message-number) (number-of (Decanonicalise-Number :>)))
)

(defmethod (Message-Sequence :%) (message-number &rest ignore)
  (equal (number-of message-number) (number-of (Decanonicalise-Number :%)))
)

(defmethod (Message-Sequence :*) (message-number &rest ignore)
  (equal (number-of message-number) (number-of (Decanonicalise-Number :*)))
)

(defmethod (Message-Sequence :<) (message-number &rest ignore)
  (equal (number-of message-number) (number-of (Decanonicalise-Number :<)))
)

(Defun-method decanonicalise-number Message-Sequence (a-number)
;  (case a-number ;;; Used to be this.
;    (:> (GETSTREAMPROP (send self :Mailstream) :MessageCnt))
;    (:% (GETSTREAMPROP (send self :Mailstream) :MessageCnt))
;    (:< 1)
;    (Otherwise a-number)
;  )
  (case a-number
    ((:> :% :*) (if superior
		 (first (last (send superior :Numberise-Messages-In-Order)))
		 (or (getstreamprop (send self :Mailstream) :MessageCnt)
		     (yw-error "System error.  Stream has no message count.")
		 )
	     )
    )
    (:< (if superior
	    (first (send superior :numberise-messages-in-order))
	    (or (getstreamprop (send self :Mailstream) :MessageCnt)
		(yw-error "System error.  Stream has no message count.")
	    )
	)
    )
    (Otherwise (typecase a-number
		 (message-descriptor (send a-number :Number))
		 (fixnum a-number)
		 (Message-Sequence a-number)
		 (otherwise a-number)
	       )
    )
  )
)

(Defmethod (Message-Sequence :Accept-Message-P-1) (message filt)
  (declare (optimize (safety 0) (speed 3)))
  (let ((message-number (etypecase message
			  (fixnum message)
			  (message-descriptor (send message :Number))
			  (cache (setq message (descriptor-of message nil))
				 (number-of message)
			  )
			)
        )
       )
       (if (consp filt)
	   (typecase (first filt)
	     ((or number cons);;; This is a sequence of numbers (ORed together)
	      (or (if (consp (first filt))
		      (send self :Accept-Message-P-1 Message-number
			    (first filt)
		      )
		      (equal message-number
			     (Decanonicalise-Number (first filt))
		      )
		  )
		  (send self :Accept-Message-P-1 Message-number (rest filt))
	      )
	     )
	     (Message-Descriptor
	      (if (equal (send (first filt) :Mailstream)
			 (send self :Mailstream)
		  )
		  (or (equal message-number
			     (Decanonicalise-Number (send (first filt) :Number))
		      )
		      (send self :Accept-Message-P-1 Message-number (rest filt))
		  )
		  (send self :Accept-Message-P-1 Message-number (rest filt))
	      )
	     )
	     (cache
	      (let ((thing (descriptor-of (first filt) nil)))
		   (if (equal (send thing :Mailstream)
			      (send self :Mailstream)
		       )
		       (or (equal message-number
				  (Decanonicalise-Number (send thing :Number))
			   )
			   (send self :Accept-Message-P-1 Message-number
				 (rest filt)
			   )
		       )
		       (send self :Accept-Message-P-1 Message-number
			     (rest filt)
		       )
		   )
	      )
	     )
	     (keyword (yw:safe-lexpr-send self (first filt) message-number
				  (mapcar #'Decanonicalise-Number (rest filt))
		      )
	     )
	     (otherwise (ferror nil "Can't understand sequence ~S" filt))
	   )
	   (if filt
	       (yw-error "Can't understand sequence ~S" filt)
	       nil
	   )
       )
  )
)

(defmethod (Message-Sequence :Accept-Message-P-Given-Sequence)
	   (message-number sequence)
  (send (if (typep sequence 'Message-Sequence) sequence self)
	:Accept-Message-P-1 message-number
	(if (typep sequence 'Message-Sequence)
	    (send sequence :sequence-specifier)
	    sequence
	)
  )
)

(defmethod (Message-Sequence :Accept-Message-P) (message-number)
  (if sequence-specifier
      (send self :Accept-Message-P-1 message-number
	    (send self :canonicalise-specifier)
      )
      t
  )
)

(defmethod (Message-Sequence :Make-Label) ()
  (if sequence-specifier
;      (let ((body (mapcar #'Make-Label-From-Filter sequence-specifier)))
;	   (format nil "~A~{ ~A~}" (first body) (rest body))
;      )
      (let ((body (Make-Label-From-Filter sequence-specifier)))
	   (format nil "~A" body)
      )
      ""
  )
)

(defmethod (Message-Sequence :numberise-messages) (&optional (start-from 1))
;  (send (send self :Mailstream) :Flush-Search-Cache)
  (let ((TotalMsgs    (getstreamprop (send self :Mailstream) :MessageCnt))
	(mailstream   (send self :Mailstream))
	(mailbox-name (send self :Mailbox-Name))
       )
       (let ((result
	       (loop for i from start-from to totalmsgs
		     for descriptor
			 = (Descriptor-Of i mailstream mailbox-name)
		     when (send self :accept-message-p descriptor)
		     collect descriptor
	       )
	     )
	    )
	    result
       )
  )
)

(defmethod (Message-Sequence :numberise-messages-in-order)
	   (&optional (start-from 0))
  (let ((current-number start-from)
	(mailstream (send self :Mailstream))
	(mailbox-name (send self :Mailbox-Name))
       )
       (letf (((symeval-in-instance self 'location-of-current-message)
	       :Unbound
	      )
	     )
	     (loop for result = (send self :Next-Message-Number current-number)
		   until (not result)
		   do (setq current-number result)
		   collect (Descriptor-Of
			     current-number mailstream mailbox-name
			   )
	     )
       )
  )
)

(defun complement-direction (direction)
  (case direction
    (:Forwards  :Backwards)
    (:Backwards :Forwards)
    (otherwise (yw-error "~S is not a valid direction." direction))
  )
)


(defmethod (Message-Sequence :next-message-number-for-then)
	(current-number direction)
  (if (equal :Unbound location-of-current-message)
      (progn (setq location-of-current-message 1)
	     (setq messages-selected nil)
      )
      nil
  )
  (let ((result
	  (loop for (temp new-dir) =
		(multiple-value-list
		(send (nth location-of-current-message
			   sequence-specifier
		      )
		      :Next-Message-Number current-number
		      direction (nth location-of-current-message
				     sequence-specifier
				)
		)
		)
		when (member temp messages-selected)
		do (setq current-number
			 (+ (if (equal :Forwards new-dir) 1 -1) current-number)
		   )
		until (or (not temp)
			  (not (member temp messages-selected))
		      )
		finally (return temp)
	  )
	)
       )
       (if result
	   (progn (setq messages-selected
			(cons result messages-selected)
		  )
		  result
	   )
	   (if (nth (+ 1 location-of-current-message)
		    sequence-specifier
	       )
	       (progn (setq location-of-current-message
			    (+ 1 location-of-current-message)
		      )
;		      (print :---------------)
		      (send self :Next-Message-Number
			    0 direction
		      )
	       )
	       (progn (setq location-of-current-message :Unbound)
		      nil
	       )
	   )
       )
  )
)

(defun numbers-match (x y)
  (etypecase x
    (fixnum
     (etypecase y
       (fixnum (eql x y))
       (message-descriptor (numbers-match x (send y :Number)))
     )
    )
    (message-descriptor (numbers-match (send x :Number) y))
  )
)

(defmethod (Message-Sequence :computed-order-safe) ()
  (if (equal computed-order :Undefined)
      (progn (send self :compute-order)
	     (send self :computed-order-safe)
      )
      computed-order
  )
)

(defmethod (Message-Sequence :next-message-number)
	(&optional (current-number 0) (direction :Forwards)
	 (last-sequence nil) (increment 1)
	)
  (ignore last-sequence) ;;; ????
  (let ((order (send self :computed-order-safe)))
       (let ((index
	       (position current-number order :Test 'numbers-match)
	     )
	    )
	    (let ((real-index (if index
				  (+ (max 0 index)
				     (if (equal direction :Forwards)
					 increment
					 (- increment)
				     )
				  )
				  0
			      )
		  )
		 )
		 (if (>= real-index 0)
		     (nth real-index order)
		     nil
		 )
	    )
       )
  )
)

(defmethod (Message-Sequence :compute-order) ()
  (if (equal :Undefined computed-order)
      (setq computed-order (send self :compute-order-1))
      computed-order
  )
)

(defmethod (Message-Sequence :compute-order-1) ()
  (let ((entry (assoc (first sequence-specifier)
		      *Sequence-Key-To-Control-Structure-Method-Mappings*
	       )
	)
       )
       (if entry
	   (lexpr-send self (second entry) (rest sequence-specifier))
	   (send self :Numberise-Messages)
       )
  )
)

(defun ordered-difference (a b result)
  (if a
      (if (member (first a) b)
	  (ordered-difference (rest a) b result)
	  (ordered-difference (rest a) b (cons (first a) result))
      )
      (reverse result)
  )
)

(defmethod (Message-Sequence :One-After-Another) (&rest sequences)
  (if sequences
      (let ((result (send (first sequences) :Compute-Order-1)))
	   (append result
		   (Ordered-Difference
		     (lexpr-send self :One-After-Another (rest sequences))
		     result nil
		   )
	   )
      )
      nil
  )
)

(defmethod (Message-Sequence :reverse-order) (sequence)
  (reverse (send sequence :Compute-Order-1))
)

(defmethod (Message-Sequence :sort-the-sequence) (sequence key)
  (let ((messages (send sequence :Compute-Order-1))
	(instance self)
       )
       (sort messages
	     #'(lambda (x y)
		 (send instance :order-messages key x y)
	       )
       )
  )
)


(defun general-less-p (a b)
  (typecase a
    (number (if (numberp b)
		(< a b)
		nil
	    )
    )
    (string (if (stringp b)
		(let ((t1 (catch-error (time:parse-universal-time a) nil))
		      (t2 (catch-error (time:parse-universal-time b) nil))
		     )
		     (if (and t1 t2)
			 (< t1 t2)
			 (string-lessp a b)
		     )
		)
		nil
	    )
    )
    (otherwise nil)
  )
)

(defmethod (Message-Sequence :order-messages) (key number-x number-y)
  (general-less-p (send self key number-x)
		  (send self key number-y)
  )
)

(defmethod (message-sequence :next-number)
	   (direction in-sequence-p current-number &optional (increment 1))
  (if in-sequence-p
      (send self :Next-Message-Number
	    current-number direction increment
      )
      (if (or (and (<= current-number increment)
		   (not (equal direction :Forwards))
	      )
	      (and (equal direction :Forwards)
		   (> (+ increment current-number)
		      (getstreamprop (send self :Mailstream)
				     :Messagecnt
		      )
		   )
	      )
	  )
	  nil
	  (+ (if (equal direction :Forwards) increment (- increment))
	     current-number
	  )
      )
  )
)

(defmethod (Message-Sequence :map-over-messages) (method-or-function &rest args)
;  (send (send self :Mailstream) :Flush-Search-Cache)
  (let ((TotalMsgs (with-mailbox-locked ((send self :Mailstream))
		     (getstreamprop (send self :Mailstream) :MessageCnt)
		   )
	)
       )
       (loop for i from 1 to totalmsgs
	     when (send self :accept-message-p i)
	     collect (if (keywordp method-or-function)
			 (yw:safe-lexpr-send self method-or-function i args)
			 (apply method-or-function self i args)
		     )
       )
  )
)

(defun user-find-zmacs-frame ()
  (if (typep *default-yw-zmacs-frame* 'zwei:zmacs-frame)
      *default-yw-zmacs-frame*
      (or (and *default-yw-zmacs-frame*
	       (catch-error (eval *default-yw-zmacs-frame*))
	  )
	  (progn (if (not (and (boundp 'Zwei::*All-Zmacs-Windows*)
			       Zwei::*All-Zmacs-Windows*
			  )
		     )
		     (zwei:find-or-create-idle-zmacs-window)
		     nil
		 )
		 (Send (First Zwei::*All-Zmacs-Windows*) :Superior)
	  )
      )
  )
)

(defun find-zmacs-frame ()
  (declare (values frame window-pane))
  (let ((frame (User-Find-Zmacs-Frame)))
       (values frame
	       (find-if #'(lambda (x) (typep x 'zwei:zmacs-window-pane))
			(send frame :Inferiors)
	       )
       )
  )
)

(defun find-mail-buffer (name)
  (dolist (buffer zwei:*zmacs-buffer-list*)
    (and (equal name (send buffer :name))
	 (return buffer)
    )
  )
)

(defun buffer-from-stream (ed-stream)
  (zwei:line-node
    (zwei:bp-line
      (send (symeval-in-instance ed-stream 'zwei:**interval**) :First-Bp)
    )
  )
)

(defun mail-beep ()
  (beep)
)

(defmethod (Message-Sequence :Eager-Message)
	   (message-number &optional (sleep-p nil))
  (MAP-Fetch-Message (send self :Mailstream) message-number)
  (if sleep-p (mail-beep))
  (if sleep-p (sleep *Yw-daemon-Sleep-Interval*) nil)
)

;(defmethod (Message-Sequence :make-hardcopy-index-page) (numbers)
;  (make-string-input-stream
;    (with-output-to-string (*standard-output*)
;      (mapcar #'(lambda (number)
;		  (format t "~&~A"
;			  (make-instance 'Message-Descriptor
;				:Number number
;				:Mailbox-Name (send self :Mailbox-Name)
;				:Mailstream (send self :Mailstream)
;			  )
;		  )
;		)
;	        numbers
;      )
;    )
;  )
;)

(defun space-with-pages (streams)
  (if streams
      (cons (first streams)
	    (if (rest streams)
		(cons (make-string-input-stream "")
		      (space-with-pages (rest streams))
		)
		nil
	    )
      )
      nil
  )
)

(defflavor message-printing-stream
	   ((messages nil)
	    (current nil)
	    (string-stream nil)
	    (header-p nil)
	    (numbers nil)
	    (sequence nil)
	   )
	   (si:input-stream)
  :Initable-Instance-Variables
)

(defmethod (Message-Printing-Stream :After :Init) (&rest ignore)
  (setq messages
	(mapcar #'(lambda (number)
		    (multiple-value-bind (message header)
			(map-fetch-message (send sequence :Mailstream) number)
		      (list (Parse-And-Filter-Header header) message)
		    )
		  )
		  numbers
        )
  )
  (if (rest messages) ;;; More than one, so have a banner page.
      (setq messages
	    (cons (without-tabs-1
		   (with-output-to-string (*standard-output*)
		     (mapcar #'(lambda (number)
				 (format t "~&~A"
				   (make-instance 'Message-Descriptor
					 :Number number
					 :Mailbox-Name
					   (send sequence :Mailbox-Name)
					 :Mailstream
					   (send sequence :Mailstream)
				   )
				 )
			       )
			       numbers
		     )
		   )
		   0
		  )
		  messages
	    )
      )
      nil
  )
  messages
)

(defmethod (Message-Printing-Stream :get-new-string-stream) ()
  (if messages
      (if (consp (first messages))
	  (progn (setq string-stream
		       (make-string-input-stream (first (first messages)))
		 )
		 (if (second (first messages))
		     (setq messages
			   (cons (second (first messages)) (rest messages))
		     )
		     (setq messages (rest messages))
		 )
		 (setq header-p t)
	  )
	  (progn (setq string-stream
		       (make-string-input-stream (first messages))
		 )
		 (setq messages (rest messages))
		 (setq header-p nil)
	  )
      )
      (setq string-stream nil)
  )
  (values string-stream (length messages)
	  (first messages)
  )
)

(defmethod (message-printing-stream :UnTyi) (&rest args)
  (if string-stream
      (lexpr-send string-stream :Untyi args)
      nil
  )
)

(defmethod (message-printing-stream :Tyi) (&rest args)
  (if string-stream
      (let ((char (lexpr-send string-stream :Tyi args)))
	   (if char
	       char
	       (progn (send string-stream :Close)
		      (if (send self :get-new-string-stream)
			  (if (and header-p
				   *page-break-between-printed-messages*
			      )
			      #\
			      (if header-p
				  (let ((string (make-string 80
						  :Initial-Element #\_
						)
					)
				       )
				       (setf (aref string 79) #\newline)
				       (setq string-stream
					     (make-concatenated-stream
					       (make-string-input-stream
						 string
					       )
					       string-stream
					     )
				       )
				       #\Newline
				  )
				  #\Newline
			      )
			  )
			  nil
		      )
	       )
	   )
      )
      (progn (send self :get-new-string-stream)
	     (if string-stream
		 (lexpr-send self :Tyi args)
		 nil
	     )
      )
  )
)

(defmethod (message-printing-stream :Close) (&rest args)
  (if string-stream
      (lexpr-send string-stream :Close args)
      nil
  )
)

(defun copy-stream (from to)
  (loop for char = (send from :Tyi)
	while char
	do (send to :Tyo char)
  )
)


;imagen:
;(DEFMETHOD (PRINTER::IMAGEN-PRINTER :PRINT-PAGE-HEADING) (&AUX FIRST-LINE (SECOND-LINE NIL)
;							  BRULE-WIDTH FORMAT-STRING HEADING-LINE-HEIGHT)
;  "Print page heading."
;  (DECLARE (SPECIAL IMAGEN-FONTS::COUR12))
;  (SEND SELF :SWITCH-PRINTER-TO-FONT IMAGEN-FONTS::COUR12); Switch to COUR12 for page heading.
;  (SETQ HEADING-LINE-HEIGHT; Remember COUR12's interline height.
; (INTERLINE-SPACING IMAGEN-FONTS::COUR12))
;  (SEND SELF :STRING-OUT-RAW; Use COUR12's interline height temporarily.
;     (IMPRESS-SET-IL :INTER-LINE HEADING-LINE-HEIGHT))
;  ;; Get the new page's page number...
;  (SETQ PRINTER::PAGE-COUNT (1+ PRINTER::PAGE-COUNT))
;  ;; If the page-heading is a list, get two lines worth of heading text, otherwise get just one...
;  (IF (CONSP PRINTER::PAGE-HEADING)
;    (SETQ FIRST-LINE (FIRST PRINTER::PAGE-HEADING)
;	  SECOND-LINE (SECOND PRINTER::PAGE-HEADING))
;    (SETQ FIRST-LINE PRINTER::PAGE-HEADING))
;  ;; Select brule width and the width/format of the page heading based on rotation...
;  (COND
;    (ROTATED-PAGE-IMAGE
;     (SETQ BRULE-WIDTH *PIXELS-DOWN-A-PAGE*
;	   FORMAT-STRING "~98A~18A Page -~D-~@[~%~A~]"))
;    (T (SETQ BRULE-WIDTH *PIXELS-IN-A-LINE*
;	     FORMAT-STRING "~45A~18A Page -~D-~@[~%~A~]")))
;  ;; Print the page heading string (one or two lines), leaving cursor at end of last line printed...
;  (SEND SELF :STRING-OUT-CHARS
;     (FORMAT () FORMAT-STRING FIRST-LINE PRINTER::CURRENT-TIME PRINTER::PAGE-COUNT SECOND-LINE))
;  ;; Print a nice underline for the page heading string, then switch back to normal interline height and
;  ;;    position the printer for the first text line...
;  (SEND SELF :STRING-OUT-RAW
;     (STRING-APPEND (IMPRESS-SET-ABS-H :NEW-H *LEFT-MARGIN-WIDTH*); Move back to start of line.
;		    (IMPRESS-BRULE :WIDTH BRULE-WIDTH; Print the underline.
;				   :HEIGHT 3;    *
;				   :TOP-OFFSET 15);    *
;		    (IMPRESS-SET-REL-V :DELTA-V 18); Make sure 1st text line clears it.
;		    (IMPRESS-CRLF); Advance COUR12-height pixels.
;		    (IMPRESS-CRLF); Twice.
;		    (IMPRESS-SET-IL :INTER-LINE ADVANCE-HEIGHT))); Switch back to text's line height.
;  ;; Adjust our internal state to reflect the 2/3 heading-lines' just moved vertically...
;  (SETQ VERTICAL-POSITION
;	(+ VERTICAL-POSITION HEADING-LINE-HEIGHT HEADING-LINE-HEIGHT
;	   (IF SECOND-LINE
;	     HEADING-LINE-HEIGHT
;	     0)))
;  ;; Switch back to the font in which the file's text is currently being printed...
;  (SEND SELF :SWITCH-PRINTER-TO-FONT CURRENT-FONT-DESCRIPTOR))


(defun fonts-list-from-header-objects (header-objects)
"Given a list of header objects returns a fonts list."
  (loop for header in header-objects
	when (member (send header :Type) '(:Fonts :X-Fonts))
	do (return (Fonts-List-From-Header-Object header))
	finally (return nil)
  )
)
	
(defun collect-font-maps-from-messages (message-numbers mailstream)
"Given a set of messages and a mailstream, returns the longest font attribute
for any of the messages and a list of all of the font attributes too.
"
  (declare (values longest-fonts-list list-of-fonts-lists))
  (let ((fonts-lists
	  (loop for number in message-numbers
		for cache = (cache-entry-of number mailstream)
		for header = (cache-rfc822header cache)
		for header-objects = (parse-headers header)
		collect (fonts-list-from-header-objects header-objects)
	  )
	)
       )
       (let ((longest nil))
	    (loop for font-list in fonts-lists
		  when (> (length font-list) (length longest))
		  do (setq longest font-list)
	    )
	    (values longest fonts-lists)
       )
  )
)

(defmethod (Message-Sequence :hardcopy-self) (&optional some-numbers)
  (let ((numbers (or some-numbers (send self :Numberise-Messages))))
       (send self :Eager-Message numbers)
       (MAP-Fetch-Message (send self :Mailstream) numbers)
       (let ((heading
	      (without-tabs-1
	       (let ((label (make-label-from-filter sequence-specifier))
		     (coloned (colonify-numbers numbers))
		    )
		    (if (equal label coloned)
			(format nil "Mail: ~A; ~A" fs:user-id label)
			(format nil "Mail: ~A; ~A; ~A" fs:user-id label coloned)
		    )
	       )
	       0
	      )
	     )
	     (fonts (or (if *use-fonts-from-messages-when-printing-p*
			    (collect-font-maps-from-messages
			      numbers (send self :mailstream)
			    )
			    nil
			)
			(list-if-not *default-printer-font-list*)
		    )
	     )
	    )
	    (print-stream
	      (make-instance 'Message-Printing-Stream :Sequence self
			     :Numbers numbers
	      )
	      :Page-Heading t
	      :Header-Name  heading
	      :Font-List fonts
	    )
       )
  )
)

(defadvise (:method zwei:file-buffer :after :set-attribute) (:Maybe-Dont-Query)
	   (ignore ignore ignore query-p)
  (declare (special *really-dont-query*))
  (if (and (boundp '*really-dont-query*) *really-dont-query*
	   query-p
      )
      (setf query-p nil)
  )
  :do-it
)

(defun Prepare-Mail-Read-Buffer
  (buffer owner sequence message-number continuation-method extra-things-to-do)
  (declare (special yw-zwei:*Windows-Not-To-Redisplay-Twice*))
  (let ((*really-dont-query* t)
        (cache-entry
	  (message-cache-for message-number (send sequence :Mailstream))
	)
       )
       (declare (special *really-dont-query*))
       (pushnew buffer zwei:*sent-message-list*)
       (putprop buffer owner :Source-Mailer)
       (putprop buffer sequence :message-sequence)
       (putprop buffer :Read :buffer-type)
       (putprop buffer cache-entry :message-cache-entry)
       (pushnew buffer (cache-associated-zmacs-buffers cache-entry))
       (putprop buffer continuation-method :continuation-method)
       (send buffer :activate t)
       (zwei:make-buffer-current buffer)
       (zwei:com-text-mode)
       (zwei:turn-off-mode 'zwei:mail-mode)
       (zwei:turn-off-mode 'yw-zwei:yw-read-mode)
       (zwei:turn-off-mode 'zwei:highlight-mode)
;       (yw-zwei:com-yw-read-mode)
       (zwei:turn-on-mode 'yw-zwei:yw-read-mode)
       (zwei:not-modified zwei:*interval*)
       (zwei:make-buffer-read-only zwei:*interval*)
       (yw-zwei:remember-parsed-message buffer)
       (If (member zwei:*window* yw-zwei:*Windows-Not-To-Redisplay-Twice*)
	   (setq yw-zwei:*Windows-Not-To-Redisplay-Twice*
		 (Remove zwei:*window* yw-zwei:*Windows-Not-To-Redisplay-Twice*
;			 :Count 1
		 )
	   )
	   (send (send zwei:*window* :Superior) :Refresh)
       )
       (if extra-things-to-do (funcall extra-things-to-do) nil)
  )
  buffer
)

(defun kill-associated-buffers (cache-entry)
  (loop for buffer in (cache-associated-zmacs-buffers cache-entry) do
	(let ((buffer-name (Make-Read-Buffer-Name (cache-msg# cache-entry)
						  (get buffer :Message-Sequence)
		           )
	      )
	     )
	     (if (zwei:find-buffer-named buffer-name nil)
		 (zwei:kill-buffer (zwei:find-buffer-named buffer-name nil) t)
		 nil
	     )
	)
  )
)

(defun kill-associated-buffers (cache-entry)
  (loop for buffer in (cache-associated-zmacs-buffers cache-entry) do
	(zwei:kill-buffer buffer t)
  )
)

(defun Rename-Associated-Buffers
       (cache-entry &optional (string nil) (change-props-cause nil))
  (loop for buffer in (cache-associated-zmacs-buffers cache-entry) do
	(let ((buffer-name (Make-Read-Buffer-Name (cache-msg# cache-entry)
						  (get buffer :Message-Sequence)
		           )
	      )
	     )
	     (let ((new-name
		     (if string
			 (string-append string " {" (send buffer :Name) "}")
			 (case (get buffer :Buffer-Type)
			  (:Read buffer-name)
			  (otherwise
			   (yw-zwei:make-non-read-buffer-name
			     (get buffer :title-string) buffer-name
			   )
			  )
			 )
		     )
		   )
		  )
		  (zwei:rename-buffer
		    buffer
		    (if (zwei:find-buffer-named new-name nil)
			(string-append
			  new-name
			  (string-capitalize
			    (symbol-name (gensym "DUPLICATE-NAME-"))
			    :Spaces t
			  )
			)
			new-name
		    )
		  )
	     )
	     (gensym "G")
	     (if change-props-cause
		 (progn (setf (get buffer :Source-Mailer) change-props-cause)
			(setf (get buffer :Message-Sequence)    nil)
			(setf (get buffer :Message-Cache-Entry) nil)
			(setf (get buffer :Continuation-Method) nil)
		 )
		 nil
	     )
	)
  )
)

(defun get-typein-window ()
  (send (send (send zwei:*window* :Superior) :Mode-Line-Window) :Typein-Window)
)

(Defmethod (Message-Sequence :reply-to-message)
	   (message-number
	    &optional (window nil)
	              (all-p *reply-to-all-by-default*)
	              (inclusive-p *reply-inclusive-by-default*)
	   )
  (send self :Read-Message message-number window :Reply-To-Message
	#'(lambda ()
	    (let ((*query-io* (get-typein-window))
		  (*reply-to-all-by-default* all-p)
		  (*reply-inclusive-by-default* inclusive-p)
		 )
	         (yw-zwei:com-yw-reply)
	    )
	  )
  )
)

(defmethod (Message-Sequence :Copy/Move-Message)
	   (message-number to delete-p &optional (numbers nil))
  (funcall (if delete-p
	       'map-move-message
	       'map-copy-message
	   )
	   (send self :Mailstream)
	   (or numbers
	       (list message-number)
	   )
	   (if (canonical-mailbox-name-p to)
	       (mailbox-and-host-from-mailbox-name
		 (decanonicalize-mailbox-name to nil)
	       )
	       (send (fs:default-pathname to) :String-For-Host)
	   )
  )
)

(defmethod (Message-Sequence :hardcopy-message)
	   (message-number &optional (numbers nil))
  (send self :Hardcopy-Self (if message-number
				(list message-number)
				numbers
			    )
  )
)

(defmethod (Message-Sequence :delete-message) (message-number delete-p numbers)
  (send self :Alter-Flag-For-Message (or message-number numbers)
	:\\Deleted delete-p
  )
)

(defmethod (Message-Sequence :alter-flag-for-message)
	   (message-number flag-keyword flag-p)
  (let ((to-set
	  (if (equal flag-p :Toggle)
	      (loop for n in (list-if-not message-number)
		    unless (send self :Flag-Seen n flag-keyword)
		    collect n
	      )
	      (if flag-p (list-if-not message-number) nil)
	  )
	)
       )
       (if to-set
	   (flag/unflag-message
	     (send self :Mailstream) to-set :Set flag-keyword
	   )
	   nil
       )
       (let ((to-clear (set-difference (list-if-not message-number) to-set)))
	    (if to-clear
		(flag/unflag-message
		  (send self :Mailstream) to-clear
		  :Clear flag-keyword
		)
		nil
	    )
       )
  )
)

(defmethod (Message-Sequence :flag-message) (message-number flag-p numbers)
  (send self :Alter-Flag-For-Message
	(or message-number numbers (send self :numberise-messages))
	:\\Flagged flag-p
  )
)

(defmethod (Message-Sequence :mark-message-as-answered)
	   (message-number flag-p numbers)
  (send self :Alter-Flag-For-Message (or message-number numbers)
	:\\Answered flag-p
  )
)

(Defmethod (Message-Sequence :Forward-Message)
	   (message-number &optional (window nil))
  (send self :Read-Message message-number window :Forward-Message
	#'(lambda ()
	    (let ((*query-io* (get-typein-window))) (yw-zwei:com-yw-forward))
	  )
  )
)

(Defmethod (Message-Sequence :Remail-Message)
	   (message-number &optional (window nil))
  (send self :Read-Message message-number window :Remail-Message
	#'(lambda ()
	    (let ((*query-io* (get-typein-window))) (yw-zwei:com-yw-remail))
	  )
  )
)

(defmethod (Message-Sequence :Highlight-Message)
	   (message-number &optional (type t))
  (mapcar #'(lambda (sum)
	      (if (equal (first sum) (send mailbox :Mailbox))
		  (send (second sum) :Highlight-Message message-number type t)
		  nil
	      )
	    )
	    (send owner :All-Summary-Windows)
  )
)

(defmethod (Message-Sequence :DeHighlight-Message)
	   (message-number &optional (type t))
  (mapcar #'(lambda (sum)
	      (if (equal (first sum) (send mailbox :mailbox))
		  (send (second sum) :DeHighlight-Message message-number type t)
		  nil
	      )
	    )
	    (send owner :All-Summary-Windows)
  )
)

(defun split-into-lines (header start)
  (let ((index (string-search-set '(#\newline) header start)))
       (cons (subseq header start index)
	     (if index
		 (split-into-lines header (+ 1 index))
		 nil
	     )
       )
  )
)

(defun merge-tabbed-lines (lines)
  (if lines
      (Merge-Tabbed-Lines-1 (first lines) (rest lines))
      nil
  )
)

(defun merge-tabbed-lines-1 (this-line lines)
  (if lines
      (if (and (> (length (first lines)) 0)
	       (member (aref (first lines) 0) '(#\tab #\space)
		       :Test #'char-equal
	       )
	  )
	  (merge-tabbed-lines-1
	    (string-append this-line
			   (string-trim '(#\tab #\space) (first lines))
	    )
	    (rest lines)
	  )
	  (cons this-line (merge-tabbed-lines-1 (first lines) (rest lines)))
      )
      (list this-line)
  )
)

(defun discard-blank-lines (lines)
  (remove "" lines :Test #'string-equal)
)

(defun should-filter-header (header-object)
  (or (and (typep header-object 'mail:basic-header)
	   (member (send header-object :Type) *basic-header-types-to-filter*)
      )
      (and (typep header-object 'mail:address-header)
	   (member (send header-object :Type) *address-header-types-to-filter*)
      )
      (and *header-types-to-include*
	   (not (member (send header-object :Type) *header-types-to-include*))
      )
  )
)

(defun parse-headers (header)
  (mapcar #'mail:parse-header
	  (Merge-Tabbed-Lines
	    (Discard-Blank-Lines
	      (split-into-lines header 0)
	    )
	  )
  )
)

(defun post-process-header (header buffer)
  (let ((type (send header :Type)))
       (loop for entry in *post-process-header-actions*
	     when (and (consp entry) (equal type (first entry)))
	     do (setq header (funcall (second entry) header buffer))
       )
       header
  )
)

(defun remap-zwei-font (font-name)
  (let ((entry (assoc font-name yw-zwei:*mail-fonts-attribute-mapping-alist*)))
       (if entry
	   (second entry)
	   font-name
       )
  )
)

(defun fonts-list-from-header-object (header)
"Given a zmail header object for a font line returns a list of explorer
implementable fonts.
"
  (let ((*package* (find-package 'fonts)))
       (let ((fonts (read-separated-list
		      '(#\space #\tab #\,) (send header :body) 0
		    )
	     )
	    )
	    (let ((parsed-fonts
		    (remove-if-not
		      #'(lambda (x)
			  (and (symbolp x)
			       (boundp x)
			       (typep (symbol-value x) 'tv:font)
			  )
			)
		      (mapcar 'Remap-Zwei-Font fonts)
		    )
		  )
		 )
	         parsed-fonts
	    )
       )
  )
)

(defun do-fontification-of-buffer (buffer font-list)
"actually refontifies a buffer."
  (if font-list
      (let ((zwei:*interval* buffer))
	   (send buffer :set-attribute :Fonts font-list nil)
	   (zwei:redefine-fonts zwei:*window*
	     (mapcar #'(lambda (name)
			 (cons (symbol-name name)
			       (symbol-value name)
			 )
		       )
		       font-list
	     )
	   )
	   (zwei:update-font-name)
      )
      nil
  )
)

(defun fontify-buffer (header buffer)
  (let ((parsed-fonts (fonts-list-from-header-object header)))
       (inside-zmacs ((find-zmacs-frame))
	 (do-fontification-of-buffer buffer parsed-fonts)
       )
  )
  header
)

(defun fontify-buffer-to-default-fonts (headers buffer)
  (let ((fonts (send buffer :get-attribute :Fonts)))
       (if (or (not yw-zwei:*default-fonts-for-read-buffer*) fonts)
	   nil
	   (let ((parsed-fonts
		   (remove-if-not
		     #'(lambda (x)
			 (and (symbolp x)
			      (boundp x)
			      (typep (symbol-value x) 'tv:font)
			 )
		       )
		     (mapcar 'Remap-Zwei-Font
			     yw-zwei:*default-fonts-for-read-buffer*
		     )
		   )
		 )
		)
		(inside-zmacs ((find-zmacs-frame))
		  (do-fontification-of-buffer buffer parsed-fonts)
		)
	   )
      )
  )
  headers
)


(pushnew 'fontify-buffer-to-default-fonts *post-process-header-actions*)


(defun post-process-headers (parsed buffer)
"Given a list of parsed header objects and the buffer to which they belong.
Uses the *post-process-header-actions* list to do things for different types of
header.
"
  (let ((processed (loop for header in parsed collect
			 (post-process-header header buffer)
		   )
	)
       )
       (loop for entry in *post-process-header-actions*
	     when (not (consp entry))
	     do (setq processed (funcall entry processed buffer))
       )
       processed
  )
)

(defun maybe-filter-header (header &optional (headers (Parse-Headers header)))
  (or (catch-error
        (remove-if 'should-filter-header headers)
	nil
      )
      header
  )
)

;(defflavor font-hacking-stream
;	   ((current-font 0)
;	    (waiting-for-font nil)
;	    stream
;	   )
;	   (si:output-stream)
;  (:Initable-Instance-Variables stream)
;)

;(defmethod (Font-Hacking-Stream :Tyo) (char &rest args)
;  (let ((fix-char (etypecase char
;		    (integer char)
;		    (character (char-code char))
;		  )
;        )
;       )
;       (if waiting-for-font
;	   (progn (setq waiting-for-font nil)
;		  (if (char-equal #\* char)
;		      (setq current-font 0)
;		      (setq current-font (- fix-char (char-int #\0)))
;		  )
;	    )		 
;	    (if (char-equal char 6) ;;; Epsilon
;		(setq waiting-for-font t)
;		(lexpr-send
;		  stream :Tyo
;		  (if (and (>= fix-char 128) (<= fix-char 160))
;		      char
;		      (code-char fix-char 0 current-font)
;		  )
;		  args
;		)
;	    )
;       )
;  )
;)

;(defmethod (Font-Hacking-Stream :Close) (&rest args)
;  (lexpr-send stream :Close args)
;)

(defun make-read-buffer-name (message sequence)
  (let ((number (number-of message))
	(cache (and sequence
		    (cache-entry-of message (send sequence :Mailstream))
	       )
	)
       )
       (format nil "Reading ~D of ~A: \"~A\""
	       number (if sequence (send sequence :Short-Name) "No Sequence")
	       (if cache (Cache-SubjectText cache) "<error>")
       )
  )
)


(defun parse-and-filter-header (header)
  "Given a header, parses it and filters out unwanted header types."
  (let ((parsed (parse-headers header)))
       (let ((filtered
	       (if (or *filter-headers* *header-types-to-include*)
		   (Maybe-Filter-Header (or header " ") parsed)
		   (or header " ")
	       )
	     )
	    )
	    (typecase filtered
	      (string filtered)
	      (list (with-output-to-string (*standard-output*)
		      (loop for head in filtered do
			    (etypecase head
			      (string (princ head))
			      (mail:header
			       (princ (send head :String))
			      )
			    )
			    (terpri)
		      )
		    )
	      )
	      (otherwise
	       (tv:notify tv:selected-window "Error in parsing header")
	      )
	    )
       )
  )
)

(defmethod (Message-Sequence :insert-text-into-zmacs)
	   (ed-stream buffer message-number frame &optional (new-buffer-p t))
  (inside-zmacs (frame)
    (multiple-value-bind (body header)
	  (MAP-Fetch-Message (send self :Mailstream) message-number)
      (let ((parsed (parse-headers header)))
	   (let ((filtered
		   (if (or *filter-headers* *header-types-to-include*)
		       (Maybe-Filter-Header (or header " ")
					    (Post-Process-Headers parsed buffer)
		       )
		       (or header " ")
		   )
		 )
		 (buffer-fonts nil)
		 (nl-in-body-p (and (> (length body) 0)
				    (char= #\newline (aref body 0))
			       )
		 )
		)
		(multiple-value-bind (real-header nl-at-end-of-header-p)
		    (typecase filtered
		      (string (values filtered
				      (and (> (length header) 2)
					   (char= (aref header
							(- (length header) 1)
						  )
						  #\newline
					   )
					   (char= (aref header
							(- (length header) 2)
						  )
						  #\newline
					   )
				      )
			      )
		      )
		      (list (values
			      (with-output-to-string (*standard-output*)
				(loop for head in filtered do
				      (etypecase head
					(string (princ head))
					(mail:header
					 (princ (send head :String))
					)
				      )
				      (terpri)
				)
			      )
			      nil
			    )
		      )
		      (otherwise
		       (princ "Error in parsing header" ed-stream)
		      )
		    )
		  (yw-zwei:load-up-mail-buffer
		    buffer buffer-fonts real-header body
		    (not (or nl-at-end-of-header-p nl-in-body-p)) t new-buffer-p
		  )
		)
	   )
      )
    )
  )
)

(Defmethod (Message-Sequence :read-message)
	   (message-number &optional (window nil)
	    (continuation-method :read-message)
	    (extra-things-to-do nil)
	   )
  (declare (special *owning-window* *address-server* *edit-server*))
  (if (or *process-messages-even-if-deleted*
	  (not (send self :Sequence-Deleted message-number))
      )
      (multiple-value-bind (frame zwei:*window*)
	  (if window (values (send window :Superior) window) (find-zmacs-frame))
	(declare (special zwei:*window*))
	(let ((buffer-name (Make-Read-Buffer-Name message-number self)))
	     (if (Find-Mail-Buffer buffer-name)
		 (let ((buffer (Find-Mail-Buffer buffer-name)))
		      (send frame :Select)
		      (funcall (send frame :editor-closure)
			       'Prepare-Mail-read-Buffer buffer owner
			       self message-number continuation-method
			       extra-things-to-do
		      )
		 )
		 (let ((buffer
			 (Inside-Zmacs (frame)
			   (yw-zwei:open-read-buffer buffer-name)
			 )
		       )
		       (path
			 (make-pathname :Host "ED-BUFFER" :Name buffer-name)
		       )
		       (*owning-cache-entry*
			 (cache-entry-of (number-of message-number)
					 (send self :mailstream)
			 )
		       )
		       (*owning-mailstream* (send self :mailstream))
		      )
		      (declare (special *owning-cache-entry*
					*owning-mailstream*
			       )
		      )
		      (send *address-server* :Put-Task
			    :IMAP-Parse-Addresses-In-Envelope
			    (list :Parse-Envelope
				  (Cache-Envelope *owning-cache-entry*)
				  *owning-cache-entry*
				  (send self :Mailstream)
		            )
	              )
		      (with-open-file (ed-stream path :Direction :output)
			(send self :insert-text-into-zmacs
			      ed-stream buffer message-number frame
			)
			(send frame :Select)
			(funcall (send frame :editor-closure)
				 'Prepare-Mail-Read-Buffer buffer owner
				 self message-number continuation-method
				 extra-things-to-do
			)
			(send self :Highlight-Message message-number :read)
			(send *edit-server* :Put-Task :Mark-Messages-Read
			      `(:Mark-Message ,(send self :Mailstream)
					      ,Message-number
			       )
			)
			buffer
		      )
		 )
	     )
	)
      )
      (progn (format-scroll-window *owning-window*
		      "~&Message ~A ignored because it is deleted."
		      message-number
	     )
	     :try-the-next
      )
  )
)

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

(defflavor user-filter-sequence
	   ((user-filter-name nil))
	   (message-sequence)
  :Initable-Instance-Variables
)

(defwhopper (user-filter-sequence :reconstruction-init-plist) ()
  (let ((run-super (continue-whopper)))
       (cons :User-Filter-Name (cons user-filter-name run-super))
  )
)

(defmethod (user-filter-sequence :Print-Self) (stream depth slashify)
  (ignore depth)
  (catch-error
    (if (and (boundp-in-instance self 'owner)
	     (boundp-in-instance self 'mailbox)
	)
        (if (or slashify *dbg*)
	    (if (not sequence-specifier)
		(format stream "#<Seq ~A ~>" user-filter-name
		  (list mailbox nil (send self :short-name))
		)
		(format stream "#<Seq ~A ~, ~>" user-filter-name
		  (list sequence-specifier nil
			(make-label-from-filter sequence-specifier)
		  )
		  (list mailbox nil (send self :short-name))
		)
	    )
	    (if (or (not sequence-specifier) (not user-filter-name))
		(format stream "All Messages")
		(format stream "~A" user-filter-name)
	    )
	)
	(format stream "#<Seq {Uninitialised}>")
    )
    nil
  )
)

(defmethod (user-filter-sequence :Make-Label) ()
  (if (and user-filter-name sequence-specifier)
      (if *display-expanded-name-of-filters-in-labels-p*
	  (let ((body (Make-Label-From-Filter sequence-specifier)))
	       (format nil "~A {~A}" (format nil "~A" self) body)
	  )
	  (format nil "~A" (format nil "~A" self))
      )
      ""
  )
)

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

;;; User defined filters.

(defun get-string (x)
  (typecase x
    (symbol (symbol-name x))
    (string x)
    (otherwise (yw-error nil "~S cannot be coerced into a string." x))
  )
)

(defun parse-filter-cons (exp)
  (if (boundp (get-filter-representation (first exp)))
      (values (symbol-value (get-filter-representation (first exp)))
	      (get-filter-printed-representation (first exp))
      )
      (let ((operator
	      (intern (string-append "SEQUENCE-" (get-string (first exp)))
		      :Keyword
	      )
	    )
	   )
	   (cons operator (mapcar 'parse-filter-expression (rest exp)))
      )
  )
)

(defun parse-filter-expression (exp)
  (if (consp exp)
      (parse-filter-cons exp)
      (typecase exp
	(string exp)
	(symbol (symbol-name exp))
	(otherwise exp)
      )
  )
)

(defun apply-filter-1 (filter owner mailbox)
  (if (consp filter)
      (make-a-sequence 'Message-Sequence
		       :owner owner
		       :Mailbox mailbox
		       :Sequence-Specifier
		        (cons (first filter)
			      (mapcar #'(lambda (x)
					  (apply-filter-1 x owner mailbox)
					)
					(rest filter)
			      )
			)
      )
      filter
  )
)

(defun apply-filter (filter user-filter-name owner mailbox)
  (typecase filter
    (symbol (Apply-Filter
	      (symbol-value (get-filter-representation filter))
	      (get-filter-printed-representation filter)
	      owner mailbox
	    )
    )
    (cons (make-a-sequence (if user-filter-name
			       'User-Filter-Sequence
			       'Message-Sequence
			   )
			   :User-Filter-Name user-filter-name
			   :Owner owner
			   :Mailbox mailbox
			   :Sequence-Specifier
			    (cons (first filter)
				  (mapcar #'(lambda (x)
					      (apply-filter-1 x owner mailbox)
					    )
					    (rest filter)
				  )
			    )
	  )
    )
    (string (let ((seq (parse-a-sequence-from-string filter owner)))
	         (if (typep seq 'closure)
		     (copy-and-concretify-filter
		       (funcall seq) owner mailbox
		       (if user-filter-name
			   'User-Filter-Sequence
			   'Message-Sequence
		       )
		       :User-Filter-Name user-filter-name
		     )
		     (yw-warn "Cannot apply filter ~S.  ~
                               It is illegal in some way." filter
                     )
		 )
	    )
    )
    (otherwise
     (yw-warn "Cannot apply filter ~S.  It is illegal in some way." filter)
    )
  )
)
;-------------------------------------------------------------------------------