X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-show.el;h=33024390d70e439e8554a6b02e242505c0962a3f;hp=b565f336832382862101df17a7a203e76ce46561;hb=047792102c133f02e043759e9b8399e98938ba7f;hpb=8392a7cc54c4c08c0abbf2cc2707774f504ec33f diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el index b565f336..33024390 100644 --- a/emacs/notmuch-show.el +++ b/emacs/notmuch-show.el @@ -34,10 +34,12 @@ (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,54 +60,70 @@ 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) - -(defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-excerpt-citations) + :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-indent-messages-width 1 +(defcustom notmuch-show-indent-messages-width 1 "Width of message indentation in threads. 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))) (defmacro with-current-notmuch-show-message (&rest body) "Evaluate body with current buffer set to the text of current message" @@ -117,18 +135,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) @@ -183,6 +205,52 @@ 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))) + (with-temp-buffer + (insert all) + (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:") @@ -227,28 +295,54 @@ 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 " style. + ((string-match "\\(.*\\) <\\(.*\\)>" address) + (setq p-name (match-string 1 address) + p-address (match-string 2 address))) + + ;; "" style. + ((string-match "<\\(.*\\)>" address) + (setq p-address (match-string 1 address))) + + ;; Everything else. + (t + (setq p-address address))) + + ;; Remove elements of the mailbox part that are not relevant for + ;; display, even if they are required during transport. + (when p-name + ;; Outer double quotes. + (when (string-match "^\"\\(.*\\)\"$" p-name) + (setq p-name (match-string 1 p-name))) + + ;; Backslashes. + (setq p-name (replace-regexp-in-string "\\\\" "" p-name))) + ;; If the address is '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) "Insert a notmuch style headerline based on HEADERS for a message at DEPTH in the current thread." (let ((start (point))) - (insert (notmuch-show-spaces-n (* notmuch-indent-messages-width depth)) + (insert (notmuch-show-spaces-n (* notmuch-show-indent-messages-width depth)) (notmuch-show-clean-address (plist-get headers :From)) " (" date @@ -278,10 +372,21 @@ 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) + 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 @@ -296,44 +401,75 @@ 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))))) +(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-show-get-bodypart-internal ,message-id ,nth)) + ,@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-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 ((handle (mm-make-handle (current-buffer) (list content-type)))) - (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))))) + (let* ((charset (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-show-get-bodypart-content msg part nth)) + (when (mm-inlinable-p handle) + (set-buffer display-buffer) + (mm-display-part handle) + t)))))) (defvar notmuch-show-multipart/alternative-discouraged '( @@ -585,6 +721,10 @@ current buffer, if possible." nil)) nil)))) +;; Handler for wash generated inline patch fake parts. +(defun notmuch-show-insert-part-inline-patch-fake-part (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-*/* msg part "text/x-diff" nth depth "inline patch")) + (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)) @@ -652,8 +792,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." @@ -733,13 +873,13 @@ current buffer, if possible." (setq body-start (point-marker)) (notmuch-show-insert-body msg (plist-get msg :body) depth) ;; 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-indent-messages-width depth)) + (indent-rigidly content-start content-end (* notmuch-show-indent-messages-width depth)) (setq message-end (point-max-marker)) @@ -753,6 +893,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 @@ -803,7 +945,7 @@ a corresponding notmuch search." (remove-overlays (match-beginning 0) (match-end 0) 'goto-address t) (make-text-button (match-beginning 0) (match-end 0) 'action `(lambda (arg) - (notmuch-search ,(match-string-no-properties 0))) + (notmuch-show ,(match-string-no-properties 0))) 'follow-link t 'help-echo "Mouse-1, RET: search for this message" 'face goto-address-mail-face)))) @@ -869,14 +1011,11 @@ buffer." (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)) + (unless (notmuch-show-message-visible-p) + (notmuch-show-next-open-message)) ;; Set the header line to the subject of the first open message. (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject))) @@ -925,7 +1064,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) @@ -945,6 +1085,7 @@ 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) map) "Keymap for \"notmuch show\" buffers.") (fset 'notmuch-show-mode-map notmuch-show-mode-map) @@ -982,7 +1123,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))) @@ -1104,6 +1246,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) @@ -1230,9 +1375,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 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)) + (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." @@ -1300,7 +1450,7 @@ than only the current message." (interactive "P\nsPipe message to command: ") (let (shell-command) (if entire-thread - (setq shell-command + (setq shell-command (concat notmuch-command " show --format=mbox " (shell-quote-argument (mapconcat 'identity (notmuch-show-get-message-ids-for-open-messages) " OR ")) @@ -1407,20 +1557,38 @@ 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. +(defun notmuch-show-tag-thread-internal (tag &optional remove) + "Add tag to the current set of messages. + +If the remove switch is given, tags will be removed instead of +added." (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. + (let ((tag-function (if remove + 'notmuch-show-remove-tag + 'notmuch-show-add-tag))) + (loop do (funcall tag-function tag) + until (not (notmuch-show-goto-message-next))))) + +(defun notmuch-show-add-tag-thread (tag) + "Add tag to all messages in the current thread." + (interactive) + (notmuch-show-tag-thread-internal tag)) + +(defun notmuch-show-remove-tag-thread (tag) + "Remove tag from all messages in the current thread." + (interactive) + (notmuch-show-tag-thread-internal tag t)) + +(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 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. @@ -1434,12 +1602,14 @@ being delivered to the same thread. It does not archive the entire thread, but only the messages shown in the current buffer." (interactive) - (notmuch-show-archive-thread-internal t)) + (notmuch-show-remove-tag-thread "inbox") + (notmuch-show-next-thread t)) (defun notmuch-show-archive-thread-then-exit () "Archive each message in thread, then exit back to search results." (interactive) - (notmuch-show-archive-thread-internal nil)) + (notmuch-show-remove-tag-thread "inbox") + (notmuch-show-next-thread)) (defun notmuch-show-stash-cc () "Copy CC field of current message to kill-ring." @@ -1488,12 +1658,30 @@ buffer." ;; 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-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))))))) ;;