;;; Lisp Machine mail reader -*- Mode:LISP; Package:ZWEI; Base:8; Readtable:ZL -*- ;;; These are the frames used by filtering and their commands ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-SELECT (STRING) (FORMAT STRING "Create//Select buffer: ~@[L: /"~A/"; ~]M: filter; R: menu." (DOLIST (MF *ZMAIL-BUFFER-LIST*) (OR (EQ MF *ZMAIL-BUFFER*) (RETURN (ZMAIL-BUFFER-NAME-for-buffer-alist MF)))))) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SELECT "Select another buffer. Left selects most recently selected other buffer. Middle creates a new subset buffer by filtering. Right gives a menu listing all existing buffers, and creation techniques such as reading in a mail file and marking the summary window." (NO-ZMAIL-BUFFER-OK) (SET-ZMAIL-USER) (SELECT-ZMAIL-BUFFER (CASE *ZMAIL-COMMAND-BUTTON* (:RIGHT (MENU-GET-ZMAIL-BUFFER-FOR-SELECTION)) (:MIDDLE (READ-SUBSET-ZMAIL-BUFFER)) (OTHERWISE (OR (DOLIST (MF *ZMAIL-BUFFER-LIST*) (OR (EQ MF *ZMAIL-BUFFER*) (RETURN MF))) (BARF "This is the only buffer")))))) (DEFUN MENU-GET-ZMAIL-BUFFER-FOR-SELECTION (&AUX ITEM-LIST) "Return a ZMAIL-BUFFER chose by the user. We offer the menu." (MULTIPLE-VALUE-BIND (ZMAIL-BUFFER-ALIST TEMP-ZMAIL-BUFFER-ALIST) (GET-ZMAIL-BUFFER-ALISTS T) (IF (OR ZMAIL-BUFFER-ALIST TEMP-ZMAIL-BUFFER-ALIST) (SEND *SELECT-ZMAIL-BUFFER-MENU* :SET-GEOMETRY 2 NIL) (SEND *SELECT-ZMAIL-BUFFER-MENU* :SET-GEOMETRY NIL 1)) (SETQ ITEM-LIST (TV:APPEND-ITEM-LISTS ZMAIL-BUFFER-ALIST TEMP-ZMAIL-BUFFER-ALIST))) (SETQ ITEM-LIST (APPEND ITEM-LIST (AND (ODDP (LENGTH ITEM-LIST)) '(("" :NO-SELECT T))) '(("Read or create file" :VALUE :READ-FILE :FONT FONTS:HL12I :DOCUMENTATION "Read in and select a mail file, creating it if necessary.") ("Mark summary" :VALUE :MARKING :FONT FONTS:HL12I :DOCUMENTATION "Select a temporary buffer made by clicking on the summary window.") ("Abort" :VALUE :ABORT :FONT FONTS:HL12I :DOCUMENTATION "Abort this command.") ("Subset" :VALUE :SUBSET :FONT FONTS:HL12I :DOCUMENTATION "Select a subset buffer made by filtering.") ))) (OR (EQUAL ITEM-LIST (SEND *SELECT-ZMAIL-BUFFER-MENU* :ITEM-LIST)) (SEND *SELECT-ZMAIL-BUFFER-MENU* :SET-ITEM-LIST ITEM-LIST)) (UNWIND-PROTECT (PROGN (TV:EXPOSE-WINDOW-NEAR *SELECT-ZMAIL-BUFFER-MENU* (RECTANGLE-NEAR-COMMAND-MENU)) (DO ((ZMAIL-BUFFER)) (NIL) (SETQ ZMAIL-BUFFER (SEND *SELECT-ZMAIL-BUFFER-MENU* :CHOOSE)) (SET-COMMAND-BUTTON (SEND *SELECT-ZMAIL-BUFFER-MENU* :LAST-BUTTONS)) (CASE ZMAIL-BUFFER (:ABORT (ABORT-CURRENT-COMMAND)) (:SUBSET (SEND *SELECT-ZMAIL-BUFFER-MENU* :DEACTIVATE) (SETQ ZMAIL-BUFFER (READ-SUBSET-ZMAIL-BUFFER))) (:MARKING (SEND *SELECT-ZMAIL-BUFFER-MENU* :DEACTIVATE) (SETQ ZMAIL-BUFFER (MAKE-ZMAIL-BUFFER-BY-MARKING))) (:READ-FILE (SETQ ZMAIL-BUFFER (READ-ZMAIL-BUFFER-FILENAME *SELECT-ZMAIL-BUFFER-MENU*)))) (COND ((OR (STRINGP ZMAIL-BUFFER) (TYPEP ZMAIL-BUFFER 'FS:PATHNAME)) (SEND *SELECT-ZMAIL-BUFFER-MENU* :DEACTIVATE) (SETQ ZMAIL-BUFFER (ZMAIL-FIND-FILE-NOSELECT ZMAIL-BUFFER)))) (AND ZMAIL-BUFFER (RETURN ZMAIL-BUFFER)))) (SEND *SELECT-ZMAIL-BUFFER-MENU* :DEACTIVATE))) (DEFUN READ-ZMAIL-BUFFER-FILENAME (NEAR-WINDOW &AUX ZMAIL-BUFFER) (LET ((PN (IF *ZMAIL-BUFFER* (BUFFER-PATHNAME (IF (ZMAIL-BUFFER-DISK-P *ZMAIL-BUFFER*) *ZMAIL-BUFFER* *PRIMARY-ZMAIL-BUFFER*)) (DEFAULT-ZMAIL-MOVE-PATHNAME)))) (*CATCH 'ZWEI-COMMAND-LOOP ;In case of G (SETQ ZMAIL-BUFFER (CALL-POP-UP-MINI-BUFFER-EDITOR NEAR-WINDOW 'READ-DEFAULTED-PATHNAME "Find file" PN (SEND PN :TYPE) NIL :NEW-OK)))) ZMAIL-BUFFER) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* FILE "Select" SELECT-ZMAIL-BUFFER-FROM-PATHNAME T "Select this file.") (DEFUN SELECT-ZMAIL-BUFFER-FROM-PATHNAME (PATHNAME) (SELECT-ZMAIL-BUFFER (ZMAIL-FIND-FILE-NOSELECT PATHNAME))) (DEFUN READ-SUBSET-ZMAIL-BUFFER () "Ask the user to specify a universe and filter; create and return a subset buffer." (MULTIPLE-VALUE-BIND (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (GET-FILTER-FUNCTION) (MAKE-ZMAIL-BUFFER-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))) (DEFUN MAKE-ZMAIL-BUFFER-FROM-FILTER (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG &OPTIONAL ZMAIL-BUFFER) "Create and return a subset buffer using specified mapping and filtering." (OR ZMAIL-BUFFER (MULTIPLE-VALUE-BIND (NAME FULL-NAME) (GENERATE-SUBSET-BUFFER-NAME MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (SETQ ZMAIL-BUFFER (GET-RECYCLED-TEMP-ZMAIL-BUFFER NAME FULL-NAME)))) (LET ((ARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER)) (*N* 0)) (DECLARE (SPECIAL *N*)) (FUNCALL MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG #'(LAMBDA (MSG ARRAY) (AND ( *N* (ARRAY-LENGTH ARRAY)) (ADJUST-ARRAY-SIZE ARRAY (TRUNCATE (* *N* 5) 4))) (ASET MSG ARRAY *N*) (SETQ *N* (1+ *N*))) ARRAY) (SETF (ARRAY-LEADER ARRAY 0) *N*)) ZMAIL-BUFFER) (DEFUN (COM-ZMAIL-SELECT ASSOCIATED-MAP-COMMAND) (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (SELECT-ZMAIL-BUFFER (IF (AND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER) (EQ FILTER-FUNCTION 'MSG-TRUE-FILTER)) MAP-ARG (MAKE-ZMAIL-BUFFER-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)))) (DEFCONST *MAX-NAME-LENGTH* 50.) (DEFUN GENERATE-SUBSET-BUFFER-NAME (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG &AUX FULL-NAME NAME ADDED-NAME) (SETQ FULL-NAME (FUNCALL (GET MAP-FUNCTION 'MAP-FUNCTION-BUFFER-NAME-FUNCTION) MAP-ARG) NAME FULL-NAME ADDED-NAME (FILTER-FUNCTION-BUFFER-NAME FILTER-FUNCTION FILTER-ARG)) (DO ((I 0) (LEN (STRING-LENGTH NAME)) (MAXL (MAX (- *MAX-NAME-LENGTH* (STRING-LENGTH ADDED-NAME) 4) 0))) (( (- LEN I) MAXL) (OR (ZEROP I) (SETQ NAME (STRING-APPEND "<...>" (SUBSTRING NAME I))))) (IF (SETQ I (STRING-SEARCH-SET '(#/> #/) #/} #/] #/) NAME I)) (SETQ I (1+ I)) (SETQ I LEN))) (LET ((SAME (EQ FULL-NAME NAME))) (SETQ NAME (STRING-APPEND NAME ADDED-NAME) FULL-NAME (IF SAME NAME (STRING-APPEND FULL-NAME ADDED-NAME)))) (VALUES NAME FULL-NAME)) (DEFUN FILTER-FUNCTION-BUFFER-NAME (FILTER-FUNCTION FILTER-ARG &AUX TEM) (COND ((SETQ TEM (GET FILTER-FUNCTION 'FILTER-FUNCTION-BUFFER-NAME-FUNCTION)) (FUNCALL TEM FILTER-ARG)) ((SETQ TEM (GET FILTER-FUNCTION 'FILTER-FUNCTION-OPPOSITE-FUNCTION)) (STRING-APPEND #/~ (FILTER-FUNCTION-BUFFER-NAME TEM FILTER-ARG))) (T (STRING-APPEND #/< FILTER-FUNCTION #/>)))) (DEFUN GET-RECYCLED-TEMP-ZMAIL-BUFFER (NAME &OPTIONAL (FULL-NAME NAME)) ;; Make sure the name is unique (DO ((ORIGINAL-NAME NAME) (COUNT 1 (1+ COUNT))) ((NOT (GET-ZMAIL-BUFFER-FROM-NAME NAME))) (SETQ NAME (FORMAT NIL "~A-~D" ORIGINAL-NAME COUNT))) (MAKE-NEW-TEMP-ZMAIL-BUFFER NAME FULL-NAME)) (DEFUN MAKE-ZMAIL-BUFFER-BY-MARKING (&AUX OLD-CONFIG OLD-DOC) (OR *ZMAIL-BUFFER* (BARF "There is no current buffer")) (SETQ OLD-CONFIG *WINDOW-CONFIGURATION* OLD-DOC (SEND *SUMMARY-WINDOW* :WHO-LINE-OVERRIDE-DOCUMENTATION-STRING)) (UNWIND-PROTECT (LET ((*MODE-LINE-LIST* `("ZMail " "Marking " *ZMAIL-FILE-NAME* ,(FORMAT NIL " ~:@C to finish; ~:@C to abort." #/END #/ABORT) (*MACRO-LEVEL* " Macro-level: " *MACRO-LEVEL*)))) (SEND *SUMMARY-WINDOW* :SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING "Click left to complement marked state of message.") (UNMARK-ALL-MESSAGES) (OR (SEND *SUMMARY-WINDOW* :EXPOSED-P) (SEND *ZMAIL-WINDOW* :SET-WINDOW-CONFIGURATION :SUMMARY)) (DO ((LIST NIL) (CH)) (NIL) (REDISPLAY-MODE-LINE) (SEND *SUMMARY-WINDOW* :REDISPLAY-AS-NECESSARY) (SETQ CH (SEND *STANDARD-INPUT* :ANY-TYI)) (COND ((AND (CONSP CH) (EQ (CAR CH) 'SUMMARY-MOUSE)) (LET* ((MSG (CADADR CH)) (STATUS (ASSURE-MSG-PARSED MSG))) (IF (PUTPROP STATUS (NOT (GET STATUS 'MARKED)) 'MARKED) (PUSH MSG LIST) (SETQ LIST (DELQ MSG LIST))) (SEND *SUMMARY-WINDOW* :NEED-TO-REDISPLAY-MSG MSG))) ((OR (CONSP CH) (EQ CH #/END)) (OR (EQ CH #/END) (SEND *STANDARD-INPUT* :UNTYI CH)) (LET ((ZMAIL-BUFFER (GET-RECYCLED-TEMP-ZMAIL-BUFFER (STRING-APPEND (SINGLE-ZMAIL-BUFFER-NAME *ZMAIL-BUFFER*) "")))) (LET ((ARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER))) (DOLIST (MSG (NREVERSE LIST)) (VECTOR-PUSH-EXTEND MSG ARRAY))) (RETURN ZMAIL-BUFFER))) ((MEMQ CH '(#/ABORT #/C-])) (ABORT-CURRENT-COMMAND)) (T (BEEP))))) (SEND *SUMMARY-WINDOW* :SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING OLD-DOC) (UNMARK-ALL-MESSAGES) (SEND *SUMMARY-WINDOW* :NEED-FULL-REDISPLAY) (OR (EQ OLD-CONFIG *WINDOW-CONFIGURATION*) (SEND *ZMAIL-WINDOW* :SET-WINDOW-CONFIGURATION OLD-CONFIG)))) (DEFUN UNMARK-ALL-MESSAGES (&AUX ARRAY) (SETQ ARRAY (ZMAIL-BUFFER-ARRAY *ZMAIL-BUFFER*)) (DO ((I 0 (1+ I)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (TEM)) (( I NMSGS)) ;; Avoid ASSURE-MSG-PARSED, since messages that haven't been cannot be marked. (AND (SETQ TEM (GETL (LOCF (MSG-STATUS (AREF ARRAY I))) '(MARKED))) (SETF (CADR TEM) NIL)))) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION COM-ZMAIL-SURVEY "Survey messages in typeout window: L: all messages; M: last predicate; R: predicate menu.") (DEFINE-ZMAIL-GLOBAL *LAST-SURVEY-FILTER-DATA* NIL) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-SURVEY "Survey set of messages in typeout window. Click right to give filter." (NO-MSG-OK) (LET ((MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER) (MAP-ARG *ZMAIL-BUFFER*) (FILTER-FUNCTION 'MSG-TRUE-FILTER) (FILTER-ARG NIL)) (COND ((EQ *ZMAIL-COMMAND-BUTTON* :RIGHT) (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (GET-FILTER-FUNCTION (RECTANGLE-NEAR-COMMAND-MENU))) (SETQ *LAST-SURVEY-FILTER-DATA* (LIST MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))) ((EQ *ZMAIL-COMMAND-BUTTON* :MIDDLE) (UNLESS *LAST-SURVEY-FILTER-DATA* (BARF)) (SETF (LIST MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) *LAST-SURVEY-FILTER-DATA*))) (SURVEY-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))) (DEFPROP COM-ZMAIL-SURVEY SURVEY-FROM-FILTER ASSOCIATED-MAP-COMMAND) (DEFUN SURVEY-FROM-FILTER (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG &AUX *TERMINAL-IO*) (IF (TV:SHEET-EXPOSED-P *SUMMARY-WINDOW*) (SETQ *TERMINAL-IO* (SEND *SUMMARY-WINDOW* :TYPEOUT-WINDOW)) (SETQ *TERMINAL-IO* (WINDOW-TYPEOUT-WINDOW *WINDOW*)) (SEND *STANDARD-OUTPUT* :LINE-OUT *SUMMARY-WINDOW-LABEL*)) ; (TV:WINDOW-CALL (*TERMINAL-IO*) ;For **MORE** blinking (LET ((*N* 0)) (FUNCALL MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG #'(LAMBDA (MSG STREAM &AUX STATUS) (SETQ STATUS (ASSURE-MSG-PARSED MSG)) (SEND STREAM :TRUNCATED-ITEM 'SUMMARY-LINE MSG "~\ARROW\~3D~C~A" (EQ MSG *MSG*) (SETQ *N* (1+ *N*)) (STATUS-LETTER STATUS) (MSG-SUMMARY-LINE MSG)) (SEND STREAM :TYO #/CR)) *STANDARD-OUTPUT*)) (SEND *STANDARD-OUTPUT* :LINE-OUT "Done.") (CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT) DIS-NONE) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* SUMMARY-LINE "Select" SELECT-MSG-AND-POSSIBLY-ZMAIL-BUFFER T "Select this message.") (DEFINE-ZMAIL-GLOBAL *LAST-GOTO-FILTER-FUNCTION* NIL) (DEFINE-ZMAIL-GLOBAL *LAST-GOTO-FILTER-ARG* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER COM-ZMAIL-GOTO (STRING) (APPEND-TO-ARRAY STRING "Move to message from filter: ") (COND (*LAST-GOTO-FILTER-FUNCTION* (APPEND-TO-ARRAY STRING "L: ") (APPEND-TO-ARRAY STRING (FILTER-FUNCTION-BUFFER-NAME *LAST-GOTO-FILTER-FUNCTION* *LAST-GOTO-FILTER-ARG*)) (APPEND-TO-ARRAY STRING "; "))) (APPEND-TO-ARRAY STRING "M: point pdl; R: specify filter.")) (DEFINE-ZMAIL-TOP-LEVEL-COMMAND COM-ZMAIL-GOTO "Move to next message fitting a particular filter. Left default to last filter used. Middle gives a menu of recent messages. Right to specify the filter." () (IF (EQ *ZMAIL-COMMAND-BUTTON* :MIDDLE) (COM-ZMAIL-MOUSE-POINT-PDL) (LET ((MAP-FUNCTION 'MAP-OVER-REST-OF-ZMAIL-BUFFER) (MAP-ARG *ZMAIL-BUFFER*) (FILTER-FUNCTION *LAST-GOTO-FILTER-FUNCTION*) (FILTER-ARG *LAST-GOTO-FILTER-ARG*)) (IF (NEQ *ZMAIL-COMMAND-BUTTON* :RIGHT) (OR FILTER-FUNCTION (BARF "There is no default for this command yet")) (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (GET-FILTER-FUNCTION-1 MAP-FUNCTION MAP-ARG (FORMAT NIL "Rest of ~A" (ZMAIL-BUFFER-NAME MAP-ARG)) (RECTANGLE-NEAR-COMMAND-MENU))) (SETQ *LAST-GOTO-FILTER-FUNCTION* FILTER-FUNCTION *LAST-GOTO-FILTER-ARG* FILTER-ARG) (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION 'COM-ZMAIL-GOTO)) (LET ((MSG (FIND-MSG-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))) (OR MSG (BARF "No more messages of this type")) (SELECT-MSG-AND-POSSIBLY-ZMAIL-BUFFER MSG))))) (DEFUN FIND-MSG-FROM-FILTER (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) "Return the first message among those mapped over which fits the filter." (*CATCH 'FOUND (FUNCALL MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG #'(LAMBDA (MSG IGNORE) (*THROW 'FOUND MSG)) NIL) NIL)) (DEFUN (COM-ZMAIL-NEXT ASSOCIATED-MAP-COMMAND) (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (AND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER) (SETQ MAP-FUNCTION 'MAP-OVER-REST-OF-ZMAIL-BUFFER)) (LET ((MSG (FIND-MSG-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))) (OR MSG (BARF "No more messages of this type")) (SELECT-MSG-AND-POSSIBLY-ZMAIL-BUFFER MSG))) (DEFUN (COM-ZMAIL-PREVIOUS ASSOCIATED-MAP-COMMAND) (MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG) (AND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER) (SETQ MAP-FUNCTION 'MAP-OVER-BEGINNING-OF-ZMAIL-BUFFER)) (LET ((MSG (FIND-MSG-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG))) (OR MSG (BARF "No more messages of this type")) (SELECT-MSG-AND-POSSIBLY-ZMAIL-BUFFER MSG))) (DEFVAR *SYSTEM-FILTER-ALIST* '(("Deleted" :VALUE DELETED :DOCUMENTATION "Messages marked as deleted.") ("Unseen" :VALUE UNSEEN :DOCUMENTATION "Messages never displayed before.") ("Recent" :VALUE RECENT :DOCUMENTATION "Messages read in since last expunge.") ("Answered" :VALUE ANSWERED :DOCUMENTATION "Messages to which replies have been sent.") ("Filed" :VALUE FILED :DOCUMENTATION "Messages that have been moved into another file.") ("Search" :VALUE :SEARCH :DOCUMENTATION "Messages containing a given string."))) (DEFFLAVOR ZMAIL-COMMAND-MENU-PANE () TV:(WHITESPACE-PANE-MIXIN COMMAND-MENU-MIXIN BASIC-MENU TOP-LABEL-MIXIN BORDERS-MIXIN BASIC-SCROLL-BAR MINIMUM-WINDOW) (:DEFAULT-INIT-PLIST :COLUMNS 1 :BORDERS 2 :LABEL NIL :FONT-MAP '(FONTS:HL12B FONTS:HL12BI))) (DEFFLAVOR FILTER-SELECTION-FRAME () (TV:TEMPORARY-WINDOW-MIXIN TV:ANY-TYI-MIXIN TV:STREAM-MIXIN TV:BORDERS-MIXIN TV:ITEM-LIST-PANE-KLUDGE TV:FRAME-WITH-XOR-BUTTONS TV:CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER TV:MINIMUM-WINDOW)) ;;;; This page is entirely concerned with arranging the panes of the filter selection frame. (DEFMETHOD (FILTER-SELECTION-FRAME :BEFORE :INIT) (IGNORE) (SETQ TV:PANES `((UNIVERSE-BUTTON TV:BIG-BUTTON-WITH-TOP-OUTSIDE-LABEL-PANE :LABEL "Universe:" :DOCUMENTATION "Give a menu of universes, buffers, and universe creation techniques.") (NOT-BUTTON TV:BUTTON-PANE :NAME "Not" :DOCUMENTATION "Toggle negation of filter.") (KEYWORD-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST NIL :LABEL "Keywords:") (SYSTEM-FILTER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST ,`(("All" :VALUE :ALL :DOCUMENTATION "All messages in this universe.") ,@*SYSTEM-FILTER-ALIST* ("From//To" :VALUE :FROM-TO :DOCUMENTATION "Messages with a given From or To field, read from the keyboard or from message in summary.") ("Subject" :VALUE :SUBJECT :DOCUMENTATION "Messages with a given Subject field, read from the keyboard or from message in summary."))) (USER-FILTER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST NIL :LABEL "Filters:") (ABORT-BUTTON TV:BUTTON-PANE :NAME "Abort" :DOCUMENTATION "Abort this command.")) TV:CONSTRAINTS (LIST (FILTER-SELECTION-FRAME-MAKE-CONSTRAINT 'WITH T) (FILTER-SELECTION-FRAME-MAKE-CONSTRAINT 'WITHOUT NIL)))) (DEFUN FILTER-SELECTION-FRAME-MAKE-CONSTRAINT (NAME UNIVERSE-P) `(,NAME . ((WHOLE-THING) ((WHOLE-THING :HORIZONTAL (:EVEN) (WHOLE) ((WHOLE TV:WHITE-INCLUDE-WHITESPACE ;Vert (0.95) (:EVEN) (,@(AND UNIVERSE-P '(UNIVERSAL)) MENUS CONTROLS) ,@(AND UNIVERSE-P '(((UNIVERSAL TV:SINGLE-PANE-IN-WHITESPACE UNIVERSE-BUTTON)))) ((CONTROLS TV:SINGLE-PANE-IN-WHITESPACE ABORT-BUTTON)) ((MENUS TV:WHITE-INCLUDE-WHITESPACE ;Horiz (:ASK-WINDOW SELF :MENUS-SIZE) (:EVEN) (KEYWORD-MENUX SYSTEM-FILTER-AND-BUTTON USER-FILTER-MENUX) ((KEYWORD-MENUX TV:SINGLE-PANE-IN-WHITESPACE KEYWORD-MENU)) ((USER-FILTER-MENUX TV:SINGLE-PANE-IN-WHITESPACE USER-FILTER-MENU)) ((SYSTEM-FILTER-AND-BUTTON TV:PANES-IN-WHITESPACE (:ASK-WINDOW SYSTEM-FILTER-MENU :PANE-SIZE) (NOT-BUTTON SYSTEM-FILTER-MENU)))))))))))) (DEFMETHOD (FILTER-SELECTION-FRAME :MENUS-SIZE) (&REST ARGS) (MAX (LEXPR-SEND SELF :SEND-PANE 'KEYWORD-MENU :PANE-SIZE ARGS) (TRUNCATE (* (+ (LEXPR-SEND SELF :SEND-PANE 'NOT-BUTTON :PANE-SIZE ARGS) (LEXPR-SEND SELF :SEND-PANE 'SYSTEM-FILTER-MENU :PANE-SIZE ARGS)) 12.) 10.) (LEXPR-SEND SELF :SEND-PANE 'USER-FILTER-MENU :PANE-SIZE ARGS))) (DEFMETHOD (FILTER-SELECTION-FRAME :COMPUTE-GEOMETRY) (UNIVERSE-NAME KEYWORD-ALIST USER-FILTER-ALIST &AUX MAX-WIDTH MAX-HEIGHT CHANGED-P (CONFIG 'WITH)) (SETQ MAX-WIDTH TV:(- (SHEET-INSIDE-WIDTH SUPERIOR) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE) MAX-HEIGHT TV:(- (SHEET-INSIDE-HEIGHT SUPERIOR) TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)) (IF UNIVERSE-NAME (SEND SELF :SET-PANES-NAME 'UNIVERSE-BUTTON UNIVERSE-NAME) (SETQ CONFIG 'WITHOUT)) (SETQ CHANGED-P (NEQ CONFIG TV:CONFIGURATION)) (SETQ CHANGED-P (OR (SEND SELF :SET-PANES-ITEM-LIST 'KEYWORD-MENU KEYWORD-ALIST) CHANGED-P)) (SETQ CHANGED-P (OR (SEND SELF :SET-PANES-ITEM-LIST 'USER-FILTER-MENU USER-FILTER-ALIST) CHANGED-P)) (AND CHANGED-P (LET ((WID (MIN MAX-WIDTH (TRUNCATE (* (MAX (SEND SELF :SEND-PANE 'UNIVERSE-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (+ (SEND SELF :SEND-PANE 'KEYWORD-MENU :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'SYSTEM-FILTER-MENU :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'USER-FILTER-MENU :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL)) (SEND SELF :SEND-PANE 'ABORT-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL)) 15.) 10.))) (HEI (MIN MAX-HEIGHT (TRUNCATE (* (+ (SEND SELF :SEND-PANE 'UNIVERSE-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL) (SEND SELF :MENUS-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL) (SEND SELF :SEND-PANE 'ABORT-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL)) 12.) 10.)))) (IF (AND (= WID (TV:SHEET-INSIDE-WIDTH)) (= HEI (TV:SHEET-INSIDE-HEIGHT))) (SEND SELF :SET-CONFIGURATION CONFIG) (OR (EQ CONFIG TV:CONFIGURATION) (SEND SELF :SET-CONFIGURATION CONFIG)) (SEND SELF :SET-INSIDE-SIZE WID HEI))))) (DEFUN GET-FILTER-FUNCTION (&OPTIONAL (NEAR-MODE '(:MOUSE))) "Ask user to choose a filter, using the filter selection frame. The user also specifies a domain to map over -- possibly a defined universe. Values are map function and arg, and filter function and arg." (DECLARE (RETURN-LIST MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)) (OR *ZMAIL-BUFFER* (BARF "There is no current buffer")) (GET-FILTER-FUNCTION-1 'MAP-OVER-SINGLE-ZMAIL-BUFFER *ZMAIL-BUFFER* (ZMAIL-BUFFER-NAME *ZMAIL-BUFFER*) NEAR-MODE)) (DEFUN GET-FILTER-FUNCTION-1 (MAP-FUNCTION MAP-ARG NAME NEAR-MODE &AUX FILTER-FUNCTION FILTER-ARG NOT-P) (DECLARE (RETURN-LIST MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)) (SEND *FILTER-SELECTION-FRAME* :COMPUTE-GEOMETRY NAME (APPEND '(("Any" :VALUE ANY :FONT FONTS:HL12BI :DOCUMENTATION "Messages with any keyword on them.")) *KEYWORD-ALIST* NIL) ;Use a copy of the keyword-alist. (APPEND *USER-FILTER-ALIST* '(("New filter" :VALUE :NEW-FILTER :FONT FONTS:HL12BI :DOCUMENTATION "Define and use a new filter.")))) (SEND *FILTER-SELECTION-FRAME* :TURN-OFF-ACCENTS) (UNWIND-PROTECT (PROGN (TV:EXPOSE-WINDOW-NEAR *FILTER-SELECTION-FRAME* NEAR-MODE) (DO ((CHAR)) (NIL) (SETQ CHAR (SEND *FILTER-SELECTION-FRAME* :ANY-TYI)) (IF (ATOM CHAR) (TV:BEEP) (CASE (FIRST CHAR) (:MOUSE-BUTTON (IF (SEND (THIRD CHAR) :OPERATION-HANDLED-P :SET-ACCENT) (LET* ((WINDOW (THIRD CHAR)) (WINDOW-NAME (SEND *FILTER-SELECTION-FRAME* :PANE-NAME WINDOW))) (UNWIND-PROTECT (CASE WINDOW-NAME (ABORT-BUTTON (ABORT-CURRENT-COMMAND)) (NOT-BUTTON) (UNIVERSE-BUTTON (MULTIPLE-VALUE-BIND (NEW-MAP-FUNCTION NEW-MAP-ARG NEW-NAME) (GET-UNIVERSE-FUNCTION `(:WINDOW ,*FILTER-SELECTION-FRAME*)) (AND NEW-MAP-FUNCTION (SETQ MAP-FUNCTION NEW-MAP-FUNCTION MAP-ARG NEW-MAP-ARG NAME NEW-NAME))) (SEND *FILTER-SELECTION-FRAME* :SET-PANES-NAME 'UNIVERSE-BUTTON NAME) (SEND *FILTER-SELECTION-FRAME* :EXPOSE) ) (OTHERWISE (ZMAIL-ERROR "~S is not a known window" (THIRD CHAR)))) (SEND WINDOW :SET-ACCENT (AND (EQ WINDOW-NAME 'NOT-BUTTON) (SETQ NOT-P (NOT NOT-P)))))))) (:MENU (SETQ FILTER-ARG (SEND (FOURTH CHAR) :EXECUTE-NO-SIDE-EFFECTS (SECOND CHAR))) (CASE (SEND *FILTER-SELECTION-FRAME* :PANE-NAME (FOURTH CHAR)) (KEYWORD-MENU (SETQ FILTER-FUNCTION (IF (EQ FILTER-ARG 'ANY) (IF NOT-P 'MSG-DOES-NOT-HAVE-KEYWORDS-P 'MSG-HAS-KEYWORDS-P) (IF NOT-P 'MSG-DOES-NOT-HAVE-KEYWORD-P 'MSG-HAS-KEYWORD-P)))) (SYSTEM-FILTER-MENU (SETQ FILTER-FUNCTION (COND ((EQ FILTER-ARG :ALL) (IF NOT-P 'MSG-FALSE-FILTER 'MSG-TRUE-FILTER)) ((EQ FILTER-ARG :SEARCH) (SEND *FILTER-SELECTION-FRAME* :DEACTIVATE) (MULTIPLE-VALUE-BIND (FUN KEY) (ZMAIL-READ-FIND-SEARCH-STRING "Messages containing string") (SETQ FILTER-ARG KEY) (CASE FUN (SEARCH (IF NOT-P 'MSG-DOES-NOT-HAVE-SEARCH-STRING 'MSG-HAS-SEARCH-STRING)) (FSM-SEARCH (IF NOT-P 'MSG-DOES-NOT-HAVE-FSM-SEARCH-STRING 'MSG-HAS-FSM-SEARCH-STRING)) (FSM-EXPR-SEARCH (IF NOT-P 'MSG-DOES-NOT-HAVE-FSM-EXPR-SEARCH-STRING 'MSG-HAS-FSM-EXPR-SEARCH-STRING))))) ((EQ FILTER-ARG :FROM-TO) (SEND *FILTER-SELECTION-FRAME* :DEACTIVATE) (LET (X) (MULTIPLE-VALUE (X FILTER-ARG) (CHOOSE-OR-READLINE-ADDRESS "From//To" NOT-P)) X)) ((EQ FILTER-ARG :SUBJECT) (SEND *FILTER-SELECTION-FRAME* :DEACTIVATE) (LET ((X (CHOOSE-MSG-OR-READLINE "Subject"))) (OR (STRINGP X) (SETQ X (GET-MSG-SUBJECT-CLEVERLY X))) (SETQ FILTER-ARG X)) (IF NOT-P 'MSG-DOES-NOT-HAVE-SUBJECT-STRING 'MSG-HAS-SUBJECT-STRING)) (T (IF NOT-P 'MSG-DOES-NOT-HAVE-ATTRIBUTE-P 'MSG-HAS-ATTRIBUTE-P))))) (USER-FILTER-MENU (COND ((EQ FILTER-ARG :NEW-FILTER) (SETQ NOT-P NIL) (SEND *FILTER-SELECTION-FRAME* :DEACTIVATE) (SETQ FILTER-ARG (DEFINE-NEW-FILTER)) (OR FILTER-ARG (ABORT-CURRENT-COMMAND)))) (SETQ FILTER-FUNCTION (IF NOT-P 'MSG-DOES-NOT-FIT-FILTER-P 'MSG-FITS-FILTER-P))) (OTHERWISE (ZMAIL-ERROR "~S is not a known window" (THIRD CHAR)))) (AND FILTER-FUNCTION (RETURN NIL))))))) (SEND *FILTER-SELECTION-FRAME* :DEACTIVATE)) (VALUES MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)) ;;; Map functions that implement that standard, simple domains to map over. ;;; A map function is always called with five arguments: ;;; an argument "for tha map function" which is computed ;;; at the same time as the map function is (eg, which buffer to map over), ;;; a filter function and an argument for it, ;;; and a processing function and an argument for it. ;;; MAP-OVER-SINGLE-MSG shows what these arguments are for. ;;; THe map function also has a MAP-FUNCTION-BUFFER-NAME-FUNCTION property. ;;; This function, given the argument "for the map function", ;;; returns a name to use for a subset buffer if that is what you are making. (DEFUN (MAP-OVER-SINGLE-MSG MAP-FUNCTION-BUFFER-NAME-FUNCTION) (MSG) (STRING-APPEND #/$ (MSG-SUMMARY-LINE MSG) #/$)) (DEFUN MAP-OVER-SINGLE-MSG (MSG FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG) (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG) (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG))) (DEFPROP MAP-OVER-SINGLE-ZMAIL-BUFFER SINGLE-ZMAIL-BUFFER-NAME MAP-FUNCTION-BUFFER-NAME-FUNCTION) (DEFUN SINGLE-ZMAIL-BUFFER-NAME (ZMAIL-BUFFER) (IF (ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER) (STRING-APPEND #/[ (ZMAIL-BUFFER-NAME ZMAIL-BUFFER) #/]) (SEND ZMAIL-BUFFER :FULL-NAME))) (DEFUN MAP-OVER-SINGLE-ZMAIL-BUFFER (ZMAIL-BUFFER FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG) (DOMSGS (MSG ZMAIL-BUFFER) (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG) (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG)))) (DEFUN (MAP-OVER-REST-OF-ZMAIL-BUFFER MAP-FUNCTION-BUFFER-NAME-FUNCTION) (ZMAIL-BUFFER) (STRING-APPEND #/ (SINGLE-ZMAIL-BUFFER-NAME ZMAIL-BUFFER))) (DEFUN MAP-OVER-REST-OF-ZMAIL-BUFFER (ZMAIL-BUFFER FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG &AUX INDEX ARRAY) (SETQ ARRAY (ZMAIL-BUFFER-ARRAY ZMAIL-BUFFER) INDEX (IF (EQ ZMAIL-BUFFER *ZMAIL-BUFFER*) (1+ *MSG-NO*) 0)) (DO ((INDEX INDEX (1+ INDEX)) (NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)) (MSG)) (NIL) (AND ( INDEX NMSGS) (OR (SEND ZMAIL-BUFFER :READ-NEXT-MSG) (RETURN NIL))) (SETQ MSG (AREF ARRAY INDEX)) (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG) (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG)))) (DEFUN (MAP-OVER-BEGINNING-OF-ZMAIL-BUFFER MAP-FUNCTION-BUFFER-NAME-FUNCTION) (ZMAIL-BUFFER) (STRING-APPEND #/ (SINGLE-ZMAIL-BUFFER-NAME ZMAIL-BUFFER))) (DEFUN MAP-OVER-BEGINNING-OF-ZMAIL-BUFFER (ZMAIL-BUFFER FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG &AUX ARRAY) (SETQ ARRAY (ZMAIL-BUFFER-ARRAY *ZMAIL-BUFFER*)) (DO ((N (1- (IF (EQ ZMAIL-BUFFER *ZMAIL-BUFFER*) *MSG-NO* (ARRAY-ACTIVE-LENGTH ARRAY))) (1- N)) (MSG)) ((< N 0) NIL) (SETQ MSG (AREF ARRAY N)) (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG) (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG)))) (DEFUN (MAP-OVER-LOADED-ZMAIL-BUFFERS MAP-FUNCTION-BUFFER-NAME-FUNCTION) (IGNORE) "[*]") (DEFUN MAP-OVER-LOADED-ZMAIL-BUFFERS (IGNORE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG) (DOLIST (ZMAIL-BUFFER *ZMAIL-BUFFER-LIST*) (COND ((ZMAIL-BUFFER-DISK-P ZMAIL-BUFFER) (ASSURE-ZMAIL-BUFFER-FULLY-LOADED ZMAIL-BUFFER) (MAP-OVER-SINGLE-ZMAIL-BUFFER ZMAIL-BUFFER FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG))))) (DEFUN (MAP-OVER-ALL-ZMAIL-BUFFERS MAP-FUNCTION-BUFFER-NAME-FUNCTION) (IGNORE) "[**]") (DEFUN MAP-OVER-ALL-ZMAIL-BUFFERS (IGNORE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG &AUX ZMAIL-BUFFER) ;; First all that are loaded (MAP-OVER-LOADED-ZMAIL-BUFFERS NIL FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG) (DOLIST (ALIST-ELEM (GET-ZMAIL-BUFFER-ALISTS T)) (SETQ ZMAIL-BUFFER (CDR ALIST-ELEM)) (COND ((OR (STRINGP ZMAIL-BUFFER) (TYPEP ZMAIL-BUFFER 'FS:PATHNAME)) (SETQ ZMAIL-BUFFER (ZMAIL-FIND-FILE-NOSELECT ZMAIL-BUFFER)) (ASSURE-ZMAIL-BUFFER-FULLY-LOADED ZMAIL-BUFFER) (MAP-OVER-SINGLE-ZMAIL-BUFFER ZMAIL-BUFFER FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG))))) ;;; Some built-in filter-functions. ;;; A filter function is called with two arguments: ;;; first a message, and then another arg whose meaning ;;; is specific to the particular filter function. ;;; This is the "filter function argument" that is passed to map functions, etc. ;;; Each filter function may have a FILTER-FUNCTION-BUFFER-NAME-FUNCTION property ;;; which is a function of one arg, the filter function argument, ;;; to return the second half of a name for a subset buffer. ;;; A filter defined by the user is not a filter-function. ;;; It serves as the filter-function-argument ;;; for the filter function MSG-FITS-FILTER-P. (DEFUN (MSG-HAS-KEYWORDS-P FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (IGNORE) "{*}") (DEFUN MSG-HAS-KEYWORDS-P (MSG IGNORE) (NOT (NULL (MSG-GET MSG 'KEYWORDS)))) (DEFPROP MSG-DOES-NOT-HAVE-KEYWORDS-P MSG-HAS-KEYWORDS-P FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-KEYWORDS-P (MSG IGNORE) (NULL (MSG-GET MSG 'KEYWORDS))) (DEFUN (MSG-HAS-KEYWORD-P FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (KEYWORD) (STRING-APPEND #/{ (CAR (RASSQ KEYWORD *KEYWORD-ALIST*)) #/})) (DEFUN MSG-HAS-KEYWORD-P (MSG KEYWORD) (MEMQ KEYWORD (MSG-GET MSG 'KEYWORDS))) (DEFPROP MSG-DOES-NOT-HAVE-KEYWORD-P MSG-HAS-KEYWORD-P FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-KEYWORD-P (MSG KEYWORD) (NOT (MEMQ KEYWORD (MSG-GET MSG 'KEYWORDS)))) (DEFUN (MSG-TRUE-FILTER FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (IGNORE) "<*>") (DEFUN MSG-TRUE-FILTER (IGNORE IGNORE) T) (DEFPROP MSG-FALSE-FILTER MSG-TRUE-FILTER FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-FALSE-FILTER (IGNORE IGNORE) NIL) (DEFUN (MSG-HAS-ATTRIBUTE-P FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (ATTRIBUTE) (STRING-APPEND #/< (SYSTEM-ATTRIBUTE-NAME ATTRIBUTE) #/>)) (DEFUN SYSTEM-ATTRIBUTE-NAME (ATTRIBUTE) (OR (DOLIST (X *SYSTEM-FILTER-ALIST*) (AND (EQ ATTRIBUTE (GET X :VALUE)) (RETURN (CAR X)))) (STRING ATTRIBUTE))) (DEFUN MSG-HAS-ATTRIBUTE-P (MSG ATTRIBUTE) (NOT (NULL (MSG-GET MSG ATTRIBUTE)))) (DEFPROP MSG-DOES-NOT-HAVE-ATTRIBUTE-P MSG-HAS-ATTRIBUTE-P FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-ATTRIBUTE-P (MSG ATTRIBUTE) (NOT (MSG-GET MSG ATTRIBUTE))) (DEFUN (MSG-FITS-FILTER-P FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (FILTER) (STRING-APPEND #/< FILTER #/>)) (DEFUN MSG-FITS-FILTER-P (MSG FILTER) (NOT (NULL (FUNCALL (OR (GET FILTER 'FILTER-FUNCTION) (ZMAIL-ERROR "~S is not the name of a filter" FILTER)) MSG)))) (DEFPROP MSG-DOES-NOT-FIT-FILTER-P MSG-FITS-FILTER-P FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-FIT-FILTER-P (MSG FILTER) (NOT (FUNCALL (OR (GET FILTER 'FILTER-FUNCTION) (ZMAIL-ERROR "~S is not the name of a filter" FILTER)) MSG))) (DEFUN (MSG-HAS-SEARCH-STRING FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (KEY) (STRING-APPEND "(Search: " KEY ")")) (DEFUN MSG-HAS-SEARCH-STRING (MSG KEY) (NOT (NULL (ZWEI-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG))))) (DEFPROP MSG-DOES-NOT-HAVE-SEARCH-STRING MSG-HAS-SEARCH-STRING FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-SEARCH-STRING (MSG KEY) (NULL (ZWEI-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG)))) (DEFUN MSG-HAS-FSM-SEARCH-STRING (MSG KEY) (NOT (NULL (FSM-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG))))) (DEFUN MSG-DOES-NOT-HAVE-FSM-SEARCH-STRING (MSG KEY) (NULL (FSM-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG)))) (DEFUN MSG-HAS-FSM-EXPR-SEARCH-STRING (MSG KEY) (NOT (NULL (FSM-EXPR-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG))))) (DEFUN MSG-DOES-NOT-HAVE-FSM-EXPR-SEARCH-STRING (MSG KEY) (NULL (FSM-EXPR-SEARCH (MSG-START-BP MSG) KEY NIL NIL NIL (MSG-END-BP MSG)))) (DEFUN (MSG-HAS-RECIPIENT-FIELD FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (FIELD) (STRING-APPEND "(Recipient: " FIELD #/))) (DEFUN MSG-HAS-RECIPIENT-FIELD (MSG FIELD &AUX (STATUS (ASSURE-MSG-PARSED MSG))) (DOLIST (F *RECIPIENT-TYPE-HEADERS*) (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD) (RETURN T)))) (DEFPROP MSG-DOES-NOT-HAVE-RECIPIENT-FIELD MSG-HAS-RECIPIENT-FIELD FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-RECIPIENT-FIELD (MSG FIELD &AUX (STATUS (ASSURE-MSG-PARSED MSG))) (NOT (DOLIST (F *RECIPIENT-TYPE-HEADERS*) (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD) (RETURN T))))) (DEFUN (MSG-HAS-FROM-FIELD FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (FIELD) (STRING-APPEND "(From: " FIELD #/))) (DEFUN MSG-HAS-FROM-FIELD (MSG FIELD) (MSG-HEADER-RECIPIENT-MATCH (MSG-GET MSG :FROM) FIELD)) (DEFPROP MSG-DOES-NOT-HAVE-FROM-FIELD MSG-HAS-FROM-FIELD FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-FROM-FIELD (MSG FIELD) (NOT (MSG-HEADER-RECIPIENT-MATCH (MSG-GET MSG :FROM) FIELD))) (DEFUN (MSG-HAS-SENDER-OR-RECIPIENT-FIELD FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (FIELD) (STRING-APPEND "(From//To: " FIELD #/))) (DEFUN MSG-HAS-SENDER-OR-RECIPIENT-FIELD (MSG FIELD &AUX (STATUS (ASSURE-MSG-PARSED MSG))) (DOLIST (F *SENDER-OR-RECIPIENT-TYPE-HEADERS*) (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD) (RETURN T)))) (DEFPROP MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD MSG-HAS-SENDER-OR-RECIPIENT-FIELD FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD (MSG FIELD &AUX (STATUS (ASSURE-MSG-PARSED MSG))) (NOT (DOLIST (F *SENDER-OR-RECIPIENT-TYPE-HEADERS*) (AND (MSG-HEADER-RECIPIENT-MATCH (GET STATUS F) FIELD) (RETURN T))))) (DEFUN (MSG-HAS-SUBJECT-STRING FILTER-FUNCTION-BUFFER-NAME-FUNCTION) (KEY) (STRING-APPEND "(Subject: " KEY #/))) (DEFUN MSG-HAS-SUBJECT-STRING (MSG KEY &AUX SUBJECT) (NOT (NULL (AND (SETQ SUBJECT (MSG-GET MSG :SUBJECT)) (IF (CONSP SUBJECT) (LOOP FOR STRING IN SUBJECT THEREIS (STRING-SEARCH KEY STRING)) (STRING-SEARCH KEY SUBJECT)))))) (DEFPROP MSG-DOES-NOT-HAVE-SUBJECT-STRING MSG-HAS-SUBJECT-STRING FILTER-FUNCTION-OPPOSITE-FUNCTION) (DEFUN MSG-DOES-NOT-HAVE-SUBJECT-STRING (MSG KEY &AUX SUBJECT) (NOT (AND (SETQ SUBJECT (MSG-GET MSG :SUBJECT)) (IF (CONSP SUBJECT) (LOOP FOR STRING IN SUBJECT THEREIS (STRING-SEARCH KEY STRING)) (STRING-SEARCH KEY SUBJECT))))) ;;; The filter definition frame, which appears if you ask to define a new filter ;;; when in the filter selection frame (and in other ways). (DEFFLAVOR ZMAIL-FILTER-FRAME () (ZMAIL-COMMAND-LOOP-MIXIN-WITH-SUMMARY TV:SELECT-MIXIN ZMAIL-UTILITY-FRAME) (:DEFAULT-INIT-PLIST :EDITOR-CLOSURE-VARIABLES ZMAIL-FILTER-FRAME-EDITOR-CLOSURE-VARIABLES :COMTAB *STANDALONE-COMTAB*)) (DEFVAR *EDITOR-WINDOW* :UNBOUND) (DEFVAR *EDITOR-INTERVAL* :UNBOUND) (DEFVAR *EDITOR-ISTREAM* :UNBOUND) (DEFVAR *EDITOR-INSERT-BP* :UNBOUND) (DEFCONST ZMAIL-FILTER-FRAME-EDITOR-CLOSURE-VARIABLES (MERGE-CLOSURE-VARIABLE-LISTS '((*MODE-LINE-LIST* '("ZMail " "Filter")) (*MAJOR-MODE* NIL) (*STANDARD-OUTPUT* SI:SYN-TERMINAL-IO) (*QUERY-IO* SYN-TYPEIN-WINDOW-IO) (*SELECTABLE-MODE-LINE-ELEMENTS* NIL) (*EDITOR-WINDOW* NIL) (*EDITOR-INTERVAL* NIL) (*EDITOR-ISTREAM* NIL) (*EDITOR-INSERT-BP* NIL)) TOP-LEVEL-EDITOR-CLOSURE-VARIABLES)) (DEFMETHOD (ZMAIL-FILTER-FRAME :TOP-OF-EDITOR-HIERARCHY) () SELF) (DEFMETHOD (ZMAIL-FILTER-FRAME :AFTER :INIT) (IGNORE) (SETQ MODE-LINE-WINDOW (SEND SELF :GET-PANE 'MODE-LINE-WINDOW)) (SYS:%USING-BINDING-INSTANCES (CLOSURE-BINDINGS EDITOR-CLOSURE)) (SETQ *EDITOR-WINDOW* (SEND SELF :GET-PANE 'EDITOR-WINDOW)) (SEND *EDITOR-WINDOW* :SET-EDITOR-CLOSURE EDITOR-CLOSURE) (INITIALIZE-TOP-LEVEL-EDITOR *EDITOR-WINDOW* T) (SETQ *EDITOR-INTERVAL* *INTERVAL*) (SETQ *EDITOR-ISTREAM* (INTERVAL-STREAM *EDITOR-INTERVAL* NIL NIL :TYI)) (SETQ *EDITOR-INSERT-BP* (COPY-BP (POINT) :MOVES)) (SET-COMTAB *COMTAB* (LIST #/C-H (COMMAND-LOOKUP #/C-H *SEARCH-MINI-BUFFER-COMTAB*)))) (DEFVAR *HEADER-FILTER-MENU-ALIST* '(("To" :VALUE :TO :DOCUMENTATION "Messages to a recipient in the To: line") ("To//Cc" :VALUE :TO//CC :DOCUMENTATION "Messages to a recipient in TO:, CC:, Forwarded to:, etc.") ("From" :VALUE :FROM :DOCUMENTATION "Messages from a sender") ("Subject" :VALUE :SUBJECT :DOCUMENTATION "Messages with a given string anywhere in the subject line") ("Other" :VALUE :OTHER :DOCUMENTATION "messages with a string in an arbitrary header field"))) (DEFVAR *DATE-FILTER-MENU-ALIST* '(("Before" :VALUE :BEFORE :DOCUMENTATION "Messages before a given constant date") ("On" :VALUE :ON :DOCUMENTATION "Messages on a specific date") ("After" :VALUE :AFTER :DOCUMENTATION "Messages after a specific date"))) ;;; Arrange the panes of the filter definition frame. (DEFMETHOD (ZMAIL-FILTER-FRAME :BEFORE :INIT) (IGNORE &AUX MODE-LINE-LINE-HEIGHT MODE-LINE-HEIGHT) (SETQ MODE-LINE-LINE-HEIGHT (+ 2 (MAX (FONT-CHAR-HEIGHT TV:(SCREEN-DEFAULT-FONT (SHEET-GET-SCREEN SUPERIOR))) (FONT-CHAR-HEIGHT FONTS:SEARCH))) MODE-LINE-HEIGHT (+ 11 (* 3 MODE-LINE-LINE-HEIGHT))) (SETQ TV:PANES `((NOT-BUTTON TV:BUTTON-PANE :NAME "Not" :DOCUMENTATION "Negate a clause.") (AND-BUTTON TV:BUTTON-PANE :NAME "And" :DOCUMENTATION "Logical and of several clauses.") (OR-BUTTON TV:BUTTON-PANE :NAME "Or" :DOCUMENTATION "Logical or of several clauses.") (CLOSE-BUTTON TV:BUTTON-PANE :NAME "Close" :DOCUMENTATION "Add clauses to the next higher AND or OR.") (SAMPLE-BUTTON TV:BUTTON-PANE :NAME "Sample" :DOCUMENTATION "Show messages matching the filter as so far defined in the typeout window.") (DONE-BUTTON TV:BUTTON-PANE :NAME "Done" :DOCUMENTATION "Use this filter definition.") (ABORT-BUTTON TV:BUTTON-PANE :NAME "Abort" :DOCUMENTATION "Abort this command.") (KEYWORD-COMMAND-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST NIL :LABEL "Keywords:") (USER-FILTER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST NIL :LABEL "Filters:") (SYSTEM-FILTER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST ,*SYSTEM-FILTER-ALIST*) (HEADER-FILTER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST ,*HEADER-FILTER-MENU-ALIST*) (DATE-FILTER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST ,*DATE-FILTER-MENU-ALIST*) (NAME-BUTTON TV:BIG-BUTTON-PANE :NAME "Name" :BORDERS 3 :DOCUMENTATION "Specify a new name for this filter. Click right for a menu of existing filters to edit.") (EDITOR-WINDOW ZMAIL-WINDOW :LABEL NIL :BORDERS (2 2 2 1) :SAVE-BITS NIL :FONT-MAP (FONTS:CPTFONT FONTS:SEARCH)) (MODE-LINE-WINDOW ZMAIL-MOUSE-SENSITIVE-MODE-LINE-PANE :HEIGHT ,MODE-LINE-HEIGHT :MORE-P NIL :BORDERS (2 1 2 2) :BLINKER-DESELECTED-VISIBILITY :OFF)) TV:CONSTRAINTS `((ONLY . ((WHOLE-THING) ((WHOLE-THING TV:WHITE-INCLUDE-WHITESPACE ;Horiz (0.9) (:EVEN) (MENUS FORM) ((FORM TV:WHITE-INCLUDE-WHITESPACE ;Vert (0.625) (:EVEN) (NAMEX EDITORSS) ((NAMEX TV:SINGLE-PANE-IN-WHITESPACE NAME-BUTTON)) ((EDITORSS :HORIZONTAL (0.85) (EDITORS) ((EDITORS :VERTICAL (:EVEN) (EDITOR-WINDOW MODE-LINE-WINDOW) ((MODE-LINE-WINDOW ,MODE-LINE-HEIGHT)) ((EDITOR-WINDOW :EVEN)))))))) ((MENUS TV:WHITE-INCLUDE-WHITESPACE ;Vert (0.95) (:EVEN) (CONDITIONALS CONTROLS SYSTEM-MENUS USER-MENUS) ((CONDITIONALS TV:FLOATING-BUTTONS (NOT-BUTTON AND-BUTTON OR-BUTTON CLOSE-BUTTON))) ((CONTROLS TV:FLOATING-BUTTONS (SAMPLE-BUTTON DONE-BUTTON ABORT-BUTTON))) ((SYSTEM-MENUS TV:FLOATING-MENUS (:ASK-WINDOW SYSTEM-FILTER-MENU :PANE-SIZE-WITH-WHITESPACE) (SYSTEM-FILTER-MENU HEADER-FILTER-MENU DATE-FILTER-MENU))) ((USER-MENUS TV:FLOATING-MENUS (:ASK-WINDOW SELF :USER-MENUS-SIZE) (KEYWORD-COMMAND-MENU USER-FILTER-MENU)))))))))))) (DEFMETHOD (ZMAIL-FILTER-FRAME :USER-MENUS-SIZE) (&REST ARGS) (MAX (LEXPR-SEND SELF :SEND-PANE 'KEYWORD-COMMAND-MENU :PANE-SIZE-WITH-WHITESPACE ARGS) (LEXPR-SEND SELF :SEND-PANE 'USER-FILTER-MENU :PANE-SIZE-WITH-WHITESPACE ARGS))) ;; This is sent when the window configuration is changed to :FILTER. (DEFMETHOD (ZMAIL-FILTER-FRAME :INITIALIZE) (&AUX NEW-NAME CHANGED-P) (SETQ NEW-NAME (GENERATE-UNIQUE-NAME *USER-FILTER-ALIST*)) (SETQ CHANGED-P (SEND SELF :SET-PANES-ITEM-LIST 'KEYWORD-COMMAND-MENU (APPEND '(("Any" :VALUE ANY :FONT FONTS:HL12BI :DOCUMENTATION "Messages with any keyword on them.")) *KEYWORD-ALIST* NIL))) (SETQ CHANGED-P (OR (SEND SELF :SET-PANES-ITEM-LIST 'USER-FILTER-MENU (COPYLIST *USER-FILTER-ALIST*)) CHANGED-P)) (AND CHANGED-P (SEND SELF :SET-CONFIGURATION 'ONLY)) (SEND SELF :TURN-OFF-ACCENTS) (SEND SELF :SET-PANES-NAME 'NAME-BUTTON NEW-NAME) (SEND SELF :SET-SELECTION-SUBSTITUTE NIL) (SYS:%USING-BINDING-INSTANCES (CLOSURE-BINDINGS EDITOR-CLOSURE)) (UNLESS (EQ *MAJOR-MODE* 'LISP-MODE) (COM-LISP-MODE)) (LET ((*BATCH-UNDO-SAVE* T)) (DELETE-INTERVAL *EDITOR-INTERVAL*) (INSERT-FORM-INTO-WINDOW `(DEFINE-FILTER ,(INTERN (STRING-UPCASE NEW-NAME)) (MSG)) -1)) (SETF (WINDOW-BASE-TICK *EDITOR-WINDOW*) (TICK)) (DISCARD-UNDO-INFORMATION *EDITOR-INTERVAL*) (MUST-REDISPLAY *EDITOR-WINDOW* DIS-ALL) (FORMAT *QUERY-IO* "~&") (SEND SELF :SET-SELECTION-SUBSTITUTE NIL)) ;;; These are the methods that :COMMAND-LOOP expects us to provide. (DEFMETHOD (ZMAIL-FILTER-FRAME :TOP-LEVEL-TAG) () 'EXIT-FILTER-DEFINITION) (DEFMETHOD (ZMAIL-FILTER-FRAME :PROCESS-SPECIAL-COMMAND) (&REST ARGS) (APPLY 'ZMAIL-FILTER-COMMAND-LIST ARGS)) (DEFSELECT (ZMAIL-FILTER-COMMAND-LIST ZMAIL-COMMAND-LIST-DEFAULT) (:MENU (ITEM IGNORE WINDOW &AUX WINDOW-NAME ITEM-NAME) (SETQ WINDOW-NAME (SEND SELF :PANE-NAME WINDOW) ITEM-NAME (IF (ATOM ITEM) ITEM (CAR ITEM)) ITEM (SEND WINDOW :EXECUTE-NO-SIDE-EFFECTS ITEM)) (CASE WINDOW-NAME (KEYWORD-COMMAND-MENU (INSERT-FORM-INTO-WINDOW (IF (EQ ITEM 'ANY) 'KEYWORDS `(MEMQ ',ITEM KEYWORDS)))) (USER-FILTER-MENU (INSERT-FORM-INTO-WINDOW `(MSG-FITS-FILTER-P MSG ',ITEM))) (OTHERWISE (INSERT-FILTER ITEM-NAME ITEM))) DIS-NONE) (SELECT-WINDOW (WINDOW) ;Moused a window, edit there (TV:WITH-SELECTION-SUBSTITUTE (WINDOW SELF) ; (MAKE-WINDOW-CURRENT WINDOW) (*CATCH 'ABORT-STANDALONE-EDIT (SEND *WINDOW* :EDIT))) DIS-NONE) (:MOUSE-BUTTON (CH WINDOW IGNORE IGNORE &AUX WINDOW-NAME) (COND ((EQ WINDOW *WINDOW*) (SEND *STANDARD-INPUT* :UNTYI *LAST-COMMAND-CHAR*) (SEND SELF :PROCESS-SPECIAL-COMMAND 'SELECT-WINDOW *WINDOW*)) ((SEND WINDOW :OPERATION-HANDLED-P :SET-ACCENT) (SETQ WINDOW-NAME (SEND SELF :PANE-NAME WINDOW)) (UNWIND-PROTECT (CASE WINDOW-NAME (ABORT-BUTTON (*THROW 'EXIT-FILTER-DEFINITION NIL)) (DONE-BUTTON (*THROW 'EXIT-FILTER-DEFINITION (GET-AND-COMPILE-FILTER))) (SAMPLE-BUTTON (LET ((MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER) (MAP-ARG *ZMAIL-BUFFER*)) (AND (= CH #/MOUSE-3-1) (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG) (GET-UNIVERSE-FUNCTION `(:WINDOW ,SELF)))) (OR MAP-FUNCTION (ABORT-CURRENT-COMMAND)) (SURVEY-FROM-FILTER MAP-FUNCTION MAP-ARG 'MSG-FITS-FILTER-P (GET-AND-COMPILE-FILTER))) (CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT)) (NAME-BUTTON (READ-NEW-NAME WINDOW CH *USER-FILTER-ALIST* 'GET-FILTER-DEFINITION)) (CLOSE-BUTTON (EDITOR-WINDOW-CLOSE-BUTTON)) (OTHERWISE (INSERT-FORM-INTO-WINDOW `(,(CASE WINDOW-NAME (NOT-BUTTON 'NOT) (AND-BUTTON 'AND) (OR-BUTTON 'OR))) -1))) (SEND WINDOW :SET-ACCENT NIL))) (T NIL)) ;random window DIS-NONE) (SUMMARY-MOUSE (ITEM IGNORE IGNORE &AUX (MSG (CADR ITEM))) ;Mouse in summary window (EXTRACT-FILTERS-FROM-MSG MSG) DIS-NONE) ((:TYPEOUT-EXECUTE SUMMARY-EXECUTE) (&REST IGNORE) (BARF))) (DEFUN INSERT-FILTER (NAME TYPE) (INSERT-FORM-INTO-WINDOW (LET ((*TYPE* TYPE)) (DECLARE (SPECIAL *TYPE*)) (CONDITION-BIND ((UNKNOWN-SPECIAL-COMMAND 'ZMAIL-FILTER-MINI-BUFFER-UNKNOWN-SPECIAL-COMMAND)) (CASE TYPE ((DELETED UNSEEN ANSWERED RECENT FILED) `(GET STATUS ',TYPE)) (:SEARCH (LET ((KEY (READ-SEARCH-KEY-FROM-EDITOR-WINDOW "String to search for:"))) `(SEARCH-WITHIN-MSG ,KEY))) ((:TO :TO//CC :FROM :SUBJECT :OTHER) (COND ((EQ TYPE :OTHER) (MULTIPLE-VALUE (NAME TYPE) (READ-HEADER-NAME-FROM-EDITOR-WINDOW "Header name:")))) (LET ((KEY (READ-SEARCH-KEY-FROM-EDITOR-WINDOW (STRING-APPEND NAME #/:)))) (IF (ZEROP (STRING-LENGTH KEY)) `(NOT (NULL (GET STATUS ',TYPE))) `(,(IF (OR (MEMQ TYPE *ADDRESS-TYPE-HEADERS*) (EQ TYPE :TO//CC)) 'MSG-HEADER-RECIPIENT-SEARCH 'MSG-HEADER-SEARCH) ,(IF (EQ TYPE :TO//CC) '*RECIPIENT-TYPE-HEADERS* `',TYPE) ,KEY)))) ((:ON :BEFORE :AFTER) (MULTIPLE-VALUE-BIND (DATE RELATIVE-P) (READ-DATE-FROM-EDITOR-WINDOW "~A date:" NAME) (IF (NOT RELATIVE-P) `(,(CASE TYPE (:ON 'MSG-SAME-DATE) (:BEFORE 'MSG-DATE-LESSP) (:AFTER 'MSG-DATE-GREATERP)) ,DATE) `(,(CASE TYPE (:ON 'MSG-SAME-RELATIVE-DATE) (:BEFORE 'MSG-RELATIVE-DATE-LESSP) (:AFTER 'MSG-RELATIVE-DATE-GREATERP)) ,DATE ,(FORMAT-CURRENT-DATE-FOR-FILTER))))) ))))) (DEFUN INSERT-FORM-INTO-WINDOW (FORM &OPTIONAL (NCHARS 0) &AUX BP (POINT (POINT))) (SEND *EDITOR-ISTREAM* :SET-BP *EDITOR-INSERT-BP*) (LET ((*READTABLE* (INITIALIZE-SPECIAL-/#/"-READTABLE))) (GRIND-TOP-LEVEL FORM (SEND (WINDOW-SHEET *WINDOW*) :SIZE-IN-CHARACTERS) *EDITOR-ISTREAM* T 'SI:DISPLACED NIL)) (SETQ BP (SEND *EDITOR-ISTREAM* :READ-BP)) (MOVE-BP POINT (COND ((= NCHARS 0) BP) ((< NCHARS 0) (FORWARD-CHAR BP NCHARS)) (T (FORWARD-CHAR POINT NCHARS)))) (DO ((N) (FLAG NIL)) (FLAG) (DELETE-BACKWARD-OVER *WHITESPACE-CHARS* POINT) (SETQ FLAG T N (LET ((BP (FORWARD-SEXP POINT -1 NIL 1))) (IF BP (COUNT-LIST-ELEMENTS BP) 0))) (COND ((ZEROP N)) ((= N 1) (INSERT-MOVING POINT #/SP)) ((MEMQ (RELEVANT-FUNCTION-NAME POINT NIL NIL) '(NOT )) (MOVE-BP POINT (FORWARD-CHAR POINT 1)) (SETQ FLAG NIL)) (T (LET ((*NUMERIC-ARG-P* NIL) (*NUMERIC-ARG* 1)) (COM-INDENT-NEW-LINE))))) (MUST-REDISPLAY *WINDOW* DIS-TEXT) (MOVE-BP *EDITOR-INSERT-BP* POINT)) (DEFUN READ-SEARCH-KEY-FROM-EDITOR-WINDOW (PROMPT) (GET-EXTENDED-SEARCH-16B-STRING PROMPT)) (DEFUN READLINE-FROM-EDITOR-WINDOW (&REST PROMPT) (APPLY 'TYPEIN-LINE-READLINE PROMPT)) (DEFUN READ-HEADER-NAME-FROM-EDITOR-WINDOW (PROMPT) (LET ((KEY (COMPLETING-READ-FROM-MINI-BUFFER PROMPT *HEADER-NAME-ALIST* T))) (IF (STRINGP KEY) (VALUES KEY (INTERN (STRING-UPCASE KEY) "")) (VALUES (CAR KEY) (CDR KEY))))) (DEFUN FORMAT-DATE-FOR-FILTER (STRING) (DECLARE (RETURNS TIME-STRING RELATIVE-P)) (MULTIPLE-VALUE-BIND (TIME RELATIVE-P) (CONDITION-CASE (ERROR) (TIME:PARSE-UNIVERSAL-TIME STRING 0 NIL NIL) ;Parse it, assuming not in future (ERROR (BARF ERROR))) (IF (AND RELATIVE-P (Y-OR-N-P "Do you want that time relative to when the filter is run?")) (VALUES STRING RELATIVE-P) (MULTIPLE-VALUE-BIND (SECONDS-OR-ERRMES MINUTES HOURS DAY MONTH YEAR) (TIME:DECODE-UNIVERSAL-TIME TIME) (AND ( YEAR 1900.) (< YEAR 2000.) (SETQ YEAR (- YEAR 1900.))) (FORMAT-DATE-FOR-FILTER-INTERNAL SECONDS-OR-ERRMES MINUTES HOURS DAY MONTH YEAR))))) (DEFUN FORMAT-DATE-FOR-FILTER-INTERNAL (SECONDS MINUTES HOURS DAY MONTH YEAR) (FORMAT NIL "~D-~A-~D~:[ ~D:~2,48D~:[:~2,48D~]~]" DAY (TIME:MONTH-STRING MONTH :SHORT) YEAR (AND (ZEROP HOURS) (ZEROP MINUTES) (ZEROP SECONDS)) HOURS MINUTES (ZEROP SECONDS) SECONDS)) (DEFUN FORMAT-CURRENT-DATE-FOR-FILTER () (MULTIPLE-VALUE-BIND (SECONDS-OR-ERRMSG MINUTES HOURS DAY MONTH YEAR) (TIME:DECODE-UNIVERSAL-TIME (TIME:GET-UNIVERSAL-TIME)) (IF (ERRORP SECONDS-OR-ERRMSG) (BARF SECONDS-OR-ERRMSG) (FORMAT-DATE-FOR-FILTER-INTERNAL SECONDS-OR-ERRMSG MINUTES HOURS DAY MONTH YEAR)))) (DEFUN READ-DATE-FROM-EDITOR-WINDOW (&REST PROMPT) (LET ((STRING (APPLY 'TYPEIN-LINE-READLINE PROMPT))) (FORMAT-DATE-FOR-FILTER STRING))) ;; Condition handler function for UNKNOWN-SPECIAL-COMMAND condition. (DEFUN ZMAIL-FILTER-MINI-BUFFER-UNKNOWN-SPECIAL-COMMAND (&REST IGNORE &AUX MSG STRING) (DECLARE (SPECIAL *TYPE*)) (COND ((EQ (CAR *LAST-COMMAND-CHAR*) 'SUMMARY-MOUSE) (SETQ MSG (CADADR *LAST-COMMAND-CHAR*)) (SETQ STRING (MSG-HEADER-FILTER-STRING MSG *TYPE*)) (DELETE-INTERVAL *INTERVAL*) (INSERT-MOVING (POINT) STRING) (MUST-REDISPLAY *WINDOW* DIS-TEXT) (VALUES :NEW-VALUE T)))) (DEFUN MSG-HEADER-FILTER-STRING (MSG TYPE &AUX STATUS PROP) (SETQ STATUS (ASSURE-MSG-PARSED MSG)) (AND (MEMQ TYPE '(:ON :BEFORE :AFTER)) (SETQ TYPE :DATE)) (SETQ PROP (IF (EQ TYPE :TO//CC) (DO ((TYPES *RECIPIENT-TYPE-HEADERS* (CDR TYPES)) (L NIL)) ((NULL TYPES) L) (SETQ L (APPEND L (GET STATUS (CAR TYPES))))) (GET STATUS TYPE))) (COND ((NULL PROP) (BARF)) ((EQ TYPE :DATE) (OR PROP (BARF)) (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR) (TIME:DECODE-UNIVERSAL-TIME PROP) (AND ( YEAR 1900.) (< YEAR 2000.) (SETQ YEAR (- YEAR 1900.))) (FORMAT NIL "~D-~A-~D ~D:~2,48D:~2,48D" DAY (TIME:MONTH-STRING MONTH :SHORT) YEAR HOURS MINUTES SECONDS))) ((STRINGP PROP) PROP) ((NULL (CDR PROP)) (CANONICALIZE-RECIPIENT-FILTER-STRING (CAR PROP))) (T (UNWIND-PROTECT (PROGN (PRINT-TYPEOUT-FILTER (CAR (RASSQ TYPE *HEADER-FILTER-MENU-ALIST*)) 'MINI-BUFFER-STRING (MAPCAR 'CANONICALIZE-RECIPIENT-FILTER-STRING PROP)) (LET ((CH (SEND *STANDARD-INPUT* :ANY-TYI))) (OR (AND (CONSP CH) (EQ (CAR CH) :TYPEOUT-EXECUTE)) (BARF)) (CADDR CH))) (SEND *TYPEOUT-WINDOW* :MAKE-COMPLETE))))) (DEFUN CANONICALIZE-RECIPIENT-FILTER-STRING (STRING) (COND ((STRINGP STRING) STRING) ((NULL (CDR STRING)) (CAR STRING)) (T (STRING-FROM-HEADER STRING :SHORT)))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* MINI-BUFFER-STRING "Insert" STRING T "Insert this string.") (DEFUN EDITOR-WINDOW-CLOSE-BUTTON (&AUX (*NUMERIC-ARG* 1) (*NUMERIC-ARG-P* NIL) (*LAST-COMMAND-CHAR* #/))) (MUST-REDISPLAY *WINDOW* (COM-MOVE-OVER-/))) (MOVE-BP *EDITOR-INSERT-BP* (POINT))) (DEFUN READ-FROM-EDITOR-WINDOW (&AUX (FORM '*EOF*)) (SEND *EDITOR-ISTREAM* :SET-BP (INTERVAL-FIRST-BP *EDITOR-INTERVAL*)) (CATCH-ERROR (LET ((*READTABLE* (INITIALIZE-SPECIAL-/#/"-READTABLE))) (SETQ FORM (READ *EDITOR-ISTREAM* '*EOF*))) NIL) (AND (EQ FORM '*EOF*) (BARF "Unbalanced parentheses")) FORM) (DEFUN GET-AND-COMPILE-FILTER (&AUX FILTER-PROP FILTER) (SETQ *TYPEOUT-WINDOW* (WINDOW-TYPEOUT-WINDOW *WINDOW*) *TERMINAL-IO* *TYPEOUT-WINDOW*) (SEND *TYPEOUT-WINDOW* :MAKE-COMPLETE) (SETQ FILTER-PROP (EVAL (READ-FROM-EDITOR-WINDOW))) (OR (AND (EQ (CAR FILTER-PROP) :PROPERTY) (EQ (CADDR FILTER-PROP) 'FILTER-FUNCTION)) (BARF "Does not look like a filter definition")) (SETQ FILTER (CADR FILTER-PROP)) (PUTPROP FILTER (GET FILTER 'FILTER-FUNCTION) 'EXPR-FILTER-FUNCTION) (COMPILE FILTER-PROP) (AND (SEND *TYPEOUT-WINDOW* :INCOMPLETE-P) ;If there are warning messages, (NOT (LET ((*QUERY-IO* *TYPEOUT-WINDOW*)) (Y-OR-N-P "Ok? "))) ;user has chance to not exit (ABORT-CURRENT-COMMAND)) FILTER) (DEFUN READ-NEW-NAME (NAME-BUTTON CHAR CHOICE-LIST DEFINITION-ACCESS-FUNCTION &AUX STRING) (COND ((= CHAR #/MOUSE-1-1) ;Left button gets new one (SETQ STRING (READLINE-FROM-EDITOR-WINDOW "New name:")) (LET ((BP (FORWARD-OVER *BLANKS* (FORWARD-ATOM (INTERVAL-FIRST-BP *INTERVAL*))))) (SETQ BP (DELETE-INTERVAL BP (FORWARD-ATOM BP) T)) (INSERT BP (FORMAT NIL "~S" (INTERN STRING)))) (MUST-REDISPLAY *WINDOW* DIS-TEXT)) (T (SETQ STRING (TV:MENU-CHOOSE CHOICE-LIST NIL `(:WINDOW ,NAME-BUTTON))) (OR STRING (ABORT-CURRENT-COMMAND)) (DELETE-INTERVAL *INTERVAL*) (INSERT-FORM-INTO-WINDOW (FUNCALL DEFINITION-ACCESS-FUNCTION STRING)) (SETQ STRING (STRING STRING)))) (SEND (TV:SHEET-SUPERIOR NAME-BUTTON) :SET-PANES-NAME 'NAME-BUTTON STRING)) (DEFVAR *FILTER-DEFINITION-SUMMARY-DOCUMENTATION* "Select filters based on this message.") (DEFUN DEFINE-NEW-FILTER (&AUX OLD-DOC) (WITH-WINDOW-CONFIGURATION (:FILTER) (WITH-BACKGROUND-PROCESS-LOCKED (SETQ OLD-DOC (SEND *SUMMARY-WINDOW* :WHO-LINE-OVERRIDE-DOCUMENTATION-STRING)) (PKG-BIND (SYMBOL-PACKAGE 'FOO) (UNWIND-PROTECT (PROGN (SEND *SUMMARY-WINDOW* :SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING *FILTER-DEFINITION-SUMMARY-DOCUMENTATION*) (SEND *FILTER-WINDOW* :COMMAND-LOOP)) (SEND *SUMMARY-WINDOW* :SET-WHO-LINE-OVERRIDE-DOCUMENTATION-STRING OLD-DOC)))))) (DEFUN GENERATE-UNIQUE-NAME (LIST &OPTIONAL (NAME "Noname")) (DO ((I 1 (1+ I)) (STRING)) (NIL) (SETQ STRING (FORMAT NIL "~A-~D" NAME I)) (OR (MEM #'(LAMBDA (X Y) (IF (NOT (ATOM Y)) (SETQ Y (CAR Y))) (STRING-EQUAL X Y)) STRING LIST) (RETURN STRING)))) (DEFUN EXTRACT-FILTERS-FROM-MSG (MSG) (DO-NAMED TOP ((*TYPEOUT-WINDOW*)) (NIL) (PRINT-MSG-TYPEOUT-FILTERS MSG) (DO ((CH) (TYPE)) (NIL) (REDISPLAY-ALL-WINDOWS) (SETQ CH (SEND *STANDARD-INPUT* :ANY-TYI)) (COND ((OR (ATOM CH) (NOT (MEMQ (SETQ TYPE (CAR CH)) '(:TYPEOUT-EXECUTE SUMMARY-MOUSE)))) (OR (EQ CH #/SP) (SEND *STANDARD-INPUT* :UNTYI CH)) (SEND *TYPEOUT-WINDOW* :MAKE-COMPLETE) (RETURN-FROM TOP NIL)) ((EQ TYPE 'SUMMARY-MOUSE) (SETQ MSG (CADADR CH)) (RETURN)) ((EQ TYPE :TYPEOUT-EXECUTE) (APPLY (CADR CH) (CDDR CH))))))) (DEFUN PRINT-MSG-TYPEOUT-FILTERS (MSG &OPTIONAL JUST-FROM-TO INCLUDE-SITE &AUX STATUS) (SETQ *TYPEOUT-WINDOW* (SEND *SUMMARY-WINDOW* :TYPEOUT-WINDOW)) (SETQ STATUS (ASSURE-MSG-PARSED MSG)) (COND (JUST-FROM-TO (PRINT-MSG-TYPEOUT-FILTERS-1 "From//To: " 'SENDER-OR-RECIPIENT-FIELD STATUS *SENDER-OR-RECIPIENT-TYPE-HEADERS* INCLUDE-SITE)) (T (PRINT-MSG-TYPEOUT-FILTERS-1 "From: " 'FROM-FIELD STATUS *SENDER-TYPE-HEADERS* INCLUDE-SITE) (PRINT-MSG-TYPEOUT-FILTERS-1 "Recipients: " 'RECIPIENT-FIELD STATUS *RECIPIENT-TYPE-HEADERS* INCLUDE-SITE) (PRINT-TYPEOUT-FILTER "Subject: " 'SUBJECT-FIELD (GET-MSG-SUBJECT-CLEVERLY MSG NIL))))) (DEFUN PRINT-MSG-TYPEOUT-FILTERS-1 (NAME TYPE STATUS LIST INCLUDE-SITE) (PRINT-TYPEOUT-FILTER NAME TYPE (LOOP FOR IND IN LIST NCONC (MAKE-RECIPIENT-TYPEOUT-ALIST STATUS IND INCLUDE-SITE)))) (DEFUN PRINT-TYPEOUT-FILTER (NAME TYPE ELEMENTS) (COND ((NOT (NULL ELEMENTS)) (SEND *TYPEOUT-WINDOW* :FRESH-LINE) (SEND *TYPEOUT-WINDOW* :STRING-OUT NAME) (IF (OR (ATOM ELEMENTS) (NULL (CDR ELEMENTS))) ;Only one element (SEND *TYPEOUT-WINDOW* :ITEM TYPE (IF (CONSP ELEMENTS) (CAR ELEMENTS) ELEMENTS)) (SEND *TYPEOUT-WINDOW* :ITEM-LIST TYPE ELEMENTS))))) (DEFUN MAKE-RECIPIENT-TYPEOUT-ALIST (STATUS TYPE INCLUDE-SITE) (LOOP FOR HEADER IN (GET STATUS TYPE) COLLECT (IF INCLUDE-SITE (STRING-FROM-HEADER HEADER :SHORT) (GET (LOCF HEADER) :NAME)))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* FROM-FIELD "Insert" INSERT-FROM-FIELD T "Insert this from field.") (DEFUN INSERT-FROM-FIELD (FIELD) (INSERT-FORM-INTO-WINDOW `(MSG-HEADER-RECIPIENT-SEARCH :FROM ,FIELD))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* RECIPIENT-FIELD "Insert" INSERT-RECIPIENT-FIELD T "Insert this recipient field.") (DEFUN INSERT-RECIPIENT-FIELD (FIELD) (INSERT-FORM-INTO-WINDOW `(MSG-HEADER-RECIPIENT-SEARCH *RECIPIENT-TYPE-HEADERS* ,FIELD))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* SENDER-OR-RECIPIENT-FIELD "Insert" INSERT-SENDER-OR-RECIPIENT-FIELD T "Insert this recipient field.") (DEFUN INSERT-SENDER-OR-RECIPIENT-FIELD (FIELD) (INSERT-FORM-INTO-WINDOW `(MSG-HEADER-RECIPIENT-SEARCH *SENDER-OR-RECIPIENT-TYPE-HEADERS* ,FIELD))) (TV:ADD-TYPEOUT-ITEM-TYPE *ZMAIL-TYPEOUT-ITEM-ALIST* SUBJECT-FIELD "Insert" INSERT-SUBJECT-FIELD T "Insert this subject field.") (DEFUN INSERT-SUBJECT-FIELD (FIELD) (INSERT-FORM-INTO-WINDOW `(MSG-HEADER-SEARCH :SUBJECT ,FIELD))) (DEFUN CHOOSE-MSG-OR-READLINE (PROMPT &OPTIONAL DEFAULT &AUX RESULT) (*CATCH 'CHOOSE-MSG-OR-READLINE (WITH-BACKGROUND-PROCESS-LOCKED (CONDITION-BIND ((UNKNOWN-SPECIAL-COMMAND 'CHOOSE-MSG-OR-READLINE-UNKNOWN-SPECIAL-COMMAND)) (SETQ RESULT (TYPEIN-LINE-READLINE "~A:~@[ (Default: ~A)~]~:[ (Or select message with mouse)~]" PROMPT DEFAULT (NOT (SEND *SUMMARY-WINDOW* :EXPOSED-P)))))) (AND DEFAULT (EQUAL RESULT "") (SETQ RESULT DEFAULT)) RESULT)) (DEFUN CHOOSE-MSG-OR-READLINE-UNKNOWN-SPECIAL-COMMAND (&REST IGNORE) (AND (EQ (CAR *LAST-COMMAND-CHAR*) 'SUMMARY-MOUSE) (*THROW 'CHOOSE-MSG-OR-READLINE (CADADR *LAST-COMMAND-CHAR*)))) ;Return the msg (DEFUN CHOOSE-OR-READLINE-ADDRESS (PROMPT &OPTIONAL NOT-P INCLUDE-SITE DEFAULT &AUX X) (SETQ X (CHOOSE-MSG-OR-READLINE PROMPT DEFAULT)) (IF (STRINGP X) ;Typed by user (VALUES (IF NOT-P 'MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD 'MSG-HAS-SENDER-OR-RECIPIENT-FIELD) X) (GET-FILTERS-FROM-MSG X NOT-P T INCLUDE-SITE))) (DEFUN GET-FILTERS-FROM-MSG (MSG NOT-P &OPTIONAL JUST-FROM-TO INCLUDE-SITE &AUX CH FUN *TYPEOUT-WINDOW*) (PRINT-MSG-TYPEOUT-FILTERS MSG JUST-FROM-TO INCLUDE-SITE) (SEND *TYPEOUT-WINDOW* :FRESH-LINE) (SETQ CH (SEND *STANDARD-INPUT* :ANY-TYI)) (SEND *TYPEOUT-WINDOW* :MAKE-COMPLETE) (OR (AND (CONSP CH) (EQ (CAR CH) :TYPEOUT-EXECUTE)) (BARF)) (SETQ FUN (CASE (CADR CH) (INSERT-FROM-FIELD (IF NOT-P 'MSG-DOES-NOT-HAVE-FROM-FIELD 'MSG-HAS-FROM-FIELD)) (INSERT-RECIPIENT-FIELD (IF NOT-P 'MSG-DOES-NOT-HAVE-RECIPIENT-FIELD 'MSG-HAS-RECIPIENT-FIELD)) (INSERT-SENDER-OR-RECIPIENT-FIELD (IF NOT-P 'MSG-DOES-NOT-HAVE-SENDER-OR-RECIPIENT-FIELD 'MSG-HAS-SENDER-OR-RECIPIENT-FIELD)) (INSERT-SUBJECT-FIELD (IF NOT-P 'MSG-DOES-NOT-HAVE-SUBJECT-STRING 'MSG-HAS-SUBJECT-STRING)) (OTHERWISE (BARF)))) (VALUES FUN (CADDR CH))) (DEFUN GET-MSG-SUBJECT-CLEVERLY (MSG &OPTIONAL (ERROR-P T) &AUX SUBJECT START END) (COND ((SETQ SUBJECT (MSG-GET MSG :SUBJECT)) (SETQ START 0 END (STRING-LENGTH SUBJECT)) (DO () ((NOT (%STRING-EQUAL SUBJECT START "Re: " 0 4))) (SETQ START (+ START 4))) (DO ((TEM)) ((NOT (AND (PLUSP END) (= (AREF SUBJECT (1- END)) #/])))) (OR (SETQ TEM (STRING-SEARCH-CHAR #/: SUBJECT START END)) (RETURN)) (SETQ TEM (1+ TEM)) (DO () ((NOT (MEMQ (AREF SUBJECT TEM) '(#/SP #/TAB)))) (SETQ TEM (1+ TEM))) (SETQ START TEM END (1- END))) (IF (AND (= START 0) (= END (STRING-LENGTH SUBJECT))) SUBJECT (SUBSTRING SUBJECT START END))) (ERROR-P (BARF "This message has no subject")))) (DEFUN MAKE-ZMAIL-BUFFER-FROM-FILTER-FROM-MSG (MSG) (MULTIPLE-VALUE-BIND (FILTER-FUNCTION FILTER-ARG) (GET-FILTERS-FROM-MSG MSG NIL) (MAKE-ZMAIL-BUFFER-FROM-FILTER 'MAP-OVER-SINGLE-ZMAIL-BUFFER *ZMAIL-BUFFER* FILTER-FUNCTION FILTER-ARG))) ;;; Choosing and defining universes. (DEFUN GET-UNIVERSE-FUNCTION (&OPTIONAL (NEAR-MODE '(:MOUSE)) LABEL &AUX CHOICE MAP-FUNCTION MAP-ARG NAME) "Ask the user to choose a universe, using the universe menu. Return digested information about the universe: a map-function and an argument for it, which can be used to map over that universe. The third value is a name for the universe." (DECLARE (RETURN-LIST MAP-FUNCTION MAP-ARG NAME)) (SEND *UNIVERSE-SELECTION-MENU* :SET-LABEL LABEL) (MULTIPLE-VALUE-BIND (ZMAIL-BUFFER-ITEM-LIST TEMP-ZMAIL-BUFFER-ITEM-LIST) (GET-ZMAIL-BUFFER-ALISTS T) (SEND *UNIVERSE-SELECTION-MENU* :SET-ITEM-LISTS ZMAIL-BUFFER-ITEM-LIST TEMP-ZMAIL-BUFFER-ITEM-LIST (APPEND *UNIVERSE-LIST* ;; "Built-in" universes '(("Find file" :VALUE :FIND-FILE :FONT FONTS:HL12I :DOCUMENTATION "Map over messages in a specified file.") ("All" :VALUE :ALL :FONT FONTS:HL12I :DOCUMENTATION "All messages, including those in files not yet read in.") ("Loaded files" :VALUE :LOADED :FONT FONTS:HL12I :DOCUMENTATION "All messages currently read in.") ("New universe" :VALUE :NEW-UNIVERSE :FONT FONTS:HL12I :DOCUMENTATION "Create a new universe by set operations.")) (AND *ZMAIL-BUFFER* '(("Rest of current" :VALUE :REST :FONT FONTS:HL12I :DOCUMENTATION "Messsages after this one in this buffer") ("Beginning of current" :VALUE :BEGINNING :FONT FONTS:HL12I :DOCUMENTATION "Messages before this one in this buffer")))))) (TV:EXPOSE-WINDOW-NEAR *UNIVERSE-SELECTION-MENU* NEAR-MODE) (SETQ CHOICE (SEND *UNIVERSE-SELECTION-MENU* :CHOOSE)) (AND (EQ CHOICE :FIND-FILE) (SETQ CHOICE (READ-ZMAIL-BUFFER-FILENAME :MOUSE))) (AND (OR (STRINGP CHOICE) (TYPEP CHOICE 'FS:PATHNAME)) (SETQ CHOICE (ZMAIL-FIND-FILE-NOSELECT CHOICE))) (COND ((NULL CHOICE) (SETQ MAP-FUNCTION NIL)) ((EQ CHOICE :ALL) (SETQ MAP-FUNCTION 'MAP-OVER-ALL-ZMAIL-BUFFERS NAME "All")) ((EQ CHOICE :LOADED) (SETQ MAP-FUNCTION 'MAP-OVER-LOADED-ZMAIL-BUFFERS NAME "Loaded files")) ((EQ CHOICE :REST) (SETQ MAP-FUNCTION 'MAP-OVER-REST-OF-ZMAIL-BUFFER MAP-ARG *ZMAIL-BUFFER* NAME (FORMAT NIL "Rest of ~A" (ZMAIL-BUFFER-NAME MAP-ARG)))) ((EQ CHOICE :BEGINNING) (SETQ MAP-FUNCTION 'MAP-OVER-BEGINNING-OF-ZMAIL-BUFFER MAP-ARG *ZMAIL-BUFFER* NAME (FORMAT NIL "Beginning of ~A" (ZMAIL-BUFFER-NAME MAP-ARG)))) ((EQ CHOICE :NEW-UNIVERSE) (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG NAME) (DEFINE-NEW-UNIVERSE NEAR-MODE))) ((SYMBOLP CHOICE) (SETQ MAP-FUNCTION 'MAP-OVER-DEFINED-UNIVERSE MAP-ARG CHOICE NAME (STRING CHOICE))) (T (SETQ MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER MAP-ARG CHOICE NAME (ZMAIL-BUFFER-NAME MAP-ARG)) (AND (ZMAIL-BUFFER-DISK-P CHOICE) (ASSURE-ZMAIL-BUFFER-FULLY-LOADED CHOICE)))) (VALUES MAP-FUNCTION MAP-ARG NAME)) (DEFFLAVOR UNIVERSE-DEFINITION-FRAME () (TV:TEMPORARY-WINDOW-MIXIN TV:SELECT-MIXIN ZMAIL-UTILITY-FRAME) (:DEFAULT-INIT-PLIST :EDITOR-CLOSURE-VARIABLES UNIVERSE-DEFINITION-FRAME-EDITOR-CLOSURE-VARIABLES :COMTAB *STANDALONE-COMTAB*)) (DEFCONST UNIVERSE-DEFINITION-FRAME-EDITOR-CLOSURE-VARIABLES (MERGE-CLOSURE-VARIABLE-LISTS '((*MODE-LINE-LIST* '("ZMail " "Universe")) (*MAJOR-MODE* NIL) (*STANDARD-OUTPUT* SI:SYN-TERMINAL-IO) (*QUERY-IO* SYN-TYPEIN-WINDOW-IO) (*SELECTABLE-MODE-LINE-ELEMENTS* NIL) (*EDITOR-WINDOW* NIL) (*EDITOR-INTERVAL* NIL) (*EDITOR-ISTREAM* NIL) (*EDITOR-INSERT-BP* NIL)) TOP-LEVEL-EDITOR-CLOSURE-VARIABLES)) (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :AFTER :INIT) (IGNORE) (SETQ MODE-LINE-WINDOW (SEND SELF :GET-PANE 'MODE-LINE-WINDOW)) (SYS:%USING-BINDING-INSTANCES (CLOSURE-BINDINGS EDITOR-CLOSURE)) (SETQ *EDITOR-WINDOW* (SEND SELF :GET-PANE 'EDITOR-WINDOW)) (SEND *EDITOR-WINDOW* :SET-EDITOR-CLOSURE EDITOR-CLOSURE) (INITIALIZE-TOP-LEVEL-EDITOR *EDITOR-WINDOW* T) (SETQ *EDITOR-INTERVAL* *INTERVAL*) (SETQ *EDITOR-ISTREAM* (INTERVAL-STREAM *INTERVAL*)) (SETQ *EDITOR-INSERT-BP* (COPY-BP (POINT) :MOVES))) ;;; This page is concerned only with arranging the layout of the panes ;;; of the universe definition frame. (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :BEFORE :INIT) (IGNORE &AUX MODE-LINE-LINE-HEIGHT MODE-LINE-HEIGHT) (SETQ MODE-LINE-LINE-HEIGHT (+ 2 (MAX (FONT-CHAR-HEIGHT TV:(SCREEN-DEFAULT-FONT (SHEET-GET-SCREEN SUPERIOR))) (FONT-CHAR-HEIGHT FONTS:SEARCH))) MODE-LINE-HEIGHT (+ 11 (* 2 MODE-LINE-LINE-HEIGHT))) (SETQ TV:PANES `((UNION-BUTTON TV:BUTTON-PANE :NAME "Union" :DOCUMENTATION "Set union of several universes.") (INTERSECTION-BUTTON TV:BUTTON-PANE :NAME "Intersection" :DOCUMENTATION "Set intersection of several universes.") (NOT-BUTTON TV:BUTTON-PANE :NAME "Not" :DOCUMENTATION "Set of all messages not in a universe.") (CLOSE-BUTTON TV:BUTTON-PANE :NAME "Close" :DOCUMENTATION "Move to next higher Union or Intersection.") (ZMAIL-BUFFER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST NIL :LABEL "File buffers:") (TEMP-ZMAIL-BUFFER-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST NIL :LABEL "") (UNIVERSE-MENU ZMAIL-COMMAND-MENU-PANE :ITEM-LIST NIL :LABEL "Universes:") (NAME-BUTTON TV:BIG-BUTTON-PANE :NAME "Name" :BORDERS 3 :DOCUMENTATION "Specify a new name for this universe. Click right for a menu of existing filters to edit.") (EDITOR-WINDOW ZMAIL-WINDOW :LABEL NIL :BORDERS (2 2 2 1) :SAVE-BITS NIL :CHARACTER-HEIGHT 10.) (MODE-LINE-WINDOW ZMAIL-MOUSE-SENSITIVE-MODE-LINE-PANE :HEIGHT ,MODE-LINE-HEIGHT :MORE-P NIL :BORDERS (2 1 2 2) :BLINKER-DESELECTED-VISIBILITY :OFF) (DONE-BUTTON TV:BUTTON-PANE :NAME "Done" :DOCUMENTATION "Use this universe definition.") (ABORT-BUTTON TV:BUTTON-PANE :NAME "Abort" :DOCUMENTATION "Abort this command.")) TV:CONSTRAINTS `((ONLY . ( (WHOLE-THING) ((WHOLE-THING :HORIZONTAL (:EVEN) (WHOLE) ((WHOLE TV:WHITE-INCLUDE-WHITESPACE ;Vert (0.95) (:EVEN) (OPERATIONS MENUS NAME EDITOR CONTROLS) ((OPERATIONS TV:FLOATING-BUTTONS (UNION-BUTTON INTERSECTION-BUTTON NOT-BUTTON CLOSE-BUTTON))) ((NAME TV:SINGLE-PANE-IN-WHITESPACE NAME-BUTTON)) ((CONTROLS TV:FLOATING-BUTTONS (DONE-BUTTON ABORT-BUTTON))) ((EDITOR TV:WHITE-INCLUDE-WHITESPACE ;Horiz (:ASK-WINDOW SELF :EDITOR-SIZE) (:EVEN) (EDITORS) ((EDITORS :VERTICAL (0.8) (EDITOR-WINDOW MODE-LINE-WINDOW) ((MODE-LINE-WINDOW ,MODE-LINE-HEIGHT)) ((EDITOR-WINDOW :EVEN)))))) ;; This comes last since it can afford a scroll bar ((MENUS TV:FLOATING-MENUS (:ASK-WINDOW SELF :MENUS-SIZE) (ZMAIL-BUFFER-MENU TEMP-ZMAIL-BUFFER-MENU UNIVERSE-MENU)))))))))))) (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :MENUS-SIZE) (&REST ARGS) (MAX (LEXPR-SEND SELF :SEND-PANE 'ZMAIL-BUFFER-MENU :PANE-SIZE ARGS) (LEXPR-SEND SELF :SEND-PANE 'TEMP-ZMAIL-BUFFER-MENU :PANE-SIZE ARGS) (LEXPR-SEND SELF :SEND-PANE 'UNIVERSE-MENU :PANE-SIZE ARGS))) (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :EDITOR-SIZE) (&REST IGNORE) (+ (TV:SHEET-HEIGHT (SEND SELF :GET-PANE 'MODE-LINE-WINDOW)) (LET ((EDITOR-WINDOW (SEND SELF :GET-PANE 'EDITOR-WINDOW))) (+ (TV:SHEET-TOP-MARGIN-SIZE EDITOR-WINDOW) (TV:SHEET-BOTTOM-MARGIN-SIZE EDITOR-WINDOW) (* 10. (TV:SHEET-LINE-HEIGHT EDITOR-WINDOW)))))) (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :COMPUTE-GEOMETRY) (UNIVERSE-NAME ZMAIL-BUFFER-ALIST TEMP-ZMAIL-BUFFER-ALIST UNIVERSE-ALIST &AUX MAX-WIDTH MAX-HEIGHT CHANGED-P) (SETQ MAX-WIDTH TV:(- (SHEET-INSIDE-WIDTH SUPERIOR) LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE) MAX-HEIGHT TV:(- (SHEET-INSIDE-HEIGHT SUPERIOR) TOP-MARGIN-SIZE BOTTOM-MARGIN-SIZE)) (SEND SELF :SET-PANES-NAME 'NAME-BUTTON UNIVERSE-NAME) (SETQ CHANGED-P (SEND SELF :SET-PANES-ITEM-LIST 'ZMAIL-BUFFER-MENU ZMAIL-BUFFER-ALIST)) (SETQ CHANGED-P (OR (SEND SELF :SET-PANES-ITEM-LIST 'TEMP-ZMAIL-BUFFER-MENU TEMP-ZMAIL-BUFFER-ALIST) CHANGED-P)) (SETQ CHANGED-P (OR (SEND SELF :SET-PANES-ITEM-LIST 'UNIVERSE-MENU UNIVERSE-ALIST) CHANGED-P)) (AND CHANGED-P (LET ((WID (MIN MAX-WIDTH (TRUNCATE (* (MAX (+ (SEND SELF :SEND-PANE 'UNION-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'INTERSECTION-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'NOT-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'CLOSE-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL)) (+ (SEND SELF :SEND-PANE 'ZMAIL-BUFFER-MENU :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'TEMP-ZMAIL-BUFFER-MENU :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'UNIVERSE-MENU :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL)) (SEND SELF :SEND-PANE 'NAME-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (+ (SEND SELF :SEND-PANE 'DONE-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL) (SEND SELF :SEND-PANE 'ABORT-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :HORIZONTAL))) 15.) 10.))) (HEI (MIN MAX-HEIGHT (TRUNCATE (* (+ (SEND SELF :SEND-PANE 'UNION-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL) (SEND SELF :MENUS-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL) (SEND SELF :SEND-PANE 'NAME-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL) (SEND SELF :EDITOR-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL) (SEND SELF :SEND-PANE 'DONE-BUTTON :PANE-SIZE MAX-WIDTH MAX-HEIGHT NIL NIL :VERTICAL)) 12.) 10.)))) (IF (AND (= WID (TV:SHEET-INSIDE-WIDTH)) (= HEI (TV:SHEET-INSIDE-HEIGHT))) (SEND SELF :SET-CONFIGURATION 'ONLY) (SEND SELF :SET-INSIDE-SIZE WID HEI))))) ;;; Cosmogony (DEFUN DEFINE-NEW-UNIVERSE (&OPTIONAL (NEAR-MODE '(:MOUSE))) "Ask user to define a universe. Switches to the universe definition frame and back out. Returns a map function and argument, for use in filtering, and the universe name. Also, the fourth value is the universe itself." (PKG-BIND (SYMBOL-PACKAGE 'FOO) (SEND *UNIVERSE-DEFINITION-FRAME* :INITIALIZE) (TV:WITH-SELECTION-SUBSTITUTE (*UNIVERSE-DEFINITION-FRAME* *ZMAIL-WINDOW*) (LET (UNIVERSE) (AND (SETQ UNIVERSE (SEND *UNIVERSE-DEFINITION-FRAME* :GET-UNIVERSE NEAR-MODE)) (VALUES 'MAP-OVER-DEFINED-UNIVERSE UNIVERSE (STRING UNIVERSE) UNIVERSE)))))) (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :INITIALIZE) (&AUX NEW-NAME) (SETQ NEW-NAME (GENERATE-UNIQUE-NAME *UNIVERSE-LIST*)) (SYS:%USING-BINDING-INSTANCES (CLOSURE-BINDINGS EDITOR-CLOSURE)) (UNLESS (EQ *MAJOR-MODE* 'LISP-MODE) (COM-LISP-MODE)) (LET ((*BATCH-UNDO-SAVE* T)) (DELETE-INTERVAL *INTERVAL*) (INSERT-FORM-INTO-WINDOW `(DEFINE-UNIVERSE ,(INTERN (STRING-UPCASE NEW-NAME)) ()) -1)) (SETF (WINDOW-BASE-TICK *EDITOR-WINDOW*) (TICK)) (DISCARD-UNDO-INFORMATION *INTERVAL*) (MUST-REDISPLAY *WINDOW* DIS-ALL) (MULTIPLE-VALUE-BIND (ZMAIL-BUFFER-ALIST TEMP-ZMAIL-BUFFER-ALIST) (GET-ZMAIL-BUFFER-ALISTS T) (SEND SELF :COMPUTE-GEOMETRY NEW-NAME (NCONC ZMAIL-BUFFER-ALIST '(("Primary" :VALUE PRIMARY :FONT FONTS:HL12BI :DOCUMENTATION "The primary mail file buffer."))) (NCONC TEMP-ZMAIL-BUFFER-ALIST '(("Current" :VALUE CURRENT :FONT FONTS:HL12BI :DOCUMENTATION "The current buffer."))) (APPEND *UNIVERSE-LIST* '(("All" :VALUE ALL :FONT FONTS:HL12BI :DOCUMENTATION "All messages in Zmail."))))) (SEND *MINI-BUFFER-WINDOW* :DEACTIVATE) (SEND SELF :TURN-OFF-ACCENTS)) (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :GET-UNIVERSE) (&OPTIONAL (NEAR-MODE '(:MOUSE))) ;; Some domain specific knowledge here (AND (EQ (CAR NEAR-MODE) :WINDOW) (LET ((MIN-BOTTOM (+ (TV:SHEET-INSIDE-TOP TV:SUPERIOR) TV:HEIGHT)) (BROTHER (CADR NEAR-MODE))) (AND (< (TV:SHEET-Y-OFFSET BROTHER) MIN-BOTTOM) ;If we won't fit on top ( MIN-BOTTOM (- (TV:SHEET-INSIDE-BOTTOM TV:SUPERIOR) ;and moving will help (TV:SHEET-HEIGHT BROTHER))) (SEND BROTHER :SET-POSITION (TV:SHEET-X-OFFSET BROTHER) MIN-BOTTOM)))) (TV:EXPOSE-WINDOW-NEAR SELF NEAR-MODE) (SEND SELF :COMMAND-LOOP)) ;;; Here are the methods that :COMMAND-LOOP requires us to define. (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :TOP-LEVEL-TAG) () 'EXIT-UNIVERSE-DEFINITION) (DEFMETHOD (UNIVERSE-DEFINITION-FRAME :PROCESS-SPECIAL-COMMAND) (&REST ARGS) (APPLY 'ZMAIL-UNIVERSE-COMMAND-LIST ARGS)) (DEFSELECT (ZMAIL-UNIVERSE-COMMAND-LIST ZMAIL-COMMAND-LIST-DEFAULT) (SELECT-WINDOW (WINDOW) ;Moused a window, edit there (TV:WITH-SELECTION-SUBSTITUTE (WINDOW SELF) (LET ((*COMTAB* *STANDALONE-COMTAB*) (*MODE-LINE-LIST* '("ZMail " "Editing Filter"))) (*CATCH 'ABORT-STANDALONE-EDIT (SEND *WINDOW* :EDIT)))) DIS-NONE) (:MENU (ITEM IGNORE WINDOW &AUX WINDOW-NAME) (SETQ WINDOW-NAME (SEND SELF :PANE-NAME WINDOW)) (SETQ ITEM (SEND WINDOW :EXECUTE-NO-SIDE-EFFECTS ITEM)) (IF (EQ WINDOW-NAME 'UNIVERSE-MENU) (SETQ ITEM `(,ITEM)) (AND (TYPEP ITEM 'ZMAIL-BUFFER) (SETQ ITEM (ZMAIL-BUFFER-NAME ITEM)))) (INSERT-FORM-INTO-WINDOW ITEM) DIS-NONE) (:MOUSE-BUTTON (CH WINDOW IGNORE IGNORE &AUX WINDOW-NAME) (COND ((SEND WINDOW :OPERATION-HANDLED-P :SET-ACCENT) (SETQ WINDOW-NAME (SEND SELF :PANE-NAME WINDOW)) (UNWIND-PROTECT (CASE WINDOW-NAME (ABORT-BUTTON (*THROW 'EXIT-UNIVERSE-DEFINITION NIL)) (DONE-BUTTON (*THROW 'EXIT-UNIVERSE-DEFINITION (EVAL (READ-FROM-EDITOR-WINDOW)))) (NAME-BUTTON (READ-NEW-NAME WINDOW CH *UNIVERSE-LIST* 'GET-UNIVERSE-DEFINITION)) (CLOSE-BUTTON (EDITOR-WINDOW-CLOSE-BUTTON)) (OTHERWISE (INSERT-FORM-INTO-WINDOW `(,(CASE WINDOW-NAME (NOT-BUTTON ') (UNION-BUTTON ') (INTERSECTION-BUTTON '))) -1))) (SEND WINDOW :SET-ACCENT NIL))) (T NIL)) ;random window DIS-NONE) ) ;;; Filter definition components (DEFUN MACRO-EXPAND-SEARCH-KEY (KEY &AUX FUNCTION (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)) (DECLARE (RETURN-LIST FUNCTION KEY)) (COND ((STRINGP KEY) (SETQ FUNCTION 'SEARCH)) ((EQ (ARRAY-TYPE KEY) 'ART-16B) (MULTIPLE-VALUE (FUNCTION KEY) (PARSE-EXTENDED-SEARCH-16B-STRING KEY))) (T (ZMAIL-ERROR "~S not a valid search key" KEY))) (VALUES FUNCTION KEY)) (DEFMACRO SEARCH-WITHIN-MSG (KEY) (MULTIPLE-VALUE-BIND (FUNCTION KEY) (MACRO-EXPAND-SEARCH-KEY KEY) `(,FUNCTION (MSG-START-BP MSG) ',KEY NIL NIL NIL (MSG-END-BP MSG)))) (DEFMACRO MSG-HEADER-SEARCH (TYPE KEY) (MULTIPLE-VALUE-BIND (FUNCTION KEY) (MACRO-EXPAND-SEARCH-KEY KEY) (SETQ FUNCTION (CASE FUNCTION (SEARCH 'STRING-SEARCH) (FSM-SEARCH 'FSM-STRING-SEARCH))) `(LET ((.HEADER. (GET STATUS ,TYPE))) (AND .HEADER. (IF (CONSP .HEADER.) (LOOP FOR .STRING. IN .HEADER. THEREIS (,FUNCTION ',KEY .STRING.)) (,FUNCTION ',KEY .HEADER.)))))) (DEFMACRO MSG-HEADER-RECIPIENT-SEARCH (TYPE KEY) (MULTIPLE-VALUE-BIND (FUNCTION KEY) (MACRO-EXPAND-SEARCH-KEY KEY) (SETQ FUNCTION (COND ((EQ FUNCTION 'FSM-SEARCH) 'MSG-HEADER-RECIPIENT-FSM-SEARCH) ((AND (= (AREF KEY 0) #/) (= (AREF KEY (1- (STRING-LENGTH KEY))) #/)) (SETQ KEY (SUBSTRING KEY 1 (1- (STRING-LENGTH KEY)))) 'MSG-HEADER-RECIPIENT-PARTIAL-MATCH) (T 'MSG-HEADER-RECIPIENT-MATCH))) (IF (AND (CONSP TYPE) (EQ (CAR TYPE) 'QUOTE) (SYMBOLP (CADR TYPE))) `(,FUNCTION (GET STATUS ,TYPE) ',KEY) `(DO .L. ,TYPE (CDR .L.) (NULL .L.) (AND (,FUNCTION (GET STATUS (CAR .L.)) ',KEY) (RETURN T)))))) (DEFUN MSG-HEADER-RECIPIENT-FSM-SEARCH (RECIPIENTS KEY &AUX INTERVAL) (DOLIST (RECIPIENT RECIPIENTS) (AND (SETQ INTERVAL (GET (LOCF RECIPIENT) :INTERVAL)) (FSM-SEARCH (CAR INTERVAL) KEY NIL NIL NIL (CADR INTERVAL)) (RETURN T)))) (DEFUN MSG-HEADER-RECIPIENT-PARTIAL-MATCH (RECIPIENTS KEY) (DO L RECIPIENTS (CDR L) (NULL L) (AND (STRING-SEARCH KEY (GET (LOCF (CAR L)) :NAME)) (RETURN T)))) (DEFUN MSG-HEADER-RECIPIENT-MATCH (RECIPIENTS KEY &AUX END-1 START-2 PLIST) (AND (SETQ END-1 (STRING-SEARCH-CHAR #/@ KEY)) (SETQ START-2 (1+ END-1))) (DOLIST (RECIPIENT RECIPIENTS) (SETQ PLIST (LOCF RECIPIENT)) (AND (STRING-EQUAL (GET PLIST :NAME) KEY :start1 0 :start2 0 :end1 NIL :end2 END-1) (OR (NULL START-2) (STRING-EQUAL (CAR (GET PLIST :HOST)) KEY :start1 0 :start2 START-2)) (RETURN T)))) (DEFMACRO MSG-HEADER-RECIPIENT-EQUAL (TYPE KEY) `(LET ((.RECIPIENTS. (GET STATUS ,TYPE))) (AND (NULL (CDR .RECIPIENTS.)) (MSG-HEADER-RECIPIENT-MATCH .RECIPIENTS. ',KEY)))) (DEFMACRO DEFINE-FILTER (FILTER (MSG) . BODY) "Define a FILTER with argument MSG to compute BODY. This function is used in ZMAIL init files." (LET ((DOCUMENTATION)) (IF (STRINGP (CAR BODY)) (SETQ DOCUMENTATION (CAR BODY) BODY (CDR BODY))) `(PROGN 'COMPILE (DEFINE-FILTER-1 ',FILTER ',DOCUMENTATION) (DEFUN (:PROPERTY ,FILTER FILTER-FUNCTION) (,MSG &AUX STATUS KEYWORDS) (SETQ STATUS (ASSURE-MSG-PARSED ,MSG) KEYWORDS (GET STATUS 'KEYWORDS)) . ,BODY)))) ;;; Add a new filter-name, with optional mouse documentation (DEFUN DEFINE-FILTER-1 (FILTER DOCUMENTATION) (IF DOCUMENTATION (SETQ DOCUMENTATION `(:DOCUMENTATION ,DOCUMENTATION))) (LET ((ALIST-ENTRY (ASSQ FILTER *USER-FILTER-ALIST*)) (ALIST-DATA `(:VALUE ,FILTER ,@DOCUMENTATION))) (IF ALIST-ENTRY (RPLACD ALIST-ENTRY ALIST-DATA) (SETQ *USER-FILTER-ALIST* (NCONC *USER-FILTER-ALIST* (NCONS `(,FILTER ,@ALIST-DATA))))))) (DEFUN GET-FILTER-DEFINITION (FILTER &AUX DEF) "Given a filter name, return a DEFINE-FILTER form that could define it." (SETQ DEF (GET FILTER 'FILTER-FUNCTION)) (AND (ATOM DEF) (SETQ DEF (GET FILTER 'EXPR-FILTER-FUNCTION))) (OR (AND DEF (EQ (CAR DEF) 'NAMED-LAMBDA) (NOT (ATOM (CADR DEF))) (EQ (CAR (CAADR DEF)) :PROPERTY) (EQ (CADR (CAADR DEF)) FILTER)) (BARF "~A is compiled" FILTER)) `(DEFINE-FILTER ,FILTER (,(CAADDR DEF)) . ,(CDDDDR DEF))) (DEFUN MACRO-EXPAND-DATE (DATE) (OR (STRINGP DATE) (ZMAIL-ERROR "~S is not a valid date" DATE)) (TIME:PARSE-UNIVERSAL-TIME DATE)) ;; Currently the "NOW" argument to MACRO-EXPAND-RELATIVE-DATE is useless. ;; However, if anything special is to be done with things like "A week after ;; my birthday" or "January", besides forcing them to be absolute, the current ;; date is required. (DEFUN MACRO-EXPAND-RELATIVE-DATE (DATE NOW &REST OTHERS &AUX (DEFAULT-CONS-AREA WORKING-STORAGE-AREA) RELATIVE-P) (MULTIPLE-VALUE (DATE RELATIVE-P) (MACRO-EXPAND-DATE DATE)) (SETQ OTHERS (COPYLIST OTHERS)) (IF (EQ RELATIVE-P :RELATIVE) `(- (TIME:GET-UNIVERSAL-TIME) ,(- (TIME:GET-UNIVERSAL-TIME) DATE) ;Relative: Compute offset from now ,@OTHERS) `(- (TIME:GET-UNIVERSAL-TIME) ,(- (MACRO-EXPAND-DATE NOW) DATE) ;Absolute: Compute offset from then ,@OTHERS))) (DEFMACRO MSG-SAME-DATE (DATE) (SETQ DATE (MACRO-EXPAND-DATE DATE)) `(LET ((.DATE. (GET STATUS :DATE))) (AND (NOT (NULL .DATE.)) ( ',DATE .DATE.) (> ',(LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA)) (+ DATE 86400.)) .DATE.)))) (DEFMACRO MSG-SAME-RELATIVE-DATE (DATE NOW) `(LET ((.DATE. (GET STATUS :DATE))) (AND (NOT (NULL .DATE.)) ( ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW) .DATE.) (> ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW -86400.) .DATE.)))) (DEFMACRO MSG-DATE-LESSP (DATE) `(LET ((.DATE. (GET STATUS :DATE))) (AND (NOT (NULL .DATE.)) (< .DATE. ',(MACRO-EXPAND-DATE DATE))))) (DEFMACRO MSG-RELATIVE-DATE-LESSP (DATE NOW) `(LET ((.DATE. (GET STATUS :DATE))) (AND (NOT (NULL .DATE.)) (< .DATE. ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW))))) (DEFMACRO MSG-DATE-GREATERP (DATE) `(LET ((.DATE. (GET STATUS :DATE))) (AND (NOT (NULL .DATE.)) ( .DATE. ',(MACRO-EXPAND-DATE DATE))))) (DEFMACRO MSG-RELATIVE-DATE-GREATERP (DATE NOW) `(LET ((.DATE. (GET STATUS :DATE))) (AND (NOT (NULL .DATE.)) ( .DATE. ,(MACRO-EXPAND-RELATIVE-DATE DATE NOW))))) ;;;; Defining universes in the init file, and writing definitions there. (DEFMACRO DEFINE-UNIVERSE (UNIVERSE IGNORE EXPANSION) (CHECK-EXPANSION EXPANSION) `(PROGN (OR (MEMQ ',UNIVERSE *UNIVERSE-LIST*) (SETQ *UNIVERSE-LIST* (NCONC *UNIVERSE-LIST* (NCONS ',UNIVERSE)))) (DEFPROP ,UNIVERSE ,EXPANSION UNIVERSE))) (DEFUN GET-UNIVERSE-DEFINITION (UNIVERSE) `(DEFINE-UNIVERSE ,UNIVERSE () ,(GET UNIVERSE 'UNIVERSE))) (DEFUN CHECK-EXPANSION (EXPANSION) (COND ((STRINGP EXPANSION)) ((PATHNAMEP EXPANSION)) ((NULL EXPANSION)) ((MEMQ EXPANSION '(PRIMARY CURRENT))) ((AND (SYMBOLP EXPANSION) (GET EXPANSION 'UNIVERSE))) ((ATOM EXPANSION) (ZMAIL-ERROR "~S is not a valid universe component" EXPANSION)) ((NULL (CDR EXPANSION)) (OR (SYMBOLP (CAR EXPANSION)) (ZMAIL-ERROR "~S is not a valid universe component" EXPANSION))) ((EQ (CAR EXPANSION) ') (OR (= (LENGTH EXPANSION) 2) (ZMAIL-ERROR "~S wrong number of argument to " EXPANSION))) ((NOT (MEMQ (CAR EXPANSION) '( ))) (ZMAIL-ERROR "~S is not a known set operator" (CAR EXPANSION))) (T (DOLIST (EXP (CDR EXPANSION)) (CHECK-EXPANSION EXP))))) ;;;; Implementation of mapping over a universe. (DEFUN (MAP-OVER-DEFINED-UNIVERSE MAP-FUNCTION-BUFFER-NAME-FUNCTION) (UNIVERSE) (STRING-APPEND "" UNIVERSE "")) (DEFUN MAP-OVER-DEFINED-UNIVERSE (UNIVERSE FILTER-FUNCTION FILTER-ARG PROCESSING-FUNCTION PROCESSING-ARG) (SETQ UNIVERSE (EXPAND-UNIVERSE UNIVERSE)) (DOMSGS (MSG UNIVERSE) (AND (FUNCALL FILTER-FUNCTION MSG FILTER-ARG) (FUNCALL PROCESSING-FUNCTION MSG PROCESSING-ARG)))) ;;; This takes a universe and returns an array with the appropriate messages in it. (DEFUN EXPAND-UNIVERSE (UNIVERSE) (COND ((NULL UNIVERSE) NIL) ((SYMBOLP UNIVERSE) (CASE UNIVERSE (PRIMARY *PRIMARY-ZMAIL-BUFFER*) (CURRENT *ZMAIL-BUFFER*) (ALL (EXPAND-UNIVERSE-INTERSECTION NIL)) (OTHERWISE (EXPAND-UNIVERSE (GET UNIVERSE 'UNIVERSE))))) ((STRINGP UNIVERSE) (GET-ZMAIL-BUFFER-FROM-NAME UNIVERSE T)) ((EQ (CAR UNIVERSE) ') (EXPAND-UNIVERSE-NOT (EXPAND-UNIVERSE (CADR UNIVERSE)))) ((EQ (CAR UNIVERSE) ') (EXPAND-UNIVERSE-UNION (MAPCAR 'EXPAND-UNIVERSE (CDR UNIVERSE)))) ((EQ (CAR UNIVERSE) ') (EXPAND-UNIVERSE-INTERSECTION (MAPCAR 'EXPAND-UNIVERSE (CDR UNIVERSE)))) ((NULL (CDR UNIVERSE)) (EXPAND-UNIVERSE (GET (CAR UNIVERSE) 'UNIVERSE))) (T (ZMAIL-ERROR "~S is not a valid universe" UNIVERSE)))) (DEFUN EXPAND-UNIVERSE-NOT (ZMAIL-BUFFER &AUX NEW-ZMAIL-BUFFER ARRAY) (SETQ NEW-ZMAIL-BUFFER (MAKE-ZMAIL-BUFFER 'TEMP-ZMAIL-BUFFER) ARRAY (ZMAIL-BUFFER-ARRAY NEW-ZMAIL-BUFFER)) (DOLIST (MF *ZMAIL-BUFFER-LIST*) (AND (ZMAIL-BUFFER-DISK-P MF) (DOMSGS (MSG MF) (OR (MSG-IN-ZMAIL-BUFFER-P MSG ZMAIL-BUFFER) (VECTOR-PUSH-EXTEND MSG ARRAY))))) NEW-ZMAIL-BUFFER) (DEFUN EXPAND-UNIVERSE-UNION (ZMAIL-BUFFERS &AUX NEW-ZMAIL-BUFFER ARRAY) ;; Move the larger buffers to the start of the list for speed (SETQ ZMAIL-BUFFERS (SORT ZMAIL-BUFFERS #'(LAMBDA (MF1 MF2) (> (ZMAIL-BUFFER-NMSGS MF1) (ZMAIL-BUFFER-NMSGS MF2)))) NEW-ZMAIL-BUFFER (MAKE-ZMAIL-BUFFER 'TEMP-ZMAIL-BUFFER) ARRAY (ZMAIL-BUFFER-ARRAY NEW-ZMAIL-BUFFER)) (DOLIST (MF ZMAIL-BUFFERS) (DOMSGS (MSG MF) (OR (MSG-IN-ZMAIL-BUFFER-P MSG NEW-ZMAIL-BUFFER) (VECTOR-PUSH-EXTEND MSG ARRAY)))) NEW-ZMAIL-BUFFER) (DEFUN EXPAND-UNIVERSE-INTERSECTION (ZMAIL-BUFFERS &AUX NEW-ZMAIL-BUFFER ZMAIL-BUFFER ARRAY) (IF (NULL ZMAIL-BUFFERS) ;Intersection of no args is everything (EXPAND-UNIVERSE-UNION *ZMAIL-BUFFER-LIST*) ;; Move the smaller buffers to the start of the list for speed (SETQ ZMAIL-BUFFERS (SORT ZMAIL-BUFFERS #'(LAMBDA (MF1 MF2) (< (ZMAIL-BUFFER-NMSGS MF1) (ZMAIL-BUFFER-NMSGS MF2)))) NEW-ZMAIL-BUFFER (MAKE-ZMAIL-BUFFER 'TEMP-ZMAIL-BUFFER) ARRAY (ZMAIL-BUFFER-ARRAY NEW-ZMAIL-BUFFER)) (POP ZMAIL-BUFFERS ZMAIL-BUFFER) (DOMSGS (MSG ZMAIL-BUFFER) (OR (DOLIST (MF ZMAIL-BUFFERS) (OR (MSG-IN-ZMAIL-BUFFER-P MSG MF) (RETURN T))) (VECTOR-PUSH-EXTEND MSG ARRAY))) NEW-ZMAIL-BUFFER)) ;;;; Implementation of the "experimental" window configuration. ;;;Execute a command - a blip read from the input stream - ;;;using a universe or filter or both, which will be specified by other blips. ;;;The blip specifying the command comes last and is of type :MENU. ;;;The blips specifying the universe and/or filter are assumed to be coming ;;;from the universe and filter "button" windows. ;;;It is quite possible that, when this function is entered, ;;;the last blip is not yet read in, and we will wait for the user to click it. (DEFUN COMMAND-WITH-UNIVERSE-OR-FILTER (&AUX BUTTON-FRAME UNIVERSE-BUTTON FILTER-BUTTON) (SETQ BUTTON-FRAME (SEND *ZMAIL-WINDOW* :GET-PANE 'BUTTONS-FRAME) UNIVERSE-BUTTON (SEND BUTTON-FRAME :GET-PANE 'UNIVERSE-BUTTON) FILTER-BUTTON (SEND BUTTON-FRAME :GET-PANE 'FILTER-BUTTON)) (UNWIND-PROTECT (DO ((FILTER-FUNCTION 'MSG-TRUE-FILTER) (FILTER-ARG NIL) ;; Assume by default that there is no universe, no filter. (MAP-FUNCTION 'MAP-OVER-SINGLE-MSG) (MAP-ARG *MSG*) (CHAR)) (NIL) ;; Read the next blip. (SETQ CHAR (WITHOUT-IO-BUFFER-OUTPUT-FUNCTION (SEND *STANDARD-INPUT* :ANY-TYI))) (SETQ *LAST-COMMAND-CHAR* CHAR) (COND ((AND (CONSP CHAR) (EQ (FIRST CHAR) :MENU)) ;; If the blip is a command, execute it ;; using universe and filter already specified. (LET* ((COMMAND (SEND (FOURTH CHAR) :EXECUTE-NO-SIDE-EFFECTS (SECOND CHAR))) (ALL-COMMAND (GET COMMAND 'ASSOCIATED-ALL-COMMAND)) (MAP-COMMAND (GET COMMAND 'ASSOCIATED-MAP-COMMAND))) ;; Record which button was typed to invoke command we will now do. (SET-COMMAND-BUTTON (THIRD CHAR)) (DO () ((NEQ COMMAND 'COM-ZMAIL-OTHER-COMMANDS)) (SETQ COMMAND (CHOOSE-OTHER-COMMAND))) ;; How to execute the command depends on whether the command ;; provides a MAP-FUNCTION or an ALL-FUNCTION, and what universe/filter. ;; The MAP-FUNCTION does mapping itself; the ALL-FUNCTION can only ;; operate on an entire buffer. (RETURN (COND ((EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MSG) (FUNCALL COMMAND)) ((AND ALL-COMMAND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER) (EQ MAP-ARG *ZMAIL-BUFFER*) (EQ FILTER-FUNCTION 'MSG-TRUE-FILTER)) (FUNCALL ALL-COMMAND)) ((AND ALL-COMMAND (EQ MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER) (TYPEP MAP-ARG 'ZMAIL-BUFFER) (EQ FILTER-FUNCTION 'MSG-TRUE-FILTER)) (LET ((*ZMAIL-BUFFER* MAP-ARG) (*MSG* :NO-SELECT)) (FUNCALL ALL-COMMAND))) ((AND (NULL MAP-COMMAND) ALL-COMMAND) (LET ((*ZMAIL-BUFFER* (MAKE-ZMAIL-BUFFER-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)) (*MSG* :NO-SELECT)) (FUNCALL ALL-COMMAND)) (ZMAIL-SELECT-MSG *MSG* NIL NIL)) (MAP-COMMAND (FUNCALL MAP-COMMAND MAP-FUNCTION MAP-ARG FILTER-FUNCTION FILTER-ARG)) (T (BARF "That command does not take a filter argument")))))) ;; If the blip is a :MOUSE-BUTTON blip, it contains data from the ;; universe or filter button. Look at them to specify the ((AND (CONSP CHAR) (EQ (FIRST CHAR) :MOUSE-BUTTON)) (SET-COMMAND-BUTTON (SECOND CHAR)) (LET ((WINDOW (THIRD CHAR))) (COND ((SEND WINDOW :OPERATION-HANDLED-P :SET-ACCENT) (UNWIND-PROTECT (*CATCH 'ZWEI-COMMAND-LOOP (COND ((EQ WINDOW UNIVERSE-BUTTON) (MULTIPLE-VALUE (MAP-FUNCTION MAP-ARG) (GET-UNIVERSE-OR-FILTER-FOR-COMMAND 'GET-UNIVERSE-FUNCTION-FOR-COMMAND WINDOW BUTTON-FRAME '*LAST-COMMAND-UNIVERSE-FUNCTION* '*LAST-COMMAND-UNIVERSE-ARG* '*LAST-COMMAND-UNIVERSE-NAME* 'MAP-OVER-SINGLE-ZMAIL-BUFFER *ZMAIL-BUFFER* (AND *ZMAIL-BUFFER* (ZMAIL-BUFFER-NAME *ZMAIL-BUFFER*))))) ((EQ WINDOW FILTER-BUTTON) (MULTIPLE-VALUE (FILTER-FUNCTION FILTER-ARG) (GET-UNIVERSE-OR-FILTER-FOR-COMMAND 'GET-FILTER-FUNCTION-FOR-COMMAND WINDOW BUTTON-FRAME '*LAST-COMMAND-FILTER-FUNCTION* '*LAST-COMMAND-FILTER-ARG* '*LAST-COMMAND-FILTER-NAME* NIL NIL NIL)) (COND ((EQ MAP-FUNCTION 'MAP-OVER-SINGLE-MSG) (SETQ MAP-FUNCTION 'MAP-OVER-SINGLE-ZMAIL-BUFFER MAP-ARG *ZMAIL-BUFFER*) (SEND BUTTON-FRAME :CHANGE-BUTTONS UNIVERSE-BUTTON (ZMAIL-BUFFER-NAME *ZMAIL-BUFFER*))))) (T (ZMAIL-ERROR "~S is not a known window" WINDOW)))) (SEND WINDOW :SET-ACCENT NIL))) (T NIL)))) ;random window (T (SEND *STANDARD-INPUT* :UNTYI CHAR) (RETURN NIL)))) (SEND BUTTON-FRAME :CHANGE-BUTTONS UNIVERSE-BUTTON "Just current message" FILTER-BUTTON "All"))) ;;;This function allows a command to either use its own default filter or universe ;;;or get a filter or universe from a menu and set the command's default. ;;;Which one depends on the value of *ZMAIL-COMMAND-BUTTON*; that is, ;;;which button the user clicked on to invoke the command this time. ;;;Args are: the function to read the universe/filter using a menu, ;;; the "button" window for universes of filters (so its default can be set), ;;; the "button" window's superior window, ;;; three symbols which are variables describing the default for the left button ;;; (as three separate arguments), ;;; and three values which describe the default for the middle button. (DEFUN GET-UNIVERSE-OR-FILTER-FOR-COMMAND (FUNCTION WINDOW SUPERIOR FUNVAR ARGVAR NAMVAR MIDFUN MIDARG MIDNAM &AUX FV AV NAME) (COND ((EQ *ZMAIL-COMMAND-BUTTON* :LEFT) ;; Left button => use values of the variables which contain the default. (SETQ FV (OR (SYMEVAL FUNVAR) (BARF "There is no default for this yet.")) AV (SYMEVAL ARGVAR) NAME (SYMEVAL NAMVAR))) (T ;; Otherwise, set the default either from middle-button values ;; or by reading it in using FUNCTION. (IF (NEQ *ZMAIL-COMMAND-BUTTON* :MIDDLE) (MULTIPLE-VALUE (FV AV NAME) (FUNCALL FUNCTION)) (OR MIDFUN (BARF)) (SETQ FV MIDFUN AV MIDARG NAME MIDNAM)) (COND (FV (SET FUNVAR FV) (SET ARGVAR AV) (SET NAMVAR NAME) ;; Update documentation for the universe or filter button, ;; about defaults for clicking on those buttons, (UPDATE-COMMAND-WHO-LINE-DOCUMENTATION FUNCTION))))) ;; Update what appears in the universe or filter button ;; to show you what universe or filter is being used in this command. ;; It will get changed back at the end of the command. (IF FV (SEND SUPERIOR :CHANGE-BUTTONS WINDOW NAME)) (VALUES FV AV)) (DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-UNIVERSE-FUNCTION* NIL) (DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-UNIVERSE-ARG* NIL) (DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-UNIVERSE-NAME* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION GET-UNIVERSE-FUNCTION-FOR-COMMAND *UNIVERSE-BUTTON-DOCUMENTATION*) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER GET-UNIVERSE-FUNCTION-FOR-COMMAND (STRING) (FORMAT STRING "Change universe for next command: ~@[L: ~A; ~]M: Current buffer; R: menu." *LAST-COMMAND-UNIVERSE-NAME*)) (DEFF GET-UNIVERSE-FUNCTION-FOR-COMMAND 'GET-UNIVERSE-FUNCTION) (DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-FILTER-FUNCTION* NIL) (DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-FILTER-ARG* NIL) (DEFINE-ZMAIL-GLOBAL *LAST-COMMAND-FILTER-NAME* NIL) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION GET-FILTER-FUNCTION-FOR-COMMAND *FILTER-BUTTON-DOCUMENTATION*) (DEFINE-COMMAND-WHO-LINE-DOCUMENTATION-UPDATER GET-FILTER-FUNCTION-FOR-COMMAND (STRING) (FORMAT STRING "Change filter for next command: ~@[L: ~A; ~]R: menu." *LAST-COMMAND-FILTER-NAME*)) (DEFUN GET-FILTER-FUNCTION-FOR-COMMAND (&AUX FUN ARG) (MULTIPLE-VALUE (NIL NIL FUN ARG) (GET-FILTER-FUNCTION-1 NIL NIL NIL '(:MOUSE))) (VALUES FUN ARG (FILTER-FUNCTION-BUFFER-NAME FUN ARG)))