diff options
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/Makefile.local | 4 | ||||
| -rw-r--r-- | emacs/notmuch-address.el | 9 | ||||
| -rw-r--r-- | emacs/notmuch-crypto.el | 28 | ||||
| -rw-r--r-- | emacs/notmuch-hello.el | 728 | ||||
| -rw-r--r-- | emacs/notmuch-lib.el | 376 | ||||
| -rw-r--r-- | emacs/notmuch-maildir-fcc.el | 13 | ||||
| -rw-r--r-- | emacs/notmuch-message.el | 5 | ||||
| -rw-r--r-- | emacs/notmuch-mua.el | 227 | ||||
| -rw-r--r-- | emacs/notmuch-print.el | 92 | ||||
| -rw-r--r-- | emacs/notmuch-show.el | 966 | ||||
| -rw-r--r-- | emacs/notmuch-tag.el | 145 | ||||
| -rw-r--r-- | emacs/notmuch-wash.el | 107 | ||||
| -rw-r--r-- | emacs/notmuch.el | 804 |
13 files changed, 2446 insertions, 1058 deletions
diff --git a/emacs/Makefile.local b/emacs/Makefile.local index 0c58b82..fb82247 100644 --- a/emacs/Makefile.local +++ b/emacs/Makefile.local @@ -13,7 +13,9 @@ emacs_sources := \ $(dir)/notmuch-maildir-fcc.el \ $(dir)/notmuch-message.el \ $(dir)/notmuch-crypto.el \ - $(dir)/coolj.el + $(dir)/notmuch-tag.el \ + $(dir)/coolj.el \ + $(dir)/notmuch-print.el emacs_images := \ $(srcdir)/$(dir)/notmuch-logo.png diff --git a/emacs/notmuch-address.el b/emacs/notmuch-address.el index 8eba7a0..2bf762b 100644 --- a/emacs/notmuch-address.el +++ b/emacs/notmuch-address.el @@ -28,7 +28,8 @@ single argument and output a list of possible matches, one per line." :type 'string - :group 'notmuch) + :group 'notmuch-send + :group 'notmuch-external) (defvar notmuch-address-message-alist-member '("^\\(Resent-\\)?\\(To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" @@ -37,9 +38,9 @@ line." (defvar notmuch-address-history nil) (defun notmuch-address-message-insinuate () - (if (not (memq notmuch-address-message-alist-member message-completion-alist)) - (setq message-completion-alist - (push notmuch-address-message-alist-member message-completion-alist)))) + (unless (memq notmuch-address-message-alist-member message-completion-alist) + (setq message-completion-alist + (push notmuch-address-message-alist-member message-completion-alist)))) (defun notmuch-address-options (original) (process-lines notmuch-address-command original)) diff --git a/emacs/notmuch-crypto.el b/emacs/notmuch-crypto.el index ac30098..83e5d37 100644 --- a/emacs/notmuch-crypto.el +++ b/emacs/notmuch-crypto.el @@ -34,38 +34,44 @@ The effect of setting this variable can be seen temporarily by providing a prefix when viewing a signed or encrypted message, or by providing a prefix when reloading the message in notmuch-show mode." - :group 'notmuch - :type 'boolean) + :type 'boolean + :group 'notmuch-crypto) (defface notmuch-crypto-part-header '((t (:foreground "blue"))) "Face used for crypto parts headers." - :group 'notmuch) + :group 'notmuch-crypto + :group 'notmuch-faces) (defface notmuch-crypto-signature-good '((t (:background "green" :foreground "black"))) "Face used for good signatures." - :group 'notmuch) + :group 'notmuch-crypto + :group 'notmuch-faces) (defface notmuch-crypto-signature-good-key '((t (:background "orange" :foreground "black"))) "Face used for good signatures." - :group 'notmuch) + :group 'notmuch-crypto + :group 'notmuch-faces) (defface notmuch-crypto-signature-bad '((t (:background "red" :foreground "black"))) "Face used for bad signatures." - :group 'notmuch) + :group 'notmuch-crypto + :group 'notmuch-faces) (defface notmuch-crypto-signature-unknown '((t (:background "red" :foreground "black"))) "Face used for signatures of unknown status." - :group 'notmuch) + :group 'notmuch-crypto + :group 'notmuch-faces) (defface notmuch-crypto-decryption '((t (:background "purple" :foreground "black"))) "Face used for encryption/decryption status messages." - :group 'notmuch) + :group 'notmuch-crypto + :group 'notmuch-faces) (define-button-type 'notmuch-crypto-status-button-type 'action (lambda (button) (message (button-get button 'help-echo))) @@ -95,7 +101,7 @@ mode." (let ((keyid (concat "0x" (plist-get sigstatus :keyid)))) (setq label (concat "Unknown key ID " keyid " or unsupported algorithm")) (setq button-action 'notmuch-crypto-sigstatus-error-callback) - (setq help-msg (concat "Click to retreive key ID " keyid " from keyserver and redisplay.")))) + (setq help-msg (concat "Click to retrieve key ID " keyid " from keyserver and redisplay.")))) ((string= status "bad") (let ((keyid (concat "0x" (plist-get sigstatus :keyid)))) (setq label (concat "Bad signature (claimed key ID " keyid ")")) @@ -114,7 +120,7 @@ mode." :notmuch-from from) (insert "\n"))) -(declare-function notmuch-show-refresh-view "notmuch-show" (&optional crypto-switch)) +(declare-function notmuch-show-refresh-view "notmuch-show" (&optional reset-state)) (defun notmuch-crypto-sigstatus-good-callback (button) (let* ((sigstatus (button-get button :notmuch-sigstatus)) @@ -123,6 +129,7 @@ mode." (window (display-buffer buffer t nil))) (with-selected-window window (with-current-buffer buffer + (goto-char (point-max)) (call-process "gpg" nil t t "--list-keys" fingerprint)) (recenter -1)))) @@ -133,6 +140,7 @@ mode." (window (display-buffer buffer t nil))) (with-selected-window window (with-current-buffer buffer + (goto-char (point-max)) (call-process "gpg" nil t t "--recv-keys" keyid) (insert "\n") (call-process "gpg" nil t t "--list-keys" keyid)) diff --git a/emacs/notmuch-hello.el b/emacs/notmuch-hello.el index 02017ce..684bedc 100644 --- a/emacs/notmuch-hello.el +++ b/emacs/notmuch-hello.el @@ -29,22 +29,19 @@ (declare-function notmuch-search "notmuch" (query &optional oldest-first target-thread target-line continuation)) (declare-function notmuch-poll "notmuch" ()) -(defvar notmuch-hello-search-bar-marker nil - "The position of the search bar within the notmuch-hello buffer.") - -(defcustom notmuch-recent-searches-max 10 - "The number of recent searches to store and display." +(defcustom notmuch-hello-recent-searches-max 10 + "The number of recent searches to display." :type 'integer - :group 'notmuch) + :group 'notmuch-hello) (defcustom notmuch-show-empty-saved-searches nil "Should saved searches with no messages be listed?" :type 'boolean - :group 'notmuch) + :group 'notmuch-hello) (defun notmuch-sort-saved-searches (alist) "Generate an alphabetically sorted saved searches alist." - (sort alist (lambda (a b) (string< (car a) (car b))))) + (sort (copy-sequence alist) (lambda (a b) (string< (car a) (car b))))) (defcustom notmuch-saved-search-sort-function nil "Function used to sort the saved searches for the notmuch-hello view. @@ -60,7 +57,7 @@ alist to be used." (const :tag "Sort alphabetically" notmuch-sort-saved-searches) (function :tag "Custom sort function" :value notmuch-sort-saved-searches)) - :group 'notmuch) + :group 'notmuch-hello) (defvar notmuch-hello-indent 4 "How much to indent non-headers.") @@ -68,12 +65,12 @@ alist to be used." (defcustom notmuch-show-logo t "Should the notmuch logo be shown?" :type 'boolean - :group 'notmuch) + :group 'notmuch-hello) (defcustom notmuch-show-all-tags-list nil "Should all tags be shown in the notmuch-hello view?" :type 'boolean - :group 'notmuch) + :group 'notmuch-hello) (defcustom notmuch-hello-tag-list-make-query nil "Function or string to generate queries for the all tags list. @@ -89,12 +86,12 @@ should return a filter for that tag, or nil to hide the tag." (string :tag "Custom filter" :value "tag:unread") (function :tag "Custom filter function")) - :group 'notmuch) + :group 'notmuch-hello) (defcustom notmuch-hello-hide-tags nil "List of tags to be hidden in the \"all tags\"-section." :type '(repeat string) - :group 'notmuch) + :group 'notmuch-hello) (defface notmuch-hello-logo-background '((((class color) @@ -104,7 +101,8 @@ should return a filter for that tag, or nil to hide the tag." (background light)) (:background "white"))) "Background colour for the notmuch logo." - :group 'notmuch) + :group 'notmuch-hello + :group 'notmuch-faces) (defcustom notmuch-column-control t "Controls the number of columns for saved searches/tags in notmuch view. @@ -126,11 +124,11 @@ So: 30. - if you don't want to worry about all of this nonsense, leave this set to `t'." - :group 'notmuch :type '(choice (const :tag "Automatically calculated" t) (integer :tag "Number of characters") - (float :tag "Fraction of window"))) + (float :tag "Fraction of window")) + :group 'notmuch-hello) (defcustom notmuch-hello-thousands-separator " " "The string used as a thousands separator. @@ -138,31 +136,125 @@ So: Typically \",\" in the US and UK and \".\" or \" \" in Europe. The latter is recommended in the SI/ISO 31-0 standard and by the International Bureau of Weights and Measures." - :group 'notmuch - :type 'string) + :type 'string + :group 'notmuch-hello) (defcustom notmuch-hello-mode-hook nil "Functions called after entering `notmuch-hello-mode'." - :group 'notmuch - :type 'hook) + :type 'hook + :group 'notmuch-hello + :group 'notmuch-hooks) (defcustom notmuch-hello-refresh-hook nil "Functions called after updating a `notmuch-hello' buffer." :type 'hook - :group 'notmuch) + :group 'notmuch-hello + :group 'notmuch-hooks) (defvar notmuch-hello-url "http://notmuchmail.org" "The `notmuch' web site.") -(defvar notmuch-hello-recent-searches nil) - -(defun notmuch-hello-remember-search (search) - (setq notmuch-hello-recent-searches - (delete search notmuch-hello-recent-searches)) - (push search notmuch-hello-recent-searches) - (if (> (length notmuch-hello-recent-searches) - notmuch-recent-searches-max) - (setq notmuch-hello-recent-searches (butlast notmuch-hello-recent-searches)))) +(defvar notmuch-hello-search-pos nil + "Position of search widget, if any. + +This should only be set by `notmuch-hello-insert-search'.") + +(defvar notmuch-hello-custom-section-options + '((:filter (string :tag "Filter for each tag")) + (:filter-count (string :tag "Different filter to generate message counts")) + (:initially-hidden (const :tag "Hide this section on startup" t)) + (:show-empty-searches (const :tag "Show queries with no matching messages" t)) + (:hide-if-empty (const :tag "Hide this section if all queries are empty +\(and not shown by show-empty-searches)" t))) + "Various customization-options for notmuch-hello-tags/query-section.") + +(define-widget 'notmuch-hello-tags-section 'lazy + "Customize-type for notmuch-hello tag-list sections." + :tag "Customized tag-list section (see docstring for details)" + :type + `(list :tag "" + (const :tag "" notmuch-hello-insert-tags-section) + (string :tag "Title for this section") + (plist + :inline t + :options + ,(append notmuch-hello-custom-section-options + '((:hide-tags (repeat :tag "Tags that will be hidden" + string))))))) + +(define-widget 'notmuch-hello-query-section 'lazy + "Customize-type for custom saved-search-like sections" + :tag "Customized queries section (see docstring for details)" + :type + `(list :tag "" + (const :tag "" notmuch-hello-insert-searches) + (string :tag "Title for this section") + (repeat :tag "Queries" + (cons (string :tag "Name") (string :tag "Query"))) + (plist :inline t :options ,notmuch-hello-custom-section-options))) + +(defcustom notmuch-hello-sections + (list #'notmuch-hello-insert-header + #'notmuch-hello-insert-saved-searches + #'notmuch-hello-insert-search + #'notmuch-hello-insert-recent-searches + #'notmuch-hello-insert-alltags + #'notmuch-hello-insert-footer) + "Sections for notmuch-hello. + +The list contains functions which are used to construct sections in +notmuch-hello buffer. When notmuch-hello buffer is constructed, +these functions are run in the order they appear in this list. Each +function produces a section simply by adding content to the current +buffer. A section should not end with an empty line, because a +newline will be inserted after each section by `notmuch-hello'. + +Each function should take no arguments. If the produced section +includes `notmuch-hello-target' (i.e. cursor should be positioned +inside this section), the function should return this element's +position. +Otherwise, it should return nil. + +For convenience an element can also be a list of the form (FUNC ARG1 +ARG2 .. ARGN) in which case FUNC will be applied to the rest of the +list. + +A \"Customized tag-list section\" item in the customize-interface +displays a list of all tags, optionally hiding some of them. It +is also possible to filter the list of messages matching each tag +by an additional filter query. Similarly, the count of messages +displayed next to the buttons can be generated by applying a +different filter to the tag query. These filters are also +supported for \"Customized queries section\" items." + :group 'notmuch-hello + :type + '(repeat + (choice (function-item notmuch-hello-insert-header) + (function-item notmuch-hello-insert-saved-searches) + (function-item notmuch-hello-insert-search) + (function-item notmuch-hello-insert-recent-searches) + (function-item notmuch-hello-insert-alltags) + (function-item notmuch-hello-insert-footer) + (function-item notmuch-hello-insert-inbox) + notmuch-hello-tags-section + notmuch-hello-query-section + (function :tag "Custom section")))) + +(defvar notmuch-hello-target nil + "Button text at position of point before rebuilding the notmuch-buffer. + +This variable contains the text of the button, if any, the +point was positioned at before the notmuch-hello buffer was +rebuilt. This should never actually be global and is defined as a +defvar only for documentation purposes and to avoid a compiler +warning about it occurring as a free variable.") + +(defvar notmuch-hello-hidden-sections nil + "List of sections titles whose contents are hidden") + +(defvar notmuch-hello-first-run t + "True if `notmuch-hello' is run for the first time, set to nil +afterwards.") (defun notmuch-hello-nice-number (n) (let (result) @@ -182,10 +274,14 @@ International Bureau of Weights and Measures." (match-string 1 search) search)) -(defun notmuch-hello-search (search) - (let ((search (notmuch-hello-trim search))) - (notmuch-hello-remember-search search) - (notmuch-search search notmuch-search-oldest-first nil nil #'notmuch-hello-search-continuation))) +(defun notmuch-hello-search (&optional search) + (interactive) + (unless (null search) + (setq search (notmuch-hello-trim search)) + (let ((history-delete-duplicates t)) + (add-to-history 'notmuch-search-history search))) + (notmuch-search search notmuch-search-oldest-first nil nil + #'notmuch-hello-search-continuation)) (defun notmuch-hello-add-saved-search (widget) (interactive) @@ -207,8 +303,8 @@ International Bureau of Weights and Measures." (message "Saved '%s' as '%s'." search name) (notmuch-hello-update))) -(defun notmuch-hello-longest-label (tag-alist) - (or (loop for elem in tag-alist +(defun notmuch-hello-longest-label (searches-alist) + (or (loop for elem in searches-alist maximize (length (car elem))) 0)) @@ -272,12 +368,71 @@ should be. Returns a cons cell `(tags-per-line width)'." (* tags-per-line (+ 9 1)))) tags-per-line)))) -(defun notmuch-hello-insert-tags (tag-alist widest target) - (let* ((tags-and-width (notmuch-hello-tags-per-line widest)) +(defun notmuch-hello-filtered-query (query filter) + "Constructs a query to search all messages matching QUERY and FILTER. + +If FILTER is a string, it is directly used in the returned query. + +If FILTER is a function, it is called with QUERY as a parameter and +the string it returns is used as the query. If nil is returned, +the entry is hidden. + +Otherwise, FILTER is ignored. +" + (cond + ((functionp filter) (funcall filter query)) + ((stringp filter) + (concat "(" query ") and (" filter ")")) + (t query))) + +(defun notmuch-hello-query-counts (query-alist &rest options) + "Compute list of counts of matched messages from QUERY-ALIST. + +QUERY-ALIST must be a list containing elements of the form (NAME . QUERY) +or (NAME QUERY COUNT-QUERY). If the latter form is used, +COUNT-QUERY specifies an alternate query to be used to generate +the count for the associated query. + +The result is the list of elements of the form (NAME QUERY COUNT). + +The values :show-empty-searches, :filter and :filter-count from +options will be handled as specified for +`notmuch-hello-insert-searches'." + (notmuch-remove-if-not + #'identity + (mapcar + (lambda (elem) + (let* ((name (car elem)) + (query-and-count (if (consp (cdr elem)) + ;; do we have a different query for the message count? + (cons (second elem) (third elem)) + (cons (cdr elem) (cdr elem)))) + (message-count + (string-to-number + (notmuch-saved-search-count + (notmuch-hello-filtered-query (cdr query-and-count) + (or (plist-get options :filter-count) + (plist-get options :filter))))))) + (and (or (plist-get options :show-empty-searches) (> message-count 0)) + (list name (notmuch-hello-filtered-query + (car query-and-count) (plist-get options :filter)) + message-count)))) + query-alist))) + +(defun notmuch-hello-insert-buttons (searches) + "Insert buttons for SEARCHES. + +SEARCHES must be a list containing lists of the form (NAME QUERY COUNT), where +QUERY is the query to start when the button for the corresponding entry is +activated. COUNT should be the number of messages matching the query. +Such a list can be computed with `notmuch-hello-query-counts'." + (let* ((widest (notmuch-hello-longest-label searches)) + (tags-and-width (notmuch-hello-tags-per-line widest)) (tags-per-line (car tags-and-width)) - (widest (cdr tags-and-width)) + (column-width (cdr tags-and-width)) + (column-indent 0) (count 0) - (reordered-list (notmuch-hello-reflect tag-alist tags-per-line)) + (reordered-list (notmuch-hello-reflect searches tags-per-line)) ;; Hack the display of the buttons used. (widget-push-button-prefix "") (widget-push-button-suffix "") @@ -287,45 +442,33 @@ should be. Returns a cons cell `(tags-per-line width)'." (mapc (lambda (elem) ;; (not elem) indicates an empty slot in the matrix. (when elem - (let* ((name (car elem)) - (query (cdr elem)) - (formatted-name (format "%s " name))) + (if (> column-indent 0) + (widget-insert (make-string column-indent ? ))) + (let* ((name (first elem)) + (query (second elem)) + (msg-count (third elem))) (widget-insert (format "%8s " - (notmuch-hello-nice-number - (string-to-number (notmuch-saved-search-count query))))) - (if (string= formatted-name target) + (notmuch-hello-nice-number msg-count))) + (if (string= name notmuch-hello-target) (setq found-target-pos (point-marker))) (widget-create 'push-button :notify #'notmuch-hello-widget-search :notmuch-search-terms query - formatted-name) - (unless (eq (% count tags-per-line) (1- tags-per-line)) - ;; If this is not the last tag on the line, insert - ;; enough space to consume the rest of the column. - ;; Because the button for the name is `(1+ (length - ;; name))' long (due to the trailing space) we can - ;; just insert `(- widest (length name))' spaces - the - ;; column separator is included in the button if - ;; `(equal widest (length name)'. - (widget-insert (make-string (max 1 - (- widest (length name))) - ? ))))) + name) + (setq column-indent + (1+ (max 0 (- column-width (length name))))))) (setq count (1+ count)) - (if (eq (% count tags-per-line) 0) - (widget-insert "\n"))) + (when (eq (% count tags-per-line) 0) + (setq column-indent 0) + (widget-insert "\n"))) reordered-list) ;; If the last line was not full (and hence did not include a ;; carriage return), insert one now. - (if (not (eq (% count tags-per-line) 0)) - (widget-insert "\n")) + (unless (eq (% count tags-per-line) 0) + (widget-insert "\n")) found-target-pos)) -(defun notmuch-hello-goto-search () - "Put point inside the `search' widget." - (interactive) - (goto-char notmuch-hello-search-bar-marker)) - (defimage notmuch-hello-logo ((:type png :file "notmuch-logo.png"))) (defun notmuch-hello-search-continuation() @@ -355,7 +498,7 @@ should be. Returns a cons cell `(tags-per-line width)'." (define-key map "G" 'notmuch-hello-poll-and-update) (define-key map (kbd "<C-tab>") 'widget-backward) (define-key map "m" 'notmuch-mua-new-mail) - (define-key map "s" 'notmuch-hello-goto-search) + (define-key map "s" 'notmuch-hello-search) map) "Keymap for \"notmuch hello\" buffers.") (fset 'notmuch-hello-mode-map notmuch-hello-mode-map) @@ -370,51 +513,263 @@ Complete list of currently available key bindings: (kill-all-local-variables) (use-local-map notmuch-hello-mode-map) (setq major-mode 'notmuch-hello-mode - mode-name "notmuch-hello") + mode-name "notmuch-hello") (run-mode-hooks 'notmuch-hello-mode-hook) ;;(setq buffer-read-only t) ) -(defun notmuch-hello-generate-tag-alist () +(defun notmuch-hello-generate-tag-alist (&optional hide-tags) "Return an alist from tags to queries to display in the all-tags section." - (notmuch-remove-if-not - #'cdr - (mapcar (lambda (tag) - (cons tag - (cond - ((functionp notmuch-hello-tag-list-make-query) - (concat "tag:" tag " and (" - (funcall notmuch-hello-tag-list-make-query tag) ")")) - ((stringp notmuch-hello-tag-list-make-query) - (concat "tag:" tag " and (" - notmuch-hello-tag-list-make-query ")")) - (t (concat "tag:" tag))))) - (notmuch-remove-if-not - (lambda (tag) - (not (member tag notmuch-hello-hide-tags))) - (process-lines notmuch-command "search-tags"))))) + (mapcar (lambda (tag) + (cons tag (format "tag:%s" tag))) + (notmuch-remove-if-not + (lambda (tag) + (not (member tag hide-tags))) + (process-lines notmuch-command "search-tags")))) + +(defun notmuch-hello-insert-header () + "Insert the default notmuch-hello header." + (when notmuch-show-logo + (let ((image notmuch-hello-logo)) + ;; The notmuch logo uses transparency. That can display poorly + ;; when inserting the image into an emacs buffer (black logo on + ;; a black background), so force the background colour of the + ;; image. We use a face to represent the colour so that + ;; `defface' can be used to declare the different possible + ;; colours, which depend on whether the frame has a light or + ;; dark background. + (setq image (cons 'image + (append (cdr image) + (list :background (face-background 'notmuch-hello-logo-background))))) + (insert-image image)) + (widget-insert " ")) + + (widget-insert "Welcome to ") + ;; Hack the display of the links used. + (let ((widget-link-prefix "") + (widget-link-suffix "")) + (widget-create 'link + :notify (lambda (&rest ignore) + (browse-url notmuch-hello-url)) + :help-echo "Visit the notmuch website." + "notmuch") + (widget-insert ". ") + (widget-insert "You have ") + (widget-create 'link + :notify (lambda (&rest ignore) + (notmuch-hello-update)) + :help-echo "Refresh" + (notmuch-hello-nice-number + (string-to-number (car (process-lines notmuch-command "count"))))) + (widget-insert " messages.\n"))) + + +(defun notmuch-hello-insert-saved-searches () + "Insert the saved-searches section." + (let ((searches (notmuch-hello-query-counts + (if notmuch-saved-search-sort-function + (funcall notmuch-saved-search-sort-function + notmuch-saved-searches) + notmuch-saved-searches) + :show-empty-searches notmuch-show-empty-saved-searches)) + found-target-pos) + (when searches + (widget-insert "Saved searches: ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (customize-variable 'notmuch-saved-searches)) + "edit") + (widget-insert "\n\n") + (let ((start (point))) + (setq found-target-pos + (notmuch-hello-insert-buttons searches)) + (indent-rigidly start (point) notmuch-hello-indent) + found-target-pos)))) + +(defun notmuch-hello-insert-search () + "Insert a search widget." + (widget-insert "Search: ") + (setq notmuch-hello-search-pos (point-marker)) + (widget-create 'editable-field + ;; Leave some space at the start and end of the + ;; search boxes. + :size (max 8 (- (window-width) notmuch-hello-indent + (length "Search: "))) + :action (lambda (widget &rest ignore) + (notmuch-hello-search (widget-value widget)))) + ;; Add an invisible dot to make `widget-end-of-line' ignore + ;; trailing spaces in the search widget field. A dot is used + ;; instead of a space to make `show-trailing-whitespace' + ;; happy, i.e. avoid it marking the whole line as trailing + ;; spaces. + (widget-insert ".") + (put-text-property (1- (point)) (point) 'invisible t) + (widget-insert "\n")) + +(defun notmuch-hello-insert-recent-searches () + "Insert recent searches." + (when notmuch-search-history + (widget-insert "Recent searches: ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (setq notmuch-search-history nil) + (notmuch-hello-update)) + "clear") + (widget-insert "\n\n") + (let ((start (point))) + (loop for i from 1 to notmuch-hello-recent-searches-max + for search in notmuch-search-history do + (let ((widget-symbol (intern (format "notmuch-hello-search-%d" i)))) + (set widget-symbol + (widget-create 'editable-field + ;; Don't let the search boxes be + ;; less than 8 characters wide. + :size (max 8 + (- (window-width) + ;; Leave some space + ;; at the start and + ;; end of the + ;; boxes. + (* 2 notmuch-hello-indent) + ;; 1 for the space + ;; before the + ;; `[save]' button. 6 + ;; for the `[save]' + ;; button. + 1 6)) + :action (lambda (widget &rest ignore) + (notmuch-hello-search (widget-value widget))) + search)) + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (widget &rest ignore) + (notmuch-hello-add-saved-search widget)) + :notmuch-saved-search-widget widget-symbol + "save")) + (widget-insert "\n")) + (indent-rigidly start (point) notmuch-hello-indent)) + nil)) + +(defun notmuch-hello-insert-searches (title query-alist &rest options) + "Insert a section with TITLE showing a list of buttons made from QUERY-ALIST. + +QUERY-ALIST must be a list containing elements of the form (NAME . QUERY) +or (NAME QUERY COUNT-QUERY). If the latter form is used, +COUNT-QUERY specifies an alternate query to be used to generate +the count for the associated item. + +Supports the following entries in OPTIONS as a plist: +:initially-hidden - if non-nil, section will be hidden on startup +:show-empty-searches - show buttons with no matching messages +:hide-if-empty - hide if no buttons would be shown + (only makes sense without :show-empty-searches) +:filter - This can be a function that takes the search query as its argument and + returns a filter to be used in conjuction with the query for that search or nil + to hide the element. This can also be a string that is used as a combined with + each query using \"and\". +:filter-count - Separate filter to generate the count displayed each search. Accepts + the same values as :filter. If :filter and :filter-count are specified, this + will be used instead of :filter, not in conjunction with it." + (widget-insert title ": ") + (if (and notmuch-hello-first-run (plist-get options :initially-hidden)) + (add-to-list 'notmuch-hello-hidden-sections title)) + (let ((is-hidden (member title notmuch-hello-hidden-sections)) + (start (point))) + (if is-hidden + (widget-create 'push-button + :notify `(lambda (widget &rest ignore) + (setq notmuch-hello-hidden-sections + (delete ,title notmuch-hello-hidden-sections)) + (notmuch-hello-update)) + "show") + (widget-create 'push-button + :notify `(lambda (widget &rest ignore) + (add-to-list 'notmuch-hello-hidden-sections + ,title) + (notmuch-hello-update)) + "hide")) + (widget-insert "\n") + (let (target-pos) + (when (not is-hidden) + (let ((searches (apply 'notmuch-hello-query-counts query-alist options))) + (when (or (not (plist-get options :hide-if-empty)) + searches) + (widget-insert "\n") + (setq target-pos + (notmuch-hello-insert-buttons searches)) + (indent-rigidly start (point) notmuch-hello-indent)))) + target-pos))) + +(defun notmuch-hello-insert-tags-section (&optional title &rest options) + "Insert a section displaying all tags with message counts. + +TITLE defaults to \"All tags\". +Allowed options are those accepted by `notmuch-hello-insert-searches' and the +following: + +:hide-tags - List of tags that should be excluded." + (apply 'notmuch-hello-insert-searches + (or title "All tags") + (notmuch-hello-generate-tag-alist (plist-get options :hide-tags)) + options)) + +(defun notmuch-hello-insert-inbox () + "Show an entry for each saved search and inboxed messages for each tag" + (notmuch-hello-insert-searches "What's in your inbox" + (append + (notmuch-saved-searches) + (notmuch-hello-generate-tag-alist)) + :filter "tag:inbox")) + +(defun notmuch-hello-insert-alltags () + "Insert a section displaying all tags and associated message counts" + (notmuch-hello-insert-tags-section + nil + :initially-hidden (not notmuch-show-all-tags-list) + :hide-tags notmuch-hello-hide-tags + :filter notmuch-hello-tag-list-make-query)) + +(defun notmuch-hello-insert-footer () + "Insert the notmuch-hello footer." + (let ((start (point))) + (widget-insert "Type a search query and hit RET to view matching threads.\n") + (when notmuch-search-history + (widget-insert "Hit RET to re-submit a previous search. Edit it first if you like.\n") + (widget-insert "Save recent searches with the `save' button.\n")) + (when notmuch-saved-searches + (widget-insert "Edit saved searches with the `edit' button.\n")) + (widget-insert "Hit RET or click on a saved search or tag name to view matching threads.\n") + (widget-insert "`=' to refresh this screen. `s' to search messages. `q' to quit.\n") + (widget-create 'link + :notify (lambda (&rest ignore) + (customize-variable 'notmuch-hello-sections)) + :button-prefix "" :button-suffix "" + "Customize") + (widget-insert " this page.") + (let ((fill-column (- (window-width) notmuch-hello-indent))) + (center-region start (point))))) ;;;###autoload (defun notmuch-hello (&optional no-display) "Run notmuch and display saved searches, known tags, etc." (interactive) - ; Jump through a hoop to get this value from the deprecated variable - ; name (`notmuch-folders') or from the default value. - (if (not notmuch-saved-searches) + ;; Jump through a hoop to get this value from the deprecated variable + ;; name (`notmuch-folders') or from the default value. + (unless notmuch-saved-searches (setq notmuch-saved-searches (notmuch-saved-searches))) (if no-display (set-buffer "*notmuch-hello*") (switch-to-buffer "*notmuch-hello*")) - (let ((target (if (widget-at) - (widget-value (widget-at)) - (condition-case nil - (progn - (widget-forward 1) - (widget-value (widget-at))) - (error nil)))) + (let ((notmuch-hello-target (if (widget-at) + (widget-value (widget-at)) + (condition-case nil + (progn + (widget-forward 1) + (widget-value (widget-at))) + (error nil)))) (inhibit-read-only t)) ;; Delete all editable widget fields. Editable widget fields are @@ -433,166 +788,20 @@ Complete list of currently available key bindings: (mapc 'delete-overlay (car all)) (mapc 'delete-overlay (cdr all))) - (when notmuch-show-logo - (let ((image notmuch-hello-logo)) - ;; The notmuch logo uses transparency. That can display poorly - ;; when inserting the image into an emacs buffer (black logo on - ;; a black background), so force the background colour of the - ;; image. We use a face to represent the colour so that - ;; `defface' can be used to declare the different possible - ;; colours, which depend on whether the frame has a light or - ;; dark background. - (setq image (cons 'image - (append (cdr image) - (list :background (face-background 'notmuch-hello-logo-background))))) - (insert-image image)) - (widget-insert " ")) - - (widget-insert "Welcome to ") - ;; Hack the display of the links used. - (let ((widget-link-prefix "") - (widget-link-suffix "")) - (widget-create 'link - :notify (lambda (&rest ignore) - (browse-url notmuch-hello-url)) - :help-echo "Visit the notmuch website." - "notmuch") - (widget-insert ". ") - (widget-insert "You have ") - (widget-create 'link - :notify (lambda (&rest ignore) - (notmuch-hello-update)) - :help-echo "Refresh" - (notmuch-hello-nice-number - (string-to-number (car (process-lines notmuch-command "count"))))) - (widget-insert " messages.\n")) - - (let ((found-target-pos nil) - (final-target-pos nil)) - (let* ((saved-alist - ;; Filter out empty saved searches if required. - (if notmuch-show-empty-saved-searches - notmuch-saved-searches - (loop for elem in notmuch-saved-searches - if (> (string-to-number (notmuch-saved-search-count (cdr elem))) 0) - collect elem))) - (saved-widest (notmuch-hello-longest-label saved-alist)) - (alltags-alist (if notmuch-show-all-tags-list (notmuch-hello-generate-tag-alist))) - (alltags-widest (notmuch-hello-longest-label alltags-alist)) - (widest (max saved-widest alltags-widest))) - - (when saved-alist - ;; Sort saved searches if required. - (when notmuch-saved-search-sort-function - (setq saved-alist - (funcall notmuch-saved-search-sort-function saved-alist))) - (widget-insert "\nSaved searches: ") - (widget-create 'push-button - :notify (lambda (&rest ignore) - (customize-variable 'notmuch-saved-searches)) - "edit") - (widget-insert "\n\n") - (setq final-target-pos (point-marker)) - (let ((start (point))) - (setq found-target-pos (notmuch-hello-insert-tags saved-alist widest target)) - (if found-target-pos - (setq final-target-pos found-target-pos)) - (indent-rigidly start (point) notmuch-hello-indent))) - - (widget-insert "\nSearch: ") - (setq notmuch-hello-search-bar-marker (point-marker)) - (widget-create 'editable-field - ;; Leave some space at the start and end of the - ;; search boxes. - :size (max 8 (- (window-width) notmuch-hello-indent - (length "Search: "))) - :action (lambda (widget &rest ignore) - (notmuch-hello-search (widget-value widget)))) - ;; add an invisible space to make `widget-end-of-line' ignore - ;; trailine spaces in the search widget field - (widget-insert " ") - (put-text-property (1- (point)) (point) 'invisible t) - (widget-insert "\n") - - (when notmuch-hello-recent-searches - (widget-insert "\nRecent searches: ") - (widget-create 'push-button - :notify (lambda (&rest ignore) - (setq notmuch-hello-recent-searches nil) - (notmuch-hello-update)) - "clear") - (widget-insert "\n\n") - (let ((start (point)) - (nth 0)) - (mapc (lambda (search) - (let ((widget-symbol (intern (format "notmuch-hello-search-%d" nth)))) - (set widget-symbol - (widget-create 'editable-field - ;; Don't let the search boxes be - ;; less than 8 characters wide. - :size (max 8 - (- (window-width) - ;; Leave some space - ;; at the start and - ;; end of the - ;; boxes. - (* 2 notmuch-hello-indent) - ;; 1 for the space - ;; before the - ;; `[save]' button. 6 - ;; for the `[save]' - ;; button. - 1 6)) - :action (lambda (widget &rest ignore) - (notmuch-hello-search (widget-value widget))) - search)) - (widget-insert " ") - (widget-create 'push-button - :notify (lambda (widget &rest ignore) - (notmuch-hello-add-saved-search widget)) - :notmuch-saved-search-widget widget-symbol - "save")) - (widget-insert "\n") - (setq nth (1+ nth))) - notmuch-hello-recent-searches) - (indent-rigidly start (point) notmuch-hello-indent))) - - (when alltags-alist - (widget-insert "\nAll tags: ") - (widget-create 'push-button - :notify (lambda (widget &rest ignore) - (setq notmuch-show-all-tags-list nil) - (notmuch-hello-update)) - "hide") - (widget-insert "\n\n") - (let ((start (point))) - (setq found-target-pos (notmuch-hello-insert-tags alltags-alist widest target)) - (if (not final-target-pos) - (setq final-target-pos found-target-pos)) - (indent-rigidly start (point) notmuch-hello-indent))) - - (widget-insert "\n") - - (if (not notmuch-show-all-tags-list) - (widget-create 'push-button - :notify (lambda (widget &rest ignore) - (setq notmuch-show-all-tags-list t) - (notmuch-hello-update)) - "Show all tags"))) - - (let ((start (point))) - (widget-insert "\n\n") - (widget-insert "Type a search query and hit RET to view matching threads.\n") - (when notmuch-hello-recent-searches - (widget-insert "Hit RET to re-submit a previous search. Edit it first if you like.\n") - (widget-insert "Save recent searches with the `save' button.\n")) - (when notmuch-saved-searches - (widget-insert "Edit saved searches with the `edit' button.\n")) - (widget-insert "Hit RET or click on a saved search or tag name to view matching threads.\n") - (widget-insert "`=' refreshes this screen. `s' jumps to the search box. `q' to quit.\n") - (let ((fill-column (- (window-width) notmuch-hello-indent))) - (center-region start (point)))) - + (let (final-target-pos) + (mapc + (lambda (section) + (let ((point-before (point)) + (result (if (functionp section) + (funcall section) + (apply (car section) (cdr section))))) + (if (and (not final-target-pos) (integer-or-marker-p result)) + (setq final-target-pos result)) + ;; don't insert a newline when the previous section didn't show + ;; anything. + (unless (eq (point) point-before) + (widget-insert "\n")))) + notmuch-hello-sections) (widget-setup) (when final-target-pos @@ -601,9 +810,10 @@ Complete list of currently available key bindings: (widget-forward 1))) (unless (widget-at) - (notmuch-hello-goto-search)))) - - (run-hooks 'notmuch-hello-refresh-hook)) + (when notmuch-hello-search-pos + (goto-char notmuch-hello-search-pos))))) + (run-hooks 'notmuch-hello-refresh-hook) + (setq notmuch-hello-first-run nil)) (defun notmuch-folder () "Deprecated function for invoking notmuch---calling `notmuch' is preferred now." diff --git a/emacs/notmuch-lib.el b/emacs/notmuch-lib.el index 0f856bf..30db58f 100644 --- a/emacs/notmuch-lib.el +++ b/emacs/notmuch-lib.el @@ -21,6 +21,11 @@ ;; This is an part of an emacs-based interface to the notmuch mail system. +(require 'mm-view) +(require 'mm-decode) +(require 'json) +(eval-when-compile (require 'cl)) + (defvar notmuch-command "notmuch" "Command to run the notmuch binary.") @@ -28,17 +33,54 @@ "Notmuch mail reader for Emacs." :group 'mail) +(defgroup notmuch-hello nil + "Overview of saved searches, tags, etc." + :group 'notmuch) + +(defgroup notmuch-search nil + "Searching and sorting mail." + :group 'notmuch) + +(defgroup notmuch-show nil + "Showing messages and threads." + :group 'notmuch) + +(defgroup notmuch-send nil + "Sending messages from Notmuch." + :group 'notmuch) + +(custom-add-to-group 'notmuch-send 'message 'custom-group) + +(defgroup notmuch-crypto nil + "Processing and display of cryptographic MIME parts." + :group 'notmuch) + +(defgroup notmuch-hooks nil + "Running custom code on well-defined occasions." + :group 'notmuch) + +(defgroup notmuch-external nil + "Running external commands from within Notmuch." + :group 'notmuch) + +(defgroup notmuch-faces nil + "Graphical attributes for displaying text" + :group 'notmuch) + (defcustom notmuch-search-oldest-first t "Show the oldest mail first when searching." :type 'boolean - :group 'notmuch) + :group 'notmuch-search) ;; +(defvar notmuch-search-history nil + "Variable to store notmuch searches history.") + (defcustom notmuch-saved-searches nil "A list of saved searches to display." :type '(alist :key-type string :value-type string) - :group 'notmuch) + :group 'notmuch-hello) (defvar notmuch-folders nil "Deprecated name for what is now known as `notmuch-saved-searches'.") @@ -96,6 +138,19 @@ the user hasn't set this variable with the old or new value." (interactive) (kill-buffer (current-buffer))) +(defun notmuch-prettify-subject (subject) + ;; This function is used by `notmuch-search-process-filter' which + ;; requires that we not disrupt its' matching state. + (save-match-data + (if (and subject + (string-match "^[ \t]*$" subject)) + "[No Subject]" + subject))) + +(defun notmuch-id-to-query (id) + "Return a query that matches the message with id ID." + (concat "id:\"" (replace-regexp-in-string "\"" "\"\"" id t t) "\"")) + ;; (defun notmuch-common-do-stash (text) @@ -114,19 +169,121 @@ the user hasn't set this variable with the old or new value." (setq list (cdr list))) (nreverse out))) -; This lets us avoid compiling these replacement functions when emacs -; is sufficiently new enough to supply them alone. We do the macro -; treatment rather than just wrapping our defun calls in a when form -; specifically so that the compiler never sees the code on new emacs, -; (since the code is triggering warnings that we don't know how to get -; rid of. -; -; A more clever macro here would accept a condition and a list of forms. +;; This lets us avoid compiling these replacement functions when emacs +;; is sufficiently new enough to supply them alone. We do the macro +;; treatment rather than just wrapping our defun calls in a when form +;; specifically so that the compiler never sees the code on new emacs, +;; (since the code is triggering warnings that we don't know how to get +;; rid of. +;; +;; A more clever macro here would accept a condition and a list of forms. (defmacro compile-on-emacs-prior-to-23 (form) "Conditionally evaluate form only on emacs < emacs-23." (list 'when (< emacs-major-version 23) form)) +(defun notmuch-split-content-type (content-type) + "Split content/type into 'content' and 'type'" + (split-string content-type "/")) + +(defun notmuch-match-content-type (t1 t2) + "Return t if t1 and t2 are matching content types, taking wildcards into account" + (let ((st1 (notmuch-split-content-type t1)) + (st2 (notmuch-split-content-type t2))) + (if (or (string= (cadr st1) "*") + (string= (cadr st2) "*")) + ;; Comparison of content types should be case insensitive. + (string= (downcase (car st1)) (downcase (car st2))) + (string= (downcase t1) (downcase t2))))) + +(defvar notmuch-multipart/alternative-discouraged + '( + ;; Avoid HTML parts. + "text/html" + ;; multipart/related usually contain a text/html part and some associated graphics. + "multipart/related" + )) + +(defun notmuch-multipart/alternative-choose (types) + "Return a list of preferred types from the given list of types" + ;; Based on `mm-preferred-alternative-precedence'. + (let ((seq types)) + (dolist (pref (reverse notmuch-multipart/alternative-discouraged)) + (dolist (elem (copy-sequence seq)) + (when (string-match pref elem) + (setq seq (nconc (delete elem seq) (list elem)))))) + seq)) + +(defun notmuch-parts-filter-by-type (parts type) + "Given a list of message parts, return a list containing the ones matching +the given type." + (remove-if-not + (lambda (part) (notmuch-match-content-type (plist-get part :content-type) type)) + parts)) + +;; Helper for parts which are generally not included in the default +;; JSON output. +(defun notmuch-get-bodypart-internal (query part-number process-crypto) + (let ((args '("show" "--format=raw")) + (part-arg (format "--part=%s" part-number))) + (setq args (append args (list part-arg))) + (if process-crypto + (setq args (append args '("--decrypt")))) + (setq args (append args (list query))) + (with-temp-buffer + (let ((coding-system-for-read 'no-conversion)) + (progn + (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args)) + (buffer-string)))))) + +(defun notmuch-get-bodypart-content (msg part nth process-crypto) + (or (plist-get part :content) + (notmuch-get-bodypart-internal (notmuch-id-to-query (plist-get msg :id)) nth process-crypto))) + +(defun notmuch-mm-display-part-inline (msg part nth content-type process-crypto) + "Use the mm-decode/mm-view functions to display a part in the +current buffer, if possible." + (let ((display-buffer (current-buffer))) + (with-temp-buffer + ;; In case there is :content, the content string is already converted + ;; into emacs internal format. `gnus-decoded' is a fake charset, + ;; which means no further decoding (to be done by mm- functions). + (let* ((charset (if (plist-member part :content) + 'gnus-decoded + (plist-get part :content-charset))) + (handle (mm-make-handle (current-buffer) `(,content-type (charset . ,charset))))) + ;; If the user wants the part inlined, insert the content and + ;; test whether we are able to inline it (which includes both + ;; capability and suitability tests). + (when (mm-inlined-p handle) + (insert (notmuch-get-bodypart-content msg part nth process-crypto)) + (when (mm-inlinable-p handle) + (set-buffer display-buffer) + (mm-display-part handle) + t)))))) + +;; Converts a plist of headers to an alist of headers. The input plist should +;; have symbols of the form :Header as keys, and the resulting alist will have +;; symbols of the form 'Header as keys. +(defun notmuch-headers-plist-to-alist (plist) + (loop for (key value . rest) on plist by #'cddr + collect (cons (intern (substring (symbol-name key) 1)) value))) + +(defun notmuch-combine-face-text-property (start end face) + "Combine FACE into the 'face text property between START and END. + +This function combines FACE with any existing faces between START +and END. Attributes specified by FACE take precedence over +existing attributes. FACE must be a face name (a symbol or +string), a property list of face attributes, or a list of these." + + (let ((pos start)) + (while (< pos end) + (let ((cur (get-text-property pos 'face)) + (next (next-single-property-change pos 'face nil end))) + (put-text-property pos next 'face (cons face cur)) + (setq pos next))))) + ;; Compatibility functions for versions of emacs before emacs 23. ;; ;; Both functions here were copied from emacs 23 with the following copyright: @@ -155,5 +312,204 @@ was called." (defvar notmuch-show-process-crypto nil) (make-variable-buffer-local 'notmuch-show-process-crypto) +;; Incremental JSON parsing + +(defun notmuch-json-create-parser (buffer) + "Return a streaming JSON parser that consumes input from BUFFER. + +This parser is designed to read streaming JSON whose structure is +known to the caller. Like a typical JSON parsing interface, it +provides a function to read a complete JSON value from the input. +However, it extends this with an additional function that +requires the next value in the input to be a compound value and +descends into it, allowing its elements to be read one at a time +or further descended into. Both functions can return 'retry to +indicate that not enough input is available. + +The parser always consumes input from BUFFER's point. Hence, the +caller is allowed to delete and data before point and may +resynchronize after an error by moving point." + + (list buffer + ;; Terminator stack: a stack of characters that indicate the + ;; end of the compound values enclosing point + '() + ;; Next: One of + ;; * 'expect-value if the next token must be a value, but a + ;; value has not yet been reached + ;; * 'value if point is at the beginning of a value + ;; * 'expect-comma if the next token must be a comma + 'expect-value + ;; Allow terminator: non-nil if the next token may be a + ;; terminator + nil + ;; Partial parse position: If state is 'value, a marker for + ;; the position of the partial parser or nil if no partial + ;; parsing has happened yet + nil + ;; Partial parse state: If state is 'value, the current + ;; `parse-partial-sexp' state + nil)) + +(defmacro notmuch-json-buffer (jp) `(first ,jp)) +(defmacro notmuch-json-term-stack (jp) `(second ,jp)) +(defmacro notmuch-json-next (jp) `(third ,jp)) +(defmacro notmuch-json-allow-term (jp) `(fourth ,jp)) +(defmacro notmuch-json-partial-pos (jp) `(fifth ,jp)) +(defmacro notmuch-json-partial-state (jp) `(sixth ,jp)) + +(defvar notmuch-json-syntax-table + (let ((table (make-syntax-table))) + ;; The standard syntax table is what we need except that "." needs + ;; to have word syntax instead of punctuation syntax. + (modify-syntax-entry ?. "w" table) + table) + "Syntax table used for incremental JSON parsing.") + +(defun notmuch-json-scan-to-value (jp) + ;; Helper function that consumes separators, terminators, and + ;; whitespace from point. Returns nil if it successfully reached + ;; the beginning of a value, 'end if it consumed a terminator, or + ;; 'retry if not enough input was available to reach a value. Upon + ;; nil return, (notmuch-json-next jp) is always 'value. + + (if (eq (notmuch-json-next jp) 'value) + ;; We're already at a value + nil + ;; Drive the state toward 'expect-value + (skip-chars-forward " \t\r\n") + (or (when (eobp) 'retry) + ;; Test for the terminator for the current compound + (when (and (notmuch-json-allow-term jp) + (eq (char-after) (car (notmuch-json-term-stack jp)))) + ;; Consume it and expect a comma or terminator next + (forward-char) + (setf (notmuch-json-term-stack jp) (cdr (notmuch-json-term-stack jp)) + (notmuch-json-next jp) 'expect-comma + (notmuch-json-allow-term jp) t) + 'end) + ;; Test for a separator + (when (eq (notmuch-json-next jp) 'expect-comma) + (when (/= (char-after) ?,) + (signal 'json-readtable-error (list "expected ','"))) + ;; Consume it, switch to 'expect-value, and disallow a + ;; terminator + (forward-char) + (skip-chars-forward " \t\r\n") + (setf (notmuch-json-next jp) 'expect-value + (notmuch-json-allow-term jp) nil) + ;; We moved point, so test for eobp again and fall through + ;; to the next test if there's more input + (when (eobp) 'retry)) + ;; Next must be 'expect-value and we know this isn't + ;; whitespace, EOB, or a terminator, so point must be on a + ;; value + (progn + (assert (eq (notmuch-json-next jp) 'expect-value)) + (setf (notmuch-json-next jp) 'value) + nil)))) + +(defun notmuch-json-begin-compound (jp) + "Parse the beginning of a compound value and traverse inside it. + +Returns 'retry if there is insufficient input to parse the +beginning of the compound. If this is able to parse the +beginning of a compound, it moves point past the token that opens +the compound and returns t. Later calls to `notmuch-json-read' +will return the compound's elements. + +Entering JSON objects is currently unimplemented." + + (with-current-buffer (notmuch-json-buffer jp) + ;; Disallow terminators + (setf (notmuch-json-allow-term jp) nil) + (or (notmuch-json-scan-to-value jp) + (if (/= (char-after) ?\[) + (signal 'json-readtable-error (list "expected '['")) + (forward-char) + (push ?\] (notmuch-json-term-stack jp)) + ;; Expect a value or terminator next + (setf (notmuch-json-next jp) 'expect-value + (notmuch-json-allow-term jp) t) + t)))) + +(defun notmuch-json-read (jp) + "Parse the value at point in JP's buffer. + +Returns 'retry if there is insufficient input to parse a complete +JSON value (though it may still move point over separators or +whitespace). If the parser is currently inside a compound value +and the next token ends the list or object, this moves point just +past the terminator and returns 'end. Otherwise, this moves +point to just past the end of the value and returns the value." + + (with-current-buffer (notmuch-json-buffer jp) + (or + ;; Get to a value state + (notmuch-json-scan-to-value jp) + + ;; Can we parse a complete value? + (let ((complete + (if (looking-at "[-+0-9tfn]") + ;; This is a number or a keyword, so the partial + ;; parser isn't going to help us because a truncated + ;; number or keyword looks like a complete symbol to + ;; it. Look for something that clearly ends it. + (save-excursion + (skip-chars-forward "^]},: \t\r\n") + (not (eobp))) + + ;; We're looking at a string, object, or array, which we + ;; can partial parse. If we just reached the value, set + ;; up the partial parser. + (when (null (notmuch-json-partial-state jp)) + (setf (notmuch-json-partial-pos jp) (point-marker))) + + ;; Extend the partial parse until we either reach EOB or + ;; get the whole value + (save-excursion + (let ((pstate + (with-syntax-table notmuch-json-syntax-table + (parse-partial-sexp + (notmuch-json-partial-pos jp) (point-max) 0 nil + (notmuch-json-partial-state jp))))) + ;; A complete value is available if we've reached + ;; depth 0 or less and encountered a complete + ;; subexpression. + (if (and (<= (first pstate) 0) (third pstate)) + t + ;; Not complete. Update the partial parser state + (setf (notmuch-json-partial-pos jp) (point-marker) + (notmuch-json-partial-state jp) pstate) + nil)))))) + + (if (not complete) + 'retry + ;; We have a value. Reset the partial parse state and expect + ;; a comma or terminator after the value. + (setf (notmuch-json-next jp) 'expect-comma + (notmuch-json-allow-term jp) t + (notmuch-json-partial-pos jp) nil + (notmuch-json-partial-state jp) nil) + ;; Parse the value + (let ((json-object-type 'plist) + (json-array-type 'list) + (json-false nil)) + (json-read))))))) + +(defun notmuch-json-eof (jp) + "Signal a json-error if there is more data in JP's buffer. + +Moves point to the beginning of any trailing data or to the end +of the buffer if there is only trailing whitespace." + + (with-current-buffer (notmuch-json-buffer jp) + (skip-chars-forward " \t\r\n") + (unless (eobp) + (signal 'json-error (list "Trailing garbage following JSON data"))))) + (provide 'notmuch-lib) +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/emacs/notmuch-maildir-fcc.el b/emacs/notmuch-maildir-fcc.el index 6fbf82d..07eedba 100644 --- a/emacs/notmuch-maildir-fcc.el +++ b/emacs/notmuch-maildir-fcc.el @@ -51,13 +51,13 @@ the database.path option in the notmuch configuration file). You will be prompted to create the directory if it does not exist yet when sending a mail." - :require 'notmuch-fcc-initialization - :group 'notmuch :type '(choice (const :tag "No FCC header" nil) (string :tag "A single folder") (repeat :tag "A folder based on the From header" - (cons regexp (string :tag "Folder"))))) + (cons regexp (string :tag "Folder")))) + :require 'notmuch-fcc-initialization + :group 'notmuch-send) (defun notmuch-fcc-initialization () "If notmuch-fcc-directories is set, @@ -140,13 +140,12 @@ will NOT be removed or replaced." t)) (defun notmuch-maildir-fcc-make-uniq-maildir-id () - (let* ((ct (current-time)) - (timeid (+ (* (car ct) 65536) (cadr ct))) - (microseconds (car (cdr (cdr ct)))) + (let* ((ftime (float-time)) + (microseconds (mod (* 1000000 ftime) 1000000)) (hostname (notmuch-maildir-fcc-host-fixer system-name))) (setq notmuch-maildir-fcc-count (+ notmuch-maildir-fcc-count 1)) (format "%d.%d_%d_%d.%s" - timeid + ftime (emacs-pid) microseconds notmuch-maildir-fcc-count diff --git a/emacs/notmuch-message.el b/emacs/notmuch-message.el index 08e5b17..d3738bf 100644 --- a/emacs/notmuch-message.el +++ b/emacs/notmuch-message.el @@ -20,6 +20,7 @@ ;; Authors: Jesse Rosenthal <jrosenthal@jhu.edu> (require 'message) +(require 'notmuch-tag) (require 'notmuch-mua) (defcustom notmuch-message-replied-tags '("replied") @@ -31,7 +32,7 @@ For example, if you wanted to add a \"replied\" tag and remove the \"inbox\" and \"todo\", you would set (\"replied\" \"-inbox\" \"-todo\"\)" :type 'list - :group 'notmuch) + :group 'notmuch-send) (defun notmuch-message-mark-replied () ;; get the in-reply-to header and parse it for the message id. @@ -44,7 +45,7 @@ the \"inbox\" and \"todo\", you would set (concat "+" str) str)) notmuch-message-replied-tags))) - (apply 'notmuch-tag (concat "id:" (car (car rep))) tags))))) + (funcall 'notmuch-tag (notmuch-id-to-query (car (car rep))) tags))))) (add-hook 'message-send-hook 'notmuch-message-mark-replied) diff --git a/emacs/notmuch-mua.el b/emacs/notmuch-mua.el index 32e2e30..408b49e 100644 --- a/emacs/notmuch-mua.el +++ b/emacs/notmuch-mua.el @@ -19,37 +19,80 @@ ;; ;; Authors: David Edmondson <dme@dme.org> +(require 'json) (require 'message) +(require 'mm-view) +(require 'format-spec) (require 'notmuch-lib) (require 'notmuch-address) +(eval-when-compile (require 'cl)) + ;; (defcustom notmuch-mua-send-hook '(notmuch-mua-message-send-hook) "Hook run before sending messages." - :group 'notmuch - :type 'hook) + :type 'hook + :group 'notmuch-send + :group 'notmuch-hooks) + +(defcustom notmuch-mua-compose-in 'current-window + (concat + "Where to create the mail buffer used to compose a new message. +Possible values are `current-window' (default), `new-window' and +`new-frame'. If set to `current-window', the mail buffer will be +displayed in the current window, so the old buffer will be +restored when the mail buffer is killed. If set to `new-window' +or `new-frame', the mail buffer will be displayed in a new +window/frame that will be destroyed when the buffer is killed. +You may want to customize `message-kill-buffer-on-exit' +accordingly." + (when (< emacs-major-version 24) + " Due to a known bug in Emacs 23, you should not set +this to `new-window' if `message-kill-buffer-on-exit' is +disabled: this would result in an incorrect behavior.")) + :group 'notmuch-send + :type '(choice (const :tag "Compose in the current window" current-window) + (const :tag "Compose mail in a new window" new-window) + (const :tag "Compose mail in a new frame" new-frame))) (defcustom notmuch-mua-user-agent-function 'notmuch-mua-user-agent-full "Function used to generate a `User-Agent:' string. If this is `nil' then no `User-Agent:' will be generated." - :group 'notmuch :type '(choice (const :tag "No user agent string" nil) (const :tag "Full" notmuch-mua-user-agent-full) (const :tag "Notmuch" notmuch-mua-user-agent-notmuch) (const :tag "Emacs" notmuch-mua-user-agent-emacs) (function :tag "Custom user agent function" - :value notmuch-mua-user-agent-full))) + :value notmuch-mua-user-agent-full)) + :group 'notmuch-send) (defcustom notmuch-mua-hidden-headers '("^User-Agent:") "Headers that are added to the `message-mode' hidden headers list." - :group 'notmuch - :type '(repeat string)) + :type '(repeat string) + :group 'notmuch-send) ;; +(defun notmuch-mua-get-switch-function () + "Get a switch function according to `notmuch-mua-compose-in'." + (cond ((eq notmuch-mua-compose-in 'current-window) + 'switch-to-buffer) + ((eq notmuch-mua-compose-in 'new-window) + 'switch-to-buffer-other-window) + ((eq notmuch-mua-compose-in 'new-frame) + 'switch-to-buffer-other-frame) + (t (error "Invalid value for `notmuch-mua-compose-in'")))) + +(defun notmuch-mua-maybe-set-window-dedicated () + "Set the selected window as dedicated according to +`notmuch-mua-compose-in'." + (when (or (eq notmuch-mua-compose-in 'new-frame) + (eq notmuch-mua-compose-in 'new-window)) + (set-window-dedicated-p (selected-window) t))) + (defun notmuch-mua-user-agent-full () "Generate a `User-Agent:' string suitable for notmuch." (concat (notmuch-mua-user-agent-notmuch) @@ -71,50 +114,122 @@ list." (push header message-hidden-headers))) notmuch-mua-hidden-headers)) -(defun notmuch-mua-reply (query-string &optional sender) - (let (headers - body - (args '("reply"))) - (if notmuch-show-process-crypto - (setq args (append args '("--decrypt")))) +(defun notmuch-mua-get-quotable-parts (parts) + (loop for part in parts + if (notmuch-match-content-type (plist-get part :content-type) "multipart/alternative") + collect (let* ((subparts (plist-get part :content)) + (types (mapcar (lambda (part) (plist-get part :content-type)) subparts)) + (chosen-type (car (notmuch-multipart/alternative-choose types)))) + (loop for part in (reverse subparts) + if (notmuch-match-content-type (plist-get part :content-type) chosen-type) + return part)) + else if (notmuch-match-content-type (plist-get part :content-type) "multipart/*") + append (notmuch-mua-get-quotable-parts (plist-get part :content)) + else if (notmuch-match-content-type (plist-get part :content-type) "text/*") + collect part)) + +(defun notmuch-mua-insert-quotable-part (message part) + (save-restriction + (narrow-to-region (point) (point)) + (notmuch-mm-display-part-inline message part (plist-get part :id) + (plist-get part :content-type) + notmuch-show-process-crypto) + (goto-char (point-max)))) + +;; There is a bug in emacs 23's message.el that results in a newline +;; not being inserted after the References header, so the next header +;; is concatenated to the end of it. This function fixes the problem, +;; while guarding against the possibility that some current or future +;; version of emacs has the bug fixed. +(defun notmuch-mua-insert-references (original-func header references) + (funcall original-func header references) + (unless (bolp) (insert "\n"))) + +(defun notmuch-mua-reply (query-string &optional sender reply-all) + (let ((args '("reply" "--format=json")) + reply + original) + (when notmuch-show-process-crypto + (setq args (append args '("--decrypt")))) + + (if reply-all + (setq args (append args '("--reply-to=all"))) + (setq args (append args '("--reply-to=sender")))) (setq args (append args (list query-string))) - ;; This make assumptions about the output of `notmuch reply', but - ;; really only that the headers come first followed by a blank - ;; line and then the body. + + ;; Get the reply object as JSON, and parse it into an elisp object. (with-temp-buffer - (apply 'call-process (append (list notmuch-command nil (list t t) nil) args)) + (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args)) (goto-char (point-min)) - (if (re-search-forward "^$" nil t) - (save-excursion - (save-restriction - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (setq headers (mail-header-extract))))) - (forward-line 1) - (setq body (buffer-substring (point) (point-max)))) - ;; If sender is non-nil, set the From: header to its value. - (when sender - (mail-header-set 'from sender headers)) - (let - ;; Overlay the composition window on that being used to read - ;; the original message. - ((same-window-regexps '("\\*mail .*"))) - (notmuch-mua-mail (mail-header 'to headers) - (mail-header 'subject headers) - (message-headers-to-generate headers t '(to subject)))) - ;; insert the message body - but put it in front of the signature - ;; if one is present - (goto-char (point-max)) - (if (re-search-backward message-signature-separator nil t) + (let ((json-object-type 'plist) + (json-array-type 'list) + (json-false 'nil)) + (setq reply (json-read)))) + + ;; Extract the original message to simplify the following code. + (setq original (plist-get reply :original)) + + ;; Extract the headers of both the reply and the original message. + (let* ((original-headers (plist-get original :headers)) + (reply-headers (plist-get reply :reply-headers))) + + ;; If sender is non-nil, set the From: header to its value. + (when sender + (plist-put reply-headers :From sender)) + (let + ;; Overlay the composition window on that being used to read + ;; the original message. + ((same-window-regexps '("\\*mail .*"))) + + ;; We modify message-header-format-alist to get around a bug in message.el. + ;; See the comment above on notmuch-mua-insert-references. + (let ((message-header-format-alist + (loop for pair in message-header-format-alist + if (eq (car pair) 'References) + collect (cons 'References + (apply-partially + 'notmuch-mua-insert-references + (cdr pair))) + else + collect pair))) + (notmuch-mua-mail (plist-get reply-headers :To) + (plist-get reply-headers :Subject) + (notmuch-headers-plist-to-alist reply-headers) + nil (notmuch-mua-get-switch-function)))) + + ;; Insert the message body - but put it in front of the signature + ;; if one is present + (goto-char (point-max)) + (if (re-search-backward message-signature-separator nil t) (forward-line -1) - (goto-char (point-max))) - (insert body) - (push-mark)) - (set-buffer-modified-p nil) + (goto-char (point-max))) + + (let ((from (plist-get original-headers :From)) + (date (plist-get original-headers :Date)) + (start (point))) + + ;; message-cite-original constructs a citation line based on the From and Date + ;; headers of the original message, which are assumed to be in the buffer. + (insert "From: " from "\n") + (insert "Date: " date "\n\n") + + ;; Get the parts of the original message that should be quoted; this includes + ;; all the text parts, except the non-preferred ones in a multipart/alternative. + (let ((quotable-parts (notmuch-mua-get-quotable-parts (plist-get original :body)))) + (mapc (apply-partially 'notmuch-mua-insert-quotable-part original) quotable-parts)) + + (set-mark (point)) + (goto-char start) + ;; Quote the original message according to the user's configured style. + (message-cite-original)))) - (message-goto-body)) + (goto-char (point-max)) + (push-mark) + (message-goto-body) + (set-buffer-modified-p nil)) (defun notmuch-mua-forward-message () + (funcall (notmuch-mua-get-switch-function) (current-buffer)) (message-forward) (when notmuch-mua-user-agent-function @@ -124,6 +239,7 @@ list." (message-sort-headers) (message-hide-headers) (set-buffer-modified-p nil) + (notmuch-mua-maybe-set-window-dedicated) (message-goto-to)) @@ -136,16 +252,17 @@ OTHER-ARGS are passed through to `message-mail'." (when notmuch-mua-user-agent-function (let ((user-agent (funcall notmuch-mua-user-agent-function))) (when (not (string= "" user-agent)) - (push (cons "User-Agent" user-agent) other-headers)))) + (push (cons 'User-Agent user-agent) other-headers)))) - (unless (mail-header 'from other-headers) - (push (cons "From" (concat - (notmuch-user-name) " <" (notmuch-user-primary-email) ">")) other-headers)) + (unless (assq 'From other-headers) + (push (cons 'From (concat + (notmuch-user-name) " <" (notmuch-user-primary-email) ">")) other-headers)) (apply #'message-mail to subject other-headers other-args) (message-sort-headers) (message-hide-headers) (set-buffer-modified-p nil) + (notmuch-mua-maybe-set-window-dedicated) (message-goto-to)) @@ -154,16 +271,16 @@ OTHER-ARGS are passed through to `message-mail'." If this variable is left unset, then a list will be constructed from the name and addresses configured in the notmuch configuration file." - :group 'notmuch - :type '(repeat string)) + :type '(repeat string) + :group 'notmuch-send) (defcustom notmuch-always-prompt-for-sender nil "Always prompt for the From: address when composing or forwarding a message. This is not taken into account when replying to a message, because in that case the From: header is already filled in by notmuch." - :group 'notmuch - :type 'boolean) + :type 'boolean + :group 'notmuch-send) (defvar notmuch-mua-sender-history nil) @@ -201,8 +318,8 @@ the From: address first." (interactive "P") (let ((other-headers (when (or prompt-for-sender notmuch-always-prompt-for-sender) - (list (cons 'from (notmuch-mua-prompt-for-sender)))))) - (notmuch-mua-mail nil nil other-headers))) + (list (cons 'From (notmuch-mua-prompt-for-sender)))))) + (notmuch-mua-mail nil nil other-headers nil (notmuch-mua-get-switch-function)))) (defun notmuch-mua-new-forward-message (&optional prompt-for-sender) "Invoke the notmuch message forwarding window. @@ -218,13 +335,13 @@ the From: address first." (notmuch-mua-forward-message)) (notmuch-mua-forward-message))) -(defun notmuch-mua-new-reply (query-string &optional prompt-for-sender) +(defun notmuch-mua-new-reply (query-string &optional prompt-for-sender reply-all) "Invoke the notmuch reply window." (interactive "P") (let ((sender (when prompt-for-sender (notmuch-mua-prompt-for-sender)))) - (notmuch-mua-reply query-string sender))) + (notmuch-mua-reply query-string sender reply-all))) (defun notmuch-mua-send-and-exit (&optional arg) (interactive "P") diff --git a/emacs/notmuch-print.el b/emacs/notmuch-print.el new file mode 100644 index 0000000..8c18f4b --- /dev/null +++ b/emacs/notmuch-print.el @@ -0,0 +1,92 @@ +;; notmuch-print.el --- printing messages from notmuch. +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see <http://www.gnu.org/licenses/>. +;; +;; Authors: David Edmondson <dme@dme.org> + +(require 'notmuch-lib) + +(declare-function notmuch-show-get-prop "notmuch-show" (prop &optional props)) + +(defcustom notmuch-print-mechanism 'notmuch-print-lpr + "How should printing be done?" + :group 'notmuch-show + :type '(choice + (function :tag "Use lpr" notmuch-print-lpr) + (function :tag "Use ps-print" notmuch-print-ps-print) + (function :tag "Use ps-print then evince" notmuch-print-ps-print/evince) + (function :tag "Use muttprint" notmuch-print-muttprint) + (function :tag "Use muttprint then evince" notmuch-print-muttprint/evince) + (function :tag "Using a custom function"))) + +;; Utility functions: + +(defun notmuch-print-run-evince (file) + "View FILE using 'evince'." + (start-process "evince" nil "evince" file)) + +(defun notmuch-print-run-muttprint (&optional output) + "Pass the contents of the current buffer to 'muttprint'. + +Optional OUTPUT allows passing a list of flags to muttprint." + (apply #'call-process-region (point-min) (point-max) + ;; Reads from stdin. + "muttprint" + nil nil nil + ;; Show the tags. + "--printed-headers" "Date_To_From_CC_Newsgroups_*Subject*_/Tags/" + output)) + +;; User-visible functions: + +(defun notmuch-print-lpr (msg) + "Print a message buffer using lpr." + (lpr-buffer)) + +(defun notmuch-print-ps-print (msg) + "Print a message buffer using the ps-print package." + (let ((subject (notmuch-prettify-subject + (plist-get (notmuch-show-get-prop :headers msg) :Subject)))) + (rename-buffer subject t) + (ps-print-buffer))) + +(defun notmuch-print-ps-print/evince (msg) + "Preview a message buffer using ps-print and evince." + (let ((ps-file (make-temp-file "notmuch")) + (subject (notmuch-prettify-subject + (plist-get (notmuch-show-get-prop :headers msg) :Subject)))) + (rename-buffer subject t) + (ps-print-buffer ps-file) + (notmuch-print-run-evince ps-file))) + +(defun notmuch-print-muttprint (msg) + "Print a message using muttprint." + (notmuch-print-run-muttprint)) + +(defun notmuch-print-muttprint/evince (msg) + "Preview a message buffer using muttprint and evince." + (let ((ps-file (make-temp-file "notmuch"))) + (notmuch-print-run-muttprint (list "--printer" (concat "TO_FILE:" ps-file))) + (notmuch-print-run-evince ps-file))) + +(defun notmuch-print-message (msg) + "Print a message using the user-selected mechanism." + (set-buffer-modified-p nil) + (funcall notmuch-print-mechanism msg)) + +(provide 'notmuch-print) diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el index 034db87..dcfc190 100644 --- a/emacs/notmuch-show.el +++ b/emacs/notmuch-show.el @@ -30,14 +30,16 @@ (require 'goto-addr) (require 'notmuch-lib) +(require 'notmuch-tag) (require 'notmuch-query) (require 'notmuch-wash) (require 'notmuch-mua) (require 'notmuch-crypto) +(require 'notmuch-print) (declare-function notmuch-call-notmuch-process "notmuch" (&rest args)) (declare-function notmuch-fontify-headers "notmuch" nil) -(declare-function notmuch-select-tag-with-completion "notmuch" (prompt &rest search-terms)) +(declare-function notmuch-search-next-thread "notmuch" nil) (declare-function notmuch-search-show-thread "notmuch" nil) (defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date") @@ -47,8 +49,8 @@ For an open message, all of these headers will be made visible according to `notmuch-message-headers-visible' or can be toggled with `notmuch-show-toggle-headers'. For a closed message, only the first header in the list will be visible." - :group 'notmuch - :type '(repeat string)) + :type '(repeat string) + :group 'notmuch-show) (defcustom notmuch-message-headers-visible t "Should the headers be visible by default? @@ -58,41 +60,44 @@ If this value is non-nil, then all of the headers defined in of each message. Otherwise, these headers will be hidden and `notmuch-show-toggle-headers' can be used to make the visible for any given message." - :group 'notmuch - :type 'boolean) + :type 'boolean + :group 'notmuch-show) (defcustom notmuch-show-relative-dates t "Display relative dates in the message summary line." - :group 'notmuch - :type 'boolean) + :type 'boolean + :group 'notmuch-show) (defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers) "A list of functions called to decorate the headers listed in `notmuch-message-headers'.") -(defcustom notmuch-show-hook nil +(defcustom notmuch-show-hook '(notmuch-show-turn-on-visual-line-mode) "Functions called after populating a `notmuch-show' buffer." - :group 'notmuch - :type 'hook) + :type 'hook + :options '(notmuch-show-turn-on-visual-line-mode) + :group 'notmuch-show + :group 'notmuch-hooks) (defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-wrap-long-lines notmuch-wash-tidy-citations notmuch-wash-elide-blank-lines notmuch-wash-excerpt-citations) "Functions used to improve the display of text/plain parts." - :group 'notmuch :type 'hook :options '(notmuch-wash-convert-inline-patch-to-part notmuch-wash-wrap-long-lines notmuch-wash-tidy-citations notmuch-wash-elide-blank-lines - notmuch-wash-excerpt-citations)) + notmuch-wash-excerpt-citations) + :group 'notmuch-show + :group 'notmuch-hooks) ;; Mostly useful for debugging. (defcustom notmuch-show-all-multipart/alternative-parts t "Should all parts of multipart/alternative parts be shown?" - :group 'notmuch - :type 'boolean) + :type 'boolean + :group 'notmuch-show) (defcustom notmuch-show-indent-messages-width 1 "Width of message indentation in threads. @@ -101,14 +106,82 @@ Messages are shown indented according to their depth in a thread. This variable determines the width of this indentation measured in number of blanks. Defaults to `1', choose `0' to disable indentation." - :group 'notmuch - :type 'integer) + :type 'integer + :group 'notmuch-show) (defcustom notmuch-show-indent-multipart nil "Should the sub-parts of a multipart/* part be indented?" ;; dme: Not sure which is a good default. - :group 'notmuch - :type 'boolean) + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-part-button-default-action 'notmuch-show-save-part + "Default part header button action (on ENTER or mouse click)." + :group 'notmuch-show + :type '(choice (const :tag "Save part" + notmuch-show-save-part) + (const :tag "View part" + notmuch-show-view-part) + (const :tag "View interactively" + notmuch-show-interactively-view-part))) + +(defcustom notmuch-show-only-matching-messages nil + "Only matching messages are shown by default." + :type 'boolean + :group 'notmuch-show) + +(defvar notmuch-show-thread-id nil) +(make-variable-buffer-local 'notmuch-show-thread-id) +(put 'notmuch-show-thread-id 'permanent-local t) + +(defvar notmuch-show-parent-buffer nil) +(make-variable-buffer-local 'notmuch-show-parent-buffer) +(put 'notmuch-show-parent-buffer 'permanent-local t) + +(defvar notmuch-show-query-context nil) +(make-variable-buffer-local 'notmuch-show-query-context) +(put 'notmuch-show-query-context 'permanent-local t) + +(defvar notmuch-show-process-crypto nil) +(make-variable-buffer-local 'notmuch-show-process-crypto) +(put 'notmuch-show-process-crypto 'permanent-local t) + +(defvar notmuch-show-elide-non-matching-messages nil) +(make-variable-buffer-local 'notmuch-show-elide-non-matching-messages) +(put 'notmuch-show-elide-non-matching-messages 'permanent-local t) + +(defvar notmuch-show-indent-content t) +(make-variable-buffer-local 'notmuch-show-indent-content) +(put 'notmuch-show-indent-content 'permanent-local t) + +(defcustom notmuch-show-stash-mlarchive-link-alist + '(("Gmane" . "http://mid.gmane.org/") + ("MARC" . "http://marc.info/?i=") + ("Mail Archive, The" . "http://mail-archive.com/search?l=mid&q=") + ;; FIXME: can these services be searched by `Message-Id' ? + ;; ("MarkMail" . "http://markmail.org/") + ;; ("Nabble" . "http://nabble.com/") + ;; ("opensubscriber" . "http://opensubscriber.com/") + ) + "List of Mailing List Archives to use when stashing links. + +These URIs are concatenated with the current message's +Message-Id in `notmuch-show-stash-mlarchive-link'." + :type '(alist :key-type (string :tag "Name") + :value-type (string :tag "URL")) + :group 'notmuch-show) + +(defcustom notmuch-show-stash-mlarchive-link-default "Gmane" + "Default Mailing List Archive to use when stashing links. + +This is used when `notmuch-show-stash-mlarchive-link' isn't +provided with an MLA argument nor `completing-read' input." + :type `(choice + ,@(mapcar + (lambda (mla) + (list 'const :tag (car mla) :value (car mla))) + notmuch-show-stash-mlarchive-link-alist)) + :group 'notmuch-show) (defmacro with-current-notmuch-show-message (&rest body) "Evaluate body with current buffer set to the text of current message" @@ -120,18 +193,22 @@ indentation." ,@body) (kill-buffer buf))))) +(defun notmuch-show-turn-on-visual-line-mode () + "Enable Visual Line mode." + (visual-line-mode t)) + (defun notmuch-show-view-all-mime-parts () "Use external viewers to view all attachments from the current message." (interactive) (with-current-notmuch-show-message - ; We override the mm-inline-media-tests to indicate which message - ; parts are already sufficiently handled by the original - ; presentation of the message in notmuch-show mode. These parts - ; will be inserted directly into the temporary buffer of - ; with-current-notmuch-show-message and silently discarded. - ; - ; Any MIME part not explicitly mentioned here will be handled by an - ; external viewer as configured in the various mailcap files. + ;; We override the mm-inline-media-tests to indicate which message + ;; parts are already sufficiently handled by the original + ;; presentation of the message in notmuch-show mode. These parts + ;; will be inserted directly into the temporary buffer of + ;; with-current-notmuch-show-message and silently discarded. + ;; + ;; Any MIME part not explicitly mentioned here will be handled by an + ;; external viewer as configured in the various mailcap files. (let ((mm-inline-media-tests '( ("text/.*" ignore identity) ("application/pgp-signature" ignore identity) @@ -186,6 +263,54 @@ indentation." mm-handle (> (notmuch-count-attachments mm-handle) 1)))) (message "Done")) +(defun notmuch-show-with-message-as-text (fn) + "Apply FN to a text representation of the current message. + +FN is called with one argument, the message properties. It should +operation on the contents of the current buffer." + + ;; Remake the header to ensure that all information is available. + (let* ((to (notmuch-show-get-to)) + (cc (notmuch-show-get-cc)) + (from (notmuch-show-get-from)) + (subject (notmuch-show-get-subject)) + (date (notmuch-show-get-date)) + (tags (notmuch-show-get-tags)) + (depth (notmuch-show-get-depth)) + + (header (concat + "Subject: " subject "\n" + "To: " to "\n" + (if (not (string= cc "")) + (concat "Cc: " cc "\n") + "") + "From: " from "\n" + "Date: " date "\n" + (if tags + (concat "Tags: " + (mapconcat #'identity tags ", ") "\n") + ""))) + (all (buffer-substring (notmuch-show-message-top) + (notmuch-show-message-bottom))) + + (props (notmuch-show-get-message-properties)) + (indenting notmuch-show-indent-content)) + (with-temp-buffer + (insert all) + (if indenting + (indent-rigidly (point-min) (point-max) (- depth))) + ;; Remove the original header. + (goto-char (point-min)) + (re-search-forward "^$" (point-max) nil) + (delete-region (point-min) (point)) + (insert header) + (funcall fn props)))) + +(defun notmuch-show-print-message () + "Print the current message." + (interactive) + (notmuch-show-with-message-as-text 'notmuch-print-message)) + (defun notmuch-show-fontify-header () (let ((face (cond ((looking-at "[Tt]o:") @@ -230,21 +355,57 @@ indentation." "Try to clean a single email ADDRESS for display. Return unchanged ADDRESS if parsing fails." (condition-case nil - (let* ((parsed (mail-header-parse-address address)) - (address (car parsed)) - (name (cdr parsed))) - ;; Remove double quotes. They might be required during transport, - ;; but we don't need to see them. - (when name - (setq name (replace-regexp-in-string "\"" "" name))) + (let (p-name p-address) + ;; It would be convenient to use `mail-header-parse-address', + ;; but that expects un-decoded mailbox parts, whereas our + ;; mailbox parts are already decoded (and hence may contain + ;; UTF-8). Given that notmuch should handle most of the awkward + ;; cases, some simple string deconstruction should be sufficient + ;; here. + (cond + ;; "User <user@dom.ain>" style. + ((string-match "\\(.*\\) <\\(.*\\)>" address) + (setq p-name (match-string 1 address) + p-address (match-string 2 address))) + + ;; "<user@dom.ain>" style. + ((string-match "<\\(.*\\)>" address) + (setq p-address (match-string 1 address))) + + ;; Everything else. + (t + (setq p-address address))) + + (when p-name + ;; Remove elements of the mailbox part that are not relevant for + ;; display, even if they are required during transport: + ;; + ;; Backslashes. + (setq p-name (replace-regexp-in-string "\\\\" "" p-name)) + + ;; Outer single and double quotes, which might be nested. + (loop + with start-of-loop + do (setq start-of-loop p-name) + + when (string-match "^\"\\(.*\\)\"$" p-name) + do (setq p-name (match-string 1 p-name)) + + when (string-match "^'\\(.*\\)'$" p-name) + do (setq p-name (match-string 1 p-name)) + + until (string= start-of-loop p-name))) + ;; If the address is 'foo@bar.com <foo@bar.com>' then show just ;; 'foo@bar.com'. - (when (string= name address) - (setq name nil)) - - (if (not name) - address - (concat name " <" address ">"))) + (when (string= p-name p-address) + (setq p-name nil)) + + ;; If no name results, return just the address. + (if (not p-name) + p-address + ;; Otherwise format the name and address together. + (concat p-name " <" p-address ">"))) (error address))) (defun notmuch-show-insert-headerline (headers date tags depth) @@ -281,10 +442,22 @@ message at DEPTH in the current thread." (run-hooks 'notmuch-show-markup-headers-hook))))) (define-button-type 'notmuch-show-part-button-type - 'action 'notmuch-show-part-button-action + 'action 'notmuch-show-part-button-default + 'keymap 'notmuch-show-part-button-map 'follow-link t 'face 'message-mml) +(defvar notmuch-show-part-button-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map button-map) + (define-key map "s" 'notmuch-show-part-button-save) + (define-key map "v" 'notmuch-show-part-button-view) + (define-key map "o" 'notmuch-show-part-button-interactively-view) + (define-key map "|" 'notmuch-show-part-button-pipe) + map) + "Submap for button commands") +(fset 'notmuch-show-part-button-map notmuch-show-part-button-map) + (defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment) (let ((button)) (setq button @@ -299,70 +472,71 @@ message at DEPTH in the current thread." " ]") :type 'notmuch-show-part-button-type :notmuch-part nth - :notmuch-filename name)) + :notmuch-filename name + :notmuch-content-type content-type)) (insert "\n") ;; return button button)) ;; Functions handling particular MIME parts. -(defun notmuch-show-save-part (message-id nth &optional filename) - (let ((process-crypto notmuch-show-process-crypto)) - (with-temp-buffer - (setq notmuch-show-process-crypto process-crypto) - ;; Always acquires the part via `notmuch part', even if it is - ;; available in the JSON output. - (insert (notmuch-show-get-bodypart-internal message-id nth)) - (let ((file (read-file-name - "Filename to save as: " - (or mailcap-download-directory "~/") - nil nil - filename))) - ;; Don't re-compress .gz & al. Arguably we should make - ;; `file-name-handler-alist' nil, but that would chop - ;; ange-ftp, which is reasonable to use here. - (mm-write-region (point-min) (point-max) file nil nil nil 'no-conversion t))))) - -(defun notmuch-show-mm-display-part-inline (msg part nth content-type) - "Use the mm-decode/mm-view functions to display a part in the -current buffer, if possible." - (let ((display-buffer (current-buffer))) - (with-temp-buffer - (let* ((charset (plist-get part :content-charset)) - (handle (mm-make-handle (current-buffer) `(,content-type (charset . ,charset))))) - (if (and (mm-inlinable-p handle) - (mm-inlined-p handle)) - (let ((content (notmuch-show-get-bodypart-content msg part nth))) - (insert content) - (set-buffer display-buffer) - (mm-display-part handle) - t) - nil))))) - -(defvar notmuch-show-multipart/alternative-discouraged - '( - ;; Avoid HTML parts. - "text/html" - ;; multipart/related usually contain a text/html part and some associated graphics. - "multipart/related" - )) +(defmacro notmuch-with-temp-part-buffer (message-id nth &rest body) + (declare (indent 2)) + (let ((process-crypto (make-symbol "process-crypto"))) + `(let ((,process-crypto notmuch-show-process-crypto)) + (with-temp-buffer + (setq notmuch-show-process-crypto ,process-crypto) + ;; Always acquires the part via `notmuch part', even if it is + ;; available in the JSON output. + (insert (notmuch-get-bodypart-internal ,message-id ,nth notmuch-show-process-crypto)) + ,@body)))) + +(defun notmuch-show-save-part (message-id nth &optional filename content-type) + (notmuch-with-temp-part-buffer message-id nth + (let ((file (read-file-name + "Filename to save as: " + (or mailcap-download-directory "~/") + nil nil + filename))) + ;; Don't re-compress .gz & al. Arguably we should make + ;; `file-name-handler-alist' nil, but that would chop + ;; ange-ftp, which is reasonable to use here. + (mm-write-region (point-min) (point-max) file nil nil nil 'no-conversion t)))) + +(defun notmuch-show-view-part (message-id nth &optional filename content-type ) + (notmuch-with-temp-part-buffer message-id nth + ;; set mm-inlined-types to nil to force an external viewer + (let ((handle (mm-make-handle (current-buffer) (list content-type))) + (mm-inlined-types nil)) + ;; We override mm-save-part as notmuch-show-save-part is better + ;; since it offers the filename. We need to lexically bind + ;; everything we need for notmuch-show-save-part to prevent + ;; potential dynamic shadowing. + (lexical-let ((message-id message-id) + (nth nth) + (filename filename) + (content-type content-type)) + (flet ((mm-save-part (&rest args) (notmuch-show-save-part + message-id nth filename content-type))) + (mm-display-part handle)))))) + +(defun notmuch-show-interactively-view-part (message-id nth &optional filename content-type) + (notmuch-with-temp-part-buffer message-id nth + (let ((handle (mm-make-handle (current-buffer) (list content-type)))) + (mm-interactively-view-part handle)))) + +(defun notmuch-show-pipe-part (message-id nth &optional filename content-type) + (notmuch-with-temp-part-buffer message-id nth + (let ((handle (mm-make-handle (current-buffer) (list content-type)))) + (mm-pipe-part handle)))) (defun notmuch-show-multipart/*-to-list (part) (mapcar (lambda (inner-part) (plist-get inner-part :content-type)) (plist-get part :content))) -(defun notmuch-show-multipart/alternative-choose (types) - ;; Based on `mm-preferred-alternative-precedence'. - (let ((seq types)) - (dolist (pref (reverse notmuch-show-multipart/alternative-discouraged)) - (dolist (elem (copy-sequence seq)) - (when (string-match pref elem) - (setq seq (nconc (delete elem seq) (list elem)))))) - seq)) - (defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth declared-type) (notmuch-show-insert-part-header nth declared-type content-type nil) - (let ((chosen-type (car (notmuch-show-multipart/alternative-choose (notmuch-show-multipart/*-to-list part)))) + (let ((chosen-type (car (notmuch-multipart/alternative-choose (notmuch-show-multipart/*-to-list part)))) (inner-parts (plist-get part :content)) (start (point))) ;; This inserts all parts of the chosen type rather than just one, @@ -427,8 +601,8 @@ current buffer, if possible." ;; times (hundreds!), which results in many calls to ;; `notmuch part'. (unless content - (setq content (notmuch-show-get-bodypart-internal (concat "id:" message-id) - part-number)) + (setq content (notmuch-get-bodypart-internal (notmuch-id-to-query message-id) + part-number notmuch-show-process-crypto)) (with-current-buffer w3m-current-buffer (notmuch-show-w3m-cid-store-internal url message-id @@ -468,7 +642,7 @@ current buffer, if possible." (sigstatus (car (plist-get part :sigstatus)))) (notmuch-crypto-insert-sigstatus-button sigstatus from)) ;; if we're not adding sigstatus, tell the user how they can get it - (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic mime parts."))) + (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts."))) (let ((inner-parts (plist-get part :content)) (start (point))) @@ -494,7 +668,7 @@ current buffer, if possible." (sigstatus (car (plist-get part :sigstatus)))) (notmuch-crypto-insert-sigstatus-button sigstatus from)))) ;; if we're not adding encstatus, tell the user how they can get it - (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic mime parts."))) + (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts."))) (let ((inner-parts (plist-get part :content)) (start (point))) @@ -548,17 +722,17 @@ current buffer, if possible." ;; insert a header to make this clear. (if (> nth 1) (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename))) - (insert (notmuch-show-get-bodypart-content msg part nth)) + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) (save-excursion (save-restriction (narrow-to-region start (point-max)) (run-hook-with-args 'notmuch-show-insert-text/plain-hook msg depth)))) t) -(defun notmuch-show-insert-part-text/x-vcalendar (msg part content-type nth depth declared-type) +(defun notmuch-show-insert-part-text/calendar (msg part content-type nth depth declared-type) (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)) (insert (with-temp-buffer - (insert (notmuch-show-get-bodypart-content msg part nth)) + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) (goto-char (point-min)) (let ((file (make-temp-file "notmuch-ical")) result) @@ -573,6 +747,10 @@ current buffer, if possible." result))) t) +;; For backwards compatibility. +(defun notmuch-show-insert-part-text/x-vcalendar (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-text/calendar msg part content-type nth depth declared-type)) + (defun notmuch-show-insert-part-application/octet-stream (msg part content-type nth depth declared-type) ;; If we can deduce a MIME type from the filename of the attachment, ;; do so and pass it on to the handler for that type. @@ -596,14 +774,11 @@ current buffer, if possible." (defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type) ;; This handler _must_ succeed - it is the handler of last resort. (notmuch-show-insert-part-header nth content-type declared-type (plist-get part :filename)) - (notmuch-show-mm-display-part-inline msg part nth content-type) + (notmuch-mm-display-part-inline msg part nth content-type notmuch-show-process-crypto) t) ;; Functions for determining how to handle MIME parts. -(defun notmuch-show-split-content-type (content-type) - (split-string content-type "/")) - (defun notmuch-show-handlers-for (content-type) "Return a list of content handlers for a part of type CONTENT-TYPE." (let (result) @@ -614,32 +789,11 @@ current buffer, if possible." (list (intern (concat "notmuch-show-insert-part-*/*")) (intern (concat "notmuch-show-insert-part-" - (car (notmuch-show-split-content-type content-type)) + (car (notmuch-split-content-type content-type)) "/*")) (intern (concat "notmuch-show-insert-part-" content-type)))) result)) -;; Helper for parts which are generally not included in the default -;; JSON output. -;; Uses the buffer-local variable notmuch-show-process-crypto to -;; determine if parts should be decrypted first. -(defun notmuch-show-get-bodypart-internal (message-id part-number) - (let ((args '("show" "--format=raw")) - (part-arg (format "--part=%s" part-number))) - (setq args (append args (list part-arg))) - (if notmuch-show-process-crypto - (setq args (append args '("--decrypt")))) - (setq args (append args (list message-id))) - (with-temp-buffer - (let ((coding-system-for-read 'no-conversion)) - (progn - (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args)) - (buffer-string)))))) - -(defun notmuch-show-get-bodypart-content (msg part nth) - (or (plist-get part :content) - (notmuch-show-get-bodypart-internal (concat "id:" (plist-get msg :id)) nth))) - ;; (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type) @@ -660,8 +814,8 @@ current buffer, if possible." ;; part, so we make sure that we're down at the end. (goto-char (point-max)) ;; Ensure that the part ends with a carriage return. - (if (not (bolp)) - (insert "\n"))) + (unless (bolp) + (insert "\n"))) (defun notmuch-show-insert-body (msg body depth) "Insert the body BODY at depth DEPTH in the current thread." @@ -671,7 +825,7 @@ current buffer, if possible." (make-symbol (concat "notmuch-show-" type))) (defun notmuch-show-strip-re (string) - (replace-regexp-in-string "\\([Rr]e: *\\)+" "" string)) + (replace-regexp-in-string "^\\([Rr]e: *\\)+" "" string)) (defvar notmuch-show-previous-subject "") (make-variable-buffer-local 'notmuch-show-previous-subject) @@ -723,8 +877,6 @@ current buffer, if possible." ;; compatible with the existing implementation. This just sets it ;; to after the first header. (notmuch-show-insert-headers headers) - ;; Headers should include a blank line (backwards compatibility). - (insert "\n") (save-excursion (goto-char content-start) ;; If the subject of this message is the same as that of the @@ -739,15 +891,19 @@ current buffer, if possible." (setq notmuch-show-previous-subject bare-subject) (setq body-start (point-marker)) - (notmuch-show-insert-body msg (plist-get msg :body) depth) + ;; A blank line between the headers and the body. + (insert "\n") + (notmuch-show-insert-body msg (plist-get msg :body) + (if notmuch-show-indent-content depth 0)) ;; Ensure that the body ends with a newline. - (if (not (bolp)) - (insert "\n")) + (unless (bolp) + (insert "\n")) (setq body-end (point-marker)) (setq content-end (point-marker)) ;; Indent according to the depth in the thread. - (indent-rigidly content-start content-end (* notmuch-show-indent-messages-width depth)) + (if notmuch-show-indent-content + (indent-rigidly content-start content-end (* notmuch-show-indent-messages-width depth))) (setq message-end (point-max-marker)) @@ -761,6 +917,8 @@ current buffer, if possible." (overlay-put headers-overlay 'priority 10)) (overlay-put (make-overlay body-start body-end) 'invisible message-invis-spec) + (plist-put msg :depth depth) + ;; Save the properties for this message. Currently this saves the ;; entire message (augmented it with other stuff), which seems ;; like overkill. We might save a reduced subset (for example, not @@ -772,13 +930,43 @@ current buffer, if possible." ;; Message visibility depends on whether it matched the search ;; criteria. - (notmuch-show-message-visible msg (plist-get msg :match)))) + (notmuch-show-message-visible msg (and (plist-get msg :match) + (not (plist-get msg :excluded)))))) + +(defun notmuch-show-toggle-process-crypto () + "Toggle the processing of cryptographic MIME parts." + (interactive) + (setq notmuch-show-process-crypto (not notmuch-show-process-crypto)) + (message (if notmuch-show-process-crypto + "Processing cryptographic MIME parts." + "Not processing cryptographic MIME parts.")) + (notmuch-show-refresh-view)) + +(defun notmuch-show-toggle-elide-non-matching () + "Toggle the display of non-matching messages." + (interactive) + (setq notmuch-show-elide-non-matching-messages (not notmuch-show-elide-non-matching-messages)) + (message (if notmuch-show-elide-non-matching-messages + "Showing matching messages only." + "Showing all messages.")) + (notmuch-show-refresh-view)) + +(defun notmuch-show-toggle-thread-indentation () + "Toggle the indentation of threads." + (interactive) + (setq notmuch-show-indent-content (not notmuch-show-indent-content)) + (message (if notmuch-show-indent-content + "Content is indented." + "Content is not indented.")) + (notmuch-show-refresh-view)) (defun notmuch-show-insert-tree (tree depth) "Insert the message tree TREE at depth DEPTH in the current thread." (let ((msg (car tree)) (replies (cadr tree))) - (notmuch-show-insert-msg msg depth) + ;; We test whether there is a message or just some replies. + (when msg + (notmuch-show-insert-msg msg depth)) (notmuch-show-insert-thread replies (1+ depth)))) (defun notmuch-show-insert-thread (thread depth) @@ -789,15 +977,6 @@ current buffer, if possible." "Insert the forest of threads FOREST." (mapc (lambda (thread) (notmuch-show-insert-thread thread 0)) forest)) -(defvar notmuch-show-thread-id nil) -(make-variable-buffer-local 'notmuch-show-thread-id) -(defvar notmuch-show-parent-buffer nil) -(make-variable-buffer-local 'notmuch-show-parent-buffer) -(defvar notmuch-show-query-context nil) -(make-variable-buffer-local 'notmuch-show-query-context) -(defvar notmuch-show-buffer-name nil) -(make-variable-buffer-local 'notmuch-show-buffer-name) - (defun notmuch-show-buttonise-links (start end) "Buttonise URLs and mail addresses between START and END. @@ -817,7 +996,7 @@ a corresponding notmuch search." 'face goto-address-mail-face)))) ;;;###autoload -(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name crypto-switch) +(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name) "Run \"notmuch show\" with the given thread ID and display results. The optional PARENT-BUFFER is the notmuch-search buffer from @@ -832,80 +1011,113 @@ non-nil. The optional BUFFER-NAME provides the name of the buffer in which the message thread is shown. If it is nil (which occurs when the command is called interactively) the argument to the -function is used. - -The optional CRYPTO-SWITCH toggles the value of the -notmuch-crypto-process-mime customization variable for this show -buffer." +function is used." (interactive "sNotmuch show: ") - (let* ((process-crypto (if crypto-switch - (not notmuch-crypto-process-mime) - notmuch-crypto-process-mime))) - (notmuch-show-worker thread-id parent-buffer query-context buffer-name process-crypto))) - -(defun notmuch-show-worker (thread-id parent-buffer query-context buffer-name process-crypto) - (let* ((buffer-name (generate-new-buffer-name - (or buffer-name - (concat "*notmuch-" thread-id "*")))) - (buffer (get-buffer-create buffer-name)) - (inhibit-read-only t)) - (switch-to-buffer buffer) + (let ((buffer-name (generate-new-buffer-name + (or buffer-name + (concat "*notmuch-" thread-id "*"))))) + (switch-to-buffer (get-buffer-create buffer-name)) + ;; Set the default value for `notmuch-show-process-crypto' in this + ;; buffer. + (setq notmuch-show-process-crypto notmuch-crypto-process-mime) + ;; Set the default value for + ;; `notmuch-show-elide-non-matching-messages' in this buffer. If + ;; there is a prefix argument, invert the default. + (setq notmuch-show-elide-non-matching-messages notmuch-show-only-matching-messages) + (if current-prefix-arg + (setq notmuch-show-elide-non-matching-messages (not notmuch-show-elide-non-matching-messages))) + + (setq notmuch-show-thread-id thread-id + notmuch-show-parent-buffer parent-buffer + notmuch-show-query-context query-context) + (notmuch-show-build-buffer) + (notmuch-show-goto-first-wanted-message))) + +(defun notmuch-show-build-buffer () + (let ((inhibit-read-only t)) + (notmuch-show-mode) ;; Don't track undo information for this buffer (set 'buffer-undo-list t) - (setq notmuch-show-thread-id thread-id) - (setq notmuch-show-parent-buffer parent-buffer) - (setq notmuch-show-query-context query-context) - (setq notmuch-show-buffer-name buffer-name) - (setq notmuch-show-process-crypto process-crypto) - (erase-buffer) (goto-char (point-min)) (save-excursion - (let* ((basic-args (list thread-id)) - (args (if query-context - (append (list "\'") basic-args (list "and (" query-context ")\'")) - (append (list "\'") basic-args (list "\'"))))) - (notmuch-show-insert-forest (notmuch-query-get-threads args)) + (let* ((basic-args (list notmuch-show-thread-id)) + (args (if notmuch-show-query-context + (append (list "\'") basic-args + (list "and (" notmuch-show-query-context ")\'")) + (append (list "\'") basic-args (list "\'")))) + (cli-args (cons "--exclude=false" + (when notmuch-show-elide-non-matching-messages + (list "--entire-thread=false"))))) + + (notmuch-show-insert-forest (notmuch-query-get-threads (append cli-args args))) ;; If the query context reduced the results to nothing, run ;; the basic query. (when (and (eq (buffer-size) 0) - query-context) + notmuch-show-query-context) (notmuch-show-insert-forest - (notmuch-query-get-threads basic-args)))) + (notmuch-query-get-threads (append cli-args basic-args))))) (jit-lock-register #'notmuch-show-buttonise-links) - ;; Act on visual lines rather than logical lines. - (visual-line-mode t) - (run-hooks 'notmuch-show-hook)) - ;; Move straight to the first open message - (if (not (notmuch-show-message-visible-p)) - (notmuch-show-next-open-message)) + ;; Set the header line to the subject of the first message. + (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject))))) - ;; Set the header line to the subject of the first open message. - (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject))) +(defun notmuch-show-capture-state () + "Capture the state of the current buffer. - (notmuch-show-mark-read))) +This includes: + - the list of open messages, + - the current message." + (list (notmuch-show-get-message-id) (notmuch-show-get-message-ids-for-open-messages))) -(defun notmuch-show-refresh-view (&optional crypto-switch) - "Refresh the current view (with crypto switch if prefix given). +(defun notmuch-show-apply-state (state) + "Apply STATE to the current buffer. -Kills the current buffer and reruns notmuch show with the same -thread id. If a prefix is given, crypto processing is toggled." +This includes: + - opening the messages previously opened, + - closing all other messages, + - moving to the correct current message." + (let ((current (car state)) + (open (cadr state))) + + ;; Open those that were open. + (goto-char (point-min)) + (loop do (notmuch-show-message-visible (notmuch-show-get-message-properties) + (member (notmuch-show-get-message-id) open)) + until (not (notmuch-show-goto-message-next))) + + ;; Go to the previously open message. + (goto-char (point-min)) + (unless (loop if (string= current (notmuch-show-get-message-id)) + return t + until (not (notmuch-show-goto-message-next))) + (goto-char (point-min)) + (message "Previously current message not found.")) + (notmuch-show-message-adjust))) + +(defun notmuch-show-refresh-view (&optional reset-state) + "Refresh the current view. + +Refreshes the current view, observing changes in display +preferences. If invoked with a prefix argument (or RESET-STATE is +non-nil) then the state of the buffer (open/closed messages) is +reset based on the original query." (interactive "P") - (let ((thread-id notmuch-show-thread-id) - (parent-buffer notmuch-show-parent-buffer) - (query-context notmuch-show-query-context) - (buffer-name notmuch-show-buffer-name) - (process-crypto (if crypto-switch - (not notmuch-show-process-crypto) - notmuch-show-process-crypto))) - (notmuch-kill-this-buffer) - (notmuch-show-worker thread-id parent-buffer query-context buffer-name process-crypto))) + (let ((inhibit-read-only t) + (state (unless reset-state + (notmuch-show-capture-state)))) + (erase-buffer) + (notmuch-show-build-buffer) + (if state + (notmuch-show-apply-state state) + ;; We're resetting state, so navigate to the first open message + ;; and mark it read, just like opening a new show buffer. + (notmuch-show-goto-first-wanted-message)))) (defvar notmuch-show-stash-map (let ((map (make-sparse-keymap))) @@ -918,6 +1130,8 @@ thread id. If a prefix is given, crypto processing is toggled." (define-key map "s" 'notmuch-show-stash-subject) (define-key map "T" 'notmuch-show-stash-tags) (define-key map "t" 'notmuch-show-stash-to) + (define-key map "l" 'notmuch-show-stash-mlarchive-link) + (define-key map "L" 'notmuch-show-stash-mlarchive-link-and-go) map) "Submap for stash commands") (fset 'notmuch-show-stash-map notmuch-show-stash-map) @@ -933,7 +1147,8 @@ thread id. If a prefix is given, crypto processing is toggled." (define-key map "s" 'notmuch-search) (define-key map "m" 'notmuch-mua-new-mail) (define-key map "f" 'notmuch-show-forward-message) - (define-key map "r" 'notmuch-show-reply) + (define-key map "r" 'notmuch-show-reply-sender) + (define-key map "R" 'notmuch-show-reply) (define-key map "|" 'notmuch-show-pipe-message) (define-key map "w" 'notmuch-show-save-attachments) (define-key map "V" 'notmuch-show-view-raw-message) @@ -941,10 +1156,13 @@ thread id. If a prefix is given, crypto processing is toggled." (define-key map "c" 'notmuch-show-stash-map) (define-key map "=" 'notmuch-show-refresh-view) (define-key map "h" 'notmuch-show-toggle-headers) + (define-key map "*" 'notmuch-show-tag-all) (define-key map "-" 'notmuch-show-remove-tag) (define-key map "+" 'notmuch-show-add-tag) - (define-key map "x" 'notmuch-show-archive-thread-then-exit) - (define-key map "a" 'notmuch-show-archive-thread) + (define-key map "X" 'notmuch-show-archive-thread-then-exit) + (define-key map "x" 'notmuch-show-archive-message-then-next-or-exit) + (define-key map "A" 'notmuch-show-archive-thread-then-next) + (define-key map "a" 'notmuch-show-archive-message-then-next-or-next-thread) (define-key map "N" 'notmuch-show-next-message) (define-key map "P" 'notmuch-show-previous-message) (define-key map "n" 'notmuch-show-next-open-message) @@ -953,6 +1171,11 @@ thread id. If a prefix is given, crypto processing is toggled." (define-key map " " 'notmuch-show-advance-and-archive) (define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all) (define-key map (kbd "RET") 'notmuch-show-toggle-message) + (define-key map "#" 'notmuch-show-print-message) + (define-key map "!" 'notmuch-show-toggle-elide-non-matching) + (define-key map "$" 'notmuch-show-toggle-process-crypto) + (define-key map "<" 'notmuch-show-toggle-thread-indentation) + (define-key map "t" 'toggle-truncate-lines) map) "Keymap for \"notmuch show\" buffers.") (fset 'notmuch-show-mode-map notmuch-show-mode-map) @@ -990,7 +1213,8 @@ All currently available key bindings: (use-local-map notmuch-show-mode-map) (setq major-mode 'notmuch-show-mode mode-name "notmuch-show") - (setq buffer-read-only t)) + (setq buffer-read-only t + truncate-lines t)) (defun notmuch-show-move-to-message-top () (goto-char (notmuch-show-message-top))) @@ -1035,6 +1259,15 @@ All currently available key bindings: (notmuch-show-move-to-message-top) t)) +(defun notmuch-show-mapc (function) + "Iterate through all messages in the current thread with +`notmuch-show-goto-message-next' and call FUNCTION for side +effects." + (save-excursion + (goto-char (point-min)) + (loop do (funcall function) + while (notmuch-show-goto-message-next)))) + ;; Functions relating to the visibility of messages and their ;; components. @@ -1083,9 +1316,26 @@ Some useful entries are: (notmuch-show-get-message-properties)))) (plist-get props prop))) -(defun notmuch-show-get-message-id () - "Return the message id of the current message." - (concat "id:\"" (notmuch-show-get-prop :id) "\"")) +(defun notmuch-show-get-message-id (&optional bare) + "Return an id: query for the Message-Id of the current message. + +If optional argument BARE is non-nil, return +the Message-Id without id: prefix and escaping." + (if bare + (notmuch-show-get-prop :id) + (notmuch-id-to-query (notmuch-show-get-prop :id)))) + +(defun notmuch-show-get-messages-ids () + "Return all id: queries of messages in the current thread." + (let ((message-ids)) + (notmuch-show-mapc + (lambda () (push (notmuch-show-get-message-id) message-ids))) + message-ids)) + +(defun notmuch-show-get-messages-ids-search () + "Return a search string for all message ids of messages in the +current thread." + (mapconcat 'identity (notmuch-show-get-messages-ids) " or ")) ;; dme: Would it make sense to use a macro for many of these? @@ -1112,6 +1362,9 @@ Some useful entries are: (defun notmuch-show-get-to () (notmuch-show-get-header :To)) +(defun notmuch-show-get-depth () + (notmuch-show-get-prop :depth)) + (defun notmuch-show-set-tags (tags) "Set the tags of the current message." (notmuch-show-set-prop :tags tags) @@ -1131,13 +1384,13 @@ Some useful entries are: (defun notmuch-show-mark-read () "Mark the current message as read." - (notmuch-show-remove-tag "unread")) + (notmuch-show-tag-message "-unread")) ;; Functions for getting attributes of several messages in the current ;; thread. (defun notmuch-show-get-message-ids-for-open-messages () - "Return a list of all message IDs for open messages in the current thread." + "Return a list of all id: queries for open messages in the current thread." (save-excursion (let (message-ids done) (goto-char (point-min)) @@ -1181,6 +1434,11 @@ current window), advance to the next open message." ;; This is not the last message - move to the next visible one. (notmuch-show-next-open-message)) + ((not (= (point) (point-max))) + ;; This is the last message, but the cursor is not at the end of + ;; the buffer. Move it there. + (goto-char (point-max))) + (t ;; This is the last message - change the return value (setq ret t))) @@ -1199,7 +1457,7 @@ thread from the search from which this thread was originally shown." (interactive) (if (notmuch-show-advance) - (notmuch-show-archive-thread))) + (notmuch-show-archive-thread-then-next))) (defun notmuch-show-rewind () "Backup through the thread, (reverse scrolling compared to \\[notmuch-show-advance-and-archive]). @@ -1226,11 +1484,10 @@ any effects from previous calls to ;; If a small number of lines from the previous message are ;; visible, realign so that the top of the current message is at ;; the top of the screen. - (if (<= (count-screen-lines (window-start) start-of-message) - next-screen-context-lines) - (progn - (goto-char (notmuch-show-message-top)) - (notmuch-show-message-adjust))) + (when (<= (count-screen-lines (window-start) start-of-message) + next-screen-context-lines) + (goto-char (notmuch-show-message-top)) + (notmuch-show-message-adjust)) ;; Move to the top left of the window. (goto-char (window-start))) (t @@ -1238,9 +1495,14 @@ any effects from previous calls to (notmuch-show-previous-message))))) (defun notmuch-show-reply (&optional prompt-for-sender) - "Reply to the current message." + "Reply to the sender and all recipients of the current message." (interactive "P") - (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender)) + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender t)) + +(defun notmuch-show-reply-sender (&optional prompt-for-sender) + "Reply to the sender of the current message." + (interactive "P") + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender nil)) (defun notmuch-show-forward-message (&optional prompt-for-sender) "Forward the current message." @@ -1248,14 +1510,19 @@ any effects from previous calls to (with-current-notmuch-show-message (notmuch-mua-new-forward-message prompt-for-sender))) -(defun notmuch-show-next-message () - "Show the next message." - (interactive) +(defun notmuch-show-next-message (&optional pop-at-end) + "Show the next message. + +If a prefix argument is given and this is the last message in the +thread, navigate to the next thread in the parent search buffer." + (interactive "P") (if (notmuch-show-goto-message-next) (progn (notmuch-show-mark-read) (notmuch-show-message-adjust)) - (goto-char (point-max)))) + (if pop-at-end + (notmuch-show-next-thread) + (goto-char (point-max))))) (defun notmuch-show-previous-message () "Show the previous message." @@ -1264,9 +1531,14 @@ any effects from previous calls to (notmuch-show-mark-read) (notmuch-show-message-adjust)) -(defun notmuch-show-next-open-message () - "Show the next message." - (interactive) +(defun notmuch-show-next-open-message (&optional pop-at-end) + "Show the next open message. + +If a prefix argument is given and this is the last open message +in the thread, navigate to the next thread in the parent search +buffer. Return t if there was a next open message in the thread +to show, nil otherwise." + (interactive "P") (let (r) (while (and (setq r (notmuch-show-goto-message-next)) (not (notmuch-show-message-visible-p)))) @@ -1274,10 +1546,46 @@ any effects from previous calls to (progn (notmuch-show-mark-read) (notmuch-show-message-adjust)) + (if pop-at-end + (notmuch-show-next-thread) + (goto-char (point-max)))) + r)) + +(defun notmuch-show-next-matching-message () + "Show the next matching message." + (interactive) + (let (r) + (while (and (setq r (notmuch-show-goto-message-next)) + (not (notmuch-show-get-prop :match)))) + (if r + (progn + (notmuch-show-mark-read) + (notmuch-show-message-adjust)) (goto-char (point-max))))) +(defun notmuch-show-open-if-matched () + "Open a message if it is matched (whether or not excluded)." + (let ((props (notmuch-show-get-message-properties))) + (notmuch-show-message-visible props (plist-get props :match)))) + +(defun notmuch-show-goto-first-wanted-message () + "Move to the first open message and mark it read" + (goto-char (point-min)) + (if (notmuch-show-message-visible-p) + (notmuch-show-mark-read) + (notmuch-show-next-open-message)) + (when (eobp) + ;; There are no matched non-excluded messages so open all matched + ;; (necessarily excluded) messages and go to the first. + (notmuch-show-mapc 'notmuch-show-open-if-matched) + (force-window-update) + (goto-char (point-min)) + (if (notmuch-show-message-visible-p) + (notmuch-show-mark-read) + (notmuch-show-next-open-message)))) + (defun notmuch-show-previous-open-message () - "Show the previous message." + "Show the previous open message." (interactive) (while (and (notmuch-show-goto-message-previous) (not (notmuch-show-message-visible-p)))) @@ -1308,8 +1616,8 @@ than only the current message." (interactive "P\nsPipe message to command: ") (let (shell-command) (if entire-thread - (setq shell-command - (concat notmuch-command " show --format=mbox " + (setq shell-command + (concat notmuch-command " show --format=mbox --exclude=false " (shell-quote-argument (mapconcat 'identity (notmuch-show-get-message-ids-for-open-messages) " OR ")) " | " command)) @@ -1329,52 +1637,50 @@ than only the current message." (message (format "Command '%s' exited abnormally with code %d" shell-command exit-code)))))))) -(defun notmuch-show-add-tags-worker (current-tags add-tags) - "Add to `current-tags' with any tags from `add-tags' not -currently present and return the result." - (let ((result-tags (copy-sequence current-tags))) - (mapc (lambda (add-tag) - (unless (member add-tag current-tags) - (setq result-tags (push add-tag result-tags)))) - add-tags) - (sort result-tags 'string<))) - -(defun notmuch-show-del-tags-worker (current-tags del-tags) - "Remove any tags in `del-tags' from `current-tags' and return -the result." - (let ((result-tags (copy-sequence current-tags))) - (mapc (lambda (del-tag) - (setq result-tags (delete del-tag result-tags))) - del-tags) - result-tags)) - -(defun notmuch-show-add-tag (&rest toadd) - "Add a tag to the current message." - (interactive - (list (notmuch-select-tag-with-completion "Tag to add: "))) +(defun notmuch-show-tag-message (&rest tag-changes) + "Change tags for the current message. +TAG-CHANGES is a list of tag operations for `notmuch-tag'." (let* ((current-tags (notmuch-show-get-tags)) - (new-tags (notmuch-show-add-tags-worker current-tags toadd))) - + (new-tags (notmuch-update-tags current-tags tag-changes))) (unless (equal current-tags new-tags) - (apply 'notmuch-tag (notmuch-show-get-message-id) - (mapcar (lambda (s) (concat "+" s)) toadd)) + (funcall 'notmuch-tag (notmuch-show-get-message-id) tag-changes) (notmuch-show-set-tags new-tags)))) -(defun notmuch-show-remove-tag (&rest toremove) - "Remove a tag from the current message." - (interactive - (list (notmuch-select-tag-with-completion - "Tag to remove: " (notmuch-show-get-message-id)))) +(defun notmuch-show-tag (&optional tag-changes) + "Change tags for the current message. +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (setq tag-changes (funcall 'notmuch-tag (notmuch-show-get-message-id) tag-changes)) (let* ((current-tags (notmuch-show-get-tags)) - (new-tags (notmuch-show-del-tags-worker current-tags toremove))) - + (new-tags (notmuch-update-tags current-tags tag-changes))) (unless (equal current-tags new-tags) - (apply 'notmuch-tag (notmuch-show-get-message-id) - (mapcar (lambda (s) (concat "-" s)) toremove)) (notmuch-show-set-tags new-tags)))) +(defun notmuch-show-tag-all (&optional tag-changes) + "Change tags for all messages in the current show buffer. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (setq tag-changes (funcall 'notmuch-tag (notmuch-show-get-messages-ids-search) tag-changes)) + (notmuch-show-mapc + (lambda () + (let* ((current-tags (notmuch-show-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes))) + (unless (equal current-tags new-tags) + (notmuch-show-set-tags new-tags)))))) + +(defun notmuch-show-add-tag () + "Same as `notmuch-show-tag' but sets initial input to '+'." + (interactive) + (notmuch-show-tag "+")) + +(defun notmuch-show-remove-tag () + "Same as `notmuch-show-tag' but sets initial input to '-'." + (interactive) + (notmuch-show-tag "-")) + (defun notmuch-show-toggle-headers () "Toggle the visibility of the current message headers." (interactive) @@ -1415,39 +1721,73 @@ argument, hide all of the messages." (interactive) (backward-button 1)) -(defun notmuch-show-archive-thread-internal (show-next) - ;; Remove the tag from the current set of messages. - (goto-char (point-min)) - (loop do (notmuch-show-remove-tag "inbox") - until (not (notmuch-show-goto-message-next))) - ;; Move to the next item in the search results, if any. +(defun notmuch-show-next-thread (&optional show-next) + "Move to the next item in the search results, if any." + (interactive "P") (let ((parent-buffer notmuch-show-parent-buffer)) (notmuch-kill-this-buffer) - (if parent-buffer - (progn - (switch-to-buffer parent-buffer) - (forward-line) - (if show-next - (notmuch-search-show-thread)))))) + (when (buffer-live-p parent-buffer) + (switch-to-buffer parent-buffer) + (notmuch-search-next-thread) + (if show-next + (notmuch-search-show-thread))))) -(defun notmuch-show-archive-thread () - "Archive each message in thread, then show next thread from search. +(defun notmuch-show-archive-thread (&optional unarchive) + "Archive each message in thread. Archive each message currently shown by removing the \"inbox\" -tag from each. Then kill this buffer and show the next thread -from the search from which this thread was originally shown. +tag from each. If a prefix argument is given, the messages will +be \"unarchived\" (ie. the \"inbox\" tag will be added instead of +removed). Note: This command is safe from any race condition of new messages being delivered to the same thread. It does not archive the entire thread, but only the messages shown in the current buffer." + (interactive "P") + (let ((op (if unarchive "+" "-"))) + (notmuch-show-tag-all (concat op "inbox")))) + +(defun notmuch-show-archive-thread-then-next () + "Archive all messages in the current buffer, then show next thread from search." (interactive) - (notmuch-show-archive-thread-internal t)) + (notmuch-show-archive-thread) + (notmuch-show-next-thread t)) (defun notmuch-show-archive-thread-then-exit () - "Archive each message in thread, then exit back to search results." + "Archive all messages in the current buffer, then exit back to search results." + (interactive) + (notmuch-show-archive-thread) + (notmuch-show-next-thread)) + +(defun notmuch-show-archive-message (&optional unarchive) + "Archive the current message (remove \"inbox\" tag). + +If a prefix argument is given, the message will be +\"unarchived\" (ie. the \"inbox\" tag will be added instead of +removed)." + (interactive "P") + (let ((op (if unarchive "+" "-"))) + (notmuch-show-tag-message (concat op "inbox")))) + +(defun notmuch-show-archive-message-then-next-or-exit () + "Archive the current message, then show the next open message in the current thread. + +If at the last open message in the current thread, then exit back +to search results." (interactive) - (notmuch-show-archive-thread-internal nil)) + (notmuch-show-archive-message) + (notmuch-show-next-open-message t)) + +(defun notmuch-show-archive-message-then-next-or-next-thread () + "Archive the current message, then show the next open message in the current thread. + +If at the last open message in the current thread, then show next +thread from search." + (interactive) + (notmuch-show-archive-message) + (unless (notmuch-show-next-open-message) + (notmuch-show-next-thread t))) (defun notmuch-show-stash-cc () "Copy CC field of current message to kill-ring." @@ -1470,14 +1810,14 @@ buffer." (notmuch-common-do-stash (notmuch-show-get-from))) (defun notmuch-show-stash-message-id () - "Copy message ID of current message to kill-ring." + "Copy id: query matching the current message to kill-ring." (interactive) (notmuch-common-do-stash (notmuch-show-get-message-id))) (defun notmuch-show-stash-message-id-stripped () "Copy message ID of current message (sans `id:' prefix) to kill-ring." (interactive) - (notmuch-common-do-stash (substring (notmuch-show-get-message-id) 4 -1))) + (notmuch-common-do-stash (notmuch-show-get-message-id t))) (defun notmuch-show-stash-subject () "Copy Subject field of current message to kill-ring." @@ -1494,14 +1834,66 @@ buffer." (interactive) (notmuch-common-do-stash (notmuch-show-get-to))) +(defun notmuch-show-stash-mlarchive-link (&optional mla) + "Copy an ML Archive URI for the current message to the kill-ring. + +This presumes that the message is available at the selected Mailing List Archive. + +If optional argument MLA is non-nil, use the provided key instead of prompting +the user (see `notmuch-show-stash-mlarchive-link-alist')." + (interactive) + (notmuch-common-do-stash + (concat (cdr (assoc + (or mla + (let ((completion-ignore-case t)) + (completing-read + "Mailing List Archive: " + notmuch-show-stash-mlarchive-link-alist + nil t nil nil notmuch-show-stash-mlarchive-link-default))) + notmuch-show-stash-mlarchive-link-alist)) + (notmuch-show-get-message-id t)))) + +(defun notmuch-show-stash-mlarchive-link-and-go (&optional mla) + "Copy an ML Archive URI for the current message to the kill-ring and visit it. + +This presumes that the message is available at the selected Mailing List Archive. + +If optional argument MLA is non-nil, use the provided key instead of prompting +the user (see `notmuch-show-stash-mlarchive-link-alist')." + (interactive) + (notmuch-show-stash-mlarchive-link mla) + (browse-url (current-kill 0 t))) + ;; Commands typically bound to buttons. -(defun notmuch-show-part-button-action (button) - (let ((nth (button-get button :notmuch-part))) - (if nth - (notmuch-show-save-part (notmuch-show-get-message-id) nth - (button-get button :notmuch-filename)) - (message "Not a valid part (is it a fake part?).")))) +(defun notmuch-show-part-button-default (&optional button) + (interactive) + (notmuch-show-part-button-internal button notmuch-show-part-button-default-action)) + +(defun notmuch-show-part-button-save (&optional button) + (interactive) + (notmuch-show-part-button-internal button #'notmuch-show-save-part)) + +(defun notmuch-show-part-button-view (&optional button) + (interactive) + (notmuch-show-part-button-internal button #'notmuch-show-view-part)) + +(defun notmuch-show-part-button-interactively-view (&optional button) + (interactive) + (notmuch-show-part-button-internal button #'notmuch-show-interactively-view-part)) + +(defun notmuch-show-part-button-pipe (&optional button) + (interactive) + (notmuch-show-part-button-internal button #'notmuch-show-pipe-part)) + +(defun notmuch-show-part-button-internal (button handler) + (let ((button (or button (button-at (point))))) + (if button + (let ((nth (button-get button :notmuch-part))) + (if nth + (funcall handler (notmuch-show-get-message-id) nth + (button-get button :notmuch-filename) + (button-get button :notmuch-content-type))))))) ;; diff --git a/emacs/notmuch-tag.el b/emacs/notmuch-tag.el new file mode 100644 index 0000000..0c0fc87 --- /dev/null +++ b/emacs/notmuch-tag.el @@ -0,0 +1,145 @@ +;; notmuch-tag.el --- tag messages within emacs +;; +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see <http://www.gnu.org/licenses/>. +;; +;; Authors: Carl Worth <cworth@cworth.org> + +(eval-when-compile (require 'cl)) +(require 'crm) +(require 'notmuch-lib) + +(defcustom notmuch-before-tag-hook nil + "Hooks that are run before tags of a message are modified. + +'tags' will contain the tags that are about to be added or removed as +a list of strings of the form \"+TAG\" or \"-TAG\". +'query' will be a string containing the search query that determines +the messages that are about to be tagged" + + :type 'hook + :options '(notmuch-hl-line-mode) + :group 'notmuch-hooks) + +(defcustom notmuch-after-tag-hook nil + "Hooks that are run after tags of a message are modified. + +'tags' will contain the tags that were added or removed as +a list of strings of the form \"+TAG\" or \"-TAG\". +'query' will be a string containing the search query that determines +the messages that were tagged" + :type 'hook + :options '(notmuch-hl-line-mode) + :group 'notmuch-hooks) + +(defvar notmuch-select-tag-history nil + "Variable to store minibuffer history for +`notmuch-select-tag-with-completion' function.") + +(defvar notmuch-read-tag-changes-history nil + "Variable to store minibuffer history for +`notmuch-read-tag-changes' function.") + +(defun notmuch-tag-completions (&optional search-terms) + (if (null search-terms) + (setq search-terms (list "*"))) + (split-string + (with-output-to-string + (with-current-buffer standard-output + (apply 'call-process notmuch-command nil t + nil "search" "--output=tags" "--exclude=false" search-terms))) + "\n+" t)) + +(defun notmuch-select-tag-with-completion (prompt &rest search-terms) + (let ((tag-list (notmuch-tag-completions search-terms))) + (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history))) + +(defun notmuch-read-tag-changes (&optional initial-input &rest search-terms) + (let* ((all-tag-list (notmuch-tag-completions)) + (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list)) + (remove-tag-list (mapcar (apply-partially 'concat "-") + (if (null search-terms) + all-tag-list + (notmuch-tag-completions search-terms)))) + (tag-list (append add-tag-list remove-tag-list)) + (crm-separator " ") + ;; By default, space is bound to "complete word" function. + ;; Re-bind it to insert a space instead. Note that <tab> + ;; still does the completion. + (crm-local-completion-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map crm-local-completion-map) + (define-key map " " 'self-insert-command) + map))) + (delete "" (completing-read-multiple "Tags (+add -drop): " + tag-list nil nil initial-input + 'notmuch-read-tag-changes-history)))) + +(defun notmuch-update-tags (tags tag-changes) + "Return a copy of TAGS with additions and removals from TAG-CHANGES. + +TAG-CHANGES must be a list of tags names, each prefixed with +either a \"+\" to indicate the tag should be added to TAGS if not +present or a \"-\" to indicate that the tag should be removed +from TAGS if present." + (let ((result-tags (copy-sequence tags))) + (dolist (tag-change tag-changes) + (let ((op (string-to-char tag-change)) + (tag (unless (string= tag-change "") (substring tag-change 1)))) + (case op + (?+ (unless (member tag result-tags) + (push tag result-tags))) + (?- (setq result-tags (delete tag result-tags))) + (otherwise + (error "Changed tag must be of the form `+this_tag' or `-that_tag'"))))) + (sort result-tags 'string<))) + +(defun notmuch-tag (query &optional tag-changes) + "Add/remove tags in TAG-CHANGES to messages matching QUERY. + +QUERY should be a string containing the search-terms. +TAG-CHANGES can take multiple forms. If TAG-CHANGES is a list of +strings of the form \"+tag\" or \"-tag\" then those are the tag +changes applied. If TAG-CHANGES is a string then it is +interpreted as a single tag change. If TAG-CHANGES is the string +\"-\" or \"+\", or null, then the user is prompted to enter the +tag changes. + +Note: Other code should always use this function alter tags of +messages instead of running (notmuch-call-notmuch-process \"tag\" ..) +directly, so that hooks specified in notmuch-before-tag-hook and +notmuch-after-tag-hook will be run." + ;; Perform some validation + (if (string-or-null-p tag-changes) + (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes)) + (setq tag-changes (notmuch-read-tag-changes tag-changes query)) + (setq tag-changes (list tag-changes)))) + (mapc (lambda (tag-change) + (unless (string-match-p "^[-+]\\S-+$" tag-change) + (error "Tag must be of the form `+this_tag' or `-that_tag'"))) + tag-changes) + (unless (null tag-changes) + (run-hooks 'notmuch-before-tag-hook) + (apply 'notmuch-call-notmuch-process "tag" + (append tag-changes (list "--" query))) + (run-hooks 'notmuch-after-tag-hook)) + ;; in all cases we return tag-changes as a list + tag-changes) + +;; + +(provide 'notmuch-tag) diff --git a/emacs/notmuch-wash.el b/emacs/notmuch-wash.el index 5c1e830..7d003a2 100644 --- a/emacs/notmuch-wash.el +++ b/emacs/notmuch-wash.el @@ -87,6 +87,14 @@ If there is one more line than the sum of `notmuch-wash-citation-lines-suffix', show that, otherwise collapse the remaining lines into a button.") +(defvar notmuch-wash-wrap-lines-length nil + "Wrap line after at most this many characters. + +If this is nil, lines in messages will be wrapped to fit in the +current window. If this is a number, lines will be wrapped after +this many characters or at the window width (whichever one is +lower).") + (defun notmuch-wash-toggle-invisible-action (cite-button) (let ((invis-spec (button-get cite-button 'invisibility-spec))) (if (invisible-p invis-spec) @@ -136,12 +144,13 @@ collapse the remaining lines into a button.") (lines-count (count-lines (overlay-start overlay) (overlay-end overlay)))) (format label-format lines-count))) -(defun notmuch-wash-region-to-button (msg beg end type prefix) +(defun notmuch-wash-region-to-button (msg beg end type &optional prefix) "Auxiliary function to do the actual making of overlays and buttons BEG and END are buffer locations. TYPE should a string, either -\"citation\" or \"signature\". PREFIX is some arbitrary text to -insert before the button, probably for indentation." +\"citation\" or \"signature\". Optional PREFIX is some arbitrary +text to insert before the button, probably for indentation. Note +that PREFIX should not include a newline." ;; This uses some slightly tricky conversions between strings and ;; symbols because of the way the button code works. Note that @@ -160,12 +169,15 @@ insert before the button, probably for indentation." (overlay-put overlay 'type type) (goto-char (1+ end)) (save-excursion - (goto-char (1- beg)) - (insert prefix) - (insert-button (notmuch-wash-button-label overlay) + (goto-char beg) + (if prefix + (insert-before-markers prefix)) + (let ((button-beg (point))) + (insert-before-markers (notmuch-wash-button-label overlay) "\n") + (make-button button-beg (1- (point)) 'invisibility-spec invis-spec 'overlay overlay - :type button-type)))) + :type button-type))))) (defun notmuch-wash-excerpt-citations (msg depth) "Excerpt citations and up to one signature." @@ -177,7 +189,7 @@ insert before the button, probably for indentation." (msg-end (point-max)) (msg-lines (count-lines msg-start msg-end))) (notmuch-wash-region-to-button - msg msg-start msg-end "original" "\n"))) + msg msg-start msg-end "original"))) (while (and (< (point) (point-max)) (re-search-forward notmuch-wash-citation-regexp nil t)) (let* ((cite-start (match-beginning 0)) @@ -194,7 +206,7 @@ insert before the button, probably for indentation." (forward-line (- notmuch-wash-citation-lines-suffix)) (notmuch-wash-region-to-button msg hidden-start (point-marker) - "citation" "\n"))))) + "citation"))))) (if (and (not (eobp)) (re-search-forward notmuch-wash-signature-regexp nil t)) (let* ((sig-start (match-beginning 0)) @@ -208,7 +220,7 @@ insert before the button, probably for indentation." (overlay-put (make-overlay sig-start-marker sig-end-marker) 'face 'message-cited-text) (notmuch-wash-region-to-button msg sig-start-marker sig-end-marker - "signature" "\n")))))) + "signature")))))) ;; @@ -272,16 +284,24 @@ Perform several transformations on the message body: ;; (defun notmuch-wash-wrap-long-lines (msg depth) - "Wrap any long lines in the message to the width of the window. - -When doing so, maintaining citation leaders in the wrapped text." - - (let ((coolj-wrap-follows-window-size nil) - (fill-column (- (window-width) - depth - ;; 2 to avoid poor interaction with - ;; `word-wrap'. - 2))) + "Wrap long lines in the message. + +If `notmuch-wash-wrap-lines-length' is a number, this will wrap +the message lines to the minimum of the width of the window or +its value. Otherwise, this function will wrap long lines in the +message at the window width. When doing so, citation leaders in +the wrapped text are maintained." + + (let* ((coolj-wrap-follows-window-size nil) + (limit (if (numberp notmuch-wash-wrap-lines-length) + (min notmuch-wash-wrap-lines-length + (window-width)) + (window-width))) + (fill-column (- limit + depth + ;; 2 to avoid poor interaction with + ;; `word-wrap'. + 2))) (coolj-wrap-region (point-min) (point-max)))) ;; @@ -336,30 +356,29 @@ patch and then guesses the extent of the patch, there is scope for error." (goto-char (point-min)) - (if (re-search-forward diff-file-header-re nil t) - (progn - (beginning-of-line -1) - (let ((patch-start (point)) - (patch-end (point-max)) - part) - (goto-char patch-start) - (if (or - ;; Patch ends with signature. - (re-search-forward notmuch-wash-signature-regexp nil t) - ;; Patch ends with bugtraq comment. - (re-search-forward "^\\*\\*\\* " nil t)) - (setq patch-end (match-beginning 0))) - (save-restriction - (narrow-to-region patch-start patch-end) - (setq part (plist-put part :content-type "inline-patch-fake-part")) - (setq part (plist-put part :content (buffer-string))) - (setq part (plist-put part :id -1)) - (setq part (plist-put part :filename - (notmuch-wash-subject-to-patch-filename - (plist-get - (plist-get msg :headers) :Subject)))) - (delete-region (point-min) (point-max)) - (notmuch-show-insert-bodypart nil part depth)))))) + (when (re-search-forward diff-file-header-re nil t) + (beginning-of-line -1) + (let ((patch-start (point)) + (patch-end (point-max)) + part) + (goto-char patch-start) + (if (or + ;; Patch ends with signature. + (re-search-forward notmuch-wash-signature-regexp nil t) + ;; Patch ends with bugtraq comment. + (re-search-forward "^\\*\\*\\* " nil t)) + (setq patch-end (match-beginning 0))) + (save-restriction + (narrow-to-region patch-start patch-end) + (setq part (plist-put part :content-type "inline-patch-fake-part")) + (setq part (plist-put part :content (buffer-string))) + (setq part (plist-put part :id -1)) + (setq part (plist-put part :filename + (notmuch-wash-subject-to-patch-filename + (plist-get + (plist-get msg :headers) :Subject)))) + (delete-region (point-min) (point-max)) + (notmuch-show-insert-bodypart nil part depth))))) ;; diff --git a/emacs/notmuch.el b/emacs/notmuch.el index 1e61775..d2d82a9 100644 --- a/emacs/notmuch.el +++ b/emacs/notmuch.el @@ -1,57 +1,58 @@ -; notmuch.el --- run notmuch within emacs -; -; Copyright © Carl Worth -; -; This file is part of Notmuch. -; -; Notmuch is free software: you can redistribute it and/or modify it -; under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 3 of the License, or -; (at your option) any later version. -; -; Notmuch is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; You should have received a copy of the GNU General Public License -; along with Notmuch. If not, see <http://www.gnu.org/licenses/>. -; -; Authors: Carl Worth <cworth@cworth.org> - -; This is an emacs-based interface to the notmuch mail system. -; -; You will first need to have the notmuch program installed and have a -; notmuch database built in order to use this. See -; http://notmuchmail.org for details. -; -; To install this software, copy it to a directory that is on the -; `load-path' variable within emacs (a good candidate is -; /usr/local/share/emacs/site-lisp). If you are viewing this from the -; notmuch source distribution then you can simply run: -; -; sudo make install-emacs -; -; to install it. -; -; Then, to actually run it, add: -; -; (require 'notmuch) -; -; to your ~/.emacs file, and then run "M-x notmuch" from within emacs, -; or run: -; -; emacs -f notmuch -; -; Have fun, and let us know if you have any comment, questions, or -; kudos: Notmuch list <notmuch@notmuchmail.org> (subscription is not -; required, but is available from http://notmuchmail.org). +;; notmuch.el --- run notmuch within emacs +;; +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see <http://www.gnu.org/licenses/>. +;; +;; Authors: Carl Worth <cworth@cworth.org> + +;; This is an emacs-based interface to the notmuch mail system. +;; +;; You will first need to have the notmuch program installed and have a +;; notmuch database built in order to use this. See +;; http://notmuchmail.org for details. +;; +;; To install this software, copy it to a directory that is on the +;; `load-path' variable within emacs (a good candidate is +;; /usr/local/share/emacs/site-lisp). If you are viewing this from the +;; notmuch source distribution then you can simply run: +;; +;; sudo make install-emacs +;; +;; to install it. +;; +;; Then, to actually run it, add: +;; +;; (require 'notmuch) +;; +;; to your ~/.emacs file, and then run "M-x notmuch" from within emacs, +;; or run: +;; +;; emacs -f notmuch +;; +;; Have fun, and let us know if you have any comment, questions, or +;; kudos: Notmuch list <notmuch@notmuchmail.org> (subscription is not +;; required, but is available from http://notmuchmail.org). (eval-when-compile (require 'cl)) (require 'mm-view) (require 'message) (require 'notmuch-lib) +(require 'notmuch-tag) (require 'notmuch-show) (require 'notmuch-mua) (require 'notmuch-hello) @@ -59,7 +60,7 @@ (require 'notmuch-message) (defcustom notmuch-search-result-format - `(("date" . "%s ") + `(("date" . "%12s ") ("count" . "%-7s ") ("authors" . "%-20s ") ("subject" . "%s ") @@ -68,20 +69,19 @@ date, count, authors, subject, tags For example: (setq notmuch-search-result-format \(\(\"authors\" . \"%-40s\"\) - \(\"subject\" . \"%s\"\)\)\)" + \(\"subject\" . \"%s\"\)\)\) +Line breaks are permitted in format strings (though this is +currently experimental). Note that a line break at the end of an +\"authors\" field will get elided if the authors list is long; +place it instead at the beginning of the following field. To +enter a line break when setting this variable with setq, use \\n. +To enter a line break in customize, press \\[quoted-insert] C-j." :type '(alist :key-type (string) :value-type (string)) - :group 'notmuch) + :group 'notmuch-search) (defvar notmuch-query-history nil "Variable to store minibuffer history for notmuch queries") -(defun notmuch-select-tag-with-completion (prompt &rest search-terms) - (let ((tag-list - (with-output-to-string - (with-current-buffer standard-output - (apply 'call-process notmuch-command nil t nil "search-tags" search-terms))))) - (completing-read prompt (split-string tag-list "\n+" t) nil nil nil))) - (defun notmuch-foreach-mime-part (function mm-handle) (cond ((stringp (car mm-handle)) (dolist (part (cdr mm-handle)) @@ -139,10 +139,10 @@ This is basically just `format-kbd-macro' but we also convert ESC to M-." "M-" (concat desc " ")))) -; I would think that emacs would have code handy for walking a keymap -; and generating strings for each key, and I would prefer to just call -; that. But I couldn't find any (could be all implemented in C I -; suppose), so I wrote my own here. +;; I would think that emacs would have code handy for walking a keymap +;; and generating strings for each key, and I would prefer to just call +;; that. But I couldn't find any (could be all implemented in C I +;; suppose), so I wrote my own here. (defun notmuch-substitute-one-command-key-with-prefix (prefix binding) "For a key binding, return a string showing a human-readable representation of the prefixed key as well as the first line of @@ -195,11 +195,19 @@ For a mouse binding, return nil." (set-buffer-modified-p nil) (view-buffer (current-buffer) 'kill-buffer-if-not-modified)))) -(defcustom notmuch-search-hook '(hl-line-mode) +(require 'hl-line) + +(defun notmuch-hl-line-mode () + (prog1 (hl-line-mode) + (when hl-line-overlay + (overlay-put hl-line-overlay 'priority 1)))) + +(defcustom notmuch-search-hook '(notmuch-hl-line-mode) "List of functions to call when notmuch displays the search results." :type 'hook - :options '(hl-line-mode) - :group 'notmuch) + :options '(notmuch-hl-line-mode) + :group 'notmuch-search + :group 'notmuch-hooks) (defvar notmuch-search-mode-map (let ((map (make-sparse-keymap))) @@ -213,7 +221,8 @@ For a mouse binding, return nil." (define-key map ">" 'notmuch-search-last-thread) (define-key map "p" 'notmuch-search-previous-thread) (define-key map "n" 'notmuch-search-next-thread) - (define-key map "r" 'notmuch-search-reply-to-thread) + (define-key map "r" 'notmuch-search-reply-to-thread-sender) + (define-key map "R" 'notmuch-search-reply-to-thread) (define-key map "m" 'notmuch-mua-new-mail) (define-key map "s" 'notmuch-search) (define-key map "o" 'notmuch-search-toggle-order) @@ -223,7 +232,7 @@ For a mouse binding, return nil." (define-key map "t" 'notmuch-search-filter-by-tag) (define-key map "f" 'notmuch-search-filter) (define-key map [mouse-1] 'notmuch-search-show-thread) - (define-key map "*" 'notmuch-search-operate-all) + (define-key map "*" 'notmuch-search-tag-all) (define-key map "a" 'notmuch-search-archive-thread) (define-key map "-" 'notmuch-search-remove-tag) (define-key map "+" 'notmuch-search-add-tag) @@ -269,14 +278,14 @@ For a mouse binding, return nil." (defun notmuch-search-scroll-down () "Move backward through the search results by one window's worth." (interactive) - ; I don't know why scroll-down doesn't signal beginning-of-buffer - ; the way that scroll-up signals end-of-buffer, but c'est la vie. - ; - ; So instead of trapping a signal we instead check whether the - ; window begins on the first line of the buffer and if so, move - ; directly to that position. (We have to count lines since the - ; window-start position is not the same as point-min due to the - ; invisible thread-ID characters on the first line. + ;; I don't know why scroll-down doesn't signal beginning-of-buffer + ;; the way that scroll-up signals end-of-buffer, but c'est la vie. + ;; + ;; So instead of trapping a signal we instead check whether the + ;; window begins on the first line of the buffer and if so, move + ;; directly to that position. (We have to count lines since the + ;; window-start position is not the same as point-min due to the + ;; invisible thread-ID characters on the first line. (if (equal (count-lines (point-min) (window-start)) 0) (goto-char (point-min)) (scroll-down nil))) @@ -284,18 +293,25 @@ For a mouse binding, return nil." (defun notmuch-search-next-thread () "Select the next thread in the search results." (interactive) - (forward-line 1)) + (when (notmuch-search-get-result) + (goto-char (notmuch-search-result-end)))) (defun notmuch-search-previous-thread () "Select the previous thread in the search results." (interactive) - (forward-line -1)) + (if (notmuch-search-get-result) + (unless (bobp) + (goto-char (notmuch-search-result-beginning (- (point) 1)))) + ;; We must be past the end; jump to the last result + (notmuch-search-last-thread))) (defun notmuch-search-last-thread () "Select the last thread in the search results." (interactive) (goto-char (point-max)) - (forward-line -2)) + (forward-line -2) + (let ((beg (notmuch-search-result-beginning))) + (when beg (goto-char beg)))) (defun notmuch-search-first-thread () "Select the first thread in the search results." @@ -306,27 +322,32 @@ For a mouse binding, return nil." '((((class color) (background light)) (:background "#f0f0f0")) (((class color) (background dark)) (:background "#303030"))) "Face for the single-line message summary in notmuch-show-mode." - :group 'notmuch) + :group 'notmuch-show + :group 'notmuch-faces) (defface notmuch-search-date '((t :inherit default)) "Face used in search mode for dates." - :group 'notmuch) + :group 'notmuch-search + :group 'notmuch-faces) (defface notmuch-search-count '((t :inherit default)) "Face used in search mode for the count matching the query." - :group 'notmuch) + :group 'notmuch-search + :group 'notmuch-faces) (defface notmuch-search-subject '((t :inherit default)) "Face used in search mode for subjects." - :group 'notmuch) + :group 'notmuch-search + :group 'notmuch-faces) (defface notmuch-search-matching-authors '((t :inherit default)) "Face used in search mode for authors matching the query." - :group 'notmuch) + :group 'notmuch-search + :group 'notmuch-faces) (defface notmuch-search-non-matching-authors '((((class color) @@ -338,7 +359,8 @@ For a mouse binding, return nil." (t (:italic t))) "Face used in search mode for authors not matching the query." - :group 'notmuch) + :group 'notmuch-search + :group 'notmuch-faces) (defface notmuch-tag-face '((((class color) @@ -350,7 +372,8 @@ For a mouse binding, return nil." (t (:bold t))) "Face used in search mode face for tags." - :group 'notmuch) + :group 'notmuch-search + :group 'notmuch-faces) (defun notmuch-search-mode () "Major mode displaying results of a notmuch search. @@ -365,7 +388,7 @@ any tags). Pressing \\[notmuch-search-show-thread] on any line displays that thread. The '\\[notmuch-search-add-tag]' and '\\[notmuch-search-remove-tag]' keys can be used to add or remove tags from a thread. The '\\[notmuch-search-archive-thread]' key is a convenience for archiving a thread (removing the \"inbox\" -tag). The '\\[notmuch-search-operate-all]' key can be used to add or remove a tag from all +tag). The '\\[notmuch-search-tag-all]' key can be used to add or remove a tag from all threads in the current buffer. Other useful commands are '\\[notmuch-search-filter]' for filtering the current search @@ -391,67 +414,121 @@ Complete list of currently available key bindings: mode-name "notmuch-search") (setq buffer-read-only t)) +(defun notmuch-search-get-result (&optional pos) + "Return the result object for the thread at POS (or point). + +If there is no thread at POS (or point), returns nil." + (get-text-property (or pos (point)) 'notmuch-search-result)) + +(defun notmuch-search-result-beginning (&optional pos) + "Return the point at the beginning of the thread at POS (or point). + +If there is no thread at POS (or point), returns nil." + (when (notmuch-search-get-result pos) + ;; We pass 1+point because previous-single-property-change starts + ;; searching one before the position we give it. + (previous-single-property-change (1+ (or pos (point))) + 'notmuch-search-result nil (point-min)))) + +(defun notmuch-search-result-end (&optional pos) + "Return the point at the end of the thread at POS (or point). + +The returned point will be just after the newline character that +ends the result line. If there is no thread at POS (or point), +returns nil" + (when (notmuch-search-get-result pos) + (next-single-property-change (or pos (point)) 'notmuch-search-result + nil (point-max)))) + +(defun notmuch-search-foreach-result (beg end function) + "Invoke FUNCTION for each result between BEG and END. + +FUNCTION should take one argument. It will be applied to the +character position of the beginning of each result that overlaps +the region between points BEG and END. As a special case, if (= +BEG END), FUNCTION will be applied to the result containing point +BEG." + + (lexical-let ((pos (notmuch-search-result-beginning beg)) + ;; End must be a marker in case function changes the + ;; text. + (end (copy-marker end)) + ;; Make sure we examine at least one result, even if + ;; (= beg end). + (first t)) + ;; We have to be careful if the region extends beyond the results. + ;; In this case, pos could be null or there could be no result at + ;; pos. + (while (and pos (or (< pos end) first)) + (when (notmuch-search-get-result pos) + (funcall function pos)) + (setq pos (notmuch-search-result-end pos) + first nil)))) +;; Unindent the function argument of notmuch-search-foreach-result so +;; the indentation of callers doesn't get out of hand. +(put 'notmuch-search-foreach-result 'lisp-indent-function 2) + (defun notmuch-search-properties-in-region (property beg end) - (save-excursion - (let ((output nil) - (last-line (line-number-at-pos end)) - (max-line (- (line-number-at-pos (point-max)) 2))) - (goto-char beg) - (beginning-of-line) - (while (<= (line-number-at-pos) (min last-line max-line)) - (setq output (cons (get-text-property (point) property) output)) - (forward-line 1)) - output))) + (let (output) + (notmuch-search-foreach-result beg end + (lambda (pos) + (push (plist-get (notmuch-search-get-result pos) property) output))) + output)) (defun notmuch-search-find-thread-id () "Return the thread for the current thread" - (get-text-property (point) 'notmuch-search-thread-id)) + (let ((thread (plist-get (notmuch-search-get-result) :thread))) + (when thread (concat "thread:" thread)))) (defun notmuch-search-find-thread-id-region (beg end) "Return a list of threads for the current region" - (notmuch-search-properties-in-region 'notmuch-search-thread-id beg end)) + (mapcar (lambda (thread) (concat "thread:" thread)) + (notmuch-search-properties-in-region :thread beg end))) + +(defun notmuch-search-find-thread-id-region-search (beg end) + "Return a search string for threads for the current region" + (mapconcat 'identity (notmuch-search-find-thread-id-region beg end) " or ")) (defun notmuch-search-find-authors () "Return the authors for the current thread" - (get-text-property (point) 'notmuch-search-authors)) + (plist-get (notmuch-search-get-result) :authors)) (defun notmuch-search-find-authors-region (beg end) "Return a list of authors for the current region" - (notmuch-search-properties-in-region 'notmuch-search-authors beg end)) + (notmuch-search-properties-in-region :authors beg end)) (defun notmuch-search-find-subject () "Return the subject for the current thread" - (get-text-property (point) 'notmuch-search-subject)) + (plist-get (notmuch-search-get-result) :subject)) (defun notmuch-search-find-subject-region (beg end) "Return a list of authors for the current region" - (notmuch-search-properties-in-region 'notmuch-search-subject beg end)) + (notmuch-search-properties-in-region :subject beg end)) -(defun notmuch-search-show-thread (&optional crypto-switch) +(defun notmuch-search-show-thread () "Display the currently selected thread." - (interactive "P") + (interactive) (let ((thread-id (notmuch-search-find-thread-id)) (subject (notmuch-search-find-subject))) (if (> (length thread-id) 0) (notmuch-show thread-id (current-buffer) notmuch-search-query-string - ;; name the buffer based on notmuch-search-find-subject - (if (string-match "^[ \t]*$" subject) - "[No Subject]" - (truncate-string-to-width - (concat "*" - (truncate-string-to-width subject 32 nil nil t) - "*") - 32 nil nil t)) - crypto-switch) + ;; Name the buffer based on the subject. + (concat "*" (truncate-string-to-width subject 30 nil nil t) "*")) (message "End of search results.")))) (defun notmuch-search-reply-to-thread (&optional prompt-for-sender) + "Begin composing a reply-all to the entire current thread in a new buffer." + (interactive "P") + (let ((message-id (notmuch-search-find-thread-id))) + (notmuch-mua-new-reply message-id prompt-for-sender t))) + +(defun notmuch-search-reply-to-thread-sender (&optional prompt-for-sender) "Begin composing a reply to the entire current thread in a new buffer." (interactive "P") (let ((message-id (notmuch-search-find-thread-id))) - (notmuch-mua-new-reply message-id prompt-for-sender))) + (notmuch-mua-new-reply message-id prompt-for-sender nil))) (defun notmuch-call-notmuch-process (&rest args) "Synchronously invoke \"notmuch\" with the given list of arguments. @@ -470,151 +547,84 @@ and will also appear in a buffer named \"*Notmuch errors*\"." (error (buffer-substring beg end)) )))))) -(defun notmuch-tag (query &rest tags) - "Add/remove tags in TAGS to messages matching QUERY. - -TAGS should be a list of strings of the form \"+TAG\" or \"-TAG\" and -QUERY should be a string containing the search-query. +(defun notmuch-search-set-tags (tags &optional pos) + (let ((new-result (plist-put (notmuch-search-get-result pos) :tags tags))) + (notmuch-search-update-result new-result pos))) -Note: Other code should always use this function alter tags of -messages instead of running (notmuch-call-notmuch-process \"tag\" ..) -directly, so that hooks specified in notmuch-before-tag-hook and -notmuch-after-tag-hook will be run." - (run-hooks 'notmuch-before-tag-hook) - (apply 'notmuch-call-notmuch-process - (append (list "tag") tags (list "--" query))) - (run-hooks 'notmuch-after-tag-hook)) - -(defcustom notmuch-before-tag-hook nil - "Hooks that are run before tags of a message are modified. - -'tags' will contain the tags that are about to be added or removed as -a list of strings of the form \"+TAG\" or \"-TAG\". -'query' will be a string containing the search query that determines -the messages that are about to be tagged" - - :type 'hook - :options '(hl-line-mode) - :group 'notmuch) - -(defcustom notmuch-after-tag-hook nil - "Hooks that are run after tags of a message are modified. - -'tags' will contain the tags that were added or removed as -a list of strings of the form \"+TAG\" or \"-TAG\". -'query' will be a string containing the search query that determines -the messages that were tagged" - :type 'hook - :options '(hl-line-mode) - :group 'notmuch) - -(defun notmuch-search-set-tags (tags) - (save-excursion - (end-of-line) - (re-search-backward "(") - (forward-char) - (let ((beg (point)) - (inhibit-read-only t)) - (re-search-forward ")") - (backward-char) - (let ((end (point))) - (delete-region beg end) - (insert (propertize (mapconcat 'identity tags " ") - 'face 'notmuch-tag-face)))))) - -(defun notmuch-search-get-tags () - (save-excursion - (end-of-line) - (re-search-backward "(") - (let ((beg (+ (point) 1))) - (re-search-forward ")") - (let ((end (- (point) 1))) - (split-string (buffer-substring beg end)))))) +(defun notmuch-search-get-tags (&optional pos) + (plist-get (notmuch-search-get-result pos) :tags)) (defun notmuch-search-get-tags-region (beg end) - (save-excursion - (let ((output nil) - (last-line (line-number-at-pos end)) - (max-line (- (line-number-at-pos (point-max)) 2))) - (goto-char beg) - (while (<= (line-number-at-pos) (min last-line max-line)) - (setq output (append output (notmuch-search-get-tags))) - (forward-line 1)) - output))) - -(defun notmuch-search-add-tag-thread (tag) - (notmuch-search-add-tag-region tag (point) (point))) - -(defun notmuch-search-add-tag-region (tag beg end) - (let ((search-id-string (mapconcat 'identity (notmuch-search-find-thread-id-region beg end) " or "))) - (notmuch-tag search-id-string (concat "+" tag)) - (save-excursion - (let ((last-line (line-number-at-pos end)) - (max-line (- (line-number-at-pos (point-max)) 2))) - (goto-char beg) - (while (<= (line-number-at-pos) (min last-line max-line)) - (notmuch-search-set-tags (delete-dups (sort (cons tag (notmuch-search-get-tags)) 'string<))) - (forward-line)))))) - -(defun notmuch-search-remove-tag-thread (tag) - (notmuch-search-remove-tag-region tag (point) (point))) - -(defun notmuch-search-remove-tag-region (tag beg end) - (let ((search-id-string (mapconcat 'identity (notmuch-search-find-thread-id-region beg end) " or "))) - (notmuch-tag search-id-string (concat "-" tag)) - (save-excursion - (let ((last-line (line-number-at-pos end)) - (max-line (- (line-number-at-pos (point-max)) 2))) - (goto-char beg) - (while (<= (line-number-at-pos) (min last-line max-line)) - (notmuch-search-set-tags (delete tag (notmuch-search-get-tags))) - (forward-line)))))) - -(defun notmuch-search-add-tag (tag) - "Add a tag to the currently selected thread or region. - -The tag is added to all messages in the currently selected thread -or threads in the current region." - (interactive - (list (notmuch-select-tag-with-completion "Tag to add: "))) - (save-excursion - (if (region-active-p) - (let* ((beg (region-beginning)) - (end (region-end))) - (notmuch-search-add-tag-region tag beg end)) - (notmuch-search-add-tag-thread tag)))) + (let (output) + (notmuch-search-foreach-result beg end + (lambda (pos) + (setq output (append output (notmuch-search-get-tags pos))))) + output)) + +(defun notmuch-search-tag-region (beg end &optional tag-changes) + "Change tags for threads in the given region." + (let ((search-string (notmuch-search-find-thread-id-region-search beg end))) + (setq tag-changes (funcall 'notmuch-tag search-string tag-changes)) + (notmuch-search-foreach-result beg end + (lambda (pos) + (notmuch-search-set-tags + (notmuch-update-tags (notmuch-search-get-tags pos) tag-changes) + pos))))) + +(defun notmuch-search-tag (&optional tag-changes) + "Change tags for the currently selected thread or region. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (let* ((beg (if (region-active-p) (region-beginning) (point))) + (end (if (region-active-p) (region-end) (point)))) + (funcall 'notmuch-search-tag-region beg end tag-changes))) -(defun notmuch-search-remove-tag (tag) - "Remove a tag from the currently selected thread or region. +(defun notmuch-search-add-tag () + "Same as `notmuch-search-tag' but sets initial input to '+'." + (interactive) + (notmuch-search-tag "+")) -The tag is removed from all messages in the currently selected -thread or threads in the current region." - (interactive - (list (notmuch-select-tag-with-completion - "Tag to remove: " - (if (region-active-p) - (mapconcat 'identity - (notmuch-search-find-thread-id-region (region-beginning) (region-end)) - " ") - (notmuch-search-find-thread-id))))) - (save-excursion - (if (region-active-p) - (let* ((beg (region-beginning)) - (end (region-end))) - (notmuch-search-remove-tag-region tag beg end)) - (notmuch-search-remove-tag-thread tag)))) +(defun notmuch-search-remove-tag () + "Same as `notmuch-search-tag' but sets initial input to '-'." + (interactive) + (notmuch-search-tag "-")) (defun notmuch-search-archive-thread () "Archive the currently selected thread (remove its \"inbox\" tag). This function advances the next thread when finished." (interactive) - (notmuch-search-remove-tag-thread "inbox") - (forward-line)) - -(defvar notmuch-search-process-filter-data nil - "Data that has not yet been processed.") -(make-variable-buffer-local 'notmuch-search-process-filter-data) + (notmuch-search-tag '("-inbox")) + (notmuch-search-next-thread)) + +(defun notmuch-search-update-result (result &optional pos) + "Replace the result object of the thread at POS (or point) by +RESULT and redraw it. + +This will keep point in a reasonable location. However, if there +are enclosing save-excursions and the saved point is in the +result being updated, the point will be restored to the beginning +of the result." + (let ((start (notmuch-search-result-beginning pos)) + (end (notmuch-search-result-end pos)) + (init-point (point)) + (inhibit-read-only t)) + ;; Delete the current thread + (delete-region start end) + ;; Insert the updated thread + (notmuch-search-show-result result start) + ;; If point was inside the old result, make an educated guess + ;; about where to place it now. Unfortunately, this won't work + ;; with save-excursion (or any other markers that would be nice to + ;; preserve, such as the window start), but there's nothing we can + ;; do about that without a way to retrieve markers in a region. + (when (and (>= init-point start) (<= init-point end)) + (let* ((new-end (notmuch-search-result-end start)) + (new-point (if (= init-point end) + new-end + (min init-point (- new-end 1))))) + (goto-char new-point))))) (defun notmuch-search-process-sentinel (proc msg) "Add a message to let user know when \"notmuch search\" exits" @@ -622,7 +632,8 @@ This function advances the next thread when finished." (status (process-status proc)) (exit-status (process-exit-status proc)) (never-found-target-thread nil)) - (if (memq status '(exit signal)) + (when (memq status '(exit signal)) + (kill-buffer (process-get proc 'parse-buf)) (if (buffer-live-p buffer) (with-current-buffer buffer (save-excursion @@ -631,55 +642,47 @@ This function advances the next thread when finished." (goto-char (point-max)) (if (eq status 'signal) (insert "Incomplete search results (search process was killed).\n")) - (if (eq status 'exit) - (progn - (if notmuch-search-process-filter-data - (insert (concat "Error: Unexpected output from notmuch search:\n" notmuch-search-process-filter-data))) - (insert "End of search results.") - (if (not (= exit-status 0)) - (insert (format " (process returned %d)" exit-status))) - (insert "\n") - (if (and atbob - (not (string= notmuch-search-target-thread "found"))) - (set 'never-found-target-thread t)))))) + (when (eq status 'exit) + (insert "End of search results.") + (unless (= exit-status 0) + (insert (format " (process returned %d)" exit-status))) + (insert "\n") + (if (and atbob + (not (string= notmuch-search-target-thread "found"))) + (set 'never-found-target-thread t))))) (when (and never-found-target-thread notmuch-search-target-line) (goto-char (point-min)) (forward-line (1- notmuch-search-target-line)))))))) -(defcustom notmuch-search-line-faces nil +(defcustom notmuch-search-line-faces '(("unread" :weight bold) + ("flagged" :foreground "blue")) "Tag/face mapping for line highlighting in notmuch-search. Here is an example of how to color search results based on tags. (the following text would be placed in your ~/.emacs file): - (setq notmuch-search-line-faces '((\"delete\" . (:foreground \"red\" + (setq notmuch-search-line-faces '((\"deleted\" . (:foreground \"red\" :background \"blue\")) (\"unread\" . (:foreground \"green\")))) The attributes defined for matching tags are merged, with later -attributes overriding earlier. A message having both \"delete\" +attributes overriding earlier. A message having both \"deleted\" and \"unread\" tags with the above settings would have a green foreground and blue background." :type '(alist :key-type (string) :value-type (custom-face-edit)) - :group 'notmuch) + :group 'notmuch-search + :group 'notmuch-faces) (defun notmuch-search-color-line (start end line-tag-list) "Colorize lines in `notmuch-show' based on tags." - ;; Create the overlay only if the message has tags which match one - ;; of those specified in `notmuch-search-line-faces'. - (let (overlay) - (mapc (lambda (elem) - (let ((tag (car elem)) - (attributes (cdr elem))) - (when (member tag line-tag-list) - (when (not overlay) - (setq overlay (make-overlay start end))) - ;; Merge the specified properties with any already - ;; applied from an earlier match. - (overlay-put overlay 'face - (append (overlay-get overlay 'face) attributes))))) - notmuch-search-line-faces))) + (mapc (lambda (elem) + (let ((tag (car elem)) + (attributes (cdr elem))) + (when (member tag line-tag-list) + (notmuch-combine-face-text-property start end attributes)))) + ;; Reverse the list so earlier entries take precedence + (reverse notmuch-search-line-faces))) (defun notmuch-search-author-propertize (authors) "Split `authors' into matching and non-matching authors and @@ -761,99 +764,111 @@ non-authors is found, assume that all of the authors match." (overlay-put overlay 'isearch-open-invisible #'delete-overlay))) (insert padding)))) -(defun notmuch-search-insert-field (field date count authors subject tags) +(defun notmuch-search-insert-field (field format-string result) (cond ((string-equal field "date") - (insert (propertize (format (cdr (assoc field notmuch-search-result-format)) date) + (insert (propertize (format format-string (plist-get result :date_relative)) 'face 'notmuch-search-date))) ((string-equal field "count") - (insert (propertize (format (cdr (assoc field notmuch-search-result-format)) count) + (insert (propertize (format format-string + (format "[%s/%s]" (plist-get result :matched) + (plist-get result :total))) 'face 'notmuch-search-count))) ((string-equal field "subject") - (insert (propertize (format (cdr (assoc field notmuch-search-result-format)) subject) + (insert (propertize (format format-string (plist-get result :subject)) 'face 'notmuch-search-subject))) ((string-equal field "authors") - (notmuch-search-insert-authors (cdr (assoc field notmuch-search-result-format)) authors)) + (notmuch-search-insert-authors format-string (plist-get result :authors))) ((string-equal field "tags") - (insert (concat "(" (propertize tags 'font-lock-face 'notmuch-tag-face) ")"))))) + (let ((tags-str (mapconcat 'identity (plist-get result :tags) " "))) + (insert (propertize (format format-string tags-str) + 'face 'notmuch-tag-face)))))) + +(defun notmuch-search-show-result (result &optional pos) + "Insert RESULT at POS or the end of the buffer if POS is null." + ;; Ignore excluded matches + (unless (= (plist-get result :matched) 0) + (let ((beg (or pos (point-max)))) + (save-excursion + (goto-char beg) + (dolist (spec notmuch-search-result-format) + (notmuch-search-insert-field (car spec) (cdr spec) result)) + (insert "\n") + (notmuch-search-color-line beg (point) (plist-get result :tags)) + (put-text-property beg (point) 'notmuch-search-result result)) + (when (string= (plist-get result :thread) notmuch-search-target-thread) + (setq notmuch-search-target-thread "found") + (goto-char beg))))) + +(defun notmuch-search-show-error (string &rest objects) + (save-excursion + (goto-char (point-max)) + (insert "Error: Unexpected output from notmuch search:\n") + (insert (apply #'format string objects)) + (insert "\n"))) + +(defvar notmuch-search-process-state nil + "Parsing state of the search process filter.") -(defun notmuch-search-show-result (date count authors subject tags) - (let ((fields) (field)) - (setq fields (mapcar 'car notmuch-search-result-format)) - (loop for field in fields - do (notmuch-search-insert-field field date count authors subject tags))) - (insert "\n")) +(defvar notmuch-search-json-parser nil + "Incremental JSON parser for the search process filter.") (defun notmuch-search-process-filter (proc string) "Process and filter the output of \"notmuch search\"" - (let ((buffer (process-buffer proc)) - (found-target nil)) - (if (buffer-live-p buffer) - (with-current-buffer buffer - (save-excursion - (let ((line 0) - (more t) - (inhibit-read-only t) - (string (concat notmuch-search-process-filter-data string))) - (setq notmuch-search-process-filter-data nil) - (while more - (while (and (< line (length string)) (= (elt string line) ?\n)) - (setq line (1+ line))) - (if (string-match "^\\(thread:[0-9A-Fa-f]*\\) \\([^][]*\\) \\(\\[[0-9/]*\\]\\) \\([^;]*\\); \\(.*\\) (\\([^()]*\\))$" string line) - (let* ((thread-id (match-string 1 string)) - (date (match-string 2 string)) - (count (match-string 3 string)) - (authors (match-string 4 string)) - (subject (match-string 5 string)) - (tags (match-string 6 string)) - (tag-list (if tags (save-match-data (split-string tags))))) - (goto-char (point-max)) - (if (/= (match-beginning 1) line) - (insert (concat "Error: Unexpected output from notmuch search:\n" (substring string line (match-beginning 1)) "\n"))) - (let ((beg (point))) - (notmuch-search-show-result date count authors subject tags) - (notmuch-search-color-line beg (point) tag-list) - (put-text-property beg (point) 'notmuch-search-thread-id thread-id) - (put-text-property beg (point) 'notmuch-search-authors authors) - (put-text-property beg (point) 'notmuch-search-subject subject) - (if (string= thread-id notmuch-search-target-thread) - (progn - (set 'found-target beg) - (set 'notmuch-search-target-thread "found")))) - (set 'line (match-end 0))) - (set 'more nil) - (while (and (< line (length string)) (= (elt string line) ?\n)) - (setq line (1+ line))) - (if (< line (length string)) - (setq notmuch-search-process-filter-data (substring string line))) - )))) - (if found-target - (goto-char found-target))) - (delete-process proc)))) - -(defun notmuch-search-operate-all (action) - "Add/remove tags from all matching messages. - -This command adds or removes tags from all messages matching the -current search terms. When called interactively, this command -will prompt for tags to be added or removed. Tags prefixed with -'+' will be added and tags prefixed with '-' will be removed. - -Each character of the tag name may consist of alphanumeric -characters as well as `_.+-'. -" - (interactive "sOperation (+add -drop): notmuch tag ") - (let ((action-split (split-string action " +"))) - ;; Perform some validation - (let ((words action-split)) - (when (null words) (error "No operation given")) - (while words - (unless (string-match-p "^[-+][-+_.[:word:]]+$" (car words)) - (error "Action must be of the form `+thistag -that_tag'")) - (setq words (cdr words)))) - (apply 'notmuch-tag notmuch-search-query-string action-split))) + (let ((results-buf (process-buffer proc)) + (parse-buf (process-get proc 'parse-buf)) + (inhibit-read-only t) + done) + (if (not (buffer-live-p results-buf)) + (delete-process proc) + (with-current-buffer parse-buf + ;; Insert new data + (save-excursion + (goto-char (point-max)) + (insert string))) + (with-current-buffer results-buf + (while (not done) + (condition-case nil + (case notmuch-search-process-state + ((begin) + ;; Enter the results list + (if (eq (notmuch-json-begin-compound + notmuch-search-json-parser) 'retry) + (setq done t) + (setq notmuch-search-process-state 'result))) + ((result) + ;; Parse a result + (let ((result (notmuch-json-read notmuch-search-json-parser))) + (case result + ((retry) (setq done t)) + ((end) (setq notmuch-search-process-state 'end)) + (otherwise (notmuch-search-show-result result))))) + ((end) + ;; Any trailing data is unexpected + (notmuch-json-eof notmuch-search-json-parser) + (setq done t))) + (json-error + ;; Do our best to resynchronize and ensure forward + ;; progress + (notmuch-search-show-error + "%s" + (with-current-buffer parse-buf + (let ((bad (buffer-substring (line-beginning-position) + (line-end-position)))) + (forward-line) + bad)))))) + ;; Clear out what we've parsed + (with-current-buffer parse-buf + (delete-region (point-min) (point))))))) + +(defun notmuch-search-tag-all (&optional tag-changes) + "Add/remove tags from all messages in current search buffer. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (apply 'notmuch-tag notmuch-search-query-string tag-changes)) (defun notmuch-search-buffer-title (query) "Returns the title for a buffer with notmuch search results." @@ -908,22 +923,26 @@ PROMPT is the string to prompt with." completions))) (t (list string))))))) ;; this was simpler than convincing completing-read to accept spaces: - (define-key keymap (kbd "<tab>") 'minibuffer-complete) - (read-from-minibuffer prompt nil keymap nil - 'notmuch-query-history nil nil)))) + (define-key keymap (kbd "TAB") 'minibuffer-complete) + (let ((history-delete-duplicates t)) + (read-from-minibuffer prompt nil keymap nil + 'notmuch-search-history nil nil))))) ;;;###autoload -(defun notmuch-search (query &optional oldest-first target-thread target-line continuation) - "Run \"notmuch search\" with the given query string and display results. +(defun notmuch-search (&optional query oldest-first target-thread target-line continuation) + "Run \"notmuch search\" with the given `query' and display results. -The optional parameters are used as follows: +If `query' is nil, it is read interactively from the minibuffer. +Other optional parameters are used as follows: oldest-first: A Boolean controlling the sort order of returned threads target-thread: A thread ID (with the thread: prefix) that will be made current if it appears in the search results. target-line: The line number to move to if the target thread does not appear in the search results." - (interactive (list (notmuch-read-query "Notmuch search: "))) + (interactive) + (if (null query) + (setq query (notmuch-read-query "Notmuch search: "))) (let ((buffer (get-buffer-create (notmuch-search-buffer-title query)))) (switch-to-buffer buffer) (notmuch-search-mode) @@ -945,10 +964,19 @@ The optional parameters are used as follows: (let ((proc (start-process "notmuch-search" buffer notmuch-command "search" + "--format=json" (if oldest-first "--sort=oldest-first" "--sort=newest-first") - query))) + query)) + ;; Use a scratch buffer to accumulate partial output. + ;; This buffer will be killed by the sentinel, which + ;; should be called no matter how the process dies. + (parse-buf (generate-new-buffer " *notmuch search parse*"))) + (set (make-local-variable 'notmuch-search-process-state) 'begin) + (set (make-local-variable 'notmuch-search-json-parser) + (notmuch-json-create-parser parse-buf)) + (process-put proc 'parse-buf parse-buf) (set-process-sentinel proc 'notmuch-search-process-sentinel) (set-process-filter proc 'notmuch-search-process-filter) (set-process-query-on-exit-flag proc nil)))) @@ -997,7 +1025,7 @@ Note that the recommended way of achieving the same is using :type '(choice (const :tag "notmuch new" nil) (const :tag "Disabled" "") (string :tag "Custom script")) - :group 'notmuch) + :group 'notmuch-external) (defun notmuch-poll () "Run \"notmuch new\" or an external script to import mail. @@ -1006,8 +1034,8 @@ Invokes `notmuch-poll-script', \"notmuch new\", or does nothing depending on the value of `notmuch-poll-script'." (interactive) (if (stringp notmuch-poll-script) - (if (not (string= notmuch-poll-script "")) - (call-process notmuch-poll-script nil nil)) + (unless (string= notmuch-poll-script "") + (call-process notmuch-poll-script nil nil)) (call-process notmuch-command nil nil nil "new"))) (defun notmuch-search-poll-and-refresh-view () @@ -1062,21 +1090,39 @@ current search results AND that are tagged with the given tag." (interactive) (notmuch-hello)) +(defun notmuch-interesting-buffer (b) + "Is the current buffer of interest to a notmuch user?" + (with-current-buffer b + (memq major-mode '(notmuch-show-mode + notmuch-search-mode + notmuch-hello-mode + message-mode)))) + ;;;###autoload -(defun notmuch-jump-to-recent-buffer () - "Jump to the most recent notmuch buffer (search, show or hello). +(defun notmuch-cycle-notmuch-buffers () + "Cycle through any existing notmuch buffers (search, show or hello). -If no recent buffer is found, run `notmuch'." +If the current buffer is the only notmuch buffer, bury it. If no +notmuch buffers exist, run `notmuch'." (interactive) - (let ((last - (loop for buffer in (buffer-list) - if (with-current-buffer buffer - (memq major-mode '(notmuch-show-mode - notmuch-search-mode - notmuch-hello-mode))) - return buffer))) - (if last - (switch-to-buffer last) + + (let (start first) + ;; If the current buffer is a notmuch buffer, remember it and then + ;; bury it. + (when (notmuch-interesting-buffer (current-buffer)) + (setq start (current-buffer)) + (bury-buffer)) + + ;; Find the first notmuch buffer. + (setq first (loop for buffer in (buffer-list) + if (notmuch-interesting-buffer buffer) + return buffer)) + + (if first + ;; If the first one we found is any other than the starting + ;; buffer, switch to it. + (unless (eq first start) + (switch-to-buffer first)) (notmuch)))) (setq mail-user-agent 'notmuch-user-agent) |