;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI; Base:8; Readtable:ZL -*- 
;;; Buffer handling, definition are in DEFS
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **
;;; An invalid Enhancements copyright notice on AI:ZMAIL;MFILES 236 removed on 5/7/82 by RG
;;;  This file had been installed as the official MIT source in direct contravention
;;;  to instructions to Symbolics personnel acting on MIT's behalf.

(TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* ZMAIL-BUFFER "Select"
			  SELECT-ZMAIL-BUFFER T
			  "Select this buffer.")

(DEFUN SELECT-ZMAIL-BUFFER (ZMAIL-BUFFER &OPTIONAL PRIMARY-TOO (MSG-TOO T))
  "Make ZMAIL-BUFFER be ZMAIL's selected buffer (the value of *ZMAIL-BUFFER*).
MSG-TOO non-NIL (the default) means also reselect a message, *MSG* if possible.
PRIMARY-TOO non-NIL says make this buffer the primary buffer."
  (COND (ZMAIL-BUFFER
	 (COND ((AND *ZMAIL-BUFFER* *MSG*)
		(SETF (ZMAIL-BUFFER-SAVED-CURRENT-MSG *ZMAIL-BUFFER*) *MSG*)
		(MSG-POINT-PDL-PUSH *MSG* *ZMAIL-BUFFER*)))
	 (OR (TYPEP ZMAIL-BUFFER 'INBOX-BUFFER)
	     (SETQ *ZMAIL-BUFFER-LIST* (CONS ZMAIL-BUFFER (DELQ ZMAIL-BUFFER *ZMAIL-BUFFER-LIST*))))
	 (SETQ *ZMAIL-FILE-NAME* (ZMAIL-BUFFER-NAME ZMAIL-BUFFER)))
	(T
	 (SETQ *ZMAIL-FILE-NAME* "No current buffer")))
  (SEND *SUMMARY-WINDOW* :SET-CURRENT-ZMAIL-BUFFER ZMAIL-BUFFER)
  (AND PRIMARY-TOO (SETQ *PRIMARY-ZMAIL-BUFFER* ZMAIL-BUFFER))
  (SETQ *ZMAIL-BUFFER* ZMAIL-BUFFER)
  (SETQ *INTERVAL* ZMAIL-BUFFER)
  (DOLIST (COM '(COM-ZMAIL-SELECT COM-ZMAIL-SORT COM-ZMAIL-RENAME-BUFFER
		 SET-MSG-SUMMARY-LINE))
    (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION COM))
  (AND MSG-TOO (ZMAIL-SELECT-MSG *MSG* T NIL)))

(DEFUN GET-ZMAIL-BUFFER-FROM-NAME (NAME &OPTIONAL CREATE-P)
  "Given a string, return ZMAIL buffer with that name.
CREATE-P says create one (parsing name as pathname) if none.
Otherwise return NIL in that case."
  (COND ((DOLIST (ZMAIL-BUFFER *ZMAIL-BUFFER-LIST*)
	   (AND (STRING-EQUAL NAME (ZMAIL-BUFFER-NAME ZMAIL-BUFFER))
		(RETURN ZMAIL-BUFFER))))
	(CREATE-P
	 (ZMAIL-FIND-FILE-NOSELECT
	   (LET ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* T))
	     (FS:MERGE-PATHNAME-DEFAULTS NAME *ZMAIL-PATHNAME-DEFAULTS*))))))

(DEFUN GET-ZMAIL-BUFFER-FROM-PATHNAME (PATHNAME &OPTIONAL CREATE-P)
  "Return the ZMAIL buffer visiting PATHNAME.
CREATE-P non-NIL says visit the file if there is none.
Otherwise return NIL in that case."
  (LET ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* T))
    (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME *ZMAIL-PATHNAME-DEFAULTS*)))
  (COND ((DOLIST (ZMAIL-BUFFER *ZMAIL-BUFFER-LIST*)
	   (AND (ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER)
		(EQ (FS:TRANSLATED-PATHNAME PATHNAME) (BUFFER-PATHNAME ZMAIL-BUFFER))
		(RETURN ZMAIL-BUFFER))))
	(CREATE-P
	 (ZMAIL-FIND-FILE-NOSELECT PATHNAME))))

(DEFUN MSG-IN-ZMAIL-BUFFER-P (MSG ZMAIL-BUFFER &AUX ARRAY)
  "T if MSG is one of the messages in ZMAIL-BUFFER.
Note that a message can be in more than one ZMAIL buffer;
only one non temporary one, but any number of temporaries."
  (SETQ ARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER))
  (DO ((I 0 (1+ I))
       (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)))
      (( I NMSGS))
    (AND (EQ MSG (AREF ARRAY I))
	 (RETURN I))))

(DEFUN LOCATE-MSG-IN-ZMAIL-BUFFER (MSG ZMAIL-BUFFER &AUX HINT)
  "Return the index of MSG in ZMAIL-BUFFER.  Error if not in that buffer."
  (COND ((AND (SETQ HINT (MSG-DISPLAYED-INDEX MSG))
	      (< HINT (ZMAIL-BUFFER-NMSGS ZMAIL-BUFFER))
	      (EQ MSG (AREF (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER) HINT)))
	 HINT)
	((MSG-IN-ZMAIL-BUFFER-P MSG ZMAIL-BUFFER))
	(T
	 (ZMAIL-ERROR "Cannot find ~S in ~S" MSG ZMAIL-BUFFER))))

(DEFUN MAKE-EMPTY-MSG (&AUX REAL-INTERVAL INTERVAL START-BP END-BP MSG)
  "Return a new empty MSG with no text in it."
  (SETQ REAL-INTERVAL (CREATE-INTERVAL)
	START-BP (COPY-BP (INTERVAL-FIRST-BP REAL-INTERVAL) :NORMAL)
	END-BP (COPY-BP (INTERVAL-LAST-BP REAL-INTERVAL) :MOVES)
	INTERVAL (CREATE-INTERVAL START-BP END-BP)
	MSG (MAKE-MSG :TICK (TICK)
		      :REAL-INTERVAL REAL-INTERVAL
		      :INTERVAL INTERVAL))
  (SETF (NODE-TICK (MSG-INTERVAL MSG)) (MSG-TICK MSG))
  (SETF (NODE-TICK (MSG-REAL-INTERVAL MSG)) (MSG-TICK MSG))
  (SETF (LINE-NODE (BP-LINE END-BP)) INTERVAL)
  (SETF (NODE-SUPERIOR INTERVAL) REAL-INTERVAL)
  (SETF (NODE-INFERIORS REAL-INTERVAL) (LIST INTERVAL))
  MSG)

(DEFVAR *PROPERTIES-NOT-COPIED* '(DELETED FILED))

(DEFUN COPY-MSG (MSG &AUX NMSG)
  "Return a copy of MSG."
  (SETQ NMSG (MAKE-EMPTY-MSG))
  (SETF (MSG-STATUS NMSG)
	(SOME-PLIST-NOT (CAR (ASSURE-MSG-PARSED MSG)) *PROPERTIES-NOT-COPIED*))
  (SETF (MSG-PARSED-P NMSG) T)
  (LET* ((OLD-LINE (MSG-SUMMARY-LINE MSG))
	 (NEW-LINE (MAKE-SUMMARY-LINE :MAKE-ARRAY (:LENGTH (ARRAY-ACTIVE-LENGTH OLD-LINE)))))
    (SETF (MSG-SUMMARY-LINE NMSG) NEW-LINE)
    (COPY-ARRAY-CONTENTS-AND-LEADER OLD-LINE NEW-LINE))
  (SETF (NODE-UNDO-STATUS (MSG-REAL-INTERVAL NMSG)) :DONT)
  (INSERT-INTERVAL (MSG-END-BP NMSG) (MSG-INTERVAL MSG))
  ;; Mpdify the HEADERS-END-BP property in the MSG-STATUS
  ;; so that it points into the copied text.
  ;; Try to preserve where it points.
  (LET ((HEADERS-END-BP (GET (LOCF (MSG-STATUS MSG)) 'HEADERS-END-BP)))
    (WHEN HEADERS-END-BP
      (DO ((OLINE (BP-LINE (INTERVAL-FIRST-BP (MSG-INTERVAL MSG))) (LINE-NEXT OLINE))
	   (NLINE (BP-LINE (INTERVAL-FIRST-BP (MSG-INTERVAL NMSG))) (LINE-NEXT NLINE)))
	  ((OR (NULL OLINE) (NULL NLINE))
	   (REMPROP (LOCF (MSG-STATUS NMSG)) 'HEADERS-END-BP))
	;; When we find the line in the old interval that the old bp points to,
	;; make the new bp point at the corresponding new line.
	(WHEN (EQ OLINE (CAR HEADERS-END-BP))
	  (PUTPROP (LOCF (MSG-STATUS NMSG)) (CREATE-BP NLINE (BP-INDEX HEADERS-END-BP))
		   'HEADERS-END-BP)
	  (RETURN)))))
  NMSG)

;;; Changing the options of a mail file.

(DEFVAR *ZMAIL-BUFFER-FLAVOR-ALIST* NIL
  "Alist of pretty names of ZMAIL flavors vs actual names.
For user in choosing a flavor as part of setting file options.")

(DEFUN ADD-ZMAIL-BUFFER-FLAVOR (FLAVOR NAME &AUX ELEM)
  (IF (SETQ ELEM (ASS 'EQUALP NAME *ZMAIL-BUFFER-FLAVOR-ALIST*))
      (SETF (CDR ELEM) FLAVOR)
    (PUSH (CONS NAME FLAVOR) *ZMAIL-BUFFER-FLAVOR-ALIST*)))

(DEFVAR *ZMAIL-BUFFER-OPTION-ALIST* NIL)

(DEFMACRO DEFINE-SETTABLE-MAIL-FILE-OPTION (OPTION DEFAULT &OPTIONAL TYPE NAME &REST ARGS)
  `(TV:DEFINE-USER-OPTION-1 ',OPTION '*ZMAIL-BUFFER-OPTION-ALIST* ,DEFAULT
			    ',(OR TYPE :SEXP)
			    ',(OR NAME (MAKE-COMMAND-NAME OPTION)) . ,ARGS))

(DEFMACRO DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION (OPTION)
  `(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION-1 ',OPTION))

(DEFUN DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION-1 (OPTION)
  (OR (ASSQ OPTION *ZMAIL-BUFFER-OPTION-ALIST*)
      (PUSH (NCONS OPTION) *ZMAIL-BUFFER-OPTION-ALIST*)))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :APPEND NIL :BOOLEAN
  "Append messages moved into file")

(DEFUN CHOOSE-MAIL-FILE-OPTIONS (ZMAIL-BUFFER &AUX OLD-FLAVOR OLD-APPEND-P PATHNAME FLAVOR
				 APPEND-P OPTIONS PLIST OLD-SUMMARY-FORMAT WANT-TO-REVERSE)
  (SETQ OLD-FLAVOR (TYPE-OF ZMAIL-BUFFER)
	PATHNAME (BUFFER-PATHNAME ZMAIL-BUFFER)
	OPTIONS (ZMAIL-BUFFER-OPTIONS ZMAIL-BUFFER)
	PLIST (LOCF OPTIONS)
	OLD-APPEND-P (GET PLIST :APPEND)
	OLD-SUMMARY-FORMAT (GET PLIST :SUMMARY-WINDOW-OPTIONS))
  (*CATCH 'ZWEI-COMMAND-LOOP			;In case aborted
    (MULTIPLE-VALUE (FLAVOR OPTIONS)
      (CHOOSE-MAIL-FILE-OPTIONS-1 PATHNAME OLD-FLAVOR OPTIONS))
    (SETQ APPEND-P (GET PLIST :APPEND))
    (AND (NEQ APPEND-P OLD-APPEND-P)
	 (> (ZMAIL-BUFFER-NMSGS ZMAIL-BUFFER) 1)
	 (TYPEOUT-BEEP-YES-OR-NO-P "Reverse the messages already in ~A? " PATHNAME)
	 (SETQ WANT-TO-REVERSE T))
    (COND ((NEQ FLAVOR OLD-FLAVOR)
	   (REMPROP PLIST :APPEND)
	   (LET ((NEW-ZMAIL-BUFFER (MAKE-ZMAIL-BUFFER FLAVOR
						      :PATHNAME PATHNAME :FILE-ID T
						      :OPTIONS OPTIONS :APPEND-P APPEND-P)))
	     ;; ADD-ZMAIL-BUFFER adds messages in forward order, so that if the file is
	     ;; prepended, they would be reversed accidentally.  Similary, if now in append
	     ;; mode, must reverse first to get old prepend mode messages right.
	     (AND (EQ WANT-TO-REVERSE APPEND-P)
		  (REVERSE-ZMAIL-BUFFER ZMAIL-BUFFER))
	     (SEND NEW-ZMAIL-BUFFER :ADD-ZMAIL-BUFFER ZMAIL-BUFFER)
	     (LET ((OLD-SELECTED-P (EQ ZMAIL-BUFFER *ZMAIL-BUFFER*))
		   (OLD-PRIMARY-P (EQ ZMAIL-BUFFER *PRIMARY-ZMAIL-BUFFER*)))
	       (KILL-ZMAIL-BUFFER ZMAIL-BUFFER)
	       (AND OLD-SELECTED-P (SELECT-ZMAIL-BUFFER NEW-ZMAIL-BUFFER OLD-PRIMARY-P)))))
	  (T
	   (AND WANT-TO-REVERSE (REVERSE-ZMAIL-BUFFER ZMAIL-BUFFER))
	   (SEND ZMAIL-BUFFER :SET-OPTIONS OPTIONS))))
  (OR (EQ OLD-SUMMARY-FORMAT (GET PLIST :SUMMARY-WINDOW-OPTIONS))
      (CHANGE-ZMAIL-BUFFER-MSGS-SUMMARY-LINES ZMAIL-BUFFER))
  (AND (EQ ZMAIL-BUFFER *ZMAIL-BUFFER*)
       (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-SORT)))

(DEFUN CHOOSE-MAIL-FILE-OPTIONS-1 (PATHNAME FLAVOR OPTIONS &OPTIONAL (NEAR-MODE '(:MOUSE))
							   &AUX VARS VALS)
  (DECLARE (RETURN-LIST FLAVOR OPTIONS))
  (SETQ VARS (NCONS 'FLAVOR)
	VALS (NCONS FLAVOR))
  (LOOP FOR POSS IN *ZMAIL-BUFFER-OPTION-ALIST*
	AS VAR = (CAR POSS)
	AS TEM = (NCONS VAR)
	WITH PLIST = (LOCF OPTIONS)
	DO (SETQ VARS (NCONC VARS TEM))
	   (SETQ VALS (NCONC VALS (NCONS (GET PLIST (CAR TEM) (GET VAR 'TV:DEFAULT-VALUE))))))
  (LET ((*POSSIBLE-FLAVORS*
	  (LOOP FOR FLAVOR IN (SEND PATHNAME :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS)
		COLLECT (RASSQ FLAVOR *ZMAIL-BUFFER-FLAVOR-ALIST*) INTO FOO
		FINALLY (RETURN (NCONC FOO (NCONS (RASSQ 'TEXT-MAIL-FILE-BUFFER
							 *ZMAIL-BUFFER-FLAVOR-ALIST*)))))))
    (DECLARE (SPECIAL *POSSIBLE-FLAVORS*))
    (PROGV VARS VALS
      (TV:CHOOSE-VARIABLE-VALUES (COMPUTE-ZMAIL-BUFFER-CHOICES FLAVOR)
				 :LABEL (FORMAT NIL "Options for ~A:" PATHNAME)
				 :NEAR-MODE NEAR-MODE
				 :MARGIN-CHOICES '("Do It"
						    ("Abort" (ABORT-CURRENT-COMMAND)))
				 :FUNCTION 'CHOOSE-MAIL-FILE-OPTIONS-FUNCTION)
      (SETQ FLAVOR (SYMEVAL 'FLAVOR))
      ;; Somewhat of a kludge
      (AND (MEMQ :MAIL VARS)
	   (DO L (SYMEVAL :MAIL) (CDR L) (NULL L)
	       (LET ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* T))
		 (SETF (CAR L) (FS:MERGE-PATHNAME-DEFAULTS (CAR L) *ZMAIL-PATHNAME-DEFAULTS*)))))
      (SETQ OPTIONS
	    (LOOP FOR VAR IN (LET (SELF)
			       (SEND (SI:GET-FLAVOR-HANDLER-FOR FLAVOR :POSSIBLE-OPTIONS)
					:POSSIBLE-OPTIONS))
		  NCONC `(,VAR ,(SYMEVAL VAR))))))
  (VALUES FLAVOR OPTIONS))

(DEFUN CHOOSE-MAIL-FILE-OPTIONS-FUNCTION (WINDOW VARIABLE OLDVAL NEWVAL)
  OLDVAL
  (COND ((EQ VARIABLE 'FLAVOR)
	 (TV:WITH-SHEET-DEEXPOSED (WINDOW)
	   (SEND WINDOW :SETUP (COMPUTE-ZMAIL-BUFFER-CHOICES NEWVAL)
		    (SEND WINDOW :LABEL)
		    (SEND WINDOW :FUNCTION)
		    (SYMEVAL-IN-INSTANCE WINDOW 'TV:MARGIN-CHOICES)))
	 T)))

(DEFUN COMPUTE-ZMAIL-BUFFER-CHOICES (FLAVOR)
  (DECLARE (SPECIAL *POSSIBLE-FLAVORS*))
  `((FLAVOR "Format" :ASSOC ,*POSSIBLE-FLAVORS*)
    . ,(MAPCAR #'(LAMBDA (X) (ASSQ X *ZMAIL-BUFFER-OPTION-ALIST*))
	       (LET (SELF)
		 (SEND (SI:GET-FLAVOR-HANDLER-FOR FLAVOR :SETTABLE-OPTIONS)
			  :SETTABLE-OPTIONS)))))

;;; Operating on ZMAIL buffers.

(DEFUN MAKE-ZMAIL-BUFFER (TYPE &REST OPTIONS)
  (APPLY 'MAKE-INSTANCE TYPE OPTIONS))

(DEFMETHOD (ZMAIL-BUFFER :AFTER :INIT) (PLIST)
  (SETQ ARRAY (MAKE-ARRAY 100 :FILL-POINTER 0 :area *zmail-msg-area*))
  (AND (GET PLIST :APPEND-P)
       (PUTPROP (LOCF OPTIONS) T :APPEND)))

(DEFMETHOD (ZMAIL-BUFFER :WINDOWS) ()
  (SUBSET #'(LAMBDA (WINDOW) (EQ SELF (WINDOW-INTERVAL WINDOW)))
	  *ALL-ZMAIL-WINDOWS*))

(DEFMETHOD (ZMAIL-BUFFER :OTHER-WINDOWS) (WINDOW)
  (DECLARE (SPECIAL WINDOW))
  (SUBSET #'(LAMBDA (W) (AND (NEQ W WINDOW) (EQ SELF (WINDOW-INTERVAL W))))
	  *ALL-ZMAIL-WINDOWS*))

(DEFMETHOD (ZMAIL-BUFFER :POSSIBLE-WINDOWS) ()
  *ALL-ZMAIL-WINDOWS*)

(DEFMETHOD (ZMAIL-BUFFER :POINT) ()
  (ZMAIL-ERROR "Should not get here."))

(DEFMETHOD (ZMAIL-BUFFER :MARK) ()
  (ZMAIL-ERROR "Should not get here."))

(DEFMETHOD (ZMAIL-BUFFER :RENAME) (NEW-NAME)
  (SETQ NAME NEW-NAME)
  (IF (EQ SELF *ZMAIL-BUFFER*)
      (SETQ *ZMAIL-FILE-NAME* NEW-NAME)))

(DEFMETHOD (ZMAIL-BUFFER :REVERT) (&REST IGNORE)
  (ZMAIL-ERROR "Should not get here."))

(DEFMETHOD (ZMAIL-BUFFER :ACTIVATE) ()
  (SETQ *ZMAIL-BUFFER-LIST* (NCONC *ZMAIL-BUFFER-LIST* (NCONS SELF)))
  ;; We may make another buffer available for left on Select.
  (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-SELECT))

(DEFMETHOD (ZMAIL-BUFFER :SELECT) ()
  (ZMAIL-ERROR "Should not get here."))

(DEFMETHOD (ZMAIL-BUFFER :SECTIONIZE) ()
  (ZMAIL-ERROR "Should not get here."))

(DEFMETHOD (ZMAIL-BUFFER :RESECTIONIZE) ()
  (ZMAIL-ERROR "Should not get here."))

(DEFMETHOD (ZMAIL-BUFFER :SET-READ-ONLY-P) (IGNORE)
  (ZMAIL-ERROR "Should not get here."))

(DEFMETHOD (ZMAIL-BUFFER :MODIFIED-P) ()
  "T if ZMAIL-BUFFER has unsaved changes."
  (DOMSGS (MSG SELF)
    (SEND SELF :UPDATE-MSG-OPTIONS-IN-FILE-IF-NECESSARY MSG))
  (COND ((ZMAIL-BUFFER-DISK-P SELF)
	 (SETF (ZMAIL-DISK-BUFFER-MSG-UPDATE-TICK SELF) (TICK))
	 ;; This may require that the file be saved out.
	 (SEND SELF :UPDATE-OPTIONS-IN-FILE)
	 (OR (EQ (BUFFER-FILE-ID SELF) T)
	     (> (NODE-TICK SELF)
		(BUFFER-TICK SELF))))))

(DEFMETHOD (ZMAIL-BUFFER :KILL) ()
  (SETQ *ZMAIL-BUFFER-LIST* (DELQ SELF *ZMAIL-BUFFER-LIST*))
  (MSG-POINT-PDL-PURGE NIL SELF)
  (AND (EQ SELF *PRIMARY-ZMAIL-BUFFER*)
       (SETQ *PRIMARY-ZMAIL-BUFFER* NIL))
  (AND (EQ SELF *ZMAIL-BUFFER*)
       (SELECT-ZMAIL-BUFFER (CAR *ZMAIL-BUFFER-LIST*)))
  (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-SELECT))

(DEFMETHOD (ZMAIL-BUFFER :ADD-MSG) (MSG &OPTIONAL AT-INDEX &AUX LEN)
  (SETQ LEN (ARRAY-ACTIVE-LENGTH ARRAY))
  (COND ((NOT (DOTIMES (I LEN) ;If not already in file
		(AND (EQ MSG (AREF ARRAY I)) (RETURN T))))
	 (OR AT-INDEX
	     (SETQ AT-INDEX (LET (PREDICATE APPEND-P)
			      (LET ((PLIST (LOCF OPTIONS)))
				(SETQ PREDICATE (GET PLIST :SORT)
				      APPEND-P (GET PLIST :APPEND)))
			      (IF (NULL PREDICATE)
				  (IF APPEND-P LEN 0)
				(LOOP FOR I FROM 0 TO LEN
				      WHEN (OR (= I LEN)
					       (EQ APPEND-P
						   (FUNCALL PREDICATE MSG (AREF ARRAY I))))
				      DO (RETURN I))))))		
	 (AND (< (ARRAY-LENGTH ARRAY) (1+ LEN))
	      (ADJUST-ARRAY-SIZE ARRAY (TRUNCATE (* LEN 5) 4)))
	 (SETF (FILL-POINTER ARRAY) (1+ LEN))
	 (SETQ MSG (SEND SELF :ADD-MSG-TEXT MSG AT-INDEX))
	 (DO ((I LEN (1- I))
	      (J (1- LEN) (1- J)))
	     ((< J AT-INDEX))
	   (ASET (AREF ARRAY J) ARRAY I))
	 (ASET MSG ARRAY AT-INDEX))))

(DEFMETHOD (ZMAIL-BUFFER :ADD-ZMAIL-BUFFER) (ZMAIL-BUFFER &AUX NARRAY NLENGTH PREDICATE APPEND-P)
  (SETQ NARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER)
	NLENGTH (ARRAY-ACTIVE-LENGTH NARRAY))
  (unless (zerop nlength)
    (LET ((PLIST (LOCF OPTIONS)))
      (SETQ PREDICATE (GET PLIST :SORT)
	    APPEND-P (GET PLIST :APPEND)))
    (AND (> NLENGTH 1)
	 (OR PREDICATE (NULL APPEND-P))
	 (LET ((NNARRAY (MAKE-ARRAY NLENGTH)))
	   (COPY-ARRAY-CONTENTS NARRAY NNARRAY)
	   (IF (NULL PREDICATE)
	       (NREVERSE NNARRAY)
	     (FUNCALL (IF APPEND-P 'STABLE-SORT 'REVERSE-STABLE-SORT) NNARRAY PREDICATE))
	   (SETQ NARRAY NNARRAY)))
    ;; Now merge
    (LOOP FOR OLD-IDX FROM 0
	  WITH LENGTH = (ARRAY-ACTIVE-LENGTH ARRAY)
	  AND NEW-IDX = 0
	  AS NMSG = (AREF NARRAY NEW-IDX)
	  WHEN (OR ( OLD-IDX LENGTH)
		   (EQ APPEND-P (AND PREDICATE (FUNCALL PREDICATE NMSG (AREF ARRAY OLD-IDX)))))
	  DO (SEND SELF :ADD-MSG NMSG OLD-IDX)
	  (INCF NEW-IDX)
	  (INCF LENGTH)
	  UNTIL ( NEW-IDX NLENGTH))))

(DEFMETHOD (ZMAIL-BUFFER :ADD-MSG-TEXT) (MSG AT-INDEX)
  AT-INDEX					;Not used
  MSG)

(DEFMETHOD (ZMAIL-BUFFER :READ-NEXT-MSG) (&OPTIONAL IGNORE)
  NIL)

(DEFMETHOD (ZMAIL-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE-IF-NECESSARY) (MSG)
  MSG)

(DEFMETHOD (ZMAIL-BUFFER :FULL-NAME) ()
  (SEND SELF :NAME))

(DEFUN TEMP-ZMAIL-BUFFER-AVAILABLE-P (IGNORE ZMAIL-BUFFER IGNORE)
  (NOT (MEMQ ZMAIL-BUFFER *ZMAIL-BUFFER-LIST*)))

(DEFUN MAKE-TEMP-ZMAIL-BUFFER (IGNORE)
  (MAKE-ZMAIL-BUFFER 'TEMP-ZMAIL-BUFFER :APPEND-P T))

(DEFUN MAKE-NEW-TEMP-ZMAIL-BUFFER (NAME &OPTIONAL (FULL-NAME NAME) &AUX ZMAIL-BUFFER)
  (SETQ ZMAIL-BUFFER (ALLOCATE-RESOURCE 'TEMP-ZMAIL-BUFFER))
  (SETF (ZMAIL-BUFFER-NAME ZMAIL-BUFFER) NAME)
  (SEND ZMAIL-BUFFER :SET-FULL-NAME FULL-NAME)
  (SETF (ZMAIL-BUFFER-SAVED-CURRENT-MSG ZMAIL-BUFFER) NIL)
  (SETF (NODE-TICK ZMAIL-BUFFER) (TICK))
  (SEND ZMAIL-BUFFER :ACTIVATE)
  ZMAIL-BUFFER)

;;; Disk buffers
(DEFMETHOD (ZMAIL-DISK-BUFFER :BEFORE :KILL) ()
  (DOMSGS (MSG SELF)
    (SETF (MSG-PARSED-P MSG) :KILLED))
  ;; Get rid of any messages we killed this way
  (LOOP FOR ZMAIL-BUFFER IN *ZMAIL-BUFFER-LIST*
	WHEN (NOT (ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER))
	DO (EXPUNGE-ZMAIL-BUFFER ZMAIL-BUFFER NIL)))

(DEFMETHOD (ZMAIL-DISK-BUFFER :PARSE-MSG) (MSG -STATUS-)
  (SET-PARSED-MSG-HEADERS MSG -STATUS-))

(DEFMETHOD (ZMAIL-DISK-BUFFER :PARSE-MSG-TEXT) (MSG IGNORE)
  (PARSE-HEADERS-INTERVAL (MSG-INTERVAL MSG) NIL NIL T))

(DEFMETHOD (ZMAIL-DISK-BUFFER :UPDATE-MSG-END) (MSG &OPTIONAL IGNORE)
  MSG)

;;; MAIL-FILE-BUFFERs.

;;; ALWAYS-NEW means do not read in any old file.  FLAVOR overrides any default
(DEFUN ZMAIL-FIND-FILE-NOSELECT (PATHNAME &OPTIONAL (NEAR-MODE '(:MOUSE)) FLAVOR ALWAYS-NEW
				 &AUX STREAM)
  (DECLARE (RETURN-LIST ZMAIL-BUFFER NEW-P))
  (LET ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* T))
    (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME *ZMAIL-PATHNAME-DEFAULTS*)) )
  (SETQ PATHNAME (SEND PATHNAME :TRANSLATED-PATHNAME))
  (COND ((NOT (OR ALWAYS-NEW
		  (ERRORP (SETQ STREAM (OPEN PATHNAME '(:IN :NOERROR))))))
	 (GET-ZMAIL-FILE STREAM PATHNAME NIL FLAVOR))
	((AND STREAM
	      (NOT (CONDITION-TYPEP STREAM 'FS:FILE-NOT-FOUND)))
	 (BARF STREAM))
	(T
	 (FORMAT *QUERY-IO* "~&New file: ~A" PATHNAME)
	 (VALUES (ZMAIL-FIND-FILE-NOSELECT-1
		   PATHNAME
		   (COND ((OR ALWAYS-NEW (NULL *ZMAIL-BUFFER*)) NIL)
			 ((AND *DEFAULT-MOVE-ZMAIL-BUFFER*
			       (ZMAIL-BUFFER-DISK-P
				 *DEFAULT-MOVE-ZMAIL-BUFFER*))
			  *DEFAULT-MOVE-ZMAIL-BUFFER*)
			 ((ZMAIL-BUFFER-DISK-P *ZMAIL-BUFFER*)
			  *ZMAIL-BUFFER*)
			 (*PRIMARY-ZMAIL-BUFFER*))
		   NEAR-MODE
		   FLAVOR)
		 T))))

(DEFUN ZMAIL-FIND-FILE-NOSELECT-1 (PATHNAME &OPTIONAL ZMAIL-BUFFER NEAR-MODE FLAVOR PRIMARY-P
				   &AUX OPTIONS PLIST APPEND-P)
  (SETQ PLIST (LOCF OPTIONS))
  (COND (ZMAIL-BUFFER
	 (SETQ FLAVOR (TYPE-OF ZMAIL-BUFFER)
	       OPTIONS (SEND ZMAIL-BUFFER :STICKY-OPTIONS)
	       APPEND-P (GET PLIST :APPEND)))
	((NULL FLAVOR)
	 (MULTIPLE-VALUE (FLAVOR APPEND-P)
	   (SEND PATHNAME :MAIL-FILE-FORMAT-COMPUTER NIL))))
  (SETQ APPEND-P (CASE *NEW-MAIL-FILE-APPEND-P*
		   (:APPEND T)
		   (:PREPEND NIL)
		   (:STICKY APPEND-P)
		   (:ASK (IF (EQ *ZMAIL-COMMAND-BUTTON* :RIGHT)
			     APPEND-P
			   (LET ((CHOICE (TV:MENU-CHOOSE '(("Append" . :APPEND)
							   ("Prepend" . :PREPEND)))))
			     (OR CHOICE (ABORT-CURRENT-COMMAND))
			     (EQ CHOICE :APPEND))))))
  (COND ((EQ *ZMAIL-COMMAND-BUTTON* :RIGHT)
	 (PUTPROP PLIST APPEND-P :APPEND)
	 (OR NEAR-MODE (SETQ NEAR-MODE '(:MOUSE)))
	 (MULTIPLE-VALUE (FLAVOR OPTIONS)
	   (CHOOSE-MAIL-FILE-OPTIONS-1 PATHNAME FLAVOR OPTIONS NEAR-MODE))
	 (SETQ APPEND-P (CAR (REMPROP PLIST :APPEND))))
	(T
	 (REMPROP PLIST :APPEND)))			;Do not get confused in :INIT method
  (let ((buffer (MAKE-ZMAIL-BUFFER FLAVOR :PATHNAME PATHNAME :FILE-ID T
				   :OPTIONS OPTIONS :APPEND-P APPEND-P
				   :NEW-PRIMARY-P PRIMARY-P)))
    (setf (get buffer 'generation-retention-count) *default-mail-buffer-generation-retention-count*)
    buffer))

(DEFMETHOD (MAIL-FILE-BUFFER :SETTABLE-OPTIONS) ()
  NIL)

(DEFMETHOD (MAIL-FILE-BUFFER :POSSIBLE-OPTIONS) ()
  '(:APPEND))

(DEFMETHOD (MAIL-FILE-BUFFER :STICKY-OPTIONS) ()
  (SOME-PLIST OPTIONS '(:APPEND)))

(DEFMETHOD (MAIL-FILE-BUFFER :AFTER :INIT) (IGNORE)
  (SETQ NAME (SEND PATHNAME :STRING-FOR-EDITOR))
  (SETQ FILE-TICK TICK)
  (SETQ MSG-UPDATE-TICK TICK)
  (AND STREAM (SETQ STATUS :LOADING))
  (SEND SELF :ACTIVATE))

(DEFMETHOD (MAIL-FILE-BUFFER :INBOX-BUFFER) (&OPTIONAL NEW-PATHNAME DELETE-P &AUX LIST)
  (IF NEW-PATHNAME
      (SETQ LIST (LIST (LIST NEW-PATHNAME NIL DELETE-P)))
    (SETQ NEW-PATHNAME (SEND PATHNAME :NEW-MAIL-PATHNAME))
    (SETQ LIST (LIST (LIST NEW-PATHNAME
			   (SEND NEW-PATHNAME :NEW-TYPE
				 (SEND NEW-PATHNAME
				       :ZMAIL-TEMP-FILE-NAME))
			   T)))
    (COND (*RUN-GMSGS-P*
	   (SETQ NEW-PATHNAME (SEND NEW-PATHNAME :NEW-TYPE "GMSGS"))
	   (PUSH (LIST NEW-PATHNAME
		       (SEND NEW-PATHNAME :NEW-TYPE
			     (SEND NEW-PATHNAME
				   :ZMAIL-TEMP-FILE-NAME))
		       T)
		 LIST))))
  (MAKE-INBOX-BUFFER (SEND NEW-PATHNAME :INBOX-BUFFER-FLAVOR) LIST SELF))

;;; Update the buffer version of a message's status
(DEFMETHOD (MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE-IF-NECESSARY) (MSG)
  (AND (> (MSG-TICK MSG) MSG-UPDATE-TICK)
       (SEND SELF :UPDATE-MSG-OPTIONS-IN-FILE MSG)))

(DEFMETHOD (MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE) (MSG)
  MSG)

;; Mung the message MSG so that its contents are suitable for
;; being part of this mail file buffer.
;; The headers, as well as the invisible stuff at the front and end of the message,
;; are altered to fit.
;; Also, the MSG-MAIL-FILE-BUFFER is set.
(DEFMETHOD (MAIL-FILE-BUFFER :NEW-MSG) (MSG &AUX OLD-FILE)
  (SETQ OLD-FILE (MSG-MAIL-FILE-BUFFER MSG))
  (SETF (MSG-MAIL-FILE-BUFFER MSG) SELF)
  (MULTIPLE-VALUE-BIND (BEFORE AFTER)
      (SEND SELF :NEW-HEADER-AND-TRAILER)
    (REPLACE-REAL-HEADER-AREA MSG BEFORE)
    (REPLACE-REAL-TRAILER-AREA MSG AFTER))
  (SEND SELF :UPDATE-MSG-END MSG)
  ;; If the old mail file of this message wanted different style headers,
  ;; must reformat the headers so the message can be reparsed right in this file.
  (WHEN (AND OLD-FILE (GET (LOCF (MSG-STATUS MSG)) 'HEADERS-END-BP))
    (UNLESS (MEMBER (SEND OLD-FILE :FORMAT-NAME)
		    (SEND SELF :HEADER-COMPATIBLE-MAIL-FILE-FORMATS))
      (SEND SELF :REFORMAT-MSG-HEADER MSG)))
  MSG)

;; Should return a list of :FORMAT-NAMEs of formats whose
;; header standards are the same as this mail file's format's standards.
(DEFMETHOD (MAIL-FILE-BUFFER :HEADER-COMPATIBLE-MAIL-FILE-FORMATS) ()
  (LIST (SEND SELF :FORMAT-NAME)))

;; Replace the visible header of MSG with one which has the right format
;; to be parsed in the type of mail file which SELF is.
;; The default definition makes a standard-ish network header.
(DEFMETHOD (MAIL-FILE-BUFFER :REFORMAT-MSG-HEADER) (MSG)
  (WITH-BP (SEP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG)) :MOVES)
    (LET ((STRM (INTERVAL-STREAM-INTO-BP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG)))))
      (DO ((TAIL (MSG-STATUS MSG) (CDDR TAIL)))
	  ((NULL TAIL))
	(WHEN (RASSQ (CAR TAIL) *HEADER-NAME-ALIST*)
	  (PRINT-HEADER STRM (CADR TAIL) (CAR TAIL))))
      (TERPRI STRM))
    (DELETE-INTERVAL SEP (GET (LOCF (MSG-STATUS MSG)) 'HEADERS-END-BP))))

(DEFMETHOD (MAIL-FILE-BUFFER :NEW-HEADER-AND-TRAILER) ()
  (VALUES "" ""))

(DEFUN REPLACE-REAL-HEADER-AREA (MSG STRING &AUX START-BP MSG-REAL-INTERVAL
						 PREV-END-BP PREV-END-BP-1
						 MOVE-BP-P MOVE-BP-1-P
						 NEW-BP)
  (SETQ START-BP (MSG-START-BP MSG)
	MSG-REAL-INTERVAL (MSG-REAL-INTERVAL MSG))
  (DELETE-INTERVAL (INTERVAL-FIRST-BP MSG-REAL-INTERVAL) START-BP T)
  (AND (SETQ MOVE-BP-P (NODE-PREVIOUS MSG-REAL-INTERVAL))
       (SETQ PREV-END-BP (INTERVAL-LAST-BP MOVE-BP-P)
	     PREV-END-BP-1 (INTERVAL-LAST-BP (CAR (NODE-INFERIORS MOVE-BP-P)))
	     MOVE-BP-P (BP-= PREV-END-BP START-BP)
	     MOVE-BP-1-P (BP-= PREV-END-BP-1 START-BP)))
  (SETQ NEW-BP (INSERT START-BP STRING))
  ;; If we inserted text that made the end of the previous message move accidentally,
  ;; put it back where it was.
  (AND MOVE-BP-P
       (MOVE-BP PREV-END-BP START-BP))
  (AND MOVE-BP-1-P
       (MOVE-BP PREV-END-BP-1 START-BP))
  (MOVE-BP START-BP NEW-BP)
  (SEND SELF :UPDATE-MSG-OPTIONS-IN-FILE MSG))

(DEFUN REPLACE-REAL-TRAILER-AREA (MSG STRING &AUX END-BP REAL-INTERVAL
						  NEXT-START-BP NEXT-START-BP-1
						  MOVE-BP-P MOVE-BP-1-P)
  (SETQ END-BP (MSG-END-BP MSG)
	REAL-INTERVAL (MSG-REAL-INTERVAL MSG))
  (DELETE-INTERVAL END-BP (INTERVAL-LAST-BP REAL-INTERVAL) T)
  (AND (SETQ MOVE-BP-P (NODE-NEXT REAL-INTERVAL))
       (SETQ NEXT-START-BP (INTERVAL-FIRST-BP MOVE-BP-P)
	     NEXT-START-BP-1 (INTERVAL-FIRST-BP (CAR (NODE-INFERIORS MOVE-BP-P)))
	     MOVE-BP-P (BP-= NEXT-START-BP END-BP)
	     MOVE-BP-1-P (BP-= NEXT-START-BP-1 END-BP)))
  (WITH-BP (OLD-END-BP END-BP :NORMAL)
    (INSERT-MOVING END-BP STRING)
    (AND MOVE-BP-P
	 (MOVE-BP NEXT-START-BP END-BP))
    (AND MOVE-BP-1-P
	 (MOVE-BP NEXT-START-BP-1 END-BP))
    (MOVE-BP END-BP OLD-END-BP)))

;; Return a pointer to the beginning of the first message.
;; By default, that is the beginning of the interval's contents.
(DEFMETHOD (ZMAIL-DISK-BUFFER :FIRST-MSG-BP) ()
  FIRST-BP)

;;; The count of messages can be inconsistent while the text is being added, prevent lossage
;;; with background parsing
(DEFWRAPPER (ZMAIL-DISK-BUFFER :ADD-MSG) (IGNORE . BODY)
  `(LOCK-ZMAIL-BUFFER (SELF)
     . ,BODY))

(DEFWRAPPER (ZMAIL-DISK-BUFFER :ADD-ZMAIL-BUFFER) (IGNORE . BODY)
  `(LOCK-ZMAIL-BUFFER (SELF)
     . ,BODY))

;;; This actually links in the lines of a message
(DEFMETHOD (MAIL-FILE-BUFFER :ADD-MSG-TEXT) (MSG AT-INDEX)
  (COND ((MSG-MAIL-FILE-BUFFER MSG)
	 ;; This MSG-PUT and the COPY-MSG below insure that the message has been parsed
	 ;; if its text is going to be copied.  This is necessary so that the *** EOOH ***
	 ;; line isn't copied as well.
	 (MSG-PUT MSG T 'FILED)
	 (AND *DELETE-AFTER-MOVE-TO-FILE*
	      (ZMAIL-DELETE-MSG MSG))
	 (LET ((FILE (MSG-MAIL-FILE-BUFFER MSG)))
	   (SETQ MSG (COPY-MSG MSG))
	   (SETF (MSG-MAIL-FILE-BUFFER MSG) FILE))))
  (SEND SELF :NEW-MSG MSG)
  (LET* ((MSG-INT (MSG-REAL-INTERVAL MSG))
	 (MSG-REAL-START-BP (INTERVAL-FIRST-BP MSG-INT))
	 (MSG-REAL-END-BP (INTERVAL-LAST-BP MSG-INT))
	 (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
	 (INFS (NODE-INFERIORS SELF))
	 (LINE2 (BP-LINE MSG-REAL-START-BP))
	 (LINE3 (BP-LINE MSG-REAL-END-BP))
	 PREV-MSG-END-BPS LINE1 LINE4)
    (SETF (NODE-SUPERIOR MSG-INT) SELF)
    (COND ((= AT-INDEX (1- NMSGS))		;Putting in at the end
	   (MULTIPLE-VALUE (LINE1 PREV-MSG-END-BPS)
	     (SEND SELF :LAST-LINE-FOR-APPEND (1- NMSGS))))
	  (T
	   (UNLESS (ZEROP AT-INDEX)
	     (MULTIPLE-VALUE (NIL PREV-MSG-END-BPS)
	       (SEND SELF :LAST-LINE-FOR-APPEND AT-INDEX)))
	   (LET ((NEXT-MSG (AREF ARRAY AT-INDEX)))
	     (LET ((NEXT-NODE (MSG-REAL-INTERVAL NEXT-MSG)))
	       (SETF (NODE-NEXT MSG-INT) NEXT-NODE)
	       (SETF (NODE-PREVIOUS NEXT-NODE) MSG-INT))
	     (SETQ LINE4 (BP-LINE (MSG-REAL-START-BP NEXT-MSG))
		   LINE1 (LINE-PREVIOUS LINE4)))))
    (COND (LINE1
	   (SETF (LINE-PREVIOUS LINE2) LINE1)
	   (SETF (LINE-NEXT LINE1) LINE2)
	   (DOLIST (BP PREV-MSG-END-BPS)
	     (MOVE-BP BP LINE2 0)))
	  (T
	   (MOVE-BP FIRST-BP MSG-REAL-START-BP)))
    (COND (LINE4
	   (AND (ZEROP (BP-INDEX MSG-REAL-END-BP))
		(SETQ LINE3 (LINE-PREVIOUS LINE3)))
	   (SETF (LINE-NEXT LINE3) LINE4)
	   (SETF (LINE-PREVIOUS LINE4) LINE3)
	   (LET ((MSG-END-BP (MSG-END-BP MSG)))
	     (AND (BP-= MSG-END-BP MSG-REAL-END-BP)
		  (MOVE-BP MSG-END-BP LINE4 0)))
	   (MOVE-BP MSG-REAL-END-BP LINE4 0))
	  (T
	   (MOVE-BP LAST-BP LINE3 (LINE-LENGTH LINE3))))
    (IF (ZEROP AT-INDEX)
	(SETQ INFERIORS (CONS MSG-INT INFS))
      (LET ((PREV-NODE (MSG-REAL-INTERVAL (AREF ARRAY (1- AT-INDEX)))))
	(SETF (NODE-NEXT PREV-NODE) MSG-INT)
	(SETF (NODE-PREVIOUS MSG-INT) PREV-NODE)
	(AND (SETQ INFS (MEMQ PREV-NODE INFS))
	     (PUSH MSG-INT (CDR INFS))))))
  (MUNG-NODE SELF)
  MSG)

;;; If there was a message in here before, it may not have had a  or whatever at
;;; the end of it.  Also, there may be an empty line at the end of the file
;;; which signifies a final CR, and that empty line will not be needed
;;; when more text is appended.

;;; The first value is the line to append the new text after.
;;; The second valus is a list of BPs to relocate to point at the
;;; beginning of the appended text.
(DEFMETHOD (MAIL-FILE-BUFFER :LAST-LINE-FOR-APPEND) (&OPTIONAL NMSGS
						     &AUX BP BP1 LINE PREV-END-BPS)
  (OR NMSGS (SETQ NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)))
  (IF (PLUSP NMSGS)
      (LET ((MSG (AREF ARRAY (1- NMSGS))))
	(SEND SELF :UPDATE-MSG-END MSG T)
	(SETQ BP (MSG-REAL-END-BP MSG)
	      BP1 (MSG-END-BP MSG)))
    (SETQ BP (SEND SELF :FIRST-MSG-BP)))
  (SETQ LINE (BP-LINE BP))
  (AND (ZEROP (BP-INDEX BP))
       (SETQ PREV-END-BPS
	     (IF (EQ LINE (BP-LINE BP1))
		 (LIST BP BP1)
	       (LIST BP))
;	     LINE (LINE-PREVIOUS LINE) fixes bug 337 an additional line may appear in some files as a side effect. jwc
	     ))
  (VALUES LINE PREV-END-BPS))

;;; This makes sure that a mail file that corresponds to an actual file has
;;; its messages in the right order.
(DEFUN RESPLICE-ZMAIL-BUFFER (ZMAIL-BUFFER &AUX START-LINE START-BP ARRAY)
  (SETF (NODE-TICK ZMAIL-BUFFER) (TICK))
  (OR (SETQ START-LINE (LINE-PREVIOUS (BP-LINE (SEND ZMAIL-BUFFER :FIRST-MSG-BP))))
      (SETQ START-BP (ZMAIL-BUFFER-START-BP ZMAIL-BUFFER)))
  (SETQ ARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER))
  (DO ((I 0 (1+ I))
       (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
       (LINE1 START-LINE (BP-LINE (MSG-END-BP MSG)))
       (MSG-END-BP NIL (MSG-END-BP MSG))
       (REAL-END-BP START-BP (MSG-REAL-END-BP MSG))
       (REAL-INT) (PREV-REAL-INT NIL REAL-INT)
       (LINE2) (MSG) (REAL-START-BP) (FLAG)
       (INFS NIL (CONS REAL-INT INFS)))
      (NIL)
    (AND (SETQ FLAG (AND MSG-END-BP REAL-END-BP (BP-= MSG-END-BP REAL-END-BP)))
	 (DO ((L (BP-LINE (MSG-START-BP MSG)) (LINE-NEXT L))
	      (PL LINE1 L))
	     ((EQ L LINE1) (SETQ LINE1 PL))))
    (COND (( I NMSGS)
	   (LET ((ZMAIL-BUFFER-END-BP (ZMAIL-BUFFER-END-BP ZMAIL-BUFFER))
		 (BP (END-OF-LINE LINE1)))
	     (SETF (LINE-NEXT LINE1) NIL)
	     (MOVE-BP ZMAIL-BUFFER-END-BP BP)
	     (MOVE-BP REAL-END-BP ZMAIL-BUFFER-END-BP)
	     (AND FLAG (MOVE-BP MSG-END-BP ZMAIL-BUFFER-END-BP)))
	   (AND MSG (SEND ZMAIL-BUFFER :UPDATE-MSG-END MSG))
	   (AND REAL-INT (SETF (NODE-NEXT REAL-INT) NIL))
	   (SETF (NODE-INFERIORS ZMAIL-BUFFER) (NREVERSE INFS))
	   (RETURN NIL)))
    (SETQ MSG (AREF ARRAY I)
	  REAL-INT (MSG-REAL-INTERVAL MSG)
	  REAL-START-BP (INTERVAL-FIRST-BP REAL-INT))
    (SETF (NODE-PREVIOUS REAL-INT) PREV-REAL-INT)
    (AND PREV-REAL-INT (SETF (NODE-NEXT PREV-REAL-INT) REAL-INT))
    (SEND ZMAIL-BUFFER :UPDATE-MSG-END MSG)
    (AND REAL-END-BP
	 (MOVE-BP REAL-END-BP REAL-START-BP))
    (AND FLAG (MOVE-BP MSG-END-BP REAL-START-BP))
    (SETQ LINE2 (BP-LINE REAL-START-BP))
    (AND LINE1 (SETF (LINE-NEXT LINE1) LINE2))
    (SETF (LINE-PREVIOUS LINE2) LINE1))
  (MUNG-NODE ZMAIL-BUFFER))

;;; Reverse the order of messages in a buffer
(DEFUN REVERSE-ZMAIL-BUFFER (ZMAIL-BUFFER)
  (NREVERSE (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER))
  (AND (ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER)
       (RESPLICE-ZMAIL-BUFFER ZMAIL-BUFFER)))

;;; Update the list of options at the start of the file
(DEFMETHOD (MAIL-FILE-BUFFER :UPDATE-OPTIONS-IN-FILE) ())

;;; Simple write-only mail files without separators
(ADD-ZMAIL-BUFFER-FLAVOR 'TEXT-MAIL-FILE-BUFFER "Text")

(DEFFLAVOR TEXT-MAIL-FILE-BUFFER () (MAIL-FILE-BUFFER))

(DEFMETHOD (TEXT-MAIL-FILE-BUFFER :FORMAT-NAME) () "Text")

;; Don't change appearance of a header just to print it.
(DEFMETHOD (TEXT-MAIL-FILE-BUFFER :REFORMAT-MSG-HEADER) (IGNORE)
  NIL)

(DEFMETHOD (TEXT-MAIL-FILE-BUFFER :MAIL-FILE-REPARSABLE-P) () NIL)

;;; If we try to read one of these in, don't get any messages
(DEFMETHOD (TEXT-MAIL-FILE-BUFFER :LINE-END-OF-MSG-P) (&REST IGNORE)
  T)

(DEFMETHOD (TEXT-MAIL-FILE-BUFFER :UPDATE-MSG-END) (MSG &OPTIONAL IGNORE)
  (LET ((END-LINE (BP-LINE (MSG-END-BP MSG))))
    (SETF (LINE-LENGTH END-LINE) 0)
    (APPEND-TO-ARRAY END-LINE *TEXT-MAIL-FILE-SEPARATOR*)))

;;; I/O

(DEFUN STARTUP-ZMAIL-BUFFER (&OPTIONAL NEW-PATHNAME &AUX STREAM PATHNAME ZMAIL-BUFFER)
  (SET-ZMAIL-USER)
  ;; Do not let the background process run again until all file requests are pending.
  ;; Otherwise the RMAIL file may all get in before the call to get-new-mail below.
  (WITH-BACKGROUND-PROCESS-LOCKED
    (COND ((OR (NULL *PRIMARY-ZMAIL-BUFFER*) NEW-PATHNAME)
	   (SETQ PATHNAME (OR NEW-PATHNAME *ZMAIL-STARTUP-FILE-NAME*))
	   (AND PATHNAME
		(SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME
							   *ZMAIL-PATHNAME-DEFAULTS*)))
	   (DO ((LIST (AND (NULL PATHNAME)
			   (SEND (FS:USER-HOMEDIR) :POSSIBLE-MAIL-FILE-NAMES))))
	       (NIL)
	     (OR PATHNAME (POP LIST PATHNAME))	;Get a pathname to use
	     (SETQ STREAM (OPEN PATHNAME '(:IN :NOERROR)))
	     (COND ((NOT (ERRORP STREAM))
		    (SETQ ZMAIL-BUFFER (GET-ZMAIL-FILE STREAM PATHNAME T))
		    (RETURN NIL)))
	     (COND ((NULL LIST)		;Ran out of choices
		    (UNLESS (CONDITION-TYPEP STREAM 'FS:FILE-NOT-FOUND)
		      (BARF "Error: ~A" STREAM))
		    (LET ((TEM (READ-DEFAULTED-PATHNAME
				 (FORMAT NIL "~A, use what file (RETURN to create ~A)"
					 STREAM PATHNAME)
				 PATHNAME NIL NIL :NEW-OK)))
		      (IF (NEQ TEM PATHNAME)
			  (SETQ PATHNAME TEM)	;Gave a new file, try that, else make it
			(SETQ ZMAIL-BUFFER (ZMAIL-FIND-FILE-NOSELECT-1 PATHNAME NIL NIL NIL T))
			(RETURN NIL))))
		   (T
		    (SETQ PATHNAME NIL))))
	   (SELECT-ZMAIL-BUFFER ZMAIL-BUFFER (NULL NEW-PATHNAME) NIL)
	   (COND (NEW-PATHNAME			;Not the primary mail file
		  (SETQ *MSG-NO* -1)
		  (ZMAIL-SELECT-NEXT-MSG NIL T))	;Select the first message
		 (T
		  (COM-GET-NEW-MAIL-INTERNAL T))))
	  (T DIS-NONE))))

;;; Getting new mail.

(DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-GET-NEW-MAIL
  "Merge any new mail:  L: selected or primary mail file; R: specify file.")

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-GET-NEW-MAIL "Read any new mail.
Click right to specify another new mail file.
The file is not deleted in this case." (NO-ZMAIL-BUFFER-OK)
  (COM-GET-NEW-MAIL-INTERNAL NIL))

(DEFUN COM-GET-NEW-MAIL-INTERNAL (FIRST-TIME-P &OPTIONAL FOR-BUFFER &AUX FROM-FILE)
  (OR FOR-BUFFER
      (SETQ FOR-BUFFER (COND ((AND *ZMAIL-BUFFER*
				   (GET (LOCF (ZMAIL-BUFFER-OPTIONS *ZMAIL-BUFFER*)) :MAIL))
			      *ZMAIL-BUFFER*)
			     ((NULL *PRIMARY-ZMAIL-BUFFER*)
			      NIL)
			     ((TYPEP *PRIMARY-ZMAIL-BUFFER* 'INBOX-BUFFER)
			      (SEND *PRIMARY-ZMAIL-BUFFER* :ASSOCIATED-MAIL-FILE-BUFFER))
			     (T
			      *PRIMARY-ZMAIL-BUFFER*))))
  (COND ((NULL FOR-BUFFER)
	 (STARTUP-ZMAIL-BUFFER))	;This will call COM-GET-NEW-MAIL-INTERNAL with FIRST-TIME-P
	((SEND FOR-BUFFER :ASSOCIATED-INBOX-BUFFER)
	 (IF (MEMQ (ZMAIL-DISK-BUFFER-STATUS FOR-BUFFER)
		   '(:LOADING :AWAITING-NEW-MAIL))
	     ;; If it's already reading in new mail, do nothing.
	     DIS-NONE
	   (IF (ZMAIL-DISK-BUFFER-STATUS FOR-BUFFER)
	       ;; Ordinary reading in of other file
	       (FOREGROUND-BACKGROUND-FINISH FOR-BUFFER NIL)
	     ;; Probably left around from an error
	     (SEND FOR-BUFFER :SET-ASSOCIATED-INBOX-BUFFER NIL))
	   (COM-GET-NEW-MAIL-INTERNAL NIL FOR-BUFFER)))
	(T
	 (AND (EQ *ZMAIL-COMMAND-BUTTON* :RIGHT)
	      (LET ((FS:*ALWAYS-MERGE-TYPE-AND-VERSION* T))
		(SETQ FROM-FILE (READ-DEFAULTED-PATHNAME
				  "Get new mail from file"
				  (DEFAULT-ZMAIL-MOVE-PATHNAME)))))
	 (AND (EQ FOR-BUFFER *PRIMARY-ZMAIL-BUFFER*)
	      (CASE *RUN-GMSGS-P*
		(:YES T)
		(:NO NIL)
		(:ONCE-ONLY FIRST-TIME-P))
	      (NULL FROM-FILE)		;The inbox-buffer won't look at us if this is set.
	      (GMSGS (ZMAIL-BUFFER-GMSGS-HOST FOR-BUFFER)))
	 ;; Possibly any mail file should be allowed that knows about getting new mail
	 (GET-NEW-MAIL-FOR-ZMAIL-BUFFER FOR-BUFFER FROM-FILE NIL FIRST-TIME-P))))

(DEFUN ZMAIL-BUFFER-GMSGS-HOST (ZMAIL-BUFFER)
  (LET ((HOSTNAME (CADR (MEMQ :GMSGS-HOST (SEND ZMAIL-BUFFER :OPTIONS)))))
    (IF HOSTNAME (FS:GET-PATHNAME-HOST HOSTNAME)
      (SEND (BUFFER-PATHNAME ZMAIL-BUFFER) :HOST))))

(DEFUN GET-NEW-MAIL-FOR-ZMAIL-BUFFER (ZMAIL-BUFFER FROM-FILE DELETE-P TELL-BACKGROUND-P
				   &AUX MOVE-P INBOX-BUFFER APPEND-P)
  (AND (SEND ZMAIL-BUFFER :ASSOCIATED-INBOX-BUFFER)
       (BARF "Already reading new mail into ~A" (ZMAIL-BUFFER-NAME ZMAIL-BUFFER)))
  ;; Don't start reading new mail while in middle of saving.
  (IF (EQ (ZMAIL-DISK-BUFFER-STATUS ZMAIL-BUFFER) :SAVING)
      (FOREGROUND-BACKGROUND-FINISH ZMAIL-BUFFER))
  (SETQ APPEND-P (ZMAIL-BUFFER-APPEND-P ZMAIL-BUFFER))
  (SELECT-ZMAIL-BUFFER ZMAIL-BUFFER)
  (SETQ INBOX-BUFFER (SEND *ZMAIL-BUFFER* :INBOX-BUFFER FROM-FILE DELETE-P))
  (AND TELL-BACKGROUND-P
       (ZMAIL-BACKGROUND-REQUEST-PUSH
	 `(ZMAIL-BACKGROUND-SET-INBOX-BUFFER ,INBOX-BUFFER)))
  (COND ((NULL (SEND INBOX-BUFFER :START-NEXT-FILE))
	 (FORMAT *QUERY-IO* "~&No new mail")
	 (SEND *ZMAIL-BUFFER* :SET-ASSOCIATED-INBOX-BUFFER NIL)
	 (SETQ MOVE-P (OR (NULL *MSG*) *ALWAYS-JUMP-AFTER-GET-NEW-MAIL*)))
	(T
	 (SETQ MOVE-P T)
	 ;; In case :START-NEXT-FILE changed this.
	 (SETQ INBOX-BUFFER (SEND *ZMAIL-BUFFER* :ASSOCIATED-INBOX-BUFFER))
	 ;; Make sure ZMAIL-BUFFER's status indicates it may be getting new mail now.
	 (UNLESS (EQ (ZMAIL-DISK-BUFFER-STATUS *ZMAIL-BUFFER*) :LOADING)
	   (SETF (ZMAIL-DISK-BUFFER-STATUS *ZMAIL-BUFFER*) :AWAITING-NEW-MAIL))
	 (SELECT-ZMAIL-BUFFER INBOX-BUFFER (EQ ZMAIL-BUFFER *PRIMARY-ZMAIL-BUFFER*) NIL)))
  (IF (NOT MOVE-P)
      DIS-TEXT
    (LOCK-ZMAIL-BUFFER (*ZMAIL-BUFFER*)		;Don't allow getting all messages
      (SETQ *MSG-NO* (IF (AND APPEND-P (EQ *ZMAIL-BUFFER* ZMAIL-BUFFER))
			 (1- (ZMAIL-BUFFER-NMSGS *ZMAIL-BUFFER*))	;but may have already.
		       -1))
      (ZMAIL-SELECT-NEXT-MSG NIL T))))

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-GMSGS "Run gmsgs" ()
  (GET-NEW-MAIL-FOR-ZMAIL-BUFFER *PRIMARY-ZMAIL-BUFFER*
			      (GMSGS (ZMAIL-BUFFER-GMSGS-HOST *PRIMARY-ZMAIL-BUFFER*))
			      T NIL)
  ;; No need for out output of "(There are messages)" to prevent immediate redisplay
  (SEND *TYPEOUT-WINDOW* :MAKE-COMPLETE)
  DIS-TEXT)

(DEFUN GMSGS (&OPTIONAL (HOST FS:USER-LOGIN-MACHINE) (STREAM *STANDARD-OUTPUT*))
  (IF (STRINGP HOST) (SETQ HOST (SI:PARSE-HOST HOST)))
  (SEND HOST :DO-GMSGS STREAM))		;Methods are in MFHOST

;;; Setup for loading a mail file from stream, does not actually read any messages.
;;; FLAVOR is the parsing format to be forced on the file.  If not specified, it
;;; is computed by looking at the file.
(DEFUN GET-ZMAIL-FILE (STREAM PATHNAME &OPTIONAL BACKGROUND-P FLAVOR &AUX INFO SUCCESS)
  (SETQ INFO (SEND STREAM :INFO))
  (UNWIND-PROTECT
      (OR (LET ((ZMAIL-BUFFER (GET-ZMAIL-BUFFER-FROM-PATHNAME PATHNAME)))
	    (WHEN ZMAIL-BUFFER
	      (IF (AND (NOT (EQUAL INFO (BUFFER-FILE-ID ZMAIL-BUFFER)))
		       (YES-OR-NO-P
			 (FORMAT NIL "File ~A has been changed since you last read or saved it.
Read in the new version? " PATHNAME)))
		  (PROGN
		    (KILL-ZMAIL-BUFFER ZMAIL-BUFFER)
		    NIL)
		(CLOSE STREAM)
		  (SETQ SUCCESS T)
		(WHEN (ZMAIL-DISK-BUFFER-STREAM ZMAIL-BUFFER)
		  (ZMAIL-BACKGROUND-REQUEST-PUSH
		    (LIST 'ZMAIL-BACKGROUND-LOAD-FILE ZMAIL-BUFFER)))
		ZMAIL-BUFFER)))
	  (LET (APPEND-P ZMAIL-BUFFER)
	    (OR FLAVOR (MULTIPLE-VALUE (FLAVOR APPEND-P)
			 (SEND PATHNAME :MAIL-FILE-FORMAT-COMPUTER STREAM)))
	    (SETQ ZMAIL-BUFFER (MAKE-ZMAIL-BUFFER FLAVOR
						  :PATHNAME PATHNAME
						  :STREAM STREAM
						  :FILE-ID INFO
						  :APPEND-P APPEND-P))
	    (START-LOADING-ZMAIL-BUFFER ZMAIL-BUFFER STREAM BACKGROUND-P)
	    (SETQ SUCCESS T)
	    ZMAIL-BUFFER))
    (UNLESS SUCCESS (CLOSE STREAM))))

(DEFUN START-LOADING-ZMAIL-BUFFER (ZMAIL-BUFFER STREAM BACKGROUND-P &OPTIONAL TRUENAME)
  (FORMAT *QUERY-IO* "~&Reading ~A file ~A" (SEND ZMAIL-BUFFER :FORMAT-NAME)
	  (OR TRUENAME (SEND STREAM :TRUENAME)))
  (IF BACKGROUND-P
      (ZMAIL-BACKGROUND-REQUEST-PUSH (LIST 'ZMAIL-BACKGROUND-LOAD-FILE ZMAIL-BUFFER))
    (LET ((*ZMAIL-BACKGROUND-P* :DISABLE))
      (LOAD-ALL-MSGS ZMAIL-BUFFER))))

(DEFUN LOAD-ALL-MSGS (ZMAIL-BUFFER &AUX MAIL-FILE-BUFFER)
  (SETQ MAIL-FILE-BUFFER (AND (TYPEP ZMAIL-BUFFER 'INBOX-BUFFER)
			      (SEND ZMAIL-BUFFER :ASSOCIATED-MAIL-FILE-BUFFER)))
  (SEND ZMAIL-BUFFER :READ-NEXT-MSG 177777)	;Finish reading in foreground
  (COND (MAIL-FILE-BUFFER
	 (SETQ ZMAIL-BUFFER MAIL-FILE-BUFFER)
	 (SEND ZMAIL-BUFFER :READ-NEXT-MSG 177777)))
  ZMAIL-BUFFER)

;;; This is the default message loader.  Different formats provide two messages,
;;; :LINE-END-OF-MSG-P and :CANONICAL-LAST-LINE.
;;; :LINE-END-OF-MSG-P is passed a LINE, its LENGTH, a STATE, an EOF flag, and the START.
;;; START is the line on which this message started.
;;; It should return END-IDX and an updated STATE variable.
;;; END-IDX is T if this was the last line, or index of the end of the message
;;; within the line, or :START-NEXT if this line should also start next message, or NIL.
;;; If END-IDX is a number, it is the index of the end of the message's "contents"
;;; but the next message may not start until the following line.
;;; STATE is NIL for the first line of each message.
;;; Aside from this, the meaning of values of STATE is up to the
;;; individual format's :LINE-END-OF-MESSAGE-P method.
;;; :CANONICAL-LAST-LINE is called to make a dummy line for the end of
;;; the file if the normal format requires this.  This will default to
;;; an empty line.

(DEFMETHOD (ZMAIL-DISK-BUFFER :READ-NEXT-MSG) (&OPTIONAL (NMSGS 1) &AUX EOF)
  (LOCK-ZMAIL-BUFFER (SELF)
    (COND ((MEMQ STATUS '(:LOADING-NEW-MAIL :LOADING))
	   (WHEN STREAM
	     (LET* ((START (GET (LOCF OPTIONS) 'NEXT-MSG-START-LINE))
		    (LINE-WAITING-FLAG START))
	       (REMPROP (LOCF OPTIONS) 'NEXT-MSG-START-LINE)
	       (DO ((TEST-FUNCTION (GET-HANDLER-FOR SELF :LINE-END-OF-MSG-P))
		    (END-LINE) (LINE) (LENGTH) (END-IDX)
		    (MSG-REAL-START-BP) (STATE))	;One piece of state for test function
		   (EOF)
		 (LET ((DEFAULT-CONS-AREA *ZMAIL-MSG-LINE-AREA*))
		   (IF LINE-WAITING-FLAG
		       (SETQ LINE (IF (EQ LINE-WAITING-FLAG T)
				      (LINE-NEXT LINE)
				    LINE-WAITING-FLAG)
			     LINE-WAITING-FLAG NIL)
		     (MULTIPLE-VALUE (LINE EOF)
		       (SEND STREAM :LINE-IN LINE-LEADER-SIZE))))
		 (COND ((AND EOF (OR (NULL LINE) (ZEROP (LINE-LENGTH LINE))))
			(OR START (RETURN NIL))
			(SETQ LINE (SEND SELF :CANONICAL-LAST-LINE))))
		 (OR END-LINE (SETQ END-LINE (PROGN
					       (AND (NOT (ZEROP (BP-INDEX LAST-BP)))
						    (INSERT LAST-BP #\CR))
					       (BP-LINE LAST-BP))))
		 (UNLESS (LINE-NEXT LINE) (INSERT-LINE-WITH-LEADER LINE END-LINE))
		 (SETQ LENGTH (LINE-LENGTH LINE))
		 (AND (NULL START)
		      (PLUSP LENGTH)
		      (DO I 0 (1+ I) ( I LENGTH)
			  (OR (MEMQ (CHAR LINE I) '(#/SP #/TAB))
			      (RETURN T)))
		      (SETQ START LINE))
		 (MULTIPLE-VALUE (END-IDX STATE)
		   (FUNCALL TEST-FUNCTION :LINE-END-OF-MSG-P LINE LENGTH STATE EOF START))
		 (UNLESS (EQ END-LINE (LINE-NEXT LINE))
		   ;; :LINE-END-OF-MSG-P made a new line.
		   (SETQ LINE-WAITING-FLAG T))
		 (COND (END-IDX
			(SETQ MSG-REAL-START-BP (CREATE-BP START 0 :NORMAL))
			(LET ((MSG-REAL-INTERVAL (CREATE-INTERVAL
						   MSG-REAL-START-BP
						   (CREATE-BP (IF (EQ END-IDX :START-NEXT)
								  LINE
								(LINE-NEXT LINE))
							      0 :MOVES)))
			      (MSG-INTERVAL (CREATE-INTERVAL
					      (COPY-BP MSG-REAL-START-BP :NORMAL)
					      (COND ((EQ END-IDX T)
						     (CREATE-BP (LINE-NEXT LINE) 0 :MOVES))
						    ((EQ END-IDX :START-NEXT)
						     (CREATE-BP LINE 0 :MOVES))
						    (T
						     (CREATE-BP LINE END-IDX :MOVES))))))
			  (SETF (NODE-TICK MSG-INTERVAL) FILE-TICK)
			  (SETF (NODE-TICK MSG-REAL-INTERVAL) FILE-TICK)
			  (VECTOR-PUSH-EXTEND
			    (MAKE-MSG :REAL-INTERVAL MSG-REAL-INTERVAL
				      :INTERVAL MSG-INTERVAL
				      :TICK FILE-TICK
				      :MAIL-FILE-BUFFER SELF)
			    ARRAY)
			  (DO ((LINE START (LINE-NEXT LINE))
			       (LAST (LINE-NEXT LINE)))
			      ((EQ LINE LAST))
			    (SETF (LINE-NODE LINE) MSG-REAL-INTERVAL))
			  (SETF (NODE-SUPERIOR MSG-INTERVAL) MSG-REAL-INTERVAL)
			  (SETF (NODE-INFERIORS MSG-REAL-INTERVAL) (LIST MSG-INTERVAL))
			  (SETF (NODE-SUPERIOR MSG-REAL-INTERVAL) SELF)
			  (LET ((INFS (NODE-INFERIORS SELF)))
			    (LET ((LAST (CAR (LAST INFS))))
			      (SETF (NODE-PREVIOUS MSG-REAL-INTERVAL) LAST)
			      (COND (LAST
				     (SETF (NODE-NEXT LAST) MSG-REAL-INTERVAL)
				     ;;The last-bp of the previous interval is :MOVES
				     ;;but should have stayed at the start of this one.
				     (LET ((LAST-BP-0 (INTERVAL-LAST-BP LAST))
					   (LAST-BP-1 (INTERVAL-LAST-BP
							(CAR (NODE-INFERIORS LAST)))))
				       (AND (BP-= LAST-BP-0 LAST-BP-1)
					    (MOVE-BP LAST-BP-1 MSG-REAL-START-BP))
				       (MOVE-BP LAST-BP-0 MSG-REAL-START-BP)))))
			    (SETQ INFERIORS
				  (NCONC INFS (NCONS MSG-REAL-INTERVAL)))))
			(COND (( (SETQ NMSGS (1- NMSGS)) 0)
			       (AND (EQ END-IDX :START-NEXT)
				    (PUTPROP (LOCF OPTIONS) LINE 'NEXT-MSG-START-LINE))
			       (IF LINE-WAITING-FLAG
				   (PUTPROP (LOCF OPTIONS) (LINE-NEXT LINE)
					    'NEXT-MSG-START-LINE))
			       (RETURN NIL)))
			(SETQ START (IF (EQ END-IDX :START-NEXT) LINE)
			      STATE NIL))))))
	   (IF (AND STREAM (NOT EOF))
	       T
	     (SEND SELF :LOADING-DONE)
	     (AND STREAM (PLUSP NMSGS) (NOT *ZMAIL-BACKGROUND-P*)
		  (SEND SELF :READ-NEXT-MSG NMSGS)))))))

(DEFMETHOD (ZMAIL-DISK-BUFFER :CANONICAL-LAST-LINE) ()
  (CREATE-LINE 'ART-STRING 0 NIL))

(DEFWRAPPER (ZMAIL-DISK-BUFFER :LOADING-DONE) (IGNORE . BODY)
  `(IF (EQ *ZMAIL-BACKGROUND-P* T)
       (ZMAIL-BACKGROUND-RESPONSE-PUSH `(FILE-LOADED ,SELF))
     SI:.DAEMON-CALLER-ARGS.
     . ,BODY))

(DEFMETHOD (MAIL-FILE-BUFFER :LOADING-DONE) ()
  (AND STREAM (SEND STREAM :CLOSE))
  (SETQ STREAM NIL)
  ;; If no new mail or new mail is not in yet, wait.
  (COND ((NULL ASSOCIATED-INBOX-BUFFER)
	 (SETQ STATUS NIL))
	((NEQ (ZMAIL-DISK-BUFFER-STATUS ASSOCIATED-INBOX-BUFFER) :AWAITING-SAVE)
	 (SETQ STATUS :AWAITING-NEW-MAIL))
	(T
	 ;; If new mail all in may need to append it now.
	 (AND (ZMAIL-BUFFER-APPEND-P SELF)
	      (INSERT-NEW-MAIL SELF ASSOCIATED-INBOX-BUFFER))
	 ;; Now ready to save back out.
	 (SETQ STATUS :SAVING-REQUIRED)
	 (LET ((SORT (GET (LOCF OPTIONS) :SORT)))
	   (AND SORT (SORT-ZMAIL-BUFFER SELF SORT
					(GET (LOCF OPTIONS) :APPEND-P) T)))
	 (UNLESS *INHIBIT-BACKGROUND-SAVES*
	   (ZMAIL-BUFFER-BACKGROUND-SAVE SELF))))
  (ZMAIL-BACKGROUND-REQUEST-PUSH (LIST 'ZMAIL-BACKGROUND-PARSE-MSGS SELF 0))
  (AND (NEQ *MSG* :NO-SELECT)
       (COMPUTE-CURRENT-MSG-NAME)))		;We may now know how many messages

(DEFWRAPPER (ZMAIL-DISK-BUFFER :SAVING-DONE) (IGNORE . BODY)
  `(IF *ZMAIL-BACKGROUND-P*
       (ZMAIL-BACKGROUND-RESPONSE-PUSH `(FILE-SAVED ,SELF))
     SI:.DAEMON-CALLER-ARGS.			;Prevent compiler warnings
     . ,BODY))

(DEFMETHOD (MAIL-FILE-BUFFER :SAVING-DONE) (&OPTIONAL FORCING-OUT)
  (SETQ FILE-TICK (TICK))
  (SETQ FILE-ID (SEND STREAM :INFO))
  (when (get self 'generation-retention-count) ; Only gets put on for new files
    (send stream :change-properties nil
	  :generation-retentation-count (get self 'generation-retention-count))
    (setf (get self 'generation-retention-count) nil))
  (SEND STREAM :CLOSE)
  (FORMAT *QUERY-IO* "~&Written: ~A" (SEND STREAM :TRUENAME))
  (COND (ASSOCIATED-INBOX-BUFFER
	 (OR (EQ (ZMAIL-DISK-BUFFER-STATUS ASSOCIATED-INBOX-BUFFER) :AWAITING-SAVE)
	     (LET ((OMF ASSOCIATED-INBOX-BUFFER))
	       (SETQ ASSOCIATED-INBOX-BUFFER NIL STATUS NIL)
	       (ZMAIL-ERROR "Inbox buffer out of synch (~S), get a wizard"
		       (ZMAIL-DISK-BUFFER-STATUS OMF))))
	 (COND (ASSOCIATED-INBOX-BUFFER
		(OR (SEND ASSOCIATED-INBOX-BUFFER :SAVING-DONE FORCING-OUT)
		    ;; Returns T if starts to load another inbox file.
		    (SETQ ASSOCIATED-INBOX-BUFFER NIL))))))
  (SETQ STATUS NIL))

(DEFWRAPPER (ZMAIL-DISK-BUFFER :SAVING-ABORTED) (IGNORE . BODY)
  `(IF *ZMAIL-BACKGROUND-P*
       (ZMAIL-BACKGROUND-RESPONSE-PUSH `(FILE-SAVE-ABORTED ,SELF))
     SI:.DAEMON-CALLER-ARGS.			;Prevent compiler warnings
     . ,BODY))

;;;Called when saving in background process gets an error.
;;;The message is sent in the background process, intercepted by the wrapper above,
;;;and queued to be resent in the main process.
;;;Set status back to :SAVING-REQUIRED if there is an inbox buffer (in :AWAITING-SAVE).
(DEFMETHOD (MAIL-FILE-BUFFER :SAVING-ABORTED) ()
  (SEND STREAM :CLOSE :ABORT)
  (FORMAT *QUERY-IO* "~&Error saving ~A" (SEND STREAM :TRUENAME))
  (COND (ASSOCIATED-INBOX-BUFFER
	 (OR (EQ (ZMAIL-DISK-BUFFER-STATUS ASSOCIATED-INBOX-BUFFER) :AWAITING-SAVE)
	     (LET ((OMF ASSOCIATED-INBOX-BUFFER))
	       (SETQ ASSOCIATED-INBOX-BUFFER NIL STATUS :SAVING-REQUIRED)
	       (ZMAIL-ERROR "Inbox buffer out of synch (~S), get a wizard"
		       (ZMAIL-DISK-BUFFER-STATUS OMF))))
	 (SETQ STATUS :SAVING-REQUIRED))
	(T
	 (SETQ STATUS NIL))))

(DEFUN INSERT-NEW-MAIL (OLD-FILE NEW-FILE &AUX APPEND-P OLD-INT NEW-INT INT-APPEND-P)
  (COND ((GET (LOCF (ZMAIL-BUFFER-OPTIONS OLD-FILE)) :REVERSE-NEW-MAIL)
	 (REVERSE-ZMAIL-BUFFER NEW-FILE)
	 ;; Select the lowest numbered message
	 (AND (EQ NEW-FILE *ZMAIL-BUFFER*)
	      (LET ((NMSGS (ZMAIL-BUFFER-NMSGS NEW-FILE)))
		(AND ( NMSGS 2)
		     (MUST-REDISPLAY *MSG-WINDOW*
			 (ZMAIL-SELECT-MSG (AREF (ZMAIL-BUFFER-ARRAY NEW-FILE) 0) NIL NIL)))))))
  (SETQ APPEND-P (ZMAIL-BUFFER-APPEND-P OLD-FILE)
	OLD-INT (ZMAIL-DISK-BUFFER-INTERVAL OLD-FILE)
	NEW-INT (ZMAIL-DISK-BUFFER-INTERVAL NEW-FILE))
  (LOCK-ZMAIL-BUFFER (OLD-FILE)
    (LOCK-ZMAIL-BUFFER (NEW-FILE)
      (IF (SETQ INT-APPEND-P (OR APPEND-P (ZEROP (ZMAIL-BUFFER-NMSGS OLD-FILE))))
	  (MULTIPLE-VALUE-BIND (END-LINE PREV-MSG-END-BPS)
	      (SEND OLD-FILE :LAST-LINE-FOR-APPEND)
	    (IF END-LINE
		(LET ((START-LINE (BP-LINE (INTERVAL-FIRST-BP NEW-INT))))
		  (SETF (LINE-NEXT END-LINE) START-LINE)
		  (SETF (LINE-PREVIOUS START-LINE) END-LINE)
		  (DOLIST (BP PREV-MSG-END-BPS)
		    (MOVE-BP BP START-LINE 0)))
	      (MOVE-BP (INTERVAL-FIRST-BP OLD-INT) (INTERVAL-FIRST-BP NEW-INT)))
	    (MOVE-BP (INTERVAL-LAST-BP OLD-INT) (INTERVAL-LAST-BP NEW-INT)))
	(LET ((START-LINE (BP-LINE (SEND OLD-FILE :FIRST-MSG-BP))))
	  (LET ((PREV (LINE-PREVIOUS START-LINE))
		(NEW-START-LINE (BP-LINE (INTERVAL-FIRST-BP NEW-INT))))
	    (SETF (LINE-PREVIOUS NEW-START-LINE) PREV)
	    (IF PREV
		(SETF (LINE-NEXT PREV) NEW-START-LINE)
	      (MOVE-BP (INTERVAL-FIRST-BP OLD-INT) NEW-START-LINE 0)))
	  (LET ((NEW-END-LINE (BP-LINE (INTERVAL-LAST-BP NEW-INT))))
	    (AND (ZEROP (LINE-LENGTH NEW-END-LINE))
		 (LINE-PREVIOUS NEW-END-LINE)
		 (SETQ NEW-END-LINE (LINE-PREVIOUS NEW-END-LINE)))
	    (SETF (LINE-NEXT NEW-END-LINE) START-LINE)
	    (SETF (LINE-PREVIOUS START-LINE) NEW-END-LINE))))
      (LET ((NEW-INFS (NODE-INFERIORS NEW-INT))
	    (OLD-INFS (NODE-INFERIORS OLD-INT))
	    LAST-INT FIRST-INT)
	(DOLIST (INT NEW-INFS)
	  (SETF (NODE-SUPERIOR INT) OLD-INT))
	(IF INT-APPEND-P
	    (SETQ LAST-INT (CAR (LAST OLD-INFS))
		  FIRST-INT (CAR NEW-INFS)
		  OLD-INFS (NCONC OLD-INFS NEW-INFS))
	  (SETQ LAST-INT (CAR (LAST NEW-INFS))
		FIRST-INT (CAR OLD-INFS)
		OLD-INFS (NCONC NEW-INFS OLD-INFS)))
	(SETF (NODE-INFERIORS OLD-INT) OLD-INFS)
	(COND ((AND LAST-INT FIRST-INT)
	       (LET* ((LAST-INT-END (INTERVAL-LAST-BP LAST-INT))
		      (FIRST-INT-START (INTERVAL-FIRST-BP FIRST-INT))
		      (LAST-INT-END-1 (INTERVAL-LAST-BP (CAR (NODE-INFERIORS LAST-INT))))
		      (MOVE-1-P (BP-= LAST-INT-END LAST-INT-END-1)))
		 (MOVE-BP LAST-INT-END FIRST-INT-START)
		 (AND MOVE-1-P (MOVE-BP LAST-INT-END-1 FIRST-INT-START))) 
	       (SETF (NODE-NEXT LAST-INT) FIRST-INT)
	       (SETF (NODE-PREVIOUS FIRST-INT) LAST-INT))))
      (LET* ((NEW-ARRAY (ZMAIL-BUFFER-ARRAY NEW-FILE))
	     (OLD-ARRAY (ZMAIL-BUFFER-ARRAY OLD-FILE))
	     (NMSGS (ARRAY-ACTIVE-LENGTH NEW-ARRAY))
	     (OLDLEN (ARRAY-ACTIVE-LENGTH OLD-ARRAY))
	     (NEWLEN (+ NMSGS OLDLEN)))
	(AND (< (ARRAY-LENGTH OLD-ARRAY) NEWLEN)
	     (ADJUST-ARRAY-SIZE OLD-ARRAY (TRUNCATE (* NEWLEN 5) 4)))
	(OR APPEND-P
	    ;; If prepending, make space in the array
	    (DO ((I (1- OLDLEN) (1- I))
		 (J (1- NEWLEN) (1- J)))
		((< I 0))
	      (ASET (AREF OLD-ARRAY I) OLD-ARRAY J)))
	(SETF (ARRAY-LEADER OLD-ARRAY 0) NEWLEN)
	(DO ((I 0 (1+ I))
	     (J (IF APPEND-P OLDLEN 0) (1+ J))
	     (MSG))
	    (( I NMSGS))
	  (SETQ MSG (AREF NEW-ARRAY I))
	  ;; It is important that the message be parsed by the inbox buffer, so that UNSEEN
	  ;; properties get put on.  That is why this MSG-PUT is before the :NEW-MSG.
	  (MSG-PUT MSG T 'RECENT)
	  (SEND OLD-FILE :NEW-MSG MSG)
	  (ASET MSG OLD-ARRAY J))
	;; If this is new mail for a prepending BABYL file, and there is still some old mail
	;; to come in, the last new message won't get a formfeed.  Fix it now.
	(AND (NOT APPEND-P) (ZEROP OLDLEN) (PLUSP NEWLEN)
	     (EQ (ZMAIL-DISK-BUFFER-STATUS OLD-FILE) :LOADING)
	     (LET* ((MSG (AREF NEW-ARRAY (1- NEWLEN)))
		    (LAST-BP (INTERVAL-LAST-BP OLD-INT))
		    (MSG-LAST-BP (MSG-REAL-END-BP MSG))
		    (AT-END-P (BP-= LAST-BP MSG-LAST-BP)))
	       (SEND OLD-FILE :UPDATE-MSG-END MSG T)
	       (AND AT-END-P (MOVE-BP LAST-BP (END-LINE MSG-LAST-BP))))))))
  (COND ((EQ NEW-FILE *ZMAIL-BUFFER*)
	 (SELECT-ZMAIL-BUFFER OLD-FILE (EQ NEW-FILE *PRIMARY-ZMAIL-BUFFER*)))
	((EQ OLD-FILE *ZMAIL-BUFFER*)		;*MSG-NO* may need changing
	 (ZMAIL-SELECT-MSG *MSG* T NIL)))
  (MSG-POINT-PDL-FORWARD-ZMAIL-BUFFER NEW-FILE OLD-FILE))

(DEFUN ZMAIL-BUFFER-BACKGROUND-SAVE (ZMAIL-BUFFER)
  (COND ((AND (NEQ *ZMAIL-BACKGROUND-P* :DISABLE)
	      (SEND ZMAIL-BUFFER :ASSOCIATED-INBOX-BUFFER))
	 (ZMAIL-BUFFER-SAVE-SETUP ZMAIL-BUFFER)
	 (ZMAIL-BACKGROUND-REQUEST-PUSH
	   (LIST 'ZMAIL-BACKGROUND-SAVE-FILE
		 ZMAIL-BUFFER
		 (INTERVAL-STREAM (ZMAIL-DISK-BUFFER-INTERVAL ZMAIL-BUFFER)))))
	(T
	 (SETF (ZMAIL-DISK-BUFFER-STATUS ZMAIL-BUFFER) NIL))))

;;; New mail

;;; Note: all inbox buffer flavors must have the same instance variables,
;;; namely, those of INBOX-BUFFER.

(DEFUN MAKE-INBOX-BUFFER (TYPE LIST FROM-ZMAIL-BUFFER)
  (OR (ZMAIL-BUFFER-APPEND-P FROM-ZMAIL-BUFFER)
      (SETQ LIST (NREVERSE LIST)))
  (MAKE-ZMAIL-BUFFER TYPE
		     :ASSOCIATED-MAIL-FILE-BUFFER FROM-ZMAIL-BUFFER
		     :NAME (STRING-APPEND "New mail for " (STRING (SEND FROM-ZMAIL-BUFFER :NAME)))
		     :FILE-LIST LIST))

(DEFUN REPLACE-INBOX-BUFFER (FLAVOR)
  (DECLARE (:SELF-FLAVOR INBOX-BUFFER))
  ;; Parse all messages before replacing
  ;; since the way to parse depends on the flavor.
  (DOTIMES (I (ZMAIL-BUFFER-NMSGS SELF))
    (ASSURE-MSG-PARSED (AREF ARRAY I)))
  ;; Just magically change the flavor of the instance.
  (SI:ASSURE-FLAVOR-COMPOSED FLAVOR)
  (%P-STORE-POINTER SELF (GET FLAVOR 'SI:FLAVOR))
  SELF)

(DEFMETHOD (INBOX-BUFFER :AFTER :INIT) (IGNORE)
  (SEND ASSOCIATED-MAIL-FILE-BUFFER :SET-ASSOCIATED-INBOX-BUFFER SELF)
  (SETQ PENDING-FILE-LIST FILE-LIST
	STATUS :NEW-MAIL
	FILE-LIST-MAIL-CHECK-INFO (LOOP FOR X IN FILE-LIST
					COLLECT (LIST (CAR X) NIL))))

;;; This gets called when starting to get new mail or after one file of new mail
;;; has been read in.  It should return T if it has started something loading.
(DEFMETHOD (INBOX-BUFFER :START-NEXT-FILE) ()
  (DO ((FILE) (RENAME) (DELETE-P) (STR)
       (LOADING-NAME NIL NIL)
       (LOADING-TRUENAME NIL NIL))
      ((NULL PENDING-FILE-LIST) NIL)
    (SETF `(,FILE ,RENAME ,DELETE-P) (CAR PENDING-FILE-LIST))
    ;; If the next pending file is on a different host,
    ;; and needs a different flavor of INBOX-BUFFER,
    ;; replace this one with a suitable one and try again with that one.
    (UNLESS (EQ (TYPE-OF SELF) (SEND FILE :INBOX-BUFFER-FLAVOR))
      (RETURN (SEND (REPLACE-INBOX-BUFFER (SEND FILE :INBOX-BUFFER-FLAVOR))
		    :START-NEXT-FILE)))
    (COND ((NOT RENAME)
	   ;;No file to rename to, see if new file exists
	   (CONDITION-CASE ()
	       (SETQ STREAM (OPEN FILE :DIRECTION :INPUT))
	     (FS:FILE-NOT-FOUND (POP PENDING-FILE-LIST) NIL)
	     (:NO-ERROR (POP PENDING-FILE-LIST) NIL)
	     (ERROR)))
	  ((IGNORE-ERRORS
	     (SETQ STREAM (OPEN RENAME :DIRECTION :INPUT)))
	   (LET ((TEM (CAR PENDING-FILE-LIST)))
	     (POP PENDING-FILE-LIST)
	     ;;If file to rename to already exists,
	     ;;arrange for real file to get read in after saving done next time
	     (SETQ NEXT-PENDING-FILE-LIST
		   (NCONC NEXT-PENDING-FILE-LIST (NCONS TEM)))))
	  ((CONDITION-CASE ()
	       (SETQ STR (OPEN FILE :DIRECTION NIL))
	     (FS:FILE-NOT-FOUND (POP PENDING-FILE-LIST) NIL)
	     (ERROR))
	   (POP PENDING-FILE-LIST)
	   ;;Rename to new file.  This does not use the :RENAME stream operation since that
	   ;;doesn't work correctly on Tops-20 and does not return the TRUENAME.
	   (SETQ LOADING-NAME (SEND STR :PATHNAME)
		 LOADING-TRUENAME (SEND STR :TRUENAME))
	   (CONDITION-CASE ()
	       (SEND FILE :RENAME RENAME)
	     (FS:FILE-LOCKED
	      (FORMAT *QUERY-IO* "~&File ~A is being accessed so cannot be renamed.  Pausing."
		      LOADING-TRUENAME)
	      (PROCESS-SLEEP (* 10. 60.))
	      (DO ()
		  (())
		(CONDITION-CASE ()
		    (SEND FILE :RENAME RENAME)
		  (FS:FILE-LOCKED NIL)
		  (:NO-ERROR
		   (FORMAT *QUERY-IO* "~&File successfully renamed, continuing.")
		   (RETURN T)))
		(UNLESS (Y-OR-N-P "Try again?  You can also abort. ")
		  (SIGNAL-CONDITION EH:ABORT-OBJECT)))))

	   ;;Get the renamed file
	   (SETQ STREAM (OPEN RENAME '(:IN)))))
    (WHEN STREAM
      (SETQ PATHNAME (OR LOADING-NAME (SEND STREAM :PATHNAME))
	    NAME (SEND PATHNAME :STRING-FOR-PRINTING)
	    STATUS :LOADING-NEW-MAIL)
      (START-LOADING-ZMAIL-BUFFER SELF STREAM T LOADING-TRUENAME)
      (AND DELETE-P (PUSH (SEND STREAM :TRUENAME) PENDING-DELETION-LIST))
      (RETURN T))))

;;; This is called when the one file is all the way in
(DEFMETHOD (INBOX-BUFFER :LOADING-DONE) ()
  (COND (STREAM
	 (SEND STREAM :CLOSE)
	 (SETQ STREAM NIL)))
  (OR (SEND SELF :START-NEXT-FILE)		;We can still do more, continue
      (SEND (SEND ASSOCIATED-MAIL-FILE-BUFFER :ASSOCIATED-INBOX-BUFFER)
	    :LOADING-DONE-INTERNAL)))

(DEFMETHOD (INBOX-BUFFER :LOADING-DONE-INTERNAL) ()
  ;; If the other file is all in or we are prepending, can put together now
  (AND (OR (NOT (ZMAIL-BUFFER-APPEND-P ASSOCIATED-MAIL-FILE-BUFFER))
	   (MEMQ (ZMAIL-DISK-BUFFER-STATUS ASSOCIATED-MAIL-FILE-BUFFER)
		 '(NIL :AWAITING-NEW-MAIL :SAVING-REQUIRED)))
       (INSERT-NEW-MAIL ASSOCIATED-MAIL-FILE-BUFFER SELF))
  (SETQ STATUS :AWAITING-SAVE)
  (COND ((NOT (MEMQ (ZMAIL-DISK-BUFFER-STATUS ASSOCIATED-MAIL-FILE-BUFFER)
		    ;;Loading or already saving
		    '(NIL :AWAITING-NEW-MAIL :SAVING-REQUIRED))))
	(*INHIBIT-BACKGROUND-SAVES*
	 (SETF (ZMAIL-DISK-BUFFER-STATUS ASSOCIATED-MAIL-FILE-BUFFER) :SAVING-REQUIRED))
	(T
	 (ZMAIL-BUFFER-BACKGROUND-SAVE ASSOCIATED-MAIL-FILE-BUFFER))))

;;; This is called after the primary mail file has been saved out with us in it
;;; It should return T if it has started up again
(DEFMETHOD (INBOX-BUFFER :SAVING-DONE) (FORCING-OUT)
  (SETQ STATUS :NEW-MAIL)
  (DOLIST (FILE PENDING-DELETION-LIST)
    (CONDITION-CASE (ERROR)
	(SEND FILE :DELETE)
      (FS:FILE-ERROR
       (FORMAT *QUERY-IO* "~&Deletion error: ~A" ERROR))))
  (SETQ PENDING-DELETION-LIST NIL)
  (COND ((AND (NOT FORCING-OUT)
	      (SETQ PENDING-FILE-LIST NEXT-PENDING-FILE-LIST))
	 (SETQ NEXT-PENDING-FILE-LIST NIL)
	 ;; Start things over
	 (STORE-ARRAY-LEADER 0 ARRAY 0)
	 (SETQ INFERIORS NIL)
	 (LET ((LINE (CREATE-LINE 'ART-STRING 0 NIL)))
	   (SETF FIRST-BP (CREATE-BP LINE 0 :NORMAL))
	   (SETF LAST-BP (CREATE-BP LINE 0 :MOVES))
	   (SETF (LINE-NODE LINE) SELF))
	 (SEND SELF :START-NEXT-FILE))))

;;; This is called from the background process to see if there is new mail
(DEFMETHOD (INBOX-BUFFER :BACKGROUND-CHECK-FOR-NEW-MAIL) (&AUX -STREAM- CREATION-DATE)
  (AND (EQ STATUS :NEW-MAIL)			;Only if idle
       (DOLIST (ELEM FILE-LIST-MAIL-CHECK-INFO)
	 (IGNORE-ERRORS
	   ;; Don't wait a long time to bomb out if the host is down.
	   ;; It could hold up the ZMAIL process.
	   (WHEN (CHAOS:HOST-UP-P (PATHNAME-HOST (FIRST ELEM)) 60.)
	     (SETQ -STREAM- (OPEN (FIRST ELEM) :DIRECTION NIL))))
	 (COND ((AND -STREAM-
		     (NOT (EQUAL (SETQ CREATION-DATE (SEND -STREAM- :CREATION-DATE))
				 (SECOND ELEM))))
		(SETF (SECOND ELEM) CREATION-DATE)
		(MULTIPLE-VALUE-BIND (NIL MINUTES HOURS)
		    (TIME:DECODE-UNIVERSAL-TIME CREATION-DATE)
		  (ZMAIL-BACKGROUND-RESPONSE-PUSH
		    (LIST 'NEW-MAIL
			  "New mail in ~A at ~D:~2,'0D"
			  (FIRST ELEM)
			  HOURS MINUTES))))))))

;;; Hardcopy functions

(DEFVAR *HARDCOPY-DEVICE*)

;;; Options for all
(DEFVAR *INCLUDE-SUMMARY-ALIST*
	'(("Yes" :VALUE T :DOCUMENTATION "Print summary and messages.")
	  ("No" :VALUE NIL :DOCUMENTATION "Do not print a summary.")
	  ("Just summary" :VALUE :JUST-SUMMARY
	   :DOCUMENTATION "Print summary but not messages themselves.")))

(DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-SUMMARY-P* T :MENU-ALIST
			      "Include summary" *INCLUDE-SUMMARY-ALIST*)
(DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-SEPARATE-PAGES* NIL :BOOLEAN
			      "Print each message on a separate page")
(DEFINE-ZMAIL-HARDCOPY-OPTION *HARDCOPY-SEPARATOR-LINE* NIL :STRING-OR-NIL
			      "Line between messages (when not on separate pages)")

(DEFVAR *ZMAIL-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS* NIL)

(DEFVAR *ZMAIL-SINGLE-MSG-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS* NIL)

(DEFVAR *ZMAIL-WHOLE-FILE-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS*
	'(*HARDCOPY-SUMMARY-P* *HARDCOPY-SEPARATE-PAGES* *HARDCOPY-SEPARATOR-LINE*))

(DEFSTRUCT (HARDCOPY-DEVICE :LIST :CONC-NAME)
  KEY
  FLAVOR
  OTHER-OPTIONS)

(DEFMACRO ADD-HARDCOPY-DEVICE (FLAVOR-NAME KEY NAME OTHER-OPTION-VARIABLES)
  `(ADD-HARDCOPY-DEVICE-1 ',FLAVOR-NAME ',KEY ',NAME ,OTHER-OPTION-VARIABLES))

(DEFVAR *HARDCOPY-DEVICE-ALIST* NIL)
(DEFVAR *HARDCOPY-DEVICE-MENU-ALIST* NIL)

(DEFUN ADD-HARDCOPY-DEVICE-1 (FLAVOR KEY NAME OTHER-OPTIONS &AUX DEVICE)
  (SETQ DEVICE (MAKE-HARDCOPY-DEVICE :KEY KEY
				     :FLAVOR FLAVOR
				     :OTHER-OPTIONS OTHER-OPTIONS))
  (SETQ *HARDCOPY-DEVICE-ALIST* (CONS DEVICE
				      (DELQ (ASSQ KEY *HARDCOPY-DEVICE-ALIST*)
					    *HARDCOPY-DEVICE-ALIST*)))
  (SETQ *HARDCOPY-DEVICE-MENU-ALIST* (CONS (CONS NAME KEY)
					   (DELQ (RASSQ KEY *HARDCOPY-DEVICE-MENU-ALIST*)
						 *HARDCOPY-DEVICE-MENU-ALIST*)))
  ;; If this is being added after normal initializations
  (LET ((INIT (ASSOC "SITE:*HARDCOPY-DEVICE*" SI:SITE-INITIALIZATION-LIST)))
    (AND INIT (EVAL (SI:INIT-FORM INIT)))))

(DEFVAR *HARDCOPY-WHOLE-FILE-P*)

(DEFUN COMPUTE-HARDCOPY-CHOICES (DEVICE &AUX ALIST)
  (OR *HARDCOPY-DEVICE* (BARF "No known hardcopy devices at this site"))
  (SETQ DEVICE (ASSQ DEVICE *HARDCOPY-DEVICE-ALIST*))
  (SETQ ALIST `(*HARDCOPY-DEVICE*
	        ,@(HARDCOPY-DEVICE-OTHER-OPTIONS DEVICE)
		,@*ZMAIL-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS*
		,@(IF *HARDCOPY-WHOLE-FILE-P*
		      *ZMAIL-WHOLE-FILE-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS*
		    *ZMAIL-SINGLE-MSG-DEVICE-INDEPENDENT-HARDCOPY-OPTIONS*)))
  (SETQ ALIST (MAPCAR #'(LAMBDA (X) (ASSQ X *ZMAIL-HARDCOPY-OPTION-ALIST*)) ALIST))
  (SETQ ALIST (TV:PRUNE-USER-OPTION-ALIST ALIST))
  ALIST)

(DEFUN CHOOSE-HARDCOPY-OPTIONS (NEAR-MODE *HARDCOPY-WHOLE-FILE-P*)
  (TV:CHOOSE-VARIABLE-VALUES (COMPUTE-HARDCOPY-CHOICES *HARDCOPY-DEVICE*)
			     :LABEL "Hardcopy options:"
			     :NEAR-MODE NEAR-MODE
			     :MARGIN-CHOICES '("Do It"
						("Abort" (ABORT-CURRENT-COMMAND)))
			     :FUNCTION 'CHOOSE-HARDCOPY-OPTIONS-FUNCTION))

(DEFUN CHOOSE-HARDCOPY-OPTIONS-FUNCTION (WINDOW VARIABLE OLDVAL NEWVAL)
  OLDVAL
  (SEND *PROFILE-WINDOW* :VARIABLE-TICK)
  (COND ((EQ VARIABLE '*HARDCOPY-DEVICE*)
	 (TV:WITH-SHEET-DEEXPOSED (WINDOW)
	   (SEND WINDOW :SETUP (COMPUTE-HARDCOPY-CHOICES NEWVAL)
		    (SEND WINDOW :LABEL)
		    (SEND WINDOW :FUNCTION)
		    (SYMEVAL-IN-INSTANCE WINDOW 'TV:MARGIN-CHOICES)))
	 T)))

;;; This makes hardcopy be a ZMAIL-BUFFER for GET-MOVE-ZMAIL-BUFFER
(DEFUN MAKE-HARDCOPY-ZMAIL-BUFFER (CHOOSE-OPTIONS-P FOR-WHOLE-FILE-P NEAR-MODE)
  (UNLESS *HARDCOPY-DEVICE* (BARF "No known hardcopy devices at this site"))
  (AND CHOOSE-OPTIONS-P (CHOOSE-HARDCOPY-OPTIONS NEAR-MODE FOR-WHOLE-FILE-P))
  (MAKE-INSTANCE (HARDCOPY-DEVICE-FLAVOR (ASSQ *HARDCOPY-DEVICE* *HARDCOPY-DEVICE-ALIST*))))

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-HARDCOPY-MSG "Hardcopy the current message." ()
  (SEND (MAKE-HARDCOPY-ZMAIL-BUFFER (EQ *ZMAIL-COMMAND-BUTTON* :RIGHT) NIL
				    (RECTANGLE-NEAR-COMMAND-MENU))
	   :ADD-MSG *MSG*)
  DIS-NONE)

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-HARDCOPY-ALL "Hardcopy the current buffer." ()
  (SEND (MAKE-HARDCOPY-ZMAIL-BUFFER (EQ *ZMAIL-COMMAND-BUTTON* :RIGHT) T
				    (RECTANGLE-NEAR-COMMAND-MENU))
	   :ADD-ZMAIL-BUFFER *ZMAIL-BUFFER*)
  DIS-NONE)

(DEFFLAVOR HARDCOPY-ZMAIL-BUFFER () ()
  (:INCLUDED-FLAVORS SI:LINE-OUTPUT-STREAM-MIXIN))

(DEFMETHOD (HARDCOPY-ZMAIL-BUFFER :PRINT-SELF) (STREAM &REST IGNORE)
  (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP)
    (PRIN1 (SEND SELF :NAME) STREAM)))

(DEFMETHOD (HARDCOPY-ZMAIL-BUFFER :DRAW-UNDERLINE) () NIL)

(DEFMACRO WITH-HARDCOPY-OUTPUT ((HARDCOPY-ZMAIL-BUFFER) &BODY BODY)
  `(UNWIND-PROTECT
     (PROGN ,@BODY
	    (SEND ,HARDCOPY-ZMAIL-BUFFER :CLOSE))
     (SEND ,HARDCOPY-ZMAIL-BUFFER :CLOSE :ABORT)))

(DEFMETHOD (HARDCOPY-ZMAIL-BUFFER :ADD-MSG) (MSG &OPTIONAL ALREADY-IN-OTHER-PROCESS-P)
  (IF ALREADY-IN-OTHER-PROCESS-P
      (WITH-HARDCOPY-OUTPUT (SELF)
	(SEND SELF :OPEN (ZMAIL-BUFFER-NAME (MSG-MAIL-FILE-BUFFER MSG))
	      (MSG-GET MSG :DATE))
	(HARDCOPY-ONE-MSG MSG SELF (MSG-DISPLAYED-INDEX MSG) NIL))
    (PROCESS-RUN-FUNCTION "ZMAIL HARDCOPY" SELF :ADD-MSG MSG T)))

;; Don't change appearance of a header just to print it.
(DEFMETHOD (HARDCOPY-ZMAIL-BUFFER :REFORMAT-MSG-HEADER) (IGNORE)
  NIL)

(DEFMETHOD (HARDCOPY-ZMAIL-BUFFER :ADD-ZMAIL-BUFFER) (ZMAIL-BUFFER
						      &OPTIONAL ALREADY-IN-OTHER-PROCESS-P)
  (IF ALREADY-IN-OTHER-PROCESS-P
      (LET (ARRAY NMSGS)
	(SETQ ARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER)
	      NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
	(WITH-HARDCOPY-OUTPUT (SELF)
	  (SEND SELF :OPEN (ZMAIL-BUFFER-NAME ZMAIL-BUFFER) NIL)
	  (COND (*HARDCOPY-SUMMARY-P*
		 (SEND SELF :LINE-OUT (SEND ZMAIL-BUFFER :FULL-NAME))
		 (SEND SELF :DRAW-UNDERLINE)
		 (SEND SELF :LINE-OUT *SUMMARY-WINDOW-LABEL*)
		 (DO ((I 0 (1+ I))
		      (MSG) (STATUS) (STRING))
		     (( I NMSGS))
		   (SETQ MSG (AREF ARRAY I)
			 ;; Maessage must be parsed before the MSG-SUMMARY-LINE is valid.
			 STATUS (ASSURE-MSG-PARSED MSG)
			 STRING (MSG-SUMMARY-LINE MSG))
		   (FORMAT SELF " ~3D~C" (1+ I) (STATUS-LETTER STATUS))
		   (SEND SELF :STRING-OUT STRING 0
			 (MIN (STRING-LENGTH STRING) 90.))
		   (SEND SELF :TYO #\CR))))
	  (COND ((NEQ *HARDCOPY-SUMMARY-P* :JUST-SUMMARY)
		 (DO ((I 0 (1+ I))
		      (MSG)
		      (FIRST-P T NIL))
		     (( I NMSGS))
		   (COND ((IF FIRST-P *HARDCOPY-SUMMARY-P*
			    *HARDCOPY-SEPARATE-PAGES*)
			  (SEND SELF :TYO #\PAGE))
			 ((AND *HARDCOPY-SEPARATOR-LINE* (NOT FIRST-P))
			  (SEND SELF :LINE-OUT *HARDCOPY-SEPARATOR-LINE*)))
		   (SETQ MSG (AREF ARRAY I))
		   (HARDCOPY-ONE-MSG MSG SELF I ZMAIL-BUFFER))))))
    (PROCESS-RUN-FUNCTION "ZMAIL HARDCOPY" SELF :ADD-ZMAIL-BUFFER ZMAIL-BUFFER T)))

(DEFUN HARDCOPY-ONE-MSG (MSG HARDCOPY-ZMAIL-BUFFER INDEX ZMAIL-BUFFER &AUX TEM)
  (FORMAT HARDCOPY-ZMAIL-BUFFER "Message #~D" (1+ INDEX))
  (AND (NEQ ZMAIL-BUFFER (SETQ TEM (MSG-MAIL-FILE-BUFFER MSG)))
       (FORMAT HARDCOPY-ZMAIL-BUFFER " (from ~A)" (ZMAIL-BUFFER-NAME TEM)))
  (COND ((SETQ TEM (MSG-GET MSG 'KEYWORDS-STRING))
	 (SEND HARDCOPY-ZMAIL-BUFFER :TYO #\SP)
	 (SEND HARDCOPY-ZMAIL-BUFFER :STRING-OUT TEM)))
  (SEND HARDCOPY-ZMAIL-BUFFER :TYO #\CR)
  (STREAM-OUT-INTERVAL HARDCOPY-ZMAIL-BUFFER (MSG-INTERVAL MSG)))

;;; Hardware specific

(DEFFLAVOR HARDCOPY-TO-FILE-MIXIN
	(*FILE-STREAM*)
	()
  (:INCLUDED-FLAVORS HARDCOPY-ZMAIL-BUFFER))

(DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :TYO) PASS-MESSAGE-TO-FILE-STREAM)
(DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :STRING-OUT) PASS-MESSAGE-TO-FILE-STREAM)
(DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :LINE-OUT) PASS-MESSAGE-TO-FILE-STREAM)

(DEFUN PASS-MESSAGE-TO-FILE-STREAM (&REST ARGS)
  (DECLARE (:SELF-FLAVOR HARDCOPY-TO-FILE-MIXIN))
  (APPLY *FILE-STREAM* ARGS))

(DEFMETHOD (HARDCOPY-TO-FILE-MIXIN :CLOSE) (&OPTIONAL ABORT-P)
  (SEND *FILE-STREAM* :CLOSE ABORT-P))

;;; TPL
(DEFFLAVOR TPL-HARDCOPY-ZMAIL-BUFFER
	()
	(HARDCOPY-TO-FILE-MIXIN HARDCOPY-ZMAIL-BUFFER))

(ADD-HARDCOPY-DEVICE TPL-HARDCOPY-ZMAIL-BUFFER :TPL "TPL" NIL)

(DEFMETHOD (TPL-HARDCOPY-ZMAIL-BUFFER :NAME) () "TPL:")

(DEFMETHOD (TPL-HARDCOPY-ZMAIL-BUFFER :OPEN) (IGNORE IGNORE)
  (SETQ *FILE-STREAM* (OPEN "TPL:" '(:OUT))))

;;; This comes after all the hardware specific options, so that it gets the right
;;; possibilities.
(DEFINE-SITE-ALIST-USER-OPTION (*HARDCOPY-DEVICE* *ZMAIL-HARDCOPY-OPTION-ALIST*)
			       "Output device" *HARDCOPY-DEVICE-MENU-ALIST*
			       :DEFAULT-HARDCOPY-MODE)