;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI -*- 
;;; Profile mode and commands, definition are in DEFS
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **

(DEFVAR *EDITING-PROFILE*)

(DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-PROFILE
				"Alter user options and edit ZMail init file."
				(NO-MAIL-FILE-OK)
  (SET-ZMAIL-USER)
  (LET ((OLD-CONFIGURATION *WINDOW-CONFIGURATION*)
	(OLD-DOC (FUNCALL (WINDOW-SHEET *PROFILE-EDITOR-WINDOW*)
			  ':WHO-LINE-OVERRIDE-DOCUMENTATION-STRING))
	(*EDITING-PROFILE* NIL))
    (UNWIND-PROTECT
      (PROGN
	(LOCK-BACKGROUND-PROCESS)
	(FUNCALL-SELF ':SET-WINDOW-CONFIGURATION ':PROFILE)
	(FUNCALL (WINDOW-SHEET *PROFILE-EDITOR-WINDOW*)
		 ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING NIL)
	(FUNCALL *PROFILE-EDITOR* ':EDIT-PROFILE))
      (FUNCALL (WINDOW-SHEET *PROFILE-EDITOR-WINDOW*)
	       ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING OLD-DOC)
      (FUNCALL-SELF ':SET-WINDOW-CONFIGURATION OLD-CONFIGURATION)
      (PROCESS-UNLOCK *ZMAIL-BACKGROUND-PROCESS-LOCK*)))
  DIS-NONE)

(DEFFLAVOR ZMAIL-PROFILE-EDITOR
       ((*MODE-LINE-LIST* `("ZMail " (*EDITING-PROFILE* "Editing ") "Profile "
			    *ZMAIL-FILE-NAME*
			    (*EDITING-PROFILE* ,(FORMAT NIL "     ~:@C ends." #\END ))))
	(*VARIABLE-TICK*)
	(*EDITOR-VARIABLE-TICK*)
	(*PROFILE-QFASL-GENERIC-PATHNAME*)
	(*PROFILE-SOURCE-PATHNAME*)
	(*PROFILE-COMPILE-TICK*)		;When last compiled
	(*COMTAB* *STANDALONE-COMTAB*)
	)
       (TOP-LEVEL-EDITOR ZMAIL-COMMAND-LOOP-MIXIN))

(GLOBALLY-DECLARE-FLAVOR-INSTANCE-VARIABLES ZMAIL-PROFILE-EDITOR)

(DEFUN CREATE-PROFILE-EDITOR (WINDOW &AUX OPTIONS PLIST)
  (SETQ OPTIONS `(:*WINDOW* ,WINDOW)
	PLIST (LOCF OPTIONS))
  (INSTANTIATE-FLAVOR 'ZMAIL-PROFILE-EDITOR PLIST T))

(DEFMETHOD (ZMAIL-PROFILE-EDITOR :TOP-LEVEL-TAG) () 'EXIT-PROFILE-EDITOR)

(DEFMETHOD (ZMAIL-PROFILE-EDITOR :REFRESH) ZMAIL-PROFILE-EDITOR-MSG-REALLY-FOR-ZMAIL-FRAME)
(DEFMETHOD (ZMAIL-PROFILE-EDITOR :SELECT) ZMAIL-PROFILE-EDITOR-MSG-REALLY-FOR-ZMAIL-FRAME)

(DEFUN ZMAIL-PROFILE-EDITOR-MSG-REALLY-FOR-ZMAIL-FRAME (&REST MSG-AND-ARGS)
  (LEXPR-FUNCALL *ZMAIL-WINDOW* MSG-AND-ARGS))

(DEFMETHOD (ZMAIL-PROFILE-EDITOR :RESET-PROFILE) ()
  (SETF (BUFFER-FILE-ID *INTERVAL*) NIL))

(DEFMETHOD (ZMAIL-PROFILE-EDITOR :EDIT-PROFILE) ()
  (MULTIPLE-VALUE (*MODE-LINE-WINDOW* *TYPEIN-WINDOW* *MINI-BUFFER-WINDOW*)
    (WINDOW-MODE-LINE-WINDOWS *WINDOW*))
  (PKG-BIND "ZWEI"
    (LET ((*ZMAIL-FILE-NAME* (SETUP-ZMAIL-PROFILE)))
      (FUNCALL-SELF ':COMMAND-LOOP))))

(DEFUN SETUP-ZMAIL-PROFILE (&AUX FILE-ID PATHNAME)
  (SET-ZMAIL-USER)
  (SETQ FILE-ID (BUFFER-FILE-ID *INTERVAL*))
  (IF (NULL FILE-ID)
      (SETQ PATHNAME (ZMAIL-INIT-FILE-PATHNAME))
      (SETQ PATHNAME (BUFFER-PATHNAME *INTERVAL*))
      ;; See if everything is still ok
      (WITH-OPEN-FILE (STREAM PATHNAME '(:PROBE :NOERROR))
	(IF (STRINGP STREAM)
	    (AND (NEQ FILE-ID T)
		 (TYPEIN-LINE "Note: file has been deleted on the file computer"))
	    (AND (NOT (EQUAL FILE-ID (FUNCALL STREAM ':INFO)))
		 (FQUERY '(:SELECT T
			   :BEEP T)
			 "There is a different version of this file on the file computer,~@
			  your version has~:[ not~] been modified.~@
			  Do you want the new version instead? "
			 (BUFFER-MUNGED-P *INTERVAL*))
		 (SETQ FILE-ID NIL)))))
  (COND ((NULL FILE-ID)
	 (DELETE-INTERVAL *INTERVAL*)
	 (WITH-OPEN-FILE (STREAM PATHNAME '(:PROBE :NOERROR))
	   (COND ((STRINGP STREAM)
		  (TYPEIN-LINE "Creating init file ~A" PATHNAME)
		  (FORMAT (INTERVAL-STREAM *INTERVAL*)
			  ";~A's ZMAIL init file -*-Mode:LISP;Package:ZWEI-*-~%"
			  USER-ID)
		  (INSERT-CHANGED-VARIABLES T)
		  (MOVE-BP (WINDOW-POINT *WINDOW*)
			   (INTERVAL-LAST-BP *INTERVAL*))
		  (SETF (BUFFER-FILE-ID *INTERVAL*) T)
		  (SETF (BUFFER-TICK *INTERVAL*) (TICK)))
		 (T
		  (SETQ PATHNAME (RECORD-ZMAIL-PROFILE-SOURCE-PATHNAME STREAM))
		  (CLOSE STREAM)
		  (SETQ STREAM (OPEN PATHNAME '(:IN)))
		  (LET ((GENERIC-PATHNAME
			  (FUNCALL *PROFILE-SOURCE-PATHNAME* ':GENERIC-PATHNAME)))
		    (SETF (BUFFER-GENERIC-PATHNAME *INTERVAL*)
			  GENERIC-PATHNAME)
		    (FS:FILE-READ-PROPERTY-LIST GENERIC-PATHNAME STREAM))
		  (TYPEIN-LINE "Reading init file ~A" (FUNCALL STREAM ':TRUENAME))
		  (SETF (BUFFER-TICK *INTERVAL*) (TICK))
		  (SETF (BUFFER-FILE-ID *INTERVAL*) (FUNCALL STREAM ':INFO))
		  (SECTIONIZE-BUFFER *INTERVAL* STREAM)
		  (DECIDE-IF-SOURCE-MATCHES-QFASL STREAM)))
	   (SETF (BUFFER-NAME *INTERVAL*) (FUNCALL PATHNAME ':STRING-FOR-PRINTING))
	   (SETF (BUFFER-PATHNAME *INTERVAL*) PATHNAME)
	   (LET ((TICK (TICK)))
	     (SETQ *VARIABLE-TICK* TICK)	;Now assumed to be the same
	     (SETQ *EDITOR-VARIABLE-TICK* TICK))
	   (PUSH* *WINDOW* *WINDOW-LIST*)
	   (MUST-REDISPLAY *WINDOW* DIS-TEXT))))
  (BUFFER-NAME *INTERVAL*))

(DEFMETHOD (ZMAIL-PROFILE-EDITOR :PROCESS-SPECIAL-COMMAND) (&REST ARGS)
  (APPLY #'ZMAIL-PROFILE-COMMAND-LIST ARGS))

(DEFWRAPPER (ZMAIL-PROFILE-EDITOR :EDIT) (IGNORE . BODY)
  `(LET ((*EDITING-PROFILE* T))
     . ,BODY))

(DEFVAR *EXPLICIT-OPTION-UPDATE* NIL)

(DEFSELECT (ZMAIL-PROFILE-COMMAND-LIST ZMAIL-COMMAND-LIST-DEFAULT)
  (:VARIABLE-CHOICE (WINDOW ITEM CHOICE LINE-NO)
    (UNWIND-PROTECT
      (PROGN
	(FUNCALL *PROFILE-WINDOW* ':SEND-PANE 'CHOOSE-WINDOW ':SELECT NIL)
	(TV:CHOOSE-VARIABLE-VALUES-CHOICE WINDOW ITEM CHOICE LINE-NO)
	(SETQ *VARIABLE-TICK* (TICK))
	(LET ((*EXPLICIT-OPTION-UPDATE* T))
	  (DOLIST (COM (GET (CAR ITEM) 'DOCUMENTATION-ASSOCIATED-COMMANDS))
	    (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION COM))))
      (FUNCALL *ZMAIL-WINDOW* ':SELECT NIL)))
  (:MOUSE-BUTTON (CH WINDOW IGNORE IGNORE &AUX WINDOW-NAME *ZMAIL-COMMAND-BUTTON* NEAR-MODE)
   (FUNCALL WINDOW ':SET-ACCENT T)		;It may have gotten turned off
   (SET-COMMAND-BUTTON CH)
   (SETQ WINDOW-NAME (FUNCALL *PROFILE-WINDOW* ':PANE-NAME WINDOW)
	 NEAR-MODE `(:WINDOW ,WINDOW))
   (UNWIND-PROTECT
     (SELECTQ WINDOW-NAME
       (FILTERS-BUTTON
	(PROFILE-FILTERS-BUTTON NEAR-MODE))
       (UNIVERSES-BUTTON
	(PROFILE-UNIVERSES-BUTTON NEAR-MODE))
       (MAIL-FILES-BUTTON
	(PROFILE-MAIL-FILES-BUTTON NEAR-MODE))
       (KEYWORDS-BUTTON
	(PROFILE-KEYWORDS-BUTTON NEAR-MODE))
       (HARDCOPY-BUTTON
	(CHOOSE-HARDCOPY-OPTIONS NEAR-MODE ':BOTH))
       (FILE-OPTIONS-BUTTON
	(LET* ((ALIST (OR (GET-MAIL-FILE-ALISTS T) (BARF "No mail files to choose")))
	       (MAIL-FILE (TV:MENU-CHOOSE ALIST NIL NEAR-MODE)))
	  (COND (MAIL-FILE
		 (AND (STRINGP MAIL-FILE) (SETQ MAIL-FILE (MAKE-NEW-MAIL-FILE MAIL-FILE)))
		 (CHOOSE-MAIL-FILE-OPTIONS MAIL-FILE)))))
       (DONE-BUTTON
	(*THROW 'EXIT-PROFILE-EDITOR T))
       ((RESET-BUTTON DEFAULTS-BUTTON)
	(RESET-USER-OPTIONS *ZMAIL-USER-OPTION-ALIST*)
	(IF (EQ WINDOW-NAME 'RESET-BUTTON)
	    (PROGN (LOAD (ZMAIL-INIT-FILE-PATHNAME) "ZWEI" T)
		   (WITH-OPEN-FILE (SRC-FILE *PROFILE-SOURCE-PATHNAME* ':PROBE)
		     (DECIDE-IF-SOURCE-MATCHES-QFASL SRC-FILE)))
	    (SETQ *PROFILE-COMPILE-TICK* NIL))
	(FUNCALL *PROFILE-WINDOW* ':SEND-PANE 'CHOOSE-WINDOW ':REFRESH)
	(UPDATE-ALL-COMMANDS-ASSOCIATED-WITH-OPTIONS-DOCUMENTATION)
	(SETQ *VARIABLE-TICK* (TICK))
	(AND (BUFFER-NEEDS-SAVING-P *INTERVAL*)
	     (IF (AND (EQ WINDOW-NAME 'RESET-BUTTON)
		      (TYPEOUT-BEEP-YES-OR-NO-P "Revert file buffer too? "))
		 (REVERT-BUFFER *INTERVAL*)
		 (INSERT-CHANGED-VARIABLES ':ASK))))
       (SAVE-BUTTON
	(PROFILE-SAVE-BUTTON NEAR-MODE))
       (EDIT-BUTTON
	(INSERT-CHANGED-VARIABLES NIL)
	(UNWIND-PROTECT
	  (PROGN
	    (SELECT-WINDOW *WINDOW*)
	    (FUNCALL-SELF ':EDIT)
	    (SECTIONIZE-BUFFER *INTERVAL*))
	  (FUNCALL *ZMAIL-WINDOW* ':SELECT NIL)))
       (OTHERWISE
	(BARF "~S is not a recognized window" WINDOW)))
     (FUNCALL WINDOW ':SET-ACCENT NIL)))
  )

(DEFUN TYPEOUT-BEEP-YES-OR-NO-P (&REST FORMAT-ARGS)
  (LET ((QUERY-IO *TYPEOUT-WINDOW*))
    (LEXPR-FUNCALL #'FQUERY '#,`(:SELECT T
				 :BEEP T
				 :TYPE :READLINE
				 :CHOICES ,FORMAT:YES-OR-NO-P-CHOICES)
		   FORMAT-ARGS)))

;;; 0 - sir, 1 - ma'am, anything else skip it.
(DEFVAR *ZMAIL-SEXISM-INDEX* 0)

(DEFUN MAYBE-COMPILE-ZMAIL-INIT-FILE ()
  (IF (AND *PROFILE-QFASL-GENERIC-PATHNAME*
	   (NEQ (BUFFER-TICK *INTERVAL*) *PROFILE-COMPILE-TICK*)
	   (TYPEOUT-BEEP-YES-OR-NO-P "ReCompile ZMAIL init file~[, sir~;, ma'am~]? "
				     *ZMAIL-SEXISM-INDEX*))
      (COMPILE-ZMAIL-INIT-FILE)))

(DEFUN COMPILE-ZMAIL-INIT-FILE ()
  (IF (NULL *PROFILE-QFASL-GENERIC-PATHNAME*)
      (BARF "Your init file is not compiled.")
      (QC-FILE *PROFILE-SOURCE-PATHNAME* (ZMAIL-INIT-FILE-PATHNAME))
      (LOAD (ZMAIL-INIT-FILE-PATHNAME))
      (SETQ *PROFILE-COMPILE-TICK* (BUFFER-TICK *INTERVAL*))))

(DEFUN MAKE-INIT-FILE-BE-COMPILED ()
  (IF *PROFILE-QFASL-GENERIC-PATHNAME*
      (BARF "Your init file is already compiled.")
      (LET* ((DEFAULT (FUNCALL (FS:USER-HOMEDIR) ':NEW-PATHNAME
			       ':NAME "ZMAIL" ':TYPE "LISP" ':VERSION ':NEWEST))
	     (PATHNAME (READ-DEFAULTED-PATHNAME "Save source file on" DEFAULT)))
	(SETQ *PROFILE-SOURCE-PATHNAME* PATHNAME
	      *PROFILE-QFASL-GENERIC-PATHNAME* (FUNCALL (ZMAIL-INIT-FILE-PATHNAME)
							':GENERIC-PATHNAME))
	(SETF (BUFFER-FILE-ID *INTERVAL*) T)
	(SETF (BUFFER-PATHNAME *INTERVAL*) PATHNAME)
	(SETF (BUFFER-GENERIC-PATHNAME *INTERVAL*) (FUNCALL PATHNAME ':GENERIC-PATHNAME))
	(SETQ *ZMAIL-FILE-NAME* (FUNCALL PATHNAME ':STRING-FOR-PRINTING))
	(SETF (BUFFER-NAME *INTERVAL*) *ZMAIL-FILE-NAME*))))

(DEFUN DECIDE-IF-SOURCE-MATCHES-QFASL (STREAM &AUX QFASL-FILE SRC-FILE)
  ;; We decide if the QFASL file is the one corresponding with
  ;; the source file we found by checking both the specific pathname
  ;; and the creation dates.  Our argument is a stream for the source
  ;; file.
  (COND ((NULL *PROFILE-QFASL-GENERIC-PATHNAME*)
	 (SETQ *PROFILE-COMPILE-TICK* NIL))
	((NEQ (SETQ SRC-FILE (FUNCALL STREAM ':TRUENAME))
	      (SETQ QFASL-FILE (FUNCALL *PROFILE-QFASL-GENERIC-PATHNAME*
					':GET ':QFASL-SOURCE-FILE-UNIQUE-ID)))
	 (TYPEIN-LINE
	   "(Profile compiled from ~A, current source = ~A.)
 (Click SAVE to recompile.)"
	   QFASL-FILE SRC-FILE)
	 (SETQ *PROFILE-COMPILE-TICK* NIL))
	((OR (NULL (SETQ QFASL-FILE
			 (OPEN (ZMAIL-INIT-FILE-PATHNAME) ':PROBE)))
	      (STRINGP QFASL-FILE))
	 (SETQ *PROFILE-COMPILE-TICK* NIL)
	 (FERROR () "Profile source file suddenly missing:  ~A" QFASL-FILE))
	((> (FUNCALL STREAM ':CREATION-DATE)
	    (FUNCALL QFASL-FILE ':CREATION-DATE))
	 (SETQ *PROFILE-COMPILE-TICK* NIL)
	 (TYPEIN-LINE "~
(Your Compiled profile is older than its source file.  Click SAVE to recompile)"))
	(T (SETQ *PROFILE-COMPILE-TICK* (BUFFER-TICK *INTERVAL*)))))


(DEFUN RECORD-ZMAIL-PROFILE-SOURCE-PATHNAME (STREAM &AUX PATHNAME)
  (SETQ PATHNAME (FUNCALL STREAM ':PATHNAME))
  (IF (FUNCALL STREAM ':QFASLP)
      (PROGN
	(SETQ *PROFILE-QFASL-GENERIC-PATHNAME* 
	      (FUNCALL PATHNAME ':GENERIC-PATHNAME))
	(SETQ *PROFILE-SOURCE-PATHNAME*
	      (FUNCALL (FUNCALL *PROFILE-QFASL-GENERIC-PATHNAME*
				':GET ':QFASL-SOURCE-FILE-UNIQUE-ID)
		       ':NEW-VERSION ':NEWEST))
	*PROFILE-SOURCE-PATHNAME*)
      (SETQ *PROFILE-SOURCE-PATHNAME*
	    (FUNCALL PATHNAME ':NEW-VERSION ':NEWEST)
	    *PROFILE-QFASL-GENERIC-PATHNAME* NIL)
      PATHNAME))

(DEFUN INSERT-CHANGED-VARIABLES (WHEN)
  (AND (OR (EQ WHEN T)
	   (AND (> *VARIABLE-TICK* *EDITOR-VARIABLE-TICK*)
		(OR (NEQ WHEN ':ASK)
		    (TYPEOUT-BEEP-YES-OR-NO-P "Insert changed variables? "))))
       (LET* ((BP (DO ((BP (INTERVAL-FIRST-BP *INTERVAL*))
		       (START-BP) (LAST-END-BP))
		      (NIL)
		    (OR (STRING-EQUAL (BP-LINE BP) "(" 0 0 1 1)
			(SETQ BP (FORWARD-DEFUN BP 1 T)))
		    (COND ((STRING-EQUAL (BP-LINE BP) "(LOGIN-SETQ" 0 0 13 13)
			   (OR START-BP (SETQ START-BP BP))
			   (SETQ BP (FORWARD-SEXP BP 1 T))
			   (SETQ BP (BEG-LINE BP 1 T))
			   (SETQ LAST-END-BP BP))
			  (T
			   (AND START-BP (DELETE-INTERVAL START-BP LAST-END-BP T))
			   (RETURN (OR LAST-END-BP BP))))))
	      (STREAM (INTERVAL-STREAM-INTO-BP BP)))
	 (WRITE-USER-OPTIONS *ZMAIL-USER-OPTION-ALIST* STREAM)
	 (WRITE-USER-OPTIONS *ZMAIL-HARDCOPY-OPTION-ALIST* STREAM)
	 (FUNCALL STREAM ':TYO #\CR)
	 (MUST-REDISPLAY *WINDOW* DIS-TEXT)
	 (SETQ *EDITOR-VARIABLE-TICK* (TICK)))))

(DEFMETHOD (ZMAIL-PROFILE-EDITOR :VARIABLE-TICK) ()
  (SETQ *VARIABLE-TICK* (TICK)))

(DEFFLAVOR ZMAIL-CHOOSE-VARIABLE-VALUES-PANE
	() 
	TV:(CHOOSE-VARIABLE-VALUES-PANE-MIXIN BASIC-CHOOSE-VARIABLE-VALUES
	    BORDERS-MIXIN TOP-BOX-LABEL-MIXIN SCROLL-STUFF-ON-OFF-MIXIN ANY-TYI-MIXIN WINDOW))

(DEFFLAVOR ZMAIL-PROFILE-FRAME
	()
	(TV:ANY-TYI-MIXIN TV:STREAM-MIXIN TV:BORDERS-MIXIN
	 TV:PANE-MIXIN TV:ITEM-LIST-PANE-KLUDGE TV:FRAME-WITH-XOR-BUTTONS
	 TV:CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER TV:MINIMUM-WINDOW))

(DEFMETHOD (ZMAIL-PROFILE-FRAME :BEFORE :INIT) (IGNORE)
  (SETQ TV:PANES `((FILTERS-BUTTON TV:BUTTON-PANE :NAME "Filters" :DOCUMENTATION 
  "L: Menu of filters saved in init file;  M: Filter associations;  R: menu.")
		   (UNIVERSES-BUTTON TV:BUTTON-PANE :NAME "Universes" :DOCUMENTATION
  "L: Menu of universes saved in init file;  M: Universe-Filter associations;  R: menu.")
		   (MAIL-FILES-BUTTON TV:BUTTON-PANE :NAME "Mail files" :DOCUMENTATION
 "L: Menu of non-primary disk mail files saved in init file;  M: Move associations;  R: menu."
		    )
		   (KEYWORDS-BUTTON TV:BUTTON-PANE :NAME "Keywords" :DOCUMENTATION
  "L: Edit mail file-keyword associations;  M: Keywords-Filter associations;  R: menu.")
		   (HARDCOPY-BUTTON TV:BUTTON-PANE :NAME "Hardcopy" :DOCUMENTATION
  "Give choose variable values window for hardcopy user options.")
		   (FILE-OPTIONS-BUTTON TV:BUTTON-PANE :NAME "File options" :DOCUMENTATION
  "Give menu for mail file and alter the attributes of that mail file.")
		   (CHOOSE-WINDOW ZMAIL-CHOOSE-VARIABLE-VALUES-PANE
				  :STACK-GROUP ,SYS:%CURRENT-STACK-GROUP
				  :LABEL "User options:")
		   (DONE-BUTTON TV:BUTTON-PANE :NAME "Exit" :DOCUMENTATION
				"Return to main command level.")
		   (RESET-BUTTON TV:BUTTON-PANE :NAME "Reset" :DOCUMENTATION
				 "Set all options back to values in init file.")
		   (DEFAULTS-BUTTON TV:BUTTON-PANE :NAME "Defaults" :DOCUMENTATION
				    "Set all options back to normal system default values.")
		   (SAVE-BUTTON TV:BUTTON-PANE :NAME "Save"
		    :DOCUMENTATION "L: Save file;  M: Make init file compiled;  R: menu.")
		   (EDIT-BUTTON TV:BUTTON-PANE :NAME "Edit" :DOCUMENTATION
				"Edit init file buffer."))

	TV:CONSTRAINTS
	  `((ONLY . ( (WHOLE-THING)
		     ((WHOLE-THING :HORIZONTAL (:EVEN)
		       (WHOLE)
		       ((WHOLE TV:WHITE-INCLUDE-WHITESPACE	;Vert
			 (1.0) (:EVEN)
			 (EXTENDED CHOOSE CONTROLS)
			 ((EXTENDED TV:FLOATING-BUTTONS
			   (FILTERS-BUTTON UNIVERSES-BUTTON MAIL-FILES-BUTTON
			    FILE-OPTIONS-BUTTON KEYWORDS-BUTTON HARDCOPY-BUTTON)))
			 ((CONTROLS TV:FLOATING-BUTTONS
			   (DONE-BUTTON RESET-BUTTON DEFAULTS-BUTTON SAVE-BUTTON
			    EDIT-BUTTON)))
			 ((CHOOSE TV:WHITE-INCLUDE-WHITESPACE	;Horiz
			   (0.8 :LINES CHOOSE-WINDOW) (:EVEN)
			   (CHOOSE-WINDOW)
			   ((CHOOSE-WINDOW :ASK :PANE-SIZE)))))))))))))

(DEFMETHOD (ZMAIL-PROFILE-FRAME :AFTER :INIT) (IGNORE)
  (ADD-INITIALIZATION "Reset zmail displayed user options"
		      `(FUNCALL ',(FUNCALL-SELF ':GET-PANE 'CHOOSE-WINDOW) ':SET-VARIABLES
				(TV:PRUNE-USER-OPTION-ALIST *ZMAIL-USER-OPTION-ALIST*))
		      '(SITE)))

(DEFMETHOD (ZMAIL-PROFILE-FRAME :INITIALIZE) ()
  (FUNCALL-SELF ':SEND-PANE 'CHOOSE-WINDOW ':SET-STACK-GROUP SYS:%CURRENT-STACK-GROUP)
  (FUNCALL-SELF ':TURN-OFF-ACCENTS))

(DEFUN PROFILE-FILTERS-OR-UNIVERSES (SYMBOL-LIST NEAR-MODE LABEL
				     NEW-FUNCTION DEFINITION-FUNCTION
				     &AUX ACTIVE-LIST TEM)
  (DOLIST (SYM SYMBOL-LIST)
    (SETQ SYM (TV:MENU-EXECUTE-NO-SIDE-EFFECTS SYM))
    (AND (ASSQ *INTERVAL* (GET SYM 'ZMACS-BUFFERS))
	 (PUSH SYM ACTIVE-LIST)))
  (MULTIPLE-VALUE (SYMBOL-LIST ACTIVE-LIST)
    (ZMAIL-MULTIPLE-MENU-CHOOSE SYMBOL-LIST (NREVERSE ACTIVE-LIST) NEW-FUNCTION
				NEAR-MODE LABEL))
  (DOLIST (SYM SYMBOL-LIST)			;Delete sections that aren't wanted
    (SETQ SYM (TV:MENU-EXECUTE-NO-SIDE-EFFECTS SYM))
    (AND (SETQ TEM (ASSQ *INTERVAL* (GET SYM 'ZMACS-BUFFERS)))
	 (IF (MEMQ SYM ACTIVE-LIST)
	     (SETQ ACTIVE-LIST (DELQ SYM ACTIVE-LIST))
	     (DELETE-INTERVAL (DEFUN-INTERVAL (CREATE-BP (CDR TEM) 0) 1 T T T)))))
  (AND ACTIVE-LIST
       (LET ((BP (INTERVAL-LAST-BP *INTERVAL*)))
	 (DOLIST (SYM ACTIVE-LIST)			;New ones to add
	   (INSERT BP #\CR)
	   (GRIND-INTO-BP BP (FUNCALL DEFINITION-FUNCTION SYM))
	   (INSERT BP #\CR))
	 (MOVE-BP (WINDOW-POINT *WINDOW*) BP)))
  (MUST-REDISPLAY *WINDOW* DIS-TEXT)
  (SECTIONIZE-BUFFER *INTERVAL*))

(DEFUN PROFILE-NEW-FILTER (WINDOW &OPTIONAL IGNORE IGNORE &AUX FILTER)
  (FUNCALL WINDOW ':DEACTIVATE)
  (SETQ FILTER (DEFINE-NEW-FILTER))
  (ASSQ FILTER *USER-FILTER-ALIST*))		;Return a menu item

(DEFUN PROFILE-NEW-UNIVERSE (WINDOW &OPTIONAL IGNORE IGNORE &AUX UNIVERSE)
  (FUNCALL WINDOW ':DEACTIVATE)
  (MULTIPLE-VALUE (NIL NIL NIL UNIVERSE)
    (DEFINE-NEW-UNIVERSE))
  (FUNCALL *ZMAIL-WINDOW* ':SELECT NIL)
  UNIVERSE)

(DEFUN MAKE-MAIL-FILE-OF-RECENT-MSGS (&AUX MAIL-FILE NEW-ARRAY ARRAY)
  (SETQ MAIL-FILE (MAKE-MAIL-FILE 'TEMP-MAIL-FILE ':NAME "Recent")
	NEW-ARRAY (MAIL-FILE-ARRAY MAIL-FILE)
	ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*))
  (DO ((I 0 (1+ I))
       (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
       (MSG))
      (( I NMSGS))
    (SETQ MSG (AREF ARRAY I))
    (IF (GET (LOCF (MSG-STATUS MSG)) 'RECENT)	;Cannot be recent if not parsed
	(ARRAY-PUSH-EXTEND NEW-ARRAY MSG)
	(RETURN T)))				;Can stop when find first non-recent
  MAIL-FILE)

;;; This probably goes in format someplace eventually
(DEFPROP FORMAT: FORMAT-CTL-UPCASE FORMAT:FORMAT-CTL-ONE-ARG)
(ASET 'FORMAT: FORMAT:FORMAT-CHAR-TABLE #/)

(LOCAL-DECLARE ((SPECIAL *DOWNCASE-FLAG* *ONCE-ONLY-FLAG* *OLD-STREAM*))
(DEFUN FORMAT-CTL-UPCASE (THING IGNORE)
  (LET ((*DOWNCASE-FLAG* FORMAT:ATSIGN-FLAG)
	(*ONCE-ONLY-FLAG* FORMAT:COLON-FLAG)
	(*OLD-STREAM* STANDARD-OUTPUT))
    (PRINC THING 'UPCASE-STREAM)))

(DEFPROP UPCASE-STREAM T SI:IO-STREAM-P)
(DEFUN UPCASE-STREAM (OP &OPTIONAL ARG1 &REST REST)
  (SELECTQ OP
    (:WHICH-OPERATIONS
     '(:TYO))
    (:TYO
     (IF *DOWNCASE-FLAG*
	 (AND ( ARG1 #/A) ( ARG1 #/Z)
	      (SETQ ARG1 (+ ARG1 40)))
	 (AND ( ARG1 #/a) ( ARG1 #/z)
	      (SETQ ARG1 (- ARG1 40))))
     (AND *ONCE-ONLY-FLAG* (SETQ *ONCE-ONLY-FLAG* NIL
				 *DOWNCASE-FLAG* (NOT *DOWNCASE-FLAG*)))
     (FUNCALL *OLD-STREAM* ':TYO ARG1))
    (OTHERWISE
     (STREAM-DEFAULT-HANDLER 'UPCASE-STREAM OP ARG1 REST))))
);LOCAL-DECLARE

;;; Quick processing of a set of messages
(DEFUN PROCESS-FILTER (FILTER &REST OPTIONS &AUX NAME NAME-BEFORE NAME-AFTER)
  (MULTIPLE-VALUE (FILTER NAME NAME-BEFORE NAME-AFTER)
    (PARSE-FILTER-SPEC FILTER))
  (USING-OVERLYING-WINDOW
    (LEXPR-FUNCALL #'PROCESS-FILTER-1 FILTER NAME NAME-BEFORE NAME-AFTER OPTIONS))
  (ZMAIL-SELECT-MSG *MSG* NIL NIL))

(DEFUN PARSE-FILTER-SPEC (FILTER &AUX NAME NAME-BEFORE NAME-AFTER)
  (DECLARE (RETURN-LIST FILTER NAME NAME-BEFORE NAME-AFTER))
  (IF (ATOM FILTER)
      (SETQ NAME FILTER NAME-AFTER NAME)
      (SETQ NAME (CADR FILTER) FILTER (CAR FILTER))
      (IF (ATOM NAME)
	  (SETQ NAME-AFTER NAME)
	  (SETQ NAME-BEFORE (CAR NAME) NAME-AFTER (CADR NAME)
		NAME (OR NAME-BEFORE NAME-AFTER))))
  (VALUES FILTER NAME NAME-BEFORE NAME-AFTER))

(DEFUN PROCESS-FILTER-1 (FILTER NAME NAME-BEFORE NAME-AFTER
				&REST OPTIONS
				&AUX (MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
				     (MAP-ARG *MAIL-FILE*) (LAST-P T)
				     (FILTER-ARG NIL) (COUNT-P ':ENGLISH) (SURVEY-P T)
				     (TYPE-P ':ASK) (DELETE-P NIL) (KEYWORDS NIL) (SAVE-P NIL)
				     (MARKING-FUNCTION NIL) (NOT-IF-MARKED-P NIL)
				     MAIL-FILE ARRAY NMSGS N-ALREADY-MARKED PRONOUN)
  (TV:DOPLIST (OPTIONS VAL KEY)
    (SELECTQ KEY
      (:MAP-FUNCTION
       (SETQ MAP-FUNCTION VAL))
      (:MAP-ARG
       (SETQ MAP-ARG VAL))
      (:FILTER-ARG
       (SETQ FILTER-ARG VAL))
      (:COUNT-P
       (SETQ COUNT-P VAL))
      (:SURVEY-P
       (SETQ SURVEY-P VAL))
      (:TYPE-P
       (SETQ TYPE-P VAL))
      (:DELETE-P
       (SETQ DELETE-P VAL))
      (:SAVE-P
       (SETQ SAVE-P VAL))
      (:KEYWORDS
       (SETQ KEYWORDS VAL))
      (:MARKING-FUNCTION
       (SETQ MARKING-FUNCTION VAL))
      (:NOT-IF-MARKED-P
       (SETQ NOT-IF-MARKED-P VAL))
      (:LAST-P
       (SETQ LAST-P VAL))
      (OTHERWISE
       (FERROR NIL "Unknown keyword: ~S" KEY))))
  (SETQ MAIL-FILE (MAKE-MAIL-FILE 'TEMP-MAIL-FILE ':NAME NAME))
  (MAKE-MAIL-FILE-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER FILTER-ARG MAIL-FILE)
  (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)
	NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)
	N-ALREADY-MARKED 0)
  (AND MARKING-FUNCTION
       (DO ((I 0 (1+ I))
	    (MSG))
	   (( I NMSGS))
	 (SETQ MSG (AREF ARRAY I))
	 (COND ((AND (NOT (FUNCALL MARKING-FUNCTION MSG))
		     NOT-IF-MARKED-P)		;Already done once
		(REMOVE-MSG MAIL-FILE MSG I)
		(SETQ N-ALREADY-MARKED (1+ N-ALREADY-MARKED)
		      NMSGS (1- NMSGS)
		      I (1- I))))))
  (AND COUNT-P
       (LET ((BASE (IF (EQ COUNT-P T) 10. COUNT-P)))
	 (FORMAT T "~&~: ~@[~A ~]message~P~@[ ~A~]~
		    ~:[ (not counting ~A message~:P already done)~].~%"
		 NMSGS NAME-BEFORE NMSGS NAME-AFTER
		 (ZEROP N-ALREADY-MARKED) N-ALREADY-MARKED)))
  (COND ((NOT (ZEROP NMSGS))
	 (SETQ PRONOUN (IF (= NMSGS 1) "it" "them"))
	 (COND ((OR (EQ SURVEY-P T)
		    (AND (EQ SURVEY-P ':ASK)
			 (SETQ SURVEY-P (FQUERY NIL "Survey ~A? " PRONOUN))))
		(FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
		(DO ((I 0 (1+ I))
		     (MSG) (STATUS))
		    (( I NMSGS))
		  (SETQ MSG (AREF ARRAY I)
			STATUS (ASSURE-MSG-PARSED MSG))
		  (FUNCALL STANDARD-OUTPUT ':TRUNCATED-FORMAT
			   " ~3D~C~A" (1+ I) (STATUS-LETTER STATUS) (MSG-SUMMARY-LINE MSG))
		  (FUNCALL STANDARD-OUTPUT ':TYO #\CR))))
	 (AND (OR (EQ TYPE-P T)
		  (AND (EQ TYPE-P ':ASK)
		       (SETQ TYPE-P (FQUERY NIL "Type ~A? " PRONOUN))))
	      (LET ((STREAM (MAKE-MAIL-FILE-STREAM MAIL-FILE)))
		(FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
		(FUNCALL STANDARD-OUTPUT ':VIEW-STREAM STREAM T)
		(FUNCALL STANDARD-OUTPUT ':MOVE-TO-END)
		(DO ((I 0 (1+ I))
		     (LIM (FUNCALL STREAM ':CURRENT-MSG-NO)))
		    (( I LIM))
		  (MSG-PUT (AREF ARRAY I) NIL 'UNSEEN))))
	 (AND (OR (EQ DELETE-P T)
		  (AND (EQ DELETE-P ':ASK)
		       (SETQ DELETE-P (FQUERY NIL "Delete ~A? " PRONOUN))))
	      (DO I 0 (1+ I) ( I NMSGS)
		(MSG-PUT (AREF ARRAY I) T 'DELETED)))
	 (COND ((NOT DELETE-P)
		(AND KEYWORDS
		     (DO ((KEYS KEYWORDS (CDDR KEYS))
			  (KEY-P) (KEYWORDS))
			 ((NULL KEYS))
		       (SETQ KEY-P (CAR KEYS)
			     KEYWORDS (CADR KEYS))
		       (COND ((EQ KEY-P ':ASK)
			      (FORMAT T "~&Add keyword~P" (LENGTH KEYWORDS))
			      (DOLIST (KEY KEYWORDS)
				(FUNCALL STANDARD-OUTPUT ':TYO #\SP)
				(FUNCALL STANDARD-OUTPUT ':STRING-OUT
					 (OR (CAR (RASSQ KEY *KEYWORD-ALIST*))
					     (STRING KEY))))
			      (FUNCALL STANDARD-OUTPUT ':STRING-OUT "? ")
			      (SETQ KEY-P (Y-OR-N-P))))
		       (AND KEY-P
			    (DOMSGS (MSG MAIL-FILE)
				    (LET* ((OLD-KEYWORDS (MSG-GET MSG 'KEYWORDS))
					   (NEW-KEYWORDS (DO ((L KEYWORDS (CDR L))
							      (NL (REVERSE OLD-KEYWORDS)))
							     ((NULL L) (NREVERSE NL))
							   (OR (MEMQ (CAR L) NL)
							       (PUSH (CAR L) NL)))))
				      (CHANGE-MSG-KEYWORDS MSG NEW-KEYWORDS OLD-KEYWORDS))))))
		(AND (OR (EQ SAVE-P T)
			 (AND (EQ SAVE-P ':ASK)
			      (SETQ SAVE-P (FQUERY NIL "Save ~A? " PRONOUN))))
		     (SETQ *MAIL-FILE-LIST* (NCONC *MAIL-FILE-LIST* (NCONS MAIL-FILE))))))))
  (COND (LAST-P
	 (FORMAT T "~&Type any character to flush:")
	 (FUNCALL STANDARD-INPUT ':TYI))))

(DEFUN PROCESS-FILTER-ALIST (MAIL-FILE ALIST &OPTIONAL MENU-P)
  (USING-OVERLYING-WINDOW
    (PROCESS-FILTER-ALIST-1 MAIL-FILE ALIST MENU-P))
  (ZMAIL-SELECT-MSG *MSG* NIL NIL))

(DEFUN PROCESS-FILTER-ALIST-1 (MAIL-FILE ALIST &OPTIONAL MENU-P &AUX LIST MARK-P)
  (DOMSGS (MSG MAIL-FILE)
    (MSG-PUT MSG NIL 'PROCESSED))
  (IF MENU-P
      (DO ((AL ALIST (CDR AL))
	   (L NIL)
	   (FILTER) (NAME) (ITEM))
	  ((NULL AL) (SETQ LIST (NREVERSE L)))
	(SETQ FILTER (CAR AL))
	(SETQ NAME (IF (ATOM (CAR FILTER)) (STRING (CAR FILTER)) (CADR FILTER)))
	(AND (LISTP NAME) (SETQ NAME (CAR NAME)))
	(SETQ ITEM `(,NAME :VALUE ,FILTER))
	(AND (EQ (IF (ATOM (CAR FILTER)) (CAR FILTER) (CAAR FILTER)) 'NOT-PROCESSED)
	     (SETQ MARK-P T
		   ITEM (NCONC ITEM '((:FONT FONTS:HL12I)))))
	(PUSH ITEM L))
      (SETQ LIST ALIST)
      (DO ((AL ALIST (CDR AL))
	   (FILTER))
	  ((NULL AL))
	(SETQ FILTER (CAAR AL))
	(AND (EQ (IF (ATOM FILTER) FILTER (CAR FILTER)) 'NOT-PROCESSED)
	     (SETQ MARK-P T))))
  (AND MARK-P (SETQ MARK-P 'MARK-MSG-AS-PROCESSED))
  (DO ((ITEM) (FILTER) (NAME) (NAME-BEFORE) (NAME-AFTER) (FILTER-ARG))
      (NIL)
    (SETQ ITEM (IF MENU-P (TV:MENU-CHOOSE LIST) (POP LIST)))
    (AND (NULL ITEM) (RETURN T))
    (MULTIPLE-VALUE (FILTER NAME NAME-BEFORE NAME-AFTER)
      (PARSE-FILTER-SPEC (CAR ITEM)))
    (AND (EQ FILTER 'NOT-PROCESSED)
	 (SETQ FILTER 'MSG-DOES-NOT-HAVE-ATTRIBUTE-P
	       FILTER-ARG 'PROCESSED))
    (LEXPR-FUNCALL #'PROCESS-FILTER-1 FILTER NAME NAME-BEFORE NAME-AFTER
		   ':FILTER-ARG FILTER-ARG ':MAP-ARG MAIL-FILE
		   ':MARKING-FUNCTION MARK-P ':LAST-P (NULL LIST)
		   (CDR ITEM))
    (FORMAT T "~2&")))

;;; Return T if processed for the first time
(DEFUN MARK-MSG-AS-PROCESSED (MSG &AUX (STATUS (ASSURE-MSG-PARSED MSG)))
  (AND (NOT (GET STATUS 'PROCESSED))
       (PUTPROP STATUS T 'PROCESSED)))

(DEFFLAVOR BASIC-STANDALONE-EDITOR-FRAME
	((*COMTAB* *STANDALONE-COMTAB*)
	 *MODE-LINE-LIST*)
	()
  (:INCLUDED-FLAVORS ZWEI-FRAME TOP-LEVEL-EDITOR)
  (:SETTABLE-INSTANCE-VARIABLES *MODE-LINE-LIST*)
  (:DEFAULT-INIT-PLIST :NUMBER-OF-MINI-BUFFER-LINES 1))

(DEFFLAVOR STANDALONE-EDITOR-FRAME ()
	   (TOP-LEVEL-EDITOR BASIC-STANDALONE-EDITOR-FRAME))

(DEFFLAVOR POP-UP-STANDALONE-EDITOR-FRAME ()
	   (TV:TEMPORARY-WINDOW-MIXIN TV:BORDERS-MIXIN STANDALONE-EDITOR-FRAME
	    TV:ESSENTIAL-MOUSE)
  (:DEFAULT-INIT-PLIST :BORDER-MARGIN-WIDTH 0))

(DEFMETHOD (BASIC-STANDALONE-EDITOR-FRAME :INTERVAL-STRING) PASS-ON-TO-SELECTED-PANE)
(DEFMETHOD (BASIC-STANDALONE-EDITOR-FRAME :SET-INTERVAL-STRING) PASS-ON-TO-SELECTED-PANE)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-STANDALONE-EDITOR-FRAME)
(DEFUN PASS-ON-TO-SELECTED-PANE (&REST ARGS)
  (APPLY TV:SELECTED-PANE ARGS)))

(DEFMETHOD (BASIC-STANDALONE-EDITOR-FRAME :AFTER :INIT) (IGNORE)
  (SETQ *WINDOW* (FUNCALL-SELF ':CREATE-WINDOW 'STANDALONE-ZWEI-WINDOW-PANE
			       ':ACTIVATE-P T ':LABEL NIL)
	TV:SELECTED-PANE (WINDOW-SHEET *WINDOW*))
  (SET-WINDOW-INTERVAL *WINDOW* (CREATE-INTERVAL)))

(DEFMETHOD (STANDALONE-EDITOR-FRAME :AFTER :INIT) (IGNORE)
  (SET-COMTAB *MODE-COMTAB* '(#\ABORT COM-STANDALONE-ABORT)))

(DEFCOM COM-STANDALONE-ABORT "Abort this editing" ()
  (*THROW 'ABORT-STANDALONE-EDIT NIL))

(DEFFLAVOR STANDALONE-ZWEI-WINDOW-PANE () (ZWEI-WINDOW-PANE))

(DEFMETHOD (STANDALONE-ZWEI-WINDOW-PANE :SIZE-DELTAS-FOR-STRING) (STRING)
  (VALUES (- TV:WIDTH (+ (TV:DECODE-CHARACTER-WIDTH-SPEC STRING) TV:CHAR-WIDTH))
	  (- TV:HEIGHT (TV:DECODE-CHARACTER-HEIGHT-SPEC STRING))))

(DEFMETHOD (BASIC-STANDALONE-EDITOR-FRAME :SET-SIZE-FROM-STRING)
	   (STRING &OPTIONAL MIN-WIDTH MIN-HEIGHT MAX-WIDTH MAX-HEIGHT
		   &AUX DWT DHT MODE-LINE-HEIGHT)
  (MULTIPLE-VALUE (DWT DHT)
    (FUNCALL TV:SUPERIOR ':INSIDE-SIZE))
  (SETQ MAX-WIDTH (OR MAX-WIDTH DWT)
	MAX-HEIGHT (OR MAX-HEIGHT DHT))
  (MULTIPLE-VALUE (DWT DHT)
    (FUNCALL TV:SELECTED-PANE ':SIZE-DELTAS-FOR-STRING STRING))
  (SETQ DWT (- TV:WIDTH DWT)
	DHT (- TV:HEIGHT DHT))
  (AND MIN-WIDTH (SETQ DWT (MAX MIN-WIDTH DWT)))
  (AND MIN-HEIGHT (SETQ DHT (MAX MIN-HEIGHT DHT)))
  (MULTIPLE-VALUE (NIL MODE-LINE-HEIGHT)
    (FUNCALL *MODE-LINE-WINDOW* ':SIZE))
  (SETQ DHT (+ DHT MODE-LINE-HEIGHT))
  (SETQ DWT (MIN DWT MAX-WIDTH)
	DHT (MIN DHT MAX-HEIGHT))
  (FUNCALL-SELF ':SET-SIZE DWT DHT)
  (FUNCALL TV:SELECTED-PANE ':SET-SIZE (- DWT TV:LEFT-MARGIN-SIZE TV:RIGHT-MARGIN-SIZE)
	   (- DHT TV:BOTTOM-MARGIN-SIZE TV:TOP-MARGIN-SIZE MODE-LINE-HEIGHT)))

(DEFMETHOD (BASIC-STANDALONE-EDITOR-FRAME :TYPEIN-LINE) (STRING &REST ARGS)
  (LEXPR-FUNCALL #'TYPEIN-LINE STRING ARGS))

(DEFUN POP-UP-EDSTRING (STRING &OPTIONAL (NEAR-MODE '(:MOUSE)) MODE-LINE-LIST
					 MIN-WIDTH MIN-HEIGHT INITIAL-MESSAGE)
  (USING-RESOURCE (WINDOW POP-UP-STANDALONE-EDITOR-FRAME)
    (FUNCALL WINDOW ':SET-SIZE-FROM-STRING STRING MIN-WIDTH MIN-HEIGHT)
    (FUNCALL WINDOW ':SET-INTERVAL-STRING STRING)
    (AND MODE-LINE-LIST (FUNCALL WINDOW ':SET-*MODE-LINE-LIST* MODE-LINE-LIST))
    (TV:EXPOSE-WINDOW-NEAR WINDOW NEAR-MODE)
    (AND INITIAL-MESSAGE (FUNCALL WINDOW ':TYPEIN-LINE INITIAL-MESSAGE))
    (TV:WINDOW-CALL (WINDOW :DEACTIVATE)
      (*CATCH 'ABORT-STANDALONE-EDIT
	(FUNCALL WINDOW ':EDIT)
	(FUNCALL WINDOW ':INTERVAL-STRING)))))

(DEFUN EDIT-MAIL-FILES-KEYWORDS (NEAR-MODE &AUX STRING)
  (DOLIST (MAIL-FILE *MAIL-FILE-LIST*)
    (AND (TYPEP MAIL-FILE 'BABYL-MAIL-FILE)		;Only kind that can store these
	 (LET ((OPTIONS (LOCF (MAIL-FILE-OPTIONS MAIL-FILE))))
	   (FUNCALL MAIL-FILE ':UPDATE-OPTIONS-IN-FILE)	;Make sure string correct
	   (OR STRING (SETQ STRING (MAKE-EMPTY-STRING 100.)))
	   (APPEND-TO-ARRAY STRING (MAIL-FILE-NAME MAIL-FILE))
	   (APPEND-TO-ARRAY STRING "::")
	   (APPEND-TO-ARRAY STRING (OR (GET OPTIONS ':KEYWORDS-STRING) ""))
	   (ARRAY-PUSH-EXTEND STRING #\CR))))
  (OR STRING (BARF "No mail files able to remember keywords"))
  (AND (SETQ STRING (POP-UP-EDSTRING STRING NEAR-MODE
				     `("ZMail " "Keywords"
				       ,(FORMAT NIL "     ~:@C ends, ~:@C aborts"
						#\END #\ABORT))
				     600 100
				     "Format is Mail file::key1,key2,..."))
       (DO ((I 0 (1+ I))
	    (J) (MAIL-FILE) (OPTIONS))
	   (NIL)
	 (OR (SETQ I (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* STRING I))
	     (RETURN NIL))
	 (OR (SETQ J (STRING-SEARCH "::" STRING I))
	     (BARF "Returned string in bad format, no colons found"))
	 (SETQ MAIL-FILE (SUBSTRING STRING I J))
	 (SETQ MAIL-FILE (OR (GET-MAIL-FILE-FROM-NAME MAIL-FILE)
			     (BARF "No mail file named ~A" MAIL-FILE)))
	 (SETQ OPTIONS (LOCF (MAIL-FILE-OPTIONS MAIL-FILE)))
	 (SETQ J (+ J 2)
	       I (STRING-SEARCH-CHAR #\CR STRING J))
	 (LOOP FOR (PROPNAME PROPVAL) ON (PARSE-KEYWORDS-LIST NIL STRING J I) BY 'CDDR
	       DO (PUTPROP OPTIONS PROPVAL PROPNAME))    
	 (OR I (RETURN NIL)))))

(DEFVAR *PROFILE-SAVE-MENU-ALIST*
  '(("Save file" :VALUE :SAVE
     :DOCUMENTATION "Save out the init file, changed variables are NOT inserted first.")
    ("Make init compiled" :VALUE :COMPILE-INIT
     :DOCUMENTATION "Make init file be compiled.  This will speed up its loading somewhat.")
    ("Insert changes" :VALUE :INSERT-CHANGED
     :DOCUMENTATION "Insert the changed variables, file is NOT saved.")
    ("Reap file" :VALUE :REAP
     :DOCUMENTATION "Offer to delete old versions of init file.")
    ("Recompile file" :VALUE :RECOMPILE
     :DOCUMENTATION "Recompile init file.")))

(DEFUN PROFILE-SAVE-BUTTON (NEAR-MODE &AUX MODE)
  (SETQ MODE (SELECTQ *ZMAIL-COMMAND-BUTTON*
	       ((:LEFT :KBD) ':SAVE-ALL)
	       (:MIDDLE ':COMPILE-INIT)
	       (:RIGHT
		(TV:MENU-CHOOSE *PROFILE-SAVE-MENU-ALIST* NIL NEAR-MODE))))
  (SELECTQ MODE
    (:SAVE
     (COM-SAVE-FILE))
    (:COMPILE-INIT
     (MAKE-INIT-FILE-BE-COMPILED))
    (:INSERT-CHANGED
     (INSERT-CHANGED-VARIABLES T))
    (:REAP
     (REAP-FILE (FUNCALL (ZMAIL-INIT-FILE-PATHNAME) ':NEW-PATHNAME ':VERSION ':WILD))
     (AND *PROFILE-QFASL-GENERIC-PATHNAME*
	  (REAP-FILE (FUNCALL *PROFILE-SOURCE-PATHNAME* ':NEW-PATHNAME ':VERSION ':WILD))))
    (:RECOMPILE
     (COMPILE-ZMAIL-INIT-FILE))     
    (:SAVE-ALL
     (INSERT-CHANGED-VARIABLES ':ASK)
     (COM-SAVE-FILE)
     (MAYBE-COMPILE-ZMAIL-INIT-FILE))))

(DEFUN PROFILE-MAIL-FILES-BUTTON (NEAR-MODE &AUX MODE)
  (SETQ MODE (SELECTQ *ZMAIL-COMMAND-BUTTON*
	       ((:LEFT :KBD) ':OTHER-MAIL-FILES)
	       (:MIDDLE ':FILTER-ASSOCIATIONS)
	       (:RIGHT
		(TV:MENU-CHOOSE '(("Other mail files" :VALUE :OTHER-MAIL-FILES :DOCUMENTATION
 "Give a menu of non-primary disk mail files to be remembered in init file.")
				  ("Filter associations" :VALUE :FILTER-ASSOCIATIONS
				   :DOCUMENTATION "Associate a mail file with filters."))
				NIL NEAR-MODE))))
  (SELECTQ MODE
    (:OTHER-MAIL-FILES (EDIT-OTHER-MAIL-FILES NEAR-MODE))
    (:FILTER-ASSOCIATIONS (GET-MAIL-FILE-FILTER-ASSOCIATIONS NEAR-MODE))))

(DEFUN EDIT-OTHER-MAIL-FILES (NEAR-MODE)
  (LET ((MAIL-FILE-ALIST (GET-MAIL-FILE-ALISTS))
	(ACTIVE-LIST NIL)
	TEM)
    (SETQ MAIL-FILE-ALIST (DELQ (RASSQ *PRIMARY-MAIL-FILE* MAIL-FILE-ALIST)
				MAIL-FILE-ALIST))
    (DOLIST (FILE-NAME *OTHER-MAIL-FILE-NAMES*)
      (IF (SETQ TEM (ASSOC FILE-NAME MAIL-FILE-ALIST))
	  (PUSH (CDR TEM) ACTIVE-LIST)
	  (PUSH FILE-NAME ACTIVE-LIST)
	  (SETQ MAIL-FILE-ALIST (NCONC MAIL-FILE-ALIST (NCONS (CONS FILE-NAME FILE-NAME))))))
    (MULTIPLE-VALUE (MAIL-FILE-ALIST ACTIVE-LIST)
      (ZMAIL-MULTIPLE-MENU-CHOOSE MAIL-FILE-ALIST (NREVERSE ACTIVE-LIST)
				  'MULTIPLE-MENU-NEW-PATHNAME NEAR-MODE
				  "Disk mail files to be remembered in init file"))
    (SETQ ACTIVE-LIST (LOOP FOR X IN MAIL-FILE-ALIST
			    WHEN (MEMQ (CDR X) ACTIVE-LIST)
			    COLLECT (CAR X)))
    (COND ((NOT (EQUAL ACTIVE-LIST *OTHER-MAIL-FILE-NAMES*))
	   (SETQ *OTHER-MAIL-FILE-NAMES* ACTIVE-LIST)
	   (SETQ *VARIABLE-TICK* (TICK))))))

(DEFUN PROFILE-KEYWORDS-BUTTON (NEAR-MODE &AUX MODE)
  (SETQ MODE (SELECTQ *ZMAIL-COMMAND-BUTTON*
	       ((:LEFT :KBD) ':EDIT-KEYWORDS)
	       (:MIDDLE ':FILTER-ASSOCIATIONS)
	       (:RIGHT
		(TV:MENU-CHOOSE '(("Mail files keywords" :VALUE :EDIT-KEYWORDS
				   :DOCUMENTATION
				   "Edit the keywords associated with a mail file.")
				  ("Filter associations" :VALUE :FILTER-ASSOCIATIONS
				   :DOCUMENTATION "Associate a keyword with filters."))
				NIL NEAR-MODE))))
  (SELECTQ MODE
    (:EDIT-KEYWORDS (EDIT-MAIL-FILES-KEYWORDS NEAR-MODE))
    (:FILTER-ASSOCIATIONS (GET-KEYWORD-FILTER-ASSOCIATIONS NEAR-MODE))))

(DEFUN PROFILE-FILTERS-BUTTON (NEAR-MODE &AUX MODE)
  (SETQ MODE (SELECTQ *ZMAIL-COMMAND-BUTTON*
	       ((:LEFT :KBD) ':EDIT-FILTERS)
	       (:MIDDLE ':FILTER-ASSOCIATIONS)
	       (:RIGHT
		(TV:MENU-CHOOSE '(("Edit filter list" :VALUE :EDIT-FILTERS :DOCUMENTATION
				   "Give a menu of filters to be remembered in init file.")
				  ("Filter associations" :VALUE :FILTER-ASSOCIATIONS
				   :DOCUMENTATION
  "Associate a filter with keywords, move mail files, or universes."))
				NIL NEAR-MODE))))
  (SELECTQ MODE
    (:EDIT-FILTERS
      (PROFILE-FILTERS-OR-UNIVERSES *USER-FILTER-ALIST* NEAR-MODE
				    "Filters to be remembered in init file"
				    'PROFILE-NEW-FILTER 'GET-FILTER-DEFINITION))
    (:FILTER-ASSOCIATIONS
     (GET-FILTER-ASSOCIATIONS NEAR-MODE))))

(DEFUN PROFILE-UNIVERSES-BUTTON (NEAR-MODE &AUX MODE)
  (SETQ MODE (SELECTQ *ZMAIL-COMMAND-BUTTON*
	       ((:LEFT :KBD) ':EDIT-UNIVERSES)
	       (:MIDDLE ':FILTER-ASSOCIATIONS)
	       (:RIGHT
		(TV:MENU-CHOOSE '(("Edit universe list" :VALUE :EDIT-UNIVERSES :DOCUMENTATION
				   "Give a menu of universes to be remembered in init file.")
				  ("Filter associations" :VALUE :FILTER-ASSOCIATIONS
				   :DOCUMENTATION "Associate a universe with filters."))
				NIL NEAR-MODE))))
  (SELECTQ MODE
    (:EDIT-UNIVERSES
     (PROFILE-FILTERS-OR-UNIVERSES *UNIVERSE-LIST* NEAR-MODE
				   "Universes to be remembered in init file"
				   'PROFILE-NEW-UNIVERSE 'GET-UNIVERSE-DEFINITION))
    (:FILTER-ASSOCIATIONS
     (GET-UNIVERSE-FILTER-ASSOCIATIONS NEAR-MODE))))

(DEFUN GET-MAIL-FILE-FILTER-ASSOCIATIONS (NEAR-MODE &AUX MAIL-FILE OLD-FILTERS NEW-FILTERS)
  (SETQ MAIL-FILE (GET-MAIL-FILE-OR-NEW NEAR-MODE
					"Select a mail file whose filter associations to edit"
					))
  (SETQ OLD-FILTERS (LOOP FOR (FILTER . MF) IN *FILTER-MOVE-MAIL-FILE-ALIST*
			  WHEN (EQUAL MF MAIL-FILE)
			  COLLECT FILTER))
  (MULTIPLE-VALUE (NIL NEW-FILTERS)
    (ZMAIL-MULTIPLE-MENU-CHOOSE *USER-FILTER-ALIST* OLD-FILTERS 'PROFILE-NEW-FILTER
				NEAR-MODE
				(FORMAT NIL "Filters associated with ~A:" MAIL-FILE)))
  (COND ((NOT (EQUAL OLD-FILTERS NEW-FILTERS))
	 (DOLIST (ELEM *USER-FILTER-ALIST*)
	   (LET* ((FILTER (TV:MENU-EXECUTE-NO-SIDE-EFFECTS ELEM)))
	     (SET-MAIL-FILE-FILTER-ASSOCIATION FILTER (AND (MEMQ FILTER NEW-FILTERS)
							   MAIL-FILE)))))))

(DEFUN GET-UNIVERSE-FILTER-ASSOCIATIONS (NEAR-MODE &AUX UNIVERSE OLD-FILTERS NEW-FILTERS)
  (SETQ UNIVERSE (MENU-CHOOSE-WITH-NEW *UNIVERSE-LIST* 'PROFILE-NEW-UNIVERSE NEAR-MODE
				       "Select a universe whose filter associations to edit"))
  (SETQ OLD-FILTERS (LOOP FOR (FILTER . UV) IN *FILTER-REFERENCE-UNIVERSE-ALIST*
			  WHEN (EQUAL UV UNIVERSE)
			  COLLECT FILTER))
  (MULTIPLE-VALUE (NIL NEW-FILTERS)
    (ZMAIL-MULTIPLE-MENU-CHOOSE *USER-FILTER-ALIST* OLD-FILTERS 'PROFILE-NEW-FILTER
				NEAR-MODE
				(FORMAT NIL "Filters associated with ~A:" UNIVERSE)))
  (COND ((NOT (EQUAL OLD-FILTERS NEW-FILTERS))
	 (DOLIST (ELEM *USER-FILTER-ALIST*)
	   (LET* ((FILTER (TV:MENU-EXECUTE-NO-SIDE-EFFECTS ELEM)))
	     (SET-UNIVERSE-FILTER-ASSOCIATION FILTER (AND (MEMQ FILTER NEW-FILTERS)
							   UNIVERSE))))
	 (SETQ *VARIABLE-TICK* (TICK)))))

(DEFUN GET-KEYWORD-FILTER-ASSOCIATIONS (NEAR-MODE &AUX KEYWORD OLD-FILTERS NEW-FILTERS)
  (SETQ KEYWORD (MENU-CHOOSE-WITH-NEW *KEYWORD-ALIST* 'MULTIPLE-MENU-NEW-KEYWORD NEAR-MODE
				      "Select a keyword whose filter associations to edit"))
  (SETQ OLD-FILTERS (LOOP FOR (FILTER . KEYWORDS) IN *FILTER-KEYWORDS-ALIST*
			  WHEN (MEMQ KEYWORD KEYWORDS)
			  COLLECT FILTER))
  (MULTIPLE-VALUE (NIL NEW-FILTERS)
    (ZMAIL-MULTIPLE-MENU-CHOOSE *USER-FILTER-ALIST* OLD-FILTERS 'PROFILE-NEW-FILTER
				NEAR-MODE
				(FORMAT NIL "Filters associated with ~A:"
					(CAR (RASSQ KEYWORD *KEYWORD-ALIST*)))))
  (COND ((NOT (EQUAL OLD-FILTERS NEW-FILTERS))
	 (DOLIST (ELEM *USER-FILTER-ALIST*)
	   (LET* ((FILTER (TV:MENU-EXECUTE-NO-SIDE-EFFECTS ELEM))
		  (ITEM (ASSQ FILTER *FILTER-KEYWORDS-ALIST*)))
	     (IF (MEMQ FILTER NEW-FILTERS)
		 (IF ITEM (PUSH* KEYWORD (CDR ITEM))
		     (SETQ *FILTER-KEYWORDS-ALIST* (NCONC *FILTER-KEYWORDS-ALIST*
							  (NCONS (LIST FILTER KEYWORD)))))
		 (AND ITEM (SETF (CDR ITEM) (DELQ KEYWORD (CDR ITEM)))))))
	 (SETQ *VARIABLE-TICK* (TICK)))))

(DEFUN GET-FILTER-ASSOCIATIONS (NEAR-MODE)
  (LET ((FILTER (MENU-CHOOSE-WITH-NEW *USER-FILTER-ALIST* 'PROFILE-NEW-FILTER NEAR-MODE
				      "Select a filter whose associations to edit")))
    (SELECTQ (OR (TV:MENU-CHOOSE '(("Keywords" :VALUE :KEYWORDS :DOCUMENTATION
				    "Edit keywords associated with this filter.")
				   ("Mail files" :VALUE :MAIL-FILES :DOCUMENTATION
				    "Set mail file associated with this filter.")
				   ("Universes" :VALUE :UNIVERSES :DOCUMENTATION
				    "Set universe associated with this filter.")))
		 (ABORT-CURRENT-COMMAND))
      (:KEYWORDS
       (LET* ((ITEM (ASSQ FILTER *FILTER-KEYWORDS-ALIST*))
	      (OLD-KEYWORDS (CDR ITEM))
	      NEW-KEYWORDS)
	 (SETQ NEW-KEYWORDS (CHOOSE-KEYWORDS (FORMAT NIL "Keywords associated with ~A:"
						     FILTER)
					     OLD-KEYWORDS))
	 (COND ((NOT (EQUAL OLD-KEYWORDS NEW-KEYWORDS))
		(IF (NULL NEW-KEYWORDS)
		    (AND ITEM
			 (SETQ *FILTER-KEYWORDS-ALIST* (DELQ ITEM *FILTER-KEYWORDS-ALIST*)))
		    (IF ITEM (SETF (CDR ITEM) NEW-KEYWORDS)
			(SETQ *FILTER-KEYWORDS-ALIST*
			      (NCONC *FILTER-KEYWORDS-ALIST*
				     (NCONS (CONS FILTER NEW-KEYWORDS))))))
		(SETQ *VARIABLE-TICK* (TICK))))))
      (:MAIL-FILES
       (LET ((MAIL-FILE (GET-MAIL-FILE-OR-NEW NEAR-MODE
					      (FORMAT NIL "Mail file associated with ~A:"
						      FILTER)
					      T)))
	 (SET-MAIL-FILE-FILTER-ASSOCIATION FILTER MAIL-FILE)))
      (:UNIVERSES
       (LET ((UNIVERSE (MENU-CHOOSE-WITH-NEW (CONS '("None" :VALUE :NONE :FONTS TR12I
						      :DOCUMENTATION
						      "Remove any association.")
						    *UNIVERSE-LIST*)
					     'PROFILE-NEW-UNIVERSE NEAR-MODE
					     (FORMAT NIL "Universe associated with ~A:"
						     FILTER))))
	 (AND (EQ UNIVERSE ':NONE) (SETQ UNIVERSE NIL))
	 (SET-UNIVERSE-FILTER-ASSOCIATION FILTER UNIVERSE))))))

(DEFUN GET-MAIL-FILE-OR-NEW (NEAR-MODE LABEL &OPTIONAL NONE-OK &AUX ALIST MAIL-FILE)
  (SETQ ALIST (GET-MAIL-FILE-ALISTS T))
  (AND NONE-OK (PUSH '("None" :VALUE :NONE :FONTS TR12I
		       :DOCUMENTATION "Remove any association.")
		     ALIST))
  (SETQ MAIL-FILE (MENU-CHOOSE-WITH-NEW ALIST 'MULTIPLE-MENU-NEW-PATHNAME NEAR-MODE LABEL))
  (COND ((EQ MAIL-FILE ':NONE) (SETQ MAIL-FILE NIL))
	((STRINGP MAIL-FILE))
	((TYPEP MAIL-FILE 'MAIL-FILE) (SETQ MAIL-FILE (FUNCALL MAIL-FILE ':NAME)))
	(T (SETQ MAIL-FILE (STRING MAIL-FILE))))
  MAIL-FILE)

(DEFUN SET-MAIL-FILE-FILTER-ASSOCIATION (FILTER MAIL-FILE &AUX ITEM)
  (SETQ ITEM (ASSQ FILTER *FILTER-MOVE-MAIL-FILE-ALIST*))
  (IF MAIL-FILE
      (IF ITEM (SETF (CDR ITEM) MAIL-FILE)
	  (SETQ *FILTER-MOVE-MAIL-FILE-ALIST* (NCONC *FILTER-MOVE-MAIL-FILE-ALIST*
						     (NCONS (CONS FILTER MAIL-FILE)))))
      (AND MAIL-FILE
	   (SETQ *FILTER-MOVE-MAIL-FILE-ALIST* (DELQ ITEM *FILTER-MOVE-MAIL-FILE-ALIST*))))
  (SETQ *VARIABLE-TICK* (TICK)))

(DEFUN SET-UNIVERSE-FILTER-ASSOCIATION (FILTER UNIVERSE &AUX ITEM)
  (SETQ ITEM (ASSQ FILTER *FILTER-REFERENCE-UNIVERSE-ALIST*))
  (IF UNIVERSE
      (IF ITEM (SETF (CDR ITEM) UNIVERSE)
	  (SETQ *FILTER-REFERENCE-UNIVERSE-ALIST* (NCONC *FILTER-REFERENCE-UNIVERSE-ALIST*
							 (NCONS (CONS FILTER UNIVERSE)))))
      (AND UNIVERSE
	   (SETQ *FILTER-REFERENCE-UNIVERSE-ALIST*
		 (DELQ ITEM *FILTER-REFERENCE-UNIVERSE-ALIST*))))
  (SETQ *VARIABLE-TICK* (TICK)))