X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-show.el;h=4b8c66fdb2a1feefeacbee711acceef752f7c3a3;hp=209cd4aef5fd7ef1cfc844b8698ca4d7436fd15f;hb=c13ff402c42143941010cd03bd57658d42f0df7d;hpb=27768309cee7cc52dec9bbcf9468ce744f5af31d diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el index 209cd4ae..4b8c66fd 100644 --- a/emacs/notmuch-show.el +++ b/emacs/notmuch-show.el @@ -1,4 +1,4 @@ -;; notmuch-show.el --- displaying notmuch forests. +;;; notmuch-show.el --- displaying notmuch forests. ;; ;; Copyright © Carl Worth ;; Copyright © David Edmondson @@ -21,6 +21,8 @@ ;; Authors: Carl Worth ;; David Edmondson +;;; Code: + (eval-when-compile (require 'cl)) (require 'mm-view) (require 'message) @@ -41,6 +43,13 @@ (declare-function notmuch-search-next-thread "notmuch" nil) (declare-function notmuch-search-previous-thread "notmuch" nil) (declare-function notmuch-search-show-thread "notmuch" nil) +(declare-function notmuch-foreach-mime-part "notmuch" (function mm-handle)) +(declare-function notmuch-count-attachments "notmuch" (mm-handle)) +(declare-function notmuch-save-attachments "notmuch" (mm-handle &optional queryp)) +(declare-function notmuch-tree "notmuch-tree" + (&optional query query-context target buffer-name open-target)) +(declare-function notmuch-tree-get-message-properties "notmuch-tree" nil) +(declare-function notmuch-read-query "notmuch" (prompt)) (defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date") "Headers that should be shown in a message, in this order. @@ -93,6 +102,13 @@ visible for any given message." :group 'notmuch-show :group 'notmuch-hooks) +(defcustom notmuch-show-max-text-part-size 100000 + "Maximum size of a text part to be shown by default in characters. + +Set to 0 to show the part regardless of size." + :type 'integer + :group 'notmuch-show) + ;; Mostly useful for debugging. (defcustom notmuch-show-all-multipart/alternative-parts nil "Should all parts of multipart/alternative parts be shown?" @@ -130,34 +146,44 @@ indentation." :type 'boolean :group 'notmuch-show) +;; By default, block all external images to prevent privacy leaks and +;; potential attacks. +(defcustom notmuch-show-text/html-blocked-images "." + "Remote images that have URLs matching this regexp will be blocked." + :type '(choice (const nil) regexp) + :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) + +(defvar notmuch-show-attachment-debug nil + "If t log stdout and stderr from attachment handlers + +When set to nil (the default) stdout and stderr from attachment +handlers is discarded. When set to t the stdout and stderr from +each attachment handler is logged in buffers with names beginning +\" *notmuch-part*\". This option requires emacs version at least +24.3 to work.") (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=") + ("Mail Archive, The" . "http://mid.mail-archive.com/") ("LKML" . "http://lkml.kernel.org/r/") ;; FIXME: can these services be searched by `Message-Id' ? ;; ("MarkMail" . "http://markmail.org/") @@ -166,10 +192,21 @@ indentation." ) "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'." +This list is used for generating a Mailing List Archive reference +URI with the current message's Message-Id in +`notmuch-show-stash-mlarchive-link'. + +If the cdr of the alist element is not a function, the cdr is +expected to contain a URI that is concatenated with the current +message's Message-Id to create a ML archive reference URI. + +If the cdr is a function, the function is called with the +Message-Id as the argument, and the function is expected to +return the ML archive reference URI." :type '(alist :key-type (string :tag "Name") - :value-type (string :tag "URL")) + :value-type (choice + (string :tag "URL") + (function :tag "Function returning the URL"))) :group 'notmuch-show) (defcustom notmuch-show-stash-mlarchive-link-default "Gmane" @@ -197,6 +234,16 @@ For example, if you wanted to remove an \"unread\" tag and add a :type '(repeat string) :group 'notmuch-show) +(defcustom notmuch-show-mark-read-function #'notmuch-show-seen-current-message + "Function to control which messages are marked read. + +The function should take two arguments START and END which will +be the start and end of the visible portion of the buffer and +should mark the appropriate messages read by applying +`notmuch-show-mark-read'. This function will be called after +every user interaction with notmuch." + :type 'function + :group 'notmuch-show) (defmacro with-current-notmuch-show-message (&rest body) "Evaluate body with current buffer set to the text of current message" @@ -205,14 +252,17 @@ For example, if you wanted to remove an \"unread\" tag and add a (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*")))) (with-current-buffer buf (let ((coding-system-for-read 'no-conversion)) - (call-process notmuch-command nil t nil "show" "--format=raw" id) - ,@body) - (kill-buffer buf)))))) + (call-process notmuch-command nil t nil "show" "--format=raw" id)) + ,@body) + (kill-buffer buf))))) (defun notmuch-show-turn-on-visual-line-mode () "Enable Visual Line mode." (visual-line-mode t)) +;; DEPRECATED in Notmuch 0.16 since we now have convenient part +;; commands. We'll keep the command around for a version or two in +;; case people want to bind it themselves. (defun notmuch-show-view-all-mime-parts () "Use external viewers to view all attachments from the current message." (interactive) @@ -234,42 +284,6 @@ For example, if you wanted to remove an \"unread\" tag and add a ))) (mm-display-parts (mm-dissect-buffer))))) -(defun notmuch-foreach-mime-part (function mm-handle) - (cond ((stringp (car mm-handle)) - (dolist (part (cdr mm-handle)) - (notmuch-foreach-mime-part function part))) - ((bufferp (car mm-handle)) - (funcall function mm-handle)) - (t (dolist (part mm-handle) - (notmuch-foreach-mime-part function part))))) - -(defun notmuch-count-attachments (mm-handle) - (let ((count 0)) - (notmuch-foreach-mime-part - (lambda (p) - (let ((disposition (mm-handle-disposition p))) - (and (listp disposition) - (or (equal (car disposition) "attachment") - (and (equal (car disposition) "inline") - (assq 'filename disposition))) - (incf count)))) - mm-handle) - count)) - -(defun notmuch-save-attachments (mm-handle &optional queryp) - (notmuch-foreach-mime-part - (lambda (p) - (let ((disposition (mm-handle-disposition p))) - (and (listp disposition) - (or (equal (car disposition) "attachment") - (and (equal (car disposition) "inline") - (assq 'filename disposition))) - (or (not queryp) - (y-or-n-p - (concat "Save '" (cdr (assq 'filename disposition)) "' "))) - (mm-save-part p)))) - mm-handle)) - (defun notmuch-show-save-attachments () "Save all attachments from the current message." (interactive) @@ -335,8 +349,6 @@ operation on the contents of the current buffer." 'message-header-cc) ((looking-at "[Ss]ubject:") 'message-header-subject) - ((looking-at "[Ff]rom:") - 'message-header-from) (t 'message-header-other)))) @@ -363,7 +375,7 @@ operation on the contents of the current buffer." (if (re-search-forward "(\\([^()]*\\))$" (line-end-position) t) (let ((inhibit-read-only t)) (replace-match (concat "(" - (notmuch-tag-format-tags tags) + (notmuch-tag-format-tags tags (notmuch-show-get-prop :orig-tags)) ")")))))) (defun notmuch-clean-address (address) @@ -437,17 +449,18 @@ unchanged ADDRESS if parsing fails." message at DEPTH in the current thread." (let ((start (point))) (insert (notmuch-show-spaces-n (* notmuch-show-indent-messages-width depth)) - (notmuch-show-clean-address (plist-get headers :From)) + (notmuch-sanitize + (notmuch-show-clean-address (plist-get headers :From))) " (" date ") (" - (notmuch-tag-format-tags tags) + (notmuch-tag-format-tags tags tags) ")\n") (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face))) (defun notmuch-show-insert-header (header header-value) "Insert a single header." - (insert header ": " header-value "\n")) + (insert header ": " (notmuch-sanitize header-value) "\n")) (defun notmuch-show-insert-headers (headers) "Insert the headers of the current message." @@ -482,31 +495,112 @@ message at DEPTH in the current thread." (insert-button (concat "[ " base-label " ]") :base-label base-label - :type 'notmuch-show-part-button-type)) + :type 'notmuch-show-part-button-type + :notmuch-part-hidden nil)) (insert "\n") ;; return button button)) -;; This is taken from notmuch-wash: maybe it should be unified? (defun notmuch-show-toggle-part-invisibility (&optional button) (interactive) - (let* ((button (or button (button-at (point)))) - (overlay (button-get button 'overlay))) - (when overlay - (let* ((show (overlay-get overlay 'invisible)) - (new-start (button-start button)) - (button-label (button-get button :base-label)) - (old-point (point)) - (properties (text-properties-at (point))) - (inhibit-read-only t)) - (overlay-put overlay 'invisible (not show)) - (goto-char new-start) - (insert "[ " button-label (if show " ]" " (hidden) ]")) - (set-text-properties new-start (point) properties) - (let ((old-end (button-end button))) - (move-overlay button new-start (point)) - (delete-region (point) old-end)) - (goto-char (min old-point (1- (button-end button)))))))) + (let ((button (or button (button-at (point))))) + (when button + (let ((overlay (button-get button 'overlay)) + (lazy-part (button-get button :notmuch-lazy-part))) + ;; We have a part to toggle if there is an overlay or if there is a lazy part. + ;; If neither is present we cannot toggle the part so we just return nil. + (when (or overlay lazy-part) + (let* ((show (button-get button :notmuch-part-hidden)) + (new-start (button-start button)) + (button-label (button-get button :base-label)) + (old-point (point)) + (properties (text-properties-at (button-start button))) + (inhibit-read-only t)) + ;; Toggle the button itself. + (button-put button :notmuch-part-hidden (not show)) + (goto-char new-start) + (insert "[ " button-label (if show " ]" " (hidden) ]")) + (set-text-properties new-start (point) properties) + (let ((old-end (button-end button))) + (move-overlay button new-start (point)) + (delete-region (point) old-end)) + (goto-char (min old-point (1- (button-end button)))) + ;; Return nil if there is a lazy-part, it is empty, and we are + ;; trying to show it. In all other cases return t. + (if lazy-part + (when show + (button-put button :notmuch-lazy-part nil) + (notmuch-show-lazy-part lazy-part button)) + ;; else there must be an overlay. + (overlay-put overlay 'invisible (not show)) + t))))))) + +;; Part content ID handling + +(defvar notmuch-show--cids nil + "Alist from raw content ID to (MSG PART).") +(make-variable-buffer-local 'notmuch-show--cids) + +(defun notmuch-show--register-cids (msg part) + "Register content-IDs in PART and all of PART's sub-parts." + (let ((content-id (plist-get part :content-id))) + (when content-id + ;; Note that content-IDs are globally unique, except when they + ;; aren't: RFC 2046 section 5.1.4 permits children of a + ;; multipart/alternative to have the same content-ID, in which + ;; case the MUA is supposed to pick the best one it can render. + ;; We simply add the content-ID to the beginning of our alist; + ;; so if this happens, we'll take the last (and "best") + ;; alternative (even if we can't render it). + (push (list content-id msg part) notmuch-show--cids))) + ;; Recurse on sub-parts + (let ((ctype (notmuch-split-content-type + (downcase (plist-get part :content-type))))) + (cond ((equal (first ctype) "multipart") + (mapc (apply-partially #'notmuch-show--register-cids msg) + (plist-get part :content))) + ((equal ctype '("message" "rfc822")) + (notmuch-show--register-cids + msg + (first (plist-get (first (plist-get part :content)) :body))))))) + +(defun notmuch-show--get-cid-content (cid) + "Return a list (CID-content content-type) or nil. + +This will only find parts from messages that have been inserted +into the current buffer. CID must be a raw content ID, without +enclosing angle brackets, a cid: prefix, or URL encoding. This +will return nil if the CID is unknown or cannot be retrieved." + (let ((descriptor (cdr (assoc cid notmuch-show--cids)))) + (when descriptor + (let* ((msg (first descriptor)) + (part (second descriptor)) + ;; Request caching for this content, as some messages + ;; reference the same cid: part many times (hundreds!). + (content (notmuch-get-bodypart-binary + msg part notmuch-show-process-crypto 'cache)) + (content-type (plist-get part :content-type))) + (list content content-type))))) + +(defun notmuch-show-setup-w3m () + "Instruct w3m how to retrieve content from a \"related\" part of a message." + (interactive) + (if (boundp 'w3m-cid-retrieve-function-alist) + (unless (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist) + (push (cons 'notmuch-show-mode #'notmuch-show--cid-w3m-retrieve) + w3m-cid-retrieve-function-alist))) + (setq mm-inline-text-html-with-images t)) + +(defvar w3m-current-buffer) ;; From `w3m.el'. +(defun notmuch-show--cid-w3m-retrieve (url &rest args) + ;; url includes the cid: prefix and is URL encoded (see RFC 2392). + (let* ((cid (url-unhex-string (substring url 4))) + (content-and-type + (with-current-buffer w3m-current-buffer + (notmuch-show--get-cid-content cid)))) + (when content-and-type + (insert (first content-and-type)) + (second content-and-type)))) ;; MIME part renderers @@ -514,9 +608,8 @@ message at DEPTH in the current thread." (mapcar (lambda (inner-part) (plist-get inner-part :content-type)) (plist-get part :content))) -(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-multipart/alternative-choose (notmuch-show-multipart/*-to-list part)))) +(defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth button) + (let ((chosen-type (car (notmuch-multipart/alternative-choose msg (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, @@ -533,95 +626,28 @@ message at DEPTH in the current thread." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-setup-w3m () - "Instruct w3m how to retrieve content from a \"related\" part of a message." - (interactive) - (if (boundp 'w3m-cid-retrieve-function-alist) - (unless (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist) - (push (cons 'notmuch-show-mode 'notmuch-show-w3m-cid-retrieve) - w3m-cid-retrieve-function-alist))) - (setq mm-inline-text-html-with-images t)) - -(defvar w3m-current-buffer) ;; From `w3m.el'. -(defvar notmuch-show-w3m-cid-store nil) -(make-variable-buffer-local 'notmuch-show-w3m-cid-store) - -(defun notmuch-show-w3m-cid-store-internal (content-id - message-id - part-number - content-type - content) - (push (list content-id - message-id - part-number - content-type - content) - notmuch-show-w3m-cid-store)) - -(defun notmuch-show-w3m-cid-store (msg part) - (let ((content-id (plist-get part :content-id))) - (when content-id - (notmuch-show-w3m-cid-store-internal (concat "cid:" content-id) - (plist-get msg :id) - (plist-get part :id) - (plist-get part :content-type) - nil)))) - -(defun notmuch-show-w3m-cid-retrieve (url &rest args) - (let ((matching-part (with-current-buffer w3m-current-buffer - (assoc url notmuch-show-w3m-cid-store)))) - (if matching-part - (let ((message-id (nth 1 matching-part)) - (part-number (nth 2 matching-part)) - (content-type (nth 3 matching-part)) - (content (nth 4 matching-part))) - ;; If we don't already have the content, get it and cache - ;; it, as some messages reference the same cid: part many - ;; times (hundreds!), which results in many calls to - ;; `notmuch part'. - (unless content - (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 - part-number - content-type - content))) - (insert content) - content-type) - nil))) - -(defun notmuch-show-insert-part-multipart/related (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type nil) +(defun notmuch-show-insert-part-multipart/related (msg part content-type nth depth button) (let ((inner-parts (plist-get part :content)) (start (point))) - ;; We assume that the first part is text/html and the remainder - ;; things that it references. - - ;; Stash the non-primary parts. - (mapc (lambda (part) - (notmuch-show-w3m-cid-store msg part)) - (cdr inner-parts)) - - ;; Render the primary part. + ;; Render the primary part. FIXME: Support RFC 2387 Start header. (notmuch-show-insert-bodypart msg (car inner-parts) depth) + ;; Add hidden buttons for the rest + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth t)) + (cdr inner-parts)) (when notmuch-show-indent-multipart (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-multipart/signed (msg part content-type nth depth declared-type) - (let ((button (notmuch-show-insert-part-header nth declared-type content-type nil))) - (button-put button 'face 'notmuch-crypto-part-header) - ;; add signature status button if sigstatus provided - (if (plist-member part :sigstatus) - (let* ((from (notmuch-show-get-header :From msg)) - (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."))) +(defun notmuch-show-insert-part-multipart/signed (msg part content-type nth depth button) + (when button + (button-put button 'face 'notmuch-crypto-part-header)) + + ;; Insert a button detailing the signature status. + (notmuch-crypto-insert-sigstatus-button (car (plist-get part :sigstatus)) + (notmuch-show-get-header :From msg)) (let ((inner-parts (plist-get part :content)) (start (point))) @@ -634,20 +660,16 @@ message at DEPTH in the current thread." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-multipart/encrypted (msg part content-type nth depth declared-type) - (let ((button (notmuch-show-insert-part-header nth declared-type content-type nil))) - (button-put button 'face 'notmuch-crypto-part-header) - ;; add encryption status button if encstatus specified - (if (plist-member part :encstatus) - (let ((encstatus (car (plist-get part :encstatus)))) - (notmuch-crypto-insert-encstatus-button encstatus) - ;; add signature status button if sigstatus specified - (if (plist-member part :sigstatus) - (let* ((from (notmuch-show-get-header :From msg)) - (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."))) +(defun notmuch-show-insert-part-multipart/encrypted (msg part content-type nth depth button) + (when button + (button-put button 'face 'notmuch-crypto-part-header)) + + ;; Insert a button detailing the encryption status. + (notmuch-crypto-insert-encstatus-button (car (plist-get part :encstatus))) + + ;; Insert a button detailing the signature status. + (notmuch-crypto-insert-sigstatus-button (car (plist-get part :sigstatus)) + (notmuch-show-get-header :From msg)) (let ((inner-parts (plist-get part :content)) (start (point))) @@ -660,8 +682,7 @@ message at DEPTH in the current thread." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type nil) +(defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth button) (let ((inner-parts (plist-get part :content)) (start (point))) ;; Show all of the parts. @@ -673,8 +694,7 @@ message at DEPTH in the current thread." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type nil) +(defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth button) (let* ((message (car (plist-get part :content))) (body (car (plist-get message :body))) (start (point))) @@ -695,25 +715,25 @@ message at DEPTH in the current thread." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type) - (let ((start (point))) - ;; If this text/plain part is not the first part in the message, - ;; 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-get-bodypart-content msg part nth notmuch-show-process-crypto)) +(defun notmuch-show-insert-part-text/plain (msg part content-type nth depth button) + ;; For backward compatibility we want to apply the text/plain hook + ;; to the whole of the part including the part button if there is + ;; one. + (let ((start (if button + (button-start button) + (point)))) + (insert (notmuch-get-bodypart-text msg part 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/calendar (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)) +(defun notmuch-show-insert-part-text/calendar (msg part content-type nth depth button) (insert (with-temp-buffer - (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) - ;; notmuch-get-bodypart-content provides "raw", non-converted - ;; data. Replace CRLF with LF before icalendar can use it. + (insert (notmuch-get-bodypart-text msg part notmuch-show-process-crypto)) + ;; notmuch-get-bodypart-text does no newline conversion. + ;; Replace CRLF with LF before icalendar can use it. (goto-char (point-min)) (while (re-search-forward "\r\n" nil t) (replace-match "\n" nil nil)) @@ -732,8 +752,8 @@ message at DEPTH in the current thread." 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-text/x-vcalendar (msg part content-type nth depth button) + (notmuch-show-insert-part-text/calendar msg part content-type nth depth button)) (defun notmuch-show-get-mime-type-of-application/octet-stream (part) ;; If we can deduce a MIME type from the filename of the attachment, @@ -751,20 +771,51 @@ message at DEPTH in the current thread." nil)) nil)))) -(defun notmuch-show-insert-part-text/html (msg part content-type nth depth declared-type) - ;; text/html handler to work around bugs in renderers and our - ;; invisibile parts code. In particular w3m sets up a keymap which - ;; "leaks" outside the invisible region and causes strange effects - ;; in notmuch. We set mm-inline-text-html-with-w3m-keymap to nil to - ;; tell w3m not to set a keymap (so the normal notmuch-show-mode-map - ;; remains). - (let ((mm-inline-text-html-with-w3m-keymap nil)) - (notmuch-show-insert-part-*/* msg part content-type nth depth declared-type))) - -(defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type) +(defun notmuch-show-insert-part-text/html (msg part content-type nth depth button) + (if (eq mm-text-html-renderer 'shr) + ;; It's easier to drive shr ourselves than to work around the + ;; goofy things `mm-shr' does (like irreversibly taking over + ;; content ID handling). + + ;; FIXME: If we block an image, offer a button to load external + ;; images. + (let ((shr-blocked-images notmuch-show-text/html-blocked-images)) + (notmuch-show--insert-part-text/html-shr msg part)) + ;; Otherwise, let message-mode do the heavy lifting + ;; + ;; w3m sets up a keymap which "leaks" outside the invisible region + ;; and causes strange effects in notmuch. We set + ;; mm-inline-text-html-with-w3m-keymap to nil to tell w3m not to + ;; set a keymap (so the normal notmuch-show-mode-map remains). + (let ((mm-inline-text-html-with-w3m-keymap nil) + ;; FIXME: If we block an image, offer a button to load external + ;; images. + (gnus-blocked-images notmuch-show-text/html-blocked-images)) + (notmuch-show-insert-part-*/* msg part content-type nth depth button)))) + +;; These functions are used by notmuch-show--insert-part-text/html-shr +(declare-function libxml-parse-html-region "xml.c") +(declare-function shr-insert-document "shr") + +(defun notmuch-show--insert-part-text/html-shr (msg part) + ;; Make sure shr is loaded before we start let-binding its globals + (require 'shr) + (let ((dom (let ((process-crypto notmuch-show-process-crypto)) + (with-temp-buffer + (insert (notmuch-get-bodypart-text msg part process-crypto)) + (libxml-parse-html-region (point-min) (point-max))))) + (shr-content-function + (lambda (url) + ;; shr strips the "cid:" part of URL, but doesn't + ;; URL-decode it (see RFC 2392). + (let ((cid (url-unhex-string url))) + (first (notmuch-show--get-cid-content cid)))))) + (shr-insert-document dom) + t)) + +(defun notmuch-show-insert-part-*/* (msg part content-type nth depth button) ;; 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-mm-display-part-inline msg part nth content-type notmuch-show-process-crypto) + (notmuch-mm-display-part-inline msg part content-type notmuch-show-process-crypto) t) ;; Functions for determining how to handle MIME parts. @@ -786,77 +837,174 @@ message at DEPTH in the current thread." ;; -(defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type) - (let ((handlers (notmuch-show-handlers-for content-type))) - ;; Run the content handlers until one of them returns a non-nil - ;; value. - (while (and handlers - (not (condition-case err - (funcall (car handlers) msg part content-type nth depth declared-type) - (error (progn - (insert "!!! Bodypart insert error: ") - (insert (error-message-string err)) - (insert " !!!\n") nil))))) - (setq handlers (cdr handlers)))) - t) - -(defun notmuch-show-create-part-overlays (msg beg end hide) +(defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth button) + ;; Run the handlers until one of them succeeds. + (loop for handler in (notmuch-show-handlers-for content-type) + until (condition-case err + (funcall handler msg part content-type nth depth button) + ;; Specifying `debug' here lets the debugger run if + ;; `debug-on-error' is non-nil. + ((debug error) + (insert "!!! Bodypart handler `" (prin1-to-string handler) "' threw an error:\n" + "!!! " (error-message-string err) "\n") + nil)))) + +(defun notmuch-show-create-part-overlays (button beg end) "Add an overlay to the part between BEG and END" - (let* ((button (button-at beg)) - (part-beg (and button (1+ (button-end button))))) - - ;; If the part contains no text we do not make it toggleable. We - ;; also need to check that the button is a genuine part button not - ;; a notmuch-wash button. - (when (and button (/= part-beg end) (button-get button :base-label)) - (button-put button 'overlay (make-overlay part-beg end)) - ;; We toggle the button for hidden parts as that gets the - ;; button label right. - (save-excursion - (when hide - (notmuch-show-toggle-part-invisibility button)))))) + + ;; If there is no button (i.e., the part is text/plain and the first + ;; part) or if the part has no content then we don't make the part + ;; toggleable. + (when (and button (/= beg end)) + (button-put button 'overlay (make-overlay beg end)) + ;; Return true if we created an overlay. + t)) + +(defun notmuch-show-record-part-information (part beg end) + "Store PART as a text property from BEG to END" + + ;; Record part information. Since we already inserted subparts, + ;; don't override existing :notmuch-part properties. + (notmuch-map-text-property beg end :notmuch-part + (lambda (v) (or v part))) + ;; Make :notmuch-part front sticky and rear non-sticky so it stays + ;; applied to the beginning of each line when we indent the + ;; message. Since we're operating on arbitrary renderer output, + ;; watch out for sticky specs of t, which means all properties are + ;; front-sticky/rear-nonsticky. + (notmuch-map-text-property beg end 'front-sticky + (lambda (v) (if (listp v) + (pushnew :notmuch-part v) + v))) + (notmuch-map-text-property beg end 'rear-nonsticky + (lambda (v) (if (listp v) + (pushnew :notmuch-part v) + v)))) + +(defun notmuch-show-lazy-part (part-args button) + ;; Insert the lazy part after the button for the part. We would just + ;; move to the start of the new line following the button and insert + ;; the part but that point might have text properties (eg colours + ;; from a message header etc) so instead we start from the last + ;; character of the button by adding a newline and finish by + ;; removing the extra newline from the end of the part. + (save-excursion + (goto-char (button-end button)) + (insert "\n") + (let* ((inhibit-read-only t) + ;; We need to use markers for the start and end of the part + ;; because the part insertion functions do not guarantee + ;; to leave point at the end of the part. + (part-beg (copy-marker (point) nil)) + (part-end (copy-marker (point) t)) + ;; We have to save the depth as we can't find the depth + ;; when narrowed. + (depth (notmuch-show-get-depth))) + (save-restriction + (narrow-to-region part-beg part-end) + (delete-region part-beg part-end) + (apply #'notmuch-show-insert-bodypart-internal part-args) + (indent-rigidly part-beg part-end depth)) + (goto-char part-end) + (delete-char 1) + (notmuch-show-record-part-information (second part-args) + (button-start button) + part-end) + ;; Create the overlay. If the lazy-part turned out to be empty/not + ;; showable this returns nil. + (notmuch-show-create-part-overlays button part-beg part-end)))) + +(defun notmuch-show-mime-type (part) + "Return the correct mime-type to use for PART." + (let ((content-type (downcase (plist-get part :content-type)))) + (or (and (string= content-type "application/octet-stream") + (notmuch-show-get-mime-type-of-application/octet-stream part)) + (and (string= content-type "inline patch") + "text/x-diff") + content-type))) + +;; The following variable can be overridden by let bindings. +(defvar notmuch-show-insert-header-p-function 'notmuch-show-insert-header-p + "Specify which function decides which part headers get inserted. + +The function should take two parameters, PART and HIDE, and +should return non-NIL if a header button should be inserted for +this part.") + +(defun notmuch-show-insert-header-p (part hide) + ;; Show all part buttons except for the first part if it is text/plain. + (let ((mime-type (notmuch-show-mime-type part))) + (not (and (string= mime-type "text/plain") + (<= (plist-get part :id) 1))))) + +(defun notmuch-show-reply-insert-header-p-never (part hide) + nil) + +(defun notmuch-show-reply-insert-header-p-trimmed (part hide) + (let ((mime-type (notmuch-show-mime-type part))) + (and (not (notmuch-match-content-type mime-type "multipart/*")) + (not hide)))) + +(defun notmuch-show-reply-insert-header-p-minimal (part hide) + (let ((mime-type (notmuch-show-mime-type part))) + (and (notmuch-match-content-type mime-type "text/*") + (not hide)))) (defun notmuch-show-insert-bodypart (msg part depth &optional hide) "Insert the body part PART at depth DEPTH in the current thread. -If HIDE is non-nil then initially hide this part." +HIDE determines whether to show or hide the part and the button +as follows: If HIDE is nil, show the part and the button. If HIDE +is t, hide the part initially and show the button." + (let* ((content-type (downcase (plist-get part :content-type))) - (mime-type (or (and (string= content-type "application/octet-stream") - (notmuch-show-get-mime-type-of-application/octet-stream part)) - (and (string= content-type "inline patch") - "text/x-diff") - content-type)) + (mime-type (notmuch-show-mime-type part)) (nth (plist-get part :id)) - (beg (point))) + (long (and (notmuch-match-content-type mime-type "text/*") + (> notmuch-show-max-text-part-size 0) + (> (length (plist-get part :content)) notmuch-show-max-text-part-size))) + (beg (point)) + ;; This default header-p function omits the part button for + ;; the first (or only) part if this is text/plain. + (button (when (funcall notmuch-show-insert-header-p-function part hide) + (notmuch-show-insert-part-header nth mime-type content-type (plist-get part :filename)))) + ;; Hide the part initially if HIDE is t, or if it is too long + ;; and we have a button to allow toggling. + (show-part (not (or (equal hide t) + (and long button)))) + (content-beg (point))) + + ;; Store the computed mime-type for later use (e.g. by attachment handlers). + (plist-put part :computed-type mime-type) + + (if show-part + (notmuch-show-insert-bodypart-internal msg part mime-type nth depth button) + (when button + (button-put button :notmuch-lazy-part + (list msg part mime-type nth depth button)))) - (notmuch-show-insert-bodypart-internal msg part mime-type nth depth content-type) ;; Some of the body part handlers leave point somewhere up in the ;; 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. (unless (bolp) (insert "\n")) - (notmuch-show-create-part-overlays msg beg (point) hide) - ;; Record part information. Since we already inserted subparts, - ;; don't override existing :notmuch-part properties. - (notmuch-map-text-property beg (point) :notmuch-part - (lambda (v) (or v part))) - ;; Make :notmuch-part front sticky and rear non-sticky so it stays - ;; applied to the beginning of each line when we indent the - ;; message. Since we're operating on arbitrary renderer output, - ;; watch out for sticky specs of t, which means all properties are - ;; front-sticky/rear-nonsticky. - (notmuch-map-text-property beg (point) 'front-sticky - (lambda (v) (if (listp v) - (pushnew :notmuch-part v) - v))) - (notmuch-map-text-property beg (point) 'rear-nonsticky - (lambda (v) (if (listp v) - (pushnew :notmuch-part v) - v))))) + ;; We do not create the overlay for hidden (lazy) parts until + ;; they are inserted. + (if show-part + (notmuch-show-create-part-overlays button content-beg (point)) + (save-excursion + (notmuch-show-toggle-part-invisibility button))) + (notmuch-show-record-part-information part beg (point)))) (defun notmuch-show-insert-body (msg body depth) "Insert the body BODY at depth DEPTH in the current thread." + + ;; Register all content IDs for this message. According to RFC + ;; 2392, content IDs are *global*, but it's okay if an MUA treats + ;; them as only global within a message. + (notmuch-show--register-cids msg (first body)) + (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body)) (defun notmuch-show-make-symbol (type) @@ -1042,15 +1190,17 @@ buttons for a corresponding notmuch search." (make-text-button (first link) (second link) :type 'notmuch-button-type 'action `(lambda (arg) - (notmuch-show ,(third link))) + (notmuch-show ,(third link) current-prefix-arg)) 'follow-link t 'help-echo "Mouse-1, RET: search for this message" 'face goto-address-mail-face))))) ;;;###autoload -(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name) +(defun notmuch-show (thread-id &optional elide-toggle parent-buffer query-context buffer-name) "Run \"notmuch show\" with the given thread ID and display results. +ELIDE-TOGGLE, if non-nil, inverts the default elide behavior. + The optional PARENT-BUFFER is the notmuch-search buffer from which this notmuch-show command was executed, (so that the next thread from that buffer can be show when done with this @@ -1063,62 +1213,101 @@ 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." - (interactive "sNotmuch show: ") +function is used. + +Returns the buffer containing the messages, or NIL if no messages +matched." + (interactive "sNotmuch show: \nP") (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))) + ;; No need to track undo information for this buffer. + (setq buffer-undo-list t) + (notmuch-show-mode) + + ;; Set various buffer local variables to their appropriate initial + ;; state. Do this after enabling `notmuch-show-mode' so that they + ;; aren't wiped out. (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) - (current-buffer))) - -(defun notmuch-show-build-buffer () - (let ((inhibit-read-only t)) + notmuch-show-query-context query-context + + notmuch-show-process-crypto notmuch-crypto-process-mime + ;; If `elide-toggle', invert the default value. + notmuch-show-elide-non-matching-messages + (if elide-toggle + (not notmuch-show-only-matching-messages) + notmuch-show-only-matching-messages)) + + (add-hook 'post-command-hook #'notmuch-show-command-hook nil t) + (jit-lock-register #'notmuch-show-buttonise-links) + + (notmuch-tag-clear-cache) + + (let ((inhibit-read-only t)) + (if (notmuch-show--build-buffer) + ;; Messages were inserted into the buffer. + (current-buffer) + + ;; No messages were inserted - presumably none matched the + ;; query. + (kill-buffer (current-buffer)) + (ding) + (message "No messages matched the query!") + nil)))) + +(defun notmuch-show--build-buffer (&optional state) + "Display messages matching the current buffer context. + +Apply the previously saved STATE if supplied, otherwise show the +first relevant message. + +If no messages match the query return NIL." + (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")))) + + (forest (or (notmuch-query-get-threads (append cli-args args)) + ;; If a query context reduced the number of + ;; results to zero, try again without it. + (and notmuch-show-query-context + (notmuch-query-get-threads (append cli-args basic-args))))) + + ;; Must be reset every time we are going to start inserting + ;; messages into the buffer. + (notmuch-show-previous-subject "")) + + (when forest + (notmuch-show-insert-forest forest) + + ;; Store the original tags for each message so that we can + ;; display changes. + (notmuch-show-mapc + (lambda () (notmuch-show-set-prop :orig-tags (notmuch-show-get-tags)))) - (notmuch-show-mode) - ;; Don't track undo information for this buffer - (set 'buffer-undo-list t) + ;; Set the header line to the subject of the first message. + (setq header-line-format + (replace-regexp-in-string "%" "%%" + (notmuch-sanitize + (notmuch-show-strip-re + (notmuch-show-get-subject))))) - (erase-buffer) - (goto-char (point-min)) - (save-excursion - (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) - notmuch-show-query-context) - (notmuch-show-insert-forest - (notmuch-query-get-threads (append cli-args basic-args))))) - - (jit-lock-register #'notmuch-show-buttonise-links) + (run-hooks 'notmuch-show-hook) - ;; Set the header line to the subject of the first message. - (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject))) + (if state + (notmuch-show-apply-state state) + ;; With no state to apply, just go to the first message. + (notmuch-show-goto-first-wanted-message))) - (run-hooks 'notmuch-show-hook)))) + ;; Report back to the caller whether any messages matched. + forest)) (defun notmuch-show-capture-state () "Capture the state of the current buffer. @@ -1128,6 +1317,25 @@ This includes: - the current message." (list (notmuch-show-get-message-id) (notmuch-show-get-message-ids-for-open-messages))) +(defun notmuch-show-get-query () + "Return the current query in this show buffer" + (if notmuch-show-query-context + (concat notmuch-show-thread-id + " and (" + notmuch-show-query-context + ")") + notmuch-show-thread-id)) + +(defun notmuch-show-goto-message (msg-id) + "Go to message with msg-id." + (goto-char (point-min)) + (unless (loop if (string= msg-id (notmuch-show-get-message-id)) + return t + until (not (notmuch-show-goto-message-next))) + (goto-char (point-min)) + (message "Message-id not found.")) + (notmuch-show-message-adjust)) + (defun notmuch-show-apply-state (state) "Apply STATE to the current buffer. @@ -1145,13 +1353,7 @@ This includes: 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))) + (notmuch-show-goto-message current))) (defun notmuch-show-refresh-view (&optional reset-state) "Refresh the current view. @@ -1164,17 +1366,17 @@ reset based on the original query." (let ((inhibit-read-only t) (state (unless reset-state (notmuch-show-capture-state)))) - ;; erase-buffer does not seem to remove overlays, which can lead + ;; `erase-buffer' does not seem to remove overlays, which can lead ;; to weird effects such as remaining images, so remove them ;; manually. (remove-overlays) (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)))) + + (unless (notmuch-show--build-buffer state) + ;; No messages were inserted. + (kill-buffer (current-buffer)) + (ding) + (message "Refreshing the buffer resulted in no messages!")))) (defvar notmuch-show-stash-map (let ((map (make-sparse-keymap))) @@ -1189,6 +1391,8 @@ reset based on the original query." (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) + (define-key map "G" 'notmuch-show-stash-git-send-email) + (define-key map "?" 'notmuch-subkeymap-help) map) "Submap for stash commands") (fset 'notmuch-show-stash-map notmuch-show-stash-map) @@ -1199,55 +1403,54 @@ reset based on the original query." (define-key map "v" 'notmuch-show-view-part) (define-key map "o" 'notmuch-show-interactively-view-part) (define-key map "|" 'notmuch-show-pipe-part) + (define-key map "?" 'notmuch-subkeymap-help) map) "Submap for part commands") (fset 'notmuch-show-part-map notmuch-show-part-map) (defvar notmuch-show-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "?" 'notmuch-help) - (define-key map "q" 'notmuch-kill-this-buffer) - (define-key map (kbd "") 'widget-backward) - (define-key map (kbd "M-TAB") 'notmuch-show-previous-button) - (define-key map (kbd "") 'notmuch-show-previous-button) - (define-key map (kbd "TAB") 'notmuch-show-next-button) - (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-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) - (define-key map "v" 'notmuch-show-view-all-mime-parts) - (define-key map "c" 'notmuch-show-stash-map) - (define-key map "=" 'notmuch-show-refresh-view) - (define-key map "h" 'notmuch-show-toggle-visibility-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 "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) - (define-key map "p" 'notmuch-show-previous-open-message) - (define-key map (kbd "M-n") 'notmuch-show-next-thread-show) - (define-key map (kbd "M-p") 'notmuch-show-previous-thread-show) - (define-key map (kbd "DEL") 'notmuch-show-rewind) - (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) - (define-key map "." 'notmuch-show-part-map) - map) - "Keymap for \"notmuch show\" buffers.") + (let ((map (make-sparse-keymap))) + (set-keymap-parent map notmuch-common-keymap) + (define-key map "Z" 'notmuch-tree-from-show-current-query) + (define-key map (kbd "") 'widget-backward) + (define-key map (kbd "M-TAB") 'notmuch-show-previous-button) + (define-key map (kbd "") 'notmuch-show-previous-button) + (define-key map (kbd "TAB") 'notmuch-show-next-button) + (define-key map "f" 'notmuch-show-forward-message) + (define-key map "F" 'notmuch-show-forward-open-messages) + (define-key map "l" 'notmuch-show-filter-thread) + (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) + (define-key map "c" 'notmuch-show-stash-map) + (define-key map "h" 'notmuch-show-toggle-visibility-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 "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) + (define-key map "p" 'notmuch-show-previous-open-message) + (define-key map (kbd "M-n") 'notmuch-show-next-thread-show) + (define-key map (kbd "M-p") 'notmuch-show-previous-thread-show) + (define-key map (kbd "DEL") 'notmuch-show-rewind) + (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) + (define-key map "." 'notmuch-show-part-map) + map) + "Keymap for \"notmuch show\" buffers.") (fset 'notmuch-show-mode-map notmuch-show-mode-map) (defun notmuch-show-mode () @@ -1280,12 +1483,20 @@ All currently available key bindings: \\{notmuch-show-mode-map}" (interactive) (kill-all-local-variables) + (setq notmuch-buffer-refresh-function #'notmuch-show-refresh-view) (use-local-map notmuch-show-mode-map) (setq major-mode 'notmuch-show-mode mode-name "notmuch-show") (setq buffer-read-only t truncate-lines t)) +(defun notmuch-tree-from-show-current-query () + "Call notmuch tree with the current query" + (interactive) + (notmuch-tree notmuch-show-thread-id + notmuch-show-query-context + (notmuch-show-get-message-id))) + (defun notmuch-show-move-to-message-top () (goto-char (notmuch-show-message-top))) @@ -1384,8 +1595,18 @@ an error if there is no part containing point." (notmuch-show-set-message-properties props))) (defun notmuch-show-get-prop (prop &optional props) + "Get property PROP from current message in show or tree mode. + +It gets property PROP from PROPS or, if PROPS is nil, the current +message in either tree or show. This means that several utility +functions in notmuch-show can be used directly by notmuch-tree as +they just need the correct message properties." (let ((props (or props - (notmuch-show-get-message-properties)))) + (cond ((eq major-mode 'notmuch-show-mode) + (notmuch-show-get-message-properties)) + ((eq major-mode 'notmuch-tree-mode) + (notmuch-tree-get-message-properties)) + (t nil))))) (plist-get props prop))) (defun notmuch-show-get-message-id (&optional bare) @@ -1454,6 +1675,8 @@ current thread." "Are the headers of the current message visible?" (notmuch-show-get-prop :headers-visible)) +(put 'notmuch-show-mark-read 'notmuch-prefix-doc + "Mark the current message as unread.") (defun notmuch-show-mark-read (&optional unread) "Mark the current message as read. @@ -1467,6 +1690,33 @@ marked as unread, i.e. the tag changes in (apply 'notmuch-show-tag-message (notmuch-tag-change-list notmuch-show-mark-read-tags unread)))) +(defun notmuch-show-seen-current-message (start end) + "Mark the current message read if it is open. + +We only mark it read once: if it is changed back then that is a +user decision and we should not override it." + (when (and (notmuch-show-message-visible-p) + (not (notmuch-show-get-prop :seen))) + (notmuch-show-mark-read) + (notmuch-show-set-prop :seen t))) + +(defun notmuch-show-command-hook () + (when (eq major-mode 'notmuch-show-mode) + ;; We need to redisplay to get window-start and window-end correct. + (redisplay) + (save-excursion + (funcall notmuch-show-mark-read-function (window-start) (window-end))))) + +(defun notmuch-show-filter-thread (query) + "Filter or LIMIT the current thread based on a new query string. + +Reshows the current thread with matches defined by the new query-string." + (interactive (list (notmuch-read-query "Filter thread: "))) + (let ((msg-id (notmuch-show-get-message-id))) + (setq notmuch-show-query-context (if (string= query "") nil query)) + (notmuch-show-refresh-view t) + (notmuch-show-goto-message msg-id))) + ;; Functions for getting attributes of several messages in the current ;; thread. @@ -1541,7 +1791,7 @@ shown." (notmuch-show-archive-thread-then-next))) (defun notmuch-show-rewind () - "Backup through the thread, (reverse scrolling compared to \\[notmuch-show-advance-and-archive]). + "Backup through the thread (reverse scrolling compared to \\[notmuch-show-advance-and-archive]). Specifically, if the beginning of the previous email is fewer than `window-height' lines from the current point, move to it @@ -1575,21 +1825,43 @@ any effects from previous calls to ;; Move to the previous message. (notmuch-show-previous-message))))) +(put 'notmuch-show-reply 'notmuch-prefix-doc "... and prompt for sender") (defun notmuch-show-reply (&optional prompt-for-sender) "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)) +(put 'notmuch-show-reply-sender 'notmuch-prefix-doc "... and prompt for sender") (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)) +(put 'notmuch-show-forward-message 'notmuch-prefix-doc + "... and prompt for sender") (defun notmuch-show-forward-message (&optional prompt-for-sender) "Forward the current message." (interactive "P") - (with-current-notmuch-show-message - (notmuch-mua-new-forward-message prompt-for-sender))) + (notmuch-mua-new-forward-messages (list (notmuch-show-get-message-id)) + prompt-for-sender)) + +(put 'notmuch-show-forward-open-messages 'notmuch-prefix-doc + "... and prompt for sender") +(defun notmuch-show-forward-open-messages (&optional prompt-for-sender) + "Forward the currently open messages." + (interactive "P") + (let ((open-messages (notmuch-show-get-message-ids-for-open-messages))) + (unless open-messages + (error "No open messages to forward.")) + (notmuch-mua-new-forward-messages open-messages prompt-for-sender))) + +(defun notmuch-show-resend-message (addresses) + "Resend the current message." + (interactive (list (notmuch-address-from-minibuffer "Resend to: "))) + (when (y-or-n-p (concat "Confirm resend to " addresses " ")) + (notmuch-show-view-raw-message) + (message-resend addresses) + (notmuch-bury-or-kill-this-buffer))) (defun notmuch-show-next-message (&optional pop-at-end) "Show the next message. @@ -1598,9 +1870,7 @@ 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)) + (notmuch-show-message-adjust) (if pop-at-end (notmuch-show-next-thread) (goto-char (point-max))))) @@ -1611,7 +1881,6 @@ thread, navigate to the next thread in the parent search buffer." (if (= (point) (notmuch-show-message-top)) (notmuch-show-goto-message-previous) (notmuch-show-move-to-message-top)) - (notmuch-show-mark-read) (notmuch-show-message-adjust)) (defun notmuch-show-next-open-message (&optional pop-at-end) @@ -1626,9 +1895,7 @@ to show, nil otherwise." (while (and (setq r (notmuch-show-goto-message-next)) (not (notmuch-show-message-visible-p)))) (if r - (progn - (notmuch-show-mark-read) - (notmuch-show-message-adjust)) + (notmuch-show-message-adjust) (if pop-at-end (notmuch-show-next-thread) (goto-char (point-max)))) @@ -1641,9 +1908,7 @@ to show, nil otherwise." (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)) + (notmuch-show-message-adjust) (goto-char (point-max))))) (defun notmuch-show-open-if-matched () @@ -1654,8 +1919,7 @@ to show, nil otherwise." (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) + (unless (notmuch-show-message-visible-p) (notmuch-show-next-open-message)) (when (eobp) ;; There are no matched non-excluded messages so open all matched @@ -1663,8 +1927,7 @@ to show, nil otherwise." (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) + (unless (notmuch-show-message-visible-p) (notmuch-show-next-open-message)))) (defun notmuch-show-previous-open-message () @@ -1674,31 +1937,42 @@ to show, nil otherwise." (notmuch-show-goto-message-previous) (notmuch-show-move-to-message-top)) (not (notmuch-show-message-visible-p)))) - (notmuch-show-mark-read) (notmuch-show-message-adjust)) (defun notmuch-show-view-raw-message () - "View the file holding the current message." + "View the original source of the current message." (interactive) (let* ((id (notmuch-show-get-message-id)) - (buf (get-buffer-create (concat "*notmuch-raw-" id "*")))) - (call-process notmuch-command nil buf nil "show" "--format=raw" id) + (buf (get-buffer-create (concat "*notmuch-raw-" id "*"))) + (inhibit-read-only t)) (switch-to-buffer buf) + (erase-buffer) + (let ((coding-system-for-read 'no-conversion)) + (call-process notmuch-command nil t nil "show" "--format=raw" id)) (goto-char (point-min)) (set-buffer-modified-p nil) + (setq buffer-read-only t) (view-buffer buf 'kill-buffer-if-not-modified))) +(put 'notmuch-show-pipe-message 'notmuch-doc + "Pipe the contents of the current message to a command.") +(put 'notmuch-show-pipe-message 'notmuch-prefix-doc + "Pipe the thread as an mbox to a command.") (defun notmuch-show-pipe-message (entire-thread command) - "Pipe the contents of the current message (or thread) to the given command. - -The given command will be executed with the raw contents of the -current email message as stdin. Anything printed by the command -to stdout or stderr will appear in the *notmuch-pipe* buffer. - -When invoked with a prefix argument, the command will receive all -open messages in the current thread (formatted as an mbox) rather -than only the current message." - (interactive "P\nsPipe message to command: ") + "Pipe the contents of the current message (or thread) to COMMAND. + +COMMAND will be executed with the raw contents of the current +email message as stdin. Anything printed by the command to stdout +or stderr will appear in the *notmuch-pipe* buffer. + +If ENTIRE-THREAD is non-nil (or when invoked with a prefix +argument), COMMAND will receive all open messages in the current +thread (formatted as an mbox) rather than only the current +message." + (interactive (let ((query-string (if current-prefix-arg + "Pipe all open messages to command: " + "Pipe message to command: "))) + (list current-prefix-arg (read-string query-string)))) (let (shell-command) (if entire-thread (setq shell-command @@ -1709,10 +1983,14 @@ than only the current message." (setq shell-command (concat notmuch-command " show --format=raw " (shell-quote-argument (notmuch-show-get-message-id)) " | " command))) - (let ((buf (get-buffer-create (concat "*notmuch-pipe*")))) + (let ((cwd default-directory) + (buf (get-buffer-create (concat "*notmuch-pipe*")))) (with-current-buffer buf (setq buffer-read-only nil) (erase-buffer) + ;; Use the originating buffer's working directory instead of + ;; that of the pipe buffer. + (cd cwd) (let ((exit-code (call-process-shell-command shell-command nil buf))) (goto-char (point-max)) (set-buffer-modified-p nil) @@ -1732,23 +2010,28 @@ TAG-CHANGES is a list of tag operations for `notmuch-tag'." (notmuch-tag (notmuch-show-get-message-id) tag-changes) (notmuch-show-set-tags new-tags)))) -(defun notmuch-show-tag (&optional tag-changes) +(defun notmuch-show-tag (tag-changes) "Change tags for the current message. See `notmuch-tag' for information on the format of TAG-CHANGES." - (interactive) - (let* ((tag-changes (notmuch-tag (notmuch-show-get-message-id) tag-changes)) - (current-tags (notmuch-show-get-tags)) + (interactive (list (notmuch-read-tag-changes (notmuch-show-get-tags) + "Tag message"))) + (notmuch-tag (notmuch-show-get-message-id) tag-changes) + (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-tag-all (&optional tag-changes) +(defun notmuch-show-tag-all (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 (notmuch-tag (notmuch-show-get-messages-ids-search) tag-changes)) + (interactive + (list (let (tags) + (notmuch-show-mapc + (lambda () (setq tags (append (notmuch-show-get-tags) tags)))) + (notmuch-read-tag-changes tags "Tag thread")))) + (notmuch-tag (notmuch-show-get-messages-ids-search) tag-changes) (notmuch-show-mapc (lambda () (let* ((current-tags (notmuch-show-get-tags)) @@ -1756,15 +2039,21 @@ See `notmuch-tag' for information on the format of 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-add-tag (tag-changes) + "Change tags for the current message (defaulting to add). -(defun notmuch-show-remove-tag () - "Same as `notmuch-show-tag' but sets initial input to '-'." - (interactive) - (notmuch-show-tag "-")) +Same as `notmuch-show-tag' but sets initial input to '+'." + (interactive + (list (notmuch-read-tag-changes (notmuch-show-get-tags) "Tag message" "+"))) + (notmuch-show-tag tag-changes)) + +(defun notmuch-show-remove-tag (tag-changes) + "Change tags for the current message (defaulting to remove). + +Same as `notmuch-show-tag' but sets initial input to '-'." + (interactive + (list (notmuch-read-tag-changes (notmuch-show-get-tags) "Tag message" "-"))) + (notmuch-show-tag tag-changes)) (defun notmuch-show-toggle-visibility-headers () "Toggle the visibility of the current message headers." @@ -1784,8 +2073,11 @@ See `notmuch-tag' for information on the format of TAG-CHANGES." (not (plist-get props :message-visible)))) (force-window-update)) +(put 'notmuch-show-open-or-close-all 'notmuch-doc "Show all messages.") +(put 'notmuch-show-open-or-close-all 'notmuch-prefix-doc "Hide all messages.") (defun notmuch-show-open-or-close-all () "Set the visibility all of the messages in the current thread. + By default make all of the messages visible. With a prefix argument, hide all of the messages." (interactive) @@ -1815,7 +2107,7 @@ buffer. If PREVIOUS is non-nil, move to the previous item in the search results instead." (interactive "P") (let ((parent-buffer notmuch-show-parent-buffer)) - (notmuch-kill-this-buffer) + (notmuch-bury-or-kill-this-buffer) (when (buffer-live-p parent-buffer) (switch-to-buffer parent-buffer) (and (if previous @@ -1834,6 +2126,8 @@ search results instead." (interactive) (notmuch-show-next-thread t t)) +(put 'notmuch-show-archive-thread 'notmuch-prefix-doc + "Un-archive each message in thread.") (defun notmuch-show-archive-thread (&optional unarchive) "Archive each message in thread. @@ -1863,6 +2157,8 @@ buffer." (notmuch-show-archive-thread) (notmuch-show-next-thread)) +(put 'notmuch-show-archive-message 'notmuch-prefix-doc + "Un-archive the current message.") (defun notmuch-show-archive-message (&optional unarchive) "Archive the current message. @@ -1914,6 +2210,8 @@ thread from search." (interactive) (notmuch-common-do-stash (notmuch-show-get-from))) +(put 'notmuch-show-stash-message-id 'notmuch-prefix-doc + "Copy thread: query matching current thread to kill-ring.") (defun notmuch-show-stash-message-id (&optional stash-thread-id) "Copy id: query matching the current message to kill-ring. @@ -1953,16 +2251,19 @@ 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)))) + (let ((url (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-common-do-stash + (if (functionp url) + (funcall url (notmuch-show-get-message-id t)) + (concat url (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. @@ -1975,17 +2276,53 @@ the user (see `notmuch-show-stash-mlarchive-link-alist')." (notmuch-show-stash-mlarchive-link mla) (browse-url (current-kill 0 t))) +(defun notmuch-show-stash-git-helper (addresses prefix) + "Escape, trim, quote, and add PREFIX to each address in list of ADDRESSES, and return the result as a single string." + (mapconcat (lambda (x) + (concat prefix "\"" + ;; escape double-quotes + (replace-regexp-in-string + "\"" "\\\\\"" + ;; trim leading and trailing spaces + (replace-regexp-in-string + "\\(^ *\\| *$\\)" "" + x)) "\"")) + addresses " ")) + +(put 'notmuch-show-stash-git-send-email 'notmuch-prefix-doc + "Copy From/To/Cc of current message to kill-ring in a form suitable for pasting to git send-email command line.") + +(defun notmuch-show-stash-git-send-email (&optional no-in-reply-to) + "Copy From/To/Cc/Message-Id of current message to kill-ring in a form suitable for pasting to git send-email command line. + +If invoked with a prefix argument (or NO-IN-REPLY-TO is non-nil), +omit --in-reply-to=." + (interactive "P") + (notmuch-common-do-stash + (mapconcat 'identity + (remove "" + (list + (notmuch-show-stash-git-helper + (message-tokenize-header (notmuch-show-get-from)) "--to=") + (notmuch-show-stash-git-helper + (message-tokenize-header (notmuch-show-get-to)) "--to=") + (notmuch-show-stash-git-helper + (message-tokenize-header (notmuch-show-get-cc)) "--cc=") + (unless no-in-reply-to + (notmuch-show-stash-git-helper + (list (notmuch-show-get-message-id t)) "--in-reply-to=")))) + " "))) + ;; Interactive part functions and their helpers -(defun notmuch-show-generate-part-buffer (message-id nth) +(defun notmuch-show-generate-part-buffer (msg part) "Return a temporary buffer containing the specified part's content." (let ((buf (generate-new-buffer " *notmuch-part*")) (process-crypto notmuch-show-process-crypto)) (with-current-buffer buf - (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))) + ;; This is always used in the content of mm handles, which + ;; expect undecoded, binary part content. + (insert (notmuch-get-bodypart-binary msg part process-crypto))) buf)) (defun notmuch-show-current-part-handle () @@ -1993,14 +2330,13 @@ the user (see `notmuch-show-stash-mlarchive-link-alist')." This creates a temporary buffer for the part's content; the caller is responsible for killing this buffer as appropriate." - (let* ((part (notmuch-show-get-part-properties)) - (message-id (notmuch-show-get-message-id)) - (nth (plist-get part :id)) - (buf (notmuch-show-generate-part-buffer message-id nth)) - (content-type (plist-get part :content-type)) + (let* ((msg (notmuch-show-get-message-properties)) + (part (notmuch-show-get-part-properties)) + (buf (notmuch-show-generate-part-buffer msg part)) + (computed-type (plist-get part :computed-type)) (filename (plist-get part :filename)) (disposition (if filename `(attachment (filename . ,filename))))) - (mm-make-handle buf (list content-type) nil nil disposition))) + (mm-make-handle buf (list computed-type) nil nil disposition))) (defun notmuch-show-apply-to-current-part-handle (fn) "Apply FN to an mm-handle for the part containing point. @@ -2008,15 +2344,25 @@ caller is responsible for killing this buffer as appropriate." This ensures that the temporary buffer created for the mm-handle is destroyed when FN returns." (let ((handle (notmuch-show-current-part-handle))) + ;; emacs 24.3+ puts stdout/stderr into the calling buffer so we + ;; call it from a temp-buffer, unless + ;; notmuch-show-attachment-debug is non-nil in which case we put + ;; it in " *notmuch-part*". (unwind-protect - (funcall fn handle) + (if notmuch-show-attachment-debug + (with-current-buffer (generate-new-buffer " *notmuch-part*") + (funcall fn handle)) + (with-temp-buffer + (funcall fn handle))) (kill-buffer (mm-handle-buffer handle))))) (defun notmuch-show-part-button-default (&optional button) (interactive) (let ((button (or button (button-at (point))))) - (if (button-get button 'overlay) - (notmuch-show-toggle-part-invisibility button) + ;; Try to toggle the part, if that fails then call the default + ;; action. The toggle fails if the part has no emacs renderable + ;; content. + (unless (notmuch-show-toggle-part-invisibility button) (call-interactively notmuch-show-part-button-default-action)))) (defun notmuch-show-save-part () @@ -2043,3 +2389,5 @@ is destroyed when FN returns." (provide 'notmuch-show) + +;;; notmuch-show.el ends here