; -*- Mode:LISP; Package:ZWEI; Base:8; Readtable:ZL -*- 
;;; Operating system dependent mail file handling, extension of MFILES

; ** (c) Copyright 1982 Massachusetts Institute of Technology **
; An invalid Enhancements copyright notice on AI:ZMAIL; MFHOST 15 removed on 3/31/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.

(DEFVAR *ZMAIL-HOMEDIR-REAL-NEW-MAIL-FILENAME* NIL
  "If non-NIL, pretend this is where we always should get new mail for FS:USER-ID.")

(DEFVAR *REAL-MAIL-FILE-HOST-ALIST* NIL "An alist of hosts and a real file name to override what file to get new mail for ourselves.")

(DEFUN MAYBE-OVERRIDDEN-MAIL-PATHNAME (PATHNAME &OPTIONAL (USER USER-ID) &AUX VALUE)
  "Return the pathname of the mail file if it is overridden by PATHNAME, else NIL."
  (UNLESS (NOT (STRING-EQUAL FS::USER-ID USER)) ;;if its for someone else, its not overridden
    (OR (AND (EQ (FS::USER-HOMEDIR) PATHNAME)  ;;override it with this variable
	     *ZMAIL-HOMEDIR-REAL-NEW-MAIL-FILENAME*)
	(LET ((HOST (SEND PATHNAME :HOST)))
	  (DOLIST (ELEM *REAL-MAIL-FILE-HOST-ALIST*)
	    (COND ((EQ HOST (SI:PARSE-HOST (CAR ELEM) T))
		   (SETQ VALUE (CDR ELEM)))))
	  VALUE))))

;;; The :DO-MSGS method returns the file to find the messages in
(DEFMETHOD (SI:HOST :DO-GMSGS) (STREAM)
  (MULTIPLE-VALUE-BIND (FILE-NAME UNAME-STRING) (SEND SELF :GMSGS-PATHNAME)
    (WITH-OPEN-STREAM (CSTREAM (CHAOS:OPEN-STREAM SELF
						  (GMSGS-CONTACT-NAME
						    FILE-NAME UNAME-STRING)
						  :DIRECTION :INPUT :ERROR ()))
      (IF (ERRORP CSTREAM)
	  (FORMAT *QUERY-IO* "~&GMSGS Error: ~A" CSTREAM)
	(STREAM-COPY-UNTIL-EOF CSTREAM STREAM)))  
    FILE-NAME))
	   
(DEFUN GMSGS-CONTACT-NAME (INBOX USER-STRING)
  (STRING-APPEND "GMSGS " USER-STRING " "
		 (IF (EQ (SEND INBOX :SYSTEM-TYPE) :ITS) "//G" "")
		 *GMSGS-OTHER-SWITCHES* " ")) ; 20X lossage 
  
;;; :GMSGS-PATHNAME should return two values: the expected GMSGS inbox for ZMAIL
;;; and a string which determines the user (or his GMSGS inbox in the case of ITS).
(DEFMETHOD (SI:HOST :GMSGS-PATHNAME) ()
  (VALUES (SEND (FS::USER-HOMEDIR SELF) :NEW-PATHNAME
		:NAME "GMSGS" :CANONICAL-TYPE :TEXT)
	  (OR (FS::UNAME-ON-HOST SELF) USER-ID)))

;;; ITS mail files
(DEFFLAVOR ITS-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :HEADER-COMPATIBLE-MAIL-FILE-FORMATS) ()
  '("Mail" "Rmail" "Babyl" "Tenex mail"))

(DEFFLAVOR ITS-INBOX-BUFFER () (ITS-MAIL-FILE-MIXIN INBOX-BUFFER))

(DEFMETHOD (ITS-INBOX-BUFFER :FORMAT-NAME) () "Mail")

;;should have a similar kludge for determining the inbox filename
(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM &AUX FLAVOR APPEND-P)
  (IF (NULL STREAM)
      (SETQ FLAVOR 'RMAIL-FILE-BUFFER)
      (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
	(SEND STREAM :SET-POINTER 0)
	(IF (STRING-EQUAL FIRST-LINE "Babyl Options:")
	    ;; Looks like a babyl file
	    (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
	    ;; Default is rmail file
	    (SETQ FLAVOR 'RMAIL-FILE-BUFFER)
	    (AND (STRING-EQUAL FIRST-LINE "*APPEND*")
		 (SETQ APPEND-P T)))))
  (VALUES FLAVOR APPEND-P))

(DEFVAR *ZMAIL-FILE-FN2S* '("BABYL" "RMAIL"))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LOOP FOR FN2 IN *ZMAIL-FILE-FN2S*
	COLLECT (SEND SELF :NEW-PATHNAME :NAME USER-ID :TYPE FN2 :VERSION :NEWEST)))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(RMAIL-FILE-BUFFER BABYL-MAIL-FILE-BUFFER))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME :NAME (OR FS::NAME USER-ID)
		    :TYPE "MAIL")))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  (STRING-APPEND "_Z" (SEND SELF :TYPE)))

(DEFMETHOD (FS::ITS-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'ITS-INBOX-BUFFER)

(DEFMETHOD (SI:HOST-ITS-MIXIN :GMSGS-PATHNAME) ()
  (LET* ((HOMEDIR (FS::USER-HOMEDIR SELF))
	 (INBOX (SEND (SEND HOMEDIR :NEW-PATHNAME :TYPE "GMSGS")
		      :NEW-SUGGESTED-NAME (FS::UNAME-ON-HOST SELF))))
    (VALUES INBOX
	    (FORMAT () "~A;~A" (SEND INBOX :DIRECTORY) (SEND INBOX :NAME)))))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

;;; Messages on ITS end with a line with a  in it
;;; The MSG-END-BP will be before the .
;;; The MSG-REAL-END-BP is the start of the following line.
(DEFMETHOD (ITS-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE LENGTH &REST IGNORE &AUX END-IDX)
  (AND (> LENGTH 0) (SETQ END-IDX (STRING-SEARCH-CHAR #\ LINE))
       (NOT (DO I (1+ END-IDX) (1+ I) ( I LENGTH)
		(OR (MEMQ (CHAR LINE I) '(#/SP #/TAB #/FF))
		    (RETURN T))))
       END-IDX))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :CANONICAL-LAST-LINE) (&AUX LINE)
  (SETQ LINE (CREATE-LINE 'ART-STRING 1 NIL))
  (SETF (CHAR LINE 0) #\)
  LINE)

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :NEW-HEADER-AND-TRAILER) ()
  (VALUES "" #\NewLine))

;; Our goal state is  Return  <end-bp> Return <real-end-bp> text-of-next-message
(DEFMETHOD (ITS-MAIL-FILE-MIXIN :UPDATE-MSG-END) (MSG &OPTIONAL FOR-APPEND-P)
  (DECLARE (IGNORE FOR-APPEND-P))
  (LET ((END-LINE (BP-LINE (MSG-END-BP MSG)))
	(REAL-END-BP (MSG-REAL-END-BP MSG)))
    ;; Other mail file formats leave the end-bp and the real-end-bp on the same line.
    ;; Fix that.
    (WHEN (EQ END-LINE (BP-LINE REAL-END-BP))
      (IF (MEMBER (LINE-PREVIOUS END-LINE) '("" ""))
	  (SETQ END-LINE (LINE-PREVIOUS END-LINE))
	(INSERT-MOVING REAL-END-BP #\RETURN)
	(SETQ END-LINE (LINE-PREVIOUS (BP-LINE REAL-END-BP)))))
    (MOVE-BP (MSG-END-BP MSG) END-LINE 0)
    (SETF (LINE-LENGTH END-LINE) 0)
    (VECTOR-PUSH-EXTEND #\ END-LINE)))

(DEFMETHOD (ITS-MAIL-FILE-MIXIN :PARSE-MSG-TEXT) (MSG -STATUS-)
  (PARSE-ITS-MSG-HEADERS (MSG-INTERVAL MSG) NIL NIL (GET -STATUS- :REFORMATTED)))

(DEFMETHOD (ITS-INBOX-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  MSG
  (PUTPROP -STATUS- T 'UNSEEN))

;;; RMAIL mail files
(ADD-ZMAIL-BUFFER-FLAVOR 'RMAIL-FILE-BUFFER "Rmail")

(DEFFLAVOR RMAIL-FILE-BUFFER () (ITS-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))

(DEFMETHOD (RMAIL-FILE-BUFFER :FORMAT-NAME) () "Rmail")

(DEFMETHOD (RMAIL-FILE-BUFFER :AFTER :INIT) (PLIST)
  ;; If APPEND-P, flush the *APPEND* line from the stream, it is not part of a message.
  (AND (GET PLIST :APPEND-P) STREAM
       (INSERT-LINE-WITH-LEADER (SEND STREAM :LINE-IN LINE-LEADER-SIZE)
				(BP-LINE FIRST-BP))))

(DEFMETHOD (RMAIL-FILE-BUFFER :SETTABLE-OPTIONS) ()
  '(:APPEND))

(DEFMETHOD (RMAIL-FILE-BUFFER :FIRST-MSG-BP) ()
  (LET* ((LINE (BP-LINE FIRST-BP)))
    (IF (STRING-EQUAL LINE "*APPEND*")
	(CREATE-BP (LINE-NEXT LINE) 0)
      FIRST-BP)))

(DEFMETHOD (RMAIL-FILE-BUFFER :UPDATE-OPTIONS-IN-FILE) ()
  (LET* ((LINE (BP-LINE FIRST-BP))
	 (APPEND-P (GET (LOCF OPTIONS) :APPEND)))
    (COND ((EQ (STRING-EQUAL LINE "*APPEND*") APPEND-P))
	  (APPEND-P
	   (INSERT FIRST-BP "*APPEND*
"))
	  (T
	   (DELETE-INTERVAL FIRST-BP (BEG-LINE FIRST-BP 1 T) T)))))

;;; BABYL mail files
(ADD-ZMAIL-BUFFER-FLAVOR 'BABYL-MAIL-FILE-BUFFER "Babyl")

;;; Limits of Babyl file formats supported here
(DEFPARAMETER *LOWEST-BABYL-VERSION* 4)
(DEFPARAMETER *HIGHEST-BABYL-VERSION* 5)

(DEFFLAVOR BABYL-MAIL-FILE-BUFFER () (ITS-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :FORMAT-NAME) () "Babyl")

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :SETTABLE-OPTIONS) ()
  '(:APPEND :REVERSE-NEW-MAIL :VERSION :MAIL :OWNER :SORT :DELETE-EXPIRED
    :|NO REFORMATION| :SUMMARY-WINDOW-FORMAT :GMSGS-HOST))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :POSSIBLE-OPTIONS) ()
  '(:APPEND :BABYL-P :|NO REFORMATION| :REVERSE-NEW-MAIL :VERSION
    :MAIL :OWNER :SORT :DELETE-EXPIRED :KEYWORDS :KEYWORDS-STRING
    :SUMMARY-WINDOW-FORMAT :GMSGS-HOST))

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

;;; Read the options section of the mail file
(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :AFTER :INIT) (PLIST)
  (IF STREAM
      (SETQ OPTIONS (PARSE-BABYL-OPTIONS STREAM SELF))
      (OR (GET (LOCF OPTIONS) :VERSION)
	  (PUTPROP (LOCF OPTIONS) *HIGHEST-BABYL-VERSION* :VERSION))
      (AND (GET PLIST :NEW-PRIMARY-P)
	   (NOT (GET (LOCF OPTIONS) :MAIL))
	   (PUTPROP (LOCF OPTIONS) (NCONS (SEND PATHNAME :NEW-MAIL-PATHNAME)) :MAIL))
      (INSERT LAST-BP #\)))

(DEFUN PARSE-BABYL-OPTIONS (STREAM INTERVAL)
  (FS::SET-DEFAULT-PATHNAME (SEND STREAM :PATHNAME) *ZMAIL-PATHNAME-DEFAULTS*)
  (DO ((END-LINE (BP-LINE (INTERVAL-LAST-BP INTERVAL)))
       (LINE)
       (LIST NIL))
      (NIL)
    (SETQ LINE (SEND STREAM :LINE-IN LINE-LEADER-SIZE))
    (INSERT-LINE-WITH-LEADER LINE END-LINE)
    (AND (STRING-SEARCH-CHAR #\ LINE) (RETURN LIST))
    (SETQ LIST (APPEND LIST (OPTION-FROM-STRING LINE)))))

(DEFPARAMETER *OPTION-SPECIAL-CHARS*
	'(#/( #/" #// #/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)
  "A list of (real) characters to be handled specially in Babyl format")

;;; Parse a single line of a babyl option or an unparsed message header
(DEFUN OPTION-FROM-STRING (STRING &AUX I TYPE PARSE-FUNCTION PROP)
  (SETQ I (STRING-SEARCH-CHAR #\: STRING)
        TYPE (INTERN (STRING-UPCASE (NSUBSTRING STRING 0 I)) ""))
  (AND I (SETQ I (OR (STRING-SEARCH-NOT-SET '(#\SP #\TAB) STRING (SETQ I (1+ I)))
		     (STRING-LENGTH STRING))))
  (IF (SETQ PARSE-FUNCTION (GET TYPE 'BABYL-OPTION-PARSER))
      (FUNCALL PARSE-FUNCTION TYPE STRING I)
    (COND ((NULL I)
	   (SETQ PROP T))
	  ((MEMQ (CHAR STRING I) *OPTION-SPECIAL-CHARS*)
	   (LET ((*PACKAGE* (FIND-PACKAGE 'KEYWORD))
		 (*READ-BASE* 10.))
	     (SETQ PROP (READ-FROM-STRING STRING NIL I))))
	  (T
	   (SETQ PROP (SUBSTRING STRING I))))
    (LIST TYPE PROP)))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :UPDATE-OPTIONS-IN-FILE) (&AUX PLIST)
  (FS::SET-DEFAULT-PATHNAME PATHNAME *ZMAIL-PATHNAME-DEFAULTS*)
  (SETQ PLIST (LOCF OPTIONS))
  ;; Move this to the first
  (COND ((OR (NEQ (CAAR PLIST) :BABYL-P) (NEQ (CADAR PLIST) T))
	 (REMPROP PLIST :BABYL-P)
	 (PUTPROP PLIST T :BABYL-P)))
  (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT LINE))
       (DONE NIL)
       (PROPS))
      ((STRING-SEARCH #\ LINE)
       (LOOP FOR (IND PROP) ON (CDR PLIST) BY 'CDDR
	     WITH BP = (CREATE-BP LINE 0)
	     WHEN (AND PROP
		       (NOT (MEMQ IND DONE))
		       (GETL IND '(BABYL-OPTION-PARSER BABYL-OPTION-PRINTER BABYL-OPTION-P)))
	     DO (SETQ LINE (STRING-FROM-OPTION IND PLIST)
		      BP (INSERT (INSERT BP LINE) #\NewLine))
	        (LOOP FOR IND IN (OPTION-FROM-STRING LINE) BY 'CDDR
		      DO (PUSH IND DONE))))
    (SETQ PROPS (OPTION-FROM-STRING LINE))
    (AND (LOOP FOR (IND PROP) ON PROPS BY 'CDDR
	       UNLESS (EQUAL PROP (GET PLIST IND))
	       RETURN T)			;Not still the same
	 (IF (NOT (LOOP FOR (IND PROP) ON PROPS BY 'CDDR
			WHEN (GET PLIST IND)
			RETURN T))		;All properties NIL
	     (LET ((BP (CREATE-BP LINE 0)))
	       (DELETE-INTERVAL BP (BEG-LINE BP 1 T) T))
	     (MUNG-NODE (LINE-NODE LINE))
	     (SETF (LINE-LENGTH LINE) 0)
	     (STRING-FROM-OPTION (CAR PROPS) PLIST LINE)))
    (LOOP FOR IND IN PROPS BY 'CDDR
	  DO (PUSH IND DONE))))

;;; Convert a message header into a string
(DEFUN STRING-FROM-OPTION (PROP PLIST &OPTIONAL STRING &AUX VAL TEM)
  (OR STRING (SETQ STRING (MAKE-EMPTY-STRING 40)))
  (SETQ VAL (GET PLIST PROP))
  (WITH-OUTPUT-TO-STRING (STREAM STRING)
    (COND ((SETQ TEM (GET PROP 'BABYL-OPTION-PRINTER))
	   (FUNCALL TEM STREAM PROP VAL PLIST))
	  (T
	   (FORMAT STREAM "~:" PROP)
	   (COND ((NEQ VAL T)
		  (FUNCALL STREAM :TYO #\:)
		  (LET ((*PRINT-BASE* 10.) (*NOPOINT T) (*PRINT-RADIX* NIL))
		    (FUNCALL (IF (AND (STRINGP VAL)
				      (NOT (MEMQ (CHAR VAL 0) *OPTION-SPECIAL-CHARS*))
				      (NOT (STRING-SEARCH-SET '(#\SP #\TAB) VAL)))
				 #'PRINC #'PRIN1)
			     VAL STREAM)))))))
  STRING)

;;; The options themselves
(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :BABYL-P)

(DEFUN (:|BABYL OPTIONS| BABYL-OPTION-PARSER) (&REST IGNORE)
  '(:BABYL-P T))

(DEFUN (:BABYL-P BABYL-OPTION-PRINTER) (STREAM &REST IGNORE)
  (FORMAT STREAM "Babyl Options:"))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :VERSION 5 :NUMBER)

(DEFUN (:VERSION BABYL-OPTION-PARSER) (IGNORE STRING START &AUX VERSION)
  (SETQ VERSION (PARSE-NUMBER STRING START))
  (AND (OR (NULL VERSION)
	   (< VERSION *LOWEST-BABYL-VERSION*)
	   (> VERSION *HIGHEST-BABYL-VERSION*))
       (CERROR T NIL NIL "Babyl version is ~D, not supported by this version of ZMail"
	       VERSION))
  `(:VERSION ,VERSION))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :|NO REFORMATION| NIL :BOOLEAN)
(DEFPROP :|NO REFORMATION| T BABYL-OPTION-P)

(DEFINE-SETTABLE-MAIL-FILE-OPTION :GMSGS-HOST NIL :STRING-OR-NIL)
(DEFPROP :GMSGS-HOST T BABYL-OPTION-P)

(DEFINE-SETTABLE-MAIL-FILE-OPTION :OWNER NIL :STRING-OR-NIL)

(DEFPROP :OWNER T BABYL-OPTION-P)

(DEFPROP :STRING-OR-NIL (PRINT-STRING-OR-NIL READ-STRING-OR-NIL)
	 TV::CHOOSE-VARIABLE-VALUES-KEYWORD)

(DEFUN PRINT-STRING-OR-NIL (STRING STREAM)
  (AND STRING
       (SEND STREAM :STRING-OUT STRING)))

(DEFUN READ-STRING-OR-NIL (STREAM &AUX STRING)
  (SETQ STRING (READLINE STREAM))
  (AND (PLUSP (STRING-LENGTH STRING))
       STRING))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :MAIL NIL :PATHNAME-LIST)

(DEFPROP :MAIL PATHNAME-LIST-OPTION-PARSER BABYL-OPTION-PARSER)

(DEFUN PATHNAME-LIST-OPTION-PARSER (TYPE STRING START)
  (DO ((I START (1+ J))
       (J)
       (PATHNAME-LIST NIL))
      (NIL)
    (OR (SETQ I (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* STRING I))
	(RETURN NIL))
    (SETQ J (STRING-SEARCH-CHAR #\, STRING I))
    (PUSH (FS::MERGE-PATHNAME-DEFAULTS (NSUBSTRING STRING I J) *ZMAIL-PATHNAME-DEFAULTS*)
	  PATHNAME-LIST)
    (OR J (RETURN (LIST TYPE (NREVERSE PATHNAME-LIST))))))

(DEFPROP :MAIL PATHNAME-LIST-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFUN PATHNAME-LIST-OPTION-PRINTER (STREAM PROP PATHNAME-LIST IGNORE)
  (FORMAT STREAM "~:: ~{~A~^, ~}" PROP PATHNAME-LIST))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :REVERSE-NEW-MAIL NIL :BOOLEAN)

(DEFUN (:APPEND BABYL-OPTION-PARSER) (IGNORE STRING START &AUX APPEND REVERSE)
  (IF (NULL START)				;Append<nl>
      (SETQ APPEND T)
      (LET ((N (PARSE-NUMBER STRING START NIL 8)))
	(SETQ APPEND (BIT-TEST N 1)
	      REVERSE (BIT-TEST N 2))))
  `(:APPEND ,APPEND :REVERSE-NEW-MAIL ,REVERSE))

(DEFPROP :APPEND PRINT-APPEND-AND-REVERSE-NEW-MAIL BABYL-OPTION-PRINTER)
(DEFPROP :REVERSE-NEW-MAIL PRINT-APPEND-AND-REVERSE-NEW-MAIL BABYL-OPTION-PRINTER)

(DEFUN PRINT-APPEND-AND-REVERSE-NEW-MAIL (STREAM IGNORE IGNORE PLIST &AUX (BITS 0))
  (AND (GET PLIST :APPEND)
       (SETQ BITS (LOGIOR BITS 1)))
  (AND (GET PLIST :REVERSE-NEW-MAIL)
       (SETQ BITS (LOGIOR BITS 2)))
  (FORMAT STREAM "Append:~O" BITS))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :SUMMARY-WINDOW-FORMAT *DEFAULT-SUMMARY-TEMPLATE* :SEXP)

(DEFPROP :SUMMARY-WINDOW-FORMAT SEXP-OPTION-PARSER BABYL-OPTION-PARSER)

(DEFUN SEXP-OPTION-PARSER (TYPE STRING START)
  `(,TYPE ,(READ-FROM-STRING STRING NIL START)))

(DEFPROP :SUMMARY-WINDOW-FORMAT SEXP-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFUN SEXP-OPTION-PRINTER (STREAM PROP SEXP IGNORE)
  (FORMAT STREAM "~:: ~S" PROP SEXP))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :INBOX-BUFFER) (&OPTIONAL NEW-PATHNAME DELETE-P)
  (MAKE-INBOX-BUFFER
    (FUNCALL PATHNAME :INBOX-BUFFER-FLAVOR)
    (IF NEW-PATHNAME
	(LIST (LIST NEW-PATHNAME NIL DELETE-P))
      (LOOP FOR NEW-PATHNAME
	    IN (IF *RUN-GMSGS-P*
		   (CONS (SEND (ZMAIL-BUFFER-GMSGS-HOST SELF) :GMSGS-PATHNAME)
			 (GET (LOCF OPTIONS) :MAIL))
		 (GET (LOCF OPTIONS) :MAIL))
	    COLLECT (LIST NEW-PATHNAME
			  (FUNCALL NEW-PATHNAME :NEW-TYPE
				   (SEND NEW-PATHNAME
					    :ZMAIL-TEMP-FILE-NAME))
			  T)))
    SELF))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  (LET* ((START-BP (MSG-START-BP MSG))
	 (END-BP (MSG-END-BP MSG))
	 (REAL-START-LINE (BP-LINE (MSG-REAL-START-BP MSG)))
	 (END-LINE (BP-LINE END-BP))
	 (START-LINE REAL-START-LINE))
    (DO () ((NOT (LINE-BLANK-P START-LINE)))
      (SETQ START-LINE (LINE-NEXT START-LINE)))
    (FUNCALL (IF (< (GET (LOCF OPTIONS) :VERSION) 5)
		 #'PARSE-MSG-OLD-BABYL-STATUS-LINE
	       #'PARSE-MSG-NEW-BABYL-STATUS-LINE)
	     START-LINE -STATUS-)
    (DO ((LINE START-LINE (LINE-NEXT LINE)))
	((EQ LINE END-LINE))
      (COND ((STRING-EQUAL LINE "*** EOOH ***")
	     (SETQ START-LINE LINE)
	     (RETURN NIL))))
    (SETQ END-LINE (LINE-NEXT START-LINE))
    ;;Make lines in the header area point to MSG-REAL-INTERVAL rather than
    ;;MSG-INTERVAL.
    (DO ((LINE REAL-START-LINE (LINE-NEXT LINE)))
	((EQ LINE END-LINE))
      (SETF (LINE-NODE LINE) *INTERVAL*))
    (MOVE-BP START-BP END-LINE 0)))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :AFTER :PARSE-MSG) (MSG -STATUS-)
  (send self :reformat-msg msg -status-))

(defmethod (babyl-mail-file-buffer :reformat-msg) (msg -status-)
  (OR (GET (LOCF OPTIONS) :|NO REFORMATION|)
      (GET -STATUS- 'REFORMATTED)
      (WHEN (AND (GET -STATUS- 'HEADERS-END-BP)
		 *DEFAULT-REFORMATTING-TEMPLATE*)
	(UNLESS (TYPEP (FSYMEVAL *DEFAULT-REFORMATTING-TEMPLATE*) :COMPILED-FUNCTION)
	  (COMPILE *DEFAULT-REFORMATTING-TEMPLATE*))
	;; First copy the original header.
	(INSERT-INTERVAL (FORWARD-LINE (INTERVAL-FIRST-BP (MSG-INTERVAL MSG)) -1)
			 (INTERVAL-FIRST-BP (MSG-INTERVAL MSG))
			 (GET -STATUS- 'HEADERS-END-BP)
			 T)
	(PUTPROP (LOCF (MSG-STATUS MSG)) T 'REFORMATTED)
	(SEND SELF :UPDATE-MSG-OPTIONS-IN-FILE MSG T)
	(FUNCALL *DEFAULT-REFORMATTING-TEMPLATE* (MSG-INTERVAL MSG) (LIST MSG)))))

(defmethod (babyl-mail-file-buffer :after :new-msg) (msg)
  (send self :reformat-msg msg (assure-msg-parsed msg)))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :NEW-HEADER-AND-TRAILER) ()
  (VALUES "
*** EOOH ***
"
	  #\NewLine))

;; Our goal state is  Return  <end-bp> Return <real-end-bp> text-of-next-message
(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :UPDATE-MSG-END) (MSG &OPTIONAL FOR-APPEND-P)
  (LET ((END-LINE (BP-LINE (MSG-END-BP MSG)))
	(REAL-END-BP (MSG-REAL-END-BP MSG)))
    ;; Other mail file formats leave the end-bp and the real-end-bp on the same line.
    ;; Fix that.
    (WHEN (EQ END-LINE (BP-LINE REAL-END-BP))
      (IF (MEMBER (LINE-PREVIOUS END-LINE) '("" ""))
	  (SETQ END-LINE (LINE-PREVIOUS END-LINE))
	(INSERT-MOVING REAL-END-BP #\RETURN)
	(SETQ END-LINE (LINE-PREVIOUS (BP-LINE REAL-END-BP)))))
    (MOVE-BP (MSG-END-BP MSG) END-LINE 0)
    (SETF (LINE-LENGTH END-LINE) 0)
    (VECTOR-PUSH-EXTEND #\ END-LINE)
    (IF (NOT (AND (NOT FOR-APPEND-P)
		  (EQ (BP-LINE REAL-END-BP) (BP-LINE LAST-BP))))
	(VECTOR-PUSH-EXTEND #\Page END-LINE))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :BEFORE :LOADING-DONE) (&AUX TEM)
  (AND (PLUSP (SETQ TEM (ARRAY-ACTIVE-LENGTH ARRAY)))
       (SEND SELF :UPDATE-MSG-END (AREF ARRAY (1- TEM)))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :BEFORE :SET-OPTIONS) (NEW-OPTIONS)
  (AND ( (GET (LOCF OPTIONS) :VERSION)
	  (GET (LOCF NEW-OPTIONS) :VERSION))
       (DOMSGS (MSG SELF)
	 (SEND SELF :UPDATE-MSG-OPTIONS-IN-FILE MSG))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :FIRST-MSG-BP) ()
  (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT LINE)))
      ((STRING-SEARCH #\ LINE)
       ;; If this used to standalone, assume about to have new messages
       (AND (= (LINE-LENGTH LINE) 1)
	    (VECTOR-PUSH-EXTEND #\Page LINE))
       (LET ((-NEXT- (LINE-NEXT LINE)))
	 (IF -NEXT- (CREATE-BP -NEXT- 0) (CREATE-BP LINE (LINE-LENGTH LINE)))))))

;;; Handling of babyl status line at start of message.  Format is:
;;; <status-line>  ::= <reformed-bit> "," <basic-labels> "," <user-labels>
;;; <basic-labels> ::= (<Space> <label-name> ",")*
;;; <user-labels>  ::= (<Space> <label-name> ",")*

(DEFUN PARSE-MSG-NEW-BABYL-STATUS-LINE (LINE STATUS &AUX KEYWORDS)
  (DO ((I 0 (1+ J))
       (STATE 0)				;0 - reformatted, 1 - basic-labels,
						;2 - user-labels
       (LEN (ARRAY-ACTIVE-LENGTH LINE))
       (J) (STR) (TEM))
      (( I LEN))
    (OR (SETQ J (STRING-SEARCH-CHAR #\, LINE I LEN))
	(RETURN))
    (SETQ STR (SUBSTRING LINE I J))
    ;; *** Temporary ***
    (AND (EQUALP STR "badHeader")
	 (SETQ STR "bad-header"))
    ;; *** End Temporary
    (CASE STATE
      (0
       (PUTPROP STATUS (NOT (STRING-EQUAL STR "0")) 'REFORMATTED)
       (SETQ STATE 1))
      (1
       (OR (SETQ TEM (CDR (ASS #'STRING-EQUAL STR *SAVED-INTERNAL-PROPERTIES-ALIST*)))
	   (ZMAIL-ERROR "Bad status line ~A" LINE))
       (PUTPROP STATUS T TEM))
      (2
       (COND ((NOT (SETQ TEM (ASS #'STRING-EQUAL STR *KEYWORD-ALIST*)))
	      (SETQ TEM (INTERN (STRING-UPCASE STR) ""))
	      (SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS (CONS STR TEM)))))
	     (T (SETQ TEM (CDR TEM))))
       (PUSH TEM KEYWORDS)))
    (INCF J)
    (AND (= J LEN) (RETURN))
    (CASE (CHAR LINE J)
      (#/,
       (AND (> (SETQ STATE (1+ STATE)) 2)
	    (RETURN))
       (SETQ J (1+ J)))
      (#/Space)
      (OTHERWISE
       (ZMAIL-ERROR "Bad status line ~A" LINE))))
  (COND (KEYWORDS
	 (SETQ KEYWORDS (NREVERSE KEYWORDS))
	 (PUTPROP STATUS KEYWORDS 'KEYWORDS)
	 (PUTPROP STATUS (STRING-FROM-KEYWORDS KEYWORDS) 'KEYWORDS-STRING))))

(DEFMETHOD (BABYL-MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE)
	   (MSG &OPTIONAL NOPARSE &AUX MSG-STATUS BP LINE)
  (SETQ MSG-STATUS (IF NOPARSE (LOCF (MSG-STATUS MSG)) (ASSURE-MSG-PARSED MSG))
        BP (MSG-REAL-START-BP MSG)
	LINE (BP-LINE BP))
  (SETF (LINE-LENGTH LINE) 0)
  (FUNCALL (IF (< (GET (LOCF OPTIONS) :VERSION) 5)
	       #'UPDATE-MSG-OLD-BABYL-STATUS-LINE
	       #'UPDATE-MSG-NEW-BABYL-STATUS-LINE)
	   LINE MSG-STATUS)
  (MUNG-BP-LINE-AND-INTERVAL BP))

(DEFUN UPDATE-MSG-NEW-BABYL-STATUS-LINE (LINE STATUS)
  (VECTOR-PUSH-EXTEND (IF (GET STATUS 'REFORMATTED) #\1 #\0) LINE)
  (VECTOR-PUSH-EXTEND #\, LINE)
  (DO ((LIST *SAVED-INTERNAL-PROPERTIES-ALIST* (CDR LIST))
       (KEY))
      ((NULL LIST))
    (SETQ KEY (CDAR LIST))
    (COND ((GET STATUS KEY)
	   (VECTOR-PUSH-EXTEND #\SP LINE)
	   (APPEND-TO-ARRAY LINE (CAAR LIST))
	   (VECTOR-PUSH-EXTEND #\, LINE))))
  (VECTOR-PUSH-EXTEND #\, LINE)
  (DOLIST (KEYWORD (GET STATUS 'KEYWORDS))
    (VECTOR-PUSH-EXTEND #\SP LINE)
    (APPEND-TO-ARRAY LINE (CAR (OR (RASSQ KEYWORD *KEYWORD-ALIST*)
				   (RASS 'STRING-EQUAL KEYWORD *KEYWORD-ALIST*))))
    (VECTOR-PUSH-EXTEND #\, LINE)))

;;; This is settable, but not in the standard way
(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :KEYWORDS)
(DEFINE-NOT-SETTABLE-MAIL-FILE-OPTION :KEYWORDS-STRING)

(DEFPROP :KEYWORDS PARSE-KEYWORDS-LIST BABYL-OPTION-PARSER)
(DEFPROP :LABELS PARSE-KEYWORDS-LIST BABYL-OPTION-PARSER)

(DEFUN PARSE-KEYWORDS-LIST (IGNORE STRING &OPTIONAL (START 0) END
					  &AUX KEYWORDS-STRING KEYWORDS)
  (SETQ KEYWORDS-STRING (SUBSTRING STRING START END))
  (DO ((I0 0 (1+ I1))
       (I1) (I2) (STR))
      (NIL)
    (OR (SETQ I0 (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* KEYWORDS-STRING I0))
	(RETURN NIL))
    (SETQ I1 (STRING-SEARCH-CHAR #\, KEYWORDS-STRING I0))
    (AND (SETQ I2 (STRING-SEARCH-CHAR #\= KEYWORDS-STRING I0 I1))
	 (SETQ I0 (1+ I2)))
    (SETQ STR (SUBSTRING KEYWORDS-STRING I0 I1))
    (PUSH (OR (ASS 'EQUALP STR *KEYWORD-ALIST*)
	      (LET* ((KEY (INTERN (STRING-UPCASE STR) ""))
		     (ELEM (CONS STR KEY)))
		(SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS ELEM)))
		ELEM))
	  KEYWORDS)
    (OR I1 (RETURN NIL)))
  ;;Avoid writing out an empty labels line.
  (AND (NULL KEYWORDS) (SETQ KEYWORDS-STRING NIL))
  `(:KEYWORDS ,(NREVERSE KEYWORDS) :KEYWORDS-STRING ,KEYWORDS-STRING))

;;; This updates the string of all keywords at the head of the file
;;; The idea is that old keywords that are still valid are kept in the old order, and new
;;; ones appended at the end.
(DEFUN (:KEYWORDS BABYL-OPTION-PRINTER) (STREAM IGNORE KEYWORDS PLIST &AUX STRING COMMA-FLAG)
  (SETQ STRING (MAKE-EMPTY-STRING 25.))
  (LET ((KEYWORDS-STRING (GET PLIST :KEYWORDS-STRING)))
    (AND KEYWORDS-STRING
	 (DO ((I0 0 (1+ I1))
	      (I1) (I2) (STR) (KEY) (ELEM))
	     (NIL)
	   (SETQ I1 (STRING-SEARCH-CHAR #\, KEYWORDS-STRING I0)
		 I2 (STRING-SEARCH-CHAR #\= KEYWORDS-STRING I0 I1)
		 STR (SUBSTRING KEYWORDS-STRING (IF I2 (1+ I2) I0) I1)
		 KEY (INTERN (STRING-UPCASE STR) ""))
	   (COND ((SETQ ELEM (RASSQ KEY KEYWORDS))
		  (SETQ KEYWORDS (REMQ ELEM KEYWORDS))
		  (AND COMMA-FLAG (VECTOR-PUSH-EXTEND #\, STRING))
		  (SETQ COMMA-FLAG T)
		  (APPEND-TO-ARRAY STRING KEYWORDS-STRING I0 I1)))
	   (OR I1 (RETURN NIL)))))
  (DO ((AL KEYWORDS (CDR AL)))
      ((NULL AL))
    (AND COMMA-FLAG (VECTOR-PUSH-EXTEND #\, STRING))
    (SETQ COMMA-FLAG T)
    (APPEND-TO-ARRAY STRING (CAAR AL)))
  (PUTPROP PLIST STRING :KEYWORDS-STRING)
  (SEND STREAM :STRING-OUT (IF ( (GET PLIST :VERSION) 5) "Labels:" "Keywords:"))
  (SEND STREAM :STRING-OUT STRING))

;;; *** BEGINNING OF OLD BABYL STUFF ***
(DEFVAR *BABYL-BIT-MASK-PROPERTIES*
	'(REFORMATTED				;1
	  UNSEEN				;2 - really stored the other way
	  LOSING-HEADERS			;4
	  ANSWERED				;10
	  FILED					;20
	  ))

(DEFUN PARSE-MSG-OLD-BABYL-STATUS-LINE (LINE STATUS &AUX I)
  (COND ((= (AREF LINE (SETQ I 0)) #\D)
	 (PUTPROP STATUS T 'DELETED)
	 (SETQ I 1)))
  (DO ((BITS (LOGXOR (PARSE-NUMBER LINE I NIL 8) 2))	;Check SEEN, not UNSEEN
       (L *BABYL-BIT-MASK-PROPERTIES* (CDR L))
       (N 1 (LSH N 1)))
      ((NULL L))
    (AND (BIT-TEST BITS N) (PUTPROP STATUS T (CAR L))))
  (LET ((IDX (STRING-SEARCH-CHAR #\{ LINE)))
    (AND IDX
	 (MULTIPLE-VALUE-BIND (KEYWORDS STRING) (PARSE-KEYWORDS LINE IDX)
	   (PUTPROP STATUS KEYWORDS 'KEYWORDS)
	   (PUTPROP STATUS STRING 'KEYWORDS-STRING)))))

(DEFUN PARSE-KEYWORDS (LINE IDX &AUX (LENGTH (ARRAY-ACTIVE-LENGTH LINE)) KEYWORDS)
  (DO ((I0 IDX (STRING-SEARCH-CHAR #\{ LINE I1 LENGTH))
       (I1) (STR) (KEY))
      ((NULL I0))
    (OR (SETQ I1 (STRING-SEARCH-CHAR #\} LINE (SETQ I0 (1+ I0)) LENGTH))
	(RETURN NIL))
    (SETQ STR (SUBSTRING LINE I0 I1)
	  KEY (INTERN (STRING-UPCASE STR) ""))
    (OR (RASSQ KEY *KEYWORD-ALIST*)
	;; Keywords not officially defined go at the end of the list
	(SETQ *KEYWORD-ALIST* (NCONC *KEYWORD-ALIST* (NCONS (CONS STR KEY)))))
    (PUSH KEY KEYWORDS))
  (SETQ KEYWORDS (NREVERSE KEYWORDS))
  (VALUES KEYWORDS (STRING-FROM-KEYWORDS KEYWORDS)))

(DEFUN UPDATE-MSG-OLD-BABYL-STATUS-LINE (LINE STATUS &AUX (BITS 10000))
  (DO ((L *BABYL-BIT-MASK-PROPERTIES* (CDR L))
       (N 1 (LSH N 1)))
      ((NULL L))
    (AND (GET STATUS (CAR L)) (SETQ BITS (LOGIOR BITS N))))
  (FORMAT LINE "~O" (LOGXOR BITS 2))		;Store SEEN, not UNSEEN
  (DOLIST (KEYWORD (GET STATUS 'KEYWORDS))
    (FORMAT LINE " {~A}" (CAR (RASSQ KEYWORD *KEYWORD-ALIST*))))
  (AND (GET STATUS 'DELETED) (ASET #\D LINE 0)))

;;; *** END OF OLD BABYL STUFF ***

(DEFVAR *ZMAIL-BUFFER-SORT-ALIST*
	`(("None" :VALUE NIL)
	  . ,*SORT-KEY-ALIST-1*))

(DEFINE-SETTABLE-MAIL-FILE-OPTION :SORT NIL :MENU-ALIST
				  "Sort predicate" *ZMAIL-BUFFER-SORT-ALIST*)

(DEFPROP :SORT MENU-ALIST-BABYL-OPTION-PARSER BABYL-OPTION-PARSER)
(DEFPROP :SORT MENU-ALIST-BABYL-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFINE-SETTABLE-MAIL-FILE-OPTION :DELETE-EXPIRED NIL :MENU-ALIST
				  "Delete expired messages" *YES-NO-ASK-ALIST*)

(DEFPROP :DELETE-EXPIRED MENU-ALIST-BABYL-OPTION-PARSER BABYL-OPTION-PARSER)
(DEFPROP :DELETE-EXPIRED MENU-ALIST-BABYL-OPTION-PRINTER BABYL-OPTION-PRINTER)

(DEFUN MENU-ALIST-BABYL-OPTION-PARSER (TYPE STRING START)
  (LIST TYPE (IF (NULL START) T
		 (DOLIST (ELEM (FOURTH (ASSQ TYPE *ZMAIL-BUFFER-OPTION-ALIST*)))
		   (AND (STRING-EQUAL (CAR ELEM) STRING :START1 0 :START2 START)
			(RETURN (TV::MENU-EXECUTE-NO-SIDE-EFFECTS ELEM)))))))

(DEFUN MENU-ALIST-BABYL-OPTION-PRINTER (STREAM TYPE VALUE IGNORE)
  (FORMAT STREAM "~:~:[: ~A~]" TYPE (EQ VALUE T)
	  (NAME-FROM-MENU-VALUE VALUE (FOURTH (ASSQ TYPE *ZMAIL-BUFFER-OPTION-ALIST*)))))

(DEFUN NAME-FROM-MENU-VALUE (VALUE ITEM-LIST)
  (DOLIST (ELEM ITEM-LIST)
    (AND (EQ (TV::MENU-EXECUTE-NO-SIDE-EFFECTS ELEM) VALUE)
	 (RETURN (CAR ELEM)))))

;;; T(w)enex mail files.  Each message has one status line of the form
;;; <received-date>,<byte-count>;bits.  E.g.
;;; 30-Jan-81 16:53:05-EST,129;000000000001

(DEFFLAVOR TENEX-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :FORMAT-NAME) () "Tenex mail")

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :HEADER-COMPATIBLE-MAIL-FILE-FORMATS) ()
  '("Mail" "Rmail" "Babyl" "Tenex mail"))

(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM)
  (VALUES (IF (OR (NULL STREAM)
		  (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
		    (SEND STREAM :SET-POINTER 0)
		    (STRING-EQUAL FIRST-LINE "Babyl Options:")))
	      ;; Babyl is the default when no stream since that is the filename
	      ;; prompted.  Perhaps this should be improved?
	      'BABYL-MAIL-FILE-BUFFER
	      'TENEX-MAIL-FILE-BUFFER)
	  T))					;Always APPEND-P

(ADD-ZMAIL-BUFFER-FLAVOR 'TENEX-MAIL-FILE-BUFFER "Tenex")

(DEFFLAVOR TENEX-MAIL-FILE-BUFFER () (TENEX-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))


(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LIST (SEND SELF :NEW-PATHNAME :NAME (STRING-UPCASE USER-ID)
		      :TYPE "BABYL" :VERSION :NEWEST)))

(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(TENEX-MAIL-FILE-BUFFER BABYL-MAIL-FILE-BUFFER))

(DEFMETHOD (FS::TOPS20-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME :NAME "MAIL" :TYPE "TXT" :VERSION 1)))

(DEFMETHOD (FS::TENEX-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (SEND SELF :NEW-PATHNAME :NAME "MESSAGE" :TYPE "TXT" :VERSION 1))

(DEFMETHOD (SI:HOST-TOPS20-MIXIN :DO-GMSGS) (STREAM)
  (MULTIPLE-VALUE-BIND (FILE-NAME UNAME-STRING) (SEND SELF :GMSGS-PATHNAME)
    (CONDITION-CASE (RESULT)
	(CHAOS:SIMPLE SELF (GMSGS-CONTACT-NAME FILE-NAME UNAME-STRING))
      (SYS:NETWORK-ERROR (FORMAT *QUERY-IO* "~&GMSGS Error: ~A"
				 (SEND RESULT :REPORT-STRING)))
      (:NO-ERROR (FORMAT STREAM "~&~A" (CHAOS:PKT-STRING RESULT))
		 (CHAOS:RETURN-PKT RESULT)))
    FILE-NAME))

(DEFMETHOD (SI:HOST-TOPS20-MIXIN :GMSGS-PATHNAME) ()
  (VALUES (SEND (FS::USER-HOMEDIR SELF) :NEW-PATHNAME
		:NAME "ZMAIL" :TYPE "TXT")
	  (FS::UNAME-ON-HOST SELF)))

(DEFVAR *TENEX-BIT-MASK-PROPERTIES*
	'(UNSEEN				;1 - really the other way around
	  DELETED				;2
	  ALWAYS-SHOW				;4
	  ANSWERED))				;10

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :BEFORE :PARSE-MSG) (MSG -STATUS- &AUX LINE COMMA-POS SEMI-POS)
  (SETQ LINE (BP-LINE (MSG-REAL-START-BP MSG)))
  (COND ((AND (PLUSP (LINE-LENGTH LINE))
	      (SETQ COMMA-POS (STRING-SEARCH-CHAR #\, LINE))
	      (SETQ SEMI-POS (STRING-SEARCH-CHAR #\; LINE (1+ COMMA-POS))))
	 (PUTPROP -STATUS-
		  (IGNORE-ERRORS
		    (TIME::PARSE-UNIVERSAL-TIME LINE 0 COMMA-POS))
		  'RECEIVED-DATE)
	 (DO ((BITS (LOGXOR (PARSE-NUMBER LINE (1+ SEMI-POS) NIL 8) 1))
	      (L *TENEX-BIT-MASK-PROPERTIES* (CDR L))
	      (N 1 (LSH N 1)))
	     ((NULL L))
	   (AND (BIT-TEST BITS N) (PUTPROP -STATUS- T (CAR L))))))
  (MOVE-BP (MSG-START-BP MSG) (LINE-NEXT LINE) 0))

(DEFMETHOD (TENEX-MAIL-FILE-BUFFER :NEW-HEADER-AND-TRAILER) ()
  (VALUES #\NewLine ""))

(DEFMETHOD (TENEX-MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE) (MSG &AUX -STATUS- BP LINE)
  (SETQ -STATUS- (ASSURE-MSG-PARSED MSG)
        BP (MSG-REAL-START-BP MSG)
	LINE (BP-LINE BP))
  (SETF (LINE-LENGTH LINE) 0)
  (LET (DAY MONTH YEAR HOURS MINUTES SECONDS DST-P
	(BITS 0))
    (MULTIPLE-VALUE (SECONDS MINUTES HOURS DAY MONTH YEAR NIL DST-P)
      (TIME::DECODE-UNIVERSAL-TIME (OR (CADR (GETL -STATUS- '(RECEIVED-DATE :DATE)))
				      (TIME::GET-UNIVERSAL-TIME))
				  TIME::*TIMEZONE*))
    (DO ((L *TENEX-BIT-MASK-PROPERTIES* (CDR L))
	 (N 1 (LSH N 1)))
	((NULL L))
      (AND (GET -STATUS- (CAR L)) (SETQ BITS (LOGIOR BITS N))))
    (FORMAT LINE "~D-~A-~D ~D:~2,'0D:~2,'0D-~A,~D;~12,'0O"
	    DAY (TIME::MONTH-STRING MONTH :SHORT) YEAR
	    HOURS MINUTES SECONDS (TIME::TIMEZONE-STRING TIME::*TIMEZONE* DST-P)
	    (COUNT-PDP-10-CHARS (MSG-START-BP MSG) (MSG-REAL-END-BP MSG) T)
	    (LOGXOR BITS 1)))
  (MUNG-BP-LINE-AND-INTERVAL BP))

(DEFUN COUNT-PDP-10-CHARS (FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((FIRST-LINE (BP-LINE FROM-BP))
	(FIRST-INDEX (BP-INDEX FROM-BP))
	(LAST-LINE (BP-LINE TO-BP))
	(LAST-INDEX (BP-INDEX TO-BP)))
    (COND ((EQ FIRST-LINE LAST-LINE)
	   (- LAST-INDEX FIRST-INDEX))
	  (T (DO ((LINE (LINE-NEXT FIRST-LINE) (LINE-NEXT LINE))
		  (I 2 (+ 2 I (LINE-LENGTH LINE))))
		 ((EQ LINE LAST-LINE)
		  (+ I (- (LINE-LENGTH FIRST-LINE) FIRST-INDEX) LAST-INDEX)))))))

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

;;; Messages on tenex has a byte count at the front

;;; The byte count can be screwed up by rubouts in the file
;;; turning themselves and the next character into a single LISPM character.

(DEFMETHOD (TENEX-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE LENGTH STATE IGNORE START
						       &AUX (ENTRY-STATE STATE))
  (IF (AND STATE ( STATE LENGTH))
      ;; Message ends after this line, or keeps going.
      (PROGN (SETQ STATE (- STATE (+ LENGTH 2)))
	     (VALUES ( STATE 0) STATE))
    ;; Message ends inside or in front of this line???
    (LET* ((COMMA-IDX (%STRING-SEARCH-CHAR #\, LINE (OR STATE 0) LENGTH))
	   (SEMI-IDX
	     (AND COMMA-IDX
		  (%STRING-SEARCH-CHAR #\; LINE (1+ COMMA-IDX) LENGTH))))
      (COND ((AND SEMI-IDX
		  (SETQ STATE (PARSE-NUMBER LINE (1+ COMMA-IDX) SEMI-IDX 10. T)))
	     ;; This line looks like a legitimate message starter.
	     ;; Now take care of possibility that message ends in middle of line.
	     (UNLESS (MEMQ ENTRY-STATE '(0 NIL))
	       (INSERT (CREATE-BP LINE ENTRY-STATE) #\RETURN)
	       ;;Add two to the byte count of the message that is ending,
	       ;;so that it will count the Return just inserted.
	       (LET* ((START-COMMA-IDX (%STRING-SEARCH-CHAR #\, START 0 (LINE-LENGTH START)))
		      (START-SEMI-IDX
			(AND START-COMMA-IDX
			     (%STRING-SEARCH-CHAR #\; START
						  (1+ START-COMMA-IDX) (LINE-LENGTH START))))
		      (START-COUNT
			(AND START-SEMI-IDX
			     (PARSE-NUMBER START (1+ START-COMMA-IDX) START-SEMI-IDX 10. T))))
		 (WHEN START-COUNT
		   (DELETE-INTERVAL
		     (CREATE-BP START (1+ START-COMMA-IDX))
		     (CREATE-BP START START-SEMI-IDX)
		     T)
		   (INSERT (CREATE-BP START (1+ START-COMMA-IDX))
			   (FORMAT NIL "~d" (+ 2 START-COUNT))))))
	     (VALUES (NOT (NULL ENTRY-STATE))
		     STATE))
	    (T
	     ;; If we cannot parse out a byte count on this line,
	     ;; set the state to 1, which will make us look at each line
	     ;; till we find one that looks semi-right.
	     (VALUES NIL 1))))))

(DEFMETHOD (FS::TENEX-FAMILY-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'TENEX-INBOX-BUFFER)

(DEFMETHOD (FS::TOPS20-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  (STRING-APPEND "_ZMAIL_" (SEND SELF :TYPE)))

(DEFMETHOD (FS::TENEX-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  (STRING-APPEND "-ZMAIL-" (SEND SELF :TYPE)))

(DEFFLAVOR TENEX-INBOX-BUFFER () (TENEX-MAIL-FILE-MIXIN INBOX-BUFFER))

;;; Unix mail files.

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM &AUX FLAVOR)
  (IF (NULL STREAM)
      (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
    (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
      (SEND STREAM :SET-POINTER 0)
      (IF (STRING-EQUAL FIRST-LINE "Babyl Options:")
	  ;; Looks like a babyl file
	  (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
	;; Default is unix mail file
	(SETQ FLAVOR 'UNIX-MAIL-FILE-BUFFER))))
  (VALUES FLAVOR T))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LIST (SEND SELF :NEW-PATHNAME :NAME USER-ID :TYPE :BABYL :VERSION :NEWEST)
	(SEND SELF :NEW-PATHNAME :RAW-NAME "mbox" :TYPE :UNSPECIFIC :VERSION :NEWEST)))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(BABYL-MAIL-FILE-BUFFER UNIX-MAIL-FILE-BUFFER))

(DEFFLAVOR UNIX-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :FORMAT-NAME) () "Unix mail")

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

(ADD-ZMAIL-BUFFER-FLAVOR 'UNIX-MAIL-FILE-BUFFER "Unix")

(DEFFLAVOR UNIX-MAIL-FILE-BUFFER () (UNIX-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))

(DEFCONST *UNIX-FROM-MARKER* "From ")

(DEFMETHOD (UNIX-MAIL-FILE-BUFFER :UPDATE-MSG-OPTIONS-IN-FILE) (MSG)
  (LET* ((-STATUS- (ASSURE-MSG-PARSED MSG))
	 (OLD-FROM (FIRST (GET -STATUS- 'UNIX-FROM-HEADER)))
	 (FROM (GET -STATUS- :FROM)))
    (OR (and (listp from) (listp old-from)
	     (LOOP FOR X IN FROM AND Y IN OLD-FROM
		   ALWAYS (LOOP FOR IND IN '(:NAME :HOST)
				ALWAYS (EQUAL (GET (LOCF X) IND) (GET (LOCF Y) IND)))))
	(LET* ((RECEIVED-DATE (GET -STATUS- 'RECEIVED-DATE))
	       (START-BP (MSG-START-BP MSG))
	       (LINE (BP-LINE START-BP)))
	  (SETQ OLD-FROM (LIST FROM RECEIVED-DATE))
	  (IF (STRING-EQUAL-START LINE *UNIX-FROM-MARKER*)
	      (SETF (LINE-LENGTH LINE) 0)
	      (INSERT START-BP #\NewLine))
	  (WITH-OUTPUT-TO-STRING (-STREAM- LINE)
	    (SEND -STREAM- :STRING-OUT *UNIX-FROM-MARKER*)
	    (PRINT-ADDRESS-LIST FROM -STREAM-)
	    (AND RECEIVED-DATE
		 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
		     (TIME::DECODE-UNIVERSAL-TIME RECEIVED-DATE)
		   (FORMAT -STREAM- "  ~A ~A ~2D ~2,'0D:~2,'0D:~2,'0D ~D"
			   (TIME::DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK :SHORT)
			   (TIME::MONTH-STRING MONTH :SHORT)
			   DAY HOURS MINUTES SECONDS (+ YEAR 1900.)))))))))

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :PARSE-MSG-TEXT) (MSG IGNORE &AUX UNIX-HEADER NEWSTAT)
  (LET ((START-BP (MSG-START-BP MSG)))
    (LET ((LINE (BP-LINE START-BP)))
      (COND ((STRING-EQUAL-START LINE *UNIX-FROM-MARKER*)
	     (SETQ UNIX-HEADER (PARSE-UNIX-FROM-HEADER start-bp))
	     (PUTPROP (LOCF NEWSTAT) UNIX-HEADER 'UNIX-FROM-HEADER)
	     (SETQ START-BP (BEG-LINE START-BP 1)))))
    (MULTIPLE-VALUE-BIND (TEM STOP-BP)
	(PARSE-HEADERS-INTERVAL START-BP (MSG-END-BP MSG) T T)
      (AND UNIX-HEADER
	   (LET ((PLIST (LOCF TEM)))
	     (PUTPROP PLIST (SECOND UNIX-HEADER) 'RECEIVED-DATE)
	     (OR (GET PLIST :DATE)
		 (PUTPROP PLIST (SECOND UNIX-HEADER) :DATE))
	     (OR (GET PLIST :FROM)
		 (PUTPROP PLIST (FIRST UNIX-HEADER) :FROM))))
      (VALUES (APPEND TEM NEWSTAT) STOP-BP))))

(DEFUN PARSE-UNIX-FROM-HEADER (start-bp &aux line (bp start-bp))
  ;find the last line that has either "From" or ">From"
  (do ()
      ((not (or (string-equal-start (bp-line bp) "From ")
		(string-equal-start (bp-line bp) ">From "))))
    (setq bp (beg-line bp 1 nil)))
  (cond ((not (bp-= bp start-bp))
	 (setq bp (beg-line bp -1 t))
	 (setq line (bp-line bp)))
	(t
	 ;couldn't make sense of what's going on, do the old behavior
	 (setq line (bp-line start-bp))))
  (LET ((START (STRING-LENGTH *UNIX-FROM-MARKER*))
	END)
    (SETQ END (STRING-SEARCH-CHAR #\SP LINE START))
    (DO (NEXT-END WORD)
	(())
      ;; Look at the word (between spaces) following END.
      (OR (SETQ NEXT-END (STRING-SEARCH-CHAR #\SP LINE (1+ END)))
	  (RETURN))  ;Don't get screwed by malformatted line, if we run out of it.
      (SETQ WORD (SUBSTRING LINE (1+ END) NEXT-END))
      ;; If this word is a day-of-the-week abbreviation,
      ;; then it is not part of the sender, so use END, which points before it.
      (AND ( NEXT-END (+ END 4))
	   (DOLIST (DAYLIST TIME::*DAYS-OF-THE-WEEK*)
	     (IF (STRING-EQUAL (CAR DAYLIST) WORD :START1 0 :START2 0 :END1 (LENGTH WORD))
		 (RETURN T)))
	   (RETURN))
      ;; Otherwise it is part of the sender.
      (SETQ END NEXT-END))
    (LIST (condition-case (error)
	      (PARSE-ADDRESSES LINE START END)
	    (error (send error :report-string)))
	  (AND END
	       (CONDITION-CASE (ERROR)
		   (TIME::PARSE-UNIVERSAL-TIME LINE (+ END 1) (string-search "remote" line))
		 (ERROR (SEND ERROR :REPORT-STRING)))))))

;; Copied from LAD: RELEASE-3.ZMAIL; MFHOST.LISP#66 on 2-Oct-86 03:04:07
(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE IGNORE STATE EOF IGNORE)
  (VALUES (COND ((NULL STATE) NIL)
		(EOF (LINE-LENGTH LINE))
		((and (STRING= LINE *UNIX-FROM-MARKER* :END1 (string-LENGTH *UNIX-FROM-MARKER*))
		      ;; These other tests are neccessary because, sometimes, a ``From''
		      ;; can appear at the beginning of a line (probably a Unix bug).
		      (let ((start (string-search-char #\Space line
						       (+ 1 (string-length *unix-from-marker*)))))
			(when start
			  (dolist (daylist time::*days-of-the-week*)
			    (let ((from
				    (string-search (car daylist) line start))) ; quick d-o-w check
			      (and from
				   (string-search-set "0123456789" line ; quick date/numbers check
						      (+ 1 from))
				   (return t)))))))
		 :START-NEXT))
	  T))

(DEFMETHOD (UNIX-MAIL-FILE-MIXIN :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))))
	  (RECEIVED-DATE (GET (LOCF (MSG-STATUS MSG)) 'RECEIVED-DATE)))
      (SEND STRM :STRING-OUT *UNIX-FROM-MARKER*)
      (PRINT-ADDRESS-LIST (GET (LOCF (MSG-STATUS MSG)) :FROM) STRM)
      (AND RECEIVED-DATE
	   (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
	       (TIME::DECODE-UNIVERSAL-TIME RECEIVED-DATE)
	     (FORMAT STRM "  ~A ~A ~2D ~2,'0D:~2,'0D:~2,'0D ~D"
		     (TIME::DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK :SHORT)
		     (TIME::MONTH-STRING MONTH :SHORT)
		     DAY HOURS MINUTES SECONDS (+ YEAR 1900.))))
      (DO ((TAIL (MSG-STATUS MSG) (CDDR TAIL)))
	  ((NULL TAIL))
	(WHEN (RASSQ (CAR TAIL) *HEADER-NAME-ALIST*)
	  (PRINT-HEADER STRM (CADR TAIL) (CAR TAIL)))))
    (TERPRI STREAM)
    (DELETE-INTERVAL SEP (GET (LOCF (MSG-STATUS MSG)) 'HEADERS-END-BP))))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'UNIX-INBOX-BUFFER)

(defmethod (unix-mail-file-mixin :inbox-buffer) (&optional new-pathname delete-p)
  (let ((username (progn
		    ;; Just causing a file access to the host to happen, so that we can get
		    ;; the right user id.
		    (fs::user-homedir (send pathname :host))
		    ;; We downcase the name because some Unix file servers are not case-sensitive
		    ;; to the user name for the login command.
		    (string-downcase (or (fs::uname-on-host (send pathname :host))
					 user-id)))))
    (make-inbox-buffer (send pathname :inbox-buffer-flavor)
		       (if new-pathname
			   (list (list new-pathname nil delete-p))
			 (loop for new-pathname
			       in (list (send pathname :new-pathname
					      :raw-directory '("usr" "spool" "mail")
					      :raw-name username :type :unspecific
					      :version :newest)
					(send pathname :new-pathname
					      :raw-directory '("usr" "mail")
					      :raw-name username :type :unspecific
					      :version :newest)
					(send pathname :new-pathname
					      :raw-name ".mail" :type :unspecific
					      :version :newest))
			       collect (list new-pathname
					     (send new-pathname :new-raw-type
						   (send new-pathname :zmail-temp-file-name))
					     t)))
		       self)))

;;; >> System V lossage here.
(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME
		    :RAW-DIRECTORY '("usr" "spool" "mail")
		    :RAW-NAME USER-ID
		    :TYPE :UNSPECIFIC :VERSION :NEWEST)))

(DEFMETHOD (FS::UNIX-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  "zmail")

(DEFFLAVOR UNIX-INBOX-BUFFER () (UNIX-MAIL-FILE-MIXIN INBOX-BUFFER))

(DEFMETHOD (UNIX-INBOX-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  MSG
  (PUTPROP -STATUS- T 'UNSEEN))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :MAIL-FILE-FORMAT-COMPUTER) (STREAM &AUX FLAVOR)
  (IF (NULL STREAM)
      (SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER)
    (LET ((FIRST-LINE (SEND STREAM :LINE-IN)))
      (SEND STREAM :SET-POINTER 0)
      (IF (STRING-EQUAL FIRST-LINE #\FF)
	  (SETQ FLAVOR 'VMS-MAIL-FILE-BUFFER)
	;; Doesn't look like a vms file
	(SETQ FLAVOR 'BABYL-MAIL-FILE-BUFFER))))
  (VALUES FLAVOR T))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-NAMES) ()
  (LIST (SEND SELF :NEW-PATHNAME :NAME USER-ID :TYPE :BABYL :VERSION :NEWEST)))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :POSSIBLE-MAIL-FILE-BUFFER-FLAVORS) ()
  '(BABYL-MAIL-FILE-BUFFER VMS-MAIL-FILE-BUFFER))

(DEFFLAVOR VMS-MAIL-FILE-MIXIN () ()
  :ABSTRACT-FLAVOR
  (:REQUIRED-FLAVORS ZMAIL-DISK-BUFFER))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :FORMAT-NAME) () "VMS mail")

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :MAIL-FILE-REPARSABLE-P) () T)

(ADD-ZMAIL-BUFFER-FLAVOR 'VMS-MAIL-FILE-BUFFER "VMS")

(DEFFLAVOR VMS-MAIL-FILE-BUFFER () (VMS-MAIL-FILE-MIXIN MAIL-FILE-BUFFER))
      
(DEFMETHOD (VMS-MAIL-FILE-MIXIN :LINE-END-OF-MSG-P) (LINE LENGTH STATE EOFFLAG &REST IGNORE)
  (VALUES (COND ((NULL STATE) NIL)
		(EOFFLAG LENGTH)
		((STRING-EQUAL LINE #\FF)
		 :START-NEXT))
	  T))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :BEFORE :PARSE-MSG) (MSG &REST IGNORE)
  (LET ((REAL-START-LINE (BP-LINE (INTERVAL-FIRST-BP (MSG-REAL-INTERVAL MSG)))))
    (MOVE-BP (INTERVAL-FIRST-BP (MSG-INTERVAL MSG))
	     (LINE-NEXT REAL-START-LINE) 0)
    (SETF (LINE-NODE REAL-START-LINE) *INTERVAL*)))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :AFTER :PARSE-MSG) (MSG &REST IGNORE)
  (LET ((LINE (LINE-PREVIOUS (BP-LINE (INTERVAL-LAST-BP (MSG-REAL-INTERVAL MSG))))))
    (MOVE-BP (INTERVAL-LAST-BP (MSG-INTERVAL MSG))
	     LINE (LENGTH LINE))))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :NEW-HEADER-AND-TRAILER) ()
  (VALUES (STRING-APPEND #\Page #\NewLine) #\NewLine))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :PARSE-MSG-TEXT) (MSG IGNORE &AUX VMS-HEADER NEWSTAT STOP-BP)
  (LET ((START-BP (MSG-START-BP MSG)))
    (LET ((LINE (BP-LINE START-BP))
	  (HOST (LIST (SEND (PATHNAME-HOST PATHNAME) :NAME))))
      (SETQ VMS-HEADER (PARSE-VMS-FROM-HEADER LINE))
      (PUTPROP (LOCF NEWSTAT) VMS-HEADER 'VMS-FROM-HEADER)
      (IF (EQUAL (FIRST VMS-HEADER) "CHAOSMAIL")
	  (MULTIPLE-VALUE (NEWSTAT STOP-BP)
	    (PARSE-HEADERS-INTERVAL (BEG-LINE START-BP 1) (MSG-END-BP MSG) T T))
	(SETQ STOP-BP (BEG-LINE START-BP 1))
	(WHEN (STRING-EQUAL (BP-LINE STOP-BP) "TO:	" :END1 4 :END2 4)
	  (LET ((TEM (PARSE-VMS-TO-HEADER (BP-LINE STOP-BP) HOST)))
	    (WHEN TEM
	      (PUTPROP (LOCF NEWSTAT) TEM :TO))
	    (SETQ STOP-BP (BEG-LINE STOP-BP 1))))
	(WHEN (STRING-EQUAL (BP-LINE STOP-BP) "SUBJ:	" :END1 6 :END2 6)
	  (LET ((TEM (PARSE-VMS-SUBJECT-HEADER (BP-LINE STOP-BP))))
	    (WHEN TEM
	      (PUTPROP (LOCF NEWSTAT) TEM :SUBJECT))
	    (SETQ STOP-BP (BEG-LINE STOP-BP 1)))))
      (LET ((PLIST (LOCF NEWSTAT)))
	(PUTPROP PLIST (SECOND VMS-HEADER) 'RECEIVED-DATE)
	(OR (GET PLIST :DATE)
	    (PUTPROP PLIST (SECOND VMS-HEADER) :DATE))
	(OR (GET PLIST :FROM)
	    (PUTPROP PLIST (LIST (LIST :NAME (FIRST VMS-HEADER) :HOST HOST)) :FROM)))
      (VALUES NEWSTAT STOP-BP))))

(DEFUN PARSE-VMS-FROM-HEADER (LINE)
  (LET ((START (STRING-LENGTH "FROM:	")))
    (LIST (STRING-TRIM " " (SUBSTRING LINE START (+ START 12.)))
	  (CONDITION-CASE (ERROR)
	      (TIME::PARSE-UNIVERSAL-TIME LINE (+ START 12.)
					 (STRING-SEARCH-CHAR
					   #\SP LINE
					   (1+
					     (STRING-SEARCH-CHAR #\SP LINE
								 (+ START 12.))))
					 NIL)
	    (ERROR (SEND ERROR :REPORT-STRING))))))

(DEFUN PARSE-VMS-TO-HEADER (LINE HOST &AUX COMMA TEM)
  (DO ((INDEX (STRING-LENGTH "TO:	"))
       (END (LENGTH LINE))
       RCPTS)
      (( INDEX END) RCPTS)
    (SETQ COMMA (STRING-SEARCH-CHAR #\, LINE INDEX))
    (SETQ TEM (STRING-TRIM " " (SUBSTRING LINE INDEX COMMA)))
    (UNLESS (EQUAL TEM "")
      (PUSH (LIST :NAME TEM :HOST HOST) RCPTS))
    (IF COMMA
	(SETQ INDEX (1+ COMMA))
      (RETURN RCPTS))))

(DEFUN PARSE-VMS-SUBJECT-HEADER (LINE)
  (SUBSTRING-AFTER-CHAR #\TAB LINE))

(DEFMETHOD (VMS-MAIL-FILE-MIXIN :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)))))
      (MULTIPLE-VALUE-BIND (NIL MINUTES HOURS DAY MONTH YEAR)
	  (TIME::DECODE-UNIVERSAL-TIME
	    (OR (GET (LOCF (MSG-STATUS MSG)) 'RECEIVED-DATE)
		(GET (LOCF (MSG-STATUS MSG)) :DATE)))
	(FORMAT STRM "From:	CHAOSMAIL      ~D-~A-~D ~2,'0D:~2,'0D~%"
		DAY (TIME::MONTH-STRING MONTH :SHORT) (+ 1900. YEAR) HOURS MINUTES))
      (DO ((TAIL (MSG-STATUS MSG) (CDDR TAIL)))
	  ((NULL TAIL))
	(WHEN (RASSQ (CAR TAIL) *HEADER-NAME-ALIST*)
	  (PRINT-HEADER STRM (CADR TAIL) (CAR TAIL)))))
    (TERPRI STREAM)
    (DELETE-INTERVAL SEP (GET (LOCF (MSG-STATUS MSG)) 'HEADERS-END-BP))))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :NEW-MAIL-PATHNAME) ()
  (OR (MAYBE-OVERRIDDEN-MAIL-PATHNAME SELF)
      (SEND SELF :NEW-PATHNAME
		    :NAME "MAIL"
		    :TYPE "MAI"
		    :VERSION :NEWEST)))

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :ZMAIL-TEMP-FILE-NAME) ()
  "ZML")

(DEFMETHOD (FS::VMS-PATHNAME-MIXIN :INBOX-BUFFER-FLAVOR) ()
  'VMS-INBOX-BUFFER)

(DEFFLAVOR VMS-INBOX-BUFFER () (VMS-MAIL-FILE-MIXIN INBOX-BUFFER))

(DEFMETHOD (VMS-INBOX-BUFFER :BEFORE :PARSE-MSG) (MSG -STATUS-)
  MSG
  (PUTPROP -STATUS- T 'UNSEEN))