X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-show.el;h=939f8913f2508d5ff145bdbd6a1477fcf278fae4;hp=056c4e30abf0097435f6bd253ab7ec208a231a40;hb=HEAD;hpb=06a629826208358dc6448986a47423124d7e0479 diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el index 056c4e30..4c0ad74d 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 -*- lexical-binding: t -*- ;; ;; Copyright © Carl Worth ;; Copyright © David Edmondson @@ -23,10 +23,6 @@ ;;; Code: -(eval-when-compile - (require 'cl-lib) - (require 'pcase)) - (require 'mm-view) (require 'message) (require 'mm-decode) @@ -36,29 +32,36 @@ (require 'notmuch-lib) (require 'notmuch-tag) -(require 'notmuch-query) (require 'notmuch-wash) (require 'notmuch-mua) (require 'notmuch-crypto) (require 'notmuch-print) (require 'notmuch-draft) -(declare-function notmuch-call-notmuch-process "notmuch" (&rest args)) +(declare-function notmuch-call-notmuch-process "notmuch-lib" (&rest args)) (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-search-show-thread "notmuch") (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 unthreaded)) + open-target unthreaded parent-buffer)) (declare-function notmuch-tree-get-message-properties "notmuch-tree" nil) -(declare-function notmuch-unthreaded - (&optional query query-context target buffer-name open-target)) +(declare-function notmuch-unthreaded "notmuch-tree" + (&optional query query-context target buffer-name + open-target)) (declare-function notmuch-read-query "notmuch" (prompt)) (declare-function notmuch-draft-resume "notmuch-draft" (id)) +(defvar shr-blocked-images) +(defvar gnus-blocked-images) +(defvar shr-content-function) +(defvar w3m-ignored-image-url-regexp) + +;;; Options + (defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date") "Headers that should be shown in a message, in this order. @@ -80,6 +83,59 @@ visible for any given message." :type 'boolean :group 'notmuch-show) +(defcustom notmuch-show-header-line t + "Show a header line in notmuch show buffers. + +If t (the default), the header line will contain the current +message's subject. + +If a string, this value is interpreted as a format string to be +passed to `format-spec` with `%s` as the substitution variable +for the message's subject. E.g., to display the subject trimmed +to a maximum of 80 columns, you could use \"%>-80s\" as format. + +If you assign to this variable a function, it will be called with +the subject as argument, and the return value will be used as the +header line format. Since the function is called with the +message buffer as the current buffer, it is also possible to +access any other properties of the message, using for instance +notmuch-show functions such as +`notmuch-show-get-message-properties'. + +Finally, if this variable is set to nil, no header is +displayed." + :type '(choice (const :tag "No header" ni) + (const :tag "Subject" t) + (string :tag "Format") + (function :tag "Function")) + :group 'notmuch-show) + +(defcustom notmuch-show-depth-limit nil + "Depth beyond which message bodies are displayed lazily. + +If bound to an integer, any message with tree depth greater than +this will have its body display lazily, initially +inserting only a button. + +If this variable is set to nil (the default) no such lazy +insertion is done." + :type '(choice (const :tag "No limit" nil) + (number :tag "Limit" 10)) + :group 'notmuch-show) + +(defcustom notmuch-show-height-limit nil + "Height (from leaves) beyond which message bodies are displayed lazily. + +If bound to an integer, any message with height in the message +tree greater than this will have its body displayed lazily, +initially only a button. + +If this variable is set to nil (the default) no such lazy +display is done." + :type '(choice (const :tag "No limit" nil) + (number :tag "Limit" 10)) + :group 'notmuch-show) + (defcustom notmuch-show-relative-dates t "Display relative dates in the message summary line." :type 'boolean @@ -162,6 +218,8 @@ indentation." :type '(choice (const nil) regexp) :group 'notmuch-show) +;;; Variables + (defvar-local notmuch-show-thread-id nil) (defvar-local notmuch-show-parent-buffer nil) @@ -174,6 +232,8 @@ indentation." (defvar-local notmuch-show-indent-content t) +(defvar-local notmuch-show-single-message nil) + (defvar notmuch-show-attachment-debug nil "If t log stdout and stderr from attachment handlers. @@ -182,11 +242,13 @@ handlers is discarded. When set to t the stdout and stderr from each attachment handler is logged in buffers with names beginning \" *notmuch-part*\".") +;;; Options + (defcustom notmuch-show-stash-mlarchive-link-alist - '(("Gmane" . "https://mid.gmane.org/") - ("MARC" . "https://marc.info/?i=") + '(("MARC" . "https://marc.info/?i=") ("Mail Archive, The" . "https://mid.mail-archive.com/") - ("LKML" . "https://lkml.kernel.org/r/") + ("Lore" . "https://lore.kernel.org/r/") + ("Notmuch" . "https://nmbug.notmuchmail.org/nmweb/show/") ;; FIXME: can these services be searched by `Message-Id' ? ;; ("MarkMail" . "http://markmail.org/") ;; ("Nabble" . "http://nabble.com/") @@ -211,7 +273,7 @@ return the ML archive reference URI." (function :tag "Function returning the URL"))) :group 'notmuch-show) -(defcustom notmuch-show-stash-mlarchive-link-default "Gmane" +(defcustom notmuch-show-stash-mlarchive-link-default "MARC" "Default Mailing List Archive to use when stashing links. This is used when `notmuch-show-stash-mlarchive-link' isn't @@ -260,6 +322,8 @@ position of the message in the thread." :type 'boolean :group 'notmuch-show) +;;; Utilities + (defmacro with-current-notmuch-show-message (&rest body) "Evaluate body with current buffer set to the text of current message." `(save-excursion @@ -267,7 +331,7 @@ position of the message in the thread." (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)) + (notmuch--call-process notmuch-command nil t nil "show" "--format=raw" id)) ,@body) (kill-buffer buf))))) @@ -275,6 +339,8 @@ position of the message in the thread." "Enable Visual Line mode." (visual-line-mode t)) +;;; Commands + ;; 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. @@ -323,7 +389,7 @@ operation on the contents of the current buffer." (header (concat "Subject: " subject "\n" "To: " to "\n" - (if (not (string= cc "")) + (if (not (string-empty-p cc)) (concat "Cc: " cc "\n") "") "From: " from "\n" @@ -355,6 +421,8 @@ operation on the contents of the current buffer." (interactive) (notmuch-show-with-message-as-text 'notmuch-print-message)) +;;; Headers + (defun notmuch-show-fontify-header () (let ((face (cond ((looking-at "[Tt]o:") @@ -384,14 +452,19 @@ operation on the contents of the current buffer." (defun notmuch-show-update-tags (tags) "Update the displayed tags of the current message." (save-excursion - (goto-char (notmuch-show-message-top)) - (when (re-search-forward "(\\([^()]*\\))$" (line-end-position) t) - (let ((inhibit-read-only t)) - (replace-match (concat "(" - (notmuch-tag-format-tags - tags - (notmuch-show-get-prop :orig-tags)) - ")")))))) + (let ((inhibit-read-only t) + (start (notmuch-show-message-top)) + (depth (notmuch-show-get-prop :depth)) + (orig-tags (notmuch-show-get-prop :orig-tags)) + (props (notmuch-show-get-message-properties)) + (extent (notmuch-show-message-extent))) + (goto-char start) + (notmuch-show-insert-headerline props depth tags orig-tags) + (put-text-property start (1+ start) + :notmuch-message-properties props) + (put-text-property (car extent) (cdr extent) :notmuch-message-extent extent) + ;; delete original headerline, but do not save to kill ring + (delete-region (point) (1+ (line-end-position)))))) (defun notmuch-clean-address (address) "Try to clean a single email ADDRESS for display. Return a cons @@ -450,11 +523,29 @@ Return unchanged ADDRESS if parsing fails." ;; Otherwise format the name and address together. (concat p-name " <" p-address ">")))) -(defun notmuch-show-insert-headerline (headers date tags depth) +(defun notmuch-show--mark-height (tree) + "Calculate and cache height (distance from deepest descendent)" + (let* ((msg (car tree)) + (children (cadr tree)) + (cached-height (plist-get msg :height))) + (or cached-height + (let ((height + (if (null children) 0 + (1+ (apply #'max (mapcar #'notmuch-show--mark-height children)))))) + (plist-put msg :height height) + height)))) + +(defun notmuch-show-insert-headerline (msg-plist depth tags &optional orig-tags) "Insert a notmuch style headerline based on HEADERS for a message at DEPTH in the current thread." - (let ((start (point)) - (from (notmuch-sanitize + (let* ((start (point)) + (headers (plist-get msg-plist :headers)) + (duplicate (or (plist-get msg-plist :duplicate) 0)) + (file-count (length (plist-get msg-plist :filename))) + (date (or (and notmuch-show-relative-dates + (plist-get msg-plist :date_relative)) + (plist-get headers :Date))) + (from (notmuch-sanitize (notmuch-show-clean-address (plist-get headers :From))))) (when (string-match "\\cR" from) ;; If the From header has a right-to-left character add @@ -469,8 +560,15 @@ message at DEPTH in the current thread." " (" date ") (" - (notmuch-tag-format-tags tags tags) - ")\n") + (notmuch-tag-format-tags tags (or orig-tags tags)) + ")") + (insert + (if (> file-count 1) + (let ((txt (format "%d/%d\n" duplicate file-count))) + (concat + (notmuch-show-spaces-n (max 0 (- (window-width) (+ (current-column) (length txt))))) + txt)) + "\n")) (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face))) @@ -493,13 +591,15 @@ message at DEPTH in the current thread." (narrow-to-region start (point-max)) (run-hooks 'notmuch-show-markup-headers-hook))))) +;;; Parts + (define-button-type 'notmuch-show-part-button-type 'action 'notmuch-show-part-button-default 'follow-link t 'face 'message-mml :supertype 'notmuch-button-type) -(defun notmuch-show-insert-part-header (nth content-type declared-type +(defun notmuch-show-insert-part-header (_nth content-type declared-type &optional name comment) (let ((base-label (concat (and name (concat name ": ")) declared-type @@ -544,11 +644,27 @@ message at DEPTH in the current thread." (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)) + (let* ((part (plist-get properties :notmuch-part)) + (undisplayer (plist-get part :undisplayer)) + (mime-type (plist-get part :computed-type)) + (redisplay-data (button-get button + :notmuch-redisplay-data)) + (imagep (string-match "^image/" mime-type))) + (cond + ((and imagep (not show) undisplayer) + ;; call undisplayer thunk created by gnus. + (funcall undisplayer) + ;; there is an extra newline left + (delete-region + (+ 1 (button-end button)) + (+ 2 (button-end button)))) + ((and imagep show redisplay-data) + (notmuch-show-lazy-part redisplay-data button)) + (t + (overlay-put overlay 'invisible (not show))))) t))))))) -;; Part content ID handling +;;; Part content ID handling (defvar notmuch-show--cids nil "Alist from raw content ID to (MSG PART).") @@ -567,16 +683,17 @@ message at DEPTH in the current thread." ;; alternative (even if we can't render it). (push (list content-id msg part) notmuch-show--cids))) ;; Recurse on sub-parts - (pcase-let ((`(,content ,type) - (split-string (downcase (plist-get part :content-type)) "/"))) - (cond ((equal content "multipart") - (mapc (apply-partially #'notmuch-show--register-cids msg) - (plist-get part :content))) - ((and (equal content "message") - (equal type "rfc822")) - (notmuch-show--register-cids - msg - (car (plist-get (car (plist-get part :content)) :body))))))) + (when-let ((type (plist-get part :content-type))) + (pcase-let ((`(,type ,subtype) + (split-string (downcase type) "/"))) + (cond ((equal type "multipart") + (mapc (apply-partially #'notmuch-show--register-cids msg) + (plist-get part :content))) + ((and (equal type "message") + (equal subtype "rfc822")) + (notmuch-show--register-cids + msg + (car (plist-get (car (plist-get part :content)) :body)))))))) (defun notmuch-show--get-cid-content (cid) "Return a list (CID-content content-type) or nil. @@ -585,16 +702,13 @@ 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 (car descriptor)) - (part (cadr 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))))) + (when-let ((descriptor (cdr (assoc cid notmuch-show--cids)))) + (pcase-let ((`(,msg ,part) descriptor)) + ;; Request caching for this content, as some messages + ;; reference the same cid: part many times (hundreds!). + (list (notmuch-get-bodypart-binary + msg part notmuch-show-process-crypto 'cache) + (plist-get part :content-type))))) (defun notmuch-show-setup-w3m () "Instruct w3m how to retrieve content from a \"related\" part of a message." @@ -606,7 +720,7 @@ will return nil if the CID is unknown or cannot be retrieved." (setq mm-html-inhibit-images nil)) (defvar w3m-current-buffer) ;; From `w3m.el'. -(defun notmuch-show--cid-w3m-retrieve (url &rest args) +(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 @@ -622,7 +736,7 @@ will return nil if the CID is unknown or cannot be retrieved." (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 button) +(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)) @@ -641,7 +755,7 @@ will return nil if the CID is unknown or cannot be retrieved." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-multipart/related (msg part content-type nth depth button) +(defun notmuch-show-insert-part-multipart/related (msg part _content-type _nth depth _button) (let ((inner-parts (plist-get part :content)) (start (point))) ;; Render the primary part. FIXME: Support RFC 2387 Start header. @@ -654,7 +768,7 @@ will return nil if the CID is unknown or cannot be retrieved." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-multipart/signed (msg part content-type nth depth button) +(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. @@ -670,7 +784,7 @@ will return nil if the CID is unknown or cannot be retrieved." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-multipart/encrypted (msg part content-type nth depth button) +(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. @@ -688,10 +802,10 @@ will return nil if the CID is unknown or cannot be retrieved." (indent-rigidly start (point) 1))) t) -(defun notmuch-show-insert-part-application/pgp-encrypted (msg part content-type nth depth button) +(defun notmuch-show-insert-part-application/pgp-encrypted (_msg _part _content-type _nth _depth _button) t) -(defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth button) +(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. @@ -702,24 +816,26 @@ will return nil if the CID is unknown or cannot be retrieved." (indent-rigidly start (point) 1))) t) -(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))) - ;; Override `notmuch-message-headers' to force `From' to be - ;; displayed. - (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date"))) - (notmuch-show-insert-headers (plist-get message :headers))) - ;; Blank line after headers to be compatible with the normal - ;; message display. - (insert "\n") - ;; Show the body - (notmuch-show-insert-bodypart msg body depth) - (when notmuch-show-indent-multipart - (indent-rigidly start (point) 1))) - t) - -(defun notmuch-show-insert-part-text/plain (msg part content-type nth depth button) +(defun notmuch-show-insert-part-message/rfc822 (msg part _content-type _nth depth _button) + (let ((message (car (plist-get part :content)))) + (and + message + (let ((body (car (plist-get message :body))) + (start (point))) + ;; Override `notmuch-message-headers' to force `From' to be + ;; displayed. + (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date"))) + (notmuch-show-insert-headers (plist-get message :headers))) + ;; Blank line after headers to be compatible with the normal + ;; message display. + (insert "\n") + ;; Show the body + (notmuch-show-insert-bodypart msg body depth) + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1)) + t)))) + +(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. @@ -733,7 +849,7 @@ will return nil if the CID is unknown or cannot be retrieved." (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 button) +(defun notmuch-show-insert-part-text/calendar (msg part _content-type _nth _depth _button) (insert (with-temp-buffer (insert (notmuch-get-bodypart-text msg part notmuch-show-process-crypto)) ;; notmuch-get-bodypart-text does no newline conversion. @@ -757,8 +873,8 @@ will return nil if the CID is unknown or cannot be retrieved." t) ;; For backwards compatibility. -(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-insert-part-text/x-vcalendar (msg part _content-type _nth depth _button) + (notmuch-show-insert-part-text/calendar msg part nil nil depth nil)) (when (version< emacs-version "25.3") ;; https://bugs.gnu.org/28350 @@ -774,7 +890,7 @@ will return nil if the CID is unknown or cannot be retrieved." ;; the first time). (require 'enriched) (cl-letf (((symbol-function 'enriched-decode-display-prop) - (lambda (start end &optional param) (list start end)))) + (lambda (start end &optional _param) (list start end)))) (notmuch-show-insert-part-*/* msg part content-type nth depth button)))) (defun notmuch-show-get-mime-type-of-application/octet-stream (part) @@ -808,10 +924,12 @@ will return nil if the CID is unknown or cannot be retrieved." (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)) + (gnus-blocked-images notmuch-show-text/html-blocked-images) + (w3m-ignored-image-url-regexp 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 +;;; Functions used by notmuch-show--insert-part-text/html-shr + (declare-function libxml-parse-html-region "xml.c") (declare-function shr-insert-document "shr") @@ -831,12 +949,12 @@ will return nil if the CID is unknown or cannot be retrieved." (shr-insert-document dom) t)) -(defun notmuch-show-insert-part-*/* (msg part content-type nth depth button) +(defun notmuch-show-insert-part-*/* (msg part content-type _nth _depth _button) ;; This handler _must_ succeed - it is the handler of last resort. (notmuch-mm-display-part-inline msg part content-type notmuch-show-process-crypto) t) -;; Functions for determining how to handle MIME parts. +;;; Functions for determining how to handle MIME parts. (defun notmuch-show-handlers-for (content-type) "Return a list of content handlers for a part of type CONTENT-TYPE." @@ -852,7 +970,7 @@ will return nil if the CID is unknown or cannot be retrieved." (intern (concat "notmuch-show-insert-part-" content-type)))) result)) -;; +;;; Parts (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth button) ;; Run the handlers until one of them succeeds. @@ -917,10 +1035,13 @@ will return nil if the CID is unknown or cannot be retrieved." (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))) + (depth (notmuch-show-get-depth)) + (mime-type (plist-get (cadr part-args) :computed-type))) (save-restriction (narrow-to-region part-beg part-end) (delete-region part-beg part-end) + (when (and mime-type (string-match "^image/" mime-type)) + (button-put button :notmuch-redisplay-data part-args)) (apply #'notmuch-show-insert-bodypart-internal part-args) (indent-rigidly part-beg part-end @@ -936,7 +1057,8 @@ will return nil if the CID is unknown or cannot be retrieved." (defun notmuch-show-mime-type (part) "Return the correct mime-type to use for PART." - (let ((content-type (downcase (plist-get part :content-type)))) + (when-let ((content-type (plist-get part :content-type))) + (setq content-type (downcase 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") @@ -951,13 +1073,13 @@ 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) +(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) +(defun notmuch-show-reply-insert-header-p-never (_part _hide) nil) (defun notmuch-show-reply-insert-header-p-trimmed (part hide) @@ -976,32 +1098,45 @@ 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))) + (let* ((content-type (plist-get part :content-type)) (mime-type (notmuch-show-mime-type part)) (nth (plist-get part :id)) + (height (plist-get msg :height)) (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))) + (deep (and notmuch-show-depth-limit + (> depth notmuch-show-depth-limit))) + (high (and notmuch-show-height-limit + (> height notmuch-show-height-limit))) (beg (point)) ;; This default header-p function omits the part button for ;; the first (or only) part if this is text/plain. - (button (and (funcall notmuch-show-insert-header-p-function part hide) + (button (and (or deep long high + (funcall notmuch-show-insert-header-p-function part hide)) (notmuch-show-insert-part-header - nth mime-type content-type + nth mime-type + (and content-type (downcase content-type)) (plist-get part :filename)))) - ;; Hide the part initially if HIDE is t, or if it is too long + ;; Hide the part initially if HIDE is t, or if it is too long/deep ;; and we have a button to allow toggling. (show-part (not (or (equal hide t) + (and deep button) + (and high button) (and long button)))) - (content-beg (point))) + (content-beg (point)) + (part-data (list msg part mime-type nth depth button))) ;; 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) + (cond + (show-part + (apply #'notmuch-show-insert-bodypart-internal part-data) + (when (and button (string-match "^image/" mime-type)) + (button-put button :notmuch-redisplay-data part-data))) + (t (when button - (button-put button :notmuch-lazy-part - (list msg part mime-type nth depth button)))) + (button-put button :notmuch-lazy-part part-data)))) ;; 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)) @@ -1033,6 +1168,40 @@ is t, hide the part initially and show the button." (defvar notmuch-show-previous-subject "") (make-variable-buffer-local 'notmuch-show-previous-subject) +(defun notmuch-show-choose-duplicate (duplicate) + "Display message file with index DUPLICATE in place of the current one. + +Message file indices are based on the order the files are +discovered by `notmuch new' (and hence are somewhat arbitrary), +and correspond to those passed to the \"\\-\\-duplicate\" arguments +to the CLI. + +When called interactively, the function will prompt for the index +of the file to display. An error will be signaled if the index +is out of range." + (interactive "Nduplicate: ") + (let ((count (length (notmuch-show-get-prop :filename)))) + (when (or (> duplicate count) + (< duplicate 1)) + (error "Duplicate %d out of range [1,%d]" duplicate count))) + (notmuch-show-move-to-message-top) + (save-excursion + (let* ((extent (notmuch-show-message-extent)) + (id (notmuch-show-get-message-id)) + (depth (notmuch-show-get-depth)) + (inhibit-read-only t) + (new-msg (notmuch--run-show (list id) duplicate))) + ;; clean up existing overlays to avoid extending them. + (dolist (o (overlays-in (car extent) (cdr extent))) + (delete-overlay o)) + ;; pretend insertion is happening at end of buffer + (narrow-to-region (point-min) (car extent)) + ;; Insert first, then delete, to avoid marker for start of next + ;; message being in same place as the start of this one. + (notmuch-show-insert-msg new-msg depth) + (widen) + (delete-region (point) (cdr extent))))) + (defun notmuch-show-insert-msg (msg depth) "Insert the message MSG at depth DEPTH in the current thread." (let* ((headers (plist-get msg :headers)) @@ -1043,11 +1212,7 @@ is t, hide the part initially and show the button." headers-start headers-end (bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))) (setq message-start (point-marker)) - (notmuch-show-insert-headerline headers - (or (and notmuch-show-relative-dates - (plist-get msg :date_relative)) - (plist-get headers :Date)) - (plist-get msg :tags) depth) + (notmuch-show-insert-headerline msg depth (plist-get msg :tags)) (setq content-start (point-marker)) ;; Set `headers-start' to point after the 'Subject:' header to be ;; compatible with the existing implementation. This just sets it @@ -1098,6 +1263,8 @@ is t, hide the part initially and show the button." (notmuch-show-message-visible msg (and (plist-get msg :match) (not (plist-get msg :excluded)))))) +;;; Toggle commands + (defun notmuch-show-toggle-process-crypto () "Toggle the processing of cryptographic MIME parts." (interactive) @@ -1126,12 +1293,15 @@ is t, hide the part initially and show the button." "Content is not indented.")) (notmuch-show-refresh-view)) +;;; Main insert functions + (defun notmuch-show-insert-tree (tree depth) "Insert the message tree TREE at depth DEPTH in the current thread." (let ((msg (car tree)) (replies (cadr tree))) ;; We test whether there is a message or just some replies. (when msg + (notmuch-show--mark-height tree) (notmuch-show-insert-msg msg depth)) (notmuch-show-insert-thread replies (1+ depth)))) @@ -1143,6 +1313,8 @@ is t, hide the part initially and show the button." "Insert the forest of threads FOREST." (mapc (lambda (thread) (notmuch-show-insert-thread thread 0)) forest)) +;;; Link buttons + (defvar notmuch-id-regexp (concat ;; Match the id: prefix only if it begins a word (to disallow, for @@ -1203,6 +1375,8 @@ buttons for a corresponding notmuch search." 'help-echo "Mouse-1, RET: search for this message" 'face goto-address-mail-face))))) +;;; Show command + ;;;###autoload (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. @@ -1229,14 +1403,8 @@ matched." (let ((buffer-name (generate-new-buffer-name (or buffer-name (concat "*notmuch-" thread-id "*")))) - ;; We override mm-inline-override-types to stop application/* - ;; parts from being displayed unless the user has customized - ;; it themselves. - (mm-inline-override-types - (if (equal mm-inline-override-types - (eval (car (get 'mm-inline-override-types 'standard-value)))) - (cons "application/*" mm-inline-override-types) - mm-inline-override-types))) + (mm-inline-override-types (notmuch--inline-override-types))) + (pop-to-buffer-same-window (get-buffer-create buffer-name)) ;; No need to track undo information for this buffer. (setq buffer-undo-list t) @@ -1284,6 +1452,18 @@ fallback if the prior matches no messages." (push (list thread "and (" context ")") queries)) queries)) +(defun notmuch-show--header-line-format () + "Compute the header line format of a notmuch-show buffer." + (when notmuch-show-header-line + (let* ((s (notmuch-sanitize + (notmuch-show-strip-re (notmuch-show-get-subject)))) + (subject (replace-regexp-in-string "%" "%%" s))) + (cond ((stringp notmuch-show-header-line) + (format-spec notmuch-show-header-line `((?s . ,subject)))) + ((functionp notmuch-show-header-line) + (funcall notmuch-show-header-line subject)) + (notmuch-show-header-line subject))))) + (defun notmuch-show--build-buffer (&optional state) "Display messages matching the current buffer context. @@ -1291,9 +1471,10 @@ Apply the previously saved STATE if supplied, otherwise show the first relevant message. If no messages match the query return NIL." - (let* ((cli-args (cons "--exclude=false" - (and notmuch-show-elide-non-matching-messages - (list "--entire-thread=false")))) + (let* ((cli-args (list "--exclude=false")) + (cli-args (if notmuch-show-elide-non-matching-messages (cons "--entire-thread=false" cli-args) cli-args)) + ;; "part 0 is the whole message (headers and body)" notmuch-show(1) + (cli-args (if notmuch-show-single-message (cons "--part=0" cli-args) cli-args)) (queries (notmuch-show--build-queries notmuch-show-thread-id notmuch-show-query-context)) (forest nil) @@ -1302,8 +1483,10 @@ If no messages match the query return NIL." (notmuch-show-previous-subject "")) ;; Use results from the first query that returns some. (while (and (not forest) queries) - (setq forest (notmuch-query-get-threads + (setq forest (notmuch--run-show (append cli-args (list "'") (car queries) (list "'")))) + (when (and forest notmuch-show-single-message) + (setq forest (list (list (list forest))))) (setq queries (cdr queries))) (when forest (notmuch-show-insert-forest forest) @@ -1311,12 +1494,7 @@ If no messages match the query return NIL." ;; display changes. (notmuch-show-mapc (lambda () (notmuch-show-set-prop :orig-tags (notmuch-show-get-tags)))) - ;; 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))))) + (setq header-line-format (notmuch-show--header-line-format)) (run-hooks 'notmuch-show-hook) (if state (notmuch-show-apply-state state) @@ -1325,6 +1503,8 @@ If no messages match the query return NIL." ;; Report back to the caller whether any messages matched. forest)) +;;; Refresh command + (defun notmuch-show-capture-state () "Capture the state of the current buffer. @@ -1386,6 +1566,7 @@ non-nil) then the state of the buffer (open/closed messages) is reset based on the original query." (interactive "P") (let ((inhibit-read-only t) + (mm-inline-override-types (notmuch--inline-override-types)) (state (unless reset-state (notmuch-show-capture-state)))) ;; `erase-buffer' does not seem to remove overlays, which can lead @@ -1399,6 +1580,8 @@ reset based on the original query." (ding) (message "Refreshing the buffer resulted in no messages!")))) +;;; Keymaps + (defvar notmuch-show-stash-map (let ((map (make-sparse-keymap))) (define-key map "c" 'notmuch-show-stash-cc) @@ -1472,6 +1655,7 @@ reset based on the original query." (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-choose-duplicate) (define-key map "<" 'notmuch-show-toggle-thread-indentation) (define-key map "t" 'toggle-truncate-lines) (define-key map "." 'notmuch-show-part-map) @@ -1479,6 +1663,8 @@ reset based on the original query." map) "Keymap for \"notmuch show\" buffers.") +;;; Mode + (define-derived-mode notmuch-show-mode fundamental-mode "notmuch-show" "Major mode for viewing a thread with notmuch. @@ -1515,6 +1701,8 @@ All currently available key bindings: (setq imenu-extract-index-name-function #'notmuch-show-imenu-extract-index-name-function)) +;;; Tree commands + (defun notmuch-tree-from-show-current-query () "Call notmuch tree with the current query." (interactive) @@ -1529,17 +1717,14 @@ All currently available key bindings: notmuch-show-query-context (notmuch-show-get-message-id))) +;;; Movement related functions. + (defun notmuch-show-move-to-message-top () (goto-char (notmuch-show-message-top))) (defun notmuch-show-move-to-message-bottom () (goto-char (notmuch-show-message-bottom))) -(defun notmuch-show-message-adjust () - (recenter 0)) - -;; Movement related functions. - ;; There's some strangeness here where a text property applied to a ;; region a->b is not found when point is at b. We walk backwards ;; until finding the property. @@ -1583,8 +1768,7 @@ effects." (cl-loop do (funcall function) while (notmuch-show-goto-message-next)))) -;; Functions relating to the visibility of messages and their -;; components. +;;; Functions relating to the visibility of messages and their components. (defun notmuch-show-message-visible (props visible-p) (overlay-put (plist-get props :message-overlay) 'invisible (not visible-p)) @@ -1594,8 +1778,7 @@ effects." (overlay-put (plist-get props :headers-overlay) 'invisible (not visible-p)) (notmuch-show-set-prop :headers-visible visible-p props)) -;; Functions for setting and getting attributes of the current -;; message. +;;; Functions for setting and getting attributes of the current message. (defun notmuch-show-set-message-properties (props) (save-excursion @@ -1636,13 +1819,13 @@ 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 - (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))) + (plist-get (or props + (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))) + prop)) (defun notmuch-show-get-message-id (&optional bare) "Return an id: query for the Message-Id of the current message. @@ -1667,10 +1850,10 @@ current thread." ;; dme: Would it make sense to use a macro for many of these? -;; XXX TODO figure out what to do about multiple filenames (defun notmuch-show-get-filename () "Return the filename of the current message." - (car (notmuch-show-get-prop :filename))) + (let ((duplicate (notmuch-show-get-duplicate))) + (nth (1- duplicate) (notmuch-show-get-prop :filename)))) (defun notmuch-show-get-header (header &optional props) "Return the named header of the current message, if any." @@ -1682,6 +1865,10 @@ current thread." (defun notmuch-show-get-date () (notmuch-show-get-header :Date)) +(defun notmuch-show-get-duplicate () + ;; if no duplicate property exists, assume first file + (or (notmuch-show-get-prop :duplicate) 1)) + (defun notmuch-show-get-timestamp () (notmuch-show-get-prop :timestamp)) @@ -1729,7 +1916,7 @@ 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) +(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 @@ -1747,7 +1934,7 @@ user decision and we should not override it." ;; We need to redisplay to get window-start and window-end correct. (redisplay) (save-excursion - (condition-case err + (condition-case nil (funcall notmuch-show-mark-read-function (window-start) (window-end)) ((debug error) (unless notmuch-show--seen-has-errored @@ -1764,12 +1951,11 @@ user decision and we should not override it." 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)) + (setq notmuch-show-query-context (if (string-empty-p 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. +;;; Functions for getting attributes of several messages in the current thread. (defun notmuch-show-get-message-ids-for-open-messages () "Return a list of all id: queries for open messages in the current thread." @@ -1783,7 +1969,7 @@ Reshows the current thread with matches defined by the new query-string." (setq done (not (notmuch-show-goto-message-next)))) message-ids))) -;; Commands typically bound to keys. +;;; Commands typically bound to keys. (defun notmuch-show-advance () "Advance through thread. @@ -1877,13 +2063,15 @@ any effects from previous calls to (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)) + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender t + (notmuch-show-get-prop :duplicate))) (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)) + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender nil + (notmuch-show-get-prop :duplicate))) (put 'notmuch-show-forward-message 'notmuch-prefix-doc "... and prompt for sender") @@ -1911,6 +2099,9 @@ any effects from previous calls to (message-resend addresses) (notmuch-bury-or-kill-this-buffer))) +(defun notmuch-show-message-adjust () + (recenter 0)) + (defun notmuch-show-next-message (&optional pop-at-end) "Show the next message. @@ -1991,12 +2182,16 @@ to show, nil otherwise." "View the original source of the current message." (interactive) (let* ((id (notmuch-show-get-message-id)) - (buf (get-buffer-create (concat "*notmuch-raw-" id "*"))) + (duplicate (notmuch-show-get-duplicate)) + (args (if (> duplicate 1) + (list (format "--duplicate=%d" duplicate) id) + (list id))) + (buf (get-buffer-create (format "*notmuch-raw-%s-%d*" id duplicate))) (inhibit-read-only t)) (pop-to-buffer-same-window buf) (erase-buffer) (let ((coding-system-for-read 'no-conversion)) - (call-process notmuch-command nil t nil "show" "--format=raw" id)) + (apply #'notmuch--call-process notmuch-command nil t nil "show" "--format=raw" args)) (goto-char (point-min)) (set-buffer-modified-p nil) (setq buffer-read-only t) @@ -2025,7 +2220,7 @@ 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)))) + (list current-prefix-arg (read-shell-command query-string)))) (let (shell-command) (if entire-thread (setq shell-command @@ -2042,19 +2237,19 @@ message." (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) - (setq buffer-read-only t) - (unless (zerop exit-code) - (pop-to-buffer buf) - (message (format "Command '%s' exited abnormally with code %d" - shell-command exit-code)))))))) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (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) + (unless (zerop exit-code) + (pop-to-buffer buf) + (message (format "Command '%s' exited abnormally with code %d" + shell-command exit-code))))))))) (defun notmuch-show-tag-message (&rest tag-changes) "Change tags for the current message. @@ -2161,7 +2356,9 @@ argument, hide all of the messages." If SHOW is non-nil, open the next item in a show buffer. Otherwise just highlight the next item in the search buffer. If PREVIOUS is non-nil, move to the previous item in the -search results instead." +search results instead. + +Return non-nil on success." (interactive "P") (let ((parent-buffer notmuch-show-parent-buffer)) (notmuch-bury-or-kill-this-buffer) @@ -2310,10 +2507,12 @@ kill-ring." (defun notmuch-show-stash-mlarchive-link (&optional mla) "Copy an ML Archive URI for the current message to the kill-ring. -This presumes that the message is available at the selected Mailing List Archive. +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')." +If optional argument MLA is non-nil, use the provided key instead +of prompting the user (see +`notmuch-show-stash-mlarchive-link-alist')." (interactive) (let ((url (cdr (assoc (or mla @@ -2330,12 +2529,15 @@ the user (see `notmuch-show-stash-mlarchive-link-alist')." (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. + "Copy an ML Archive URI for the current message to the + kill-ring and visit it. -This presumes that the message is available at the selected Mailing List Archive. +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')." +If optional argument MLA is non-nil, use the provided key instead +of prompting the user (see +`notmuch-show-stash-mlarchive-link-alist')." (interactive) (notmuch-show-stash-mlarchive-link mla) (browse-url (current-kill 0 t))) @@ -2381,7 +2583,7 @@ omit --in-reply-to=." (list (notmuch-show-get-message-id t)) "--in-reply-to=")))) " "))) -;; Interactive part functions and their helpers +;;; Interactive part functions and their helpers (defun notmuch-show-generate-part-buffer (msg part) "Return a temporary buffer containing the specified part's content." @@ -2528,6 +2730,8 @@ browsing." (funcall fn (completing-read prompt urls nil nil nil nil (car urls))) (message "No URLs found.")))) +;;; _ + (provide 'notmuch-show) ;;; notmuch-show.el ends here