;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI -*- ;;; ZMail Commands ;;; Definitions in DEFS ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;; Set up main command table (DEFUN INITIALIZE-ZMAIL-COMTABS (MODE-COMTAB) (SET-COMTAB MODE-COMTAB '(#/F COM-FORWARD-ADDRESS #/B COM-BACKWARD-ADDRESS #/K COM-KILL-ADDRESS #\RUBOUT COM-BACKWARD-KILL-ADDRESS #/T COM-EXCHANGE-ADDRESSES)) (SETQ *ZMAIL-COMTAB* (SET-COMTAB NIL '(#/D COM-ZMAIL-DELETE-AND-UP #/G COM-BEEP #/L COM-RECENTER-WINDOW #/N COM-ZMAIL-DOWN-TO-NEXT #/P COM-ZMAIL-UP-TO-PREVIOUS #/R COM-EDIT-CURRENT-MSG #/U COM-QUADRUPLE-NUMERIC-ARG #/V COM-NEXT-SCREEN #/Z COM-QUIT #\SP COM-ZMAIL-SET-POP-MARK #/V COM-PREVIOUS-SCREEN #/X COM-ZMAIL-EXTENDED-COMMAND #/? COM-ZMAIL-SELF-DOCUMENT #/~ COM-ZMAIL-NOT-MODIFIED #/V COM-SCROLL-SUMMARY-WINDOW #\SP COM-ZMAIL-MOVE-TO-PREVIOUS-POINT #/. COM-ZMAIL-START-OF-MSG #/? COM-ZMAIL-HELP #/C COM-ZMAIL-CONTINUE #/D COM-ZMAIL-DELETE #/E COM-ZMAIL-EXPUNGE #/G COM-GET-NEW-MAIL #/J COM-ZMAIL-JUMP #/M COM-ZMAIL-MAIL #/N COM-ZMAIL-NEXT #/P COM-ZMAIL-PREVIOUS #/Q COM-ZMAIL-QUIT #/R COM-ZMAIL-REPLY #/S COM-ZMAIL-SAVE #/U COM-ZMAIL-UNDELETE #/X COM-ZMAIL-EXTENDED-COMMAND #/Z COM-ZMAIL-LARGE-ARGUMENT #\BREAK COM-ZMAIL-BREAK #\BS COM-PREVIOUS-SCREEN #\HAND-DOWN COM-NEXT-SCREEN #\HAND-UP COM-PREVIOUS-SCREEN #\HELP COM-ZMAIL-HELP #\FF COM-ZMAIL-REFRESH #\RESUME COM-ZMAIL-CONTINUE #\SP COM-NEXT-SCREEN #/- COM-NEGATE-NUMERIC-ARG #/- COM-NEGATE-NUMERIC-ARG #/- COM-NEGATE-NUMERIC-ARG #/- COM-NEGATE-NUMERIC-ARG (#/0 10.) COM-NUMBERS (#/0 10.) COM-NUMBERS (#/0 10.) COM-NUMBERS (#/0 10.) COM-NUMBERS ))) (SETQ *MSG-COMTAB* (SET-COMTAB NIL '(#\END COM-QUIT #/ COM-QUIT #\ABORT COM-QUIT))) (SET-COMTAB-INDIRECTION *MSG-COMTAB* MODE-COMTAB) (SETQ *MSG-CONTROL-X-COMTAB* (SET-COMTAB NIL '(#/A COM-ADD-MORE-TEXT #/C COM-ADD-CC-FIELD #/S COM-ADD-SUBJECT-FIELD #/T COM-ADD-TO-FIELD))) (SET-COMTAB-INDIRECTION *MSG-CONTROL-X-COMTAB* *STANDARD-CONTROL-X-COMTAB*) (SET-COMTAB MODE-COMTAB (LIST #/X (MAKE-EXTENDED-COMMAND *MSG-CONTROL-X-COMTAB*))) (SETQ *REPLY-CONTROL-X-COMTAB* (SET-COMTAB NIL '(#/1 COM-ZMAIL-REPLY-ONE-WINDOW #/2 COM-ZMAIL-REPLY-TWO-WINDOWS #/0 COM-ZMAIL-REPLY-ZERO-WINDOWS #/M COM-ZMAIL-RECURSIVE-MAIL #/O COM-ZMAIL-OTHER-WINDOW #/Y COM-PRUNE-YANKED-HEADERS #/R COM-RESTORE-DRAFT-FILE #/S COM-SAVE-DRAFT-FILE #/W COM-WRITE-DRAFT-FILE #/S COM-SAVE-DRAFT-AS-MSG))) (SET-COMTAB-INDIRECTION *REPLY-CONTROL-X-COMTAB* *MSG-CONTROL-X-COMTAB*) (SETQ *REPLY-COMTAB* (SET-COMTAB NIL '(#\END COM-MAIL-END #/ COM-SEND-MESSAGE #/Y COM-ZMAIL-YANK #\ABORT COM-ABORT-SEND #/] COM-ABORT-SEND) (MAKE-COMMAND-ALIST '(COM-ADD-TO-FIELD COM-ADD-CC-FIELD COM-ADD-FCC-FIELD COM-ADD-SUBJECT-FIELD COM-ADD-IN-REPLY-TO-FIELD COM-ADD-MORE-TEXT COM-ADD-FROM-FIELD COM-PRUNE-YANKED-HEADERS COM-SEND-MESSAGE COM-ABORT-SEND COM-RESTORE-DRAFT-FILE COM-WRITE-DRAFT-FILE COM-SAVE-DRAFT-FILE COM-SAVE-DRAFT-AS-MSG COM-CHANGE-SUBJECT-PRONOUNS)))) (SET-COMTAB *REPLY-COMTAB* (LIST #/X (MAKE-EXTENDED-COMMAND *REPLY-CONTROL-X-COMTAB*))) (SET-COMTAB *REPLY-COMTAB* (LIST #\MOUSE-3-1 (MAKE-MENU-COMMAND '(COM-ADD-TO-FIELD COM-ADD-CC-FIELD COM-ADD-FCC-FIELD COM-ADD-SUBJECT-FIELD COM-ADD-IN-REPLY-TO-FIELD COM-ADD-MORE-TEXT COM-ADD-FROM-FIELD COM-PRUNE-YANKED-HEADERS COM-SEND-MESSAGE COM-ABORT-SEND COM-RESTORE-DRAFT-FILE COM-WRITE-DRAFT-FILE COM-SAVE-DRAFT-FILE COM-SAVE-DRAFT-AS-MSG COM-CHANGE-SUBJECT-PRONOUNS)))) (SET-COMTAB-INDIRECTION *REPLY-COMTAB* MODE-COMTAB) (SETQ *OTHER-COMMAND-ALIST* (MAKE-COMMAND-ALIST '(COM-ZMAIL-VIEW-FILE COM-ZMAIL-WHOIS)))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SELF-DOCUMENT "ZWEI line self help" (NO-MAIL-FILE-OK) (LET ((*COMTAB* *ZMAIL-COMTAB*)) (COM-SELF-DOCUMENT))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-APROPOS "List commands whose names contain a given string." (NO-MAIL-FILE-OK) (MULTIPLE-VALUE-BIND (FUNCTION KEY) (GET-EXTENDED-SEARCH-STRINGS "Apropos. (Substring:)") (DOLIST (X *ZMAIL-TOP-LEVEL-COMMAND-NAME-ALIST*) (LET ((COMMAND (CDR X))) (AND (FUNCALL FUNCTION KEY (COMMAND-NAME COMMAND)) (DOCUMENT-ZMAIL-COMMAND COMMAND)))) (FORMAT T "~%Done.~%")) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-HELP "Minimal self help" (NO-MAIL-FILE-OK) (WITH-BACKGROUND-PROCESS-LOCKED (FORMAT T "~&Select command by typing character or mousing menu, or type /"*/" for all: ") (TV:WINDOW-CALL (*TYPEOUT-WINDOW*) (LET ((CH (FUNCALL STANDARD-INPUT ':ANY-TYI)) COMMAND) (IF (EQ CH #/*) (DOLIST (CMD (SETQ *ZMAIL-TOP-LEVEL-COMMAND-NAME-ALIST* (SORTCAR *ZMAIL-TOP-LEVEL-COMMAND-NAME-ALIST* #'STRING-LESSP))) (DOCUMENT-ZMAIL-COMMAND (CDR CMD))) (COND ((NUMBERP CH) (COND ((SETQ COMMAND (COMMAND-LOOKUP CH *ZMAIL-COMTAB*)) (FORMAT T "~:C is " CH)) (T (FORMAT T "~:C is not defined" CH)))) ((AND (LISTP CH) (EQ (CAR CH) ':MENU)) (SET-COMMAND-BUTTON (THIRD CH)) (SETQ COMMAND (CDADR CH)))) (DO () ((NULL COMMAND)) (FORMAT T "~A:~%" (COMMAND-NAME COMMAND)) (PRINT-DOC ':FULL COMMAND) (SETQ COMMAND (COND ((EQ COMMAND 'COM-ZMAIL-EXTENDED-COMMAND) (CDR (COMPLETING-READ-FROM-MINI-BUFFER "Command to document:" *ZMAIL-TOP-LEVEL-COMMAND-NAME-ALIST* NIL NIL "You are typing the name of a ZMAIL command."))) ((EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) (SELECTQ COMMAND (COM-ZMAIL-MAP (ZMAIL-MENU-CHOOSE *ZMAIL-MAP-COMMAND-MENU*)) (COM-ZMAIL-OTHER-COMMANDS (ZMAIL-MENU-CHOOSE 'ZMAIL-MOMENTARY-COMMAND-MENU *OTHER-COMMAND-ALIST*)) (OTHERWISE NIL)))))))))) DIS-NONE) (DEFUN DOCUMENT-ZMAIL-COMMAND (COMMAND) (FORMAT T "~&~30,5,2A" (COMMAND-NAME COMMAND)) (PRINT-DOC ':SHORT COMMAND) (FORMAT T "~&") (AND (RASSQ COMMAND *ZMAIL-COMMAND-ALIST*) (FORMAT T "~& which can be invoked from the main command menu~%")) (AND (RASSQ COMMAND *OTHER-COMMAND-ALIST*) (FORMAT T "~& which can be invoked from the /"Other/" command menu~%")) (AND (RASSQ COMMAND *ZMAIL-MAP-COMMAND-ALIST*) (FORMAT T "~& which can be invoked from the /"Map over/" command menu~%")) (AND (> (FIND-COMMAND-ON-KEYS COMMAND 4 " which can be invoked via: " *ZMAIL-COMTAB*) 0) (TERPRI))) ;;; Recursive means updating a substring (DEFUN UPDATE-COMMAND-WHO-LINE-DOCUMENTATION (COMMAND &OPTIONAL (TELL-WHO-LINE T) RECURSIVE &AUX STRING FUNCTION) (IF (SETQ STRING (GET COMMAND ':WHO-LINE-DOCUMENTATION)) (SETF (ARRAY-LEADER STRING 0) 0) (SETQ STRING (MAKE-EMPTY-STRING 95.)) (PUTPROP COMMAND STRING ':WHO-LINE-DOCUMENTATION)) (SETQ FUNCTION (GET COMMAND 'WHO-LINE-DOCUMENTATION-UPDATER)) (IF RECURSIVE (FUNCALL FUNCTION STRING T) (FUNCALL FUNCTION STRING)) (AND TELL-WHO-LINE (FUNCALL TV:WHO-LINE-DOCUMENTATION-WINDOW ':SET-WHO-LINE-ITEM-STATE NIL))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-EXTENDED-COMMAND "Get at any top-level command" (NO-MAIL-FILE-OK NUMERIC-ARG-OK) (LET ((ANS (WITH-BACKGROUND-PROCESS-LOCKED (COMPLETING-READ-FROM-MINI-BUFFER (FORMAT NIL "Command:~:[ (Arg = ~A)~]" (NOT *NUMERIC-ARG-P*) (FORMAT-ARGUMENT *NUMERIC-ARG-P* *NUMERIC-ARG*)) *ZMAIL-TOP-LEVEL-COMMAND-NAME-ALIST* NIL NIL "You are typing the name of a ZMAIL command." #'(LAMBDA (X) (LET ((STANDARD-OUTPUT *TYPEOUT-WINDOW*)) (PRINT-DOC ':FULL (CDR X)))))))) (COND ((EQUAL ANS "") (BEEP) DIS-NONE) (T (LET ((*CURRENT-COMMAND* (CDR ANS))) (FUNCALL *CURRENT-COMMAND*)))))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-LARGE-ARGUMENT "A large number for argument to command." (NO-MAIL-FILE-OK) (SETQ *NUMERIC-ARG* 37777777 *NUMERIC-ARG-P* ':INFINITY) ':ARGUMENT) (DEFINE-ZMAIL-GLOBAL *MOVE-TO-NEXT-MENU-LAST-ITEM* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-NEXT (STRING) (FORMAT STRING "Move forward: L: ~A; M: ~A; R: menu." (NAME-FROM-MENU-VALUE ':NEXT-UNDELETED *MOVE-TO-NEXT-MENU-ALIST*) (NAME-FROM-MENU-VALUE *NEXT-MIDDLE-MODE* *MOVE-TO-NEXT-MENU-ALIST*))) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *NEXT-MIDDLE-MODE* COM-ZMAIL-NEXT) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-NEXT "Move to next message. Skips deleted messages. Middle normally moves to the end, but is controlled by *NEXT-MIDDLE-MODE*. Right for a menu." (NUMERIC-ARG-OK) (LET (MODE) (IF (MEMQ *ZMAIL-COMMAND-BUTTON* '(:KBD :LEFT)) (SETQ MODE ':NEXT-UNDELETED) (MULTIPLE-VALUE (MODE *MOVE-TO-NEXT-MENU-LAST-ITEM*) (ZMAIL-MENU-CHOOSE NIL *MOVE-TO-NEXT-MENU-ALIST* *MOVE-TO-NEXT-MENU-LAST-ITEM* NIL *NEXT-MIDDLE-MODE*))) (COM-ZMAIL-NEXT-OR-PREVIOUS-INTERNAL MODE))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-DOWN-TO-NEXT "Move to next message" (NUMERIC-ARG-OK) (COM-ZMAIL-NEXT-OR-PREVIOUS-INTERNAL ':NEXT)) (DEFINE-ZMAIL-GLOBAL *MOVE-TO-PREVIOUS-MENU-LAST-ITEM* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-PREVIOUS (STRING) (FORMAT STRING "Move backward: L: ~A; M: ~A; R: menu." (NAME-FROM-MENU-VALUE ':PREVIOUS-UNDELETED *MOVE-TO-PREVIOUS-MENU-ALIST*) (NAME-FROM-MENU-VALUE *PREVIOUS-MIDDLE-MODE* *MOVE-TO-PREVIOUS-MENU-ALIST*))) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *PREVIOUS-MIDDLE-MODE* COM-ZMAIL-PREVIOUS) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-PREVIOUS "Move to previous message. Skips deleted messages. Middle normally moves to the beginning, but is controlled by *PREVIOUS-MIDDLE-MODE*. Right for a menu." (NUMERIC-ARG-OK) (LET (MODE) (IF (MEMQ *ZMAIL-COMMAND-BUTTON* '(:KBD :LEFT)) (SETQ MODE ':PREVIOUS-UNDELETED) (MULTIPLE-VALUE (MODE *MOVE-TO-PREVIOUS-MENU-LAST-ITEM*) (ZMAIL-MENU-CHOOSE NIL *MOVE-TO-PREVIOUS-MENU-ALIST* *MOVE-TO-PREVIOUS-MENU-LAST-ITEM* NIL *PREVIOUS-MIDDLE-MODE*))) (COM-ZMAIL-NEXT-OR-PREVIOUS-INTERNAL MODE))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-UP-TO-PREVIOUS "Move to previous message" (NUMERIC-ARG-OK) (COM-ZMAIL-NEXT-OR-PREVIOUS-INTERNAL ':PREVIOUS)) (DEFUN COM-ZMAIL-NEXT-OR-PREVIOUS-INTERNAL (KEY) (COND ((MEMQ KEY '(:FIRST :FIRST-UNDELETED)) (SETQ *MSG-NO* -1)) ((MEMQ KEY '(:LAST :LAST-UNDELETED)) (SETQ *MSG-NO* (MAIL-FILE-NMSGS *MAIL-FILE*)))) (AND (MEMQ KEY '(:FIRST :FIRST-UNDELETED :LAST :LAST-UNDELETED)) (MSG-POINT-PDL-PUSH *MSG* *MAIL-FILE*)) (FUNCALL (IF (MEMQ KEY '(:NEXT :NEXT-UNDELETED :FIRST :FIRST-UNDELETED)) 'ZMAIL-SELECT-NEXT-MSG 'ZMAIL-SELECT-PREVIOUS-MSG) (MEMQ KEY '(:NEXT-UNDELETED :PREVIOUS-UNDELETED :LAST-UNDELETED :FIRST-UNDELETED)) (OR *NUMERIC-ARG-P* (MEMQ KEY '(:FIRST :FIRST-UNDELETED :LAST :LAST-UNDELETED))) *NUMERIC-ARG*)) (DEFVAR *LAST-DELETED-MSG*) ;Most recently deleted message, for the YANK command. (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-DELETE (STRING) (FORMAT STRING "Delete current message: L: ~A; M: ~A; R: menu." (NAME-FROM-MENU-VALUE *NEXT-AFTER-DELETE* *DELETE-DIRECTION-ALIST*) (NAME-FROM-MENU-VALUE *DELETE-MIDDLE-MODE* *DELETE-DIRECTION-ALIST*))) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *NEXT-AFTER-DELETE* COM-ZMAIL-DELETE) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *DELETE-MIDDLE-MODE* COM-ZMAIL-DELETE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-DELETE "Delete current message. Normally moves to the next message, but is controlled by *NEXT-AFTER-DELETE*. Middle normally moves back after deleting, but is controlled by *DELETE-MIDDLE-MODE*. Right gives a menu, including Remove. With an argument, deletes the message with that number." (NUMERIC-ARG-OK) (LET (MSG MODE) (IF *NUMERIC-ARG-P* (SETQ MSG (GET-MSG-FROM-ARG) MODE ':NONE) (SETQ MSG *MSG* MODE (CHOOSE-DELETE-MODE))) (COM-ZMAIL-DELETE-INTERNAL MODE MSG))) (DEFUN CHOOSE-DELETE-MODE () (SELECTQ *ZMAIL-COMMAND-BUTTON* (:MIDDLE *DELETE-MIDDLE-MODE*) (:RIGHT (OR (TV:MENU-CHOOSE *DELETE-DIRECTION-ALIST* NIL (RECTANGLE-NEAR-COMMAND-MENU TV:MOUSE-SHEET)) (ABORT-CURRENT-COMMAND))) (OTHERWISE *NEXT-AFTER-DELETE*))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-DELETE-AND-UP "Delete the current message and move to previous undeleted" () (COM-ZMAIL-DELETE-INTERNAL *DELETE-MIDDLE-MODE*)) (DEFUN COM-ZMAIL-DELETE-INTERNAL (MODE &OPTIONAL (MSG *MSG*)) (IF (EQ MODE ':REMOVE) (REMOVE-MSG *MAIL-FILE* *MSG* (LOCATE-MSG-IN-MAIL-FILE *MSG* *MAIL-FILE*)) (MSG-PUT MSG T 'DELETED) (SETQ *LAST-DELETED-MSG* MSG) (MOVE-AFTER-DELETE MODE))) (DEFUN MOVE-AFTER-DELETE (MODE) (SELECTQ MODE (:BACKWARD (ZMAIL-SELECT-PREVIOUS-MSG T T)) (:FORWARD (ZMAIL-SELECT-NEXT-MSG T T)) (OTHERWISE (ZMAIL-SELECT-MSG *MSG* NIL NIL)))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-UNDELETE "Undelete this or the previous deleted message." (NUMERIC-ARG-OK) (IF *NUMERIC-ARG-P* (LET ((MSG (GET-MSG-FROM-ARG))) (OR (MSG-GET MSG 'DELETED) (BARF "Message not deleted")) (ZMAIL-UNDELETE-MSG MSG)) (LET ((ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*))) (DO ((N *MSG-NO* (1- N)) (MSG)) ((< N 0) (BARF "No deleted messages")) (COND ((MSG-GET (SETQ MSG (AREF ARRAY N)) 'DELETED) (MSG-PUT MSG NIL 'DELETED) (RETURN (ZMAIL-SELECT-MSG N)))))))) (DEFUN REMOVE-MSG (MAIL-FILE MSG INDEX &AUX ARRAY LEN) (AND (MAIL-FILE-DISK-P MAIL-FILE) (BARF "Cannot remove from disk mail file")) (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)) (OR (EQ MSG (AREF ARRAY INDEX)) (FERROR NIL "~S not in ~Dth position of ~S" MSG INDEX MAIL-FILE)) (MSG-POINT-PDL-PURGE MSG MAIL-FILE) (SETQ LEN (ARRAY-ACTIVE-LENGTH ARRAY)) (COPY-ARRAY-PORTION ARRAY (1+ INDEX) LEN ARRAY INDEX (SETQ LEN (1- LEN))) (SETF (ARRAY-LEADER ARRAY 0) LEN) (COND ((EQ MAIL-FILE *MAIL-FILE*) (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY) (IF (ZEROP LEN) (ZMAIL-SELECT-MSG NIL T) (ZMAIL-SELECT-MSG (MIN INDEX (1- LEN))))))) (DEFUN ZMAIL-SELECT-NEXT-MSG (&OPTIONAL NO-DELETED NO-ERROR-P (TIMES 1) &AUX ARRAY) (SETQ ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*)) (DO ((N (1+ *MSG-NO*) (1+ N)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (NTIMES TIMES) (OK-IDX)) (NIL) (AND ( N NMSGS) (OR (FUNCALL *MAIL-FILE* ':READ-NEXT-MSG) (IF (NOT NO-ERROR-P) (BARF "Already at end") (OR OK-IDX (SETQ OK-IDX *MSG*)) (RETURN (IF OK-IDX (ZMAIL-SELECT-MSG OK-IDX) (COMPUTE-CURRENT-MSG-NAME) (SETQ *CURRENT-MSG-KEYWORDS-STRING* NIL) DIS-NONE))))) (OR (AND NO-DELETED (MSG-GET (AREF ARRAY N) 'DELETED)) (PLUSP (SETQ OK-IDX N NTIMES (1- NTIMES))) (RETURN (ZMAIL-SELECT-MSG N NIL ( TIMES 1)))))) (DEFUN ZMAIL-SELECT-PREVIOUS-MSG (&OPTIONAL NO-DELETED NO-ERROR-P (TIMES 1) &AUX ARRAY) (SETQ ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*)) (DO ((N (1- *MSG-NO*) (1- N)) (NTIMES TIMES) (OK-IDX)) ((< N 0) (IF NO-ERROR-P (ZMAIL-SELECT-MSG (OR OK-IDX *MSG*)) (BARF "Already at beginning"))) (OR (AND NO-DELETED (MSG-GET (AREF ARRAY N) 'DELETED)) (PLUSP (SETQ OK-IDX N NTIMES (1- NTIMES))) (RETURN (ZMAIL-SELECT-MSG N NIL ( TIMES 1)))))) (DEFVAR *EMPTY-MSG-INTERVAL* (CREATE-INTERVAL)) ;;; Go to a specified message, specified either as the message itself or a number (DEFUN ZMAIL-SELECT-MSG (MSG &OPTIONAL NO-ERROR-P (SAVE-POINT-P T) &AUX (OLD-CURRENT-MSG *MSG*) INDEX START-BP END-BP ARRAY NMSGS) (IF (EQ MSG ':NO-SELECT) DIS-NONE (IF (NULL *MAIL-FILE*) (SETQ *MSG-NO* -1 *MSG* NIL) (SETQ ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*) NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (COND ((NUMBERP MSG) (SETQ *MSG-NO* MSG *MSG* (AREF ARRAY *MSG-NO*))) ;; First try a hint from the summary window's display ((AND MSG (SETQ INDEX (MSG-DISPLAYED-INDEX MSG)) (< INDEX NMSGS) (EQ MSG (AREF ARRAY INDEX))) (SETQ *MSG-NO* INDEX *MSG* MSG)) (T (DO-NAMED FOO ((FLAG NIL T)) (NIL) (DO ((I 0 (1+ I))) (( I NMSGS) (OR NO-ERROR-P (FERROR NIL "Cannot find ~S in current mail file." MSG)) (COND ((OR FLAG (NULL (SETQ MSG (MAIL-FILE-SAVED-CURRENT-MSG *MAIL-FILE*)))) (IF (PLUSP NMSGS) (SETQ *MSG-NO* 0 ;If not erring, choose one at random *MSG* (AREF ARRAY 0)) (SETQ *MSG-NO* -1 *MSG* NIL)) (RETURN-FROM FOO)))) (COND ((EQ MSG (AREF ARRAY I)) (SETQ *MSG-NO* I *MSG* MSG) (RETURN-FROM FOO)))))))) (FUNCALL *SUMMARY-WINDOW* ':SET-CURRENT-MSG *MSG*) (COMPUTE-CURRENT-MSG-NAME) (SETQ *CURRENT-MSG-KEYWORDS-STRING* (AND *MSG* (OR (MSG-GET *MSG* 'KEYWORDS-STRING) "{}"))) (AND SAVE-POINT-P OLD-CURRENT-MSG (NEQ *MSG* OLD-CURRENT-MSG) *MAIL-FILE* (MSG-POINT-PDL-PUSH OLD-CURRENT-MSG *MAIL-FILE*)) (COND (*MSG* (AND (MSG-GET *MSG* 'UNSEEN) (MSG-PUT *MSG* NIL 'UNSEEN)) (SETQ START-BP (MSG-START-BP *MSG*) END-BP (MSG-END-BP *MSG*))) (T (SETQ START-BP (INTERVAL-FIRST-BP *EMPTY-MSG-INTERVAL*) END-BP (INTERVAL-LAST-BP *EMPTY-MSG-INTERVAL*)))) (SET-MSG-INTERVAL START-BP END-BP) ;;This DIS-ALL is not right, but since there are so many bugs in REDISPLAY-BLT having ;;to do with virtual bounds, moving backwards would redisplay incorrectly otherwise. (IF (EQ *MSG* OLD-CURRENT-MSG) DIS-TEXT DIS-ALL))) (DEFUN SET-MSG-INTERVAL (START-BP &OPTIONAL END-BP IN-ORDER-P) (GET-INTERVAL START-BP END-BP IN-ORDER-P) (MOVE-BP (WINDOW-POINT *MSG-WINDOW*) START-BP) (MOVE-BP (WINDOW-MARK *MSG-WINDOW*) START-BP) (MOVE-BP (WINDOW-START-BP *MSG-WINDOW*) START-BP) (SETF (INTERVAL-FIRST-BP *MSG-INTERVAL*) START-BP) (SETF (INTERVAL-LAST-BP *MSG-INTERVAL*) END-BP)) (DEFUN COMPUTE-CURRENT-MSG-NAME () (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-EDIT-CURRENT-MSG) (SETQ *CURRENT-MSG-NAME* (AND *MAIL-FILE* (IF *MSG* (LET ((STRING (MAKE-EMPTY-STRING 40)) (STATUS (ASSURE-MSG-PARSED *MSG*)) (NMSGS (AND (NOT (AND (MAIL-FILE-DISK-P *MAIL-FILE*) (MEMQ (DISK-MAIL-FILE-STATUS *MAIL-FILE*) '(:NEW-MAIL :LOADING :LOADING-NEW-MAIL)))) (MAIL-FILE-NMSGS *MAIL-FILE*)))) (FORMAT STRING "~4XMsg #~D//~:[??~*~;~D~]" (1+ *MSG-NO*) NMSGS NMSGS) (DO ((LIST *SAVED-INTERNAL-PROPERTIES-ALIST* (CDR LIST)) (FLAG NIL) (KEY)) ((NULL LIST) (AND FLAG (ARRAY-PUSH-EXTEND STRING #/)))) (SETQ KEY (CDAR LIST)) (COND ((IF (EQ KEY 'LAST) (AND NMSGS (= *MSG-NO* (1- NMSGS))) (GET STATUS KEY)) (APPEND-TO-ARRAY STRING (IF FLAG ", " " (")) (APPEND-TO-ARRAY STRING (CAAR LIST)) (SETQ FLAG T)))) STRING) " Empty mail file")))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SET-POP-MARK "Sets or pops the mark. With no U's, sets the mark at the point, and pushes point onto the point pdl. With one U, pops the point pdl. With two U's, pops the point pdl and throws it away" (NUMERIC-ARG-OK) (COND (( *NUMERIC-ARG* 3) (MSG-POINT-PDL-PUSH *MSG* *MAIL-FILE*) DIS-NONE) (( *NUMERIC-ARG* 17) (MSG-POINT-PDL-MOVE (MSG-POINT-PDL-POP))) (T (MSG-POINT-PDL-POP) DIS-NONE))) (DEFUN MSG-POINT-PDL-PUSH (MSG MAIL-FILE &AUX START-BP) (COND ((NEQ MSG ':NO-SELECT) (LET ((INT (WINDOW-INTERVAL *MSG-WINDOW*))) (AND (BP-= (INTERVAL-FIRST-BP INT) (MSG-START-BP MSG)) (BP-= (INTERVAL-LAST-BP INT) (MSG-END-BP MSG)) (SETQ START-BP (COPY-BP (WINDOW-START-BP *MSG-WINDOW*) ':NORMAL)))) (PUSH (LIST MSG MAIL-FILE START-BP) *MSG-POINT-PDL*) (AND (> (LENGTH *MSG-POINT-PDL*) *POINT-PDL-MAX*) (LET ((ENTRY (DELETE-LAST-ELEMENT *MSG-POINT-PDL*))) (FLUSH-BP (THIRD ENTRY))))))) (DEFUN MSG-POINT-PDL-POP () (OR *MSG-POINT-PDL* (BARF)) (PROG1 (CAR *MSG-POINT-PDL*) (SETQ *MSG-POINT-PDL* (NCONC (CDR *MSG-POINT-PDL*) (RPLACD *MSG-POINT-PDL* NIL))))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* POINT-PDL-ELEMENT "Select" MSG-POINT-PDL-MOVE T "Select this message.") (DEFUN MSG-POINT-PDL-MOVE (ENTRY &AUX MSG MAIL-FILE START-BP) (SETF `(,MSG ,MAIL-FILE ,START-BP) ENTRY) (OR (EQ MAIL-FILE *MAIL-FILE*) (SELECT-MAIL-FILE MAIL-FILE NIL NIL)) (ZMAIL-SELECT-MSG MSG NIL NIL) (AND START-BP (RECENTER-WINDOW *MSG-WINDOW* ':START START-BP)) DIS-ALL) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MOVE-TO-PREVIOUS-POINT "Exchange point and top of point pdl. A numeric argument rotates top arg entries of the point pdl (the default numeric argument is 2). An argument of 1 rotates the whole point pdl and a negative argument rotates the other way." (NUMERIC-ARG-OK) (ROTATE-MSG-POINT-PDL (IF *NUMERIC-ARG-P* *NUMERIC-ARG* 2))) (DEFVAR *DEFAULT-PREVIOUS-MSG-POINT-ARG* 3) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MOVE-TO-DEFAULT-PREVIOUS-POINT "Rotate the point pdl. A numeric argument specifies the number of entries to rotate, and sets the new default." (NUMERIC-ARG-OK) (AND *NUMERIC-ARG-P* (SETQ *DEFAULT-PREVIOUS-MSG-POINT-ARG* *NUMERIC-ARG*)) (ROTATE-MSG-POINT-PDL *DEFAULT-PREVIOUS-MSG-POINT-ARG*)) (DEFUN ROTATE-MSG-POINT-PDL (N &AUX ENTRY LIST) (SETQ ENTRY (LIST *MSG* *MAIL-FILE* (COPY-BP (WINDOW-START-BP *MSG-WINDOW*) ':NORMAL)) LIST (CONS ENTRY *MSG-POINT-PDL*)) (ROTATE-TOP-OF-LIST LIST N) (SETQ ENTRY (CAR LIST)) (MSG-POINT-PDL-MOVE ENTRY) DIS-BPS) (DEFUN MSG-POINT-PDL-PURGE (*MSG* *MAIL-FILE*) (SETQ *MSG-POINT-PDL* (DEL-IF #'(LAMBDA (X) (AND (OR (NULL *MSG*) (EQ (FIRST X) *MSG*)) (OR (NULL *MAIL-FILE*) (EQ (SECOND X) *MAIL-FILE*)))) *MSG-POINT-PDL*))) (DEFUN MSG-POINT-PDL-FORWARD-MAIL-FILE (FROM TO) (DOLIST (ELEM *MSG-POINT-PDL*) (COND ((EQ (SECOND ELEM) FROM) (SETF (SECOND ELEM) TO) (AND (BP-< (THIRD ELEM) (MSG-START-BP (FIRST ELEM))) (MOVE-BP (THIRD ELEM) (MSG-START-BP (FIRST ELEM)))))))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MOUSE-POINT-PDL "Give menu of message point pdl" () (LET (*TYPEOUT-WINDOW* (N 0)) (IF (TV:SHEET-EXPOSED-P *SUMMARY-WINDOW*) (SETQ *TYPEOUT-WINDOW* (FUNCALL *SUMMARY-WINDOW* ':TYPEOUT-WINDOW)) (SETQ *TYPEOUT-WINDOW* (WINDOW-TYPEOUT-WINDOW *WINDOW*)) (FUNCALL *TYPEOUT-WINDOW* ':LINE-OUT *SUMMARY-WINDOW-LABEL*)) (DOLIST (ELEM *MSG-POINT-PDL*) (LET* ((MSG (CAR ELEM)) (STATUS (ASSURE-MSG-PARSED MSG))) (FUNCALL *TYPEOUT-WINDOW* ':TRUNCATED-ITEM 'POINT-PDL-ELEMENT ELEM "~~3D~C~A" (EQ MSG *MSG*) (SETQ N (1+ N)) (STATUS-LETTER STATUS) (MSG-SUMMARY-LINE MSG)) (FUNCALL *TYPEOUT-WINDOW* ':TYO #\CR))) (CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT)) DIS-NONE) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MSG-LINE "Select" SELECT-MSG-FROM-LINE T "Select the message containing this line.") ;;; Select the message as pointed to by the typeout window (DEFUN SELECT-MSG-FROM-LINE (MSG-LINE &AUX ARRAY) (SETQ ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*)) (DO ((I 0 (1+ I)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (MSG)) (( I NMSGS) (FERROR NIL "Cannot find /"~A/" in ~S" MSG-LINE *MAIL-FILE*)) (SETQ MSG (AREF ARRAY I)) (AND (DO ((LINE (BP-LINE (MSG-START-BP MSG)) (LINE-NEXT LINE)) (END (BP-LINE (MSG-END-BP MSG)))) ((EQ LINE END) NIL) (AND (EQ LINE MSG-LINE) (RETURN T))) (RETURN (ZMAIL-SELECT-MSG MSG))))) ;;; Select a msg, possibly changing to its primary mail file (DEFUN SELECT-MSG-AND-POSSIBLY-MAIL-FILE (MSG &AUX I) (IF (SETQ I (MSG-IN-MAIL-FILE-P MSG *MAIL-FILE*)) (ZMAIL-SELECT-MSG I) (SELECT-MAIL-FILE (MSG-MAIL-FILE MSG) NIL NIL) (ZMAIL-SELECT-MSG MSG NIL NIL))) (DEFUN ABORT-CURRENT-COMMAND () (*THROW 'ZWEI-COMMAND-LOOP T)) (DEFVAR *ZMAIL-QUIT-MENU-ALIST* '((("Don't Save" :VALUE :NOSAVE :DOCUMENTATION "Don't save out any files.") ("Ask" :VALUE :ASK :DOCUMENTATION "Give a menu for saving of files.") ("Save" :VALUE :SAVE :DOCUMENTATION "Save out all changed files.")) (("Quit" :VALUE :QUIT :DOCUMENTATION "Select calling window.") ("Logout" :VALUE :LOGOUT :DOCUMENTATION "Logout when done writing.")))) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-ZMAIL-QUIT "Save and exit: L: save all; R: menu for Save mode // Logout.") (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-QUIT "Save and exit. Expunge deleted messages, write out changes and exit. Right gives menu of options." (NO-MAIL-FILE-OK) (LET ((SAVE-MODE ':SAVE) (LOGOUT-MODE ':QUIT)) (AND (EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) (MULTIPLE-VALUE (SAVE-MODE LOGOUT-MODE) (DEFAULTED-MULTIPLE-MENU-CHOOSE-NEAR-MENU *ZMAIL-QUIT-MENU-ALIST* SAVE-MODE LOGOUT-MODE))) (SELECTQ SAVE-MODE (:NOSAVE) (:SAVE (ZMAIL-SAVE-ALL)) (:ASK (ZMAIL-SAVE-MENU))) (SELECTQ LOGOUT-MODE (:QUIT) (:LOGOUT (LOGOUT)))) (MUST-REDISPLAY *MSG-WINDOW* DIS-TEXT) (*THROW 'EXIT-TOP-LEVEL T)) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-NOT-MODIFIED "Mark this mail file as not needing saving" (NO-MSG-OK) (COND ((MAIL-FILE-SAVE-P *MAIL-FILE*) (SETF (DISK-MAIL-FILE-TICK *MAIL-FILE*) (TICK)) (TYPEIN-LINE "Not modified"))) DIS-NONE) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-ZMAIL-SAVE "L: Expunge & write out all mail files; M: Expunge this; R: Expunge // Save // Kill menu.") (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SAVE "Expunge and write out all files. Right gives a menu for Expunge, Save or Kill for each file." (NO-MSG-OK) (SELECTQ *ZMAIL-COMMAND-BUTTON* ((:KBD :LEFT) (ZMAIL-SAVE-ALL)) (:MIDDLE (COM-ZMAIL-EXPUNGE)) (:RIGHT (ZMAIL-SAVE-MENU))) DIS-TEXT) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-EXPUNGE "Expunge the current mail file." () (EXPUNGE-MAIL-FILE *MAIL-FILE*) (AND (MAIL-FILE-DISK-P *MAIL-FILE*) (DOLIST (MAIL-FILE *MAIL-FILE-LIST*) (AND (NOT (MAIL-FILE-DISK-P MAIL-FILE)) (EXPUNGE-MAIL-FILE MAIL-FILE NIL)))) DIS-TEXT) (DEFUN ZMAIL-SAVE-ALL () (DOLIST (MAIL-FILE *MAIL-FILE-LIST*) (EXPUNGE-AND-SAVE-MAIL-FILE MAIL-FILE))) (DEFUN ZMAIL-SAVE-ALL-FILES () (FUNCALL *ZMAIL-WINDOW* ':FUNCALL-INSIDE-YOURSELF #'(LAMBDA (&AUX (*TYPEIN-WINDOW* TERMINAL-IO)) (DOLIST (MAIL-FILE *MAIL-FILE-LIST*) (AND (MAIL-FILE-DISK-P MAIL-FILE) (MAIL-FILE-SAVE-P MAIL-FILE) (FQUERY NIL "Save ~A? " (MAIL-FILE-NAME MAIL-FILE)) (SAVE-MAIL-FILE MAIL-FILE)))))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MAIL-FILE "Expunge & Save" EXPUNGE-AND-SAVE-MAIL-FILE NIL "Expunge and then save this mail file.") (DEFUN EXPUNGE-AND-SAVE-MAIL-FILE (MAIL-FILE) (EXPUNGE-MAIL-FILE MAIL-FILE) (AND (MAIL-FILE-DISK-P MAIL-FILE) (SAVE-MAIL-FILE MAIL-FILE))) (DEFUN ZMAIL-SAVE-MENU (&AUX CHOICES EXPUNGED-SOME) (SETQ CHOICES (DO ((L *MAIL-FILE-LIST* (CDR L)) (MAIL-FILE) (NL NIL) (SAVE-P) (EXPUNGE-P)) ((NULL L) (NREVERSE NL)) (SETQ MAIL-FILE (CAR L)) (MULTIPLE-VALUE (SAVE-P EXPUNGE-P) (MAIL-FILE-SAVE-P MAIL-FILE)) (PUSH `(,MAIL-FILE ,(MAIL-FILE-NAME MAIL-FILE) ,(IF (MAIL-FILE-DISK-P MAIL-FILE) `((:EXPUNGE ,EXPUNGE-P) (:SAVE ,(OR SAVE-P EXPUNGE-P)) :KILL) `((:EXPUNGE ,EXPUNGE-P) :KILL))) NL))) (SETQ CHOICES (TV:MULTIPLE-CHOOSE "Mail file" (SORT CHOICES #'(LAMBDA (X Y) (STRING-LESSP (CADR X) (CADR Y)))) '((:EXPUNGE "Expunge" NIL (:KILL) NIL NIL) (:SAVE "Save" NIL (:KILL) NIL NIL) (:KILL "Kill" NIL (:EXPUNGE :SAVE) NIL NIL)) '(:MOUSE) 50.)) (DOLIST (CHOICE CHOICES) (LET ((MAIL-FILE (CAR CHOICE)) (KEYWORDS (CDR CHOICE))) ;; Make sure things are done in the right order (COND ((MEMQ ':EXPUNGE KEYWORDS) (EXPUNGE-MAIL-FILE MAIL-FILE) (AND (MAIL-FILE-DISK-P MAIL-FILE) (SETQ EXPUNGED-SOME T)))) (AND (MEMQ ':SAVE KEYWORDS) (SAVE-MAIL-FILE MAIL-FILE)) (AND (MEMQ ':KILL KEYWORDS) (KILL-MAIL-FILE MAIL-FILE)))) ;;If some disk mail files were expunged, expunge any temporary ones that weren't (DOLIST (CHOICE CHOICES) (LET ((MAIL-FILE (CAR CHOICE))) (AND (NOT (MAIL-FILE-DISK-P MAIL-FILE)) (NOT (MEMQ ':EXPUNGE (CDR CHOICE))) (EXPUNGE-MAIL-FILE MAIL-FILE NIL))))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MAIL-FILE "Expunge" EXPUNGE-MAIL-FILE NIL "Expunge this mail file.") (DEFUN EXPUNGE-MAIL-FILE (MAIL-FILE &OPTIONAL (DELETED-MSGS T) &AUX ARRAY INFS (*INTERVAL* *INTERVAL*)) (COND ((MAIL-FILE-DISK-P MAIL-FILE) (SETQ *INTERVAL* (DISK-MAIL-FILE-INTERVAL MAIL-FILE)) (SETQ INFS (LOCF (NODE-INFERIORS *INTERVAL*))) (FOREGROUND-BACKGROUND-FINISH MAIL-FILE) (MAIL-FILE-DELETE-EXPIRED MAIL-FILE *DELETE-EXPIRED-MSGS*) (AND *QUERY-BEFORE-EXPUNGE* (MAIL-FILE-EXPUNGE-QUERY MAIL-FILE)))) (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)) (DO ((NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (I 0 (1+ I)) (J 0) (MSG)) (( I NMSGS) (SETF (ARRAY-LEADER ARRAY 0) J) (COND ((AND (PLUSP J) (MAIL-FILE-DISK-P MAIL-FILE)) ;; Kludge for babyl, make the last line of the file correct maybe. (FUNCALL MAIL-FILE ':UPDATE-MSG-END (AREF ARRAY (1- J)))) ((AND (ZEROP J) (NOT (MAIL-FILE-DISK-P MAIL-FILE))) ;; A temporary mail file goes away when it becomes empty. (FUNCALL MAIL-FILE ':KILL)))) ;; For speed, this does not call MSG-GET, which would parse the ;; message if need be. If the message has never been parsed, it ;; probably isn't deleted. Likewise, below it cannot be recent. (COND ((OR (EQ (MSG-PARSED-P (SETQ MSG (AREF ARRAY I))) ':KILLED) (AND DELETED-MSGS (GET (LOCF (MSG-STATUS MSG)) 'DELETED))) (MSG-POINT-PDL-PURGE MSG (AND (NOT (EQ MAIL-FILE (MSG-MAIL-FILE MSG))) MAIL-FILE)) (AND (EQ MAIL-FILE (MSG-MAIL-FILE MSG)) (LET ((REAL-INT (MSG-REAL-INTERVAL MSG))) (DELETE-INTERVAL REAL-INT) (SETF (MSG-PARSED-P MSG) ':KILLED) (IF (EQ REAL-INT (CADR INFS)) (RPLACD INFS (CDDR INFS)) (FERROR NIL "Node inferiors messed up, please report to BUG-ZMAIL"))))) (T (COND ((EQ MAIL-FILE (MSG-MAIL-FILE MSG)) (AND (REMPROP (LOCF (MSG-STATUS MSG)) 'RECENT) (SETF (MSG-TICK MSG) (TICK))) (SETQ INFS (CDR INFS)))) (OR (= I J) (ASET MSG ARRAY J)) (SETQ J (1+ J))))) (COND ((EQ MAIL-FILE *MAIL-FILE*) (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY) (ZMAIL-SELECT-MSG (COND ((ZEROP (ARRAY-ACTIVE-LENGTH ARRAY)) NIL) ((OR (EQ (MSG-PARSED-P *MSG*) ':KILLED) (MSG-GET *MSG* 'DELETED)) 0) (T *MSG*)) T NIL)))) (DEFUN MAIL-FILE-EXPUNGE-QUERY (MAIL-FILE) (AND (NOT (MAIL-FILE-PREDICATE-QUERY MAIL-FILE #'(LAMBDA (MSG) (GET (LOCF (MSG-STATUS MSG)) 'DELETED)) "expunge" "Deleted")) (ABORT-CURRENT-COMMAND))) (DEFUN MAIL-FILE-PREDICATE-QUERY (MAIL-FILE PREDICATE ACTION ATTRIBUTE &AUX ARRAY) (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)) (DO ((I 0 (1+ I)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (MSG) (FLAG 0)) (( I NMSGS) (OR (ZEROP FLAG) (TYPEOUT-YES-OR-NO-P "Ok to ~A ~:[it~;them~]? " ACTION (> FLAG 1)))) (COND ((FUNCALL PREDICATE (SETQ MSG (AREF ARRAY I))) (AND (ZEROP FLAG) (FORMAT *TYPEOUT-WINDOW* "~&~A messages to be ~Ad from ~A:~%" ATTRIBUTE ACTION (MAIL-FILE-NAME MAIL-FILE))) (FUNCALL *TYPEOUT-WINDOW* ':TRUNCATED-ITEM 'SUMMARY-LINE MSG "~~3D~C~A" (EQ MSG *MSG*) (SETQ FLAG (1+ FLAG)) (STATUS-LETTER (ASSURE-MSG-PARSED MSG)) (MSG-SUMMARY-LINE MSG)) (FUNCALL *TYPEOUT-WINDOW* ':TYO #\CR))))) (LOCAL-DECLARE ((SPECIAL *NOW*)) (DEFUN MAIL-FILE-DELETE-EXPIRED (MAIL-FILE WHEN &AUX (*NOW* (TIME:GET-UNIVERSAL-TIME))) (AND (EQ WHEN ':PER-FILE) (SETQ WHEN (GET (LOCF (MAIL-FILE-OPTIONS MAIL-FILE)) ':DELETE-EXPIRED))) (AND (OR (EQ WHEN T) (AND (EQ WHEN ':ASK) (MAIL-FILE-PREDICATE-QUERY MAIL-FILE #'MSG-EXPIRED-P "delete" "Expired"))) (DOMSGS (MSG MAIL-FILE) (AND (MSG-EXPIRED-P MSG) (MSG-PUT MSG T 'DELETED))))) (DEFUN MSG-EXPIRED-P (MSG &AUX STATUS EXPIRATION-DATE) (SETQ STATUS (ASSURE-MSG-PARSED MSG)) (AND (NOT (GET STATUS 'DELETED)) (SETQ EXPIRATION-DATE (GET STATUS ':EXPIRATION-DATE)) (> *NOW* EXPIRATION-DATE))) ) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MAIL-FILE "Save" SAVE-MAIL-FILE NIL "Save this mail file.") (DEFUN SAVE-MAIL-FILE (MAIL-FILE) (FOREGROUND-BACKGROUND-FINISH MAIL-FILE) (COND ((MAIL-FILE-SAVE-P MAIL-FILE) (LET ((OPTIONS (LOCF (MAIL-FILE-OPTIONS MAIL-FILE)))) (LET ((OWNER (GET OPTIONS ':OWNER))) (AND OWNER (NOT (STRING-EQUAL OWNER USER-ID)) (OR (FQUERY '(:SELECT T :BEEP T) "The file ~A is owned by ~A. Save it anyway? " (MAIL-FILE-NAME MAIL-FILE) OWNER) (ABORT-CURRENT-COMMAND))))) (MAIL-FILE-SAVE-SETUP MAIL-FILE) (STREAM-OUT-INTERVAL (DISK-MAIL-FILE-STREAM MAIL-FILE) (DISK-MAIL-FILE-INTERVAL MAIL-FILE)) (FUNCALL MAIL-FILE ':SAVING-DONE)) (T (TYPEIN-LINE "No changes need to be written in ~A" (MAIL-FILE-NAME MAIL-FILE)))) DIS-NONE) ;;; Does this file need saving out? Works by updating the start of each message that ;;; has changed and seeing if that mungs the mail file's interval. (DEFUN MAIL-FILE-SAVE-P (MAIL-FILE &AUX SAVE-P EXPUNGE-P) (DECLARE (RETURN-LIST SAVE-P EXPUNGE-P)) (DOMSGS (MSG MAIL-FILE) (FUNCALL MAIL-FILE ':UPDATE-MSG-OPTIONS-IN-FILE-IF-NECESSARY MSG) (AND (GET (LOCF (MSG-STATUS MSG)) 'DELETED) (SETQ EXPUNGE-P T))) (COND ((MAIL-FILE-DISK-P MAIL-FILE) (SETF (DISK-MAIL-FILE-MSG-UPDATE-TICK MAIL-FILE) (TICK)) ;; This may require that the file be saved out. (FUNCALL MAIL-FILE ':UPDATE-OPTIONS-IN-FILE) (AND (OR (EQ (DISK-MAIL-FILE-ID MAIL-FILE) T) (> (NODE-TICK (DISK-MAIL-FILE-INTERVAL MAIL-FILE)) (DISK-MAIL-FILE-TICK MAIL-FILE))) (SETQ SAVE-P T)))) (VALUES SAVE-P EXPUNGE-P)) ;;; This forces the rest of the file to be read in immediately, aborts any saving in ;;; progress, etc. ABORT-P means abort the saving rather than finishing it, as ;;; another one is about to be begun. (DEFUN FOREGROUND-BACKGROUND-FINISH (MAIL-FILE &OPTIONAL (ABORT-P T) STATUS) (LOCK-MAIL-FILE (MAIL-FILE) (SELECTQ (SETQ STATUS (DISK-MAIL-FILE-STATUS MAIL-FILE)) ((:NEW-MAIL :LOADING :LOADING-NEW-MAIL :SAVING-REQUIRED :AWAITING-NEW-MAIL :AWAITING-SAVE) (LET ((*ZMAIL-BACKGROUND-P* ':DISABLE)) (SETQ MAIL-FILE (LOAD-ALL-MSGS MAIL-FILE))) (COND (ABORT-P (SETQ STATUS ':SAVING-REQUIRED)) (T (MAIL-FILE-SAVE-SETUP MAIL-FILE) (STREAM-OUT-INTERVAL (DISK-MAIL-FILE-STREAM MAIL-FILE) (DISK-MAIL-FILE-INTERVAL MAIL-FILE)) (FUNCALL MAIL-FILE ':SAVING-DONE T) (SETQ STATUS NIL)))) (:SAVING (IF ABORT-P (FUNCALL (DISK-MAIL-FILE-STREAM MAIL-FILE) ':CLOSE ':ABORT) (LET ((INTERVAL-STREAM (DOLIST (REQUEST (CAR *ZMAIL-BACKGROUND-REQUEST-CELL*)) (AND (EQ (CAR REQUEST) 'ZMAIL-BACKGROUND-SAVE-FILE) (EQ (CADR REQUEST) MAIL-FILE) (RETURN (THIRD REQUEST)))))) (COND (INTERVAL-STREAM (STREAM-COPY-UNTIL-EOF INTERVAL-STREAM (DISK-MAIL-FILE-STREAM MAIL-FILE)) (FUNCALL MAIL-FILE ':SAVING-DONE))))) (SETQ STATUS NIL))) (SETF (DISK-MAIL-FILE-STATUS MAIL-FILE) STATUS) (WITHOUT-INTERRUPTS (SETF (CAR *ZMAIL-BACKGROUND-REQUEST-CELL*) (LET ((*MAIL-FILE* MAIL-FILE)) (DEL-IF #'(LAMBDA (X) (AND (MEMQ (CAR X) '(ZMAIL-BACKGROUND-SAVE-FILE ZMAIL-BACKGROUND-LOAD-FILE)) (EQ (CADR X) *MAIL-FILE*))) (CAR *ZMAIL-BACKGROUND-REQUEST-CELL*))))))) (DEFUN ASSURE-MAIL-FILE-FULLY-LOADED (MAIL-FILE &AUX OTHER) (LOCK-MAIL-FILE (MAIL-FILE) (AND (COND ((EQ (DISK-MAIL-FILE-STATUS MAIL-FILE) ':LOADING) T) ((AND (SETQ OTHER (DISK-MAIL-FILE-OTHER-MAIL-FILE MAIL-FILE)) (EQ (DISK-MAIL-FILE-STATUS OTHER) ':LOADING-NEW-MAIL)) (SETQ MAIL-FILE OTHER) T)) (LOAD-ALL-MSGS MAIL-FILE)))) (DEFUN MAIL-FILE-SAVE-SETUP (MAIL-FILE) (SETF (DISK-MAIL-FILE-STREAM MAIL-FILE) (OPEN (DISK-MAIL-FILE-PATHNAME MAIL-FILE) '(:OUT))) (SETF (DISK-MAIL-FILE-STATUS MAIL-FILE) ':SAVING)) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MAIL-FILE "Kill" KILL-MAIL-FILE NIL "Kill this mail file.") (DEFUN KILL-MAIL-FILE (MAIL-FILE) (FUNCALL MAIL-FILE ':KILL) DIS-NONE) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-EDIT-CURRENT-MSG *EDIT-MSG-DOCUMENTATION*) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-EDIT-CURRENT-MSG (STRING) (AND *MSG* (APPEND-TO-ARRAY STRING "L: edit this message."))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-EDIT-CURRENT-MSG "Edit the current message" () (MAKE-WINDOW-CURRENT *MSG-WINDOW*) (SELECT-WINDOW *MSG-WINDOW*) (SETQ *COMTAB* *MSG-COMTAB*) (LET ((OLD-DOC (FUNCALL (WINDOW-SHEET *WINDOW*) ':WHO-LINE-OVERRIDE-DOCUMENTATION-STRING))) (UNWIND-PROTECT (PROGN (LOCK-BACKGROUND-PROCESS) (LET ((*MODE-LINE-LIST* '("ZMail " "Editing message " "(" *MODE-NAME-LIST* (*MODE-QUANTITY-NAME* " <" *MODE-QUANTITY-NAME* ">") ") " *ZMAIL-FILE-NAME* *CURRENT-MSG-NAME*))) (BIND (LOCF (TV:BLINKER-DESELECTED-VISIBILITY (WINDOW-POINT-BLINKER *WINDOW*))) ':ON) (FUNCALL (WINDOW-SHEET *WINDOW*) ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING NIL) (FUNCALL-SELF ':EDIT) DIS-NONE)) (FUNCALL (WINDOW-SHEET *WINDOW*) ':SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING OLD-DOC) ;;Make sure the message is still separated ok (LET ((BP (INTERVAL-LAST-BP *MSG-INTERVAL*))) (OR (BEG-LINE-P BP) (INSERT BP #\CR)) (FUNCALL (MSG-MAIL-FILE *MSG*) ':UPDATE-MSG-END *MSG*)) (SETF (MSG-TICK *MSG*) (TICK)) ;Munge message (SETF (MSG-STATUS *MSG*) (SOME-PLIST (MSG-STATUS *MSG*) *INTERNAL-TYPE-PROPERTIES*)) (SET-PARSED-MSG-HEADERS *MSG*) (FUNCALL *SUMMARY-WINDOW* ':NEED-TO-REDISPLAY-MSG *MSG*) (SETF (WINDOW-MARK-P *MSG-WINDOW*) NIL) (ZMAIL-SELECT-MSG *MSG*) ;May not have losing headers any more, say (PROCESS-UNLOCK *ZMAIL-BACKGROUND-PROCESS-LOCK*) (FUNCALL-SELF ':SELECT NIL)))) ;;; Keyword stuff ;;; List of keywords on, keywords off (DEFINE-ZMAIL-GLOBAL *DEFAULT-KEYWORDS* NIL) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *FILTER-KEYWORDS-ALIST* COM-ZMAIL-KEYWORDS) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-ZMAIL-KEYWORDS *KEYWORDS-DOCUMENTATION*) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-KEYWORDS (STRING) (APPEND-TO-ARRAY STRING "Change keywords on this message: ") (COND (*DEFAULT-KEYWORDS* (APPEND-TO-ARRAY STRING "L:") (LET ((ON (CAR *DEFAULT-KEYWORDS*)) (OFF (CADR *DEFAULT-KEYWORDS*))) (COND (ON (APPEND-TO-ARRAY STRING " add ") (APPEND-TO-ARRAY STRING (STRING-FROM-KEYWORDS ON)))) (COND (OFF (AND ON (ARRAY-PUSH-EXTEND STRING #/,)) (APPEND-TO-ARRAY STRING " remove ") (APPEND-TO-ARRAY STRING (STRING-FROM-KEYWORDS OFF))))) (APPEND-TO-ARRAY STRING "; "))) (AND *FILTER-KEYWORDS-ALIST* (APPEND-TO-ARRAY STRING "M: by filters; ")) (APPEND-TO-ARRAY STRING "R: menu.")) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-KEYWORDS "Change keywords for the current message. Left does same as last keywords operation. Right gives a menu." () (ZMAIL-KEYWORDS-MSG *MSG*) DIS-NONE) (DEFUN ZMAIL-KEYWORDS-MSG (MSG &AUX OLD-KEYWORDS NEW-KEYWORDS) (SETQ OLD-KEYWORDS (MSG-GET MSG 'KEYWORDS)) (COND ((EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) (SETQ NEW-KEYWORDS (CHOOSE-KEYWORDS "Set keywords for this message:" OLD-KEYWORDS)) (SETQ *DEFAULT-KEYWORDS* (LIST (DO ((NEW NEW-KEYWORDS (CDR NEW)) (NEW-NEW NIL) (KEY)) ((NULL NEW) (NREVERSE NEW-NEW)) (SETQ KEY (CAR NEW)) (OR (MEMQ KEY OLD-KEYWORDS) (PUSH KEY NEW-NEW))) (DO ((OLD OLD-KEYWORDS (CDR OLD)) (OLD-OLD NIL) (KEY)) ((NULL OLD) (NREVERSE OLD-OLD)) (SETQ KEY (CAR OLD)) (OR (MEMQ KEY NEW-KEYWORDS) (PUSH KEY OLD-OLD))))) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-KEYWORDS)) ((MEMQ *ZMAIL-COMMAND-BUTTON* '(:KBD :MIDDLE)) (SETQ NEW-KEYWORDS (GET-KEYWORDS-FROM-MSG-BY-FILTERING MSG OLD-KEYWORDS))) (*DEFAULT-KEYWORDS* (SETQ NEW-KEYWORDS OLD-KEYWORDS) (DOLIST (KEY (CAR *DEFAULT-KEYWORDS*)) ;Keywords on (PUSH* KEY NEW-KEYWORDS)) (DOLIST (KEY (CADR *DEFAULT-KEYWORDS*)) ;Keywords off (SETQ NEW-KEYWORDS (REMQ KEY NEW-KEYWORDS)))) (T (BARF "There are no default keywords yet"))) (CHANGE-MSG-KEYWORDS MSG NEW-KEYWORDS OLD-KEYWORDS)) (DEFUN CHOOSE-KEYWORDS (&OPTIONAL LABEL OLD-KEYWORDS &AUX NEW-KEYWORDS) (FUNCALL *KEYWORD-WINDOW* ':SET-LABEL LABEL) (MULTIPLE-VALUE (*KEYWORD-ALIST* NEW-KEYWORDS) (FUNCALL *KEYWORD-WINDOW* ':MULTIPLE-CHOOSE *KEYWORD-ALIST* OLD-KEYWORDS (RECTANGLE-NEAR-COMMAND-MENU))) NEW-KEYWORDS) (DEFUN GET-KEYWORDS-FROM-MSG-BY-FILTERING (MSG &OPTIONAL OLD-KEYWORDS &AUX KEYWORDS) (SETQ KEYWORDS (LOOP FOR (FILTER . KEYWORDS) IN *FILTER-KEYWORDS-ALIST* WHEN (MSG-FITS-FILTER-P MSG FILTER) APPEND KEYWORDS)) (SETQ KEYWORDS (SI:ELIMINATE-DUPLICATES (APPEND KEYWORDS OLD-KEYWORDS))) (LOOP FOR KEYWORD IN KEYWORDS UNLESS (RASSQ KEYWORD *KEYWORD-ALIST*) DO (PUSH (CONS (STRING-DOWNCASE KEYWORD) KEYWORD) *KEYWORD-ALIST*)) KEYWORDS) (DEFUN CHANGE-MSG-KEYWORDS (MSG NEW-KEYWORDS OLD-KEYWORDS &AUX MSG-MAIL-FILE MAIL-FILE-KEYS) ;; Canonicalize the order of keywords for the msg to the order for the file. (SETQ MSG-MAIL-FILE (MSG-MAIL-FILE MSG) MAIL-FILE-KEYS (GET (LOCF (MAIL-FILE-OPTIONS MSG-MAIL-FILE)) ':KEYWORDS) NEW-KEYWORDS (LET ((*KEYWORD-ALIST* MAIL-FILE-KEYS)) (SORT NEW-KEYWORDS #'(LAMBDA (KEY1 KEY2) (DO ((L *KEYWORD-ALIST* (CDR L)) (KEY)) ((NULL L) (STRING-LESSP KEY1 KEY2)) (SETQ KEY (CDAR L)) (COND ((EQ KEY KEY1) (RETURN T)) ((EQ KEY KEY2) (RETURN NIL)))))))) (COND ((EQUAL OLD-KEYWORDS NEW-KEYWORDS)) ;Did not change (T (DO ((KEYS NEW-KEYWORDS (CDR KEYS)) (ELEM) (FLAG NIL)) ((NULL KEYS) (AND FLAG (SETF (GET (LOCF (MAIL-FILE-OPTIONS MSG-MAIL-FILE)) ':KEYWORDS) MAIL-FILE-KEYS))) (OR (MEMQ (SETQ ELEM (RASSQ (CAR KEYS) *KEYWORD-ALIST*)) MAIL-FILE-KEYS) (SETQ MAIL-FILE-KEYS (NCONC MAIL-FILE-KEYS (NCONS ELEM)) FLAG T))) (MSG-PUT MSG NEW-KEYWORDS 'KEYWORDS) (LET ((STRING (AND NEW-KEYWORDS (STRING-FROM-KEYWORDS NEW-KEYWORDS)))) (MSG-PUT MSG STRING 'KEYWORDS-STRING) (UPDATE-MSG-SUMMARY-LINE MSG ':KEYWORDS) (AND (EQ MSG *MSG*) (SETQ *CURRENT-MSG-KEYWORDS-STRING* (OR STRING "{}"))))))) (DEFUN STRING-FROM-KEYWORDS (KEYWORDS &AUX STR) (DO ((KEYS KEYWORDS (CDR KEYS)) (LENGTH 1)) ((NULL KEYS) (SETQ STR (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING))) (SETQ LENGTH (+ LENGTH (ARRAY-ACTIVE-LENGTH (CAR (RASSQ (CAR KEYS) *KEYWORD-ALIST*))) 1))) (ASET #/{ STR 0) (DO ((KEYS KEYWORDS (CDR KEYS)) (I0 1 (1+ I1)) (I1) (KEY) (LEN)) ((NULL KEYS) (ASET #/} STR I1)) (SETQ KEY (CAR (RASSQ (CAR KEYS) *KEYWORD-ALIST*)) LEN (ARRAY-ACTIVE-LENGTH KEY) I1 (+ I0 LEN)) (COPY-ARRAY-PORTION KEY 0 LEN STR I0 I1) (ASET #\SP STR I1)) STR) ;;; Some file commands (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-MOVE (STRING &OPTIONAL RECURSIVE) (OR RECURSIVE (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'GET-DEFAULTED-MOVE-MAIL-FILE NIL T)) (STRING-NCONC STRING "Move current message into mail file: " (GET 'GET-DEFAULTED-MOVE-MAIL-FILE ':WHO-LINE-DOCUMENTATION))) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION ZMAIL-SUMMARY-MOUSE *SUMMARY-MOVE-DOCUMENTATION*) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER ZMAIL-SUMMARY-MOVE (STRING &OPTIONAL RECURSIVE) (OR RECURSIVE (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'GET-DEFAULTED-MOVE-MAIL-FILE NIL T)) (STRING-NCONC STRING "Move this message into mail file: " (GET 'GET-DEFAULTED-MOVE-MAIL-FILE ':WHO-LINE-DOCUMENTATION))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MOVE "Move message into mail file. Click right for menu of existing mail files, to specify a new file, or for special destinations, such as Hardcopy." () (FUNCALL (GET-DEFAULTED-MOVE-MAIL-FILE *MSG*) ':ADD-MSG *MSG*) DIS-NONE) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *FILTER-MOVE-MAIL-FILE-ALIST* GET-DEFAULTED-MOVE-MAIL-FILE) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER GET-DEFAULTED-MOVE-MAIL-FILE (STRING &OPTIONAL RECURSIVE) (FORMAT STRING "~@[L: ~S; ~]~:[M: by filters ; ~]R: menu." (AND *DEFAULT-MOVE-MAIL-FILE* (FUNCALL *DEFAULT-MOVE-MAIL-FILE* ':NAME)) (NULL *FILTER-MOVE-MAIL-FILE-ALIST*)) (OR RECURSIVE (DOLIST (COM '(COM-ZMAIL-MOVE COM-ZMAIL-MOVE-ALL-TO-FILE ZMAIL-SUMMARY-MOVE)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION COM NIL T)))) (DEFUN GET-DEFAULTED-MOVE-MAIL-FILE (&OPTIONAL MSG FOR-WHOLE-FILE-P &AUX NEW-P) (COND ((NEQ *ZMAIL-COMMAND-BUTTON* ':LEFT) (MULTIPLE-VALUE (*DEFAULT-MOVE-MAIL-FILE* NEW-P) (GET-MOVE-MAIL-FILE (AND (NEQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) MSG) FOR-WHOLE-FILE-P)) (OR *DEFAULT-MOVE-MAIL-FILE* (ABORT-CURRENT-COMMAND)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'GET-DEFAULTED-MOVE-MAIL-FILE)) ((NULL *DEFAULT-MOVE-MAIL-FILE*) (BARF "There is no default mail file to move to"))) (OR NEW-P (TYPEIN-LINE "Moved to ~A" (FUNCALL *DEFAULT-MOVE-MAIL-FILE* ':NAME))) *DEFAULT-MOVE-MAIL-FILE*) ;;; MSG is a message to check with filters and look for a mail file from ;;; *FILTER-MOVE-MAIL-FILE-ALIST*. (DEFUN GET-MOVE-MAIL-FILE (&OPTIONAL MSG FOR-WHOLE-FILE-P &AUX ITEM-LIST NEW-P) (DECLARE (RETURN-LIST MAIL-FILE NEW-P)) (MULTIPLE-VALUE-BIND (MAIL-FILE-ALIST TEMP-MAIL-FILE-ALIST) (GET-MAIL-FILE-ALISTS T) (SETQ ITEM-LIST (TV:APPEND-ITEM-LISTS MAIL-FILE-ALIST TEMP-MAIL-FILE-ALIST))) (SETQ ITEM-LIST (APPEND ITEM-LIST (AND (ODDP (LENGTH ITEM-LIST)) '(("" :NO-SELECT T))) '(("New temporary" :VALUE :NEW-TEMP :FONT FONTS:HL12I :DOCUMENTATION "Move into a new temporary mail file, whose name is read from the keyboard.") ("Recycled temporary" :VALUE :OLD-TEMP :FONT FONTS:HL12I :DOCUMENTATION "Move into the automatically generated temporary mail file, /"Temp/".") ("Find file" :VALUE :FIND-FILE :FONT FONTS:HL12I :DOCUMENTATION "Move into a new disk mail file, pathname is read from the keyboard.") ("Just text" :VALUE :TEXT-FILE :FONT FONTS:HL12I :DOCUMENTATION "Move into a new write-only disk mail file, messages are separated just by blank lines") ("Abort" :VALUE :ABORT :FONT FONTS:HL12I :DOCUMENTATION "Abort this command.") ("Hardcopy" :BUTTONS (:HARDCOPY NIL :HARDCOPY-WITH-OPTIONS) :FONT FONTS:HL12I :DOCUMENTATION "Print on a hardcopy device. Click right to get hardcopy options.")))) (OR (EQUAL ITEM-LIST (FUNCALL *MOVE-MAIL-FILE-MENU* ':ITEM-LIST)) (FUNCALL *MOVE-MAIL-FILE-MENU* ':SET-ITEM-LIST ITEM-LIST)) (UNWIND-PROTECT (PROGN (DO ((MAIL-FILE) (ALWAYS-NEW-FLAVOR NIL NIL)) (NIL) (IF MSG ;; Let the user get out anything that could appear in the menu, including ;; hardcopy :FIND-FILE, :MENU-CHOOSE, etc. (SETQ MAIL-FILE (LOOP FOR (FILTER . MAIL-FILE) IN *FILTER-MOVE-MAIL-FILE-ALIST* WHEN (OR (EQ FILTER T) (MSG-FITS-FILTER-P MSG FILTER)) DO (RETURN MAIL-FILE) FINALLY (BARF "Cannot find suitable filter"))) ;; This is a noop if already exposed (TV:EXPOSE-WINDOW-NEAR *MOVE-MAIL-FILE-MENU* (RECTANGLE-NEAR-COMMAND-MENU)) (SETQ MAIL-FILE (FUNCALL *MOVE-MAIL-FILE-MENU* ':CHOOSE)) (SET-COMMAND-BUTTON (FUNCALL *MOVE-MAIL-FILE-MENU* ':LAST-BUTTONS))) (AND (EQ MAIL-FILE ':MENU-CHOOSE) (SETQ MAIL-FILE NIL MSG NIL)) (AND (EQ MAIL-FILE ':ABORT) (ABORT-CURRENT-COMMAND)) (AND (EQ MAIL-FILE ':NEW-TEMP) (LET ((NAME (CALL-POP-UP-MINI-BUFFER-EDITOR *MOVE-MAIL-FILE-MENU* #'TYPEIN-LINE-READLINE "New temporary"))) (AND (NOT (SYMBOLP NAME)) (SETQ MAIL-FILE (MAKE-NEW-TEMP-MAIL-FILE NAME))))) (AND (EQ MAIL-FILE ':OLD-TEMP) (SETQ MAIL-FILE (GET-RECYCLED-TEMP-MAIL-FILE "Temp"))) (AND (MEMQ MAIL-FILE '(:HARDCOPY :HARDCOPY-WITH-OPTIONS)) (SETQ MAIL-FILE (MAKE-HARDCOPY-MAIL-FILE (EQ MAIL-FILE ':HARDCOPY-WITH-OPTIONS) FOR-WHOLE-FILE-P `(:WINDOW ,*MOVE-MAIL-FILE-MENU*)))) (AND (MEMQ MAIL-FILE '(:FIND-FILE :TEXT-FILE)) (*CATCH 'ZWEI-COMMAND-LOOP ;In case of G (LET ((DEFAULT (IF (AND *DEFAULT-MOVE-MAIL-FILE* (MAIL-FILE-DISK-P *DEFAULT-MOVE-MAIL-FILE*)) (DISK-MAIL-FILE-PATHNAME *DEFAULT-MOVE-MAIL-FILE*) (DEFAULT-ZMAIL-MOVE-PATHNAME)))) (SETQ ALWAYS-NEW-FLAVOR (AND (EQ MAIL-FILE ':TEXT-FILE) 'TEXT-MAIL-FILE) MAIL-FILE NIL) (SETQ MAIL-FILE (MAYBE-CALL-POP-UP-MINI-BUFFER-EDITOR *MOVE-MAIL-FILE-MENU* #'READ-DEFAULTED-PATHNAME (IF ALWAYS-NEW-FLAVOR "Make text mail file" "Find mail file") DEFAULT (AND *MOVE-FILE-NAME-STICKY-FN2* (FUNCALL DEFAULT ':TYPE)) NIL (IF ALWAYS-NEW-FLAVOR ':WRITE ':NEW-OK)))))) (AND (OR (STRINGP MAIL-FILE) (TYPEP MAIL-FILE 'FS:PATHNAME)) (LET ((PATHNAME MAIL-FILE)) (OR (SETQ MAIL-FILE (GET-MAIL-FILE-FROM-PATHNAME MAIL-FILE NIL)) (MULTIPLE-VALUE (MAIL-FILE NEW-P) (MAKE-NEW-MAIL-FILE PATHNAME `(:WINDOW ,*MOVE-MAIL-FILE-MENU*) ALWAYS-NEW-FLAVOR ALWAYS-NEW-FLAVOR))))) (AND MAIL-FILE (RETURN MAIL-FILE NEW-P)))) (FUNCALL *MOVE-MAIL-FILE-MENU* ':DEACTIVATE))) (DEFUN GET-MAIL-FILE-ALISTS (&OPTIONAL OTHERS-TOO &AUX MFL TMFL) (DOLIST (MAIL-FILE *MAIL-FILE-LIST*) (LET ((ELEM (CONS (MAIL-FILE-NAME MAIL-FILE) MAIL-FILE))) (IF (MAIL-FILE-DISK-P MAIL-FILE) (PUSH ELEM MFL) (PUSH ELEM TMFL)))) (SETQ MFL (SORTCAR MFL #'STRING-LESSP) TMFL (SORTCAR TMFL #'STRING-LESSP)) (AND OTHERS-TOO (DOLIST (FILE-NAME *OTHER-MAIL-FILE-NAMES*) (OR (ASSOC FILE-NAME MFL) (SETQ MFL (NCONC MFL (NCONS (CONS FILE-NAME FILE-NAME))))))) (VALUES MFL TMFL)) (DEFUN SOME-PLIST (PLIST PROPERTIES) (DO ((PLIST PLIST (CDDR PLIST)) (LIST NIL)) ((NULL PLIST) (NREVERSE LIST)) (COND ((MEMQ (CAR PLIST) PROPERTIES) (PUSH (CAR PLIST) LIST) (PUSH (CADR PLIST) LIST))))) (DEFUN SOME-PLIST-NOT (PLIST PROPERTIES) (DO ((PLIST PLIST (CDDR PLIST)) (LIST NIL)) ((NULL PLIST) (NREVERSE LIST)) (COND ((NOT (MEMQ (CAR PLIST) PROPERTIES)) (PUSH (CAR PLIST) LIST) (PUSH (CADR PLIST) LIST))))) (DEFUN DEFAULT-ZMAIL-MOVE-PATHNAME () (IF *DEFAULT-MOVE-MAIL-FILE-NAME* (FS:MERGE-PATHNAME-DEFAULTS *DEFAULT-MOVE-MAIL-FILE-NAME* *ZMAIL-PATHNAME-DEFAULTS*) (FS:MERGE-PATHNAME-DEFAULTS USER-ID (FS:USER-HOMEDIR) "XMAIL"))) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-RENAME-MAIL-FILE (STRING &AUX ELEM) (SETQ ELEM (ASSQ '*ZMAIL-FILE-NAME* *SELECTABLE-MODE-LINE-ELEMENTS*)) (IF (NULL *MAIL-FILE*) (AND ELEM (SETQ *SELECTABLE-MODE-LINE-ELEMENTS* (DELQ ELEM *SELECTABLE-MODE-LINE-ELEMENTS*))) (OR ELEM (PUSH '(*ZMAIL-FILE-NAME* . COM-ZMAIL-RENAME-MAIL-FILE) *SELECTABLE-MODE-LINE-ELEMENTS*)) (FORMAT STRING "Change the ~:[file~]name of this mail file." (NOT (MAIL-FILE-DISK-P *MAIL-FILE*))))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-RENAME-MAIL-FILE "Change the name of this mail file." (NO-MSG-OK) (LET ((NEW-NAME (WITH-BACKGROUND-PROCESS-LOCKED (IF (MAIL-FILE-DISK-P *MAIL-FILE*) (READ-DEFAULTED-PATHNAME "New filename" (DISK-MAIL-FILE-PATHNAME *MAIL-FILE*) NIL NIL ':WRITE) (TYPEIN-LINE-READLINE "New name for ~A:" (MAIL-FILE-NAME *MAIL-FILE*)))))) (COND ((MAIL-FILE-DISK-P *MAIL-FILE*) (SETF (DISK-MAIL-FILE-PATHNAME *MAIL-FILE*) NEW-NAME) (SETQ NEW-NAME (STRING NEW-NAME)) (SETF (DISK-MAIL-FILE-ID *MAIL-FILE*) T))) ;Also means it must be saved out (SETF (MAIL-FILE-NAME *MAIL-FILE*) NEW-NAME) (SETQ *ZMAIL-FILE-NAME* NEW-NAME)) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-REFRESH "Complete redisplay" (NO-MAIL-FILE-OK) (DOLIST (WINDOW *WINDOW-LIST*) (FUNCALL (WINDOW-TYPEOUT-WINDOW WINDOW) ':MAKE-COMPLETE)) (FUNCALL-SELF ':REFRESH) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-START-OF-MSG "Scroll back to start of message" (NO-MAIL-FILE-OK) (REDISPLAY *WINDOW* ':START (INTERVAL-FIRST-BP *INTERVAL*)) DIS-NONE) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-ZMAIL-MODE-LINE-SCROLL "Scroll message: L: forward; M: backward; R: menu." ) (DEFINE-ZMAIL-GLOBAL *LAST-MODE-LINE-SCROLL-ITEM* NIL) (DEFVAR *MODE-LINE-SCROLL-MENU-ALIST* '(("Forward" :VALUE :FORWARD :DOCUMENTATION "Scroll message forward a screenful.") ("Backward" :VALUE :BACKWARD :DOCUMENTATION "Scroll message backward a screenful.") ("Beginning" :VALUE :BEGINNING :DOCUMENTATION "Scroll to top of message.") ("End" :VALUE :END :DOCUMENTATION "Scroll to end of message"))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MODE-LINE-SCROLL "Scroll the message window. Left scrolls forward, middle scrolls backward, right gives a menu." (NO-MAIL-FILE-OK) (LET ((MODE ':FORWARD) (N-PLINES (WINDOW-N-PLINES *WINDOW*))) (AND (MEMQ *ZMAIL-COMMAND-BUTTON* '(:MIDDLE :RIGHT)) (MULTIPLE-VALUE (MODE *LAST-MODE-LINE-SCROLL-ITEM*) (ZMAIL-MENU-CHOOSE NIL *MODE-LINE-SCROLL-MENU-ALIST* *LAST-MODE-LINE-SCROLL-ITEM* NIL ':BACKWARD))) (SELECTQ MODE (:FORWARD (RECENTER-WINDOW-RELATIVE *WINDOW* (- N-PLINES 1))) (:BACKWARD (RECENTER-WINDOW-RELATIVE *WINDOW* (- 1 N-PLINES))) (:BEGINNING (RECENTER-WINDOW *WINDOW* ':START (INTERVAL-FIRST-BP *INTERVAL*))) (:END (MOVE-BP (POINT) (INTERVAL-LAST-BP *INTERVAL*)) (RECENTER-WINDOW *WINDOW* ':ABSOLUTE (// (1- N-PLINES) (SMALL-FLOAT N-PLINES)))))) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-SCROLL-SUMMARY-WINDOW "Scroll the summary window" (NO-MSG-OK NUMERIC-ARG-OK) (OR (MEMQ *WINDOW-CONFIGURATION* *MSG-AND-SUMMARY-CONFIGURATIONS*) (BARF)) (LET* ((TYPE ':RELATIVE) (ARG (COND ((ZEROP *NUMERIC-ARG*) (SETQ TYPE ':ABSOLUTE) ;Arg of zero put current msg at top (MSG-DISPLAYED-INDEX *MSG*)) ((MEMQ *NUMERIC-ARG-P* '(:DIGITS :CONTROL-U)) ;Explicit arg *NUMERIC-ARG*) ;Scroll that many lines (T (* *NUMERIC-ARG* ;Else scroll a screenful (1- (TV:SHEET-NUMBER-OF-INSIDE-LINES *SUMMARY-WINDOW*))))))) (FUNCALL *SUMMARY-WINDOW* ':SCROLL-TO ARG TYPE)) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-JUMP "Move to a specific message" (NUMERIC-ARG-OK) (IF *NUMERIC-ARG-P* (ZMAIL-SELECT-MSG (1- (RANGE *NUMERIC-ARG* 1 (MAIL-FILE-NMSGS *MAIL-FILE*)))) (COM-ZMAIL-NEXT-OR-PREVIOUS-INTERNAL ':FIRST-UNDELETED))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-BREAK "Break loop" (NO-MAIL-FILE-OK) (FUNCALL *TYPEOUT-WINDOW* ':OUTPUT-HOLD-EXCEPTION) (TV:WINDOW-CALL (*TYPEOUT-WINDOW*) (UNWIND-PROTECT (LET ((*INSIDE-BREAK* T)) (BREAK ZMAIL)) (FUNCALL-SELF ':EXPOSE-MODE-LINE-WINDOW)) (FUNCALL *TYPEOUT-WINDOW* ':MAKE-COMPLETE)) DIS-NONE) (DEFINE-ZMAIL-GLOBAL *LAST-MAP-MENU-ITEM* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-MAP (STRING) (FORMAT STRING "Operate on all messages: ~@[L: ~A; ~]~@[M: ~A; ~]R: menu." (CAR *LAST-MAP-MENU-ITEM*) (NAME-FROM-MENU-VALUE *MAP-MIDDLE-MODE* *ZMAIL-MAP-COMMAND-ALIST*))) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *MAP-MIDDLE-MODE* COM-ZMAIL-MAP) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MAP "Perform operation on these messages. Left defaults to same as last Map command. Middle is a user option. Right gives menu of operations." (NO-MSG-OK NUMERIC-ARG-OK) (LET (COMMAND) (MULTIPLE-VALUE (COMMAND *LAST-MAP-MENU-ITEM*) (ZMAIL-MENU-CHOOSE *ZMAIL-MAP-COMMAND-MENU* NIL *LAST-MAP-MENU-ITEM* NIL *MAP-MIDDLE-MODE*)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-MAP) (FUNCALL COMMAND))) (DEFPROP COM-ZMAIL-DELETE COM-ZMAIL-DELETE-ALL ASSOCIATED-ALL-COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-DELETE-ALL "Delete these messages." () (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY) (DOMSGS (MSG *MAIL-FILE*) (OR (MSG-GET MSG 'DELETED) (MSG-PUT MSG T 'DELETED))) (ZMAIL-SELECT-MSG *MSG* NIL NIL)) ;;; This is separate so that it can move to the next undeleted message (DEFUN (COM-ZMAIL-DELETE ASSOCIATED-MAP-COMMAND) (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (FUNCALL MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG #'(LAMBDA (MSG IGNORE) (OR (MSG-GET MSG 'DELETED) (MSG-PUT MSG T 'DELETED))) NIL) (IF (AND *MSG* (MSG-GET *MSG* 'DELETED)) (MOVE-AFTER-DELETE (CHOOSE-DELETE-MODE)) DIS-NONE)) (DEFPROP COM-ZMAIL-UNDELETE COM-ZMAIL-UNDELETE-ALL ASSOCIATED-ALL-COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-UNDELETE-ALL "Undelete all these messages." () (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY) (DOMSGS (MSG *MAIL-FILE*) (AND (MSG-GET MSG 'DELETED) (MSG-PUT MSG NIL 'DELETED))) (ZMAIL-SELECT-MSG *MSG* NIL NIL)) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-TYPE "Type this message." () (USING-OVERLYING-WINDOW (FUNCALL *OVERLYING-WINDOW* ':VIEW-STREAM (INTERVAL-STREAM (MSG-INTERVAL *MSG*)))) DIS-NONE) (DEFPROP COM-ZMAIL-TYPE COM-ZMAIL-TYPE-ALL ASSOCIATED-ALL-COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-TYPE-ALL "Type out all these messages." () (USING-OVERLYING-WINDOW (FUNCALL *OVERLYING-WINDOW* ':VIEW-STREAM (MAKE-MAIL-FILE-STREAM *MAIL-FILE*))) DIS-NONE) (DEFUN MAKE-MAIL-FILE-STREAM (MAIL-FILE) (LET-CLOSED ((*ARRAY* (MAIL-FILE-ARRAY MAIL-FILE)) (*I* -1) (*LINE*) (*END-LINE*)) 'MAIL-FILE-IO)) ;;; Bare minimum for typing out purposes (LOCAL-DECLARE ((SPECIAL *ARRAY* *I* *LINE* *END-LINE*)) (DEFSELECT MAIL-FILE-IO (:LINE-IN (&OPTIONAL SIZE EOF) (COND ((NULL *LINE*) (IF ( (SETQ *I* (1+ *I*)) (ARRAY-ACTIVE-LENGTH *ARRAY*)) (IF EOF (ERROR EOF) (VALUES (CANONICALIZE-LINE "" SIZE) T)) (LET ((MSG (AREF *ARRAY* *I*))) (SETQ *LINE* (BP-LINE (MSG-START-BP MSG)) *END-LINE* (BP-LINE (MSG-END-BP MSG)))) (MAIL-FILE-IO ':LINE-IN SIZE EOF))) ((EQ *LINE* *END-LINE*) (SETQ *LINE* NIL) (CANONICALIZE-LINE "" SIZE)) (T (PROG1 (CANONICALIZE-LINE *LINE* SIZE) (SETQ *LINE* (LINE-NEXT *LINE*)))))) (:CLOSE (&REST IGNORE) T) (:CURRENT-MSG-NO () *I*))) (DEFUN CANONICALIZE-LINE (LINE SIZE &AUX LEN RET-LINE) (IF (NULL SIZE) LINE (SETQ LEN (ARRAY-ACTIVE-LENGTH LINE) RET-LINE (MAKE-ARRAY LEN ':TYPE 'ART-STRING ':LEADER-LENGTH (IF (NUMBERP SIZE) SIZE NIL))) (COPY-ARRAY-CONTENTS LINE RET-LINE) (AND (NUMBERP SIZE) (STORE-ARRAY-LEADER LEN RET-LINE 0)) RET-LINE)) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-FIND-STRING "Move to next message containing specified string" (NUMERIC-ARG-OK) (LET ((DELTA (IF (MINUSP *NUMERIC-ARG*) -1 +1)) (ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*)) FUN STR) (MULTIPLE-VALUE (FUN STR) (ZMAIL-READ-FIND-SEARCH-STRING (IF (= DELTA +1) "Find string" "Find string reverse"))) (DO ((I (+ *MSG-NO* DELTA) (+ I DELTA)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (MSG)) ((OR (< I 0) ( I NMSGS)) (BARF "Search failed: ~A" (STRING-APPEND "" STR))) (SETQ MSG (AREF ARRAY I)) (AND (NOT (MSG-GET MSG 'DELETED)) ;Not if deleted (is this right?) (FUNCALL FUN (MSG-START-BP MSG) STR NIL NIL NIL (MSG-END-BP MSG)) (RETURN (ZMAIL-SELECT-MSG I)))))) (DEFINE-ZMAIL-GLOBAL *INTERVAL-TO-BE-YANKED* NIL) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-DELETE-AND-SAVE-MSG "Delete the current msg and save its text to be yanked back" () (LET ((BP (INTERVAL-LAST-BP (OR *INTERVAL-TO-BE-YANKED* (SETQ *INTERVAL-TO-BE-YANKED* (CREATE-INTERVAL)))))) (INSERT-INTERVAL BP (MSG-INTERVAL *MSG*)) (ONE-BLANK-LINE BP)) (COM-ZMAIL-DELETE)) (DEFUN ONE-BLANK-LINE (BP &AUX (*INTERVAL* (BP-TOP-LEVEL-NODE BP))) (DELETE-AROUND '(#\CR) BP) (OR (BEG-LINE-P BP) (INSERT-MOVING BP #\CR)) (OR (LINE-BLANK-P (BP-LINE BP)) (INSERT BP #\CR))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-YANK-MSG "Appends message to end of current msg. Messages is either specified by a numeric argument or the last message deleted is used." (NUMERIC-ARG-OK) (LET ((INTERVAL (OR (PROG1 *INTERVAL-TO-BE-YANKED* (SETQ *INTERVAL-TO-BE-YANKED* NIL)) (LET ((MSG (IF *NUMERIC-ARG-P* (GET-MSG-FROM-ARG) *LAST-DELETED-MSG*))) (AND (EQ MSG *MSG*) (BARF "Can't yank a message into itself")) (MSG-PUT MSG T 'DELETED) (MSG-INTERVAL MSG))))) ;;This uses (POINT) because it really wants to end up between the messages (LET ((POINT (POINT))) (MOVE-BP POINT (MSG-END-BP *MSG*)) (INSERT-INTERVAL POINT INTERVAL) (ONE-BLANK-LINE POINT))) DIS-TEXT) (DEFUN GET-MSG-FROM-ARG () (AND (OR (< *NUMERIC-ARG* 1) (> *NUMERIC-ARG* (MAIL-FILE-NMSGS *MAIL-FILE*))) (BARF "Argument out of range")) (AREF (MAIL-FILE-ARRAY *MAIL-FILE*) (1- *NUMERIC-ARG*))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-OCCUR "Show lines within messages containing the given search string." () (SETQ *TYPEOUT-WINDOW* (IF (TV:SHEET-EXPOSED-P *SUMMARY-WINDOW*) (FUNCALL *SUMMARY-WINDOW* ':TYPEOUT-WINDOW) (WINDOW-TYPEOUT-WINDOW *WINDOW*))) (MULTIPLE-VALUE-BIND (FUN STR) (ZMAIL-READ-FIND-STRING-SEARCH-STRING "Message lines containing") (DO ((STREAM (MAKE-MAIL-FILE-STREAM *MAIL-FILE*)) (LINE) (EOF)) (NIL) (MULTIPLE-VALUE (LINE EOF) (FUNCALL STREAM ':LINE-IN NIL)) (AND EOF (RETURN NIL)) (COND ((FUNCALL FUN STR LINE) (FUNCALL *TYPEOUT-WINDOW* ':TRUNCATED-ITEM 'MSG-LINE LINE) (FUNCALL *TYPEOUT-WINDOW* ':TYO #\CR))))) DIS-NONE) (DEFINE-ZMAIL-GLOBAL *ZMAIL-FIND-DEFAULT* NIL) (DEFVAR *ZMAIL-FIND-STRING-SEARCH-DEFAULT*) (DEFVAR *ZMAIL-FIND-SEARCH-DEFAULT*) (DEFUN ZMAIL-READ-FIND-STRING-SEARCH-STRING (PROMPT) (DECLARE (RETURN-LIST FUNCTION KEY)) (ZMAIL-READ-FIND-STRING PROMPT) (PROG () (RETURN-LIST *ZMAIL-FIND-STRING-SEARCH-DEFAULT*))) (DEFUN ZMAIL-READ-FIND-SEARCH-STRING (PROMPT) (DECLARE (RETURN-LIST FUNCTION KEY)) (ZMAIL-READ-FIND-STRING PROMPT) (PROG () (RETURN-LIST *ZMAIL-FIND-SEARCH-DEFAULT*))) (DEFUN ZMAIL-READ-FIND-STRING (PROMPT &AUX STR) (SETQ STR (WITH-BACKGROUND-PROCESS-LOCKED (GET-EXTENDED-SEARCH-16B-STRING (FORMAT NIL "~A~@[ (Default: ~A)~]" PROMPT *ZMAIL-FIND-DEFAULT* *ZMAIL-FIND-DEFAULT*)))) (COND ((STRING-EQUAL STR "")) ;Leave defaults alone (T (SETQ *ZMAIL-FIND-DEFAULT* STR) ;Save for next time (MULTIPLE-VALUE-BIND (STRINGS EXPR CR-P) (PARSE-EXTENDED-SEARCH-STRING STR) (SETQ *ZMAIL-FIND-SEARCH-DEFAULT* (COND ((NLISTP STRINGS) `(SEARCH ,STRINGS)) (EXPR `(FSM-EXPR-SEARCH (,STRINGS ,EXPR))) (T `(FSM-SEARCH ,STRINGS))) *ZMAIL-FIND-STRING-SEARCH-DEFAULT* (IF (OR (LISTP STRINGS) CR-P) `(FSM-STRING-SEARCH (,(IF (LISTP STRINGS) STRINGS `(,STRINGS)) ,EXPR ,CR-P)) `(STRING-SEARCH ,STRINGS))))))) (DEFUN CALL-POP-UP-MINI-BUFFER-EDITOR (WHERE FUNCTION &REST ARGS &AUX VAL) (WITH-BACKGROUND-PROCESS-LOCKED (SETQ VAL (LEXPR-FUNCALL *POP-UP-MINI-BUFFER-EDITOR* ':CALL-MINI-BUFFER-NEAR-WINDOW WHERE FUNCTION ARGS))) (AND (SYMBOLP VAL) (ABORT-CURRENT-COMMAND)) VAL) (DEFUN MAYBE-CALL-POP-UP-MINI-BUFFER-EDITOR (WHERE FUNCTION &REST ARGS) (WITH-BACKGROUND-PROCESS-LOCKED (IF (TV:SHEET-EXPOSED-P WHERE) (LEXPR-FUNCALL #'CALL-POP-UP-MINI-BUFFER-EDITOR WHERE FUNCTION ARGS ) (APPLY FUNCTION ARGS)))) (DEFPROP COM-ZMAIL-KEYWORDS COM-ZMAIL-KEYWORDS-ALL ASSOCIATED-ALL-COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-KEYWORDS-ALL "Put some keywords on all these messages." () (ZMAIL-KEYWORDS-ALL T)) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-UNKEYWORDS-ALL "Remove some keywords from all these messages." () (ZMAIL-KEYWORDS-ALL NIL)) (DEFUN ZMAIL-KEYWORDS-ALL (ON-P &AUX KEYWORDS) (SETQ KEYWORDS (SELECTQ *ZMAIL-COMMAND-BUTTON* ((:LEFT :KBD) (BARF)) (:MIDDLE (LET ((MSG (FIRST-MSG-IF-ANY))) (OR MSG (BARF)) (GET-KEYWORDS-FROM-MSG-BY-FILTERING MSG))) (:RIGHT (CHOOSE-KEYWORDS (FORMAT NIL "Keywords to ~:[remove from~;add to~] all messages:" ON-P))))) (DOMSGS (MSG *MAIL-FILE*) (LET* ((OLD-KEYWORDS (MSG-GET MSG 'KEYWORDS)) (NEW-KEYWORDS (IF ON-P (DO ((L KEYWORDS (CDR L)) (NL (REVERSE OLD-KEYWORDS))) ((NULL L) (NREVERSE NL)) (OR (MEMQ (CAR L) NL) (PUSH (CAR L) NL))) (DO ((L OLD-KEYWORDS (CDR L)) (NL NIL)) ((NULL L) (NREVERSE NL)) (OR (MEMQ (CAR L) KEYWORDS) (PUSH (CAR L) NL)))))) (CHANGE-MSG-KEYWORDS MSG NEW-KEYWORDS OLD-KEYWORDS))) (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY) (ZMAIL-SELECT-MSG *MSG* NIL NIL)) ;Update mode line, etc. ;;; Useful for things that decide based on attributes of a message, pick one ;;; at random. (DEFUN FIRST-MSG-IF-ANY (&OPTIONAL (MAIL-FILE *MAIL-FILE*)) (AND MAIL-FILE (PLUSP (MAIL-FILE-NMSGS MAIL-FILE)) (AREF (MAIL-FILE-ARRAY MAIL-FILE) 0))) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-MOVE-ALL-TO-FILE (STRING &OPTIONAL RECURSIVE) (OR RECURSIVE (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'GET-DEFAULTED-MOVE-MAIL-FILE NIL T)) (STRING-NCONC STRING "Move these messages into mail file: " (GET 'GET-DEFAULTED-MOVE-MAIL-FILE ':WHO-LINE-DOCUMENTATION))) (DEFPROP COM-ZMAIL-MOVE COM-ZMAIL-MOVE-ALL-TO-FILE ASSOCIATED-ALL-COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MOVE-ALL-TO-FILE "Move messages into a mail file. Click right for menu of destinations." () (LET ((*MSG* ':NO-SELECT)) (FUNCALL (GET-DEFAULTED-MOVE-MAIL-FILE (FIRST-MSG-IF-ANY) T) ':ADD-MAIL-FILE *MAIL-FILE*)) (ZMAIL-SELECT-MSG *MSG* NIL NIL) DIS-NONE) (DEFVAR *MSG-SORT-KEY-ALIST* `((,@*SORT-KEY-ALIST-1* ("Position" :VALUE MSG-POSITION-LESSP :DOCUMENTATION "Numerically by position in associated disk mail file.")) (("Forward" :VALUE :FORWARD :DOCUMENTATION "Perform sort forwards (least first).") ("Backward" :VALUE :BACKWARD :DOCUMENTATION "Perform sort backwards (greatest first).")))) (DEFINE-ZMAIL-GLOBAL *LAST-SORT-MODE* 'MSG-DATE-SORT-LESSP) (DEFINE-ZMAIL-GLOBAL *LAST-SORT-DIRECTION* ':FORWARD) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-SORT (STRING &AUX MAIL-FILE-MODE) (APPEND-TO-ARRAY STRING "Sort mail file:") (APPEND-MULTIPLE-MENU-DOCUMENTATION STRING *MSG-SORT-KEY-ALIST* "by" #/L *LAST-SORT-MODE* *LAST-SORT-DIRECTION*) (AND *MAIL-FILE* (SETQ MAIL-FILE-MODE (GET (LOCF (MAIL-FILE-OPTIONS *MAIL-FILE*)) ':SORT)) (APPEND-MULTIPLE-MENU-DOCUMENTATION STRING *MSG-SORT-KEY-ALIST* "by" #/M MAIL-FILE-MODE (IF (MAIL-FILE-APPEND-P *MAIL-FILE*) ':FORWARD ':BACKWARD))) (APPEND-TO-ARRAY STRING " R: menu.")) (DEFUN APPEND-MULTIPLE-MENU-DOCUMENTATION (STRING ALIST NAME BUTTON MODE DIRECTION &AUX NAME-1 NAME-2) (COND ((AND (SETQ NAME-1 (NAME-FROM-MENU-VALUE DIRECTION (CADR ALIST))) (SETQ NAME-2 (NAME-FROM-MENU-VALUE MODE (CAR ALIST)))) (ARRAY-PUSH-EXTEND STRING #\SP) (ARRAY-PUSH-EXTEND STRING BUTTON) (APPEND-TO-ARRAY STRING ": ") (APPEND-TO-ARRAY STRING NAME-1) (ARRAY-PUSH-EXTEND STRING #\SP) (APPEND-TO-ARRAY STRING NAME) (ARRAY-PUSH-EXTEND STRING #\SP) (APPEND-TO-ARRAY STRING NAME-2) (ARRAY-PUSH-EXTEND STRING #/;)))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SORT "Sort the current mail file. Click right to specify sort key and//or direction." () (LET ((MODE *LAST-SORT-MODE*) (DIRECTION *LAST-SORT-DIRECTION*)) (SELECTQ *ZMAIL-COMMAND-BUTTON* (:MIDDLE (SETQ MODE (OR (GET (LOCF (MAIL-FILE-OPTIONS *MAIL-FILE*)) ':SORT) 'MSG-NOOP-SORT-LESSP) DIRECTION (IF (MAIL-FILE-APPEND-P *MAIL-FILE*) ':FORWARD ':BACKWARD))) (:RIGHT (MULTIPLE-VALUE (MODE DIRECTION) (DEFAULTED-MULTIPLE-MENU-CHOOSE-NEAR-MENU *MSG-SORT-KEY-ALIST* *LAST-SORT-MODE* *LAST-SORT-DIRECTION*)) (SETQ *LAST-SORT-MODE* MODE *LAST-SORT-DIRECTION* DIRECTION) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-SORT))) (SORT-MAIL-FILE *MAIL-FILE* MODE (EQ DIRECTION ':FORWARD)))) (DEFUN SORT-MAIL-FILE (MAIL-FILE MODE FORWARD-P) (AND (MAIL-FILE-DISK-P MAIL-FILE) (FOREGROUND-BACKGROUND-FINISH MAIL-FILE NIL)) ;; Parse everything now, just in case. (DOMSGS (MSG MAIL-FILE) (ASSURE-MSG-PARSED MSG)) (FUNCALL (IF FORWARD-P #'STABLE-SORT #'REVERSE-STABLE-SORT) (MAIL-FILE-ARRAY MAIL-FILE) MODE) (AND (MAIL-FILE-DISK-P MAIL-FILE) (RESPLICE-MAIL-FILE MAIL-FILE)) (COND ((EQ MAIL-FILE *MAIL-FILE*) (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY) (ZMAIL-SELECT-MSG *MSG* NIL NIL)))) ;;; Keep the status quo (DEFUN MSG-NOOP-SORT-LESSP (MSG-1 MSG-2) MSG-1 MSG-2 NIL) (DEFUN MSG-DATE-SORT-LESSP (MSG-1 MSG-2) (< (OR (MSG-GET MSG-1 ':DATE) -1) (OR (MSG-GET MSG-2 ':DATE) -1))) (DEFUN MSG-TO-STRING-LESSP (MSG-1 MSG-2) (MSG-RECIPIENT-LESSP ':TO MSG-1 MSG-2)) (DEFUN MSG-FROM-STRING-LESSP (MSG-1 MSG-2) (MSG-RECIPIENT-LESSP ':FROM MSG-1 MSG-2)) (DEFUN MSG-RECIPIENT-LESSP (TYPE MSG-1 MSG-2) (MSG-RECIPIENT-LESSP-1 (MSG-GET MSG-1 TYPE) (MSG-GET MSG-2 TYPE))) (DEFUN MSG-RECIPIENT-LESSP-1 (FIELD-1 FIELD-2) (DO ((PL1) (PL2) (STR1) (STR2)) (NIL) (COND ((NULL FIELD-1) (RETURN (NOT (NULL FIELD-2)))) ((NULL FIELD-2) (RETURN NIL)) ((NOT (STRING-EQUAL (SETQ STR1 (GET (SETQ PL1 (LOCF (CAR FIELD-1))) ':NAME)) (SETQ STR2 (GET (SETQ PL2 (LOCF (CAR FIELD-2))) ':NAME)))) (RETURN (STRING-LESSP STR1 STR2))) ((NULL (SETQ STR1 (GET PL1 ':HOST))) (RETURN (NOT (NULL (GET PL2 ':HOST))))) ((NULL (SETQ STR2 (GET PL2 ':HOST))) (RETURN NIL)) ((NOT (STRING-EQUAL (SETQ STR1 (CAR STR1)) (SETQ STR2 (CAR STR2)))) (RETURN (STRING-LESSP STR1 STR2)))) (SETQ FIELD-1 (CDR FIELD-1) FIELD-2 (CDR FIELD-2)))) (DEFUN MSG-SUBJECT-STRING-LESSP (MSG-1 MSG-2 &AUX SUB1 SUB2) (SETQ SUB1 (MSG-GET MSG-1 ':SUBJECT) SUB2 (MSG-GET MSG-2 ':SUBJECT)) (COND ((NULL SUB1) (NOT (NULL SUB2))) ((NULL SUB2) NIL) (T (STRING-LESSP SUB1 SUB2)))) (DEFUN MSG-KEYWORD-LESSP (MSG-1 MSG-2 &AUX KEY-1 KEY-2) (SETQ KEY-1 (MSG-GET MSG-1 'KEYWORDS-STRING) KEY-2 (MSG-GET MSG-2 'KEYWORDS-STRING)) (COND ((NULL KEY-1) (NOT (NULL KEY-2))) ((NULL KEY-2) NIL) (T (STRING-LESSP KEY-1 KEY-2)))) (DEFUN MSG-TEXT-STRING-LESSP (MSG-1 MSG-2) (INTERVAL-LESSP (MSG-INTERVAL MSG-1) NIL T (MSG-INTERVAL MSG-2) NIL T)) (DEFUN MSG-LENGTH-LESSP (MSG-1 MSG-2) (< (COMPUTE-MSG-LENGTH MSG-1) (COMPUTE-MSG-LENGTH MSG-2))) (DEFUN COMPUTE-MSG-LENGTH (MSG) (OR (MSG-GET MSG 'LENGTH) (LET ((LENGTH (COUNT-CHARS (MSG-INTERVAL MSG)) )) (MSG-PUT MSG LENGTH 'LENGTH) LENGTH))) (DEFUN MSG-POSITION-LESSP (MSG-1 MSG-2 &AUX MAIL-FILE-1 MAIL-FILE-2) (SETQ MAIL-FILE-1 (MSG-MAIL-FILE MSG-1) MAIL-FILE-2 (MSG-MAIL-FILE MSG-2)) (IF (NEQ MAIL-FILE-1 MAIL-FILE-2) (STRING-LESSP (MAIL-FILE-NAME MAIL-FILE-1) (MAIL-FILE-NAME MAIL-FILE-2)) (DOMSGS (MSG MAIL-FILE-1) (COND ((EQ MSG MSG-1) (RETURN T)) ;Found first message, it is less ((EQ MSG MSG-2) (RETURN NIL)))))) (LOCAL-DECLARE ((SPECIAL SORT-GREATERP-PREDICATE)) (DEFUN REVERSE-STABLE-SORT (OBJECT SORT-GREATERP-PREDICATE) (STABLE-SORT OBJECT #'(LAMBDA (X Y) (FUNCALL SORT-GREATERP-PREDICATE Y X))))) (DEFUN (COM-ZMAIL-MAIL ASSOCIATED-ALL-COMMAND) () (SELECTQ (CHOOSE-MAIL-MODE) (:FORWARD (COM-ZMAIL-FORWARD-ALL)) (:REDISTRIBUTE (COM-ZMAIL-REDISTRIBUTE-ALL)) (OTHERWISE (BARF "That command does not take a filter argument")))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-FORWARD-ALL "Forward all these messages to someone." () (INITIALIZE-FOR-MAIL) (INSERT (INSERT-MOVING (WINDOW-POINT *HEADER-WINDOW*) "To: ") #\CR) (LET* ((ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*)) (BP (INSERT-MSGS-INTO-WINDOW *REPLY-WINDOW* NIL (AREF ARRAY 0))) (STREAM (INTERVAL-STREAM-INTO-BP BP)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (LIST NIL)) (FUNCALL STREAM ':SET-BP (INTERVAL-FIRST-BP *REPLY-INTERVAL*)) (FORMAT STREAM *FORWARDED-MESSAGE-BEGIN* NMSGS) (FUNCALL STREAM ':FRESH-LINE) (DO ((I 1 (1+ I)) (MSG)) (( I NMSGS)) (SETQ MSG (AREF ARRAY I)) (PUSH MSG LIST) (FUNCALL STREAM ':SET-BP BP) (FORMAT STREAM *FORWARDED-MESSAGE-SEPARATOR* I) (FUNCALL STREAM ':TYO #\CR) (MOVE-BP BP (INSERT-INTERVAL (FUNCALL STREAM ':READ-BP) (MSG-INTERVAL MSG)))) (SETF (DRAFT-MSG-MSGS-BEING-FORWARDED *DRAFT-MSG*) (NREVERSE LIST)) (FUNCALL STREAM ':SET-BP BP) (FORMAT STREAM *FORWARDED-MESSAGE-END* NMSGS) (FUNCALL STREAM ':FRESH-LINE) (MOVE-BP BP (FUNCALL STREAM ':READ-BP))) (ZMAIL-MAIL ':MAIL ':HEADER)) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-REPLY-ALL (STRING &OPTIONAL RECURSIVE) (OR RECURSIVE (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'NORMAL-REPLY NIL T)) (STRING-NCONC STRING "Reply to these messages: " (GET 'NORMAL-REPLY ':WHO-LINE-DOCUMENTATION))) (DEFPROP COM-ZMAIL-REPLY COM-ZMAIL-REPLY-ALL ASSOCIATED-ALL-COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-REPLY-ALL "Reply to all these messages at once." () (MULTIPLE-VALUE-BIND (MODE STARTING-WINDOW) (APPLY-ARRAY #'NORMAL-REPLY (MAIL-FILE-ARRAY *MAIL-FILE*)) (ZMAIL-MAIL MODE STARTING-WINDOW))) ;;; This might be useful enough to be someplace (DEFUN APPLY-ARRAY (FUNCTION ARRAY &AUX LEN) (SETQ LEN (ARRAY-ACTIVE-LENGTH ARRAY)) (%OPEN-CALL-BLOCK FUNCTION 0 4) ;No ADI, D-RETURN (%ASSURE-PDL-ROOM LEN) (DO I 0 (1+ I) ( I LEN) (%PUSH (AREF ARRAY I))) (%ACTIVATE-OPEN-CALL-BLOCK)) (DEFPROP COM-ZMAIL-CONCATENATE COM-ZMAIL-CONCATENATE-ALL ASSOCIATED-ALL-COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-CONCATENATE-ALL "Append these messages together. The text of the first message becomes the concatenation of the text of all messages. All but resultant first message are then marked as deleted." () (LET* ((ARRAY (MAIL-FILE-ARRAY *MAIL-FILE*)) (FIRST-MSG (AREF ARRAY 0)) (BP (MSG-END-BP FIRST-MSG))) (DO ((I 1 (1+ I)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (MSG)) (( I NMSGS)) (SETQ MSG (AREF ARRAY I)) (INSERT BP #\CR) (INSERT-INTERVAL BP (MSG-INTERVAL MSG)) (MSG-PUT MSG T 'DELETED)) (ZMAIL-SELECT-MSG FIRST-MSG) (UPDATE-MSG-SUMMARY-LINE FIRST-MSG ':SIZE)) DIS-TEXT) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-CONCATENATE "Append the current message to another message" () (ZMAIL-CONCATENATE-MSG *MSG* T)) (DEFUN ZMAIL-CONCATENATE-MSG (MSG &OPTIONAL CHOOSE-P &AUX OTHER-MSG) (SETQ OTHER-MSG (IF (OR CHOOSE-P (EQ *ZMAIL-COMMAND-BUTTON* ':RIGHT)) (CHOOSE-MSG-FROM-SUMMARY "another message") *MSG*)) (CONCATENATE-MSG-TO-MSG MSG OTHER-MSG) DIS-NONE) (DEFUN CONCATENATE-MSG-TO-MSG (MSG OTHER-MSG) (AND (EQ MSG OTHER-MSG) (BARF "Cannot concatenate message to itself")) (LET ((BP (MSG-END-BP OTHER-MSG))) (INSERT BP #\CR) (INSERT-INTERVAL BP (MSG-INTERVAL MSG))) (UPDATE-MSG-SUMMARY-LINE OTHER-MSG ':SIZE) (ZMAIL-DELETE-MSG MSG)) (DEFUN ZMAIL-DELETE-MSG (MSG) (IF (EQ MSG *MSG*) (MUST-REDISPLAY *WINDOW* (LET ((*ZMAIL-COMMAND-BUTTON* ':KBD) (*NUMERIC-ARG-P* NIL)) (COM-ZMAIL-DELETE))) (MSG-PUT MSG T 'DELETED))) (DEFUN ZMAIL-UNDELETE-MSG (MSG) (MSG-PUT MSG NIL 'DELETED) (IF (EQ MSG *MSG*) (ZMAIL-SELECT-MSG *MSG* NIL NIL) DIS-NONE)) (DEFUN CHOOSE-MSG-FROM-SUMMARY (PROMPT) (OR (MEMQ *WINDOW-CONFIGURATION* *SUMMARY-WINDOW-CONFIGURATIONS*) (BARF "Summary is not visible")) (AND (OR (NULL *MAIL-FILE*) (ZEROP (MAIL-FILE-NMSGS *MAIL-FILE*))) (BARF "There are no messages to choose from")) (PROMPT-LINE "Select ~A with the mouse, or type any character to abort" PROMPT) (LET ((CH (FUNCALL STANDARD-INPUT ':ANY-TYI))) (OR (AND (LISTP CH) (EQ (CAR CH) 'SUMMARY-MOUSE)) (BARF)) (CADADR CH))) ;;; Conversation/Reference stuff (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SELECT-REFERENCES "Select messages which this message refers to" () (SELECT-MAIL-FILE (MAKE-MAIL-FILE-OF-REFERENCES *MSG*))) (DEFUN MAKE-MAIL-FILE-OF-REFERENCES (MSG &AUX MF) (SETQ MF (GET-RECYCLED-TEMP-MAIL-FILE "")) (MAKE-MAIL-FILE-OF-REFERENCES-1 MSG (MAIL-FILE-ARRAY MF)) MF) (DEFUN MAKE-MAIL-FILE-OF-REFERENCES-1 (MSG ARRAY) (ARRAY-PUSH-EXTEND ARRAY MSG) (DOLIST (REF (MSG-REFERENCES MSG)) (AND (SETQ MSG (FIND-MSG-FROM-REFERENCES REF *MSG*)) (MAKE-MAIL-FILE-OF-REFERENCES-1 MSG ARRAY)))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SELECT-REFERENCED-MSG "Select the message this message refers to" () (SELECT-MSG-AND-POSSIBLY-MAIL-FILE (FIND-MSG-FROM-CURRENT-REFERENCES))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-DELETE-REFERENCED-MSG "Delete the referenced message" () (LET ((MSG (FIND-MSG-FROM-CURRENT-REFERENCES))) (MSG-PUT MSG T 'DELETED) (TYPEIN-LINE "Message deleted from ~A" (FUNCALL (MSG-MAIL-FILE MSG) ':NAME))) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-APPEND-TO-REFERENCED-MSG "Append this message into the referenced message" () (LET ((MSG (FIND-MSG-FROM-CURRENT-REFERENCES))) (CONCATENATE-MSG-TO-MSG *MSG* MSG) (TYPEIN-LINE "Appended to message in ~A" (FUNCALL (MSG-MAIL-FILE MSG) ':NAME))) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-MOVE-IN-PLACE-OF-REFERENCED-MSG "Move this message where referenced message is. A message is found in the specified universe as references by this message. This message is then moved into the mail file that message occupies in the same place and that message deleted." () (LET* ((MSG (FIND-MSG-FROM-CURRENT-REFERENCES NIL)) (MAIL-FILE (MSG-MAIL-FILE MSG)) (INDEX (MSG-IN-MAIL-FILE-P MSG MAIL-FILE))) (MSG-PUT MSG T 'DELETED) (FUNCALL MAIL-FILE ':ADD-MSG *MSG* INDEX) (TYPEIN-LINE "Moved to ~A" (FUNCALL MAIL-FILE ':NAME))) DIS-NONE) ;;; ASK-FOR-UNIVERSE means give the menu before bothering to look in current mail file. (DEFUN FIND-MSG-FROM-CURRENT-REFERENCES (&OPTIONAL (TRY-HERE-FIRST-P (NOT *NUMERIC-ARG-P*)) &AUX REFS) (OR (SETQ REFS (MSG-REFERENCES *MSG*)) (BARF "Cannot find any message references in this message")) (SETQ REFS (CAR REFS)) (OR (FIND-MSG-FROM-REFERENCES REFS *MSG* TRY-HERE-FIRST-P) (BARF "Cannot find ~A" (STRING-FOR-MSG-REFERENCE REFS)))) (DEFUN STRING-FOR-MSG-REFERENCE (REF) (WITH-OUTPUT-TO-STRING (STREAM) (PRINT-REFERENCE STREAM REF NIL))) (DEFUN FIND-MSG-FROM-REFERENCES (REF MSG &OPTIONAL (TRY-HERE-FIRST-P T)) (COND ((AND TRY-HERE-FIRST-P (FIND-MSG-FROM-REFERENCES-IN-UNIVERSE REF #'MAP-OVER-SINGLE-MAIL-FILE *MAIL-FILE*))) ((LOOP FOR (FILTER . UNIVERSE) IN *FILTER-REFERENCE-UNIVERSE-ALIST* WHEN (MSG-FITS-FILTER-P MSG FILTER) THEREIS (FIND-MSG-FROM-REFERENCES-IN-UNIVERSE REF #'MAP-OVER-DEFINED-UNIVERSE UNIVERSE))) (T (MULTIPLE-VALUE-BIND (MAP-FUNCTION MAP-ARG) (GET-UNIVERSE-FUNCTION '(:MOUSE) (FORMAT NIL "Where is ~A?" (STRING-FOR-MSG-REFERENCE REF))) (AND MAP-FUNCTION (FIND-MSG-FROM-REFERENCES-IN-UNIVERSE REF MAP-FUNCTION MAP-ARG)))))) (DEFUN FIND-MSG-FROM-REFERENCES-IN-UNIVERSE (REF MAP-FUNCTION MAP-ARG) (FIND-MSG-FROM-FILTER MAP-FUNCTION MAP-ARG #'MSG-REFERENCE-EQUAL REF)) (DEFUN MSG-REFERENCE-EQUAL (MSG REF) (LOOP FOR (IND PROP) ON REF BY 'CDDR WITH STATUS = (ASSURE-MSG-PARSED MSG) ALWAYS (REFERENCE-EQUAL PROP (GET STATUS IND) IND))) (DEFUN REFERENCE-EQUAL (REF-PROP MSG-PROP IND) (AND MSG-PROP (SELECTQ IND (:DATE (< (ABS (- REF-PROP MSG-PROP)) 60.)) ;Resolution of one minute (:FROM (LOOP FOR (IND PROP) ON REF-PROP BY 'CDDR WITH MSG = (LOCF (CAR MSG-PROP)) ALWAYS (EQUAL PROP (GET MSG IND)))) (OTHERWISE (EQUAL REF-PROP MSG-PROP))))) (DEFUN MSG-REFERENCES (MSG &AUX STATUS TEM) (SETQ STATUS (ASSURE-MSG-PARSED MSG)) (IF (SETQ TEM (GETL STATUS '(REFERENCES))) (CADR TEM) (SETQ TEM (GET-MSG-REFERENCES MSG STATUS)) (PUTPROP STATUS TEM 'REFERENCES) TEM)) (DEFUN GET-MSG-REFERENCES (MSG STATUS) ;; If there is an IN-REPLY-TO field, use what is says, else get from text (IF (GETL STATUS *REFERENCE-TYPE-HEADERS*) (LOOP FOR IND IN *REFERENCE-TYPE-HEADERS* APPEND (GET STATUS IND)) (GET-MSG-TEXT-REFERENCES MSG))) (DEFMACRO ADD-OTHER-COMMANDS (&REST COMMANDS) `(SETQ *OTHER-COMMAND-ALIST* (APPEND *OTHER-COMMAND-ALIST* (MAKE-COMMAND-ALIST ',(COPYLIST COMMANDS))))) (DEFINE-ZMAIL-GLOBAL *LAST-OTHER-MENU-ITEM* NIL) ;;; Let the user specify what this does if (s)he wants (DEFINE-ZMAIL-GLOBAL *MIDDLE-OTHER-COMMAND* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-OTHER-COMMANDS (STRING) (FORMAT STRING "Execute auxiliary command: ~@[L: ~A; ~]~@[M: ~A; ~]R: menu." (CAR *LAST-OTHER-MENU-ITEM*) (NAME-FROM-MENU-VALUE *MIDDLE-OTHER-COMMAND* *OTHER-COMMAND-ALIST*))) (ASSOCIATE-OPTION-WITH-COMMAND-DOCUMENTATION *MIDDLE-OTHER-COMMAND* COM-ZMAIL-OTHER-COMMANDS) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-OTHER-COMMANDS "Execute an auxiliary command. Left defaults to last command used. Middle is a user option. Right gives a menu of these commands." (NO-MAIL-FILE-OK NUMERIC-ARG-OK) (FUNCALL (CHOOSE-OTHER-COMMAND))) (DEFUN CHOOSE-OTHER-COMMAND (&AUX COMMAND) (OR *OTHER-COMMAND-ALIST* (BARF "No other commands")) (MULTIPLE-VALUE (COMMAND *LAST-OTHER-MENU-ITEM*) (ZMAIL-MENU-CHOOSE 'ZMAIL-MOMENTARY-COMMAND-MENU *OTHER-COMMAND-ALIST* *LAST-OTHER-MENU-ITEM* NIL *MIDDLE-OTHER-COMMAND*)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-OTHER-COMMANDS) COMMAND) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-VIEW-FILE "View a specified file." (NO-MAIL-FILE-OK) (LET ((PATHNAME (WITH-BACKGROUND-PROCESS-LOCKED (READ-DEFAULTED-PATHNAME "View file:" (COND ((AND *MAIL-FILE* (MAIL-FILE-DISK-P *MAIL-FILE*)) (DISK-MAIL-FILE-PATHNAME *MAIL-FILE*)) (*PRIMARY-MAIL-FILE* (DISK-MAIL-FILE-PATHNAME *PRIMARY-MAIL-FILE*)) (T (DEFAULT-PATHNAME))))))) (ZMAIL-VIEW-FILE PATHNAME)) DIS-NONE) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* FILE "View" ZMAIL-VIEW-FILE NIL "View this file.") (DEFUN ZMAIL-VIEW-FILE (PATHNAME) (WITH-OPEN-FILE (STREAM PATHNAME '(:IN)) (USING-OVERLYING-WINDOW (FUNCALL *OVERLYING-WINDOW* ':VIEW-STREAM STREAM))) NIL) (DEFINE-ZMAIL-GLOBAL *ZMAIL-KEYBOARD-MACROS* NIL) (DEFINE-ZMAIL-GLOBAL *LAST-KEYBOARD-MACRO-ITEM* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-REPLAY-KEYBOARD-MACRO (STRING) (FORMAT STRING "Replay a keyboard macro: ~@[L: ~A; ~]R: menu." *LAST-KEYBOARD-MACRO-ITEM*)) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-REPLAY-KEYBOARD-MACRO "Replay a keyboard macro. Left defaults to last keyboard macro used. Right gives menu of possibilities." (NO-MAIL-FILE-OK) (OR (MEMQ ':MACRO-EXECUTE (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (BARF "This stream doesnt support macros")) (LET (MACRO) (MULTIPLE-VALUE (MACRO *LAST-KEYBOARD-MACRO-ITEM*) (ZMAIL-MENU-CHOOSE NIL *ZMAIL-KEYBOARD-MACROS* *LAST-KEYBOARD-MACRO-ITEM*)) (OR (AND MACRO (SETQ MACRO (GET MACRO 'MACRO-STREAM-MACRO))) (BARF)) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-REPLAY-KEYBOARD-MACRO) (FUNCALL STANDARD-INPUT ':MACRO-EXECUTE MACRO 1))) (DEFMACRO ADD-ZMAIL-KEYBOARD-MACROS NAMES `(SETQ *ZMAIL-KEYBOARD-MACROS* (APPEND *ZMAIL-KEYBOARD-MACROS* ',(MAPCAR #'(LAMBDA (X) (INTERN (GET-PNAME X) "")) NAMES)))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-KILL-RING-SAVE-MSG "Save the current message on the kill ring" () (KILL-RING-SAVE-INTERVAL (MSG-INTERVAL *MSG*)) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-LIST-MAIL-FILES "List the current mail files" (NO-MSG-OK) (FORMAT *TYPEOUT-WINDOW* "~& Name: Expunge Save Number of messages~%") (MULTIPLE-VALUE-BIND (DISK-MAIL-FILES TEMP-MAIL-FILES) (GET-MAIL-FILE-ALISTS) (LIST-MAIL-FILES-INTERNAL DISK-MAIL-FILES "Disk") (LIST-MAIL-FILES-INTERNAL TEMP-MAIL-FILES "Temp") (DO ((LIST *OTHER-MAIL-FILE-NAMES* (CDR LIST)) (FIRST-P T) (NAME)) ((NULL LIST) (OR FIRST-P (FUNCALL *TYPEOUT-WINDOW* ':TYO #\CR))) (SETQ NAME (CAR LIST)) (COND ((NOT (ASSOC NAME DISK-MAIL-FILES)) (COND (FIRST-P (FORMAT *TYPEOUT-WINDOW* "~&Mail files not yet read in:~%") (SETQ FIRST-P NIL))) (FUNCALL *TYPEOUT-WINDOW* ':FRESH-LINE) (FUNCALL *TYPEOUT-WINDOW* ':ITEM 'OTHER-MAIL-FILE NAME) (FUNCALL *TYPEOUT-WINDOW* ':TYO #\CR))))) DIS-NONE) (DEFUN LIST-MAIL-FILES-INTERNAL (LIST PROMPT) (COND (LIST (FORMAT *TYPEOUT-WINDOW* "~&~A mail files:~%" PROMPT) (DO L LIST (CDR L) (NULL L) (LET ((MAIL-FILE (CDAR L))) (MULTIPLE-VALUE-BIND (SAVE-P EXPUNGE-P) (MAIL-FILE-SAVE-P MAIL-FILE) (FUNCALL *TYPEOUT-WINDOW* ':FRESH-LINE) (FUNCALL *TYPEOUT-WINDOW* ':ITEM 'MAIL-FILE MAIL-FILE "~A" (CAAR L)) (FORMAT *TYPEOUT-WINDOW* "~30T~C~36T~C~46T~3D~%" (IF EXPUNGE-P #/* #\SP) (IF SAVE-P #/* #\SP) (MAIL-FILE-NMSGS MAIL-FILE))))) (FUNCALL *TYPEOUT-WINDOW* ':TYO #\CR)))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* OTHER-MAIL-FILE "Read in" READ-IN-OTHER-MAIL-FILE T "Read in this file.") (DEFUN READ-IN-OTHER-MAIL-FILE (FILE-NAME) (SELECT-MAIL-FILE (MAKE-NEW-MAIL-FILE FILE-NAME))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-ENABLE-BACKGROUND-PROCESS-WHEN-DEEXPOSED "Allow the background process to run when deexposed" (NO-MAIL-FILE-OK NUMERIC-ARG-OK) (TYPEIN-LINE "Background process ~:[en~;dis~]abled when deexposed" (SETQ *HANG-BACKGROUND-PROCESS-WHEN-DEEXPOSED* (IF *NUMERIC-ARG-P* (ZEROP *NUMERIC-ARG*) (NOT *HANG-BACKGROUND-PROCESS-WHEN-DEEXPOSED*)))) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-DELETE-DUPLICATE-MSGS "Delete any duplicate messages in the current mail file" () (LET ((HASH-TABLE (MAKE-EQUAL-HASH-TABLE ':SIZE (// (* (MAIL-FILE-NMSGS *MAIL-FILE*) 5) 4))) (NDELETED 0) OMSG) (DOMSGS (MSG *MAIL-FILE*) (COND ((AND (SETQ OMSG (SWAPHASH-EQUAL (MSG-HASH-ID MSG) MSG HASH-TABLE)) (NOT (MSG-GET OMSG 'DELETED))) (ZMAIL-DELETE-MSG OMSG) (INCF NDELETED)))) (RETURN-ARRAY HASH-TABLE) (TYPEIN-LINE "~D message~:P deleted." NDELETED)) DIS-NONE) ;;; This intentionally ignores things like Redistributed-by which might be different. ;;; I think this is probably more right (DEFUN MSG-HASH-ID (MSG &AUX STATUS) (SETQ STATUS (ASSURE-MSG-PARSED MSG)) (OR (GET STATUS 'HASH-ID) (LET ((HASH-ID (OR (GET STATUS ':MESSAGE-ID) (SOME-PLIST (CAR STATUS) '(:DATE :FROM :TO :CC))))) (PUTPROP STATUS HASH-ID 'HASH-ID) HASH-ID))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-SET-EXPIRATION-DATE "Set the expiration date on this message." () (LET ((DATE (TYPEIN-LINE-READLINE "Set expiration date:"))) (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME DATE)) (AND (STRINGP DATE) (BARF "Bad date: ~A" DATE)) (ADD-HEADER-TO-MSG *MSG* ':EXPIRATION-DATE DATE)) DIS-TEXT) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-WHOIS "Print whois information on a user" (NO-MAIL-FILE-OK) (MULTIPLE-VALUE-BIND (NIL USER) (CHOOSE-OR-READLINE-ADDRESS "Whois" NIL T (LET ((FROM (AND *MSG* (CAR (MSG-GET *MSG* ':FROM))))) (AND FROM (STRING-FROM-HEADER FROM ':SHORT)))) (CHAOS:FINGER (FORMAT NIL "~A//W" USER))) DIS-NONE) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-SELECT-ARBITRARY-FORMAT-MAIL-FILE "Read in a file and a specified format" (NO-MAIL-FILE-OK) (SET-ZMAIL-USER) (SELECT-ARBITRARY-FORMAT-MAIL-FILE (SELECT-MAIL-FILE-FIND-FILE ':MOUSE))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* FILE "Arbitrary format" SELECT-ARBITRARY-FORMAT-MAIL-FILE NIL "Select this file, specifying the format.") (DEFUN SELECT-ARBITRARY-FORMAT-MAIL-FILE (PATHNAME &AUX FLAVOR MAIL-FILE) (SETQ *ZMAIL-COMMAND-BUTTON* ':RIGHT) ;Always ask for flavor (SETQ FLAVOR (ZMAIL-MENU-CHOOSE NIL *MAIL-FILE-FLAVOR-ALIST*) MAIL-FILE (MAKE-NEW-MAIL-FILE PATHNAME '(:MOUSE) FLAVOR)) (SELECT-MAIL-FILE MAIL-FILE))