-;;; notmuch-show.el --- displaying notmuch forests
+;;; notmuch-show.el --- displaying notmuch forests -*- lexical-binding: t -*-
;;
;; Copyright © Carl Worth
;; Copyright © David Edmondson
;;; Code:
-(eval-when-compile
- (require 'cl-lib)
- (require 'pcase))
-
(require 'mm-view)
(require 'message)
(require 'mm-decode)
(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.
: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
:type '(choice (const nil) regexp)
:group 'notmuch-show)
-(defvar notmuch-show-thread-id nil)
-(make-variable-buffer-local 'notmuch-show-thread-id)
+;;; Variables
+
+(defvar-local notmuch-show-thread-id nil)
-(defvar notmuch-show-parent-buffer nil)
-(make-variable-buffer-local 'notmuch-show-parent-buffer)
+(defvar-local notmuch-show-parent-buffer nil)
-(defvar notmuch-show-query-context nil)
-(make-variable-buffer-local 'notmuch-show-query-context)
+(defvar-local notmuch-show-query-context nil)
-(defvar notmuch-show-process-crypto nil)
-(make-variable-buffer-local 'notmuch-show-process-crypto)
+(defvar-local notmuch-show-process-crypto nil)
-(defvar notmuch-show-elide-non-matching-messages nil)
-(make-variable-buffer-local 'notmuch-show-elide-non-matching-messages)
+(defvar-local notmuch-show-elide-non-matching-messages nil)
-(defvar notmuch-show-indent-content t)
-(make-variable-buffer-local 'notmuch-show-indent-content)
+(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.
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/")
(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
: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
(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)))))
"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.
(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"
(interactive)
(notmuch-show-with-message-as-text 'notmuch-print-message))
+;;; Headers
+
(defun notmuch-show-fontify-header ()
(let ((face (cond
((looking-at "[Tt]o:")
(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
;; 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
" ("
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)))
(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
(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).")
;; 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 (car ctype) "multipart")
- (mapc (apply-partially #'notmuch-show--register-cids msg)
- (plist-get part :content)))
- ((equal ctype '("message" "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.
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."
(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
(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))
(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.
(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.
(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.
(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.
(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.
(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.
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
;; 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)
(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")
(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."
(push func result)))
;; Reverse order of prefrence.
(list (intern (concat "notmuch-show-insert-part-*/*"))
- (intern (concat
- "notmuch-show-insert-part-"
- (car (notmuch-split-content-type content-type))
- "/*"))
+ (intern (concat "notmuch-show-insert-part-"
+ (car (split-string content-type "/"))
+ "/*"))
(intern (concat "notmuch-show-insert-part-" content-type))))
result))
-;; \f
+;;; Parts
(defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth button)
;; Run the handlers until one of them succeeds.
(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")
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)
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)))
;; Store the computed mime-type for later use (e.g. by attachment handlers).
(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))
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
(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)
"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))))
"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
'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.
(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)
(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.
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)
(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)
;; 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)
;; Report back to the caller whether any messages matched.
forest))
+;;; Refresh command
+
(defun notmuch-show-capture-state ()
"Capture the state of the current buffer.
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
(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)
(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)
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.
(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)
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.
(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))
(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
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.
;; 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."
(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))
(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
;; 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
- (setq notmuch-show--seen-has-errored 't)
+ (setq notmuch-show--seen-has-errored t)
(setq header-line-format
(concat header-line-format
(propertize
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."
(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.
(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")
(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.
"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)
(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
(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.
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)
(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."
+ "Normalize all ADDRESSES while adding 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
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.")
+ "Copy From/To/Cc of current message to kill-ring.
+Use 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.
+ "Copy From/To/Cc/Message-Id of current message to kill-ring.
+Use 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=<Message-Id>."
(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."
(funcall fn (completing-read prompt urls nil nil nil nil (car urls)))
(message "No URLs found."))))
+;;; _
+
(provide 'notmuch-show)
;;; notmuch-show.el ends here