commit - 8dd97a29c4e177335407ad098bf917d0552212e3
commit + ef05f544dc71c86ff6ce21d2114ced1e19e78e9a
blob - /dev/null
blob + 79d2a1b7f03db509b95705b1701fa601cf7987ca (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/coolj.el
+;;; coolj.el --- automatically wrap long lines -*- lexical-binding: t; coding: utf-8 -*-
+
+;; Copyright (C) 2000, 2001, 2004-2009 Free Software Foundation, Inc.
+
+;; Authors: Kai Grossjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>
+;; Alex Schroeder <alex@gnu.org>
+;; Chong Yidong <cyd@stupidchicken.com>
+;; Maintainer: David Edmondson <dme@dme.org>
+;; Keywords: convenience, wp
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is a simple derivative of some functionality from
+;; `longlines.el'. The key difference is that this version will
+;; insert a prefix at the head of each wrapped line. The prefix is
+;; calculated from the originating long line.
+
+;; No minor-mode is provided, the caller is expected to call
+;; `coolj-wrap-region' to wrap the region of interest.
+
+;;; Code:
+
+(defgroup coolj nil
+ "Wrapping of long lines with prefix."
+ :group 'fill)
+
+(defcustom coolj-wrap-follows-window-size t
+ "Non-nil means wrap text to the window size.
+Otherwise respect `fill-column'."
+ :group 'coolj
+ :type 'boolean)
+
+(defcustom coolj-line-prefix-regexp "^\\(>+ ?\\)*"
+ "Regular expression that matches line prefixes."
+ :group 'coolj
+ :type 'regexp)
+
+(defvar-local coolj-wrap-point nil)
+
+(defun coolj-determine-prefix ()
+ "Determine the prefix for the current line."
+ (save-excursion
+ (beginning-of-line)
+ (if (re-search-forward coolj-line-prefix-regexp nil t)
+ (buffer-substring (match-beginning 0) (match-end 0))
+ "")))
+
+(defun coolj-wrap-buffer ()
+ "Wrap the current buffer."
+ (coolj-wrap-region (point-min) (point-max)))
+
+(defun coolj-wrap-region (beg end)
+ "Wrap each successive line, starting with the line before BEG.
+Stop when we reach lines after END that don't need wrapping, or the
+end of the buffer."
+ (setq fill-column (if coolj-wrap-follows-window-size
+ (window-width)
+ fill-column))
+ (let ((mod (buffer-modified-p)))
+ (setq coolj-wrap-point (point))
+ (goto-char beg)
+ (forward-line -1)
+ ;; Two successful coolj-wrap-line's in a row mean successive
+ ;; lines don't need wrapping.
+ (while (null (and (coolj-wrap-line)
+ (or (eobp)
+ (and (>= (point) end)
+ (coolj-wrap-line))))))
+ (goto-char coolj-wrap-point)
+ (set-buffer-modified-p mod)))
+
+(defun coolj-wrap-line ()
+ "If the current line needs to be wrapped, wrap it and return nil.
+If wrapping is performed, point remains on the line. If the line does
+not need to be wrapped, move point to the next line and return t."
+ (let ((prefix (coolj-determine-prefix)))
+ (if (coolj-set-breakpoint prefix)
+ (progn
+ (insert-before-markers ?\n)
+ (backward-char 1)
+ (delete-char -1)
+ (forward-char 1)
+ (insert-before-markers prefix)
+ nil)
+ (forward-line 1)
+ t)))
+
+(defun coolj-set-breakpoint (prefix)
+ "Place point where we should break the current line, and return t.
+If the line should not be broken, return nil; point remains on the
+line."
+ (move-to-column fill-column)
+ (and (re-search-forward "[^ ]" (line-end-position) 1)
+ (> (current-column) fill-column)
+ ;; This line is too long. Can we break it?
+ (or (coolj-find-break-backward prefix)
+ (progn (move-to-column fill-column)
+ (coolj-find-break-forward)))))
+
+(defun coolj-find-break-backward (prefix)
+ "Move point backward to the first available breakpoint and return t.
+If no breakpoint is found, return nil."
+ (let ((end-of-prefix (+ (line-beginning-position) (length prefix))))
+ (and (search-backward " " end-of-prefix 1)
+ (save-excursion
+ (skip-chars-backward " " end-of-prefix)
+ (null (bolp)))
+ (progn (forward-char 1)
+ (if (and fill-nobreak-predicate
+ (run-hook-with-args-until-success
+ 'fill-nobreak-predicate))
+ (progn (skip-chars-backward " " end-of-prefix)
+ (coolj-find-break-backward prefix))
+ t)))))
+
+(defun coolj-find-break-forward ()
+ "Move point forward to the first available breakpoint and return t.
+If no break point is found, return nil."
+ (and (search-forward " " (line-end-position) 1)
+ (progn (skip-chars-forward " " (line-end-position))
+ (null (eolp)))
+ (if (and fill-nobreak-predicate
+ (run-hook-with-args-until-success
+ 'fill-nobreak-predicate))
+ (coolj-find-break-forward)
+ t)))
+
+(provide 'coolj)
+
+;;; coolj.el ends here
blob - /dev/null
blob + 8c9e0a27e988abf1e1da9d1230ea702c856bcdf7 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/make-deps.el
+;;; make-deps.el --- compute make dependencies for Elisp sources -*- lexical-binding: t -*-
+;;
+;; Copyright © Austin Clements
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Austin Clements <aclements@csail.mit.edu>
+
+;;; Code:
+
+(defun batch-make-deps ()
+ "Invoke `make-deps' for each file on the command line."
+ (setq debug-on-error t)
+ (dolist (file command-line-args-left)
+ (let ((default-directory command-line-default-directory))
+ (find-file-literally file))
+ (make-deps command-line-default-directory))
+ (kill-emacs))
+
+(defun make-deps (&optional dir)
+ "Print make dependencies for the current buffer.
+
+This prints make dependencies to `standard-output' based on the
+top-level `require' expressions in the current buffer. Paths in
+rules will be given relative to DIR, or `default-directory'."
+ (unless dir
+ (setq dir default-directory))
+ (save-excursion
+ (goto-char (point-min))
+ (condition-case nil
+ (while t
+ (let ((form (read (current-buffer))))
+ ;; Is it a (require 'x) form?
+ (when (and (listp form) (= (length form) 2)
+ (eq (car form) 'require)
+ (listp (cadr form)) (= (length (cadr form)) 2)
+ (eq (car (cadr form)) 'quote)
+ (symbolp (cadr (cadr form))))
+ ;; Find the required library
+ (let* ((name (cadr (cadr form)))
+ (fname (locate-library (symbol-name name))))
+ ;; Is this file and the library in the same directory?
+ ;; If not, assume it's a system library and don't
+ ;; bother depending on it.
+ (when (and fname
+ (string= (file-name-directory (buffer-file-name))
+ (file-name-directory fname)))
+ ;; Print the dependency
+ (princ (format "%s.elc: %s.elc\n"
+ (file-name-sans-extension
+ (file-relative-name (buffer-file-name) dir))
+ (file-name-sans-extension
+ (file-relative-name fname dir)))))))))
+ (end-of-file nil))))
+
+;;; make-deps.el ends here
blob - /dev/null
blob + 1a4cdda22b95ffee9434b589f0912700b8c22b02 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-address.el
+;;; notmuch-address.el --- address completion with notmuch -*- lexical-binding: t -*-
+;;
+;; Copyright © David Edmondson
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+;;; Code:
+
+(require 'message)
+(require 'notmuch-parser)
+(require 'notmuch-lib)
+(require 'notmuch-company)
+
+(declare-function company-manual-begin "company")
+
+;;; Cache internals
+
+(defvar notmuch-address-last-harvest 0
+ "Time of last address harvest.")
+
+(defvar notmuch-address-completions (make-hash-table :test 'equal)
+ "Hash of email addresses for completion during email composition.
+This variable is set by calling `notmuch-address-harvest'.")
+
+(defvar notmuch-address-full-harvest-finished nil
+ "Whether full completion address harvesting has finished.
+Use `notmuch-address--harvest-ready' to access as that will load
+a saved hash if necessary (and available).")
+
+(defun notmuch-address--harvest-ready ()
+ "Return t if there is a full address hash available.
+
+If the hash is not present it attempts to load a saved hash."
+ (or notmuch-address-full-harvest-finished
+ (notmuch-address--load-address-hash)))
+
+;;; Options
+
+(defcustom notmuch-address-command 'internal
+ "Determines how address completion candidates are generated.
+
+If this is a string, then that string should be an external
+program, which must take a single argument (searched string)
+and output a list of completion candidates, one per line.
+
+If this is the symbol `internal', then an implementation is used
+that relies on the \"notmuch address\" command, but does not use
+any third-party (i.e. \"external\") programs.
+
+If this is the symbol `as-is', then Notmuch does not modify the
+value of `message-completion-alist'. This option has to be set to
+this value before `notmuch' is loaded, otherwise the modification
+to `message-completion-alist' may already have taken place. This
+setting obviously does not prevent `message-completion-alist'
+from being modified at all; the user or some third-party package
+may still modify it.
+
+Finally, if this is nil, then address completion is disabled."
+ :type '(radio
+ (const :tag "Use internal address completion" internal)
+ (string :tag "Use external completion command")
+ (const :tag "Disable address completion" nil)
+ (const :tag "Use default or third-party mechanism" as-is))
+ :group 'notmuch-send
+ :group 'notmuch-address
+ :group 'notmuch-external)
+
+(defcustom notmuch-address-internal-completion '(sent nil)
+ "Determines how internal address completion generates candidates.
+
+This should be a list of the form (DIRECTION FILTER), where
+DIRECTION is either sent or received and specifies whether the
+candidates are searched in messages sent by the user or received
+by the user (note received by is much faster), and FILTER is
+either nil or a filter-string, such as \"date:1y..\" to append to
+the query."
+ :type '(list :tag "Use internal address completion"
+ (radio
+ :tag "Base completion on messages you have"
+ :value sent
+ (const :tag "sent (more accurate)" sent)
+ (const :tag "received (faster)" received))
+ (radio :tag "Filter messages used for completion"
+ (const :tag "Use all messages" nil)
+ (string :tag "Filter query")))
+ ;; We override set so that we can clear the cache when this changes
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (setq notmuch-address-last-harvest 0)
+ (setq notmuch-address-completions (clrhash notmuch-address-completions))
+ (setq notmuch-address-full-harvest-finished nil))
+ :group 'notmuch-send
+ :group 'notmuch-address
+ :group 'notmuch-external)
+
+(defcustom notmuch-address-save-filename nil
+ "Filename to save the cached completion addresses.
+
+All the addresses notmuch uses for address completion will be
+cached in this file. This has obvious privacy implications so
+you should make sure it is not somewhere publicly readable."
+ :type '(choice (const :tag "Off" nil)
+ (file :tag "Filename"))
+ :group 'notmuch-send
+ :group 'notmuch-address
+ :group 'notmuch-external)
+
+(defcustom notmuch-address-selection-function 'notmuch-address-selection-function
+ "The function to select address from given list.
+
+The function is called with PROMPT, COLLECTION, and INITIAL-INPUT
+as arguments (subset of what `completing-read' can be called
+with). While executed the value of `completion-ignore-case'
+is t. See documentation of function
+`notmuch-address-selection-function' to know how address
+selection is made by default."
+ :type 'function
+ :group 'notmuch-send
+ :group 'notmuch-address
+ :group 'notmuch-external)
+
+(defcustom notmuch-address-post-completion-functions nil
+ "Functions called after completing address.
+
+The completed address is passed as an argument to each function.
+Note that this hook will be invoked for completion in headers
+matching `notmuch-address-completion-headers-regexp'."
+ :type 'hook
+ :group 'notmuch-address
+ :group 'notmuch-hooks)
+
+(defcustom notmuch-address-use-company t
+ "If available, use company mode for address completion."
+ :type 'boolean
+ :group 'notmuch-send
+ :group 'notmuch-address)
+
+;;; Setup
+
+(defun notmuch-address-selection-function (prompt collection initial-input)
+ "Call (`completing-read'
+ PROMPT COLLECTION nil nil INITIAL-INPUT 'notmuch-address-history)"
+ (completing-read
+ prompt collection nil nil initial-input 'notmuch-address-history))
+
+(defvar notmuch-address-completion-headers-regexp
+ "^\\(Resent-\\)?\\(To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):")
+
+(defvar notmuch-address-history nil)
+
+(defun notmuch-address-message-insinuate ()
+ (message "calling notmuch-address-message-insinuate is no longer needed"))
+
+(defun notmuch-address-setup ()
+ (unless (eq notmuch-address-command 'as-is)
+ (when (and notmuch-address-use-company
+ (require 'company nil t))
+ (notmuch-company-setup))
+ (cl-pushnew (cons notmuch-address-completion-headers-regexp
+ #'notmuch-address-expand-name)
+ message-completion-alist :test #'equal)))
+
+(defun notmuch-address-toggle-internal-completion ()
+ "Toggle use of internal completion for current buffer.
+
+This overrides the global setting for address completion and
+toggles the setting in this buffer."
+ (interactive)
+ (if (local-variable-p 'notmuch-address-command)
+ (kill-local-variable 'notmuch-address-command)
+ (setq-local notmuch-address-command 'internal))
+ (when (boundp 'company-idle-delay)
+ (if (local-variable-p 'company-idle-delay)
+ (kill-local-variable 'company-idle-delay)
+ (setq-local company-idle-delay nil))))
+
+;;; Completion
+
+(defun notmuch-address-matching (substring)
+ "Returns a list of completion candidates matching SUBSTRING.
+The candidates are taken from `notmuch-address-completions'."
+ (let ((candidates)
+ (re (regexp-quote substring)))
+ (maphash (lambda (key _val)
+ (when (string-match re key)
+ (push key candidates)))
+ notmuch-address-completions)
+ candidates))
+
+(defun notmuch-address-options (original)
+ "Return a list of completion candidates.
+Use either elisp-based implementation or older implementation
+requiring external commands."
+ (cond
+ ((eq notmuch-address-command 'internal)
+ (unless (notmuch-address--harvest-ready)
+ ;; First, run quick synchronous harvest based on what the user
+ ;; entered so far.
+ (notmuch-address-harvest original t))
+ (prog1 (notmuch-address-matching original)
+ ;; Then start the (potentially long-running) full asynchronous
+ ;; harvest if necessary.
+ (notmuch-address-harvest-trigger)))
+ (t
+ (notmuch--process-lines notmuch-address-command original))))
+
+(defun notmuch-address-expand-name ()
+ (cond
+ ((and (eq notmuch-address-command 'internal)
+ notmuch-address-use-company
+ (bound-and-true-p company-mode))
+ (company-manual-begin))
+ (notmuch-address-command
+ (let* ((end (point))
+ (beg (save-excursion
+ (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
+ (goto-char (match-end 0))
+ (point)))
+ (orig (buffer-substring-no-properties beg end))
+ (completion-ignore-case t)
+ (options (with-temp-message "Looking for completion candidates..."
+ (notmuch-address-options orig)))
+ (num-options (length options))
+ (chosen (cond
+ ((eq num-options 0)
+ nil)
+ ((eq num-options 1)
+ (car options))
+ (t
+ (funcall notmuch-address-selection-function
+ (format "Address (%s matches): " num-options)
+ options
+ orig)))))
+ (if chosen
+ (progn
+ (push chosen notmuch-address-history)
+ (delete-region beg end)
+ (insert chosen)
+ (run-hook-with-args 'notmuch-address-post-completion-functions
+ chosen))
+ (message "No matches.")
+ (ding))))
+ (t nil)))
+
+;;; Harvest
+
+(defun notmuch-address-harvest-addr (result)
+ (puthash (plist-get result :name-addr)
+ t notmuch-address-completions))
+
+(defun notmuch-address-harvest-filter (proc string)
+ (when (buffer-live-p (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (save-excursion
+ (goto-char (point-max))
+ (insert string))
+ (notmuch-sexp-parse-partial-list
+ 'notmuch-address-harvest-addr (process-buffer proc)))))
+
+(defvar notmuch-address-harvest-procs '(nil . nil)
+ "The currently running harvests.
+
+The car is a partial harvest, and the cdr is a full harvest.")
+
+(defun notmuch-address-harvest (&optional addr-prefix synchronous callback)
+ "Collect addresses completion candidates.
+
+It queries the notmuch database for messages sent/received (as
+configured with `notmuch-address-command') by the user, collects
+destination/source addresses from those messages and stores them
+in `notmuch-address-completions'.
+
+If ADDR-PREFIX is not nil, only messages with to/from addresses
+matching ADDR-PREFIX*' are queried.
+
+Address harvesting may take some time so the address collection runs
+asynchronously unless SYNCHRONOUS is t. In case of asynchronous
+execution, CALLBACK is called when harvesting finishes."
+ (let* ((sent (eq (car notmuch-address-internal-completion) 'sent))
+ (config-query (cadr notmuch-address-internal-completion))
+ (prefix-query (and addr-prefix
+ (format "%s:%s*"
+ (if sent "to" "from")
+ addr-prefix)))
+ (from-or-to-me-query
+ (mapconcat (lambda (x)
+ (concat (if sent "from:" "to:") x))
+ (notmuch-user-emails) " or "))
+ (query (if (or prefix-query config-query)
+ (concat (format "(%s)" from-or-to-me-query)
+ (and prefix-query
+ (format " and (%s)" prefix-query))
+ (and config-query
+ (format " and (%s)" config-query)))
+ from-or-to-me-query))
+ (args `("address" "--format=sexp" "--format-version=5"
+ ,(if sent "--output=recipients" "--output=sender")
+ "--deduplicate=address"
+ ,query)))
+ (if synchronous
+ (mapc #'notmuch-address-harvest-addr
+ (apply 'notmuch-call-notmuch-sexp args))
+ ;; Asynchronous
+ (let* ((current-proc (if addr-prefix
+ (car notmuch-address-harvest-procs)
+ (cdr notmuch-address-harvest-procs)))
+ (proc-name (format "notmuch-address-%s-harvest"
+ (if addr-prefix "partial" "full")))
+ (proc-buf (concat " *" proc-name "*")))
+ ;; Kill any existing process
+ (when current-proc
+ (kill-buffer (process-buffer current-proc))) ; this also kills the process
+ (setq current-proc
+ (apply 'notmuch-start-notmuch proc-name proc-buf
+ callback ; process sentinel
+ args))
+ (set-process-filter current-proc 'notmuch-address-harvest-filter)
+ (set-process-query-on-exit-flag current-proc nil)
+ (if addr-prefix
+ (setcar notmuch-address-harvest-procs current-proc)
+ (setcdr notmuch-address-harvest-procs current-proc)))))
+ ;; return value
+ nil)
+
+(defvar notmuch-address--save-hash-version 1
+ "Version format of the save hash.")
+
+(defun notmuch-address--get-address-hash ()
+ "Return the saved address hash as a plist.
+
+Returns nil if the save file does not exist, or it does not seem
+to be a saved address hash."
+ (and notmuch-address-save-filename
+ (condition-case nil
+ (with-temp-buffer
+ (insert-file-contents notmuch-address-save-filename)
+ (let ((name (read (current-buffer)))
+ (plist (read (current-buffer))))
+ ;; We do two simple sanity checks on the loaded file.
+ ;; We just check a version is specified, not that
+ ;; it is the current version, as we are allowed to
+ ;; over-write and a save-file with an older version.
+ (and (string= name "notmuch-address-hash")
+ (plist-get plist :version)
+ plist)))
+ ;; The error case catches any of the reads failing.
+ (error nil))))
+
+(defun notmuch-address--load-address-hash ()
+ "Read the saved address hash and set the corresponding variables."
+ (let ((load-plist (notmuch-address--get-address-hash)))
+ (when (and load-plist
+ ;; If the user's setting have changed, or the version
+ ;; has changed, return nil to make sure the new settings
+ ;; take effect.
+ (equal (plist-get load-plist :completion-settings)
+ notmuch-address-internal-completion)
+ (equal (plist-get load-plist :version)
+ notmuch-address--save-hash-version))
+ (setq notmuch-address-last-harvest (plist-get load-plist :last-harvest))
+ (setq notmuch-address-completions (plist-get load-plist :completions))
+ (setq notmuch-address-full-harvest-finished t)
+ ;; Return t to say load was successful.
+ t)))
+
+(defun notmuch-address--save-address-hash ()
+ (when notmuch-address-save-filename
+ (if (or (not (file-exists-p notmuch-address-save-filename))
+ ;; The file exists, check it is a file we saved.
+ (notmuch-address--get-address-hash))
+ (with-temp-file notmuch-address-save-filename
+ (let ((save-plist
+ (list :version notmuch-address--save-hash-version
+ :completion-settings notmuch-address-internal-completion
+ :last-harvest notmuch-address-last-harvest
+ :completions notmuch-address-completions)))
+ (print "notmuch-address-hash" (current-buffer))
+ (print save-plist (current-buffer))))
+ (message "\
+Warning: notmuch-address-save-filename %s exists but doesn't
+appear to be an address savefile. Not overwriting."
+ notmuch-address-save-filename))))
+
+(defun notmuch-address-harvest-trigger ()
+ (let ((now (float-time)))
+ (when (> (- now notmuch-address-last-harvest) 86400)
+ (setq notmuch-address-last-harvest now)
+ (notmuch-address-harvest
+ nil nil
+ (lambda (_proc event)
+ ;; If harvest fails, we want to try
+ ;; again when the trigger is next called.
+ (if (string= event "finished\n")
+ (progn
+ (notmuch-address--save-address-hash)
+ (setq notmuch-address-full-harvest-finished t))
+ (setq notmuch-address-last-harvest 0)))))))
+
+;;; Standalone completion
+
+(defun notmuch-address-from-minibuffer (prompt)
+ (if (not notmuch-address-command)
+ (read-string prompt)
+ (let ((rmap (copy-keymap minibuffer-local-map))
+ (omap minibuffer-local-map))
+ ;; Configure TAB to start completion when executing read-string.
+ ;; "Original" minibuffer keymap is restored just before calling
+ ;; notmuch-address-expand-name as it may also use minibuffer-local-map
+ ;; (completing-read probably does not but if something else is used there).
+ (define-key rmap (kbd "TAB") (lambda ()
+ (interactive)
+ (let ((enable-recursive-minibuffers t)
+ (minibuffer-local-map omap))
+ (notmuch-address-expand-name))))
+ (let ((minibuffer-local-map rmap))
+ (read-string prompt)))))
+
+;;; _
+
+(provide 'notmuch-address)
+
+;;; notmuch-address.el ends here
blob - /dev/null
blob + b9cd7b373a93c6dc64ad28a50bb74e5c7452ba89 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-autoloads.el
+;;; notmuch-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
+;; Generated by the `loaddefs-generate' function.
+
+;; This file is part of GNU Emacs.
+
+;;; Code:
+
+(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
+
+
+
+;;; Generated autoloads from coolj.el
+
+(register-definition-prefixes "coolj" '("coolj-"))
+
+
+;;; Generated autoloads from make-deps.el
+
+(register-definition-prefixes "make-deps" '("batch-make-deps" "make-deps"))
+
+
+;;; Generated autoloads from notmuch.el
+
+(autoload 'notmuch-search "notmuch" "\
+Display threads matching QUERY in a notmuch-search buffer.
+
+If QUERY is nil, it is read interactively from the minibuffer.
+Other optional parameters are used as follows:
+
+ OLDEST-FIRST: A Boolean controlling the sort order of returned threads
+ TARGET-THREAD: A thread ID (without the thread: prefix) that will be made
+ current if it appears in the search results.
+ TARGET-LINE: The line number to move to if the target thread does not
+ appear in the search results.
+ NO-DISPLAY: Do not try to foreground the search results buffer. If it is
+ already foregrounded i.e. displayed in a window, this has no
+ effect, meaning the buffer will remain visible.
+
+When called interactively, this will prompt for a query and use
+the configured default sort order.
+
+(fn &optional QUERY OLDEST-FIRST TARGET-THREAD TARGET-LINE NO-DISPLAY)" t)
+(autoload 'notmuch "notmuch" "\
+Run notmuch and display saved searches, known tags, etc." t)
+(autoload 'notmuch-cycle-notmuch-buffers "notmuch" "\
+Cycle through any existing notmuch buffers (search, show or hello).
+
+If the current buffer is the only notmuch buffer, bury it.
+If no notmuch buffers exist, run `notmuch'." t)
+(register-definition-prefixes "notmuch" '("notmuch-"))
+
+
+;;; Generated autoloads from notmuch-address.el
+
+(register-definition-prefixes "notmuch-address" '("notmuch-address-"))
+
+
+;;; Generated autoloads from notmuch-company.el
+
+(autoload 'notmuch-company-setup "notmuch-company")
+(autoload 'notmuch-company "notmuch-company" "\
+`company-mode' completion back-end for `notmuch'.
+
+(fn COMMAND &optional ARG &rest IGNORE)" t)
+(register-definition-prefixes "notmuch-company" '("notmuch-company-last-prefix"))
+
+
+;;; Generated autoloads from notmuch-compat.el
+
+(register-definition-prefixes "notmuch-compat" '("notmuch-"))
+
+
+;;; Generated autoloads from notmuch-crypto.el
+
+(register-definition-prefixes "notmuch-crypto" '("notmuch-crypto-"))
+
+
+;;; Generated autoloads from notmuch-draft.el
+
+(register-definition-prefixes "notmuch-draft" '("notmuch-draft-"))
+
+
+;;; Generated autoloads from notmuch-hello.el
+
+(autoload 'notmuch-hello "notmuch-hello" "\
+Run notmuch and display saved searches, known tags, etc.
+
+(fn &optional NO-DISPLAY)" t)
+(register-definition-prefixes "notmuch-hello" '("notmuch-"))
+
+
+;;; Generated autoloads from notmuch-jump.el
+
+(autoload 'notmuch-jump-search "notmuch-jump" "\
+Jump to a saved search by shortcut key.
+
+This prompts for and performs a saved search using the shortcut
+keys configured in the :key property of `notmuch-saved-searches'.
+Typically these shortcuts are a single key long, so this is a
+fast way to jump to a saved search from anywhere in Notmuch." t)
+(autoload 'notmuch-jump "notmuch-jump" "\
+Interactively prompt for one of the keys in ACTION-MAP.
+
+Displays a summary of all bindings in ACTION-MAP in the
+minibuffer, reads a key from the minibuffer, and performs the
+corresponding action. The prompt can be canceled with C-g or
+RET. PROMPT must be a string to use for the prompt. PROMPT
+should include a space at the end.
+
+ACTION-MAP must be a list of triples of the form
+ (KEY LABEL ACTION)
+where KEY is a key binding, LABEL is a string label to display in
+the buffer, and ACTION is a nullary function to call. LABEL may
+be null, in which case the action will still be bound, but will
+not appear in the pop-up buffer.
+
+(fn ACTION-MAP PROMPT)")
+(register-definition-prefixes "notmuch-jump" '("notmuch-jump-"))
+
+
+;;; Generated autoloads from notmuch-lib.el
+
+(register-definition-prefixes "notmuch-lib" '("notmuch-"))
+
+
+;;; Generated autoloads from notmuch-maildir-fcc.el
+
+(register-definition-prefixes "notmuch-maildir-fcc" '("notmuch-" "with-temporary-notmuch-message-buffer"))
+
+
+;;; Generated autoloads from notmuch-message.el
+
+(register-definition-prefixes "notmuch-message" '("notmuch-message-"))
+
+
+;;; Generated autoloads from notmuch-mua.el
+
+(register-definition-prefixes "notmuch-mua" '("notmuch-"))
+
+
+;;; Generated autoloads from notmuch-parser.el
+
+(register-definition-prefixes "notmuch-parser" '("notmuch-sexp-"))
+
+
+;;; Generated autoloads from notmuch-print.el
+
+(register-definition-prefixes "notmuch-print" '("notmuch-print-"))
+
+
+;;; Generated autoloads from notmuch-query.el
+
+(register-definition-prefixes "notmuch-query" '("notmuch-query-"))
+
+
+;;; Generated autoloads from notmuch-show.el
+
+(autoload 'notmuch-show "notmuch-show" "\
+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
+one).
+
+The optional QUERY-CONTEXT is a notmuch search term. Only
+messages from the thread matching this search term are shown if
+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.
+
+Returns the buffer containing the messages, or NIL if no messages
+matched.
+
+(fn THREAD-ID &optional ELIDE-TOGGLE PARENT-BUFFER QUERY-CONTEXT BUFFER-NAME)" t)
+(register-definition-prefixes "notmuch-show" '("notmuch-" "with-current-notmuch-show-message"))
+
+
+;;; Generated autoloads from notmuch-tag.el
+
+(register-definition-prefixes "notmuch-tag" '("notmuch-"))
+
+
+;;; Generated autoloads from notmuch-tree.el
+
+(register-definition-prefixes "notmuch-tree" '("notmuch-"))
+
+
+;;; Generated autoloads from notmuch-wash.el
+
+(register-definition-prefixes "notmuch-wash" '("notmuch-wash-"))
+
+
+;;; Generated autoloads from rstdoc.el
+
+(register-definition-prefixes "rstdoc" '("rst"))
+
+;;; End of scraped data
+
+(provide 'notmuch-autoloads)
+
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; no-native-compile: t
+;; coding: utf-8-emacs-unix
+;; End:
+
+;;; notmuch-autoloads.el ends here
blob - /dev/null
blob + 7e05dc8f2a796aaf2c664fdcc4be63f6a443057f (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-company.el
+;;; notmuch-company.el --- Mail address completion for notmuch via company-mode -*- lexical-binding: t -*-
+;;
+;; Copyright © Trevor Jim
+;; Copyright © Michal Sojka
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Trevor Jim <tjim@mac.com>
+;; Michal Sojka <sojkam1@fel.cvut.cz>
+;; Keywords: mail, completion
+
+;;; Commentary:
+
+;; Mail address completion for notmuch via company-mode. To enable
+;; this, install company mode from <https://company-mode.github.io/>.
+;;
+;; NB company-minimum-prefix-length defaults to 3 so you don't get
+;; completion unless you type 3 characters.
+
+;;; Code:
+
+(require 'notmuch-lib)
+
+(defvar-local notmuch-company-last-prefix nil)
+
+(declare-function company-begin-backend "company")
+(declare-function company-grab "company")
+(declare-function company-mode "company")
+(declare-function company-manual-begin "company")
+(defvar company-backends)
+(defvar company-idle-delay)
+
+(declare-function notmuch-address-harvest "notmuch-address")
+(declare-function notmuch-address-harvest-trigger "notmuch-address")
+(declare-function notmuch-address-matching "notmuch-address")
+(declare-function notmuch-address--harvest-ready "notmuch-address")
+(defvar notmuch-address-completion-headers-regexp)
+(defvar notmuch-address-command)
+
+;;;###autoload
+(defun notmuch-company-setup ()
+ (company-mode)
+ (setq-local company-backends '(notmuch-company))
+ ;; Disable automatic company completion unless an internal
+ ;; completion method is configured. Company completion (using
+ ;; internal completion) can still be accessed via standard company
+ ;; functions, e.g., company-complete.
+ (unless (eq notmuch-address-command 'internal)
+ (setq-local company-idle-delay nil)))
+
+;;;###autoload
+(defun notmuch-company (command &optional arg &rest _ignore)
+ "`company-mode' completion back-end for `notmuch'."
+ (interactive (list 'interactive))
+ (require 'company)
+ (let ((case-fold-search t)
+ (completion-ignore-case t))
+ (cl-case command
+ (interactive (company-begin-backend 'notmuch-company))
+ (prefix (and (or (derived-mode-p 'message-mode)
+ (derived-mode-p 'org-msg-edit-mode))
+ (looking-back
+ (concat notmuch-address-completion-headers-regexp ".*")
+ (line-beginning-position))
+ (setq notmuch-company-last-prefix
+ (company-grab "[:,][ \t]*\\(.*\\)" 1 (point-at-bol)))))
+ (candidates (cond
+ ((notmuch-address--harvest-ready)
+ ;; Update harvested addressed from time to time
+ (notmuch-address-harvest-trigger)
+ (notmuch-address-matching arg))
+ (t
+ (cons :async
+ (lambda (callback)
+ ;; First run quick asynchronous harvest
+ ;; based on what the user entered so far
+ (notmuch-address-harvest
+ arg nil
+ (lambda (_proc _event)
+ (funcall callback (notmuch-address-matching arg))
+ ;; Then start the (potentially long-running)
+ ;; full asynchronous harvest if necessary
+ (notmuch-address-harvest-trigger))))))))
+ (match (if (string-match notmuch-company-last-prefix arg)
+ (match-end 0)
+ 0))
+ (post-completion
+ (run-hook-with-args 'notmuch-address-post-completion-functions arg))
+ (no-cache t))))
+
+(provide 'notmuch-company)
+
+;;; notmuch-company.el ends here
blob - /dev/null
blob + 179bf59ca86116e79b64393ff76c41d65db53be9 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-compat.el
+;;; notmuch-compat.el --- compatibility functions for earlier versions of emacs -*- lexical-binding: t -*-
+;;
+;; The functions in this file are copied from more modern versions of
+;; emacs and are Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2017
+;; Free Software Foundation, Inc.
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+;; Before Emacs 26.1 lines that are longer than 998 octets were not.
+;; folded. Commit 77bbca8c82f6e553c42abbfafca28f55fc995d00 fixed
+;; that. Until we drop support for Emacs 25 we have to backport that
+;; fix. To avoid interfering with Gnus we only run the hook when
+;; called from notmuch-message-mode.
+
+(declare-function mail-header-fold-field "mail-parse" nil)
+
+(defun notmuch-message--fold-long-headers ()
+ (when (eq major-mode 'notmuch-message-mode)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (and (looking-at "[^:]+:")
+ (> (- (line-end-position) (point)) 998))
+ (mail-header-fold-field))
+ (forward-line 1))))
+
+(unless (fboundp 'message--fold-long-headers)
+ (add-hook 'message-header-hook 'notmuch-message--fold-long-headers))
+
+;; `dlet' isn't available until Emacs 28.1. Below is a copy, with the
+;; addition of `with-no-warnings'.
+(defmacro notmuch-dlet (binders &rest body)
+ "Like `let*' but using dynamic scoping."
+ (declare (indent 1) (debug let))
+ `(let (_)
+ (with-no-warnings ; Quiet "lacks a prefix" warning.
+ ,@(mapcar (lambda (binder)
+ `(defvar ,(if (consp binder) (car binder) binder)))
+ binders))
+ (let* ,binders ,@body)))
+
+(provide 'notmuch-compat)
+
+;;; notmuch-compat.el ends here
blob - /dev/null
blob + a1cf3ddd93e176748e49472750c6138c76c4b27a (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-crypto.el
+;;; notmuch-crypto.el --- functions for handling display of cryptographic metadata -*- lexical-binding: t -*-
+;;
+;; Copyright © Jameson Rollins
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Jameson Rollins <jrollins@finestructure.net>
+
+;;; Code:
+
+(require 'epg)
+(require 'notmuch-lib)
+
+(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare))
+
+;;; Options
+
+(defcustom notmuch-crypto-process-mime t
+ "Whether to process cryptographic MIME parts.
+
+If this variable is non-nil signatures in multipart/signed
+messages will be verified and multipart/encrypted parts will be
+decrypted. The result of the crypto operation will be displayed
+in a specially colored header button at the top of the processed
+part. Signed parts will have variously colored headers depending
+on the success or failure of the verification process and on the
+validity of user ID of the signer.
+
+The effect of setting this variable can be seen temporarily by
+providing a prefix when viewing a signed or encrypted message, or
+by providing a prefix when reloading the message in notmuch-show
+mode."
+ :type 'boolean
+ :package-version '(notmuch . "0.25")
+ :group 'notmuch-crypto)
+
+(defcustom notmuch-crypto-get-keys-asynchronously t
+ "Whether to retrieve openpgp keys asynchronously."
+ :type 'boolean
+ :group 'notmuch-crypto)
+
+(defcustom notmuch-crypto-gpg-program epg-gpg-program
+ "The gpg executable."
+ :type 'string
+ :group 'notmuch-crypto)
+
+;;; Faces
+
+(defface notmuch-crypto-part-header
+ '((((class color)
+ (background dark))
+ (:foreground "LightBlue1"))
+ (((class color)
+ (background light))
+ (:foreground "blue")))
+ "Face used for crypto parts headers."
+ :group 'notmuch-crypto
+ :group 'notmuch-faces)
+
+(defface notmuch-crypto-signature-good
+ '((t (:background "green" :foreground "black")))
+ "Face used for good signatures."
+ :group 'notmuch-crypto
+ :group 'notmuch-faces)
+
+(defface notmuch-crypto-signature-good-key
+ '((t (:background "orange" :foreground "black")))
+ "Face used for good signatures."
+ :group 'notmuch-crypto
+ :group 'notmuch-faces)
+
+(defface notmuch-crypto-signature-bad
+ '((t (:background "red" :foreground "black")))
+ "Face used for bad signatures."
+ :group 'notmuch-crypto
+ :group 'notmuch-faces)
+
+(defface notmuch-crypto-signature-unknown
+ '((t (:background "red" :foreground "black")))
+ "Face used for signatures of unknown status."
+ :group 'notmuch-crypto
+ :group 'notmuch-faces)
+
+(defface notmuch-crypto-decryption
+ '((t (:background "purple" :foreground "black")))
+ "Face used for encryption/decryption status messages."
+ :group 'notmuch-crypto
+ :group 'notmuch-faces)
+
+;;; Functions
+
+(define-button-type 'notmuch-crypto-status-button-type
+ 'action (lambda (button) (message "%s" (button-get button 'help-echo)))
+ 'follow-link t
+ 'help-echo "Set notmuch-crypto-process-mime to process cryptographic mime parts."
+ :supertype 'notmuch-button-type)
+
+(defun notmuch-crypto-insert-sigstatus-button (sigstatus from)
+ "Insert a button describing the signature status SIGSTATUS sent by user FROM."
+ (let* ((status (plist-get sigstatus :status))
+ (show-button t)
+ (face 'notmuch-crypto-signature-unknown)
+ (button-action (lambda (button) (message (button-get button 'help-echo))))
+ (keyid (concat "0x" (plist-get sigstatus :keyid)))
+ label help-msg)
+ (cond
+ ((string= status "good")
+ (let ((fingerprint (concat "0x" (plist-get sigstatus :fingerprint)))
+ (email-or-userid (or (plist-get sigstatus :email)
+ (plist-get sigstatus :userid))))
+ ;; If email or userid are present, they have full or greater validity.
+ (setq label (concat "Good signature by key: " fingerprint))
+ (setq face 'notmuch-crypto-signature-good-key)
+ (when email-or-userid
+ (setq label (concat "Good signature by: " email-or-userid))
+ (setq face 'notmuch-crypto-signature-good))
+ (setq button-action 'notmuch-crypto-sigstatus-good-callback)
+ (setq help-msg (concat "Click to list key ID 0x" fingerprint "."))))
+ ((string= status "error")
+ (setq label (concat "Unknown key ID " keyid " or unsupported algorithm"))
+ (setq button-action 'notmuch-crypto-sigstatus-error-callback)
+ (setq help-msg (concat "Click to retrieve key ID " keyid
+ " from key server.")))
+ ((string= status "bad")
+ (setq label (concat "Bad signature (claimed key ID " keyid ")"))
+ (setq face 'notmuch-crypto-signature-bad))
+ (status
+ (setq label (concat "Unknown signature status: " status)))
+ (t
+ (setq show-button nil)))
+ (when show-button
+ (insert-button
+ (concat "[ " label " ]")
+ :type 'notmuch-crypto-status-button-type
+ 'help-echo help-msg
+ 'face face
+ 'mouse-face face
+ 'action button-action
+ :notmuch-sigstatus sigstatus
+ :notmuch-from from)
+ (insert "\n"))))
+
+(defun notmuch-crypto-sigstatus-good-callback (button)
+ (let* ((id (notmuch-show-get-message-id))
+ (sigstatus (button-get button :notmuch-sigstatus))
+ (fingerprint (concat "0x" (plist-get sigstatus :fingerprint)))
+ (buffer (get-buffer-create "*notmuch-crypto-gpg-out*"))
+ (window (display-buffer buffer)))
+ (with-selected-window window
+ (with-current-buffer buffer
+ (goto-char (point-max))
+ (insert (format "-- Key %s in message %s:\n"
+ fingerprint id))
+ (notmuch--call-process notmuch-crypto-gpg-program nil t t
+ "--batch" "--no-tty" "--list-keys" fingerprint))
+ (recenter -1))))
+
+(declare-function notmuch-show-refresh-view "notmuch-show" (&optional reset-state))
+(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare))
+
+(defun notmuch-crypto--async-key-sentinel (process _event)
+ "When the user asks for a GPG key to be retrieved
+asynchronously, handle completion of that task.
+
+If the retrieval is successful, the thread where the retrieval
+was initiated is still displayed and the cursor has not moved,
+redisplay the thread."
+ (let ((status (process-status process))
+ (exit-status (process-exit-status process))
+ (keyid (process-get process :gpg-key-id)))
+ (when (memq status '(exit signal))
+ (message "Getting the GPG key %s asynchronously...%s."
+ keyid
+ (if (= exit-status 0)
+ "completed"
+ "failed"))
+ ;; If the original buffer is still alive and point didn't move
+ ;; (i.e. the user didn't move on or away), refresh the buffer to
+ ;; show the updated signature status.
+ (let ((show-buffer (process-get process :notmuch-show-buffer))
+ (show-point (process-get process :notmuch-show-point)))
+ (when (and (bufferp show-buffer)
+ (buffer-live-p show-buffer)
+ (= show-point
+ (with-current-buffer show-buffer
+ (point))))
+ (with-current-buffer show-buffer
+ (notmuch-show-refresh-view)))))))
+
+(defun notmuch-crypto--set-button-label (button label)
+ "Set the text displayed in BUTTON to LABEL."
+ (save-excursion
+ (let ((inhibit-read-only t))
+ ;; This knows rather too much about how we typically format
+ ;; buttons.
+ (goto-char (button-start button))
+ (forward-char 2)
+ (delete-region (point) (- (button-end button) 2))
+ (insert label))))
+
+(defun notmuch-crypto-sigstatus-error-callback (button)
+ "When signature validation has failed, try to retrieve the
+corresponding key when the status button is pressed."
+ (let* ((sigstatus (button-get button :notmuch-sigstatus))
+ (keyid (concat "0x" (plist-get sigstatus :keyid)))
+ (buffer (get-buffer-create "*notmuch-crypto-gpg-out*")))
+ (if notmuch-crypto-get-keys-asynchronously
+ (progn
+ (notmuch-crypto--set-button-label
+ button (format "Retrieving key %s asynchronously..." keyid))
+ (with-current-buffer buffer
+ (goto-char (point-max))
+ (insert (format "--- Retrieving key %s:\n" keyid)))
+ (let ((p (notmuch--make-process
+ :name "notmuch GPG key retrieval"
+ :connection-type 'pipe
+ :buffer buffer
+ :stderr buffer
+ :command (list notmuch-crypto-gpg-program "--recv-keys" keyid)
+ :sentinel #'notmuch-crypto--async-key-sentinel)))
+ (process-put p :gpg-key-id keyid)
+ (process-put p :notmuch-show-buffer (current-buffer))
+ (process-put p :notmuch-show-point (point))
+ (message "Getting the GPG key %s asynchronously..." keyid)))
+ (let ((window (display-buffer buffer)))
+ (with-selected-window window
+ (with-current-buffer buffer
+ (goto-char (point-max))
+ (insert (format "--- Retrieving key %s:\n" keyid))
+ (notmuch--call-process notmuch-crypto-gpg-program nil t t "--recv-keys" keyid)
+ (insert "\n")
+ (notmuch--call-process notmuch-crypto-gpg-program nil t t "--list-keys" keyid))
+ (recenter -1))
+ (notmuch-show-refresh-view)))))
+
+(defun notmuch-crypto-insert-encstatus-button (encstatus)
+ "Insert a button describing the encryption status ENCSTATUS."
+ (insert-button
+ (concat "[ "
+ (let ((status (plist-get encstatus :status)))
+ (cond
+ ((string= status "good")
+ "Decryption successful")
+ ((string= status "bad")
+ "Decryption error")
+ (t
+ (concat "Unknown encryption status"
+ (and status (concat ": " status))))))
+ " ]")
+ :type 'notmuch-crypto-status-button-type
+ 'face 'notmuch-crypto-decryption
+ 'mouse-face 'notmuch-crypto-decryption)
+ (insert "\n"))
+
+;;; _
+
+(provide 'notmuch-crypto)
+
+;;; notmuch-crypto.el ends here
blob - /dev/null
blob + fcc45503c6b0816d4ab12ab98a6c86cf6b2d3eb9 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-draft.el
+;;; notmuch-draft.el --- functions for postponing and editing drafts -*- lexical-binding: t -*-
+;;
+;; Copyright © Mark Walters
+;; Copyright © David Bremner
+;; Copyright © Leo Gaspard
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Mark Walters <markwalters1009@gmail.com>
+;; David Bremner <david@tethera.net>
+;; Leo Gaspard <leo@gaspard.io>
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'pcase)
+(require 'subr-x)
+
+(require 'notmuch-maildir-fcc)
+(require 'notmuch-tag)
+
+(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare))
+(declare-function notmuch-message-mode "notmuch-mua")
+
+;;; Options
+
+(defgroup notmuch-draft nil
+ "Saving and editing drafts in Notmuch."
+ :group 'notmuch)
+
+(defcustom notmuch-draft-tags '("+draft")
+ "List of tag changes to apply when saving a draft message in the database.
+
+Tags starting with \"+\" (or not starting with either \"+\" or
+\"-\") in the list will be added, and tags starting with \"-\"
+will be removed from the message being stored.
+
+For example, if you wanted to give the message a \"draft\" tag
+but not the (normally added by default) \"inbox\" tag, you would
+set:
+ (\"+draft\" \"-inbox\")"
+ :type '(repeat string)
+ :group 'notmuch-draft)
+
+(defcustom notmuch-draft-folder "drafts"
+ "Folder to save draft messages in.
+
+This should be specified relative to the root of the notmuch
+database. It will be created if necessary."
+ :type 'string
+ :group 'notmuch-draft)
+
+(defcustom notmuch-draft-quoted-tags '()
+ "Mml tags to quote.
+
+This should be a list of mml tags to quote before saving. You do
+not need to include \"secure\" as that is handled separately.
+
+If you include \"part\" then attachments will not be saved with
+the draft -- if not then they will be saved with the draft. The
+former means the attachments may not still exist when you resume
+the message, the latter means that the attachments as they were
+when you postponed will be sent with the resumed message.
+
+Note you may get strange results if you change this between
+postponing and resuming a message."
+ :type '(repeat string)
+ :group 'notmuch-send)
+
+(defcustom notmuch-draft-save-plaintext 'ask
+ "Whether to allow saving plaintext when it seems encryption is intended.
+When a message contains mml tags, then that suggest it is
+intended to be encrypted. If the user requests that such a
+message is saved locally, then this option controls whether
+that is allowed. Beside a boolean, this can also be `ask'."
+ :type '(radio
+ (const :tag "Never" nil)
+ (const :tag "Ask every time" ask)
+ (const :tag "Always" t))
+ :group 'notmuch-draft
+ :group 'notmuch-crypto)
+
+;;; Internal
+
+(defvar notmuch-draft-encryption-tag-regex
+ "<#\\(part encrypt\\|secure.*mode=.*encrypt>\\)"
+ "Regular expression matching mml tags indicating encryption of part or message.")
+
+(defvar-local notmuch-draft-id nil
+ "Message-id of the most recent saved draft of this message.")
+
+(defun notmuch-draft--mark-deleted ()
+ "Tag the last saved draft deleted.
+
+Used when a new version is saved, or the message is sent."
+ (when notmuch-draft-id
+ (notmuch-tag notmuch-draft-id '("+deleted"))))
+
+(defun notmuch-draft-quote-some-mml ()
+ "Quote the mml tags in `notmuch-draft-quoted-tags'."
+ (save-excursion
+ ;; First we deal with any secure tag separately.
+ (message-goto-body)
+ (when (looking-at "<#secure[^\n]*>\n")
+ (let ((secure-tag (match-string 0)))
+ (delete-region (match-beginning 0) (match-end 0))
+ (message-add-header (concat "X-Notmuch-Emacs-Secure: " secure-tag))))
+ ;; This is copied from mml-quote-region but only quotes the
+ ;; specified tags.
+ (when notmuch-draft-quoted-tags
+ (let ((re (concat "<#!*/?\\("
+ (mapconcat 'regexp-quote notmuch-draft-quoted-tags "\\|")
+ "\\)")))
+ (message-goto-body)
+ (while (re-search-forward re nil t)
+ ;; Insert ! after the #.
+ (goto-char (+ (match-beginning 0) 2))
+ (insert "!"))))))
+
+(defun notmuch-draft-unquote-some-mml ()
+ "Unquote the mml tags in `notmuch-draft-quoted-tags'."
+ (save-excursion
+ (when notmuch-draft-quoted-tags
+ (let ((re (concat "<#!+/?\\("
+ (mapconcat 'regexp-quote notmuch-draft-quoted-tags "\\|")
+ "\\)")))
+ (message-goto-body)
+ (while (re-search-forward re nil t)
+ ;; Remove one ! from after the #.
+ (goto-char (+ (match-beginning 0) 2))
+ (delete-char 1))))
+ (let (secure-tag)
+ (save-restriction
+ (message-narrow-to-headers)
+ (setq secure-tag (message-fetch-field "X-Notmuch-Emacs-Secure" t))
+ (message-remove-header "X-Notmuch-Emacs-Secure"))
+ (message-goto-body)
+ (when secure-tag
+ (insert secure-tag "\n")))))
+
+(defun notmuch-draft--has-encryption-tag ()
+ "Return non-nil if there is an mml secure tag."
+ (save-excursion
+ (message-goto-body)
+ (re-search-forward notmuch-draft-encryption-tag-regex nil t)))
+
+(defun notmuch-draft--query-encryption ()
+ "Return non-nil if we should save a message that should be encrypted.
+
+`notmuch-draft-save-plaintext' controls the behaviour."
+ (cl-case notmuch-draft-save-plaintext
+ ((ask)
+ (unless (yes-or-no-p
+ "(Customize `notmuch-draft-save-plaintext' to avoid this warning)
+This message contains mml tags that suggest it is intended to be encrypted.
+Really save and index an unencrypted copy? ")
+ (error "Save aborted")))
+ ((nil)
+ (error "Refusing to save draft with encryption tags (see `%s')"
+ 'notmuch-draft-save-plaintext))
+ ((t)
+ (ignore))))
+
+(defun notmuch-draft--make-message-id ()
+ ;; message-make-message-id gives the id inside a "<" ">" pair,
+ ;; but notmuch doesn't want that form, so remove them.
+ (concat "draft-" (substring (message-make-message-id) 1 -1)))
+
+;;; Commands
+
+(defun notmuch-draft-save ()
+ "Save the current draft message in the notmuch database.
+
+This saves the current message in the database with tags
+`notmuch-draft-tags' (in addition to any default tags
+applied to newly inserted messages)."
+ (interactive)
+ (when (notmuch-draft--has-encryption-tag)
+ (notmuch-draft--query-encryption))
+ (let ((id (notmuch-draft--make-message-id)))
+ (with-temporary-notmuch-message-buffer
+ ;; We insert a Date header and a Message-ID header, the former
+ ;; so that it is easier to search for the message, and the
+ ;; latter so we have a way of accessing the saved message (for
+ ;; example to delete it at a later time). We check that the
+ ;; user has these in `message-deletable-headers' (the default)
+ ;; as otherwise they are doing something strange and we
+ ;; shouldn't interfere. Note, since we are doing this in a new
+ ;; buffer we don't change the version in the compose buffer.
+ (cond
+ ((member 'Message-ID message-deletable-headers)
+ (message-remove-header "Message-ID")
+ (message-add-header (concat "Message-ID: <" id ">")))
+ (t
+ (message "You have customized emacs so Message-ID is not a %s"
+ "deletable header, so not changing it")
+ (setq id nil)))
+ (cond
+ ((member 'Date message-deletable-headers)
+ (message-remove-header "Date")
+ (message-add-header (concat "Date: " (message-make-date))))
+ (t
+ (message "You have customized emacs so Date is not a deletable %s"
+ "header, so not changing it")))
+ (message-add-header "X-Notmuch-Emacs-Draft: True")
+ (notmuch-draft-quote-some-mml)
+ (notmuch-maildir-setup-message-for-saving)
+ (notmuch-maildir-notmuch-insert-current-buffer
+ notmuch-draft-folder t notmuch-draft-tags))
+ ;; We are now back in the original compose buffer. Note the
+ ;; function notmuch-call-notmuch-process (called by
+ ;; notmuch-maildir-notmuch-insert-current-buffer) signals an error
+ ;; on failure, so to get to this point it must have
+ ;; succeeded. Also, notmuch-draft-id is still the id of the
+ ;; previous draft, so it is safe to mark it deleted.
+ (notmuch-draft--mark-deleted)
+ (setq notmuch-draft-id (concat "id:" id))
+ (set-buffer-modified-p nil)))
+
+(defun notmuch-draft-postpone ()
+ "Save the draft message in the notmuch database and exit buffer."
+ (interactive)
+ (notmuch-draft-save)
+ (kill-buffer))
+
+(defun notmuch-draft-resume (id)
+ "Resume editing of message with id ID."
+ ;; Used by command `notmuch-show-resume-message'.
+ (let* ((tags (notmuch--process-lines notmuch-command "search" "--output=tags"
+ "--exclude=false" id))
+ (draft (equal tags (notmuch-update-tags tags notmuch-draft-tags))))
+ (when (or draft
+ (yes-or-no-p "Message does not appear to be a draft: edit as new? "))
+ (pop-to-buffer-same-window
+ (get-buffer-create (concat "*notmuch-draft-" id "*")))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (let ((coding-system-for-read 'no-conversion))
+ (notmuch--call-process notmuch-command nil t nil "show" "--format=raw" id))
+ (mime-to-mml)
+ (goto-char (point-min))
+ (when (re-search-forward "^$" nil t)
+ (replace-match mail-header-separator t t))
+ ;; Remove the Date and Message-ID headers (unless the user has
+ ;; explicitly customized emacs to tell us not to) as they will
+ ;; be replaced when the message is sent.
+ (save-restriction
+ (message-narrow-to-headers)
+ (when (member 'Message-ID message-deletable-headers)
+ (message-remove-header "Message-ID"))
+ (when (member 'Date message-deletable-headers)
+ (message-remove-header "Date"))
+ (unless draft (notmuch-fcc-header-setup))
+ ;; The X-Notmuch-Emacs-Draft header is a more reliable
+ ;; indication of whether the message really is a draft.
+ (setq draft (> (message-remove-header "X-Notmuch-Emacs-Draft") 0)))
+ ;; If the message is not a draft we should not unquote any mml.
+ (when draft
+ (notmuch-draft-unquote-some-mml))
+ (notmuch-message-mode)
+ (message-goto-body)
+ (set-buffer-modified-p nil)
+ ;; If the resumed message was a draft then set the draft
+ ;; message-id so that we can delete the current saved draft if the
+ ;; message is resaved or sent.
+ (setq notmuch-draft-id (and draft id)))))
+
+;;; _
+
+(add-hook 'message-send-hook 'notmuch-draft--mark-deleted)
+
+(provide 'notmuch-draft)
+
+;;; notmuch-draft.el ends here
blob - /dev/null
blob + 4662e704f5c253ca99d1eb47456571d41faf3392 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-hello.el
+;;; notmuch-hello.el --- welcome to notmuch, a frontend -*- lexical-binding: t -*-
+;;
+;; Copyright © David Edmondson
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+;;; Code:
+
+(require 'widget)
+(require 'wid-edit) ; For `widget-forward'.
+
+(require 'notmuch-lib)
+(require 'notmuch-mua)
+
+(declare-function notmuch-search "notmuch"
+ (&optional query oldest-first target-thread target-line
+ no-display))
+(declare-function notmuch-poll "notmuch-lib" ())
+(declare-function notmuch-tree "notmuch-tree"
+ (&optional query query-context target buffer-name
+ open-target unthreaded parent-buffer oldest-first))
+(declare-function notmuch-unthreaded "notmuch-tree"
+ (&optional query query-context target buffer-name
+ open-target))
+
+
+;;; Options
+
+(defun notmuch-saved-search-get (saved-search field)
+ "Get FIELD from SAVED-SEARCH.
+
+If SAVED-SEARCH is a plist, this is just `plist-get', but for
+backwards compatibility, this also deals with the two other
+possible formats for SAVED-SEARCH: cons cells (NAME . QUERY) and
+lists (NAME QUERY COUNT-QUERY)."
+ (cond
+ ((keywordp (car saved-search))
+ (plist-get saved-search field))
+ ;; It is not a plist so it is an old-style entry.
+ ((consp (cdr saved-search))
+ (pcase-let ((`(,name ,query ,count-query) saved-search))
+ (cl-case field
+ (:name name)
+ (:query query)
+ (:count-query count-query)
+ (t nil))))
+ (t
+ (pcase-let ((`(,name . ,query) saved-search))
+ (cl-case field
+ (:name name)
+ (:query query)
+ (t nil))))))
+
+(defun notmuch-hello-saved-search-to-plist (saved-search)
+ "Return a copy of SAVED-SEARCH in plist form.
+
+If saved search is a plist then just return a copy. In other
+cases, for backwards compatibility, convert to plist form and
+return that."
+ (if (keywordp (car saved-search))
+ (copy-sequence saved-search)
+ (let ((fields (list :name :query :count-query))
+ plist-search)
+ (dolist (field fields plist-search)
+ (let ((string (notmuch-saved-search-get saved-search field)))
+ (when string
+ (setq plist-search (append plist-search (list field string)))))))))
+
+(defun notmuch-hello--saved-searches-to-plist (symbol)
+ "Extract a saved-search variable into plist form.
+
+The new style saved search is just a plist, but for backwards
+compatibility we use this function to extract old style saved
+searches so they still work in customize."
+ (let ((saved-searches (default-value symbol)))
+ (mapcar #'notmuch-hello-saved-search-to-plist saved-searches)))
+
+(define-widget 'notmuch-saved-search-plist 'list
+ "A single saved search property list."
+ :tag "Saved Search"
+ :args '((list :inline t
+ :format "%v"
+ (group :format "%v" :inline t
+ (const :format " Name: " :name)
+ (string :format "%v"))
+ (group :format "%v" :inline t
+ (const :format " Query: " :query)
+ (string :format "%v")))
+ (checklist :inline t
+ :format "%v"
+ (group :format "%v" :inline t
+ (const :format "Shortcut key: " :key)
+ (key-sequence :format "%v"))
+ (group :format "%v" :inline t
+ (const :format "Count-Query: " :count-query)
+ (string :format "%v"))
+ (group :format "%v" :inline t
+ (const :format "" :sort-order)
+ (choice :tag " Sort Order"
+ (const :tag "Default" nil)
+ (const :tag "Oldest-first" oldest-first)
+ (const :tag "Newest-first" newest-first)))
+ (group :format "%v" :inline t
+ (const :format "" :search-type)
+ (choice :tag " Search Type"
+ (const :tag "Search mode" nil)
+ (const :tag "Tree mode" tree)
+ (const :tag "Unthreaded mode" unthreaded))))))
+
+(defcustom notmuch-saved-searches
+ `((:name "inbox" :query "tag:inbox" :key ,(kbd "i"))
+ (:name "unread" :query "tag:unread" :key ,(kbd "u"))
+ (:name "flagged" :query "tag:flagged" :key ,(kbd "f"))
+ (:name "sent" :query "tag:sent" :key ,(kbd "t"))
+ (:name "drafts" :query "tag:draft" :key ,(kbd "d"))
+ (:name "all mail" :query "*" :key ,(kbd "a")))
+ "A list of saved searches to display.
+
+The saved search can be given in 3 forms. The preferred way is as
+a plist. Supported properties are
+
+ :name Name of the search (required).
+ :query Search to run (required).
+ :key Optional shortcut key for `notmuch-jump-search'.
+ :count-query Optional extra query to generate the count
+ shown. If not present then the :query property
+ is used.
+ :sort-order Specify the sort order to be used for the search.
+ Possible values are `oldest-first', `newest-first'
+ or nil. Nil means use the default sort order.
+ :search-type Specify whether to run the search in search-mode,
+ tree mode or unthreaded mode. Set to `tree' to
+ specify tree mode, 'unthreaded to specify
+ unthreaded mode, and set to nil (or anything
+ except tree and unthreaded) to specify search
+ mode.
+
+Other accepted forms are a cons cell of the form (NAME . QUERY)
+or a list of the form (NAME QUERY COUNT-QUERY)."
+ ;; The saved-search format is also used by the all-tags notmuch-hello
+ ;; section. This section generates its own saved-search list in one of
+ ;; the latter two forms.
+ :get 'notmuch-hello--saved-searches-to-plist
+ :type '(repeat notmuch-saved-search-plist)
+ :tag "List of Saved Searches"
+ :group 'notmuch-hello)
+
+(defcustom notmuch-hello-recent-searches-max 10
+ "The number of recent searches to display."
+ :type 'integer
+ :group 'notmuch-hello)
+
+(defcustom notmuch-show-empty-saved-searches nil
+ "Should saved searches with no messages be listed?"
+ :type 'boolean
+ :group 'notmuch-hello)
+
+(defun notmuch-sort-saved-searches (saved-searches)
+ "Generate an alphabetically sorted saved searches list."
+ (sort (copy-sequence saved-searches)
+ (lambda (a b)
+ (string< (notmuch-saved-search-get a :name)
+ (notmuch-saved-search-get b :name)))))
+
+(defcustom notmuch-saved-search-sort-function nil
+ "Function used to sort the saved searches for the notmuch-hello view.
+
+This variable controls how saved searches should be sorted. No
+sorting (nil) displays the saved searches in the order they are
+stored in `notmuch-saved-searches'. Sort alphabetically sorts the
+saved searches in alphabetical order. Custom sort function should
+be a function or a lambda expression that takes the saved
+searches list as a parameter, and returns a new saved searches
+list to be used. For compatibility with the various saved-search
+formats it should use notmuch-saved-search-get to access the
+fields of the search."
+ :type '(choice (const :tag "No sorting" nil)
+ (const :tag "Sort alphabetically" notmuch-sort-saved-searches)
+ (function :tag "Custom sort function"
+ :value notmuch-sort-saved-searches))
+ :group 'notmuch-hello)
+
+(defvar notmuch-hello-indent 4
+ "How much to indent non-headers.")
+
+(defimage notmuch-hello-logo ((:type svg :file "notmuch-logo.svg")))
+
+(defcustom notmuch-show-logo t
+ "Should the notmuch logo be shown?"
+ :type 'boolean
+ :group 'notmuch-hello)
+
+(defcustom notmuch-show-all-tags-list nil
+ "Should all tags be shown in the notmuch-hello view?"
+ :type 'boolean
+ :group 'notmuch-hello)
+
+(defcustom notmuch-hello-tag-list-make-query nil
+ "Function or string to generate queries for the all tags list.
+
+This variable controls which query results are shown for each tag
+in the \"all tags\" list. If nil, it will use all messages with
+that tag. If this is set to a string, it is used as a filter for
+messages having that tag (equivalent to \"tag:TAG and (THIS-VARIABLE)\").
+Finally this can be a function that will be called for each tag and
+should return a filter for that tag, or nil to hide the tag."
+ :type '(choice (const :tag "All messages" nil)
+ (const :tag "Unread messages" "tag:unread")
+ (string :tag "Custom filter"
+ :value "tag:unread")
+ (function :tag "Custom filter function"))
+ :group 'notmuch-hello)
+
+(defcustom notmuch-hello-hide-tags nil
+ "List of tags to be hidden in the \"all tags\"-section."
+ :type '(repeat string)
+ :group 'notmuch-hello)
+
+(defface notmuch-hello-logo-background
+ '((((class color)
+ (background dark))
+ (:background "#5f5f5f"))
+ (((class color)
+ (background light))
+ (:background "white")))
+ "Background colour for the notmuch logo."
+ :group 'notmuch-hello
+ :group 'notmuch-faces)
+
+(defcustom notmuch-column-control t
+ "Controls the number of columns for saved searches/tags in notmuch view.
+
+This variable has three potential sets of values:
+
+- t: automatically calculate the number of columns possible based
+ on the tags to be shown and the window width,
+- an integer: a lower bound on the number of characters that will
+ be used to display each column,
+- a float: a fraction of the window width that is the lower bound
+ on the number of characters that should be used for each
+ column.
+
+So:
+- if you would like two columns of tags, set this to 0.5.
+- if you would like a single column of tags, set this to 1.0.
+- if you would like tags to be 30 characters wide, set this to
+ 30.
+- if you don't want to worry about all of this nonsense, leave
+ this set to `t'."
+ :type '(choice
+ (const :tag "Automatically calculated" t)
+ (integer :tag "Number of characters")
+ (float :tag "Fraction of window"))
+ :group 'notmuch-hello)
+
+(defcustom notmuch-hello-thousands-separator " "
+ "The string used as a thousands separator.
+
+Typically \",\" in the US and UK and \".\" or \" \" in Europe.
+The latter is recommended in the SI/ISO 31-0 standard and by the
+International Bureau of Weights and Measures."
+ :type 'string
+ :group 'notmuch-hello)
+
+(defcustom notmuch-hello-mode-hook nil
+ "Functions called after entering `notmuch-hello-mode'."
+ :type 'hook
+ :group 'notmuch-hello
+ :group 'notmuch-hooks)
+
+(defcustom notmuch-hello-refresh-hook nil
+ "Functions called after updating a `notmuch-hello' buffer."
+ :type 'hook
+ :group 'notmuch-hello
+ :group 'notmuch-hooks)
+
+(defconst notmuch-hello-url "https://notmuchmail.org"
+ "The `notmuch' web site.")
+
+(defvar notmuch-hello-custom-section-options
+ '((:filter (string :tag "Filter for each tag"))
+ (:filter-count (string :tag "Different filter to generate message counts"))
+ (:initially-hidden (const :tag "Hide this section on startup" t))
+ (:show-empty-searches (const :tag "Show queries with no matching messages" t))
+ (:hide-if-empty (const :tag "Hide this section if all queries are empty
+\(and not shown by show-empty-searches)" t)))
+ "Various customization-options for notmuch-hello-tags/query-section.")
+
+(define-widget 'notmuch-hello-tags-section 'lazy
+ "Customize-type for notmuch-hello tag-list sections."
+ :tag "Customized tag-list section (see docstring for details)"
+ :type
+ `(list :tag ""
+ (const :tag "" notmuch-hello-insert-tags-section)
+ (string :tag "Title for this section")
+ (plist
+ :inline t
+ :options
+ ,(append notmuch-hello-custom-section-options
+ '((:hide-tags (repeat :tag "Tags that will be hidden"
+ string)))))))
+
+(define-widget 'notmuch-hello-query-section 'lazy
+ "Customize-type for custom saved-search-like sections"
+ :tag "Customized queries section (see docstring for details)"
+ :type
+ `(list :tag ""
+ (const :tag "" notmuch-hello-insert-searches)
+ (string :tag "Title for this section")
+ (repeat :tag "Queries"
+ (cons (string :tag "Name") (string :tag "Query")))
+ (plist :inline t :options ,notmuch-hello-custom-section-options)))
+
+(defcustom notmuch-hello-sections
+ (list #'notmuch-hello-insert-header
+ #'notmuch-hello-insert-saved-searches
+ #'notmuch-hello-insert-search
+ #'notmuch-hello-insert-recent-searches
+ #'notmuch-hello-insert-alltags
+ #'notmuch-hello-insert-footer)
+ "Sections for notmuch-hello.
+
+The list contains functions which are used to construct sections in
+notmuch-hello buffer. When notmuch-hello buffer is constructed,
+these functions are run in the order they appear in this list. Each
+function produces a section simply by adding content to the current
+buffer. A section should not end with an empty line, because a
+newline will be inserted after each section by `notmuch-hello'.
+
+Each function should take no arguments. The return value is
+ignored.
+
+For convenience an element can also be a list of the form (FUNC ARG1
+ARG2 .. ARGN) in which case FUNC will be applied to the rest of the
+list.
+
+A \"Customized tag-list section\" item in the customize-interface
+displays a list of all tags, optionally hiding some of them. It
+is also possible to filter the list of messages matching each tag
+by an additional filter query. Similarly, the count of messages
+displayed next to the buttons can be generated by applying a
+different filter to the tag query. These filters are also
+supported for \"Customized queries section\" items."
+ :group 'notmuch-hello
+ :type
+ '(repeat
+ (choice (function-item notmuch-hello-insert-header)
+ (function-item notmuch-hello-insert-saved-searches)
+ (function-item notmuch-hello-insert-search)
+ (function-item notmuch-hello-insert-recent-searches)
+ (function-item notmuch-hello-insert-alltags)
+ (function-item notmuch-hello-insert-footer)
+ (function-item notmuch-hello-insert-inbox)
+ notmuch-hello-tags-section
+ notmuch-hello-query-section
+ (function :tag "Custom section"))))
+
+(defcustom notmuch-hello-auto-refresh t
+ "Automatically refresh when returning to the notmuch-hello buffer."
+ :group 'notmuch-hello
+ :type 'boolean)
+
+;;; Internal variables
+
+(defvar notmuch-hello-hidden-sections nil
+ "List of sections titles whose contents are hidden.")
+
+(defvar notmuch-hello-first-run t
+ "True if `notmuch-hello' is run for the first time, set to nil afterwards.")
+
+;;; Widgets for inserters
+
+(define-widget 'notmuch-search-item 'item
+ "A recent search."
+ :format "%v\n"
+ :value-create 'notmuch-search-item-value-create)
+
+(defun notmuch-search-item-value-create (widget)
+ (let ((value (widget-get widget :value)))
+ (widget-insert (make-string notmuch-hello-indent ?\s))
+ (widget-create 'editable-field
+ :size (widget-get widget :size)
+ :parent widget
+ :action #'notmuch-hello-search
+ value)
+ (widget-insert " ")
+ (widget-create 'push-button
+ :parent widget
+ :notify #'notmuch-hello-add-saved-search
+ "save")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :parent widget
+ :notify #'notmuch-hello-delete-search-from-history
+ "del")))
+
+(defun notmuch-search-item-field-width ()
+ (max 8 ; Don't let the search boxes be less than 8 characters wide.
+ (- (window-width)
+ notmuch-hello-indent ; space at bol
+ notmuch-hello-indent ; space at eol
+ 1 ; for the space before the [save] button
+ 6 ; for the [save] button
+ 1 ; for the space before the [del] button
+ 5))) ; for the [del] button
+
+;;; Widget actions
+
+(defun notmuch-hello-search (widget &rest _event)
+ (let ((search (widget-value widget)))
+ (when search
+ (setq search (string-trim search))
+ (let ((history-delete-duplicates t))
+ (add-to-history 'notmuch-search-history search)))
+ (notmuch-search search notmuch-search-oldest-first)))
+
+(defun notmuch-hello-add-saved-search (widget &rest _event)
+ (let ((search (widget-value (widget-get widget :parent)))
+ (name (completing-read "Name for saved search: "
+ notmuch-saved-searches)))
+ ;; If an existing saved search with this name exists, remove it.
+ (setq notmuch-saved-searches
+ (cl-loop for elem in notmuch-saved-searches
+ unless (equal name (notmuch-saved-search-get elem :name))
+ collect elem))
+ ;; Add the new one.
+ (customize-save-variable 'notmuch-saved-searches
+ (add-to-list 'notmuch-saved-searches
+ (list :name name :query search) t))
+ (message "Saved '%s' as '%s'." search name)
+ (notmuch-hello-update)))
+
+(defun notmuch-hello-delete-search-from-history (widget &rest _event)
+ (when (y-or-n-p "Are you sure you want to delete this search? ")
+ (let ((search (widget-value (widget-get widget :parent))))
+ (setq notmuch-search-history
+ (delete search notmuch-search-history)))
+ (notmuch-hello-update)))
+
+;;; Button utilities
+
+;; `notmuch-hello-query-counts', `notmuch-hello-nice-number' and
+;; `notmuch-hello-insert-buttons' are used outside this section.
+;; All other functions that are defined in this section are only
+;; used by these two functions.
+
+(defun notmuch-hello-longest-label (searches-alist)
+ (or (cl-loop for elem in searches-alist
+ maximize (length (notmuch-saved-search-get elem :name)))
+ 0))
+
+(defun notmuch-hello-reflect-generate-row (ncols nrows row list)
+ (let ((len (length list)))
+ (cl-loop for col from 0 to (- ncols 1)
+ collect (let ((offset (+ (* nrows col) row)))
+ (if (< offset len)
+ (nth offset list)
+ ;; Don't forget to insert an empty slot in the
+ ;; output matrix if there is no corresponding
+ ;; value in the input matrix.
+ nil)))))
+
+(defun notmuch-hello-reflect (list ncols)
+ "Reflect a `ncols' wide matrix represented by `list' along the
+diagonal."
+ ;; Not very lispy...
+ (let ((nrows (ceiling (length list) ncols)))
+ (cl-loop for row from 0 to (- nrows 1)
+ append (notmuch-hello-reflect-generate-row ncols nrows row list))))
+
+(defun notmuch-hello-widget-search (widget &rest _ignore)
+ (cl-case (widget-get widget :notmuch-search-type)
+ (tree
+ (let ((n (notmuch-search-format-buffer-name (widget-value widget) "tree" t)))
+ (notmuch-tree (widget-get widget :notmuch-search-terms)
+ nil nil n nil nil nil
+ (widget-get widget :notmuch-search-oldest-first))))
+ (unthreaded
+ (let ((n (notmuch-search-format-buffer-name (widget-value widget)
+ "unthreaded" t)))
+ (notmuch-unthreaded (widget-get widget :notmuch-search-terms) nil nil n)))
+ (t
+ (notmuch-search (widget-get widget :notmuch-search-terms)
+ (widget-get widget :notmuch-search-oldest-first)))))
+
+(defun notmuch-saved-search-count (search)
+ (car (notmuch--process-lines notmuch-command "count" search)))
+
+(defun notmuch-hello-tags-per-line (widest)
+ "Determine how many tags to show per line and how wide they
+should be. Returns a cons cell `(tags-per-line width)'."
+ (let ((tags-per-line
+ (cond
+ ((integerp notmuch-column-control)
+ (max 1
+ (/ (- (window-width) notmuch-hello-indent)
+ ;; Count is 9 wide (8 digits plus space), 1 for the space
+ ;; after the name.
+ (+ 9 1 (max notmuch-column-control widest)))))
+ ((floatp notmuch-column-control)
+ (let* ((available-width (- (window-width) notmuch-hello-indent))
+ (proposed-width (max (* available-width notmuch-column-control)
+ widest)))
+ (floor available-width proposed-width)))
+ (t
+ (max 1
+ (/ (- (window-width) notmuch-hello-indent)
+ ;; Count is 9 wide (8 digits plus space), 1 for the space
+ ;; after the name.
+ (+ 9 1 widest)))))))
+ (cons tags-per-line (/ (max 1
+ (- (window-width) notmuch-hello-indent
+ ;; Count is 9 wide (8 digits plus
+ ;; space), 1 for the space after the
+ ;; name.
+ (* tags-per-line (+ 9 1))))
+ tags-per-line))))
+
+(defun notmuch-hello-filtered-query (query filter)
+ "Constructs a query to search all messages matching QUERY and FILTER.
+
+If FILTER is a string, it is directly used in the returned query.
+
+If FILTER is a function, it is called with QUERY as a parameter and
+the string it returns is used as the query. If nil is returned,
+the entry is hidden.
+
+Otherwise, FILTER is ignored."
+ (cond
+ ((functionp filter) (funcall filter query))
+ ((stringp filter)
+ (concat "(" query ") and (" filter ")"))
+ (t query)))
+
+(defun notmuch-hello-query-counts (query-list &rest options)
+ "Compute list of counts of matched messages from QUERY-LIST.
+
+QUERY-LIST must be a list of saved-searches. Ideally each of
+these is a plist but other options are available for backwards
+compatibility: see `notmuch-saved-searches' for details.
+
+The result is a list of plists each of which includes the
+properties :name NAME, :query QUERY and :count COUNT, together
+with any properties in the original saved-search.
+
+The values :show-empty-searches, :filter and :filter-count from
+options will be handled as specified for
+`notmuch-hello-insert-searches'. :disable-includes can be used to
+turn off the default exclude processing in `notmuch-count(1)'"
+ (with-temp-buffer
+ (dolist (elem query-list nil)
+ (let ((count-query (or (notmuch-saved-search-get elem :count-query)
+ (notmuch-saved-search-get elem :query))))
+ (insert
+ (replace-regexp-in-string
+ "\n" " "
+ (notmuch-hello-filtered-query count-query
+ (or (plist-get options :filter-count)
+ (plist-get options :filter))))
+ "\n")))
+ (unless (= (notmuch--call-process-region (point-min) (point-max) notmuch-command
+ t t nil "count"
+ (if (plist-get options :disable-excludes)
+ "--exclude=false"
+ "--exclude=true")
+ "--batch") 0)
+ (notmuch-logged-error
+ "notmuch count --batch failed"
+ "Please check that the notmuch CLI is new enough to support `count
+--batch'. In general we recommend running matching versions of
+the CLI and emacs interface."))
+ (goto-char (point-min))
+ (cl-mapcan
+ (lambda (elem)
+ (let* ((elem-plist (notmuch-hello-saved-search-to-plist elem))
+ (search-query (plist-get elem-plist :query))
+ (filtered-query (notmuch-hello-filtered-query
+ search-query (plist-get options :filter)))
+ (message-count (prog1 (read (current-buffer))
+ (forward-line 1))))
+ (when (and filtered-query (or (plist-get options :show-empty-searches)
+ (> message-count 0)))
+ (setq elem-plist (plist-put elem-plist :query filtered-query))
+ (list (plist-put elem-plist :count message-count)))))
+ query-list)))
+
+(defun notmuch-hello-nice-number (n)
+ (let (result)
+ (while (> n 0)
+ (push (% n 1000) result)
+ (setq n (/ n 1000)))
+ (setq result (or result '(0)))
+ (apply #'concat
+ (number-to-string (car result))
+ (mapcar (lambda (elem)
+ (format "%s%03d" notmuch-hello-thousands-separator elem))
+ (cdr result)))))
+
+(defun notmuch-hello-insert-buttons (searches)
+ "Insert buttons for SEARCHES.
+
+SEARCHES must be a list of plists each of which should contain at
+least the properties :name NAME :query QUERY and :count COUNT,
+where QUERY is the query to start when the button for the
+corresponding entry is activated, and COUNT should be the number
+of messages matching the query. Such a plist can be computed
+with `notmuch-hello-query-counts'."
+ (let* ((widest (notmuch-hello-longest-label searches))
+ (tags-and-width (notmuch-hello-tags-per-line widest))
+ (tags-per-line (car tags-and-width))
+ (column-width (cdr tags-and-width))
+ (column-indent 0)
+ (count 0)
+ (reordered-list (notmuch-hello-reflect searches tags-per-line))
+ ;; Hack the display of the buttons used.
+ (widget-push-button-prefix "")
+ (widget-push-button-suffix ""))
+ ;; dme: It feels as though there should be a better way to
+ ;; implement this loop than using an incrementing counter.
+ (mapc (lambda (elem)
+ ;; (not elem) indicates an empty slot in the matrix.
+ (when elem
+ (when (> column-indent 0)
+ (widget-insert (make-string column-indent ? )))
+ (let* ((name (plist-get elem :name))
+ (query (plist-get elem :query))
+ (oldest-first (cl-case (plist-get elem :sort-order)
+ (newest-first nil)
+ (oldest-first t)
+ (otherwise notmuch-search-oldest-first)))
+ (search-type (plist-get elem :search-type))
+ (msg-count (plist-get elem :count)))
+ (widget-insert (format "%8s "
+ (notmuch-hello-nice-number msg-count)))
+ (widget-create 'push-button
+ :notify #'notmuch-hello-widget-search
+ :notmuch-search-terms query
+ :notmuch-search-oldest-first oldest-first
+ :notmuch-search-type search-type
+ name)
+ (setq column-indent
+ (1+ (max 0 (- column-width (length name)))))))
+ (cl-incf count)
+ (when (eq (% count tags-per-line) 0)
+ (setq column-indent 0)
+ (widget-insert "\n")))
+ reordered-list)
+ ;; If the last line was not full (and hence did not include a
+ ;; carriage return), insert one now.
+ (unless (eq (% count tags-per-line) 0)
+ (widget-insert "\n"))))
+
+;;; Mode
+
+(defun notmuch-hello-update ()
+ "Update the notmuch-hello buffer."
+ ;; Lazy - rebuild everything.
+ (interactive)
+ (notmuch-hello t))
+
+(defun notmuch-hello-window-configuration-change ()
+ "Hook function to update the hello buffer when it is switched to."
+ (let ((hello-buf (get-buffer "*notmuch-hello*"))
+ (do-refresh nil))
+ ;; Consider all windows in the currently selected frame, since
+ ;; that's where the configuration change happened. This also
+ ;; refreshes our snapshot of all windows, so we have to do this
+ ;; even if we know we won't refresh (e.g., hello-buf is null).
+ (dolist (window (window-list))
+ (let ((last-buf (window-parameter window 'notmuch-hello-last-buffer))
+ (cur-buf (window-buffer window)))
+ (unless (eq last-buf cur-buf)
+ ;; This window changed or is new. Update recorded buffer
+ ;; for next time.
+ (set-window-parameter window 'notmuch-hello-last-buffer cur-buf)
+ (when (and (eq cur-buf hello-buf) last-buf)
+ ;; The user just switched to hello in this window (hello
+ ;; is currently visible, was not visible on the last
+ ;; configuration change, and this is not a new window)
+ (setq do-refresh t)))))
+ (when (and do-refresh notmuch-hello-auto-refresh)
+ ;; Refresh hello as soon as we get back to redisplay. On Emacs
+ ;; 24, we can't do it right here because something in this
+ ;; hook's call stack overrides hello's point placement.
+ ;; FIXME And on Emacs releases that we still support?
+ (run-at-time nil nil #'notmuch-hello t))
+ (unless hello-buf
+ ;; Clean up hook
+ (remove-hook 'window-configuration-change-hook
+ #'notmuch-hello-window-configuration-change))))
+
+(defvar notmuch-hello-mode-map
+ ;; Inherit both widget-keymap and notmuch-common-keymap. We have
+ ;; to use make-sparse-keymap to force this to be a new keymap (so
+ ;; that when we modify map it does not modify widget-keymap).
+ (let ((map (make-composed-keymap (list (make-sparse-keymap) widget-keymap))))
+ (set-keymap-parent map notmuch-common-keymap)
+ ;; Currently notmuch-hello-mode supports free text entry, but not
+ ;; tagging operations, so provide standard undo.
+ (define-key map [remap notmuch-tag-undo] #'undo)
+ map)
+ "Keymap for \"notmuch hello\" buffers.")
+
+(define-derived-mode notmuch-hello-mode fundamental-mode "notmuch-hello"
+ "Major mode for convenient notmuch navigation. This is your entry portal into notmuch.
+
+Saved searches are \"bookmarks\" for arbitrary queries. Hit RET
+or click on a saved search to view matching threads. Edit saved
+searches with the `edit' button. Type `\\[notmuch-jump-search]'
+in any Notmuch screen for quick access to saved searches that
+have shortcut keys.
+
+Type new searches in the search box and hit RET to view matching
+threads. Hit RET in a recent search box to re-submit a previous
+search. Edit it first if you like. Save a recent search to saved
+searches with the `save' button.
+
+Hit `\\[notmuch-search]' or `\\[notmuch-tree]' in any Notmuch
+screen to search for messages and view matching threads or
+messages, respectively. Recent searches are available in the
+minibuffer history.
+
+Expand the all tags view with the `show' button (and collapse
+again with the `hide' button). Hit RET or click on a tag name to
+view matching threads.
+
+Hit `\\[notmuch-refresh-this-buffer]' to refresh the screen and
+`\\[notmuch-bury-or-kill-this-buffer]' to quit.
+
+The screen may be customized via `\\[customize]'.
+
+Complete list of currently available key bindings:
+
+\\{notmuch-hello-mode-map}"
+ (setq notmuch-buffer-refresh-function #'notmuch-hello-update))
+
+;;; Inserters
+
+(defun notmuch-hello-generate-tag-alist (&optional hide-tags)
+ "Return an alist from tags to queries to display in the all-tags section."
+ (cl-mapcan (lambda (tag)
+ (and (not (member tag hide-tags))
+ (list (cons tag
+ (concat "tag:"
+ (notmuch-escape-boolean-term tag))))))
+ (notmuch--process-lines notmuch-command "search" "--output=tags" "*")))
+
+(defun notmuch-hello-insert-header ()
+ "Insert the default notmuch-hello header."
+ (when notmuch-show-logo
+ (let ((image notmuch-hello-logo))
+ ;; The notmuch logo uses transparency. That can display poorly
+ ;; when inserting the image into an emacs buffer (black logo on
+ ;; a black background), so force the background colour of the
+ ;; image. We use a face to represent the colour so that
+ ;; `defface' can be used to declare the different possible
+ ;; colours, which depend on whether the frame has a light or
+ ;; dark background.
+ (setq image (cons 'image
+ (append (cdr image)
+ (list :background
+ (face-background
+ 'notmuch-hello-logo-background)))))
+ (insert-image image))
+ (widget-insert " "))
+
+ (widget-insert "Welcome to ")
+ ;; Hack the display of the links used.
+ (let ((widget-link-prefix "")
+ (widget-link-suffix ""))
+ (widget-create 'link
+ :notify (lambda (&rest _ignore)
+ (browse-url notmuch-hello-url))
+ :help-echo "Visit the notmuch website."
+ "notmuch")
+ (widget-insert ". ")
+ (widget-insert "You have ")
+ (widget-create 'link
+ :notify (lambda (&rest _ignore)
+ (notmuch-hello-update))
+ :help-echo "Refresh"
+ (notmuch-hello-nice-number
+ (string-to-number
+ (car (notmuch--process-lines notmuch-command "count" "--exclude=false")))))
+ (widget-insert " messages.\n")))
+
+(defun notmuch-hello-insert-saved-searches ()
+ "Insert the saved-searches section."
+ (let ((searches (notmuch-hello-query-counts
+ (if notmuch-saved-search-sort-function
+ (funcall notmuch-saved-search-sort-function
+ notmuch-saved-searches)
+ notmuch-saved-searches)
+ :show-empty-searches notmuch-show-empty-saved-searches)))
+ (when searches
+ (widget-insert "Saved searches: ")
+ (widget-create 'push-button
+ :notify (lambda (&rest _ignore)
+ (customize-variable 'notmuch-saved-searches))
+ "edit")
+ (widget-insert "\n\n")
+ (let ((start (point)))
+ (notmuch-hello-insert-buttons searches)
+ (indent-rigidly start (point) notmuch-hello-indent)))))
+
+(defun notmuch-hello-insert-search ()
+ "Insert a search widget."
+ (widget-insert "Search: ")
+ (widget-create 'editable-field
+ ;; Leave some space at the start and end of the
+ ;; search boxes.
+ :size (max 8 (- (window-width) notmuch-hello-indent
+ (length "Search: ")))
+ :action #'notmuch-hello-search)
+ ;; Add an invisible dot to make `widget-end-of-line' ignore
+ ;; trailing spaces in the search widget field. A dot is used
+ ;; instead of a space to make `show-trailing-whitespace'
+ ;; happy, i.e. avoid it marking the whole line as trailing
+ ;; spaces.
+ (widget-insert (propertize "." 'invisible t))
+ (widget-insert "\n"))
+
+(defun notmuch-hello-insert-recent-searches ()
+ "Insert recent searches."
+ (when notmuch-search-history
+ (widget-insert "Recent searches: ")
+ (widget-create
+ 'push-button
+ :notify (lambda (&rest _ignore)
+ (when (y-or-n-p "Are you sure you want to clear the searches? ")
+ (setq notmuch-search-history nil)
+ (notmuch-hello-update)))
+ "clear")
+ (widget-insert "\n\n")
+ (let ((width (notmuch-search-item-field-width)))
+ (dolist (search (seq-take notmuch-search-history
+ notmuch-hello-recent-searches-max))
+ (widget-create 'notmuch-search-item :value search :size width)))))
+
+(defun notmuch-hello-insert-searches (title query-list &rest options)
+ "Insert a section with TITLE showing a list of buttons made from QUERY-LIST.
+
+QUERY-LIST should ideally be a plist but for backwards
+compatibility other forms are also accepted (see
+`notmuch-saved-searches' for details). The plist should
+contain keys :name and :query; if :count-query is also present
+then it specifies an alternate query to be used to generate the
+count for the associated search.
+
+Supports the following entries in OPTIONS as a plist:
+:initially-hidden - if non-nil, section will be hidden on startup
+:show-empty-searches - show buttons with no matching messages
+:hide-if-empty - hide if no buttons would be shown
+ (only makes sense without :show-empty-searches)
+:filter - This can be a function that takes the search query as its argument and
+ returns a filter to be used in conjunction with the query for that search or nil
+ to hide the element. This can also be a string that is used as a combined with
+ each query using \"and\".
+:filter-count - Separate filter to generate the count displayed each search. Accepts
+ the same values as :filter. If :filter and :filter-count are specified, this
+ will be used instead of :filter, not in conjunction with it."
+ (widget-insert title ": ")
+ (when (and notmuch-hello-first-run (plist-get options :initially-hidden))
+ (add-to-list 'notmuch-hello-hidden-sections title))
+ (let ((is-hidden (member title notmuch-hello-hidden-sections))
+ (start (point)))
+ (if is-hidden
+ (widget-create 'push-button
+ :notify (lambda (&rest _ignore)
+ (setq notmuch-hello-hidden-sections
+ (delete title notmuch-hello-hidden-sections))
+ (notmuch-hello-update))
+ "show")
+ (widget-create 'push-button
+ :notify (lambda (&rest _ignore)
+ (add-to-list 'notmuch-hello-hidden-sections
+ title)
+ (notmuch-hello-update))
+ "hide"))
+ (widget-insert "\n")
+ (unless is-hidden
+ (let ((searches (apply 'notmuch-hello-query-counts query-list options)))
+ (when (or (not (plist-get options :hide-if-empty))
+ searches)
+ (widget-insert "\n")
+ (notmuch-hello-insert-buttons searches)
+ (indent-rigidly start (point) notmuch-hello-indent))))))
+
+(defun notmuch-hello-insert-tags-section (&optional title &rest options)
+ "Insert a section displaying all tags with message counts.
+
+TITLE defaults to \"All tags\".
+Allowed options are those accepted by `notmuch-hello-insert-searches' and the
+following:
+
+:hide-tags - List of tags that should be excluded."
+ (apply 'notmuch-hello-insert-searches
+ (or title "All tags")
+ (notmuch-hello-generate-tag-alist (plist-get options :hide-tags))
+ options))
+
+(defun notmuch-hello-insert-inbox ()
+ "Show an entry for each saved search and inboxed messages for each tag."
+ (notmuch-hello-insert-searches "What's in your inbox"
+ (append
+ notmuch-saved-searches
+ (notmuch-hello-generate-tag-alist))
+ :filter "tag:inbox"))
+
+(defun notmuch-hello-insert-alltags ()
+ "Insert a section displaying all tags and associated message counts."
+ (notmuch-hello-insert-tags-section
+ nil
+ :initially-hidden (not notmuch-show-all-tags-list)
+ :hide-tags notmuch-hello-hide-tags
+ :filter notmuch-hello-tag-list-make-query
+ :disable-excludes t))
+
+(defun notmuch-hello-insert-footer ()
+ "Insert the notmuch-hello footer."
+ (let ((start (point)))
+ (widget-insert "Hit `?' for context-sensitive help in any Notmuch screen.\n")
+ (widget-insert "Customize ")
+ (widget-create 'link
+ :notify (lambda (&rest _ignore)
+ (customize-group 'notmuch))
+ :button-prefix "" :button-suffix ""
+ "Notmuch")
+ (widget-insert " or ")
+ (widget-create 'link
+ :notify (lambda (&rest _ignore)
+ (customize-variable 'notmuch-hello-sections))
+ :button-prefix "" :button-suffix ""
+ "this page.")
+ (let ((fill-column (- (window-width) notmuch-hello-indent)))
+ (center-region start (point)))))
+
+;;; Hello!
+
+;;;###autoload
+(defun notmuch-hello (&optional no-display)
+ "Run notmuch and display saved searches, known tags, etc."
+ (interactive)
+ (notmuch-assert-cli-sane)
+ ;; This may cause a window configuration change, so if the
+ ;; auto-refresh hook is already installed, avoid recursive refresh.
+ (let ((notmuch-hello-auto-refresh nil))
+ (if no-display
+ (set-buffer "*notmuch-hello*")
+ (pop-to-buffer-same-window "*notmuch-hello*")))
+ ;; Install auto-refresh hook
+ (when notmuch-hello-auto-refresh
+ (add-hook 'window-configuration-change-hook
+ #'notmuch-hello-window-configuration-change))
+ (let ((target-line (line-number-at-pos))
+ (target-column (current-column))
+ (inhibit-read-only t))
+ ;; Delete all editable widget fields. Editable widget fields are
+ ;; tracked in a buffer local variable `widget-field-list' (and
+ ;; others). If we do `erase-buffer' without properly deleting the
+ ;; widgets, some widget-related functions are confused later.
+ (mapc 'widget-delete widget-field-list)
+ (erase-buffer)
+ (unless (eq major-mode 'notmuch-hello-mode)
+ (notmuch-hello-mode))
+ (let ((all (overlay-lists)))
+ ;; Delete all the overlays.
+ (mapc 'delete-overlay (car all))
+ (mapc 'delete-overlay (cdr all)))
+ (mapc
+ (lambda (section)
+ (let ((point-before (point)))
+ (if (functionp section)
+ (funcall section)
+ (apply (car section) (cdr section)))
+ ;; don't insert a newline when the previous section didn't
+ ;; show anything.
+ (unless (eq (point) point-before)
+ (widget-insert "\n"))))
+ notmuch-hello-sections)
+ (widget-setup)
+ ;; Move point back to where it was before refresh. Use line and
+ ;; column instead of point directly to be insensitive to additions
+ ;; and removals of text within earlier lines.
+ (goto-char (point-min))
+ (forward-line (1- target-line))
+ (move-to-column target-column))
+ (run-hooks 'notmuch-hello-refresh-hook)
+ (setq notmuch-hello-first-run nil))
+
+;;; _
+
+(provide 'notmuch-hello)
+
+;;; notmuch-hello.el ends here
blob - /dev/null
blob + 6a2769282ec666190b1a7cdeea8364782389977f (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-jump.el
+;;; notmuch-jump.el --- User-friendly shortcut keys -*- lexical-binding: t -*-
+;;
+;; Copyright © Austin Clements
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Austin Clements <aclements@csail.mit.edu>
+;; David Edmondson <dme@dme.org>
+
+;;; Code:
+
+(require 'notmuch-lib)
+(require 'notmuch-hello)
+
+(declare-function notmuch-search "notmuch")
+(declare-function notmuch-tree "notmuch-tree")
+(declare-function notmuch-unthreaded "notmuch-tree")
+
+;;;###autoload
+(defun notmuch-jump-search ()
+ "Jump to a saved search by shortcut key.
+
+This prompts for and performs a saved search using the shortcut
+keys configured in the :key property of `notmuch-saved-searches'.
+Typically these shortcuts are a single key long, so this is a
+fast way to jump to a saved search from anywhere in Notmuch."
+ (interactive)
+ ;; Build the action map
+ (let (action-map)
+ (dolist (saved-search notmuch-saved-searches)
+ (let* ((saved-search (notmuch-hello-saved-search-to-plist saved-search))
+ (key (plist-get saved-search :key)))
+ (when key
+ (let ((name (plist-get saved-search :name))
+ (query (plist-get saved-search :query))
+ (oldest-first
+ (cl-case (plist-get saved-search :sort-order)
+ (newest-first nil)
+ (oldest-first t)
+ (otherwise (default-value 'notmuch-search-oldest-first)))))
+ (push (list key name
+ (cond
+ ((eq (plist-get saved-search :search-type) 'tree)
+ (lambda () (notmuch-tree query)))
+ ((eq (plist-get saved-search :search-type) 'unthreaded)
+ (lambda () (notmuch-unthreaded query)))
+ (t
+ (lambda () (notmuch-search query oldest-first)))))
+ action-map)))))
+ (setq action-map (nreverse action-map))
+ (if action-map
+ (notmuch-jump action-map "Search: ")
+ (error "To use notmuch-jump, %s"
+ "please customize shortcut keys in notmuch-saved-searches."))))
+
+(defface notmuch-jump-key
+ '((t :inherit minibuffer-prompt))
+ "Default face used for keys in `notmuch-jump' and related."
+ :group 'notmuch-faces)
+
+(defvar notmuch-jump--action nil)
+
+;;;###autoload
+(defun notmuch-jump (action-map prompt)
+ "Interactively prompt for one of the keys in ACTION-MAP.
+
+Displays a summary of all bindings in ACTION-MAP in the
+minibuffer, reads a key from the minibuffer, and performs the
+corresponding action. The prompt can be canceled with C-g or
+RET. PROMPT must be a string to use for the prompt. PROMPT
+should include a space at the end.
+
+ACTION-MAP must be a list of triples of the form
+ (KEY LABEL ACTION)
+where KEY is a key binding, LABEL is a string label to display in
+the buffer, and ACTION is a nullary function to call. LABEL may
+be null, in which case the action will still be bound, but will
+not appear in the pop-up buffer."
+ (let* ((items (notmuch-jump--format-actions action-map))
+ ;; Format the table of bindings and the full prompt
+ (table
+ (with-temp-buffer
+ (notmuch-jump--insert-items (window-body-width) items)
+ (buffer-string)))
+ (full-prompt
+ (concat table "\n\n"
+ (propertize prompt 'face 'minibuffer-prompt)))
+ ;; By default, the minibuffer applies the minibuffer face to
+ ;; the entire prompt. However, we want to clearly
+ ;; distinguish bindings (which we put in the prompt face
+ ;; ourselves) from their labels, so disable the minibuffer's
+ ;; own re-face-ing.
+ (minibuffer-prompt-properties
+ (notmuch-plist-delete
+ (copy-sequence minibuffer-prompt-properties)
+ 'face))
+ ;; Build the keymap with our bindings
+ (minibuffer-map (notmuch-jump--make-keymap action-map prompt))
+ ;; The bindings save the the action in notmuch-jump--action
+ (notmuch-jump--action nil))
+ ;; Read the action
+ (read-from-minibuffer full-prompt nil minibuffer-map)
+ ;; If we got an action, do it
+ (when notmuch-jump--action
+ (funcall notmuch-jump--action))))
+
+(defun notmuch-jump--format-actions (action-map)
+ "Format the actions in ACTION-MAP.
+
+Returns a list of strings, one for each item with a label in
+ACTION-MAP. These strings can be inserted into a tabular
+buffer."
+ ;; Compute the maximum key description width
+ (let ((key-width 1))
+ (pcase-dolist (`(,key ,_desc) action-map)
+ (setq key-width
+ (max key-width
+ (string-width (format-kbd-macro key)))))
+ ;; Format each action
+ (mapcar (pcase-lambda (`(,key ,desc))
+ (setq key (format-kbd-macro key))
+ (concat (propertize key 'face 'notmuch-jump-key)
+ (make-string (- key-width (length key)) ? )
+ " " desc))
+ action-map)))
+
+(defun notmuch-jump--insert-items (width items)
+ "Make a table of ITEMS up to WIDTH wide in the current buffer."
+ (let* ((nitems (length items))
+ (col-width (+ 3 (apply #'max (mapcar #'string-width items))))
+ (ncols (if (> (* col-width nitems) width)
+ (max 1 (/ width col-width))
+ ;; Items fit on one line. Space them out
+ (setq col-width (/ width nitems))
+ (length items))))
+ (while items
+ (dotimes (col ncols)
+ (when items
+ (let ((item (pop items)))
+ (insert item)
+ (when (and items (< col (- ncols 1)))
+ (insert (make-string (- col-width (string-width item)) ? ))))))
+ (when items
+ (insert "\n")))))
+
+(defvar notmuch-jump-minibuffer-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ ;; Make this like a special-mode keymap, with no self-insert-command
+ (suppress-keymap map)
+ (define-key map (kbd "DEL") 'exit-minibuffer)
+ map)
+ "Base keymap for notmuch-jump's minibuffer keymap.")
+
+(defun notmuch-jump--make-keymap (action-map prompt)
+ "Translate ACTION-MAP into a minibuffer keymap."
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map notmuch-jump-minibuffer-map)
+ (pcase-dolist (`(,key ,_name ,fn) action-map)
+ (when (= (length key) 1)
+ (define-key map key
+ (lambda ()
+ (interactive)
+ (setq notmuch-jump--action fn)
+ (exit-minibuffer)))))
+ ;; By doing this in two passes (and checking if we already have a
+ ;; binding) we avoid problems if the user specifies a binding which
+ ;; is a prefix of another binding.
+ (pcase-dolist (`(,key ,_name ,_fn) action-map)
+ (when (> (length key) 1)
+ (let* ((key (elt key 0))
+ (keystr (string key))
+ (new-prompt (concat prompt (format-kbd-macro keystr) " "))
+ (action-submap nil))
+ (unless (lookup-key map keystr)
+ (pcase-dolist (`(,k ,n ,f) action-map)
+ (when (= key (elt k 0))
+ (push (list (substring k 1) n f) action-submap)))
+ ;; We deal with backspace specially
+ (push (list (kbd "DEL")
+ "Backup"
+ (apply-partially #'notmuch-jump action-map prompt))
+ action-submap)
+ (setq action-submap (nreverse action-submap))
+ (define-key map keystr
+ (lambda ()
+ (interactive)
+ (setq notmuch-jump--action
+ (apply-partially #'notmuch-jump
+ action-submap
+ new-prompt))
+ (exit-minibuffer)))))))
+ map))
+
+(provide 'notmuch-jump)
+
+;;; notmuch-jump.el ends here
blob - /dev/null
blob + a09f4ab8f27bb3a8e5684ef3b8f524bc4c32b7f0 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-lib.el
+;;; notmuch-lib.el --- common variables, functions and function declarations -*- lexical-binding: t -*-
+;;
+;; Copyright © Carl Worth
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'pcase)
+(require 'subr-x)
+
+(require 'mm-util)
+(require 'mm-view)
+(require 'mm-decode)
+
+(require 'notmuch-compat)
+
+(unless (require 'notmuch-version nil t)
+ (defconst notmuch-emacs-version "unknown"
+ "Placeholder variable when notmuch-version.el[c] is not available."))
+
+;;; Groups
+
+(defgroup notmuch nil
+ "Notmuch mail reader for Emacs."
+ :group 'mail)
+
+(defgroup notmuch-hello nil
+ "Overview of saved searches, tags, etc."
+ :group 'notmuch)
+
+(defgroup notmuch-search nil
+ "Searching and sorting mail."
+ :group 'notmuch)
+
+(defgroup notmuch-show nil
+ "Showing messages and threads."
+ :group 'notmuch)
+
+(defgroup notmuch-send nil
+ "Sending messages from Notmuch."
+ :group 'notmuch
+ :group 'message)
+
+(defgroup notmuch-tag nil
+ "Tags and tagging in Notmuch."
+ :group 'notmuch)
+
+(defgroup notmuch-crypto nil
+ "Processing and display of cryptographic MIME parts."
+ :group 'notmuch)
+
+(defgroup notmuch-hooks nil
+ "Running custom code on well-defined occasions."
+ :group 'notmuch)
+
+(defgroup notmuch-external nil
+ "Running external commands from within Notmuch."
+ :group 'notmuch)
+
+(defgroup notmuch-address nil
+ "Address completion."
+ :group 'notmuch)
+
+(defgroup notmuch-faces nil
+ "Graphical attributes for displaying text"
+ :group 'notmuch)
+
+;;; Options
+
+(defcustom notmuch-command "notmuch"
+ "Name of the notmuch binary.
+
+This can be a relative or absolute path to the notmuch binary.
+If this is a relative path, it will be searched for in all of the
+directories given in `exec-path' (which is, by default, based on
+$PATH)."
+ :type 'string
+ :group 'notmuch-external)
+
+(defcustom notmuch-search-oldest-first t
+ "Show the oldest mail first when searching.
+
+This variable defines the default sort order for displaying
+search results. Note that any filtered searches created by
+`notmuch-search-filter' retain the search order of the parent
+search."
+ :type 'boolean
+ :group 'notmuch-search)
+(make-variable-buffer-local 'notmuch-search-oldest-first)
+
+(defcustom notmuch-poll-script nil
+ "[Deprecated] Command to run to incorporate new mail into the notmuch database.
+
+This option has been deprecated in favor of \"notmuch new\"
+hooks (see man notmuch-hooks). To change the path to the notmuch
+binary, customize `notmuch-command'.
+
+This variable controls the action invoked by
+`notmuch-poll-and-refresh-this-buffer' (bound by default to 'G')
+to incorporate new mail into the notmuch database.
+
+If set to nil (the default), new mail is processed by invoking
+\"notmuch new\". Otherwise, this should be set to a string that
+gives the name of an external script that processes new mail. If
+set to the empty string, no command will be run.
+
+The external script could do any of the following depending on
+the user's needs:
+
+1. Invoke a program to transfer mail to the local mail store
+2. Invoke \"notmuch new\" to incorporate the new mail
+3. Invoke one or more \"notmuch tag\" commands to classify the mail"
+ :type '(choice (const :tag "notmuch new" nil)
+ (const :tag "Disabled" "")
+ (string :tag "Custom script"))
+ :group 'notmuch-external)
+
+(defcustom notmuch-archive-tags '("-inbox")
+ "List of tag changes to apply to a message or a thread when it is archived.
+
+Tags starting with \"+\" (or not starting with either \"+\" or
+\"-\") in the list will be added, and tags starting with \"-\"
+will be removed from the message or thread being archived.
+
+For example, if you wanted to remove an \"inbox\" tag and add an
+\"archived\" tag, you would set:
+ (\"-inbox\" \"+archived\")"
+ :type '(repeat string)
+ :group 'notmuch-search
+ :group 'notmuch-show)
+
+;;; Variables
+
+(defvar notmuch-search-history nil
+ "Variable to store notmuch searches history.")
+
+(defvar notmuch-common-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "?" 'notmuch-help)
+ (define-key map "v" 'notmuch-version)
+ (define-key map "q" 'notmuch-bury-or-kill-this-buffer)
+ (define-key map "s" 'notmuch-search)
+ (define-key map "t" 'notmuch-search-by-tag)
+ (define-key map "z" 'notmuch-tree)
+ (define-key map "u" 'notmuch-unthreaded)
+ (define-key map "m" 'notmuch-mua-new-mail)
+ (define-key map "g" 'notmuch-refresh-this-buffer)
+ (define-key map "=" 'notmuch-refresh-this-buffer)
+ (define-key map (kbd "M-=") 'notmuch-refresh-all-buffers)
+ (define-key map "G" 'notmuch-poll-and-refresh-this-buffer)
+ (define-key map "j" 'notmuch-jump-search)
+ (define-key map [remap undo] 'notmuch-tag-undo)
+ map)
+ "Keymap shared by all notmuch modes.")
+
+;; By default clicking on a button does not select the window
+;; containing the button (as opposed to clicking on a widget which
+;; does). This means that the button action is then executed in the
+;; current selected window which can cause problems if the button
+;; changes the buffer (e.g., id: links) or moves point.
+;;
+;; This provides a button type which overrides mouse-action so that
+;; the button's window is selected before the action is run. Other
+;; notmuch buttons can get the same behaviour by inheriting from this
+;; button type.
+(define-button-type 'notmuch-button-type
+ 'mouse-action (lambda (button)
+ (select-window (posn-window (event-start last-input-event)))
+ (button-activate button)))
+
+;;; CLI Utilities
+
+(defun notmuch-command-to-string (&rest args)
+ "Synchronously invoke \"notmuch\" with the given list of arguments.
+
+If notmuch exits with a non-zero status, output from the process
+will appear in a buffer named \"*Notmuch errors*\" and an error
+will be signaled.
+
+Otherwise the output will be returned."
+ (with-temp-buffer
+ (let ((status (apply #'notmuch--call-process notmuch-command nil t nil args))
+ (output (buffer-string)))
+ (notmuch-check-exit-status status (cons notmuch-command args) output)
+ output)))
+
+(defvar notmuch--cli-sane-p nil
+ "Cache whether the CLI seems to be configured sanely.")
+
+(defun notmuch-cli-sane-p ()
+ "Return t if the cli seems to be configured sanely."
+ (unless notmuch--cli-sane-p
+ (let ((status (notmuch--call-process notmuch-command nil nil nil
+ "config" "get" "user.primary_email")))
+ (setq notmuch--cli-sane-p (= status 0))))
+ notmuch--cli-sane-p)
+
+(defun notmuch-assert-cli-sane ()
+ (unless (notmuch-cli-sane-p)
+ (notmuch-logged-error
+ "notmuch cli seems misconfigured or unconfigured."
+ "Perhaps you haven't run \"notmuch setup\" yet? Try running this
+on the command line, and then retry your notmuch command")))
+
+(defun notmuch-cli-version ()
+ "Return a string with the notmuch cli command version number."
+ (let ((long-string
+ ;; Trim off the trailing newline.
+ (substring (notmuch-command-to-string "--version") 0 -1)))
+ (if (string-match "^notmuch\\( version\\)? \\(.*\\)$"
+ long-string)
+ (match-string 2 long-string)
+ "unknown")))
+
+(defvar notmuch-emacs-version)
+
+(defun notmuch-version ()
+ "Display the notmuch version.
+The versions of the Emacs package and the `notmuch' executable
+should match, but if and only if they don't, then this command
+displays both values separately."
+ (interactive)
+ (let ((cli-version (notmuch-cli-version)))
+ (message "notmuch version %s"
+ (if (string= notmuch-emacs-version cli-version)
+ cli-version
+ (concat cli-version
+ " (emacs mua version " notmuch-emacs-version ")")))))
+
+;;; Notmuch Configuration
+
+(defun notmuch-config-get (item)
+ "Return a value from the notmuch configuration."
+ (let* ((val (notmuch-command-to-string "config" "get" item))
+ (len (length val)))
+ ;; Trim off the trailing newline (if the value is empty or not
+ ;; configured, there will be no newline).
+ (if (and (> len 0)
+ (= (aref val (- len 1)) ?\n))
+ (substring val 0 -1)
+ val)))
+
+(defun notmuch-database-path ()
+ "Return the database.path value from the notmuch configuration."
+ (notmuch-config-get "database.path"))
+
+(defun notmuch-user-name ()
+ "Return the user.name value from the notmuch configuration."
+ (notmuch-config-get "user.name"))
+
+(defun notmuch-user-primary-email ()
+ "Return the user.primary_email value from the notmuch configuration."
+ (notmuch-config-get "user.primary_email"))
+
+(defun notmuch-user-other-email ()
+ "Return the user.other_email value (as a list) from the notmuch configuration."
+ (split-string (notmuch-config-get "user.other_email") "\n" t))
+
+(defun notmuch-user-emails ()
+ (cons (notmuch-user-primary-email) (notmuch-user-other-email)))
+
+;;; Commands
+
+(defun notmuch-poll ()
+ "Run \"notmuch new\" or an external script to import mail.
+
+Invokes `notmuch-poll-script', \"notmuch new\", or does nothing
+depending on the value of `notmuch-poll-script'."
+ (interactive)
+ (message "Polling mail...")
+ (if (stringp notmuch-poll-script)
+ (unless (string-empty-p notmuch-poll-script)
+ (unless (equal (notmuch--call-process notmuch-poll-script nil nil) 0)
+ (error "Notmuch: poll script `%s' failed!" notmuch-poll-script)))
+ (notmuch-call-notmuch-process "new"))
+ (message "Polling mail...done"))
+
+(defun notmuch-bury-or-kill-this-buffer ()
+ "Undisplay the current buffer.
+
+Bury the current buffer, unless there is only one window showing
+it, in which case it is killed."
+ (interactive)
+ (if (> (length (get-buffer-window-list nil nil t)) 1)
+ (bury-buffer)
+ (kill-buffer)))
+
+;;; Describe Key Bindings
+
+(defun notmuch-prefix-key-description (key)
+ "Given a prefix key code, return a human-readable string representation.
+
+This is basically just `format-kbd-macro' but we also convert ESC to M-."
+ (let* ((key-vector (if (vectorp key) key (vector key)))
+ (desc (format-kbd-macro key-vector)))
+ (if (string= desc "ESC")
+ "M-"
+ (concat desc " "))))
+
+(defun notmuch-describe-key (actual-key binding prefix ua-keys tail)
+ "Prepend cons cells describing prefix-arg ACTUAL-KEY and ACTUAL-KEY to TAIL.
+
+It does not prepend if ACTUAL-KEY is already listed in TAIL."
+ (let ((key-string (concat prefix (key-description actual-key))))
+ ;; We don't include documentation if the key-binding is
+ ;; over-ridden. Note, over-riding a binding automatically hides the
+ ;; prefixed version too.
+ (unless (assoc key-string tail)
+ (when (and ua-keys (symbolp binding)
+ (get binding 'notmuch-prefix-doc))
+ ;; Documentation for prefixed command
+ (let ((ua-desc (key-description ua-keys)))
+ (push (cons (concat ua-desc " " prefix (format-kbd-macro actual-key))
+ (get binding 'notmuch-prefix-doc))
+ tail)))
+ ;; Documentation for command
+ (push (cons key-string
+ (or (and (symbolp binding)
+ (get binding 'notmuch-doc))
+ (and (functionp binding)
+ (let ((doc (documentation binding)))
+ (and doc
+ (string-match "\\`.+" doc)
+ (match-string 0 doc))))))
+ tail)))
+ tail)
+
+(defun notmuch-describe-remaps (remap-keymap ua-keys base-keymap prefix tail)
+ ;; Remappings are represented as a binding whose first "event" is
+ ;; 'remap. Hence, if the keymap has any remappings, it will have a
+ ;; binding whose "key" is 'remap, and whose "binding" is itself a
+ ;; keymap that maps not from keys to commands, but from old (remapped)
+ ;; functions to the commands to use in their stead.
+ (map-keymap (lambda (command binding)
+ (mapc (lambda (actual-key)
+ (setq tail
+ (notmuch-describe-key actual-key binding
+ prefix ua-keys tail)))
+ (where-is-internal command base-keymap)))
+ remap-keymap)
+ tail)
+
+(defun notmuch-describe-keymap (keymap ua-keys base-keymap &optional prefix tail)
+ "Return a list of cons cells, each describing one binding in KEYMAP.
+
+Each cons cell consists of a string giving a human-readable
+description of the key, and a one-line description of the bound
+function. See `notmuch-help' for an overview of how this
+documentation is extracted.
+
+UA-KEYS should be a key sequence bound to `universal-argument'.
+It will be used to describe bindings of commands that support a
+prefix argument. PREFIX and TAIL are used internally."
+ (map-keymap
+ (lambda (key binding)
+ (cond ((mouse-event-p key) nil)
+ ((keymapp binding)
+ (setq tail
+ (if (eq key 'remap)
+ (notmuch-describe-remaps
+ binding ua-keys base-keymap prefix tail)
+ (notmuch-describe-keymap
+ binding ua-keys base-keymap
+ (notmuch-prefix-key-description key)
+ tail))))
+ (binding
+ (setq tail
+ (notmuch-describe-key (vector key)
+ binding prefix ua-keys tail)))))
+ keymap)
+ tail)
+
+(defun notmuch-substitute-command-keys (doc)
+ "Like `substitute-command-keys' but with documentation, not function names."
+ (let ((beg 0))
+ (while (string-match "\\\\{\\([^}[:space:]]*\\)}" doc beg)
+ (let ((desc
+ (save-match-data
+ (let* ((keymap-name (substring doc
+ (match-beginning 1)
+ (match-end 1)))
+ (keymap (symbol-value (intern keymap-name)))
+ (ua-keys (where-is-internal 'universal-argument keymap t))
+ (desc-alist (notmuch-describe-keymap keymap ua-keys keymap))
+ (desc-list (mapcar (lambda (arg)
+ (concat (car arg) "\t" (cdr arg)))
+ desc-alist)))
+ (mapconcat #'identity desc-list "\n")))))
+ (setq doc (replace-match desc 1 1 doc)))
+ (setq beg (match-end 0)))
+ doc))
+
+(defun notmuch-help ()
+ "Display help for the current notmuch mode.
+
+This is similar to `describe-function' for the current major
+mode, but bindings tables are shown with documentation strings
+rather than command names. By default, this uses the first line
+of each command's documentation string. A command can override
+this by setting the 'notmuch-doc property of its command symbol.
+A command that supports a prefix argument can explicitly document
+its prefixed behavior by setting the 'notmuch-prefix-doc property
+of its command symbol."
+ (interactive)
+ (let ((doc (substitute-command-keys
+ (notmuch-substitute-command-keys
+ (documentation major-mode t)))))
+ (with-current-buffer (generate-new-buffer "*notmuch-help*")
+ (insert doc)
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (view-buffer (current-buffer) 'kill-buffer-if-not-modified))))
+
+(defun notmuch-subkeymap-help ()
+ "Show help for a subkeymap."
+ (interactive)
+ (let* ((key (this-command-keys-vector))
+ (prefix (make-vector (1- (length key)) nil))
+ (i 0))
+ (while (< i (length prefix))
+ (aset prefix i (aref key i))
+ (cl-incf i))
+ (let* ((subkeymap (key-binding prefix))
+ (ua-keys (where-is-internal 'universal-argument nil t))
+ (prefix-string (notmuch-prefix-key-description prefix))
+ (desc-alist (notmuch-describe-keymap
+ subkeymap ua-keys subkeymap prefix-string))
+ (desc-list (mapcar (lambda (arg) (concat (car arg) "\t" (cdr arg)))
+ desc-alist))
+ (desc (mapconcat #'identity desc-list "\n")))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (insert "\nPress 'q' to quit this window.\n\n")
+ (insert desc)))
+ (pop-to-buffer (help-buffer)))))
+
+;;; Refreshing Buffers
+
+(defvar-local notmuch-buffer-refresh-function nil
+ "Function to call to refresh the current buffer.")
+
+(defun notmuch-refresh-this-buffer ()
+ "Refresh the current buffer."
+ (interactive)
+ (when notmuch-buffer-refresh-function
+ ;; Pass prefix argument, etc.
+ (call-interactively notmuch-buffer-refresh-function)))
+
+(defun notmuch-poll-and-refresh-this-buffer ()
+ "Invoke `notmuch-poll' to import mail, then refresh the current buffer."
+ (interactive)
+ (notmuch-poll)
+ (notmuch-refresh-this-buffer))
+
+(defun notmuch-refresh-all-buffers ()
+ "Invoke `notmuch-refresh-this-buffer' on all notmuch major-mode buffers.
+
+The buffers are silently refreshed, i.e. they are not forced to
+be displayed."
+ (interactive)
+ (dolist (buffer (buffer-list))
+ (let ((buffer-mode (buffer-local-value 'major-mode buffer)))
+ (when (memq buffer-mode '(notmuch-show-mode
+ notmuch-tree-mode
+ notmuch-search-mode
+ notmuch-hello-mode))
+ (with-current-buffer buffer
+ (notmuch-refresh-this-buffer))))))
+
+;;; String Utilities
+
+(defun notmuch-prettify-subject (subject)
+ ;; This function is used by `notmuch-search-process-filter',
+ ;; which requires that we not disrupt its matching state.
+ (save-match-data
+ (if (and subject
+ (string-match "^[ \t]*$" subject))
+ "[No Subject]"
+ subject)))
+
+(defun notmuch-sanitize (str)
+ "Sanitize control character in STR.
+
+This includes newlines, tabs, and other funny characters."
+ (replace-regexp-in-string "[[:cntrl:]\x7f\u2028\u2029]+" " " str))
+
+(defun notmuch-escape-boolean-term (term)
+ "Escape a boolean term for use in a query.
+
+The caller is responsible for prepending the term prefix and a
+colon. This performs minimal escaping in order to produce
+user-friendly queries."
+ (save-match-data
+ (if (or (equal term "")
+ ;; To be pessimistic, only pass through terms composed
+ ;; entirely of ASCII printing characters other than ", (,
+ ;; and ).
+ (string-match "[^!#-'*-~]" term))
+ ;; Requires escaping
+ (concat "\"" (replace-regexp-in-string "\"" "\"\"" term t t) "\"")
+ term)))
+
+(defun notmuch-id-to-query (id)
+ "Return a query that matches the message with id ID."
+ (concat "id:" (notmuch-escape-boolean-term id)))
+
+(defun notmuch-hex-encode (str)
+ "Hex-encode STR (e.g., as used by batch tagging).
+
+This replaces spaces, percents, and double quotes in STR with
+%NN where NN is the hexadecimal value of the character."
+ (replace-regexp-in-string
+ "[ %\"]" (lambda (match) (format "%%%02x" (aref match 0))) str))
+
+(defun notmuch-common-do-stash (text)
+ "Common function to stash text in kill ring, and display in minibuffer."
+ (if text
+ (progn
+ (kill-new text)
+ (message "Stashed: %s" text))
+ ;; There is nothing to stash so stash an empty string so the user
+ ;; doesn't accidentally paste something else somewhere.
+ (kill-new "")
+ (message "Nothing to stash!")))
+
+;;; Generic Utilities
+
+(defun notmuch-plist-delete (plist property)
+ (let (p)
+ (while plist
+ (unless (eq property (car plist))
+ (setq p (plist-put p (car plist) (cadr plist))))
+ (setq plist (cddr plist)))
+ p))
+
+;;; MML Utilities
+
+(defun notmuch-match-content-type (t1 t2)
+ "Return t if t1 and t2 are matching content types.
+Take wildcards into account."
+ (and (stringp t1)
+ (stringp t2)
+ (let ((st1 (split-string t1 "/"))
+ (st2 (split-string t2 "/")))
+ (if (or (string= (cadr st1) "*")
+ (string= (cadr st2) "*"))
+ ;; Comparison of content types should be case insensitive.
+ (string= (downcase (car st1))
+ (downcase (car st2)))
+ (string= (downcase t1)
+ (downcase t2))))))
+
+(defcustom notmuch-multipart/alternative-discouraged
+ '(;; Avoid HTML parts.
+ "text/html"
+ ;; multipart/related usually contain a text/html part and some
+ ;; associated graphics.
+ "multipart/related")
+ "Which mime types to hide by default for multipart messages.
+
+Can either be a list of mime types (as strings) or a function
+mapping a plist representing the current message to such a list.
+See Info node `(notmuch-emacs) notmuch-show' for a sample function."
+ :group 'notmuch-show
+ :type '(radio (repeat :tag "MIME Types" string)
+ (function :tag "Function")))
+
+(defun notmuch-multipart/alternative-determine-discouraged (msg)
+ "Return the discouraged alternatives for the specified message."
+ ;; If a function, return the result of calling it.
+ (if (functionp notmuch-multipart/alternative-discouraged)
+ (funcall notmuch-multipart/alternative-discouraged msg)
+ ;; Otherwise simply return the value of the variable, which is
+ ;; assumed to be a list of discouraged alternatives. This is the
+ ;; default behaviour.
+ notmuch-multipart/alternative-discouraged))
+
+(defun notmuch-multipart/alternative-choose (msg types)
+ "Return a list of preferred types from the given list of types
+for this message, if present."
+ ;; Based on `mm-preferred-alternative-precedence'.
+ (let ((discouraged (notmuch-multipart/alternative-determine-discouraged msg))
+ (seq types))
+ (dolist (pref (reverse discouraged))
+ (dolist (elem (copy-sequence seq))
+ (when (string-match pref elem)
+ (setq seq (nconc (delete elem seq) (list elem))))))
+ seq))
+
+(defun notmuch-parts-filter-by-type (parts type)
+ "Given a list of message parts, return a list containing the ones matching
+the given type."
+ (cl-remove-if-not
+ (lambda (part) (notmuch-match-content-type (plist-get part :content-type) type))
+ parts))
+
+(defun notmuch--get-bodypart-raw (msg part process-crypto binaryp cache)
+ (let* ((plist-elem (if binaryp :content-binary :content))
+ (data (or (plist-get part plist-elem)
+ (with-temp-buffer
+ ;; Emacs internally uses a UTF-8-like multibyte string
+ ;; representation by default (regardless of the coding
+ ;; system, which only affects how it goes from outside data
+ ;; to this internal representation). This *almost* never
+ ;; matters. Annoyingly, it does matter if we use this data
+ ;; in an image descriptor, since Emacs will use its internal
+ ;; data buffer directly and this multibyte representation
+ ;; corrupts binary image formats. Since the caller is
+ ;; asking for binary data, a unibyte string is a more
+ ;; appropriate representation anyway.
+ (when binaryp
+ (set-buffer-multibyte nil))
+ (let ((args `("show" "--format=raw"
+ ,(format "--part=%s" (plist-get part :id))
+ ,@(and process-crypto '("--decrypt=true"))
+ ,(notmuch-id-to-query (plist-get msg :id))))
+ (coding-system-for-read
+ (if binaryp
+ 'no-conversion
+ (let ((coding-system
+ (mm-charset-to-coding-system
+ (plist-get part :content-charset))))
+ ;; Sadly,
+ ;; `mm-charset-to-coding-system' seems
+ ;; to return things that are not
+ ;; considered acceptable values for
+ ;; `coding-system-for-read'.
+ (if (coding-system-p coding-system)
+ coding-system
+ ;; RFC 2047 says that the default
+ ;; charset is US-ASCII. RFC6657
+ ;; complicates this somewhat.
+ 'us-ascii)))))
+ (apply #'notmuch--call-process
+ notmuch-command nil '(t nil) nil args)
+ (buffer-string))))))
+ (when (and cache data)
+ (plist-put part plist-elem data))
+ data))
+
+(defun notmuch-get-bodypart-binary (msg part process-crypto &optional cache)
+ "Return the unprocessed content of PART in MSG as a unibyte string.
+
+This returns the \"raw\" content of the given part after content
+transfer decoding, but with no further processing (see the
+discussion of --format=raw in man notmuch-show). In particular,
+this does no charset conversion.
+
+If CACHE is non-nil, the content of this part will be saved in
+MSG (if it isn't already)."
+ (notmuch--get-bodypart-raw msg part process-crypto t cache))
+
+(defun notmuch-get-bodypart-text (msg part process-crypto &optional cache)
+ "Return the text content of PART in MSG.
+
+This returns the content of the given part as a multibyte Lisp
+string after performing content transfer decoding and any
+necessary charset decoding.
+
+If CACHE is non-nil, the content of this part will be saved in
+MSG (if it isn't already)."
+ (notmuch--get-bodypart-raw msg part process-crypto nil cache))
+
+(defun notmuch-mm-display-part-inline (msg part content-type process-crypto)
+ "Use the mm-decode/mm-view functions to display a part in the
+current buffer, if possible."
+ (let ((display-buffer (current-buffer)))
+ (with-temp-buffer
+ ;; In case we already have :content, use it and tell mm-* that
+ ;; it's already been charset-decoded by using the fake
+ ;; `gnus-decoded' charset. Otherwise, we'll fetch the binary
+ ;; part content and let mm-* decode it.
+ (let* ((have-content (plist-member part :content))
+ (charset (if have-content
+ 'gnus-decoded
+ (plist-get part :content-charset)))
+ (handle (mm-make-handle (current-buffer)
+ `(,content-type (charset . ,charset)))))
+ ;; If the user wants the part inlined, insert the content and
+ ;; test whether we are able to inline it (which includes both
+ ;; capability and suitability tests).
+ (when (mm-inlined-p handle)
+ (if have-content
+ (insert (notmuch-get-bodypart-text msg part process-crypto))
+ (insert (notmuch-get-bodypart-binary msg part process-crypto)))
+ (when (mm-inlinable-p handle)
+ (set-buffer display-buffer)
+ (mm-display-part handle)
+ (plist-put part :undisplayer (mm-handle-undisplayer handle))
+ t))))))
+
+;;; Generic Utilities
+
+;; Converts a plist of headers to an alist of headers. The input plist should
+;; have symbols of the form :Header as keys, and the resulting alist will have
+;; symbols of the form 'Header as keys.
+(defun notmuch-headers-plist-to-alist (plist)
+ (cl-loop for (key value . rest) on plist by #'cddr
+ collect (cons (intern (substring (symbol-name key) 1)) value)))
+
+(defun notmuch-face-ensure-list-form (face)
+ "Return FACE in face list form.
+
+If FACE is already a face list, it will be returned as-is. If
+FACE is a face name or face plist, it will be returned as a
+single element face list."
+ (if (and (listp face) (not (keywordp (car face))))
+ face
+ (list face)))
+
+(defun notmuch-apply-face (object face &optional below start end)
+ "Combine FACE into the 'face text property of OBJECT between START and END.
+
+This function combines FACE with any existing faces between START
+and END in OBJECT. Attributes specified by FACE take precedence
+over existing attributes unless BELOW is non-nil.
+
+OBJECT may be a string, a buffer, or nil (which means the current
+buffer). If object is a string, START and END are 0-based;
+otherwise they are buffer positions (integers or markers). FACE
+must be a face name (a symbol or string), a property list of face
+attributes, or a list of these. If START and/or END are omitted,
+they default to the beginning/end of OBJECT. For convenience
+when applied to strings, this returns OBJECT."
+ ;; A face property can have three forms: a face name (a string or
+ ;; symbol), a property list, or a list of these two forms. In the
+ ;; list case, the faces will be combined, with the earlier faces
+ ;; taking precedent. Here we canonicalize everything to list form
+ ;; to make it easy to combine.
+ (let ((pos (cond (start start)
+ ((stringp object) 0)
+ (t 1)))
+ (end (cond (end end)
+ ((stringp object) (length object))
+ (t (1+ (buffer-size object)))))
+ (face-list (notmuch-face-ensure-list-form face)))
+ (while (< pos end)
+ (let* ((cur (get-text-property pos 'face object))
+ (cur-list (notmuch-face-ensure-list-form cur))
+ (new (cond ((null cur-list) face)
+ (below (append cur-list face-list))
+ (t (append face-list cur-list))))
+ (next (next-single-property-change pos 'face object end)))
+ (put-text-property pos next 'face new object)
+ (setq pos next))))
+ object)
+
+(defun notmuch-map-text-property (start end prop func &optional object)
+ "Transform text property PROP using FUNC.
+
+Applies FUNC to each distinct value of the text property PROP
+between START and END of OBJECT, setting PROP to the value
+returned by FUNC."
+ (while (< start end)
+ (let ((value (get-text-property start prop object))
+ (next (next-single-property-change start prop object end)))
+ (put-text-property start next prop (funcall func value) object)
+ (setq start next))))
+
+;;; Running Notmuch
+
+(defun notmuch-logged-error (msg &optional extra)
+ "Log MSG and EXTRA to *Notmuch errors* and signal MSG.
+
+This logs MSG and EXTRA to the *Notmuch errors* buffer and
+signals MSG as an error. If EXTRA is non-nil, text referring the
+user to the *Notmuch errors* buffer will be appended to the
+signaled error. This function does not return."
+ (with-current-buffer (get-buffer-create "*Notmuch errors*")
+ (goto-char (point-max))
+ (unless (bobp)
+ (newline))
+ (save-excursion
+ (insert "[" (current-time-string) "]\n" msg)
+ (unless (bolp)
+ (newline))
+ (when extra
+ (insert extra)
+ (unless (bolp)
+ (newline)))))
+ (error "%s%s" msg (if extra " (see *Notmuch errors* for more details)" "")))
+
+(defun notmuch-check-async-exit-status (proc msg &optional command err)
+ "If PROC exited abnormally, pop up an error buffer and signal an error.
+
+This is a wrapper around `notmuch-check-exit-status' for
+asynchronous process sentinels. PROC and MSG must be the
+arguments passed to the sentinel. COMMAND and ERR, if provided,
+are passed to `notmuch-check-exit-status'. If COMMAND is not
+provided, it is taken from `process-command'."
+ (let ((exit-status
+ (cl-case (process-status proc)
+ ((exit) (process-exit-status proc))
+ ((signal) msg))))
+ (when exit-status
+ (notmuch-check-exit-status exit-status
+ (or command (process-command proc))
+ nil err))))
+
+(defun notmuch-check-exit-status (exit-status command &optional output err)
+ "If EXIT-STATUS is non-zero, pop up an error buffer and signal an error.
+
+If EXIT-STATUS is non-zero, pop up a notmuch error buffer
+describing the error and signal an Elisp error. EXIT-STATUS must
+be a number indicating the exit status code of a process or a
+string describing the signal that terminated the process (such as
+returned by `call-process'). COMMAND must be a list giving the
+command and its arguments. OUTPUT, if provided, is a string
+giving the output of command. ERR, if provided, is the error
+output of command. OUTPUT and ERR will be included in the error
+message."
+ (cond
+ ((eq exit-status 0) t)
+ ((eq exit-status 20)
+ (notmuch-logged-error "notmuch CLI version mismatch
+Emacs requested an older output format than supported by the notmuch CLI.
+You may need to restart Emacs or upgrade your notmuch Emacs package."))
+ ((eq exit-status 21)
+ (notmuch-logged-error "notmuch CLI version mismatch
+Emacs requested a newer output format than supported by the notmuch CLI.
+You may need to restart Emacs or upgrade your notmuch package."))
+ (t
+ (pcase-let*
+ ((`(,command . ,args) command)
+ (command (if (equal (file-name-nondirectory command)
+ notmuch-command)
+ notmuch-command
+ command))
+ (command-string
+ (mapconcat (lambda (arg)
+ (shell-quote-argument
+ (cond ((stringp arg) arg)
+ ((symbolp arg) (symbol-name arg))
+ (t "*UNKNOWN ARGUMENT*"))))
+ (cons command args)
+ " "))
+ (extra
+ (concat "command: " command-string "\n"
+ (if (integerp exit-status)
+ (format "exit status: %s\n" exit-status)
+ (format "exit signal: %s\n" exit-status))
+ (and err (concat "stderr:\n" err))
+ (and output (concat "stdout:\n" output)))))
+ (if err
+ ;; We have an error message straight from the CLI.
+ (notmuch-logged-error
+ (replace-regexp-in-string "[ \n\r\t\f]*\\'" "" err) extra)
+ ;; We only have combined output from the CLI; don't inundate
+ ;; the user with it. Mimic `process-lines'.
+ (notmuch-logged-error (format "%s exited with status %s"
+ command exit-status)
+ extra))
+ ;; `notmuch-logged-error' does not return.
+ ))))
+
+(defmacro notmuch--apply-with-env (func &rest args)
+ `(let ((default-directory "~"))
+ (apply ,func ,@args)))
+
+(defun notmuch--process-lines (program &rest args)
+ "Wrap process-lines, binding DEFAULT-DIRECTORY to a safe
+default"
+ (notmuch--apply-with-env #'process-lines program args))
+
+(defun notmuch--make-process (&rest args)
+ "Wrap make-process, binding DEFAULT-DIRECTORY to a safe
+default"
+ (notmuch--apply-with-env #'make-process args))
+
+(defun notmuch--call-process-region (start end program
+ &optional delete buffer display
+ &rest args)
+ "Wrap call-process-region, binding DEFAULT-DIRECTORY to a safe
+default"
+ (notmuch--apply-with-env
+ #'call-process-region start end program delete buffer display args))
+
+(defun notmuch--call-process (program &optional infile destination display &rest args)
+ "Wrap call-process, binding DEFAULT-DIRECTORY to a safe default"
+ (notmuch--apply-with-env #'call-process program infile destination display args))
+
+(defun notmuch-call-notmuch--helper (destination args)
+ "Helper for synchronous notmuch invocation commands.
+
+This wraps `call-process'. DESTINATION has the same meaning as
+for `call-process'. ARGS is as described for
+`notmuch-call-notmuch-process'."
+ (let (stdin-string)
+ (while (keywordp (car args))
+ (cl-case (car args)
+ (:stdin-string (setq stdin-string (cadr args))
+ (setq args (cddr args)))
+ (otherwise
+ (error "Unknown keyword argument: %s" (car args)))))
+ (if (null stdin-string)
+ (apply #'notmuch--call-process notmuch-command nil destination nil args)
+ (insert stdin-string)
+ (apply #'notmuch--call-process-region (point-min) (point-max)
+ notmuch-command t destination nil args))))
+
+(defun notmuch-call-notmuch-process (&rest args)
+ "Synchronously invoke `notmuch-command' with ARGS.
+
+The caller may provide keyword arguments before ARGS. Currently
+supported keyword arguments are:
+
+ :stdin-string STRING - Write STRING to stdin
+
+If notmuch exits with a non-zero status, output from the process
+will appear in a buffer named \"*Notmuch errors*\" and an error
+will be signaled."
+ (with-temp-buffer
+ (let ((status (notmuch-call-notmuch--helper t args)))
+ (notmuch-check-exit-status status (cons notmuch-command args)
+ (buffer-string)))))
+
+(defun notmuch-call-notmuch-sexp (&rest args)
+ "Invoke `notmuch-command' with ARGS and return the parsed S-exp output.
+
+This is equivalent to `notmuch-call-notmuch-process', but parses
+notmuch's output as an S-expression and returns the parsed value.
+Like `notmuch-call-notmuch-process', if notmuch exits with a
+non-zero status, this will report its output and signal an
+error."
+ (with-temp-buffer
+ (let ((err-file (make-temp-file "nmerr")))
+ (unwind-protect
+ (let ((status (notmuch-call-notmuch--helper (list t err-file) args))
+ (err (with-temp-buffer
+ (insert-file-contents err-file)
+ (unless (eobp)
+ (buffer-string)))))
+ (notmuch-check-exit-status status (cons notmuch-command args)
+ (buffer-string) err)
+ (goto-char (point-min))
+ (read (current-buffer)))
+ (delete-file err-file)))))
+
+(defun notmuch-start-notmuch (name buffer sentinel &rest args)
+ "Start and return an asynchronous notmuch command.
+
+This starts and returns an asynchronous process running
+`notmuch-command' with ARGS. The exit status is checked via
+`notmuch-check-async-exit-status'. Output written to stderr is
+redirected and displayed when the process exits (even if the
+process exits successfully). NAME and BUFFER are the same as in
+`start-process'. SENTINEL is a process sentinel function to call
+when the process exits, or nil for none. The caller must *not*
+invoke `set-process-sentinel' directly on the returned process,
+as that will interfere with the handling of stderr and the exit
+status."
+ (let* ((command (or (executable-find notmuch-command)
+ (error "Command not found: %s" notmuch-command)))
+ (err-buffer (generate-new-buffer " *notmuch-stderr*"))
+ (proc (notmuch--make-process
+ :name name
+ :buffer buffer
+ :command (cons command args)
+ :connection-type 'pipe
+ :stderr err-buffer))
+ (err-proc (get-buffer-process err-buffer)))
+ (process-put proc 'err-buffer err-buffer)
+ (process-put proc 'sub-sentinel sentinel)
+ (set-process-sentinel proc #'notmuch-start-notmuch-sentinel)
+ (set-process-sentinel err-proc #'notmuch-start-notmuch-error-sentinel)
+ proc))
+
+(defun notmuch-start-notmuch-sentinel (proc event)
+ "Process sentinel function used by `notmuch-start-notmuch'."
+ (let* ((err-buffer (process-get proc 'err-buffer))
+ (err (and (buffer-live-p err-buffer)
+ (not (zerop (buffer-size err-buffer)))
+ (with-current-buffer err-buffer (buffer-string))))
+ (sub-sentinel (process-get proc 'sub-sentinel)))
+ (condition-case err
+ (progn
+ ;; Invoke the sub-sentinel, if any
+ (when sub-sentinel
+ (funcall sub-sentinel proc event))
+ ;; Check the exit status. This will signal an error if the
+ ;; exit status is non-zero. Don't do this if the process
+ ;; buffer is dead since that means Emacs killed the process
+ ;; and there's no point in telling the user that (but we
+ ;; still check for and report stderr output below).
+ (when (buffer-live-p (process-buffer proc))
+ (notmuch-check-async-exit-status proc event nil err))
+ ;; If that didn't signal an error, then any error output was
+ ;; really warning output. Show warnings, if any.
+ (let ((warnings
+ (and err
+ (with-current-buffer err-buffer
+ (goto-char (point-min))
+ (end-of-line)
+ ;; Show first line; stuff remaining lines in the
+ ;; errors buffer.
+ (let ((l1 (buffer-substring (point-min) (point))))
+ (skip-chars-forward "\n")
+ (cons l1 (and (not (eobp))
+ (buffer-substring (point)
+ (point-max)))))))))
+ (when warnings
+ (notmuch-logged-error (car warnings) (cdr warnings)))))
+ (error
+ ;; Emacs behaves strangely if an error escapes from a sentinel,
+ ;; so turn errors into messages.
+ (message "%s" (error-message-string err))))))
+
+(defun notmuch-start-notmuch-error-sentinel (proc _event)
+ (unless (process-live-p proc)
+ (let ((buffer (process-buffer proc)))
+ (when (buffer-live-p buffer)
+ (kill-buffer buffer)))))
+
+(defvar-local notmuch-show-process-crypto nil)
+
+(defun notmuch--run-show (search-terms &optional duplicate)
+ "Return a list of threads of messages matching SEARCH-TERMS.
+
+A thread is a forest or list of trees. A tree is a two element
+list where the first element is a message, and the second element
+is a possibly empty forest of replies."
+ (let ((args '("show" "--format=sexp" "--format-version=5")))
+ (when notmuch-show-process-crypto
+ (setq args (append args '("--decrypt=true"))))
+ (when duplicate
+ (setq args (append args (list (format "--duplicate=%d" duplicate)))))
+ (setq args (append args search-terms))
+ (apply #'notmuch-call-notmuch-sexp args)))
+
+;;; Generic Utilities
+
+(defun notmuch-interactive-region ()
+ "Return the bounds of the current interactive region.
+
+This returns (BEG END), where BEG and END are the bounds of the
+region if the region is active, or both `point' otherwise."
+ (if (region-active-p)
+ (list (region-beginning) (region-end))
+ (list (point) (point))))
+
+(define-obsolete-function-alias
+ 'notmuch-search-interactive-region
+ 'notmuch-interactive-region
+ "notmuch 0.29")
+
+(defun notmuch--inline-override-types ()
+ "Override mm-inline-override-types to stop application/*
+parts from being displayed unless the user has customized
+it themselves."
+ (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))
+;;; _
+
+(provide 'notmuch-lib)
+
+;;; notmuch-lib.el ends here
blob - /dev/null
blob + 2c65a73b470e0fdaa6984704b6425e35ffe900cf (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-logo.svg
+<?xml version="1.0" encoding="UTF-8"?>
+<svg xmlns="http://www.w3.org/2000/svg" width="100" height="100"
+ viewbox="0 0 100 100" fill="#000" stroke-width="2">
+ <circle cx="50" cy="5" r="5" />
+ <g transform="translate(50 20) rotate(20)">
+ <circle cx="-47" cy="0" r="3" />
+ <circle cx="47" cy="0" r="3" />
+ <path d="M-47 -1 L0 -3 L47 -1 L47 1 L0 3 L-47 1 Z" />
+ </g>
+ <path d="M49 4 L45 88
+ A5 5 0 0 1 40 93 L20 93 A5 5 0 0 0 15 100
+ L85 100
+ A5 5 0 0 0 80 93 L60 93 A5 5 0 0 1 55 88
+ L55 90 L51 4 Z" />
+ <g fill="#fff" stroke="#000">
+ <rect x="7" y="33" width="30" height="18" />
+ <line x1="7" y1="51" x2="18" y2="41" />
+ <line x1="37" y1="51" x2="26" y2="41" />
+ <polyline points="7 33 22 44 37 33" fill="none" />
+ </g>
+ <path d="M-18 0 A24 20 0 0 0 18 0" transform="translate(22 51.0)" />
+ <path d="M-18 0 A24 20 0 0 0 18 0" transform="translate(78 71.5)" />
+ <g fill="none" stroke="#000">
+ <path d="M9 53.0 l 12 -42 l 2 0 l 12 42" />
+ <path d="M91 73.5 l-12 -42 l-2 0 l-12 42" />
+ </g>
+</svg>
blob - /dev/null
blob + 5102078849d629a2da37bac13c9a3548153ff996 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-maildir-fcc.el
+;;; notmuch-maildir-fcc.el --- inserting using a fcc handler -*- lexical-binding: t -*-
+
+;; Copyright © Jesse Rosenthal
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Jesse Rosenthal <jrosenthal@jhu.edu>
+
+;;; Code:
+
+(require 'seq)
+
+(require 'message)
+
+(require 'notmuch-lib)
+
+(defvar notmuch-maildir-fcc-count 0)
+
+;;; Options
+
+(defcustom notmuch-fcc-dirs "sent"
+ "Determines the Fcc Header which says where to save outgoing mail.
+
+Three types of values are permitted:
+
+- nil: no Fcc header is added,
+
+- a string: the value of `notmuch-fcc-dirs' is the Fcc header to
+ be used.
+
+- an alist: the folder is chosen based on the From address of
+ the current message according to an alist mapping regular
+ expressions to folders or nil:
+
+ ((\"Sebastian@SSpaeth.de\" . \"privat\")
+ (\"spaetz@sspaeth.de\" . \"OUTBOX.OSS\")
+ (\".*\" . \"defaultinbox\"))
+
+ If none of the regular expressions match the From address, or
+ if the cdr of the matching entry is nil, then no Fcc header
+ will be added.
+
+If `notmuch-maildir-use-notmuch-insert' is set (the default) then
+the header should be of the form \"folder +tag1 -tag2\" where
+folder is the folder (relative to the notmuch mailstore) to store
+the message in, and tag1 and tag2 are tag changes to apply to the
+stored message. This string is split using `split-string-and-unquote',
+so a folder name containing spaces can be specified by
+quoting each space with an immediately preceding backslash
+or surrounding the entire folder name in double quotes.
+
+If `notmuch-maildir-use-notmuch-insert' is nil then the Fcc
+header should be the directory where the message should be
+saved. A relative directory will be understood to specify a
+directory within the notmuch mail store, (as set by the
+database.path option in the notmuch configuration file).
+
+In all cases you will be prompted to create the folder or
+directory if it does not exist yet when sending a mail."
+
+ :type '(choice
+ (const :tag "No FCC header" nil)
+ (string :tag "A single folder")
+ (repeat :tag "A folder based on the From header"
+ (cons regexp (choice (const :tag "No FCC header" nil)
+ (string :tag "Folder")))))
+ :require 'notmuch-fcc-initialization
+ :group 'notmuch-send)
+
+(defcustom notmuch-maildir-use-notmuch-insert t
+ "Should fcc use notmuch insert instead of simple fcc."
+ :type '(choice :tag "Fcc Method"
+ (const :tag "Use notmuch insert" t)
+ (const :tag "Use simple fcc" nil))
+ :group 'notmuch-send)
+
+;;; Functions which set up the fcc header in the message buffer.
+
+(defun notmuch-fcc-header-setup ()
+ "Add an Fcc header to the current message buffer.
+
+If the Fcc header is already set, then keep it as-is.
+Otherwise set it according to `notmuch-fcc-dirs'."
+ (let ((subdir
+ (cond
+ ((or (not notmuch-fcc-dirs)
+ (message-field-value "Fcc"))
+ ;; Nothing set or an existing header.
+ nil)
+ ((stringp notmuch-fcc-dirs)
+ notmuch-fcc-dirs)
+ ((and (listp notmuch-fcc-dirs)
+ (stringp (car notmuch-fcc-dirs)))
+ ;; Old style - no longer works.
+ (error "Invalid `notmuch-fcc-dirs' setting (old style)"))
+ ((listp notmuch-fcc-dirs)
+ (if-let ((match (seq-some (let ((from (message-field-value "From")))
+ (pcase-lambda (`(,regexp . ,folder))
+ (and (string-match-p regexp from)
+ (cons t folder))))
+ notmuch-fcc-dirs)))
+ (cdr match)
+ (message "No Fcc header added.")
+ nil))
+ (t
+ (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)")))))
+ (when subdir
+ (if notmuch-maildir-use-notmuch-insert
+ (notmuch-maildir-add-notmuch-insert-style-fcc-header subdir)
+ (notmuch-maildir-add-file-style-fcc-header subdir)))))
+
+(defun notmuch-maildir-add-notmuch-insert-style-fcc-header (subdir)
+ ;; Notmuch insert does not accept absolute paths, so check the user
+ ;; really want this header inserted.
+ (when (or (not (= (elt subdir 0) ?/))
+ (y-or-n-p (format "Fcc header %s is an absolute path %s %s" subdir
+ "and notmuch insert is requested."
+ "Insert header anyway? ")))
+ (message-add-header (concat "Fcc: " subdir))))
+
+(defun notmuch-maildir-add-file-style-fcc-header (subdir)
+ (message-add-header
+ (concat "Fcc: "
+ (file-truename
+ ;; If the resulting directory is not an absolute path,
+ ;; prepend the standard notmuch database path.
+ (if (= (elt subdir 0) ?/)
+ subdir
+ (concat (notmuch-database-path) "/" subdir))))))
+
+;;; Functions for saving a message using either method.
+
+(defmacro with-temporary-notmuch-message-buffer (&rest body)
+ "Set-up a temporary copy of the current message-mode buffer."
+ `(let ((case-fold-search t)
+ (buf (current-buffer))
+ (mml-externalize-attachments message-fcc-externalize-attachments))
+ (with-current-buffer (get-buffer-create " *message temp*")
+ (message-clone-locals buf) ;; for message-encoded-mail-cache
+ (erase-buffer)
+ (insert-buffer-substring buf)
+ ,@body)))
+
+(defun notmuch-maildir-setup-message-for-saving ()
+ "Setup message for saving.
+
+This should be called on a temporary copy.
+This is taken from the function message-do-fcc."
+ (if (not message-encoded-mail-cache)
+ (message-encode-message-body)
+ (erase-buffer)
+ (insert message-encoded-mail-cache))
+ (save-restriction
+ (message-narrow-to-headers)
+ (mail-encode-encoded-word-buffer))
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$")
+ nil t)
+ (replace-match "" t t )))
+
+(defun notmuch-maildir-message-do-fcc ()
+ "Process Fcc headers in the current buffer.
+
+This is a rearranged version of message mode's message-do-fcc."
+ (let (files file)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (setq file (message-fetch-field "fcc" t)))
+ (when file
+ (with-temporary-notmuch-message-buffer
+ (notmuch-maildir-setup-message-for-saving)
+ (save-restriction
+ (message-narrow-to-headers)
+ (while (setq file (message-fetch-field "fcc" t))
+ (push file files)
+ (message-remove-header "fcc" nil t)))
+ ;; Process FCC operations.
+ (mapc #'notmuch-fcc-handler files)
+ (kill-buffer (current-buffer)))))))
+
+(defun notmuch-fcc-handler (fcc-header)
+ "Store message with notmuch insert or normal (file) fcc.
+
+If `notmuch-maildir-use-notmuch-insert' is set then store the
+message using notmuch insert. Otherwise store the message using
+normal fcc."
+ (message "Doing Fcc...")
+ (if notmuch-maildir-use-notmuch-insert
+ (notmuch-maildir-fcc-with-notmuch-insert fcc-header)
+ (notmuch-maildir-fcc-file-fcc fcc-header))
+ (message "Doing Fcc...done"))
+
+;;; Functions for saving a message using notmuch insert.
+
+(defun notmuch-maildir-notmuch-insert-current-buffer (folder &optional create tags)
+ "Use notmuch insert to put the current buffer in the database.
+
+This inserts the current buffer as a message into the notmuch
+database in folder FOLDER. If CREATE is non-nil it will supply
+the --create-folder flag to create the folder if necessary. TAGS
+should be a list of tag changes to apply to the inserted message."
+ (apply 'notmuch-call-notmuch-process
+ :stdin-string (buffer-string) "insert"
+ (append (and create (list "--create-folder"))
+ (list (concat "--folder=" folder))
+ tags)))
+
+(defun notmuch-maildir-fcc-with-notmuch-insert (fcc-header &optional create)
+ "Store message with notmuch insert.
+
+The fcc-header should be of the form \"folder +tag1 -tag2\" where
+folder is the folder (relative to the notmuch mailstore) to store
+the message in, and tag1 and tag2 are tag changes to apply to the
+stored message. This string is split using `split-string-and-unquote',
+so a folder name containing spaces can be specified by
+quoting each space with an immediately preceding backslash
+or surrounding the entire folder name in double quotes.
+
+If CREATE is non-nil then create the folder if necessary."
+ (pcase-let ((`(,folder . ,tags)
+ (split-string-and-unquote fcc-header)))
+ (condition-case nil
+ (notmuch-maildir-notmuch-insert-current-buffer folder create tags)
+ ;; Since there are many reasons notmuch insert could fail, e.g.,
+ ;; locked database, non-existent folder (which could be due to a
+ ;; typo, or just the user want a new folder, let the user decide
+ ;; how to deal with it.
+ (error
+ (let ((response (read-char-choice "Insert failed: \
+\(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " '(?r ?c ?i ?e))))
+ (cl-case response
+ (?r (notmuch-maildir-fcc-with-notmuch-insert fcc-header))
+ (?c (notmuch-maildir-fcc-with-notmuch-insert fcc-header t))
+ (?i t)
+ (?e (notmuch-maildir-fcc-with-notmuch-insert
+ (read-from-minibuffer "Fcc header: " fcc-header)))))))))
+
+;;; Functions for saving a message using file fcc.
+
+(defun notmuch-maildir-fcc-host-fixer (hostname)
+ (replace-regexp-in-string "/\\|:"
+ (lambda (s)
+ (cond ((string-equal s "/") "\\057")
+ ((string-equal s ":") "\\072")
+ (t s)))
+ hostname
+ t
+ t))
+
+(defun notmuch-maildir-fcc-make-uniq-maildir-id ()
+ (let* ((ftime (float-time))
+ (microseconds (mod (* 1000000 ftime) 1000000))
+ (hostname (notmuch-maildir-fcc-host-fixer (system-name))))
+ (cl-incf notmuch-maildir-fcc-count)
+ (format "%d.%d_%d_%d.%s"
+ ftime
+ (emacs-pid)
+ microseconds
+ notmuch-maildir-fcc-count
+ hostname)))
+
+(defun notmuch-maildir-fcc-dir-is-maildir-p (dir)
+ (and (file-exists-p (concat dir "/cur/"))
+ (file-exists-p (concat dir "/new/"))
+ (file-exists-p (concat dir "/tmp/"))))
+
+(defun notmuch-maildir-fcc-create-maildir (path)
+ (cond ((or (not (file-exists-p path)) (file-directory-p path))
+ (make-directory (concat path "/cur/") t)
+ (make-directory (concat path "/new/") t)
+ (make-directory (concat path "/tmp/") t))
+ ((file-regular-p path)
+ (error "%s is a file. Can't create maildir." path))
+ (t
+ (error "I don't know how to create a maildir here"))))
+
+(defun notmuch-maildir-fcc-save-buffer-to-tmp (destdir)
+ "Returns the msg id of the message written to the temp directory
+if successful, nil if not."
+ (let ((msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
+ (while (file-exists-p (concat destdir "/tmp/" msg-id))
+ (setq msg-id (notmuch-maildir-fcc-make-uniq-maildir-id)))
+ (cond ((notmuch-maildir-fcc-dir-is-maildir-p destdir)
+ (write-file (concat destdir "/tmp/" msg-id))
+ msg-id)
+ (t
+ (error "Can't write to %s. Not a maildir." destdir)))))
+
+(defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id)
+ (add-name-to-file
+ (concat destdir "/tmp/" msg-id)
+ (concat destdir "/new/" msg-id ":2,")))
+
+(defun notmuch-maildir-fcc-move-tmp-to-cur (destdir msg-id &optional mark-seen)
+ (add-name-to-file
+ (concat destdir "/tmp/" msg-id)
+ (concat destdir "/cur/" msg-id ":2," (and mark-seen "S"))))
+
+(defun notmuch-maildir-fcc-file-fcc (fcc-header)
+ "Write the message to the file specified by FCC-HEADER.
+
+If that fails, then offer the user a chance to correct the header
+or filesystem."
+ (if (notmuch-maildir-fcc-dir-is-maildir-p fcc-header)
+ (notmuch-maildir-fcc-write-buffer-to-maildir fcc-header t)
+ ;; The fcc-header is not a valid maildir see if the user wants to
+ ;; fix it in some way.
+ (let* ((prompt (format "Fcc %s is not a maildir: \
+\(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " fcc-header))
+ (response (read-char-choice prompt '(?r ?c ?i ?e))))
+ (cl-case response
+ (?r (notmuch-maildir-fcc-file-fcc fcc-header))
+ (?c (if (file-writable-p fcc-header)
+ (notmuch-maildir-fcc-create-maildir fcc-header)
+ (message "No permission to create %s." fcc-header)
+ (sit-for 2))
+ (notmuch-maildir-fcc-file-fcc fcc-header))
+ (?i t)
+ (?e (notmuch-maildir-fcc-file-fcc
+ (read-from-minibuffer "Fcc header: " fcc-header)))))))
+
+(defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen)
+ "Write the current buffer to maildir destdir.
+
+If mark-seen is non-nil, then write it to \"cur/\", and mark it
+as read, otherwise write it to \"new/\". Return t if successful,
+and nil otherwise."
+ (let ((orig-buffer (buffer-name)))
+ (with-temp-buffer
+ (insert-buffer-substring orig-buffer)
+ (catch 'link-error
+ (let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir)))
+ (when msg-id
+ (condition-case nil
+ (if mark-seen
+ (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t)
+ (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id))
+ (file-already-exists
+ (throw 'link-error nil))))
+ (delete-file (concat destdir "/tmp/" msg-id))))
+ t)))
+
+;;; _
+
+(provide 'notmuch-maildir-fcc)
+
+;;; notmuch-maildir-fcc.el ends here
blob - /dev/null
blob + 0856a2e943e6e4cb38d38759d976a512651edb4b (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-message.el
+;;; notmuch-message.el --- message-mode functions specific to notmuch -*- lexical-binding: t -*-
+;;
+;; Copyright © Jesse Rosenthal
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Jesse Rosenthal <jrosenthal@jhu.edu>
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'pcase)
+(require 'subr-x)
+
+(require 'message)
+(require 'notmuch-tag)
+
+(defcustom notmuch-message-replied-tags '("+replied")
+ "List of tag changes to apply to a message when it has been replied to.
+
+Tags starting with \"+\" (or not starting with either \"+\" or
+\"-\") in the list will be added, and tags starting with \"-\"
+will be removed from the message being replied to.
+
+For example, if you wanted to add a \"replied\" tag and remove
+the \"inbox\" and \"todo\" tags, you would set:
+ (\"+replied\" \"-inbox\" \"-todo\")"
+ :type '(repeat string)
+ :group 'notmuch-send)
+
+(defcustom notmuch-message-forwarded-tags '("+forwarded")
+ "List of tag changes to apply to a message when it has been forwarded.
+
+Tags starting with \"+\" (or not starting with either \"+\" or
+\"-\") in the list will be added, and tags starting with \"-\"
+will be removed from the message being forwarded.
+
+For example, if you wanted to add a \"forwarded\" tag and remove
+the \"inbox\" tag, you would set:
+ (\"+forwarded\" \"-inbox\")"
+ :type '(repeat string)
+ :group 'notmuch-send)
+
+(defvar-local notmuch-message-queued-tag-changes nil
+ "List of tag changes to be applied when sending a message.
+
+A list of queries and tag changes that are to be applied to them
+when the message that was composed in the current buffer is being
+send. Each item in this list is a list of strings, where the
+first is a notmuch query and the rest are the tag changes to be
+applied to the matching messages.")
+
+(defun notmuch-message-apply-queued-tag-changes ()
+ ;; Apply the tag changes queued in the buffer-local variable
+ ;; notmuch-message-queued-tag-changes.
+ (pcase-dolist (`(,query . ,tags) notmuch-message-queued-tag-changes)
+ (notmuch-tag query tags)))
+
+(add-hook 'message-send-hook 'notmuch-message-apply-queued-tag-changes)
+
+(provide 'notmuch-message)
+
+;;; notmuch-message.el ends here
blob - /dev/null
blob + 3679d7d70cd079374d81c3191f2548ce2e8592a3 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-mua.el
+;;; notmuch-mua.el --- emacs style mail-user-agent -*- lexical-binding: t -*-
+;;
+;; Copyright © David Edmondson
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+;;; Code:
+
+(eval-when-compile (require 'subr-x))
+
+(require 'message)
+(require 'gmm-utils)
+(require 'mm-view)
+(require 'format-spec)
+
+(require 'notmuch-lib)
+(require 'notmuch-address)
+(require 'notmuch-draft)
+(require 'notmuch-message)
+
+(declare-function notmuch-show-insert-body "notmuch-show" (msg body depth))
+(declare-function notmuch-fcc-header-setup "notmuch-maildir-fcc" ())
+(declare-function notmuch-maildir-message-do-fcc "notmuch-maildir-fcc" ())
+(declare-function notmuch-draft-postpone "notmuch-draft" ())
+(declare-function notmuch-draft-save "notmuch-draft" ())
+
+(defvar notmuch-show-indent-multipart)
+(defvar notmuch-show-insert-header-p-function)
+(defvar notmuch-show-max-text-part-size)
+(defvar notmuch-show-insert-text/plain-hook)
+
+;;; Options
+
+(defcustom notmuch-mua-send-hook nil
+ "Hook run before sending messages."
+ :type 'hook
+ :group 'notmuch-send
+ :group 'notmuch-hooks)
+
+(defcustom notmuch-mua-compose-in 'current-window
+ "Where to create the mail buffer used to compose a new message.
+Possible values are `current-window' (default), `new-window' and
+`new-frame'. If set to `current-window', the mail buffer will be
+displayed in the current window, so the old buffer will be
+restored when the mail buffer is killed. If set to `new-window'
+or `new-frame', the mail buffer will be displayed in a new
+window/frame that will be destroyed when the buffer is killed.
+You may want to customize `message-kill-buffer-on-exit'
+accordingly."
+ :group 'notmuch-send
+ :type '(choice (const :tag "Compose in the current window" current-window)
+ (const :tag "Compose mail in a new window" new-window)
+ (const :tag "Compose mail in a new frame" new-frame)))
+
+(defcustom notmuch-mua-user-agent-function nil
+ "Function used to generate a `User-Agent:' string.
+If this is `nil' then no `User-Agent:' will be generated."
+ :type '(choice (const :tag "No user agent string" nil)
+ (const :tag "Full" notmuch-mua-user-agent-full)
+ (const :tag "Notmuch" notmuch-mua-user-agent-notmuch)
+ (const :tag "Emacs" notmuch-mua-user-agent-emacs)
+ (function :tag "Custom user agent function"
+ :value notmuch-mua-user-agent-full))
+ :group 'notmuch-send)
+
+(defcustom notmuch-mua-hidden-headers nil
+ "Headers that are added to the `message-mode' hidden headers list."
+ :type '(repeat string)
+ :group 'notmuch-send)
+
+(defcustom notmuch-identities nil
+ "Identities that can be used as the From: address when composing a new message.
+
+If this variable is left unset, then a list will be constructed from the
+name and addresses configured in the notmuch configuration file."
+ :type '(repeat string)
+ :group 'notmuch-send)
+
+(defcustom notmuch-always-prompt-for-sender nil
+ "Always prompt for the From: address when composing or forwarding a message.
+
+This is not taken into account when replying to a message, because in that case
+the From: header is already filled in by notmuch."
+ :type 'boolean
+ :group 'notmuch-send)
+
+(defgroup notmuch-reply nil
+ "Replying to messages in notmuch."
+ :group 'notmuch)
+
+(defcustom notmuch-mua-cite-function 'message-cite-original
+ "Function for citing an original message.
+
+Predefined functions include `message-cite-original' and
+`message-cite-original-without-signature'. Note that these
+functions use `mail-citation-hook' if that is non-nil."
+ :type '(radio (function-item message-cite-original)
+ (function-item message-cite-original-without-signature)
+ (function-item sc-cite-original)
+ (function :tag "Other"))
+ :link '(custom-manual "(message)Insertion Variables")
+ :group 'notmuch-reply)
+
+(defcustom notmuch-mua-reply-insert-header-p-function
+ 'notmuch-show-reply-insert-header-p-never
+ "Function to decide which parts get a header when replying.
+
+This function specifies which parts of a mime message with
+multiple parts get a header."
+ :type '(radio (const :tag "No part headers"
+ notmuch-show-reply-insert-header-p-never)
+ (const :tag "All except multipart/* and hidden parts"
+ notmuch-show-reply-insert-header-p-trimmed)
+ (const :tag "Only for included text parts"
+ notmuch-show-reply-insert-header-p-minimal)
+ (const :tag "Exactly as in show view"
+ notmuch-show-insert-header-p)
+ (function :tag "Other"))
+ :group 'notmuch-reply)
+
+(defcustom notmuch-mua-attachment-regexp
+ "\\b\\(attache\?ment\\|attached\\|attach\\|pi[èe]ce\s+jointe?\\)\\b"
+ "Message body text indicating that an attachment is expected.
+
+This is not used unless `notmuch-mua-attachment-check' is added
+to `notmuch-mua-send-hook'."
+ :type 'regexp
+ :group 'notmuch-send)
+
+;;; Various functions
+
+(defun notmuch-mua-attachment-check ()
+ "Signal an error an attachement is expected but missing.
+
+Signal an error if the message text indicates that an attachment
+is expected but no MML referencing an attachment is found.
+
+Typically this is added to `notmuch-mua-send-hook'."
+ (when (and
+ ;; When the message mentions attachment...
+ (save-excursion
+ (message-goto-body)
+ ;; Limit search from reaching other possible parts of the message
+ (let ((search-limit (search-forward "\n<#" nil t)))
+ (message-goto-body)
+ (cl-loop while (re-search-forward notmuch-mua-attachment-regexp
+ search-limit t)
+ ;; For every instance of the "attachment" string
+ ;; found, examine the text properties. If the text
+ ;; has either a `face' or `syntax-table' property
+ ;; then it is quoted text and should *not* cause the
+ ;; user to be asked about a missing attachment.
+ if (let ((props (text-properties-at (match-beginning 0))))
+ (not (or (memq 'syntax-table props)
+ (memq 'face props))))
+ return t
+ finally return nil)))
+ ;; ...but doesn't have a part with a filename...
+ (save-excursion
+ (message-goto-body)
+ (not (re-search-forward "^<#part [^>]*filename=" nil t)))
+ ;; ...and that's not okay...
+ (not (y-or-n-p "Attachment mentioned, but no attachment - is that okay?")))
+ ;; ...signal an error.
+ (error "Missing attachment")))
+
+(defun notmuch-mua-get-switch-function ()
+ "Get a switch function according to `notmuch-mua-compose-in'."
+ (pcase notmuch-mua-compose-in
+ ('current-window 'switch-to-buffer)
+ ('new-window 'switch-to-buffer-other-window)
+ ('new-frame 'switch-to-buffer-other-frame)
+ (_ (error "Invalid value for `notmuch-mua-compose-in'"))))
+
+(defun notmuch-mua-maybe-set-window-dedicated ()
+ "Set the selected window as dedicated according to `notmuch-mua-compose-in'."
+ (when (or (eq notmuch-mua-compose-in 'new-frame)
+ (eq notmuch-mua-compose-in 'new-window))
+ (set-window-dedicated-p (selected-window) t)))
+
+(defun notmuch-mua-user-agent-full ()
+ "Generate a `User-Agent:' string suitable for notmuch."
+ (concat (notmuch-mua-user-agent-notmuch)
+ " "
+ (notmuch-mua-user-agent-emacs)))
+
+(defun notmuch-mua-user-agent-notmuch ()
+ "Generate a `User-Agent:' string suitable for notmuch."
+ (let ((notmuch-version (if (string= notmuch-emacs-version "unknown")
+ (notmuch-cli-version)
+ notmuch-emacs-version)))
+ (concat "Notmuch/" notmuch-version " (https://notmuchmail.org)")))
+
+(defun notmuch-mua-user-agent-emacs ()
+ "Generate a `User-Agent:' string suitable for notmuch."
+ (concat "Emacs/" emacs-version " (" system-configuration ")"))
+
+(defun notmuch-mua-add-more-hidden-headers ()
+ "Add some headers to the list that are hidden by default."
+ (mapc (lambda (header)
+ (unless (member header message-hidden-headers)
+ (push header message-hidden-headers)))
+ notmuch-mua-hidden-headers))
+
+(defun notmuch-mua-reply-crypto (parts)
+ "Add mml sign-encrypt flag if any part of original message is encrypted."
+ (cl-loop for part in parts
+ for type = (plist-get part :content-type)
+ if (notmuch-match-content-type type "multipart/encrypted")
+ do (mml-secure-message-sign-encrypt)
+ else if (notmuch-match-content-type type "multipart/*")
+ do (notmuch-mua-reply-crypto (plist-get part :content))))
+
+;; There is a bug in Emacs' message.el that results in a newline
+;; not being inserted after the References header, so the next header
+;; is concatenated to the end of it. This function fixes the problem,
+;; while guarding against the possibility that some current or future
+;; version of emacs has the bug fixed.
+(defun notmuch-mua-insert-references (original-func header references)
+ (funcall original-func header references)
+ (unless (bolp) (insert "\n")))
+
+;;; Mua reply
+
+(defun notmuch-mua-reply (query-string &optional sender reply-all duplicate)
+ (let* ((duparg (and duplicate (list (format "--duplicate=%d" duplicate))))
+ (args `("reply" "--format=sexp" "--format-version=5" ,@duparg))
+ (process-crypto notmuch-show-process-crypto)
+ reply
+ original)
+ (when process-crypto
+ (setq args (append args '("--decrypt=true"))))
+ (if reply-all
+ (setq args (append args '("--reply-to=all")))
+ (setq args (append args '("--reply-to=sender"))))
+ (setq args (append args (list query-string)))
+ ;; Get the reply object as SEXP, and parse it into an elisp object.
+ (setq reply (apply #'notmuch-call-notmuch-sexp args))
+ ;; Extract the original message to simplify the following code.
+ (setq original (plist-get reply :original))
+ ;; Extract the headers of both the reply and the original message.
+ (let* ((original-headers (plist-get original :headers))
+ (reply-headers (plist-get reply :reply-headers)))
+ ;; If sender is non-nil, set the From: header to its value.
+ (when sender
+ (plist-put reply-headers :From sender))
+ (let
+ ;; Overlay the composition window on that being used to read
+ ;; the original message.
+ ((same-window-regexps '("\\*mail .*")))
+ ;; We modify message-header-format-alist to get around
+ ;; a bug in message.el. See the comment above on
+ ;; notmuch-mua-insert-references.
+ (let ((message-header-format-alist
+ (cl-loop for pair in message-header-format-alist
+ if (eq (car pair) 'References)
+ collect (cons 'References
+ (apply-partially
+ 'notmuch-mua-insert-references
+ (cdr pair)))
+ else
+ collect pair)))
+ (notmuch-mua-mail (plist-get reply-headers :To)
+ (notmuch-sanitize (plist-get reply-headers :Subject))
+ (notmuch-headers-plist-to-alist reply-headers)
+ nil (notmuch-mua-get-switch-function))))
+ ;; Create a buffer-local queue for tag changes triggered when
+ ;; sending the reply.
+ (when notmuch-message-replied-tags
+ (setq notmuch-message-queued-tag-changes
+ (list (cons query-string notmuch-message-replied-tags))))
+ ;; Insert the message body - but put it in front of the signature
+ ;; if one is present, and after any other content
+ ;; message*setup-hooks may have added to the message body already.
+ (save-restriction
+ (message-goto-body)
+ (narrow-to-region (point) (point-max))
+ (goto-char (point-max))
+ (if (re-search-backward message-signature-separator nil t)
+ (when message-signature-insert-empty-line
+ (forward-line -1))
+ (goto-char (point-max))))
+ (let ((from (plist-get original-headers :From))
+ (date (plist-get original-headers :Date))
+ (start (point)))
+ ;; notmuch-mua-cite-function constructs a citation line based
+ ;; on the From and Date headers of the original message, which
+ ;; are assumed to be in the buffer.
+ (insert "From: " from "\n")
+ (insert "Date: " date "\n\n")
+ (insert
+ (with-temp-buffer
+ (let
+ ;; Don't attempt to clean up messages, excerpt
+ ;; citations, etc. in the original message before
+ ;; quoting.
+ ((notmuch-show-insert-text/plain-hook nil)
+ ;; Don't omit long parts.
+ (notmuch-show-max-text-part-size 0)
+ ;; Insert headers for parts as appropriate for replying.
+ (notmuch-show-insert-header-p-function
+ notmuch-mua-reply-insert-header-p-function)
+ ;; Ensure that any encrypted parts are
+ ;; decrypted during the generation of the reply
+ ;; text.
+ (notmuch-show-process-crypto process-crypto)
+ ;; Don't indent multipart sub-parts.
+ (notmuch-show-indent-multipart nil)
+ ;; Stop certain mime types from being inlined
+ (mm-inline-override-types (notmuch--inline-override-types)))
+ ;; We don't want sigstatus buttons (an information leak and usually wrong anyway).
+ (cl-letf (((symbol-function 'notmuch-crypto-insert-sigstatus-button) #'ignore)
+ ((symbol-function 'notmuch-crypto-insert-encstatus-button) #'ignore))
+ (notmuch-show-insert-body original (plist-get original :body) 0)
+ (buffer-substring-no-properties (point-min) (point-max))))))
+ (set-mark (point))
+ (goto-char start)
+ ;; Quote the original message according to the user's configured style.
+ (funcall notmuch-mua-cite-function)))
+ ;; Crypto processing based crypto content of the original message
+ (when process-crypto
+ (notmuch-mua-reply-crypto (plist-get original :body))))
+ ;; Push mark right before signature, if any.
+ (message-goto-signature)
+ (unless (eobp)
+ (end-of-line -1))
+ (push-mark)
+ (message-goto-body)
+ (set-buffer-modified-p nil))
+
+;;; Mode and keymap
+
+(defvar notmuch-message-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap message-send-and-exit] #'notmuch-mua-send-and-exit)
+ (define-key map [remap message-send] #'notmuch-mua-send)
+ (define-key map (kbd "C-c C-p") #'notmuch-draft-postpone)
+ (define-key map (kbd "C-x C-s") #'notmuch-draft-save)
+ map)
+ "Keymap for `notmuch-message-mode'.")
+
+(define-derived-mode notmuch-message-mode message-mode "Message[Notmuch]"
+ "Notmuch message composition mode. Mostly like `message-mode'."
+ (notmuch-address-setup))
+
+(put 'notmuch-message-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify)
+
+;;; New messages
+
+(defun notmuch-mua-pop-to-buffer (name switch-function)
+ "Pop to buffer NAME, and warn if it already exists and is modified.
+Like `message-pop-to-buffer' but enable `notmuch-message-mode'
+instead of `message-mode' and SWITCH-FUNCTION is mandatory."
+ (let ((buffer (get-buffer name)))
+ (if (and buffer
+ (buffer-name buffer))
+ (let ((window (get-buffer-window buffer 0)))
+ (if window
+ ;; Raise the frame already displaying the message buffer.
+ (progn
+ (select-frame-set-input-focus (window-frame window))
+ (select-window window))
+ (funcall switch-function buffer)
+ (set-buffer buffer))
+ (when (buffer-modified-p)
+ (if (y-or-n-p "Message already being composed; erase? ")
+ (message nil)
+ (error "Message being composed"))))
+ (funcall switch-function name)
+ (set-buffer name))
+ (erase-buffer)
+ (notmuch-message-mode)))
+
+(defun notmuch-mua--remove-dont-reply-to-names ()
+ (when-let* ((nr (if (functionp message-dont-reply-to-names)
+ message-dont-reply-to-names
+ (gmm-regexp-concat message-dont-reply-to-names)))
+ (nr-filter
+ (if (functionp nr)
+ (lambda (mail) (and (not (funcall nr mail)) mail))
+ (lambda (mail) (and (not (string-match-p nr mail)) mail)))))
+ (dolist (header '("To" "Cc"))
+ (when-let ((v (message-fetch-field header)))
+ (let* ((tokens (mapcar #'string-trim (message-tokenize-header v)))
+ (good-tokens (delq nil (mapcar nr-filter tokens)))
+ (addr (and good-tokens (mapconcat #'identity good-tokens ", "))))
+ (message-replace-header header addr))))))
+
+(defun notmuch-mua-mail (&optional to subject other-headers _continue
+ switch-function yank-action send-actions
+ return-action &rest ignored)
+ "Invoke the notmuch mail composition window.
+
+The position of point when the function returns differs depending
+on the values of TO and SUBJECT. If both are non-nil, point is
+moved to the message's body. If SUBJECT is nil but TO isn't,
+point is moved to the \"Subject:\" header. Otherwise, point is
+moved to the \"To:\" header."
+ (interactive)
+ (when notmuch-mua-user-agent-function
+ (let ((user-agent (funcall notmuch-mua-user-agent-function)))
+ (unless (string-empty-p user-agent)
+ (push (cons 'User-Agent user-agent) other-headers))))
+ (notmuch-mua-pop-to-buffer (message-buffer-name "mail" to)
+ (or switch-function
+ (notmuch-mua-get-switch-function)))
+ (let ((headers
+ (append
+ ;; The following is copied from `message-mail'
+ `((To . ,(or to "")) (Subject . ,(or subject "")))
+ ;; C-h f compose-mail says that headers should be specified as
+ ;; (string . value); however all the rest of message expects
+ ;; headers to be symbols, not strings (eg message-header-format-alist).
+ ;; https://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html
+ ;; We need to convert any string input, eg from rmail-start-mail.
+ (dolist (h other-headers other-headers)
+ (when (stringp (car h))
+ (setcar h (intern (capitalize (car h))))))))
+ ;; Cause `message-setup-1' to do things relevant for mail,
+ ;; such as observe `message-default-mail-headers'.
+ (message-this-is-mail t))
+ (unless (assq 'From headers)
+ (push (cons 'From (message-make-from
+ (notmuch-user-name)
+ (notmuch-user-primary-email)))
+ headers))
+ (message-setup-1 headers yank-action send-actions return-action))
+ (notmuch-fcc-header-setup)
+ (notmuch-mua--remove-dont-reply-to-names)
+ (message-sort-headers)
+ (message-hide-headers)
+ (set-buffer-modified-p nil)
+ (notmuch-mua-maybe-set-window-dedicated)
+ (cond
+ ((and to subject) (message-goto-body))
+ (to (message-goto-subject))
+ (t (message-goto-to))))
+
+(defvar notmuch-mua-sender-history nil)
+
+(defun notmuch-mua-prompt-for-sender ()
+ "Prompt for a sender from the user's configured identities."
+ (if notmuch-identities
+ (completing-read "Send mail from: " notmuch-identities
+ nil nil nil 'notmuch-mua-sender-history
+ (car notmuch-identities))
+ (let* ((name (notmuch-user-name))
+ (addrs (cons (notmuch-user-primary-email)
+ (notmuch-user-other-email)))
+ (address
+ (completing-read (concat "Sender address for " name ": ") addrs
+ nil nil nil 'notmuch-mua-sender-history
+ (car addrs))))
+ (message-make-from name address))))
+
+(put 'notmuch-mua-new-mail 'notmuch-prefix-doc "... and prompt for sender")
+(defun notmuch-mua-new-mail (&optional prompt-for-sender)
+ "Compose new mail.
+
+If PROMPT-FOR-SENDER is non-nil, the user will be prompted for
+the From: address first."
+ (interactive "P")
+ (let ((other-headers
+ (and (or prompt-for-sender notmuch-always-prompt-for-sender)
+ (list (cons 'From (notmuch-mua-prompt-for-sender))))))
+ (notmuch-mua-mail nil nil other-headers nil (notmuch-mua-get-switch-function))))
+
+(defun notmuch-mua-new-forward-messages (messages &optional prompt-for-sender)
+ "Compose a new message forwarding MESSAGES.
+
+If PROMPT-FOR-SENDER is non-nil, the user will be prompteed for
+the From: address."
+ (let* ((other-headers
+ (and (or prompt-for-sender notmuch-always-prompt-for-sender)
+ (list (cons 'From (notmuch-mua-prompt-for-sender)))))
+ ;; Comes from the first message and is applied later.
+ forward-subject
+ ;; List of accumulated message-references of forwarded messages.
+ forward-references
+ ;; List of corresponding message-query.
+ forward-queries)
+ ;; Generate the template for the outgoing message.
+ (notmuch-mua-mail nil "" other-headers nil (notmuch-mua-get-switch-function))
+ (save-excursion
+ ;; Insert all of the forwarded messages.
+ (mapc (lambda (id)
+ (let ((temp-buffer (get-buffer-create
+ (concat "*notmuch-fwd-raw-" id "*"))))
+ ;; Get the raw version of this message in the buffer.
+ (with-current-buffer temp-buffer
+ (erase-buffer)
+ (let ((coding-system-for-read 'no-conversion))
+ (notmuch--call-process notmuch-command nil t nil
+ "show" "--format=raw" id))
+ ;; Because we process the messages in reverse order,
+ ;; always generate a forwarded subject, then use the
+ ;; last (i.e. first) one.
+ (setq forward-subject (message-make-forward-subject))
+ (push (message-fetch-field "Message-ID") forward-references)
+ (push id forward-queries))
+ ;; Make a copy ready to be forwarded in the
+ ;; composition buffer.
+ (message-forward-make-body temp-buffer)
+ ;; Kill the temporary buffer.
+ (kill-buffer temp-buffer)))
+ ;; `message-forward-make-body' always puts the message at
+ ;; the top, so do them in reverse order.
+ (reverse messages))
+ ;; Add in the appropriate subject.
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-remove-header "Subject")
+ (message-add-header (concat "Subject: " forward-subject))
+ (message-remove-header "References")
+ (message-add-header (concat "References: "
+ (mapconcat 'identity forward-references " "))))
+ ;; Create a buffer-local queue for tag changes triggered when
+ ;; sending the message.
+ (when notmuch-message-forwarded-tags
+ (setq notmuch-message-queued-tag-changes
+ (cl-loop for id in forward-queries
+ collect
+ (cons id notmuch-message-forwarded-tags))))
+ ;; `message-forward-make-body' shows the User-agent header. Hide
+ ;; it again.
+ (message-hide-headers)
+ (set-buffer-modified-p nil))))
+
+(defun notmuch-mua-new-reply (query-string &optional prompt-for-sender reply-all duplicate)
+ "Compose a reply to the message identified by QUERY-STRING.
+
+If PROMPT-FOR-SENDER is non-nil, the user will be prompted for
+the From: address first. If REPLY-ALL is non-nil, the message
+will be addressed to all recipients of the source message. If
+DUPLICATE is non-nil, based the reply on that duplicate file"
+ ;; `select-active-regions' is t by default. The reply insertion code
+ ;; sets the region to the quoted message to make it easy to delete
+ ;; (kill-region or C-w). These two things combine to put the quoted
+ ;; message in the primary selection.
+ ;;
+ ;; This is not what the user wanted and is a privacy risk (accidental
+ ;; pasting of the quoted message). We can avoid some of the problems
+ ;; by let-binding select-active-regions to nil. This fixes if the
+ ;; primary selection was previously in a non-emacs window but not if
+ ;; it was in an emacs window. To avoid the problem in the latter case
+ ;; we deactivate mark.
+ (let ((sender (and prompt-for-sender
+ (notmuch-mua-prompt-for-sender)))
+ (select-active-regions nil))
+ (notmuch-mua-reply query-string sender reply-all duplicate)
+ (deactivate-mark)))
+
+;;; Checks
+
+(defun notmuch-mua-check-no-misplaced-secure-tag ()
+ "Query user if there is a misplaced secure mml tag.
+
+Emacs message-send will (probably) ignore a secure mml tag unless
+it is at the start of the body. Returns t if there is no such
+tag, or the user confirms they mean it."
+ (save-excursion
+ (let ((body-start (progn (message-goto-body) (point))))
+ (goto-char (point-max))
+ (or
+ ;; We are always fine if there is no secure tag.
+ (not (search-backward "<#secure" nil t))
+ ;; There is a secure tag, so it must be at the start of the
+ ;; body, with no secure tag earlier (i.e., in the headers).
+ (and (= (point) body-start)
+ (not (search-backward "<#secure" nil t)))
+ ;; The user confirms they means it.
+ (yes-or-no-p "\
+There is a <#secure> tag not at the start of the body. It is
+likely that the message will be sent unsigned and unencrypted.
+Really send? ")))))
+
+(defun notmuch-mua-check-secure-tag-has-newline ()
+ "Query if the secure mml tag has a newline following it.
+
+Emacs message-send will (probably) ignore a correctly placed
+secure mml tag unless it is followed by a newline. Returns t if
+any secure tag is followed by a newline, or the user confirms
+they mean it."
+ (save-excursion
+ (message-goto-body)
+ (or
+ ;; There is no (correctly placed) secure tag.
+ (not (looking-at "<#secure"))
+ ;; The secure tag is followed by a newline.
+ (looking-at "<#secure[^\n>]*>\n")
+ ;; The user confirms they means it.
+ (yes-or-no-p "\
+The <#secure> tag at the start of the body is not followed by a
+newline. It is likely that the message will be sent unsigned and
+unencrypted. Really send? "))))
+
+;;; Finishing commands
+
+(defun notmuch-mua-send-common (arg &optional exit)
+ (interactive "P")
+ (run-hooks 'notmuch-mua-send-hook)
+ (when (and (notmuch-mua-check-no-misplaced-secure-tag)
+ (notmuch-mua-check-secure-tag-has-newline))
+ (cl-letf (((symbol-function 'message-do-fcc)
+ #'notmuch-maildir-message-do-fcc))
+ (if exit
+ (message-send-and-exit arg)
+ (message-send arg)))))
+
+(defun notmuch-mua-send-and-exit (&optional arg)
+ (interactive "P")
+ (notmuch-mua-send-common arg t))
+
+(defun notmuch-mua-send (&optional arg)
+ (interactive "P")
+ (notmuch-mua-send-common arg))
+
+(defun notmuch-mua-kill-buffer ()
+ (interactive)
+ (message-kill-buffer))
+
+;;; _
+
+(define-mail-user-agent 'notmuch-user-agent
+ 'notmuch-mua-mail
+ 'notmuch-mua-send-and-exit
+ 'notmuch-mua-kill-buffer
+ 'notmuch-mua-send-hook)
+
+;; Add some more headers to the list that `message-mode' hides when
+;; composing a message.
+(notmuch-mua-add-more-hidden-headers)
+
+(provide 'notmuch-mua)
+
+;;; notmuch-mua.el ends here
blob - /dev/null
blob + f04b07c2e51b28e34f03469b88205d279c45a587 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-parser.el
+;;; notmuch-parser.el --- streaming S-expression parser -*- lexical-binding: t -*-
+;;
+;; Copyright © Austin Clements
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Austin Clements <aclements@csail.mit.edu>
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'pcase)
+(require 'subr-x)
+
+(defun notmuch-sexp-create-parser ()
+ "Return a new streaming S-expression parser.
+
+This parser is designed to incrementally read an S-expression
+whose structure is known to the caller. Like a typical
+S-expression parsing interface, it provides a function to read a
+complete S-expression from the input. However, it extends this
+with an additional function that requires the next value in the
+input to be a list and descends into it, allowing its elements to
+be read one at a time or further descended into. Both functions
+can return 'retry to indicate that not enough input is available.
+
+The parser always consumes input from point in the current
+buffer. Hence, the caller is allowed to delete any data before
+point and may resynchronize after an error by moving point."
+ (vector 'notmuch-sexp-parser
+ 0 ; List depth
+ nil ; Partial parse position marker
+ nil)) ; Partial parse state
+
+(defmacro notmuch-sexp--depth (sp) `(aref ,sp 1))
+(defmacro notmuch-sexp--partial-pos (sp) `(aref ,sp 2))
+(defmacro notmuch-sexp--partial-state (sp) `(aref ,sp 3))
+
+(defun notmuch-sexp-read (sp)
+ "Consume and return the value at point in the current buffer.
+
+Returns 'retry if there is insufficient input to parse a complete
+value (though it may still move point over whitespace). If the
+parser is currently inside a list and the next token ends the
+list, this moves point just past the terminator and returns 'end.
+Otherwise, this moves point to just past the end of the value and
+returns the value."
+ (skip-chars-forward " \n\r\t")
+ (cond ((eobp) 'retry)
+ ((= (char-after) ?\))
+ ;; We've reached the end of a list
+ (if (= (notmuch-sexp--depth sp) 0)
+ ;; .. but we weren't in a list. Let read signal the
+ ;; error to be consistent with all other code paths.
+ (read (current-buffer))
+ ;; Go up a level and return an end token
+ (cl-decf (notmuch-sexp--depth sp))
+ (forward-char)
+ 'end))
+ ((= (char-after) ?\()
+ ;; We're at the beginning of a list. If we haven't started
+ ;; a partial parse yet, attempt to read the list in its
+ ;; entirety. If this fails, or we've started a partial
+ ;; parse, extend the partial parse to figure out when we
+ ;; have a complete list.
+ (catch 'return
+ (unless (notmuch-sexp--partial-state sp)
+ (let ((start (point)))
+ (condition-case nil
+ (throw 'return (read (current-buffer)))
+ (end-of-file (goto-char start)))))
+ ;; Extend the partial parse
+ (let (is-complete)
+ (save-excursion
+ (let* ((new-state (parse-partial-sexp
+ (or (notmuch-sexp--partial-pos sp) (point))
+ (point-max) 0 nil
+ (notmuch-sexp--partial-state sp)))
+ ;; A complete value is available if we've
+ ;; reached depth 0.
+ (depth (car new-state)))
+ (cl-assert (>= depth 0))
+ (if (= depth 0)
+ ;; Reset partial parse state
+ (setf (notmuch-sexp--partial-state sp) nil
+ (notmuch-sexp--partial-pos sp) nil
+ is-complete t)
+ ;; Update partial parse state
+ (setf (notmuch-sexp--partial-state sp) new-state
+ (notmuch-sexp--partial-pos sp) (point-marker)))))
+ (if is-complete
+ (read (current-buffer))
+ 'retry))))
+ (t
+ ;; Attempt to read a non-compound value
+ (let ((start (point)))
+ (condition-case nil
+ (let ((val (read (current-buffer))))
+ ;; We got what looks like a complete read, but if
+ ;; we reached the end of the buffer in the process,
+ ;; we may not actually have all of the input we
+ ;; need (unless it's a string, which is delimited).
+ (if (or (stringp val) (not (eobp)))
+ val
+ ;; We can't be sure the input was complete
+ (goto-char start)
+ 'retry))
+ (end-of-file
+ (goto-char start)
+ 'retry))))))
+
+(defun notmuch-sexp-begin-list (sp)
+ "Parse the beginning of a list value and enter the list.
+
+Returns 'retry if there is insufficient input to parse the
+beginning of the list. If this is able to parse the beginning of
+a list, it moves point past the token that opens the list and
+returns t. Later calls to `notmuch-sexp-read' will return the
+elements inside the list. If the input in buffer is not the
+beginning of a list, throw invalid-read-syntax."
+ (skip-chars-forward " \n\r\t")
+ (cond ((eobp) 'retry)
+ ((= (char-after) ?\()
+ (forward-char)
+ (cl-incf (notmuch-sexp--depth sp))
+ t)
+ (t
+ ;; Skip over the bad character like `read' does
+ (forward-char)
+ (signal 'invalid-read-syntax (list (string (char-before)))))))
+
+(defvar notmuch-sexp--parser nil
+ "The buffer-local notmuch-sexp-parser instance.
+
+Used by `notmuch-sexp-parse-partial-list'.")
+
+(defvar notmuch-sexp--state nil
+ "The buffer-local `notmuch-sexp-parse-partial-list' state.")
+
+(defun notmuch-sexp-parse-partial-list (result-function result-buffer)
+ "Incrementally parse an S-expression list from the current buffer.
+
+This function consumes an S-expression list from the current
+buffer, applying RESULT-FUNCTION in RESULT-BUFFER to each
+complete value in the list. It operates incrementally and should
+be called whenever the input buffer has been extended with
+additional data. The caller just needs to ensure it does not
+move point in the input buffer."
+ ;; Set up the initial state
+ (unless (local-variable-p 'notmuch-sexp--parser)
+ (setq-local notmuch-sexp--parser (notmuch-sexp-create-parser))
+ (setq-local notmuch-sexp--state 'begin))
+ (let (done)
+ (while (not done)
+ (cl-case notmuch-sexp--state
+ (begin
+ ;; Enter the list
+ (if (eq (notmuch-sexp-begin-list notmuch-sexp--parser) 'retry)
+ (setq done t)
+ (setq notmuch-sexp--state 'result)))
+ (result
+ ;; Parse a result
+ (let ((result (notmuch-sexp-read notmuch-sexp--parser)))
+ (cl-case result
+ (retry (setq done t))
+ (end (setq notmuch-sexp--state 'end))
+ (t (with-current-buffer result-buffer
+ (funcall result-function result))))))
+ (end
+ ;; Skip over trailing whitespace.
+ (skip-chars-forward " \n\r\t")
+ ;; Any trailing data is unexpected.
+ (unless (eobp)
+ (error "Trailing garbage following expression"))
+ (setq done t)))))
+ ;; Clear out what we've parsed
+ (delete-region (point-min) (point)))
+
+(provide 'notmuch-parser)
+
+;;; notmuch-parser.el ends here
blob - /dev/null
blob + 6c87844b3e938585e2096dbadc4bb5fc2b450db5 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-pkg.el
+(define-package "notmuch" "0.38.3" "Run notmuch within emacs" 'nil :commit "d0469c5b4c6ed9188b96b12363fced45291813fd" :url "https://notmuchmail.org")
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
blob - /dev/null
blob + 85fa1f218cfae1111cdb3e053c49cd4e05540b38 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-print.el
+;;; notmuch-print.el --- printing messages from notmuch -*- lexical-binding: t -*-
+;;
+;; Copyright © David Edmondson
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+;;; Code:
+
+(require 'notmuch-lib)
+
+(declare-function notmuch-show-get-prop "notmuch-show" (prop &optional props))
+
+;;; Options
+
+(defcustom notmuch-print-mechanism 'notmuch-print-lpr
+ "How should printing be done?"
+ :group 'notmuch-show
+ :type '(choice
+ (function :tag "Use lpr" notmuch-print-lpr)
+ (function :tag "Use ps-print" notmuch-print-ps-print)
+ (function :tag "Use ps-print then evince" notmuch-print-ps-print/evince)
+ (function :tag "Use muttprint" notmuch-print-muttprint)
+ (function :tag "Use muttprint then evince" notmuch-print-muttprint/evince)
+ (function :tag "Using a custom function")))
+
+;;; Utility functions
+
+(defun notmuch-print-run-evince (file)
+ "View FILE using 'evince'."
+ (start-process "evince" nil "evince" file))
+
+(defun notmuch-print-run-muttprint (&optional output)
+ "Pass the contents of the current buffer to 'muttprint'.
+
+Optional OUTPUT allows passing a list of flags to muttprint."
+ (apply #'notmuch--call-process-region (point-min) (point-max)
+ ;; Reads from stdin.
+ "muttprint"
+ nil nil nil
+ ;; Show the tags.
+ "--printed-headers" "Date_To_From_CC_Newsgroups_*Subject*_/Tags/"
+ output))
+
+;;; User-visible functions
+
+(defun notmuch-print-lpr (_msg)
+ "Print a message buffer using lpr."
+ (lpr-buffer))
+
+(defun notmuch-print-ps-print (msg)
+ "Print a message buffer using the ps-print package."
+ (let ((subject (notmuch-prettify-subject
+ (plist-get (notmuch-show-get-prop :headers msg) :Subject))))
+ (rename-buffer subject t)
+ (ps-print-buffer)))
+
+(defun notmuch-print-ps-print/evince (msg)
+ "Preview a message buffer using ps-print and evince."
+ (let ((ps-file (make-temp-file "notmuch" nil ".ps"))
+ (subject (notmuch-prettify-subject
+ (plist-get (notmuch-show-get-prop :headers msg) :Subject))))
+ (rename-buffer subject t)
+ (ps-print-buffer ps-file)
+ (notmuch-print-run-evince ps-file)))
+
+(defun notmuch-print-muttprint (_msg)
+ "Print a message using muttprint."
+ (notmuch-print-run-muttprint))
+
+(defun notmuch-print-muttprint/evince (_msg)
+ "Preview a message buffer using muttprint and evince."
+ (let ((ps-file (make-temp-file "notmuch" nil ".ps")))
+ (notmuch-print-run-muttprint (list "--printer" (concat "TO_FILE:" ps-file)))
+ (notmuch-print-run-evince ps-file)))
+
+(defun notmuch-print-message (msg)
+ "Print a message using the user-selected mechanism."
+ (set-buffer-modified-p nil)
+ (funcall notmuch-print-mechanism msg))
+
+;;; _
+
+(provide 'notmuch-print)
+
+;;; notmuch-print.el ends here
blob - /dev/null
blob + 2a46144c49846dcf3301ac5b365951fcab731239 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-query.el
+;;; notmuch-query.el --- provide an emacs api to query notmuch -*- lexical-binding: t -*-
+;;
+;; Copyright © David Bremner
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: David Bremner <david@tethera.net>
+
+;;; Code:
+
+(require 'notmuch-lib)
+
+;;; Basic query function
+
+(define-obsolete-function-alias
+ 'notmuch-query-get-threads
+ #'notmuch--run-show
+ "notmuch 0.37")
+
+;;; Mapping functions across collections of messages
+
+(defun notmuch-query-map-aux (mapper function seq)
+ "Private function to do the actual mapping and flattening."
+ (cl-mapcan (lambda (tree)
+ (funcall mapper function tree))
+ seq))
+
+(defun notmuch-query-map-threads (fn threads)
+ "Apply function FN to every thread in THREADS.
+Flatten results to a list. See the function
+`notmuch-query-get-threads' for more information."
+ (notmuch-query-map-aux 'notmuch-query-map-forest fn threads))
+
+(defun notmuch-query-map-forest (fn forest)
+ "Apply function FN to every message in FOREST.
+Flatten results to a list. See the function
+`notmuch-query-get-threads' for more information."
+ (notmuch-query-map-aux 'notmuch-query-map-tree fn forest))
+
+(defun notmuch-query-map-tree (fn tree)
+ "Apply function FN to every message in TREE.
+Flatten results to a list. See the function
+`notmuch--run-show' for more information."
+ (cons (funcall fn (car tree))
+ (notmuch-query-map-forest fn (cadr tree))))
+
+;;; Predefined queries
+
+(defun notmuch-query-get-message-ids (&rest search-terms)
+ "Return a list of message-ids of messages that match SEARCH-TERMS."
+ (notmuch-query-map-threads
+ (lambda (msg) (plist-get msg :id))
+ (notmuch--run-show search-terms)))
+
+;;; Everything in this library is obsolete
+(dolist (fun '(map-aux map-threads map-forest map-tree get-message-ids))
+ (make-obsolete (intern (format "notmuch-query-%s" fun)) nil "notmuch 0.37"))
+
+(provide 'notmuch-query)
+
+;;; notmuch-query.el ends here
blob - /dev/null
blob + 4cc5aa57d91cc204b2800bf8e38c75f057231dc5 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-show.el
+;;; notmuch-show.el --- displaying notmuch forests -*- lexical-binding: t -*-
+;;
+;; Copyright © Carl Worth
+;; Copyright © David Edmondson
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+;; David Edmondson <dme@dme.org>
+
+;;; Code:
+
+(require 'mm-view)
+(require 'message)
+(require 'mm-decode)
+(require 'mailcap)
+(require 'icalendar)
+(require 'goto-addr)
+
+(require 'notmuch-lib)
+(require 'notmuch-tag)
+(require 'notmuch-wash)
+(require 'notmuch-mua)
+(require 'notmuch-crypto)
+(require 'notmuch-print)
+(require 'notmuch-draft)
+
+(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")
+(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 parent-buffer))
+(declare-function notmuch-tree-get-message-properties "notmuch-tree" nil)
+(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.
+
+For an open message, all of these headers will be made visible
+according to `notmuch-message-headers-visible' or can be toggled
+with `notmuch-show-toggle-visibility-headers'. For a closed message,
+only the first header in the list will be visible."
+ :type '(repeat string)
+ :group 'notmuch-show)
+
+(defcustom notmuch-message-headers-visible t
+ "Should the headers be visible by default?
+
+If this value is non-nil, then all of the headers defined in
+`notmuch-message-headers' will be visible by default in the display
+of each message. Otherwise, these headers will be hidden and
+`notmuch-show-toggle-visibility-headers' can be used to make them
+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
+ :group 'notmuch-show)
+
+(defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers)
+ "A list of functions called to decorate the headers listed in
+`notmuch-message-headers'.")
+
+(defcustom notmuch-show-hook '(notmuch-show-turn-on-visual-line-mode)
+ "Functions called after populating a `notmuch-show' buffer."
+ :type 'hook
+ :options '(notmuch-show-turn-on-visual-line-mode)
+ :group 'notmuch-show
+ :group 'notmuch-hooks)
+
+(defcustom notmuch-show-insert-text/plain-hook
+ '(notmuch-wash-wrap-long-lines
+ notmuch-wash-tidy-citations
+ notmuch-wash-elide-blank-lines
+ notmuch-wash-excerpt-citations)
+ "Functions used to improve the display of text/plain parts."
+ :type 'hook
+ :options '(notmuch-wash-convert-inline-patch-to-part
+ notmuch-wash-wrap-long-lines
+ notmuch-wash-tidy-citations
+ notmuch-wash-elide-blank-lines
+ notmuch-wash-excerpt-citations)
+ :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?"
+ :type 'boolean
+ :group 'notmuch-show)
+
+(defcustom notmuch-show-indent-messages-width 1
+ "Width of message indentation in threads.
+
+Messages are shown indented according to their depth in a thread.
+This variable determines the width of this indentation measured
+in number of blanks. Defaults to `1', choose `0' to disable
+indentation."
+ :type 'integer
+ :group 'notmuch-show)
+
+(defcustom notmuch-show-indent-multipart nil
+ "Should the sub-parts of a multipart/* part be indented?"
+ ;; dme: Not sure which is a good default.
+ :type 'boolean
+ :group 'notmuch-show)
+
+(defcustom notmuch-show-part-button-default-action 'notmuch-show-save-part
+ "Default part header button action (on ENTER or mouse click)."
+ :group 'notmuch-show
+ :type '(choice (const :tag "Save part"
+ notmuch-show-save-part)
+ (const :tag "View part"
+ notmuch-show-view-part)
+ (const :tag "View interactively"
+ notmuch-show-interactively-view-part)))
+
+(defcustom notmuch-show-only-matching-messages nil
+ "Only matching messages are shown by default."
+ :type 'boolean
+ :group 'notmuch-show)
+
+;; 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)
+
+;;; Variables
+
+(defvar-local notmuch-show-thread-id nil)
+
+(defvar-local notmuch-show-parent-buffer nil)
+
+(defvar-local notmuch-show-query-context nil)
+
+(defvar-local notmuch-show-process-crypto nil)
+
+(defvar-local notmuch-show-elide-non-matching-messages nil)
+
+(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.
+
+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*\".")
+
+;;; Options
+
+(defcustom notmuch-show-stash-mlarchive-link-alist
+ '(("MARC" . "https://marc.info/?i=")
+ ("Mail Archive, The" . "https://mid.mail-archive.com/")
+ ("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/")
+ ;; ("opensubscriber" . "http://opensubscriber.com/")
+ )
+ "List of Mailing List Archives to use when stashing links.
+
+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 (choice
+ (string :tag "URL")
+ (function :tag "Function returning the URL")))
+ :group 'notmuch-show)
+
+(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
+provided with an MLA argument nor `completing-read' input."
+ :type `(choice
+ ,@(mapcar
+ (lambda (mla)
+ (list 'const :tag (car mla) :value (car mla)))
+ notmuch-show-stash-mlarchive-link-alist))
+ :group 'notmuch-show)
+
+(defcustom notmuch-show-mark-read-tags '("-unread")
+ "List of tag changes to apply to a message when it is marked as read.
+
+Tags starting with \"+\" (or not starting with either \"+\" or
+\"-\") in the list will be added, and tags starting with \"-\"
+will be removed from the message being marked as read.
+
+For example, if you wanted to remove an \"unread\" tag and add a
+\"read\" tag (which would make little sense), you would set:
+ (\"-unread\" \"+read\")"
+ :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)
+
+(defcustom notmuch-show-imenu-indent nil
+ "Should Imenu display messages indented.
+
+By default, Imenu (see Info node `(emacs) Imenu') in a
+notmuch-show buffer displays all messages straight. This is
+because the default Emacs frontend for Imenu makes it difficult
+to select an Imenu entry with spaces in front. Other imenu
+frontends such as counsel-imenu does not have this limitation.
+In these cases, Imenu entries can be indented to reflect the
+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
+ (let ((id (notmuch-show-get-message-id)))
+ (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*"))))
+ (with-current-buffer buf
+ (let ((coding-system-for-read 'no-conversion))
+ (notmuch--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))
+
+;;; 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.
+(defun notmuch-show-view-all-mime-parts ()
+ "Use external viewers to view all attachments from the current message."
+ (interactive)
+ (with-current-notmuch-show-message
+ ;; We override the mm-inline-media-tests to indicate which message
+ ;; parts are already sufficiently handled by the original
+ ;; presentation of the message in notmuch-show mode. These parts
+ ;; will be inserted directly into the temporary buffer of
+ ;; with-current-notmuch-show-message and silently discarded.
+ ;;
+ ;; Any MIME part not explicitly mentioned here will be handled by an
+ ;; external viewer as configured in the various mailcap files.
+ (let ((mm-inline-media-tests
+ '(("text/.*" ignore identity)
+ ("application/pgp-signature" ignore identity)
+ ("multipart/alternative" ignore identity)
+ ("multipart/mixed" ignore identity)
+ ("multipart/related" ignore identity))))
+ (mm-display-parts (mm-dissect-buffer)))))
+
+(defun notmuch-show-save-attachments ()
+ "Save all attachments from the current message."
+ (interactive)
+ (with-current-notmuch-show-message
+ (let ((mm-handle (mm-dissect-buffer)))
+ (notmuch-save-attachments
+ mm-handle (> (notmuch-count-attachments mm-handle) 1))))
+ (message "Done"))
+
+(defun notmuch-show-with-message-as-text (fn)
+ "Apply FN to a text representation of the current message.
+
+FN is called with one argument, the message properties. It should
+operation on the contents of the current buffer."
+ ;; Remake the header to ensure that all information is available.
+ (let* ((to (notmuch-show-get-to))
+ (cc (notmuch-show-get-cc))
+ (from (notmuch-show-get-from))
+ (subject (notmuch-show-get-subject))
+ (date (notmuch-show-get-date))
+ (tags (notmuch-show-get-tags))
+ (depth (notmuch-show-get-depth))
+ (header (concat
+ "Subject: " subject "\n"
+ "To: " to "\n"
+ (if (not (string-empty-p cc))
+ (concat "Cc: " cc "\n")
+ "")
+ "From: " from "\n"
+ "Date: " date "\n"
+ (if tags
+ (concat "Tags: "
+ (mapconcat #'identity tags ", ") "\n")
+ "")))
+ (all (buffer-substring (notmuch-show-message-top)
+ (notmuch-show-message-bottom)))
+
+ (props (notmuch-show-get-message-properties))
+ (indenting notmuch-show-indent-content))
+ (with-temp-buffer
+ (insert all)
+ (when indenting
+ (indent-rigidly (point-min)
+ (point-max)
+ (- (* notmuch-show-indent-messages-width depth))))
+ ;; Remove the original header.
+ (goto-char (point-min))
+ (re-search-forward "^$" (point-max) nil)
+ (delete-region (point-min) (point))
+ (insert header)
+ (funcall fn props))))
+
+(defun notmuch-show-print-message ()
+ "Print the current message."
+ (interactive)
+ (notmuch-show-with-message-as-text 'notmuch-print-message))
+
+;;; Headers
+
+(defun notmuch-show-fontify-header ()
+ (let ((face (cond
+ ((looking-at "[Tt]o:")
+ 'message-header-to)
+ ((looking-at "[Bb]?[Cc][Cc]:")
+ 'message-header-cc)
+ ((looking-at "[Ss]ubject:")
+ 'message-header-subject)
+ (t
+ 'message-header-other))))
+ (overlay-put (make-overlay (point) (re-search-forward ":"))
+ 'face 'message-header-name)
+ (overlay-put (make-overlay (point) (re-search-forward ".*$"))
+ 'face face)))
+
+(defun notmuch-show-colour-headers ()
+ "Apply some colouring to the current headers."
+ (goto-char (point-min))
+ (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:")
+ (notmuch-show-fontify-header)
+ (forward-line)))
+
+(defun notmuch-show-spaces-n (n)
+ "Return a string comprised of `n' spaces."
+ (make-string n ? ))
+
+(defun notmuch-show-update-tags (tags)
+ "Update the displayed tags of the current message."
+ (save-excursion
+ (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
+cell of (AUTHOR_EMAIL AUTHOR_NAME). Return (ADDRESS nil) if
+parsing fails."
+ (condition-case nil
+ (let (p-name p-address)
+ ;; It would be convenient to use `mail-header-parse-address',
+ ;; but that expects un-decoded mailbox parts, whereas our
+ ;; mailbox parts are already decoded (and hence may contain
+ ;; UTF-8). Given that notmuch should handle most of the awkward
+ ;; cases, some simple string deconstruction should be sufficient
+ ;; here.
+ (cond
+ ;; "User <user@dom.ain>" style.
+ ((string-match "\\(.*\\) <\\(.*\\)>" address)
+ (setq p-name (match-string 1 address))
+ (setq p-address (match-string 2 address)))
+
+ ;; "<user@dom.ain>" style.
+ ((string-match "<\\(.*\\)>" address)
+ (setq p-address (match-string 1 address)))
+ ;; Everything else.
+ (t
+ (setq p-address address)))
+ (when p-name
+ ;; Remove elements of the mailbox part that are not relevant for
+ ;; display, even if they are required during transport:
+ ;;
+ ;; Backslashes.
+ (setq p-name (replace-regexp-in-string "\\\\" "" p-name))
+ ;; Outer single and double quotes, which might be nested.
+ (cl-loop with start-of-loop
+ do (setq start-of-loop p-name)
+ when (string-match "^\"\\(.*\\)\"$" p-name)
+ do (setq p-name (match-string 1 p-name))
+ when (string-match "^'\\(.*\\)'$" p-name)
+ do (setq p-name (match-string 1 p-name))
+ until (string= start-of-loop p-name)))
+ ;; If the address is 'foo@bar.com <foo@bar.com>' then show just
+ ;; 'foo@bar.com'.
+ (when (string= p-name p-address)
+ (setq p-name nil))
+ (cons p-address p-name))
+ (error (cons address nil))))
+
+(defun notmuch-show-clean-address (address)
+ "Try to clean a single email ADDRESS for display.
+Return unchanged ADDRESS if parsing fails."
+ (let* ((clean-address (notmuch-clean-address address))
+ (p-address (car clean-address))
+ (p-name (cdr clean-address)))
+ ;; If no name, return just the address.
+ (if (not p-name)
+ p-address
+ ;; Otherwise format the name and address together.
+ (concat p-name " <" p-address ">"))))
+
+(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))
+ (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
+ ;; invisible U+200E LEFT-TO-RIGHT MARK character which forces
+ ;; the header paragraph as left-to-right text.
+ (insert (propertize (string ?\x200e) 'invisible t)))
+ (insert (if notmuch-show-indent-content
+ (notmuch-show-spaces-n (* notmuch-show-indent-messages-width
+ depth))
+ "")
+ from
+ " ("
+ date
+ ") ("
+ (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)))
+
+(defun notmuch-show-insert-header (header header-value)
+ "Insert a single header."
+ (insert header ": " (notmuch-sanitize header-value) "\n"))
+
+(defun notmuch-show-insert-headers (headers)
+ "Insert the headers of the current message."
+ (let ((start (point)))
+ (mapc (lambda (header)
+ (let* ((header-symbol (intern (concat ":" header)))
+ (header-value (plist-get headers header-symbol)))
+ (when (and header-value
+ (not (string-equal "" header-value)))
+ (notmuch-show-insert-header header header-value))))
+ notmuch-message-headers)
+ (save-excursion
+ (save-restriction
+ (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
+ &optional name comment)
+ (let ((base-label (concat (and name (concat name ": "))
+ declared-type
+ (and (not (string-equal declared-type content-type))
+ (concat " (as " content-type ")"))
+ comment)))
+ (prog1 (insert-button
+ (concat "[ " base-label " ]")
+ :base-label base-label
+ :type 'notmuch-show-part-button-type
+ :notmuch-part-hidden nil)
+ (insert "\n"))))
+
+(defun notmuch-show-toggle-part-invisibility (&optional button)
+ (interactive)
+ (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))
+ (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
+
+(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
+ (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.
+
+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."
+ (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."
+ (interactive)
+ (when (and (boundp 'w3m-cid-retrieve-function-alist)
+ (not (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-html-inhibit-images nil))
+
+(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 (car content-and-type))
+ (cadr content-and-type))))
+
+;; MIME part renderers
+
+(defun notmuch-show-multipart/*-to-list (part)
+ (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)
+ (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,
+ ;; but it's not clear that this is the wrong thing to do - which
+ ;; should be chosen if there are more than one that match?
+ (mapc (lambda (inner-part)
+ (let* ((inner-type (plist-get inner-part :content-type))
+ (hide (not (or notmuch-show-all-multipart/alternative-parts
+ (string= chosen-type inner-type)))))
+ (notmuch-show-insert-bodypart msg inner-part depth hide)))
+ inner-parts)
+
+ (when notmuch-show-indent-multipart
+ (indent-rigidly start (point) 1)))
+ t)
+
+(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.
+ (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 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)))
+ ;; Show all of the parts.
+ (mapc (lambda (inner-part)
+ (notmuch-show-insert-bodypart msg inner-part depth))
+ inner-parts)
+ (when notmuch-show-indent-multipart
+ (indent-rigidly start (point) 1)))
+ t)
+
+(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)))
+ ;; Show all of the parts.
+ (mapc (lambda (inner-part)
+ (notmuch-show-insert-bodypart msg inner-part depth))
+ inner-parts)
+ (when notmuch-show-indent-multipart
+ (indent-rigidly start (point) 1)))
+ t)
+
+(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)
+ (let ((inner-parts (plist-get part :content))
+ (start (point)))
+ ;; Show all of the parts.
+ (mapc (lambda (inner-part)
+ (notmuch-show-insert-bodypart msg inner-part depth))
+ inner-parts)
+ (when notmuch-show-indent-multipart
+ (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))))
+ (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.
+ (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 _button)
+ (insert (with-temp-buffer
+ (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))
+ (let ((file (make-temp-file "notmuch-ical"))
+ result)
+ (unwind-protect
+ (progn
+ (unless (icalendar-import-buffer file t)
+ (error "Icalendar import error. %s"
+ "See *icalendar-errors* for more information"))
+ (set-buffer (get-file-buffer file))
+ (setq result (buffer-substring (point-min) (point-max)))
+ (set-buffer-modified-p nil)
+ (kill-buffer (current-buffer)))
+ (delete-file file))
+ result)))
+ 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 nil nil depth nil))
+
+(when (version< emacs-version "25.3")
+ ;; https://bugs.gnu.org/28350
+ ;;
+ ;; For newer emacs, we fall back to notmuch-show-insert-part-*/*
+ ;; (see notmuch-show-handlers-for)
+ (defun notmuch-show-insert-part-text/enriched
+ (msg part content-type nth depth button)
+ ;; By requiring enriched below, we ensure that the function
+ ;; enriched-decode-display-prop is defined before it will be
+ ;; shadowed by the letf below. Otherwise the version in
+ ;; enriched.el may be loaded a bit later and used instead (for
+ ;; the first time).
+ (require 'enriched)
+ (cl-letf (((symbol-function 'enriched-decode-display-prop)
+ (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)
+ ;; If we can deduce a MIME type from the filename of the attachment,
+ ;; we return that.
+ (and (plist-get part :filename)
+ (let ((extension (file-name-extension (plist-get part :filename))))
+ (and extension
+ (progn
+ (mailcap-parse-mimetypes)
+ (let ((mime-type (mailcap-extension-to-mime extension)))
+ (and mime-type
+ (not (string-equal mime-type "application/octet-stream"))
+ mime-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)
+ (w3m-ignored-image-url-regexp notmuch-show-text/html-blocked-images))
+ (notmuch-show-insert-part-*/* msg part content-type nth depth button))))
+
+;;; Functions 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)))
+ (car (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-mm-display-part-inline msg part content-type notmuch-show-process-crypto)
+ t)
+
+;;; 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."
+ (let (result)
+ (mapc (lambda (func)
+ (when (functionp func)
+ (push func result)))
+ ;; Reverse order of prefrence.
+ (list (intern (concat "notmuch-show-insert-part-*/*"))
+ (intern (concat "notmuch-show-insert-part-"
+ (car (split-string content-type "/"))
+ "/*"))
+ (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.
+ (cl-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."
+ ;; 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)
+ (cl-pushnew :notmuch-part v)
+ v)))
+ (notmuch-map-text-property beg end 'rear-nonsticky
+ (lambda (v)
+ (if (listp v)
+ (cl-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))
+ (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
+ (* notmuch-show-indent-messages-width depth)))
+ (goto-char part-end)
+ (delete-char 1)
+ (notmuch-show-record-part-information (cadr 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."
+ (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")
+ "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.
+
+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 (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 (or deep long high
+ (funcall notmuch-show-insert-header-p-function part hide))
+ (notmuch-show-insert-part-header
+ 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/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))
+ (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)
+ (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 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))
+ ;; Ensure that the part ends with a carriage return.
+ (unless (bolp)
+ (insert "\n"))
+ ;; 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 (car body))
+ (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body))
+
+(defun notmuch-show-make-symbol (type)
+ (make-symbol (concat "notmuch-show-" type)))
+
+(defun notmuch-show-strip-re (string)
+ (replace-regexp-in-string "^\\([Rr]e: *\\)+" "" string))
+
+(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))
+ ;; Indentation causes the buffer offset of the start/end
+ ;; points to move, so we must use markers.
+ message-start message-end
+ content-start content-end
+ headers-start headers-end
+ (bare-subject (notmuch-show-strip-re (plist-get headers :Subject))))
+ (setq message-start (point-marker))
+ (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
+ ;; to after the first header.
+ (notmuch-show-insert-headers headers)
+ (save-excursion
+ (goto-char content-start)
+ ;; If the subject of this message is the same as that of the
+ ;; previous message, don't display it when this message is
+ ;; collapsed.
+ (unless (string= notmuch-show-previous-subject bare-subject)
+ (forward-line 1))
+ (setq headers-start (point-marker)))
+ (setq headers-end (point-marker))
+ (setq notmuch-show-previous-subject bare-subject)
+ ;; A blank line between the headers and the body.
+ (insert "\n")
+ (notmuch-show-insert-body msg (plist-get msg :body)
+ (if notmuch-show-indent-content depth 0))
+ ;; Ensure that the body ends with a newline.
+ (unless (bolp)
+ (insert "\n"))
+ (setq content-end (point-marker))
+ ;; Indent according to the depth in the thread.
+ (when notmuch-show-indent-content
+ (indent-rigidly content-start
+ content-end
+ (* notmuch-show-indent-messages-width depth)))
+ (setq message-end (point-max-marker))
+ ;; Save the extents of this message over the whole text of the
+ ;; message.
+ (put-text-property message-start message-end
+ :notmuch-message-extent
+ (cons message-start message-end))
+ ;; Create overlays used to control visibility
+ (plist-put msg :headers-overlay (make-overlay headers-start headers-end))
+ (plist-put msg :message-overlay (make-overlay headers-start content-end))
+ (plist-put msg :depth depth)
+ ;; Save the properties for this message. Currently this saves the
+ ;; entire message (augmented it with other stuff), which seems
+ ;; like overkill. We might save a reduced subset (for example, not
+ ;; the content).
+ (notmuch-show-set-message-properties msg)
+ ;; Set header visibility.
+ (notmuch-show-headers-visible msg notmuch-message-headers-visible)
+ ;; Message visibility depends on whether it matched the search
+ ;; criteria.
+ (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)
+ (setq notmuch-show-process-crypto (not notmuch-show-process-crypto))
+ (message (if notmuch-show-process-crypto
+ "Processing cryptographic MIME parts."
+ "Not processing cryptographic MIME parts."))
+ (notmuch-show-refresh-view))
+
+(defun notmuch-show-toggle-elide-non-matching ()
+ "Toggle the display of non-matching messages."
+ (interactive)
+ (setq notmuch-show-elide-non-matching-messages
+ (not notmuch-show-elide-non-matching-messages))
+ (message (if notmuch-show-elide-non-matching-messages
+ "Showing matching messages only."
+ "Showing all messages."))
+ (notmuch-show-refresh-view))
+
+(defun notmuch-show-toggle-thread-indentation ()
+ "Toggle the indentation of threads."
+ (interactive)
+ (setq notmuch-show-indent-content (not notmuch-show-indent-content))
+ (message (if notmuch-show-indent-content
+ "Content is indented."
+ "Content is not indented."))
+ (notmuch-show-refresh-view))
+
+;;; 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))))
+
+(defun notmuch-show-insert-thread (thread depth)
+ "Insert the thread THREAD at depth DEPTH in the current forest."
+ (mapc (lambda (tree) (notmuch-show-insert-tree tree depth)) thread))
+
+(defun notmuch-show-insert-forest (forest)
+ "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
+ ;; example, matching cid:).
+ "\\<id:\\("
+ ;; If the term starts with a ", then parse Xapian's quoted boolean
+ ;; term syntax, which allows for anything as long as embedded
+ ;; double quotes escaped by doubling them. We also disallow
+ ;; newlines (which Xapian allows) to prevent runaway terms.
+ "\"\\([^\"\n]\\|\"\"\\)*\""
+ ;; Otherwise, parse Xapian's unquoted syntax, which goes up to the
+ ;; next space or ). We disallow [.,;] as the last character
+ ;; because these are probably part of the surrounding text, and not
+ ;; part of the id. This doesn't match single character ids; meh.
+ "\\|[^\"[:space:])][^[:space:])]*[^])[:space:].,:;?!]"
+ "\\)")
+ "The regexp used to match id: links in messages.")
+
+(defvar notmuch-mid-regexp
+ ;; goto-address-url-regexp matched cid: links, which have the same
+ ;; grammar as the message ID part of a mid: link. Construct the
+ ;; regexp using the same technique as goto-address-url-regexp.
+ (concat "\\<mid:\\(" thing-at-point-url-path-regexp "\\)")
+ "The regexp used to match mid: links in messages.
+
+See RFC 2392.")
+
+(defun notmuch-show-buttonise-links (start end)
+ "Buttonise URLs and mail addresses between START and END.
+
+This also turns id:\"<message id>\"-parts and mid: links into
+buttons for a corresponding notmuch search."
+ (goto-address-fontify-region start end)
+ (save-excursion
+ (let (links
+ (beg-line (progn (goto-char start) (line-beginning-position)))
+ (end-line (progn (goto-char end) (line-end-position))))
+ (goto-char beg-line)
+ (while (re-search-forward notmuch-id-regexp end-line t)
+ (push (list (match-beginning 0) (match-end 0)
+ (match-string-no-properties 0)) links))
+ (goto-char beg-line)
+ (while (re-search-forward notmuch-mid-regexp end-line t)
+ (let* ((mid-cid (match-string-no-properties 1))
+ (mid (save-match-data
+ (string-match "^[^/]*" mid-cid)
+ (url-unhex-string (match-string 0 mid-cid)))))
+ (push (list (match-beginning 0) (match-end 0)
+ (notmuch-id-to-query mid)) links)))
+ (pcase-dolist (`(,beg ,end ,link) links)
+ ;; Remove the overlay created by goto-address-mode
+ (remove-overlays beg end 'goto-address t)
+ (make-text-button beg end
+ :type 'notmuch-button-type
+ 'action `(lambda (arg)
+ (notmuch-show ,link current-prefix-arg))
+ 'follow-link t
+ '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.
+
+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
+one).
+
+The optional QUERY-CONTEXT is a notmuch search term. Only
+messages from the thread matching this search term are shown if
+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.
+
+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 "*"))))
+ (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)
+ (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)
+ (setq notmuch-show-parent-buffer parent-buffer)
+ (setq notmuch-show-query-context
+ (if (or (string= query-context "")
+ (string= query-context "*"))
+ nil
+ query-context))
+ (setq notmuch-show-process-crypto notmuch-crypto-process-mime)
+ ;; If `elide-toggle', invert the default value.
+ (setq 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-queries (thread context)
+ "Return a list of queries to try for this search.
+
+THREAD and CONTEXT are both strings, though CONTEXT may be nil.
+When CONTEXT is not nil, the first query is the conjunction of it
+and THREAD. The next query is THREAD alone, and serves as a
+fallback if the prior matches no messages."
+ (let (queries)
+ (push (list thread) queries)
+ (when context
+ (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.
+
+Apply the previously saved STATE if supplied, otherwise show the
+first relevant message.
+
+If no messages match the query return NIL."
+ (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)
+ ;; Must be reset every time we are going to start inserting
+ ;; messages into the buffer.
+ (notmuch-show-previous-subject ""))
+ ;; Use results from the first query that returns some.
+ (while (and (not forest) queries)
+ (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)
+ ;; 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))))
+ (setq header-line-format (notmuch-show--header-line-format))
+ (run-hooks 'notmuch-show-hook)
+ (if state
+ (notmuch-show-apply-state state)
+ ;; With no state to apply, just go to the first message.
+ (notmuch-show-goto-first-wanted-message)))
+ ;; Report back to the caller whether any messages matched.
+ forest))
+
+;;; Refresh command
+
+(defun notmuch-show-capture-state ()
+ "Capture the state of the current buffer.
+
+This includes:
+ - the list of open messages,
+ - the combination of current message id with/for each visible window."
+ (let* ((win-list (get-buffer-window-list (current-buffer) nil t))
+ (win-id-combo (mapcar (lambda (win)
+ (with-selected-window win
+ (list win (notmuch-show-get-message-id))))
+ win-list)))
+ (list win-id-combo (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 (cl-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.
+
+This includes:
+ - opening the messages previously opened,
+ - closing all other messages,
+ - moving to the correct current message in every displayed window."
+ (let ((win-msg-alist (car state))
+ (open (cadr state)))
+ ;; Open those that were open.
+ (goto-char (point-min))
+ (cl-loop do (notmuch-show-message-visible
+ (notmuch-show-get-message-properties)
+ (member (notmuch-show-get-message-id) open))
+ until (not (notmuch-show-goto-message-next)))
+ (dolist (win-msg-pair win-msg-alist)
+ (with-selected-window (car win-msg-pair)
+ ;; Go to the previously open message in this window
+ (notmuch-show-goto-message (cadr win-msg-pair))))))
+
+(defun notmuch-show-refresh-view (&optional reset-state)
+ "Refresh the current view.
+
+Refreshes the current view, observing changes in display
+preferences. If invoked with a prefix argument (or RESET-STATE is
+non-nil) then the state of the buffer (open/closed messages) is
+reset based on the original query."
+ (interactive "P")
+ (let ((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
+ ;; to weird effects such as remaining images, so remove them
+ ;; manually.
+ (remove-overlays)
+ (erase-buffer)
+ (unless (notmuch-show--build-buffer state)
+ ;; No messages were inserted.
+ (kill-buffer (current-buffer))
+ (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 "d" 'notmuch-show-stash-date)
+ (define-key map "F" 'notmuch-show-stash-filename)
+ (define-key map "f" 'notmuch-show-stash-from)
+ (define-key map "i" 'notmuch-show-stash-message-id)
+ (define-key map "I" 'notmuch-show-stash-message-id-stripped)
+ (define-key map "s" 'notmuch-show-stash-subject)
+ (define-key map "T" 'notmuch-show-stash-tags)
+ (define-key map "t" 'notmuch-show-stash-to)
+ (define-key map "l" 'notmuch-show-stash-mlarchive-link)
+ (define-key map "L" 'notmuch-show-stash-mlarchive-link-and-go)
+ (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)
+
+(defvar notmuch-show-part-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "s" 'notmuch-show-save-part)
+ (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 "m" 'notmuch-show-choose-mime-of-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)))
+ (set-keymap-parent map notmuch-common-keymap)
+ (define-key map "Z" 'notmuch-tree-from-show-current-query)
+ (define-key map "U" 'notmuch-unthreaded-from-show-current-query)
+ (define-key map (kbd "<C-tab>") 'widget-backward)
+ (define-key map (kbd "M-TAB") 'notmuch-show-previous-button)
+ (define-key map (kbd "<backtab>") '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 "b" 'notmuch-show-resend-message)
+ (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 "e" 'notmuch-show-resume-message)
+ (define-key map "c" 'notmuch-show-stash-map)
+ (define-key map "h" 'notmuch-show-toggle-visibility-headers)
+ (define-key map "k" 'notmuch-tag-jump)
+ (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-choose-duplicate)
+ (define-key map "<" 'notmuch-show-toggle-thread-indentation)
+ (define-key map "t" 'toggle-truncate-lines)
+ (define-key map "." 'notmuch-show-part-map)
+ (define-key map "B" 'notmuch-show-browse-urls)
+ 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.
+
+This buffer contains the results of the \"notmuch show\" command
+for displaying a single thread of email from your email archives.
+
+By default, various components of email messages, (citations,
+signatures, already-read messages), are hidden. You can make
+these parts visible by clicking with the mouse button or by
+pressing RET after positioning the cursor on a hidden part, (for
+which \\[notmuch-show-next-button] and \\[notmuch-show-previous-button] are helpful).
+
+Reading the thread sequentially is well-supported by pressing
+\\[notmuch-show-advance-and-archive]. This will scroll the current message (if necessary), advance
+to the next message, or advance to the next thread (if already on
+the last message of a thread).
+
+Other commands are available to read or manipulate the thread
+more selectively, (such as '\\[notmuch-show-next-message]' and '\\[notmuch-show-previous-message]' to advance to messages
+without removing any tags, and '\\[notmuch-show-archive-thread]' to archive an entire thread
+without scrolling through with \\[notmuch-show-advance-and-archive]).
+
+You can add or remove arbitrary tags from the current message with
+'\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'.
+
+All currently available key bindings:
+
+\\{notmuch-show-mode-map}"
+ (setq notmuch-buffer-refresh-function #'notmuch-show-refresh-view)
+ (setq buffer-read-only t)
+ (setq truncate-lines t)
+ (setq imenu-prev-index-position-function
+ #'notmuch-show-imenu-prev-index-position-function)
+ (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-tree notmuch-show-thread-id
+ notmuch-show-query-context
+ (notmuch-show-get-message-id)))
+
+(defun notmuch-unthreaded-from-show-current-query ()
+ "Call notmuch unthreaded with the current query."
+ (interactive)
+ (notmuch-unthreaded notmuch-show-thread-id
+ 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)))
+
+;; 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.
+(defun notmuch-show-message-extent ()
+ "Return a cons cell containing the start and end buffer offset
+of the current message."
+ (let (r)
+ (save-excursion
+ (while (not (setq r (get-text-property (point) :notmuch-message-extent)))
+ (backward-char)))
+ r))
+
+(defun notmuch-show-message-top ()
+ (car (notmuch-show-message-extent)))
+
+(defun notmuch-show-message-bottom ()
+ (cdr (notmuch-show-message-extent)))
+
+(defun notmuch-show-goto-message-next ()
+ (let ((start (point)))
+ (notmuch-show-move-to-message-bottom)
+ (if (not (eobp))
+ t
+ (goto-char start)
+ nil)))
+
+(defun notmuch-show-goto-message-previous ()
+ (notmuch-show-move-to-message-top)
+ (if (bobp)
+ nil
+ (backward-char)
+ (notmuch-show-move-to-message-top)
+ t))
+
+(defun notmuch-show-mapc (function)
+ "Iterate through all messages in the current thread with
+`notmuch-show-goto-message-next' and call FUNCTION for side
+effects."
+ (save-excursion
+ (goto-char (point-min))
+ (cl-loop do (funcall function)
+ while (notmuch-show-goto-message-next))))
+
+;;; 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))
+ (notmuch-show-set-prop :message-visible visible-p props))
+
+(defun notmuch-show-headers-visible (props 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.
+
+(defun notmuch-show-set-message-properties (props)
+ (save-excursion
+ (notmuch-show-move-to-message-top)
+ (put-text-property (point) (+ (point) 1)
+ :notmuch-message-properties props)))
+
+(defun notmuch-show-get-message-properties ()
+ "Return the properties of the current message as a plist.
+
+Some useful entries are:
+:headers - Property list containing the headers :Date, :Subject, :From, etc.
+:body - Body of the message
+:tags - Tags for this message"
+ (save-excursion
+ (notmuch-show-move-to-message-top)
+ (get-text-property (point) :notmuch-message-properties)))
+
+(defun notmuch-show-get-part-properties ()
+ "Return the properties of the innermost part containing point.
+
+This is the part property list retrieved from the CLI. Signals
+an error if there is no part containing point."
+ (or (get-text-property (point) :notmuch-part)
+ (error "No message part here")))
+
+(defun notmuch-show-set-prop (prop val &optional props)
+ (let ((inhibit-read-only t)
+ (props (or props
+ (notmuch-show-get-message-properties))))
+ (plist-put props prop val)
+ (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."
+ (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.
+
+If optional argument BARE is non-nil, return
+the Message-Id without id: prefix and escaping."
+ (if bare
+ (notmuch-show-get-prop :id)
+ (notmuch-id-to-query (notmuch-show-get-prop :id))))
+
+(defun notmuch-show-get-messages-ids ()
+ "Return all id: queries of messages in the current thread."
+ (let ((message-ids))
+ (notmuch-show-mapc
+ (lambda () (push (notmuch-show-get-message-id) message-ids)))
+ message-ids))
+
+(defun notmuch-show-get-messages-ids-search ()
+ "Return a search string for all message ids of messages in the
+current thread."
+ (mapconcat 'identity (notmuch-show-get-messages-ids) " or "))
+
+;; dme: Would it make sense to use a macro for many of these?
+
+(defun notmuch-show-get-filename ()
+ "Return the filename of the current message."
+ (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."
+ (plist-get (notmuch-show-get-prop :headers props) header))
+
+(defun notmuch-show-get-cc ()
+ (notmuch-show-get-header :Cc))
+
+(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))
+
+(defun notmuch-show-get-from ()
+ (notmuch-show-get-header :From))
+
+(defun notmuch-show-get-subject ()
+ (notmuch-show-get-header :Subject))
+
+(defun notmuch-show-get-to ()
+ (notmuch-show-get-header :To))
+
+(defun notmuch-show-get-depth ()
+ (notmuch-show-get-prop :depth))
+
+(defun notmuch-show-set-tags (tags)
+ "Set the tags of the current message."
+ (notmuch-show-set-prop :tags tags)
+ (notmuch-show-update-tags tags))
+
+(defun notmuch-show-get-tags ()
+ "Return the tags of the current message."
+ (notmuch-show-get-prop :tags))
+
+(defun notmuch-show-message-visible-p ()
+ "Is the current message visible?"
+ (notmuch-show-get-prop :message-visible))
+
+(defun notmuch-show-headers-visible-p ()
+ "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.
+
+Mark the current message as read by applying the tag changes in
+`notmuch-show-mark-read-tags' to it (remove the \"unread\" tag by
+default). If a prefix argument is given, the message will be
+marked as unread, i.e. the tag changes in
+`notmuch-show-mark-read-tags' will be reversed."
+ (interactive "P")
+ (when notmuch-show-mark-read-tags
+ (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)))
+
+(defvar notmuch-show--seen-has-errored nil)
+(make-variable-buffer-local 'notmuch-show--seen-has-errored)
+
+(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
+ (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 header-line-format
+ (concat header-line-format
+ (propertize
+ " [some mark read tag changes may have failed]"
+ 'face font-lock-warning-face)))))))))
+
+(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-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.
+
+(defun notmuch-show-get-message-ids-for-open-messages ()
+ "Return a list of all id: queries for open messages in the current thread."
+ (save-excursion
+ (let (message-ids done)
+ (goto-char (point-min))
+ (while (not done)
+ (when (notmuch-show-message-visible-p)
+ (setq message-ids
+ (append message-ids (list (notmuch-show-get-message-id)))))
+ (setq done (not (notmuch-show-goto-message-next))))
+ message-ids)))
+
+;;; Commands typically bound to keys.
+
+(defun notmuch-show-advance ()
+ "Advance through thread.
+
+If the current message in the thread is not yet fully visible,
+scroll by a near screenful to read more of the message.
+
+Otherwise, (the end of the current message is already within the
+current window), advance to the next open message."
+ (interactive)
+ (let* ((end-of-this-message (notmuch-show-message-bottom))
+ (visible-end-of-this-message (1- end-of-this-message))
+ (ret nil))
+ (while (invisible-p visible-end-of-this-message)
+ (setq visible-end-of-this-message
+ (max (point-min)
+ (1- (previous-single-char-property-change
+ visible-end-of-this-message 'invisible)))))
+ (cond
+ ;; Ideally we would test `end-of-this-message' against the result
+ ;; of `window-end', but that doesn't account for the fact that
+ ;; the end of the message might be hidden.
+ ((and visible-end-of-this-message
+ (> visible-end-of-this-message (window-end)))
+ ;; The bottom of this message is not visible - scroll.
+ (scroll-up nil))
+ ((not (= end-of-this-message (point-max)))
+ ;; This is not the last message - move to the next visible one.
+ (notmuch-show-next-open-message))
+ ((not (= (point) (point-max)))
+ ;; This is the last message, but the cursor is not at the end of
+ ;; the buffer. Move it there.
+ (goto-char (point-max)))
+ (t
+ ;; This is the last message - change the return value
+ (setq ret t)))
+ ret))
+
+(defun notmuch-show-advance-and-archive ()
+ "Advance through thread and archive.
+
+This command is intended to be one of the simplest ways to
+process a thread of email. It works exactly like
+notmuch-show-advance, in that it scrolls through messages in a
+show buffer, except that when it gets to the end of the buffer it
+archives the entire current thread, (apply changes in
+`notmuch-archive-tags'), kills the buffer, and displays the next
+thread from the search from which this thread was originally
+shown."
+ (interactive)
+ (when (notmuch-show-advance)
+ (notmuch-show-archive-thread-then-next)))
+
+(defun notmuch-show-rewind ()
+ "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
+just like `notmuch-show-previous-message'.
+
+Otherwise, just scroll down a screenful of the current message.
+
+This command does not modify any message tags, (it does not undo
+any effects from previous calls to
+`notmuch-show-advance-and-archive'."
+ (interactive)
+ (let ((start-of-message (notmuch-show-message-top))
+ (start-of-window (window-start)))
+ (cond
+ ;; Either this message is properly aligned with the start of the
+ ;; window or the start of this message is not visible on the
+ ;; screen - scroll.
+ ((or (= start-of-message start-of-window)
+ (< start-of-message start-of-window))
+ (scroll-down)
+ ;; If a small number of lines from the previous message are
+ ;; visible, realign so that the top of the current message is at
+ ;; the top of the screen.
+ (when (<= (count-screen-lines (window-start) start-of-message)
+ next-screen-context-lines)
+ (goto-char (notmuch-show-message-top))
+ (notmuch-show-message-adjust))
+ ;; Move to the top left of the window.
+ (goto-char (window-start)))
+ (t
+ ;; 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
+ (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-show-get-prop :duplicate)))
+
+(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")
+ (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-message-adjust ()
+ (recenter 0))
+
+(defun notmuch-show-next-message (&optional pop-at-end)
+ "Show the next message.
+
+If a prefix argument is given and this is the last message in the
+thread, navigate to the next thread in the parent search buffer."
+ (interactive "P")
+ (if (notmuch-show-goto-message-next)
+ (notmuch-show-message-adjust)
+ (if pop-at-end
+ (notmuch-show-next-thread)
+ (goto-char (point-max)))))
+
+(defun notmuch-show-previous-message ()
+ "Show the previous message or the start of the current message."
+ (interactive)
+ (if (= (point) (notmuch-show-message-top))
+ (notmuch-show-goto-message-previous)
+ (notmuch-show-move-to-message-top))
+ (notmuch-show-message-adjust))
+
+(defun notmuch-show-next-open-message (&optional pop-at-end)
+ "Show the next open message.
+
+If a prefix argument is given and this is the last open message
+in the thread, navigate to the next thread in the parent search
+buffer. Return t if there was a next open message in the thread
+to show, nil otherwise."
+ (interactive "P")
+ (let (r)
+ (while (and (setq r (notmuch-show-goto-message-next))
+ (not (notmuch-show-message-visible-p))))
+ (if r
+ (notmuch-show-message-adjust)
+ (if pop-at-end
+ (notmuch-show-next-thread)
+ (goto-char (point-max))))
+ r))
+
+(defun notmuch-show-next-matching-message ()
+ "Show the next matching message."
+ (interactive)
+ (let (r)
+ (while (and (setq r (notmuch-show-goto-message-next))
+ (not (notmuch-show-get-prop :match))))
+ (if r
+ (notmuch-show-message-adjust)
+ (goto-char (point-max)))))
+
+(defun notmuch-show-open-if-matched ()
+ "Open a message if it is matched (whether or not excluded)."
+ (let ((props (notmuch-show-get-message-properties)))
+ (notmuch-show-message-visible props (plist-get props :match))))
+
+(defun notmuch-show-goto-first-wanted-message ()
+ "Move to the first open message and mark it read."
+ (goto-char (point-min))
+ (unless (notmuch-show-message-visible-p)
+ (notmuch-show-next-open-message))
+ (when (eobp)
+ ;; There are no matched non-excluded messages so open all matched
+ ;; (necessarily excluded) messages and go to the first.
+ (notmuch-show-mapc 'notmuch-show-open-if-matched)
+ (force-window-update)
+ (goto-char (point-min))
+ (unless (notmuch-show-message-visible-p)
+ (notmuch-show-next-open-message))))
+
+(defun notmuch-show-previous-open-message ()
+ "Show the previous open message."
+ (interactive)
+ (while (and (if (= (point) (notmuch-show-message-top))
+ (notmuch-show-goto-message-previous)
+ (notmuch-show-move-to-message-top))
+ (not (notmuch-show-message-visible-p))))
+ (notmuch-show-message-adjust))
+
+(defun notmuch-show-view-raw-message ()
+ "View the original source of the current message."
+ (interactive)
+ (let* ((id (notmuch-show-get-message-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))
+ (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)
+ (view-buffer buf 'kill-buffer-if-not-modified)))
+
+(defun notmuch-show-resume-message ()
+ "Resume EDITING the current draft message."
+ (interactive)
+ (notmuch-draft-resume (notmuch-show-get-message-id)))
+
+(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 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-shell-command query-string))))
+ (let (shell-command)
+ (if entire-thread
+ (setq shell-command
+ (concat notmuch-command " show --format=mbox --exclude=false "
+ (shell-quote-argument
+ (mapconcat 'identity
+ (notmuch-show-get-message-ids-for-open-messages)
+ " OR "))
+ " | " command))
+ (setq shell-command
+ (concat notmuch-command " show --format=raw "
+ (shell-quote-argument (notmuch-show-get-message-id))
+ " | " command)))
+ (let ((cwd default-directory)
+ (buf (get-buffer-create (concat "*notmuch-pipe*"))))
+ (with-current-buffer buf
+ (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.
+
+TAG-CHANGES is a list of tag operations for `notmuch-tag'."
+ (let* ((current-tags (notmuch-show-get-tags))
+ (new-tags (notmuch-update-tags current-tags tag-changes)))
+ (unless (equal current-tags new-tags)
+ (notmuch-tag (notmuch-show-get-message-id) tag-changes)
+ (notmuch-show-set-tags new-tags))))
+
+(defun notmuch-show-tag (tag-changes)
+ "Change tags for the current message.
+
+See `notmuch-tag' for information on the format of TAG-CHANGES."
+ (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 (tag-changes)
+ "Change tags for all messages in the current show buffer.
+
+See `notmuch-tag' for information on the format of 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))
+ (new-tags (notmuch-update-tags current-tags tag-changes)))
+ (unless (equal current-tags new-tags)
+ (notmuch-show-set-tags new-tags))))))
+
+(defun notmuch-show-add-tag (tag-changes)
+ "Change tags for the current message (defaulting to add).
+
+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."
+ (interactive)
+ (let ((props (notmuch-show-get-message-properties)))
+ (notmuch-show-headers-visible
+ props
+ (not (plist-get props :headers-visible))))
+ (force-window-update))
+
+(defun notmuch-show-toggle-message ()
+ "Toggle the visibility of the current message."
+ (interactive)
+ (let ((props (notmuch-show-get-message-properties)))
+ (notmuch-show-message-visible
+ props
+ (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)
+ (save-excursion
+ (goto-char (point-min))
+ (cl-loop do (notmuch-show-message-visible
+ (notmuch-show-get-message-properties)
+ (not current-prefix-arg))
+ until (not (notmuch-show-goto-message-next))))
+ (force-window-update))
+
+(defun notmuch-show-next-button ()
+ "Advance point to the next button in the buffer."
+ (interactive)
+ (forward-button 1))
+
+(defun notmuch-show-previous-button ()
+ "Move point back to the previous button in the buffer."
+ (interactive)
+ (backward-button 1))
+
+(defun notmuch-show-next-thread (&optional show previous)
+ "Move to the next item in the search results, if any.
+
+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.
+
+Return non-nil on success."
+ (interactive "P")
+ (let ((parent-buffer notmuch-show-parent-buffer))
+ (notmuch-bury-or-kill-this-buffer)
+ (when (buffer-live-p parent-buffer)
+ (switch-to-buffer parent-buffer)
+ (and (if previous
+ (notmuch-search-previous-thread)
+ (notmuch-search-next-thread))
+ show
+ (notmuch-search-show-thread)))))
+
+(defun notmuch-show-next-thread-show ()
+ "Show the next thread in the search results, if any."
+ (interactive)
+ (notmuch-show-next-thread t))
+
+(defun notmuch-show-previous-thread-show ()
+ "Show the previous thread in the search results, if any."
+ (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.
+
+Archive each message currently shown by applying the tag changes
+in `notmuch-archive-tags' to each. If a prefix argument is given,
+the messages will be \"unarchived\", i.e. the tag changes in
+`notmuch-archive-tags' will be reversed.
+
+Note: This command is safe from any race condition of new messages
+being delivered to the same thread. It does not archive the
+entire thread, but only the messages shown in the current
+buffer."
+ (interactive "P")
+ (when notmuch-archive-tags
+ (notmuch-show-tag-all
+ (notmuch-tag-change-list notmuch-archive-tags unarchive))))
+
+(defun notmuch-show-archive-thread-then-next ()
+ "Archive all messages in the current buffer, then show next thread from search."
+ (interactive)
+ (notmuch-show-archive-thread)
+ (notmuch-show-next-thread t))
+
+(defun notmuch-show-archive-thread-then-exit ()
+ "Archive all messages in the current buffer, then exit back to search results."
+ (interactive)
+ (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.
+
+Archive the current message by applying the tag changes in
+`notmuch-archive-tags' to it. If a prefix argument is given, the
+message will be \"unarchived\", i.e. the tag changes in
+`notmuch-archive-tags' will be reversed."
+ (interactive "P")
+ (when notmuch-archive-tags
+ (apply 'notmuch-show-tag-message
+ (notmuch-tag-change-list notmuch-archive-tags unarchive))))
+
+(defun notmuch-show-archive-message-then-next-or-exit ()
+ "Archive current message, then show next open message in current thread.
+
+If at the last open message in the current thread, then exit back
+to search results."
+ (interactive)
+ (notmuch-show-archive-message)
+ (notmuch-show-next-open-message t))
+
+(defun notmuch-show-archive-message-then-next-or-next-thread ()
+ "Archive current message, then show next open message in current or next thread.
+
+If at the last open message in the current thread, then show next
+thread from search."
+ (interactive)
+ (notmuch-show-archive-message)
+ (unless (notmuch-show-next-open-message)
+ (notmuch-show-next-thread t)))
+
+(defun notmuch-show-stash-cc ()
+ "Copy CC field of current message to kill-ring."
+ (interactive)
+ (notmuch-common-do-stash (notmuch-show-get-cc)))
+
+(put 'notmuch-show-stash-date 'notmuch-prefix-doc
+ "Copy timestamp of current message to kill-ring.")
+(defun notmuch-show-stash-date (&optional stash-timestamp)
+ "Copy date of current message to kill-ring.
+
+If invoked with a prefix argument, copy timestamp of current
+message to kill-ring."
+ (interactive "P")
+ (if stash-timestamp
+ (notmuch-common-do-stash (format "%d" (notmuch-show-get-timestamp)))
+ (notmuch-common-do-stash (notmuch-show-get-date))))
+
+(defun notmuch-show-stash-filename ()
+ "Copy filename of current message to kill-ring."
+ (interactive)
+ (notmuch-common-do-stash (notmuch-show-get-filename)))
+
+(defun notmuch-show-stash-from ()
+ "Copy From address of current message to kill-ring."
+ (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.
+
+If invoked with a prefix argument (or STASH-THREAD-ID is
+non-nil), copy thread: query matching the current thread to
+kill-ring."
+ (interactive "P")
+ (if stash-thread-id
+ (notmuch-common-do-stash notmuch-show-thread-id)
+ (notmuch-common-do-stash (notmuch-show-get-message-id))))
+
+(defun notmuch-show-stash-message-id-stripped ()
+ "Copy message ID of current message (sans `id:' prefix) to kill-ring."
+ (interactive)
+ (notmuch-common-do-stash (notmuch-show-get-message-id t)))
+
+(defun notmuch-show-stash-subject ()
+ "Copy Subject field of current message to kill-ring."
+ (interactive)
+ (notmuch-common-do-stash (notmuch-show-get-subject)))
+
+(defun notmuch-show-stash-tags ()
+ "Copy tags of current message to kill-ring as a comma separated list."
+ (interactive)
+ (notmuch-common-do-stash (mapconcat 'identity (notmuch-show-get-tags) ",")))
+
+(defun notmuch-show-stash-to ()
+ "Copy To address of current message to kill-ring."
+ (interactive)
+ (notmuch-common-do-stash (notmuch-show-get-to)))
+
+(defun notmuch-show-stash-mlarchive-link (&optional mla)
+ "Copy an ML Archive URI for the current message to the kill-ring.
+
+This presumes that the message is available at the selected Mailing List Archive.
+
+If optional argument MLA is non-nil, use the provided key instead of prompting
+the user (see `notmuch-show-stash-mlarchive-link-alist')."
+ (interactive)
+ (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.
+
+This presumes that the message is available at the selected Mailing List Archive.
+
+If optional argument MLA is non-nil, use the provided key instead of prompting
+the user (see `notmuch-show-stash-mlarchive-link-alist')."
+ (interactive)
+ (notmuch-show-stash-mlarchive-link mla)
+ (browse-url (current-kill 0 t)))
+
+(defun notmuch-show-stash-git-helper (addresses prefix)
+ "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
+ (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.
+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.
+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>."
+ (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 (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
+ ;; 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 (&optional mime-type)
+ "Return an mm-handle for the part containing point.
+
+This creates a temporary buffer for the part's content; the
+caller is responsible for killing this buffer as appropriate. If
+MIME-TYPE is given then set the handle's mime-type to MIME-TYPE."
+ (let* ((msg (notmuch-show-get-message-properties))
+ (part (notmuch-show-get-part-properties))
+ (buf (notmuch-show-generate-part-buffer msg part))
+ (computed-type (or mime-type (plist-get part :computed-type)))
+ (filename (plist-get part :filename))
+ (disposition (and filename `(attachment (filename . ,filename)))))
+ (mm-make-handle buf (list computed-type) nil nil disposition)))
+
+(defun notmuch-show-apply-to-current-part-handle (fn &optional mime-type)
+ "Apply FN to an mm-handle for the part containing point.
+
+This ensures that the temporary buffer created for the mm-handle
+is destroyed when FN returns. If MIME-TYPE is given then force
+part to be treated as if it had that mime-type."
+ (let ((handle (notmuch-show-current-part-handle mime-type)))
+ ;; Emacs 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
+ (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)))))
+ ;; 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 ()
+ "Save the MIME part containing point to a file."
+ (interactive)
+ (notmuch-show-apply-to-current-part-handle #'mm-save-part))
+
+(defun notmuch-show-view-part ()
+ "View the MIME part containing point in an external viewer."
+ (interactive)
+ ;; Set mm-inlined-types to nil to force an external viewer
+ (let ((mm-inlined-types nil))
+ (notmuch-show-apply-to-current-part-handle #'mm-display-part)))
+
+(defun notmuch-show-interactively-view-part ()
+ "View the MIME part containing point, prompting for a viewer."
+ (interactive)
+ (notmuch-show-apply-to-current-part-handle #'mm-interactively-view-part))
+
+(defun notmuch-show-pipe-part ()
+ "Pipe the MIME part containing point to an external command."
+ (interactive)
+ (notmuch-show-apply-to-current-part-handle #'mm-pipe-part))
+
+(defun notmuch-show--mm-display-part (handle)
+ "Use mm-display-part to display HANDLE in a new buffer.
+
+If the part is displayed in an external application then close
+the new buffer."
+ (let ((buf (get-buffer-create (generate-new-buffer-name
+ (concat " *notmuch-internal-part*")))))
+ (pop-to-buffer-same-window buf)
+ (if (eq (mm-display-part handle) 'external)
+ (kill-buffer buf)
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (view-buffer buf 'kill-buffer-if-not-modified))))
+
+(defun notmuch-show-choose-mime-of-part (mime-type)
+ "Choose the mime type to use for displaying part."
+ (interactive
+ (list (completing-read "Mime type to use (default text/plain): "
+ (mailcap-mime-types) nil nil nil nil "text/plain")))
+ (notmuch-show-apply-to-current-part-handle #'notmuch-show--mm-display-part
+ mime-type))
+
+(defun notmuch-show-imenu-prev-index-position-function ()
+ "Move point to previous message in notmuch-show buffer.
+This function is used as a value for
+`imenu-prev-index-position-function'."
+ (if (bobp)
+ nil
+ (notmuch-show-previous-message)
+ t))
+
+(defun notmuch-show-imenu-extract-index-name-function ()
+ "Return imenu name for line at point.
+This function is used as a value for
+`imenu-extract-index-name-function'. Point should be at the
+beginning of the line."
+ (back-to-indentation)
+ (buffer-substring-no-properties (if notmuch-show-imenu-indent
+ (line-beginning-position)
+ (point))
+ (line-end-position)))
+
+(defmacro notmuch-show--with-currently-shown-message (&rest body)
+ "Evaluate BODY with display restricted to the currently shown
+message."
+ `(save-excursion
+ (save-restriction
+ (let ((extent (notmuch-show-message-extent)))
+ (narrow-to-region (car extent) (cdr extent))
+ ,@body))))
+
+(defun notmuch-show--gather-urls ()
+ "Gather any URLs in the current message."
+ (notmuch-show--with-currently-shown-message
+ (let (urls)
+ (goto-char (point-min))
+ (while (re-search-forward goto-address-url-regexp (point-max) t)
+ (push (match-string-no-properties 0) urls))
+ (reverse urls))))
+
+(defun notmuch-show-browse-urls (&optional kill)
+ "Offer to browse any URLs in the current message.
+With a prefix argument, copy the URL to the kill ring rather than
+browsing."
+ (interactive "P")
+ (let ((urls (notmuch-show--gather-urls))
+ (prompt (if kill "Copy URL to kill ring: " "Browse URL: "))
+ (fn (if kill #'kill-new #'browse-url)))
+ (if urls
+ (funcall fn (completing-read prompt urls nil nil nil nil (car urls)))
+ (message "No URLs found."))))
+
+;;; _
+
+(provide 'notmuch-show)
+
+;;; notmuch-show.el ends here
blob - /dev/null
blob + 959778819617f9cd23498818b2344103fb008c12 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-tag.el
+;;; notmuch-tag.el --- tag messages within emacs -*- lexical-binding: t -*-
+;;
+;; Copyright © Damien Cassou
+;; Copyright © Carl Worth
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+;; Damien Cassou <damien.cassou@gmail.com>
+
+;;; Code:
+
+(require 'crm)
+
+(require 'notmuch-lib)
+
+(declare-function notmuch-search-tag "notmuch"
+ (tag-changes &optional beg end only-matched))
+(declare-function notmuch-show-tag "notmuch-show" (tag-changes))
+(declare-function notmuch-tree-tag "notmuch-tree" (tag-changes))
+(declare-function notmuch-jump "notmuch-jump" (action-map prompt))
+
+;;; Keys
+
+(define-widget 'notmuch-tag-key-type 'list
+ "A single key tagging binding."
+ :format "%v"
+ :args '((list :inline t
+ :format "%v"
+ (key-sequence :tag "Key")
+ (radio :tag "Tag operations"
+ (repeat :tag "Tag list"
+ (string :format "%v" :tag "change"))
+ (variable :tag "Tag variable"))
+ (string :tag "Name"))))
+
+(defcustom notmuch-tagging-keys
+ `((,(kbd "a") notmuch-archive-tags "Archive")
+ (,(kbd "u") notmuch-show-mark-read-tags "Mark read")
+ (,(kbd "f") ("+flagged") "Flag")
+ (,(kbd "s") ("+spam" "-inbox") "Mark as spam")
+ (,(kbd "d") ("+deleted" "-inbox") "Delete"))
+ "A list of keys and corresponding tagging operations.
+
+For each key (or key sequence) you can specify a sequence of
+tagging operations to apply, or a variable which contains a list
+of tagging operations such as `notmuch-archive-tags'. The final
+element is a name for this tagging operation. If the name is
+omitted or empty then the list of tag changes, or the variable
+name is used as the name.
+
+The key `notmuch-tag-jump-reverse-key' (k by default) should not
+be used (either as a key, or as the start of a key sequence) as
+it is already bound: it switches the menu to a menu of the
+reverse tagging operations. The reverse of a tagging operation is
+the same list of individual tag-ops but with `+tag' replaced by
+`-tag' and vice versa.
+
+If setting this variable outside of customize then it should be a
+list of triples (lists of three elements). Each triple should be
+of the form (key-binding tagging-operations name). KEY-BINDING
+can be a single character or a key sequence; TAGGING-OPERATIONS
+should either be a list of individual tag operations each of the
+form `+tag' or `-tag', or the variable name of a variable that is
+a list of tagging operations; NAME should be a name for the
+tagging operation, if omitted or empty than then name is taken
+from TAGGING-OPERATIONS."
+ :tag "List of tagging bindings"
+ :type '(repeat notmuch-tag-key-type)
+ :group 'notmuch-tag)
+
+;;; Faces and Formats
+
+(define-widget 'notmuch-tag-format-type 'lazy
+ "Customize widget for notmuch-tag-format and friends."
+ :type '(alist :key-type (regexp :tag "Tag")
+ :extra-offset -3
+ :value-type
+ (radio :format "%v"
+ (const :tag "Hidden" nil)
+ (set :tag "Modified"
+ (string :tag "Display as")
+ (list :tag "Face" :extra-offset -4
+ (const :format "" :inline t
+ (notmuch-apply-face tag))
+ (list :format "%v"
+ (const :format "" quote)
+ custom-face-edit))
+ (list :format "%v" :extra-offset -4
+ (const :format "" :inline t
+ (notmuch-tag-format-image-data tag))
+ (choice :tag "Image"
+ (const :tag "Star"
+ (notmuch-tag-star-icon))
+ (const :tag "Empty star"
+ (notmuch-tag-star-empty-icon))
+ (const :tag "Tag"
+ (notmuch-tag-tag-icon))
+ (string :tag "Custom")))
+ (sexp :tag "Custom")))))
+
+(defface notmuch-tag-unread
+ '((t :foreground "red"))
+ "Default face used for the unread tag.
+
+Used in the default value of `notmuch-tag-formats'."
+ :group 'notmuch-faces)
+
+(defface notmuch-tag-flagged
+ '((((class color)
+ (background dark))
+ (:foreground "LightBlue1"))
+ (((class color)
+ (background light))
+ (:foreground "blue")))
+ "Face used for the flagged tag.
+
+Used in the default value of `notmuch-tag-formats'."
+ :group 'notmuch-faces)
+
+(defcustom notmuch-tag-formats
+ '(("unread" (propertize tag 'face 'notmuch-tag-unread))
+ ("flagged" (propertize tag 'face 'notmuch-tag-flagged)
+ (notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
+ "Custom formats for individual tags.
+
+This is an association list of the form ((MATCH EXPR...)...),
+mapping tag name regexps to lists of formatting expressions.
+
+The first entry whose MATCH regexp-matches a tag is used to
+format that tag. The regexp is implicitly anchored, so to match
+a literal tag name, just use that tag name (if it contains
+special regexp characters like \".\" or \"*\", these have to be
+escaped).
+
+The cdr of the matching entry gives a list of Elisp expressions
+that modify the tag. If the list is empty, the tag is simply
+hidden. Otherwise, each expression EXPR is evaluated in order:
+for the first expression, the variable `tag' is bound to the tag
+name; for each later expression, the variable `tag' is bound to
+the result of the previous expression. In this way, each
+expression can build on the formatting performed by the previous
+expression. The result of the last expression is displayed in
+place of the tag.
+
+For example, to replace a tag with another string, simply use
+that string as a formatting expression. To change the foreground
+of a tag to red, use the expression
+ (propertize tag 'face '(:foreground \"red\"))
+
+See also `notmuch-tag-format-image', which can help replace tags
+with images."
+ :group 'notmuch-search
+ :group 'notmuch-show
+ :group 'notmuch-faces
+ :type 'notmuch-tag-format-type)
+
+(defface notmuch-tag-deleted
+ '((((class color) (supports :strike-through "red")) :strike-through "red")
+ (t :inverse-video t))
+ "Face used to display deleted tags.
+
+Used in the default value of `notmuch-tag-deleted-formats'."
+ :group 'notmuch-faces)
+
+(defcustom notmuch-tag-deleted-formats
+ '(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted))
+ (".*" (notmuch-apply-face tag `notmuch-tag-deleted)))
+ "Custom formats for tags when deleted.
+
+For deleted tags the formats in `notmuch-tag-formats' are applied
+first and then these formats are applied on top; that is `tag'
+passed to the function is the tag with all these previous
+formattings applied. The formatted can access the original
+unformatted tag as `bare-tag'.
+
+By default this shows deleted tags with strike-through in red,
+unless strike-through is not available (e.g., emacs is running in
+a terminal) in which case it uses inverse video. To hide deleted
+tags completely set this to
+ '((\".*\" nil))
+
+See `notmuch-tag-formats' for full documentation."
+ :group 'notmuch-show
+ :group 'notmuch-faces
+ :type 'notmuch-tag-format-type)
+
+(defface notmuch-tag-added
+ '((t :underline "green"))
+ "Default face used for added tags.
+
+Used in the default value for `notmuch-tag-added-formats'."
+ :group 'notmuch-faces)
+
+(defcustom notmuch-tag-added-formats
+ '((".*" (notmuch-apply-face tag 'notmuch-tag-added)))
+ "Custom formats for tags when added.
+
+For added tags the formats in `notmuch-tag-formats' are applied
+first and then these formats are applied on top.
+
+To disable special formatting of added tags, set this variable to
+nil.
+
+See `notmuch-tag-formats' for full documentation."
+ :group 'notmuch-show
+ :group 'notmuch-faces
+ :type 'notmuch-tag-format-type)
+
+;;; Icons
+
+(defun notmuch-tag-format-image-data (tag data)
+ "Replace TAG with image DATA, if available.
+
+This function returns a propertized string that will display image
+DATA in place of TAG.This is designed for use in
+`notmuch-tag-formats'.
+
+DATA is the content of an SVG picture (e.g., as returned by
+`notmuch-tag-star-icon')."
+ (propertize tag 'display
+ `(image :type svg
+ :data ,data
+ :ascent center
+ :mask heuristic)))
+
+(defun notmuch-tag-star-icon ()
+ "Return SVG data representing a star icon.
+This can be used with `notmuch-tag-format-image-data'."
+ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
+<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
+ <g transform=\"translate(-242.81601,-315.59635)\">
+ <path
+ d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
+ transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
+ style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
+ </g>
+</svg>")
+
+(defun notmuch-tag-star-empty-icon ()
+ "Return SVG data representing an empty star icon.
+This can be used with `notmuch-tag-format-image-data'."
+ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
+<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
+ <g transform=\"translate(-242.81601,-315.59635)\">
+ <path
+ d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
+ transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
+ style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
+ </g>
+</svg>")
+
+(defun notmuch-tag-tag-icon ()
+ "Return SVG data representing a tag icon.
+This can be used with `notmuch-tag-format-image-data'."
+ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
+<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
+ <g transform=\"translate(0,-1036.3622)\">
+ <path
+ d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
+ style=\"fill:#ffff00;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.25;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-opacity:1\" />
+ </g>
+</svg>")
+
+;;; track history of tag operations
+(defvar-local notmuch-tag-history nil
+ "Buffer local history of `notmuch-tag' function.")
+(put 'notmuch-tag-history 'permanent-local t)
+
+;;; Format Handling
+
+(defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
+ "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.")
+
+(defun notmuch-tag-clear-cache ()
+ "Clear the internal cache of tag formats."
+ (clrhash notmuch-tag--format-cache))
+
+(defun notmuch-tag--get-formats (tag alist)
+ "Find the first item whose car regexp-matches TAG."
+ (save-match-data
+ ;; Don't use assoc-default since there's no way to distinguish a
+ ;; missing key from a present key with a null cdr.
+ (cl-assoc tag alist
+ :test (lambda (tag key)
+ (and (eq (string-match key tag) 0)
+ (= (match-end 0) (length tag)))))))
+
+(defun notmuch-tag--do-format (bare-tag tag formats)
+ "Apply a tag-formats entry to TAG."
+ (cond ((null formats) ;; - Tag not in `formats',
+ tag) ;; the format is the tag itself.
+ ((null (cdr formats)) ;; - Tag was deliberately hidden,
+ nil) ;; no format must be returned
+ (t
+ ;; Tag was found and has formats, we must apply all the
+ ;; formats. TAG may be null so treat that as a special case.
+ (let ((return-tag (copy-sequence (or tag ""))))
+ (dolist (format (cdr formats))
+ (setq return-tag
+ (eval format
+ `((bare-tag . ,bare-tag)
+ (tag . ,return-tag)))))
+ (if (and (null tag) (equal return-tag ""))
+ nil
+ return-tag)))))
+
+(defun notmuch-tag-format-tag (tags orig-tags tag)
+ "Format TAG according to `notmuch-tag-formats'.
+
+TAGS and ORIG-TAGS are lists of the current tags and the original
+tags; tags which have been deleted (i.e., are in ORIG-TAGS but
+are not in TAGS) are shown using formats from
+`notmuch-tag-deleted-formats'; tags which have been added (i.e.,
+are in TAGS but are not in ORIG-TAGS) are shown using formats
+from `notmuch-tag-added-formats' and tags which have not been
+changed (the normal case) are shown using formats from
+`notmuch-tag-formats'."
+ (let* ((tag-state (cond ((not (member tag tags)) 'deleted)
+ ((not (member tag orig-tags)) 'added)))
+ (formatted-tag (gethash (cons tag tag-state)
+ notmuch-tag--format-cache
+ 'missing)))
+ (when (eq formatted-tag 'missing)
+ (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats))
+ (over (cl-case tag-state
+ (deleted (notmuch-tag--get-formats
+ tag notmuch-tag-deleted-formats))
+ (added (notmuch-tag--get-formats
+ tag notmuch-tag-added-formats))
+ (otherwise nil))))
+ (setq formatted-tag (notmuch-tag--do-format tag tag base))
+ (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over))
+ (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
+ formatted-tag))
+
+(defun notmuch-tag-format-tags (tags orig-tags &optional face)
+ "Return a string representing formatted TAGS."
+ (let ((face (or face 'notmuch-tag-face))
+ (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<)))
+ (notmuch-apply-face
+ (mapconcat #'identity
+ ;; nil indicated that the tag was deliberately hidden
+ (delq nil (mapcar (apply-partially #'notmuch-tag-format-tag
+ tags orig-tags)
+ all-tags))
+ " ")
+ face
+ t)))
+
+;;; Hooks
+
+(defcustom notmuch-before-tag-hook nil
+ "Hooks that are run before tags of a message are modified.
+
+'tag-changes' will contain the tags that are about to be added or removed as
+a list of strings of the form \"+TAG\" or \"-TAG\".
+'query' will be a string containing the search query that determines
+the messages that are about to be tagged."
+ :type 'hook
+ :options '(notmuch-hl-line-mode)
+ :group 'notmuch-hooks)
+
+(defcustom notmuch-after-tag-hook nil
+ "Hooks that are run after tags of a message are modified.
+
+'tag-changes' will contain the tags that were added or removed as
+a list of strings of the form \"+TAG\" or \"-TAG\".
+'query' will be a string containing the search query that determines
+the messages that were tagged."
+ :type 'hook
+ :options '(notmuch-hl-line-mode)
+ :group 'notmuch-hooks)
+
+;;; User Input
+
+(defvar notmuch-select-tag-history nil
+ "Minibuffer history of `notmuch-select-tag-with-completion' function.")
+
+(defvar notmuch-read-tag-changes-history nil
+ "Minibuffer history of `notmuch-read-tag-changes' function.")
+
+(defun notmuch-tag-completions (&rest search-terms)
+ "Return a list of tags for messages matching SEARCH-TERMS.
+
+Return all tags if no search terms are given."
+ (unless search-terms
+ (setq search-terms (list "*")))
+ (split-string
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (apply 'notmuch--call-process notmuch-command nil t
+ nil "search" "--output=tags" "--exclude=false" search-terms)))
+ "\n+" t))
+
+(defun notmuch-select-tag-with-completion (prompt &rest search-terms)
+ (completing-read prompt
+ (apply #'notmuch-tag-completions search-terms)
+ nil nil nil 'notmuch-select-tag-history))
+
+(defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
+ "Prompt for tag changes in the minibuffer.
+
+CURRENT-TAGS is a list of tags that are present on the message
+or messages to be changed. These are offered as tag removal
+completions. CURRENT-TAGS may contain duplicates. PROMPT, if
+non-nil, is the query string to present in the minibuffer. It
+defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the
+initial input in the minibuffer."
+ (let* ((all-tag-list (notmuch-tag-completions))
+ (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
+ (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
+ (tag-list (append add-tag-list remove-tag-list))
+ (prompt (concat (or prompt "Tags") " (+add -drop): "))
+ (crm-separator " ")
+ ;; By default, space is bound to "complete word" function.
+ ;; Re-bind it to insert a space instead. Note that <tab>
+ ;; still does the completion.
+ (crm-local-completion-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map crm-local-completion-map)
+ (define-key map " " 'self-insert-command)
+ map)))
+ (completing-read-multiple prompt tag-list
+ nil nil initial-input
+ 'notmuch-read-tag-changes-history)))
+
+;;; Tagging
+
+(defun notmuch-update-tags (tags tag-changes)
+ "Return a copy of TAGS with additions and removals from TAG-CHANGES.
+
+TAG-CHANGES must be a list of tags names, each prefixed with
+either a \"+\" to indicate the tag should be added to TAGS if not
+present or a \"-\" to indicate that the tag should be removed
+from TAGS if present."
+ (let ((result-tags (copy-sequence tags)))
+ (dolist (tag-change tag-changes)
+ (let ((tag (and (not (string-empty-p tag-change))
+ (substring tag-change 1))))
+ (cl-case (aref tag-change 0)
+ (?+ (unless (member tag result-tags)
+ (push tag result-tags)))
+ (?- (setq result-tags (delete tag result-tags)))
+ (otherwise
+ (error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
+ (sort result-tags 'string<)))
+
+(defconst notmuch-tag-argument-limit 1000
+ "Use batch tagging if the tagging query is longer than this.
+
+This limits the length of arguments passed to the notmuch CLI to
+avoid system argument length limits and performance problems.
+
+NOTE: this variable is no longer used.")
+
+(make-obsolete-variable 'notmuch-tag-argument-limit nil "notmuch 0.36")
+
+(defun notmuch-tag (query tag-changes &optional omit-hist)
+ "Add/remove tags in TAG-CHANGES to messages matching QUERY.
+
+QUERY should be a string containing the search-terms.
+TAG-CHANGES is a list of strings of the form \"+tag\" or \"-tag\"
+to add or remove tags, respectively. OMIT-HIST disables history
+tracking if non-nil.
+
+Note: Other code should always use this function to alter tags of
+messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
+directly, so that hooks specified in notmuch-before-tag-hook and
+notmuch-after-tag-hook will be run."
+ ;; Perform some validation
+ (dolist (tag-change tag-changes)
+ (unless (string-match-p "^[-+]\\S-+$" tag-change)
+ (error "Tag must be of the form `+this_tag' or `-that_tag'")))
+ (unless query
+ (error "Nothing to tag!"))
+ (when tag-changes
+ (notmuch-dlet ((tag-changes tag-changes)
+ (query query))
+ (run-hooks 'notmuch-before-tag-hook))
+ (with-temp-buffer
+ (insert (concat (mapconcat #'notmuch-hex-encode tag-changes " ") " -- " query))
+ (unless (= 0
+ (notmuch--call-process-region
+ (point-min) (point-max) notmuch-command t t nil "tag" "--batch"))
+ (notmuch-logged-error "notmuch tag failed" (buffer-string))))
+ (unless omit-hist
+ (push (list :query query :tag-changes tag-changes) notmuch-tag-history)))
+ (notmuch-dlet ((tag-changes tag-changes)
+ (query query))
+ (run-hooks 'notmuch-after-tag-hook)))
+
+(defun notmuch-tag-undo ()
+ "Undo the previous tagging operation in the current buffer. Uses
+buffer local variable `notmuch-tag-history' to determine what
+that operation was."
+ (interactive)
+ (when (null notmuch-tag-history)
+ (error "no further notmuch undo information"))
+ (let* ((action (pop notmuch-tag-history))
+ (query (plist-get action :query))
+ (changes (notmuch-tag-change-list (plist-get action :tag-changes) t)))
+ (notmuch-tag query changes t))
+ (notmuch-refresh-this-buffer))
+
+(defun notmuch-tag-change-list (tags &optional reverse)
+ "Convert TAGS into a list of tag changes.
+
+Add a \"+\" prefix to any tag in TAGS list that doesn't already
+begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
+\"+\" prefixes with \"-\" and vice versa in the result."
+ (mapcar (lambda (str)
+ (let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
+ (if reverse
+ (concat (if (= (string-to-char s) ?-) "+" "-")
+ (substring s 1))
+ s)))
+ tags))
+
+(defvar notmuch-tag-jump-reverse-key "k"
+ "The key in tag-jump to switch to the reverse tag changes.")
+
+(defun notmuch-tag-jump (reverse)
+ "Create a jump menu for tagging operations.
+
+Creates and displays a jump menu for the tagging operations
+specified in `notmuch-tagging-keys'. If REVERSE is set then it
+offers a menu of the reverses of the operations specified in
+`notmuch-tagging-keys'; i.e. each `+tag' is replaced by `-tag'
+and vice versa."
+ ;; In principle this function is simple, but it has to deal with
+ ;; lots of cases: different modes (search/show/tree), whether a name
+ ;; is specified, whether the tagging operations is a list of
+ ;; tag-ops, or a symbol that evaluates to such a list, and whether
+ ;; REVERSE is specified.
+ (interactive "P")
+ (let (action-map)
+ (pcase-dolist (`(,key ,tag ,name) notmuch-tagging-keys)
+ (let* ((tag-function (cl-case major-mode
+ (notmuch-search-mode #'notmuch-search-tag)
+ (notmuch-show-mode #'notmuch-show-tag)
+ (notmuch-tree-mode #'notmuch-tree-tag)))
+ (tag (if (symbolp tag)
+ (symbol-value tag)
+ tag))
+ (tag-change (if reverse
+ (notmuch-tag-change-list tag t)
+ tag))
+ (name (or (and (not (string= name ""))
+ name)
+ (and (symbolp name)
+ (symbol-name name))))
+ (name-string (if name
+ (if reverse
+ (concat "Reverse " name)
+ name)
+ (mapconcat #'identity tag-change " "))))
+ (push (list key name-string
+ (lambda () (funcall tag-function tag-change)))
+ action-map)))
+ (push (list notmuch-tag-jump-reverse-key
+ (if reverse
+ "Forward tag changes "
+ "Reverse tag changes")
+ (apply-partially 'notmuch-tag-jump (not reverse)))
+ action-map)
+ (setq action-map (nreverse action-map))
+ (notmuch-jump action-map "Tag: ")))
+
+;;; _
+
+(provide 'notmuch-tag)
+
+;;; notmuch-tag.el ends here
blob - /dev/null
blob + b58fa6a66b33124c0d3775c613bd6f7ea81797ed (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-tree.el
+;;; notmuch-tree.el --- displaying notmuch forests -*- lexical-binding: t -*-
+;;
+;; Copyright © Carl Worth
+;; Copyright © David Edmondson
+;; Copyright © Mark Walters
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+;; Mark Walters <markwalters1009@gmail.com>
+
+;;; Code:
+
+(require 'mail-parse)
+
+(require 'notmuch-lib)
+(require 'notmuch-show)
+(require 'notmuch-tag)
+(require 'notmuch-parser)
+(require 'notmuch-jump)
+
+(declare-function notmuch-search "notmuch"
+ (&optional query oldest-first target-thread target-line
+ no-display))
+(declare-function notmuch-call-notmuch-process "notmuch-lib" (&rest args))
+(declare-function notmuch-read-query "notmuch" (prompt))
+(declare-function notmuch-search-find-thread-id "notmuch" (&optional bare))
+(declare-function notmuch-search-find-subject "notmuch" ())
+
+;; For `notmuch-tree-next-thread-from-search'.
+(declare-function notmuch-search-next-thread "notmuch" ())
+(declare-function notmuch-search-previous-thread "notmuch" ())
+(declare-function notmuch-tree-from-search-thread "notmuch" ())
+
+;; this variable distinguishes the unthreaded display from the normal tree display
+(defvar-local notmuch-tree-unthreaded nil
+ "A buffer local copy of argument unthreaded to the function notmuch-tree.")
+
+;;; Options
+
+(defgroup notmuch-tree nil
+ "Showing message and thread structure."
+ :group 'notmuch)
+
+(defcustom notmuch-tree-show-out nil
+ "View selected messages in new window rather than split-pane."
+ :type 'boolean
+ :group 'notmuch-tree)
+
+(defcustom notmuch-unthreaded-show-out t
+ "View selected messages in new window rather than split-pane."
+ :type 'boolean
+ :group 'notmuch-tree)
+
+(defun notmuch-tree-show-out ()
+ (if notmuch-tree-unthreaded
+ notmuch-unthreaded-show-out
+ notmuch-tree-show-out))
+
+(defcustom notmuch-tree-thread-symbols
+ '((prefix . " ")
+ (top . "─")
+ (top-tee . "┬")
+ (vertical . "│")
+ (vertical-tee . "├")
+ (bottom . "╰")
+ (arrow . "►"))
+ "Strings used to draw trees in notmuch tree results.
+Symbol keys denote where the corresponding string value is used:
+`prefix' is used at the top of the tree, followed by `top' if it
+has no children or `top-tee' if it does; `vertical' is a bar
+connecting with a response down the list skipping the current
+one, while `vertical-tee' marks the current message as a reply to
+the previous one; `bottom' is used at the bottom of threads.
+Finally, the `arrrow' string in the list is used as a pointer to
+every message.
+
+Common customizations include setting `prefix' to \"-\", to see
+equal-length prefixes, and `arrow' to an empty string or to a
+different kind of arrow point."
+ :type '(alist :key-type symbol :value-type string)
+ :group 'notmuch-tree)
+
+(defconst notmuch-tree--field-names
+ '(choice :tag "Field"
+ (const :tag "Date" "date")
+ (const :tag "Authors" "authors")
+ (const :tag "Subject" "subject")
+ (const :tag "Tree" "tree")
+ (const :tag "Tags" "tags")
+ (function)))
+
+(defcustom notmuch-tree-result-format
+ `(("date" . "%12s ")
+ ("authors" . "%-20s")
+ ((("tree" . "%s")
+ ("subject" . "%s"))
+ . " %-54s ")
+ ("tags" . "(%s)"))
+ "Result formatting for tree view.
+
+List of pairs of (field . format-string). Supported field
+strings are: \"date\", \"authors\", \"subject\", \"tree\",
+\"tags\". It is also supported to pass a function in place of a
+field-name. In this case the function is passed the thread
+object (plist) and format string.
+
+Tree means the thread tree box graphics. The field may
+also be a list in which case the formatting rules are
+applied recursively and then the output of all the fields
+in the list is inserted according to format-string.
+
+Note that the author string should not contain whitespace
+\(put it in the neighbouring fields instead)."
+
+ :type `(alist :key-type (choice ,notmuch-tree--field-names
+ (alist :key-type ,notmuch-tree--field-names
+ :value-type (string :tag "Format")))
+ :value-type (string :tag "Format"))
+ :group 'notmuch-tree)
+
+(defcustom notmuch-unthreaded-result-format
+ `(("date" . "%12s ")
+ ("authors" . "%-20s")
+ ((("subject" . "%s")) ." %-54s ")
+ ("tags" . "(%s)"))
+ "Result formatting for unthreaded tree view.
+
+List of pairs of (field . format-string). Supported field
+strings are: \"date\", \"authors\", \"subject\", \"tree\",
+\"tags\". It is also supported to pass a function in place of a
+field-name. In this case the function is passed the thread
+object (plist) and format string.
+
+Tree means the thread tree box graphics. The field may
+also be a list in which case the formatting rules are
+applied recursively and then the output of all the fields
+in the list is inserted according to format-string.
+
+Note that the author string should not contain whitespace
+\(put it in the neighbouring fields instead)."
+
+ :type `(alist :key-type (choice ,notmuch-tree--field-names
+ (alist :key-type ,notmuch-tree--field-names
+ :value-type (string :tag "Format")))
+ :value-type (string :tag "Format"))
+ :group 'notmuch-tree)
+
+(defun notmuch-tree-result-format ()
+ (if notmuch-tree-unthreaded
+ notmuch-unthreaded-result-format
+ notmuch-tree-result-format))
+
+;;; Faces
+;;;; Faces for messages that match the query
+
+(defface notmuch-tree-match-face
+ '((t :inherit default))
+ "Default face used in tree mode face for matching messages"
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-match-date-face
+ nil
+ "Face used in tree mode for the date in messages matching the query."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-match-author-face
+ '((((class color)
+ (background dark))
+ (:foreground "OliveDrab1"))
+ (((class color)
+ (background light))
+ (:foreground "dark blue"))
+ (t
+ (:bold t)))
+ "Face used in tree mode for the author in messages matching the query."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-match-subject-face
+ nil
+ "Face used in tree mode for the subject in messages matching the query."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-match-tree-face
+ nil
+ "Face used in tree mode for the thread tree block graphics in messages matching the query."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-match-tag-face
+ '((((class color)
+ (background dark))
+ (:foreground "OliveDrab1"))
+ (((class color)
+ (background light))
+ (:foreground "navy blue" :bold t))
+ (t
+ (:bold t)))
+ "Face used in tree mode for tags in messages matching the query."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+;;;; Faces for messages that do not match the query
+
+(defface notmuch-tree-no-match-face
+ '((t (:foreground "gray")))
+ "Default face used in tree mode face for non-matching messages."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-date-face
+ nil
+ "Face used in tree mode for non-matching dates."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-subject-face
+ nil
+ "Face used in tree mode for non-matching subjects."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-tree-face
+ nil
+ "Face used in tree mode for the thread tree block graphics in messages matching the query."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-author-face
+ nil
+ "Face used in tree mode for non-matching authors."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+(defface notmuch-tree-no-match-tag-face
+ nil
+ "Face used in tree mode face for non-matching tags."
+ :group 'notmuch-tree
+ :group 'notmuch-faces)
+
+;;; Variables
+
+(defvar-local notmuch-tree-previous-subject
+ "The subject of the most recent result shown during the async display.")
+
+(defvar-local notmuch-tree-basic-query nil
+ "A buffer local copy of argument query to the function notmuch-tree.")
+
+(defvar-local notmuch-tree-query-context nil
+ "A buffer local copy of argument query-context to the function notmuch-tree.")
+
+(defvar-local notmuch-tree-target-msg nil
+ "A buffer local copy of argument target to the function notmuch-tree.")
+
+(defvar-local notmuch-tree-open-target nil
+ "A buffer local copy of argument open-target to the function notmuch-tree.")
+
+(defvar-local notmuch-tree-parent-buffer nil)
+
+(defvar-local notmuch-tree-message-window nil
+ "The window of the message pane.
+
+It is set in both the tree buffer and the child show buffer. It
+is used to try and close the message pane when quitting tree view
+or the child show buffer.")
+(put 'notmuch-tree-message-window 'permanent-local t)
+
+(defvar-local notmuch-tree-message-buffer nil
+ "The buffer name of the show buffer in the message pane.
+
+This is used to try and make sure we don't close the message pane
+if the user has loaded a different buffer in that window.")
+(put 'notmuch-tree-message-buffer 'permanent-local t)
+
+;;; Tree wrapper commands
+
+(defmacro notmuch-tree--define-do-in-message-window (name cmd)
+ "Define NAME as a command that calls CMD interactively in the message window.
+If the message pane is closed then this command does nothing.
+Avoid using this macro in new code; it will be removed."
+ `(defun ,name ()
+ ,(concat "(In message window) " (documentation cmd t))
+ (interactive)
+ (when (window-live-p notmuch-tree-message-window)
+ (with-selected-window notmuch-tree-message-window
+ (call-interactively #',cmd)))))
+
+(notmuch-tree--define-do-in-message-window
+ notmuch-tree-previous-message-button
+ notmuch-show-previous-button)
+(notmuch-tree--define-do-in-message-window
+ notmuch-tree-next-message-button
+ notmuch-show-next-button)
+(notmuch-tree--define-do-in-message-window
+ notmuch-tree-toggle-message-process-crypto
+ notmuch-show-toggle-process-crypto)
+
+(defun notmuch-tree--message-process-crypto ()
+ "Return value of `notmuch-show-process-crypto' in the message window.
+If that window isn't alive, then return the current value.
+Avoid using this function in new code; it will be removed."
+ (if (window-live-p notmuch-tree-message-window)
+ (with-selected-window notmuch-tree-message-window
+ notmuch-show-process-crypto)
+ notmuch-show-process-crypto))
+
+(defmacro notmuch-tree--define-close-message-window-and (name cmd)
+ "Define NAME as a variant of CMD.
+
+NAME determines the value of `notmuch-show-process-crypto' in the
+message window, closes the window, and then call CMD interactively
+with that value let-bound. If the message window does not exist,
+then NAME behaves like CMD."
+ `(defun ,name ()
+ ,(concat "(Close message pane and) " (documentation cmd t))
+ (interactive)
+ (let ((notmuch-show-process-crypto
+ (notmuch-tree--message-process-crypto)))
+ (notmuch-tree-close-message-window)
+ (call-interactively #',cmd))))
+
+(notmuch-tree--define-close-message-window-and
+ notmuch-tree-help
+ notmuch-help)
+(notmuch-tree--define-close-message-window-and
+ notmuch-tree-new-mail
+ notmuch-mua-new-mail)
+(notmuch-tree--define-close-message-window-and
+ notmuch-tree-jump-search
+ notmuch-jump-search)
+(notmuch-tree--define-close-message-window-and
+ notmuch-tree-forward-message
+ notmuch-show-forward-message)
+(notmuch-tree--define-close-message-window-and
+ notmuch-tree-reply-sender
+ notmuch-show-reply-sender)
+(notmuch-tree--define-close-message-window-and
+ notmuch-tree-reply
+ notmuch-show-reply)
+(notmuch-tree--define-close-message-window-and
+ notmuch-tree-view-raw-message
+ notmuch-show-view-raw-message)
+
+;;; Keymap
+
+(defvar notmuch-tree-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map notmuch-common-keymap)
+ ;; These bindings shadow common bindings with variants
+ ;; that additionally close the message window.
+ (define-key map [remap notmuch-bury-or-kill-this-buffer] 'notmuch-tree-quit)
+ (define-key map [remap notmuch-search] 'notmuch-tree-to-search)
+ (define-key map [remap notmuch-help] 'notmuch-tree-help)
+ (define-key map [remap notmuch-mua-new-mail] 'notmuch-tree-new-mail)
+ (define-key map [remap notmuch-jump-search] 'notmuch-tree-jump-search)
+
+ (define-key map "o" 'notmuch-tree-toggle-order)
+ (define-key map "S" 'notmuch-search-from-tree-current-query)
+ (define-key map "U" 'notmuch-unthreaded-from-tree-current-query)
+ (define-key map "Z" 'notmuch-tree-from-unthreaded-current-query)
+
+ ;; these use notmuch-show functions directly
+ (define-key map "|" 'notmuch-show-pipe-message)
+ (define-key map "w" 'notmuch-show-save-attachments)
+ (define-key map "v" 'notmuch-show-view-all-mime-parts)
+ (define-key map "c" 'notmuch-show-stash-map)
+ (define-key map "b" 'notmuch-show-resend-message)
+
+ ;; these apply to the message pane
+ (define-key map (kbd "M-TAB") 'notmuch-tree-previous-message-button)
+ (define-key map (kbd "<backtab>") 'notmuch-tree-previous-message-button)
+ (define-key map (kbd "TAB") 'notmuch-tree-next-message-button)
+ (define-key map "$" 'notmuch-tree-toggle-message-process-crypto)
+
+ ;; bindings from show (or elsewhere) but we close the message pane first.
+ (define-key map "f" 'notmuch-tree-forward-message)
+ (define-key map "r" 'notmuch-tree-reply-sender)
+ (define-key map "R" 'notmuch-tree-reply)
+ (define-key map "V" 'notmuch-tree-view-raw-message)
+ (define-key map "l" 'notmuch-tree-filter)
+ (define-key map "t" 'notmuch-tree-filter-by-tag)
+ (define-key map "E" 'notmuch-tree-edit-search)
+
+ ;; The main tree view bindings
+ (define-key map (kbd "RET") 'notmuch-tree-show-message)
+ (define-key map [mouse-1] 'notmuch-tree-show-message)
+ (define-key map "x" 'notmuch-tree-archive-message-then-next-or-exit)
+ (define-key map "X" 'notmuch-tree-archive-thread-then-exit)
+ (define-key map "A" 'notmuch-tree-archive-thread-then-next)
+ (define-key map "a" 'notmuch-tree-archive-message-then-next)
+ (define-key map "z" 'notmuch-tree-to-tree)
+ (define-key map "n" 'notmuch-tree-next-matching-message)
+ (define-key map "p" 'notmuch-tree-prev-matching-message)
+ (define-key map "N" 'notmuch-tree-next-message)
+ (define-key map "P" 'notmuch-tree-prev-message)
+ (define-key map (kbd "M-p") 'notmuch-tree-prev-thread)
+ (define-key map (kbd "M-n") 'notmuch-tree-next-thread)
+ (define-key map "k" 'notmuch-tag-jump)
+ (define-key map "-" 'notmuch-tree-remove-tag)
+ (define-key map "+" 'notmuch-tree-add-tag)
+ (define-key map "*" 'notmuch-tree-tag-thread)
+ (define-key map " " 'notmuch-tree-scroll-or-next)
+ (define-key map (kbd "DEL") 'notmuch-tree-scroll-message-window-back)
+ (define-key map "e" 'notmuch-tree-resume-message)
+ map)
+ "Keymap for \"notmuch tree\" buffers.")
+
+;;; Message properties
+
+(defun notmuch-tree-get-message-properties ()
+ "Return the properties of the current message as a plist.
+
+Some useful entries are:
+:headers - Property list containing the headers :Date, :Subject, :From, etc.
+:tags - Tags for this message."
+ (save-excursion
+ (beginning-of-line)
+ (get-text-property (point) :notmuch-message-properties)))
+
+(defun notmuch-tree-set-message-properties (props)
+ (save-excursion
+ (beginning-of-line)
+ (put-text-property (point)
+ (+ (point) 1)
+ :notmuch-message-properties props)))
+
+(defun notmuch-tree-set-prop (prop val &optional props)
+ (let ((inhibit-read-only t)
+ (props (or props
+ (notmuch-tree-get-message-properties))))
+ (plist-put props prop val)
+ (notmuch-tree-set-message-properties props)))
+
+(defun notmuch-tree-get-prop (prop &optional props)
+ (plist-get (or props (notmuch-tree-get-message-properties))
+ prop))
+
+(defun notmuch-tree-set-tags (tags)
+ "Set the tags of the current message."
+ (notmuch-tree-set-prop :tags tags))
+
+(defun notmuch-tree-get-tags ()
+ "Return the tags of the current message."
+ (notmuch-tree-get-prop :tags))
+
+(defun notmuch-tree-get-message-id (&optional bare)
+ "Return the message id of the current message."
+ (let ((id (notmuch-tree-get-prop :id)))
+ (if id
+ (if bare
+ id
+ (notmuch-id-to-query id))
+ nil)))
+
+(defun notmuch-tree-get-match ()
+ "Return whether the current message is a match."
+ (notmuch-tree-get-prop :match))
+
+;;; Update display
+
+(defun notmuch-tree-refresh-result ()
+ "Redisplay the current message line.
+
+This redisplays the current line based on the messages
+properties (as they are now). This is used when tags are
+updated."
+ (let ((init-point (point))
+ (end (line-end-position))
+ (msg (notmuch-tree-get-message-properties))
+ (inhibit-read-only t))
+ (beginning-of-line)
+ ;; This is a little tricky: we override
+ ;; notmuch-tree-previous-subject to get the decision between
+ ;; ... and a subject right and it stops notmuch-tree-insert-msg
+ ;; from overwriting the buffer local copy of
+ ;; notmuch-tree-previous-subject if this is called while the
+ ;; buffer is displaying.
+ (let ((notmuch-tree-previous-subject
+ (notmuch-tree-get-prop :previous-subject)))
+ (delete-region (point) (1+ (line-end-position)))
+ (notmuch-tree-insert-msg msg))
+ (let ((new-end (line-end-position)))
+ (goto-char (if (= init-point end)
+ new-end
+ (min init-point (- new-end 1)))))))
+
+(defun notmuch-tree-tag-update-display (&optional tag-changes)
+ "Update display for TAG-CHANGES to current message.
+
+Updates the message in the message pane if appropriate, but does
+NOT change the database."
+ (let* ((current-tags (notmuch-tree-get-tags))
+ (new-tags (notmuch-update-tags current-tags tag-changes))
+ (tree-msg-id (notmuch-tree-get-message-id)))
+ (unless (equal current-tags new-tags)
+ (notmuch-tree-set-tags new-tags)
+ (notmuch-tree-refresh-result)
+ (when (window-live-p notmuch-tree-message-window)
+ (with-selected-window notmuch-tree-message-window
+ (when (string= tree-msg-id (notmuch-show-get-message-id))
+ (notmuch-show-update-tags new-tags)))))))
+
+;;; Commands (and some helper functions used by them)
+
+(defun notmuch-tree-tag (tag-changes)
+ "Change tags for the current message."
+ (interactive
+ (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message")))
+ (notmuch-tag (notmuch-tree-get-message-id) tag-changes)
+ (notmuch-tree-tag-update-display tag-changes))
+
+(defun notmuch-tree-add-tag (tag-changes)
+ "Same as `notmuch-tree-tag' but sets initial input to '+'."
+ (interactive
+ (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "+")))
+ (notmuch-tree-tag tag-changes))
+
+(defun notmuch-tree-remove-tag (tag-changes)
+ "Same as `notmuch-tree-tag' but sets initial input to '-'."
+ (interactive
+ (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "-")))
+ (notmuch-tree-tag tag-changes))
+
+(defun notmuch-tree-resume-message ()
+ "Resume EDITING the current draft message."
+ (interactive)
+ (notmuch-tree-close-message-window)
+ (let ((id (notmuch-tree-get-message-id)))
+ (if id
+ (notmuch-draft-resume id)
+ (message "No message to resume!"))))
+
+;; The next two functions close the message window before calling
+;; notmuch-search or notmuch-tree but they do so after the user has
+;; entered the query (in case the user was basing the query on
+;; something in the message window).
+
+(defun notmuch-tree-to-search ()
+ "Run \"notmuch search\" with the given `query' and display results."
+ (interactive)
+ (let ((query (notmuch-read-query "Notmuch search: ")))
+ (notmuch-tree-close-message-window)
+ (notmuch-search query)))
+
+(defun notmuch-tree-to-tree ()
+ "Run a query and display results in tree view."
+ (interactive)
+ (let ((query (notmuch-read-query "Notmuch tree view search: ")))
+ (notmuch-tree-close-message-window)
+ (notmuch-tree query)))
+
+(defun notmuch-tree-archive-thread-then-next ()
+ "Archive all messages in the current buffer, then show next thread from search."
+ (interactive)
+ (notmuch-tree-archive-thread)
+ (notmuch-tree-next-thread))
+
+(defun notmuch-unthreaded-from-tree-current-query ()
+ "Switch from tree view to unthreaded view."
+ (interactive)
+ (unless notmuch-tree-unthreaded
+ (notmuch-tree-refresh-view 'unthreaded)))
+
+(defun notmuch-tree-from-unthreaded-current-query ()
+ "Switch from unthreaded view to tree view."
+ (interactive)
+ (when notmuch-tree-unthreaded
+ (notmuch-tree-refresh-view 'tree)))
+
+(defun notmuch-search-from-tree-current-query ()
+ "Call notmuch search with the current query."
+ (interactive)
+ (notmuch-tree-close-message-window)
+ (notmuch-search (notmuch-tree-get-query)))
+
+(defun notmuch-tree-message-window-kill-hook ()
+ "Close the message pane when exiting the show buffer."
+ (let ((buffer (current-buffer)))
+ (when (and (window-live-p notmuch-tree-message-window)
+ (eq (window-buffer notmuch-tree-message-window) buffer))
+ ;; We could check whether this is the only window in its frame,
+ ;; but simply ignoring the error that is thrown otherwise is
+ ;; what we had to do for Emacs 24 and we stick to that because
+ ;; it is still the simplest approach.
+ (ignore-errors
+ (delete-window notmuch-tree-message-window)))))
+
+(defun notmuch-tree-command-hook ()
+ (when (eq major-mode 'notmuch-tree-mode)
+ ;; We just run the notmuch-show-command-hook on the message pane.
+ (when (buffer-live-p notmuch-tree-message-buffer)
+ (with-current-buffer notmuch-tree-message-buffer
+ (notmuch-show-command-hook)))))
+
+(defun notmuch-tree-show-message-in ()
+ "Show the current message (in split-pane)."
+ (interactive)
+ (let ((id (notmuch-tree-get-message-id))
+ (inhibit-read-only t)
+ buffer)
+ (when id
+ ;; We close and reopen the window to kill off un-needed buffers
+ ;; this might cause flickering but seems ok.
+ (notmuch-tree-close-message-window)
+ (setq notmuch-tree-message-window
+ (split-window-vertically (/ (window-height) 4)))
+ (with-selected-window notmuch-tree-message-window
+ (let (;; Since we are only displaying one message do not indent.
+ (notmuch-show-indent-messages-width 0)
+ (notmuch-show-single-message t)
+ ;; Ensure that `pop-to-buffer-same-window' uses the
+ ;; window we want it to use.
+ (display-buffer-overriding-action
+ '((display-buffer-same-window)
+ (inhibit-same-window . nil))))
+ (setq buffer (notmuch-show id))))
+ ;; We need the `let' as notmuch-tree-message-window is buffer local.
+ (let ((window notmuch-tree-message-window))
+ (with-current-buffer buffer
+ (setq notmuch-tree-message-window window)
+ (add-hook 'kill-buffer-hook 'notmuch-tree-message-window-kill-hook)))
+ (when notmuch-show-mark-read-tags
+ (notmuch-tree-tag-update-display notmuch-show-mark-read-tags))
+ (setq notmuch-tree-message-buffer buffer))))
+
+(defun notmuch-tree-show-message-out ()
+ "Show the current message (in whole window)."
+ (interactive)
+ (let ((id (notmuch-tree-get-message-id))
+ (inhibit-read-only t))
+ (when id
+ ;; We close the window to kill off un-needed buffers.
+ (notmuch-tree-close-message-window)
+ ;; n-s-s-m is buffer local, so use inner let.
+ (let ((notmuch-show-single-message t))
+ (notmuch-show id)))))
+
+(defun notmuch-tree-show-message (arg)
+ "Show the current message.
+
+Shows in split pane or whole window according to value of
+`notmuch-tree-show-out'. A prefix argument reverses the choice."
+ (interactive "P")
+ (if (or (and (notmuch-tree-show-out) (not arg))
+ (and (not (notmuch-tree-show-out)) arg))
+ (notmuch-tree-show-message-out)
+ (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-scroll-message-window ()
+ "Scroll the message window (if it exists)."
+ (interactive)
+ (when (window-live-p notmuch-tree-message-window)
+ (with-selected-window notmuch-tree-message-window
+ (if (pos-visible-in-window-p (point-max))
+ t
+ (scroll-up)))))
+
+(defun notmuch-tree-scroll-message-window-back ()
+ "Scroll the message window back (if it exists)."
+ (interactive)
+ (when (window-live-p notmuch-tree-message-window)
+ (with-selected-window notmuch-tree-message-window
+ (if (pos-visible-in-window-p (point-min))
+ t
+ (scroll-down)))))
+
+(defun notmuch-tree-scroll-or-next ()
+ "Scroll the message window.
+If it at end go to next message."
+ (interactive)
+ (when (notmuch-tree-scroll-message-window)
+ (notmuch-tree-next-matching-message)))
+
+(defun notmuch-tree-quit (&optional kill-both)
+ "Close the split view or exit tree."
+ (interactive "P")
+ (when (or (not (notmuch-tree-close-message-window)) kill-both)
+ (kill-buffer (current-buffer))))
+
+(defun notmuch-tree-close-message-window ()
+ "Close the message-window. Return t if close succeeds."
+ (interactive)
+ (when (and (window-live-p notmuch-tree-message-window)
+ (eq (window-buffer notmuch-tree-message-window)
+ notmuch-tree-message-buffer))
+ (delete-window notmuch-tree-message-window)
+ (unless (get-buffer-window-list notmuch-tree-message-buffer)
+ (kill-buffer notmuch-tree-message-buffer))
+ t))
+
+(defun notmuch-tree-archive-message (&optional unarchive)
+ "Archive the current message.
+
+Archive the current message by applying the tag changes in
+`notmuch-archive-tags' to it. If a prefix argument is given, the
+message will be \"unarchived\", i.e. the tag changes in
+`notmuch-archive-tags' will be reversed."
+ (interactive "P")
+ (when notmuch-archive-tags
+ (notmuch-tree-tag
+ (notmuch-tag-change-list notmuch-archive-tags unarchive))))
+
+(defun notmuch-tree-archive-message-then-next (&optional unarchive)
+ "Archive the current message and move to next matching message."
+ (interactive "P")
+ (notmuch-tree-archive-message unarchive)
+ (notmuch-tree-next-matching-message))
+
+(defun notmuch-tree-archive-thread-then-exit ()
+ "Archive all messages in the current buffer, then exit notmuch-tree."
+ (interactive)
+ (notmuch-tree-archive-thread)
+ (notmuch-tree-quit t))
+
+(defun notmuch-tree-archive-message-then-next-or-exit ()
+ "Archive current message, then show next open message in current thread.
+
+If at the last open message in the current thread, then exit back
+to search results."
+ (interactive)
+ (notmuch-tree-archive-message)
+ (notmuch-tree-next-matching-message t))
+
+(defun notmuch-tree-next-message ()
+ "Move to next message."
+ (interactive)
+ (forward-line)
+ (when (window-live-p notmuch-tree-message-window)
+ (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-prev-message ()
+ "Move to previous message."
+ (interactive)
+ (forward-line -1)
+ (when (window-live-p notmuch-tree-message-window)
+ (notmuch-tree-show-message-in)))
+
+(defun notmuch-tree-goto-matching-message (&optional prev)
+ "Move to the next or previous matching message.
+
+Returns t if there was a next matching message in the thread to show,
+nil otherwise."
+ (let ((dir (if prev -1 nil))
+ (eobfn (if prev #'bobp #'eobp)))
+ (while (and (not (funcall eobfn))
+ (not (notmuch-tree-get-match)))
+ (forward-line dir))
+ (not (funcall eobfn))))
+
+(defun notmuch-tree-matching-message (&optional prev pop-at-end)
+ "Move to the next or previous matching message."
+ (interactive "P")
+ (forward-line (if prev -1 nil))
+ (if (and (not (notmuch-tree-goto-matching-message prev)) pop-at-end)
+ (notmuch-tree-quit pop-at-end)
+ (when (window-live-p notmuch-tree-message-window)
+ (notmuch-tree-show-message-in))))
+
+(defun notmuch-tree-prev-matching-message (&optional pop-at-end)
+ "Move to previous matching message."
+ (interactive "P")
+ (notmuch-tree-matching-message t pop-at-end))
+
+(defun notmuch-tree-next-matching-message (&optional pop-at-end)
+ "Move to next matching message."
+ (interactive "P")
+ (notmuch-tree-matching-message nil pop-at-end))
+
+(defun notmuch-tree-refresh-view (&optional view)
+ "Refresh view."
+ (interactive)
+ (when (get-buffer-process (current-buffer))
+ (error "notmuch tree process already running for current buffer"))
+ (let ((inhibit-read-only t)
+ (basic-query notmuch-tree-basic-query)
+ (unthreaded (cond ((eq view 'unthreaded) t)
+ ((eq view 'tree) nil)
+ (t notmuch-tree-unthreaded)))
+ (query-context notmuch-tree-query-context)
+ (target (notmuch-tree-get-message-id)))
+ (erase-buffer)
+ (notmuch-tree-worker basic-query
+ query-context
+ target
+ nil
+ unthreaded
+ notmuch-search-oldest-first)))
+
+(defun notmuch-tree-thread-top ()
+ (when (notmuch-tree-get-message-properties)
+ (while (not (or (notmuch-tree-get-prop :first) (eobp)))
+ (forward-line -1))))
+
+(defun notmuch-tree-prev-thread-in-tree ()
+ "Move to the previous thread in the current tree"
+ (interactive)
+ (forward-line -1)
+ (notmuch-tree-thread-top)
+ (not (bobp)))
+
+(defun notmuch-tree-next-thread-in-tree ()
+ "Get the next thread in the current tree. Returns t if a thread was
+found or nil if not."
+ (interactive)
+ (forward-line 1)
+ (while (not (or (notmuch-tree-get-prop :first) (eobp)))
+ (forward-line 1))
+ (not (eobp)))
+
+(defun notmuch-tree-next-thread-from-search (&optional previous)
+ "Move to the next thread in the parent search results, if any.
+
+If PREVIOUS is non-nil, move to the previous item in the
+search results instead."
+ (interactive "P")
+ (let ((parent-buffer notmuch-tree-parent-buffer))
+ (notmuch-tree-quit t)
+ (when (buffer-live-p parent-buffer)
+ (switch-to-buffer parent-buffer)
+ (if previous
+ (notmuch-search-previous-thread)
+ (notmuch-search-next-thread))
+ (notmuch-tree-from-search-thread))))
+
+(defun notmuch-tree-next-thread (&optional previous)
+ "Move to the next thread in the current tree or parent search results.
+
+If PREVIOUS is non-nil, move to the previous thread in the tree or
+search results instead."
+ (interactive)
+ (unless (if previous (notmuch-tree-prev-thread-in-tree)
+ (notmuch-tree-next-thread-in-tree))
+ (notmuch-tree-next-thread-from-search previous)))
+
+(defun notmuch-tree-prev-thread ()
+ "Move to the previous thread in the current tree or parent search results."
+ (interactive)
+ (notmuch-tree-next-thread t))
+
+(defun notmuch-tree-thread-mapcar (function)
+ "Call FUNCTION for each message in the current thread.
+FUNCTION is called for side effects only."
+ (save-excursion
+ (notmuch-tree-thread-top)
+ (cl-loop collect (funcall function)
+ do (forward-line)
+ while (and (notmuch-tree-get-message-properties)
+ (not (notmuch-tree-get-prop :first))))))
+
+(defun notmuch-tree-get-messages-ids-thread-search ()
+ "Return a search string for all message ids of messages in the current thread."
+ (mapconcat 'identity
+ (notmuch-tree-thread-mapcar 'notmuch-tree-get-message-id)
+ " or "))
+
+(defun notmuch-tree-tag-thread (tag-changes)
+ "Tag all messages in the current thread."
+ (interactive
+ (let ((tags (apply #'append (notmuch-tree-thread-mapcar
+ (lambda () (notmuch-tree-get-tags))))))
+ (list (notmuch-read-tag-changes tags "Tag thread"))))
+ (when (notmuch-tree-get-message-properties)
+ (notmuch-tag (notmuch-tree-get-messages-ids-thread-search) tag-changes)
+ (notmuch-tree-thread-mapcar
+ (lambda () (notmuch-tree-tag-update-display tag-changes)))))
+
+(defun notmuch-tree-archive-thread (&optional unarchive)
+ "Archive each message in thread.
+
+Archive each message currently shown by applying the tag changes
+in `notmuch-archive-tags' to each. If a prefix argument is given,
+the messages will be \"unarchived\", i.e. the tag changes in
+`notmuch-archive-tags' will be reversed.
+
+Note: This command is safe from any race condition of new messages
+being delivered to the same thread. It does not archive the
+entire thread, but only the messages shown in the current
+buffer."
+ (interactive "P")
+ (when notmuch-archive-tags
+ (notmuch-tree-tag-thread
+ (notmuch-tag-change-list notmuch-archive-tags unarchive))))
+
+;;; Functions for displaying the tree buffer itself
+
+(defun notmuch-tree-clean-address (address)
+ "Try to clean a single email ADDRESS for display. Return
+AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return
+unchanged ADDRESS if parsing fails."
+ (let* ((clean-address (notmuch-clean-address address))
+ (p-address (car clean-address))
+ (p-name (cdr clean-address)))
+
+ ;; If we have a name return that otherwise return the address.
+ (or p-name p-address)))
+
+(defun notmuch-tree-format-field (field format-string msg)
+ "Format a FIELD of MSG according to FORMAT-STRING and return string."
+ (let* ((headers (plist-get msg :headers))
+ (match (plist-get msg :match)))
+ (cond
+ ((listp field)
+ (format format-string (notmuch-tree-format-field-list field msg)))
+
+ ((functionp field)
+ (funcall field format-string msg))
+
+ ((string-equal field "date")
+ (let ((face (if match
+ 'notmuch-tree-match-date-face
+ 'notmuch-tree-no-match-date-face)))
+ (propertize (format format-string (plist-get msg :date_relative))
+ 'face face)))
+
+ ((string-equal field "tree")
+ (let ((tree-status (plist-get msg :tree-status))
+ (face (if match
+ 'notmuch-tree-match-tree-face
+ 'notmuch-tree-no-match-tree-face)))
+
+ (propertize (format format-string
+ (mapconcat #'identity (reverse tree-status) ""))
+ 'face face)))
+
+ ((string-equal field "subject")
+ (let ((bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))
+ (previous-subject notmuch-tree-previous-subject)
+ (face (if match
+ 'notmuch-tree-match-subject-face
+ 'notmuch-tree-no-match-subject-face)))
+
+ (setq notmuch-tree-previous-subject bare-subject)
+ (propertize (format format-string
+ (if (string= previous-subject bare-subject)
+ " ..."
+ bare-subject))
+ 'face face)))
+
+ ((string-equal field "authors")
+ (let ((author (notmuch-tree-clean-address (plist-get headers :From)))
+ (len (length (format format-string "")))
+ (face (if match
+ 'notmuch-tree-match-author-face
+ 'notmuch-tree-no-match-author-face)))
+ (when (> (length author) len)
+ (setq author (substring author 0 len)))
+ (propertize (format format-string author) 'face face)))
+
+ ((string-equal field "tags")
+ (let ((tags (plist-get msg :tags))
+ (orig-tags (plist-get msg :orig-tags))
+ (face (if match
+ 'notmuch-tree-match-tag-face
+ 'notmuch-tree-no-match-tag-face)))
+ (format format-string (notmuch-tag-format-tags tags orig-tags face)))))))
+
+(defun notmuch-tree-format-field-list (field-list msg)
+ "Format fields of MSG according to FIELD-LIST and return string."
+ (let ((face (if (plist-get msg :match)
+ 'notmuch-tree-match-face
+ 'notmuch-tree-no-match-face))
+ (result-string))
+ (dolist (spec field-list result-string)
+ (let ((field-string (notmuch-tree-format-field (car spec) (cdr spec) msg)))
+ (setq result-string (concat result-string field-string))))
+ (notmuch-apply-face result-string face t)))
+
+(defun notmuch-tree-insert-msg (msg)
+ "Insert the message MSG according to notmuch-tree-result-format."
+ ;; We need to save the previous subject as it will get overwritten
+ ;; by the insert-field calls.
+ (let ((previous-subject notmuch-tree-previous-subject))
+ (insert (notmuch-tree-format-field-list (notmuch-tree-result-format) msg))
+ (notmuch-tree-set-message-properties msg)
+ (notmuch-tree-set-prop :previous-subject previous-subject)
+ (insert "\n")))
+
+(defun notmuch-tree-goto-and-insert-msg (msg)
+ "Insert msg at the end of the buffer. Move point to msg if it is the target."
+ (save-excursion
+ (goto-char (point-max))
+ (notmuch-tree-insert-msg msg))
+ (let ((msg-id (notmuch-id-to-query (plist-get msg :id)))
+ (target notmuch-tree-target-msg))
+ (when (or (and (not target) (plist-get msg :match))
+ (string= msg-id target))
+ (setq notmuch-tree-target-msg "found")
+ (goto-char (point-max))
+ (forward-line -1)
+ (when notmuch-tree-open-target
+ (notmuch-tree-show-message-in)
+ (notmuch-tree-command-hook)))))
+
+(defun notmuch-tree-insert-tree (tree depth tree-status first last)
+ "Insert the message tree TREE at depth DEPTH in the current thread.
+
+A message tree is another name for a single sub-thread: i.e., a
+message together with all its descendents."
+ (let ((msg (car tree))
+ (replies (cadr tree))
+ ;; outline level, computed from the message's depth and
+ ;; whether or not it's the first message in the tree.
+ (level (1+ (if (and (eq 0 depth) (not first)) 1 depth))))
+ (cond
+ ((and (< 0 depth) (not last))
+ (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status))
+ ((and (< 0 depth) last)
+ (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status))
+ ((and (eq 0 depth) first last)
+ (push (alist-get 'prefix notmuch-tree-thread-symbols) tree-status))
+ ((and (eq 0 depth) first (not last))
+ (push (alist-get 'top-tee notmuch-tree-thread-symbols) tree-status))
+ ((and (eq 0 depth) (not first) last)
+ (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status))
+ ((and (eq 0 depth) (not first) (not last))
+ (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status)))
+ (push (concat (alist-get (if replies 'top-tee 'top) notmuch-tree-thread-symbols)
+ (alist-get 'arrow notmuch-tree-thread-symbols))
+ tree-status)
+ (setq msg (plist-put msg :first (and first (eq 0 depth))))
+ (setq msg (plist-put msg :tree-status tree-status))
+ (setq msg (plist-put msg :orig-tags (plist-get msg :tags)))
+ (setq msg (plist-put msg :level level))
+ (notmuch-tree-goto-and-insert-msg msg)
+ (pop tree-status)
+ (pop tree-status)
+ (if last
+ (push " " tree-status)
+ (push (alist-get 'vertical notmuch-tree-thread-symbols) tree-status))
+ (notmuch-tree-insert-thread replies (1+ depth) tree-status)))
+
+(defun notmuch-tree-insert-thread (thread depth tree-status)
+ "Insert the collection of sibling sub-threads THREAD at depth DEPTH in the current forest."
+ (let ((n (length thread)))
+ (cl-loop for tree in thread
+ for count from 1 to n
+ do (notmuch-tree-insert-tree tree depth tree-status
+ (eq count 1)
+ (eq count n)))))
+
+(defun notmuch-tree-insert-forest-thread (forest-thread)
+ "Insert a single complete thread."
+ ;; Reset at the start of each main thread.
+ (setq notmuch-tree-previous-subject nil)
+ (notmuch-tree-insert-thread forest-thread 0 nil))
+
+(defun notmuch-tree-insert-forest (forest)
+ "Insert a forest of threads.
+
+This function inserts a collection of several complete threads as
+passed to it by notmuch-tree-process-filter."
+ (mapc 'notmuch-tree-insert-forest-thread forest))
+
+(define-derived-mode notmuch-tree-mode fundamental-mode "notmuch-tree"
+ "Major mode displaying messages (as opposed to threads) of a notmuch search.
+
+This buffer contains the results of a \"notmuch tree\" of your
+email archives. Each line in the buffer represents a single
+message giving the relative date, the author, subject, and any
+tags.
+
+Pressing \\[notmuch-tree-show-message] on any line displays that message.
+
+Complete list of currently available key bindings:
+
+\\{notmuch-tree-mode-map}"
+ (setq notmuch-buffer-refresh-function #'notmuch-tree-refresh-view)
+ (hl-line-mode 1)
+ (setq buffer-read-only t)
+ (setq truncate-lines t)
+ (when notmuch-tree-outline-enabled (notmuch-tree-outline-mode 1)))
+
+(defvar notmuch-tree-process-exit-functions nil
+ "Functions called when the process inserting a tree of results finishes.
+
+Functions in this list are called with one argument, the process
+object, and with the tree results buffer as the current buffer.")
+
+(defun notmuch-tree-process-sentinel (proc _msg)
+ "Add a message to let user know when \"notmuch tree\" exits."
+ (let ((buffer (process-buffer proc))
+ (status (process-status proc))
+ (exit-status (process-exit-status proc)))
+ (when (memq status '(exit signal))
+ (kill-buffer (process-get proc 'parse-buf))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (when (eq status 'signal)
+ (insert "Incomplete search results (tree view process was killed).\n"))
+ (when (eq status 'exit)
+ (insert "End of search results.")
+ (unless (= exit-status 0)
+ (insert (format " (process returned %d)" exit-status)))
+ (insert "\n"))))
+ (run-hook-with-args 'notmuch-tree-process-exit-functions proc))))))
+
+(defun notmuch-tree-process-filter (proc string)
+ "Process and filter the output of \"notmuch show\" for tree view."
+ (let ((results-buf (process-buffer proc))
+ (parse-buf (process-get proc 'parse-buf))
+ (inhibit-read-only t))
+ (if (not (buffer-live-p results-buf))
+ (delete-process proc)
+ (with-current-buffer parse-buf
+ ;; Insert new data
+ (save-excursion
+ (goto-char (point-max))
+ (insert string))
+ (notmuch-sexp-parse-partial-list 'notmuch-tree-insert-forest-thread
+ results-buf)))))
+
+(defun notmuch-tree-worker (basic-query &optional query-context target
+ open-target unthreaded oldest-first)
+ "Insert the tree view of the search in the current buffer.
+
+This is is a helper function for notmuch-tree. The arguments are
+the same as for the function notmuch-tree."
+ (interactive)
+ (notmuch-tree-mode)
+ (add-hook 'post-command-hook #'notmuch-tree-command-hook t t)
+ (setq notmuch-search-oldest-first oldest-first)
+ (setq notmuch-tree-unthreaded unthreaded)
+ (setq notmuch-tree-basic-query basic-query)
+ (setq notmuch-tree-query-context (if (or (string= query-context "")
+ (string= query-context "*"))
+ nil
+ query-context))
+ (setq notmuch-tree-target-msg target)
+ (setq notmuch-tree-open-target open-target)
+ ;; Set the default value for `notmuch-show-process-crypto' in this
+ ;; buffer. Although we don't use this some of the functions we call
+ ;; (such as reply) do. It is a buffer local variable so setting it
+ ;; will not affect genuine show buffers.
+ (setq notmuch-show-process-crypto notmuch-crypto-process-mime)
+ (erase-buffer)
+ (goto-char (point-min))
+ (let* ((search-args (concat basic-query
+ (and query-context
+ (concat " and (" query-context ")"))))
+ (sort-arg (if oldest-first "--sort=oldest-first" "--sort=newest-first"))
+ (message-arg (if unthreaded "--unthreaded" "--entire-thread")))
+ (when (equal (car (notmuch--process-lines notmuch-command "count" search-args)) "0")
+ (setq search-args basic-query))
+ (notmuch-tag-clear-cache)
+ (let ((proc (notmuch-start-notmuch
+ "notmuch-tree" (current-buffer) #'notmuch-tree-process-sentinel
+ "show" "--body=false" "--format=sexp" "--format-version=5"
+ sort-arg message-arg search-args))
+ ;; Use a scratch buffer to accumulate partial output.
+ ;; This buffer will be killed by the sentinel, which
+ ;; should be called no matter how the process dies.
+ (parse-buf (generate-new-buffer " *notmuch tree parse*")))
+ (process-put proc 'parse-buf parse-buf)
+ (set-process-filter proc 'notmuch-tree-process-filter)
+ (set-process-query-on-exit-flag proc nil))))
+
+(defun notmuch-tree-get-query ()
+ "Return the current query in this tree buffer."
+ (if notmuch-tree-query-context
+ (concat notmuch-tree-basic-query
+ " and ("
+ notmuch-tree-query-context
+ ")")
+ notmuch-tree-basic-query))
+
+(defun notmuch-tree-toggle-order ()
+ "Toggle the current search order.
+
+This command toggles the sort order for the current search. The
+default sort order is defined by `notmuch-search-oldest-first'."
+ (interactive)
+ (setq notmuch-search-oldest-first (not notmuch-search-oldest-first))
+ (notmuch-tree-refresh-view))
+
+(defun notmuch-tree (&optional query query-context target buffer-name
+ open-target unthreaded parent-buffer oldest-first)
+ "Display threads matching QUERY in tree view.
+
+The arguments are:
+ QUERY: the main query. This can be any query but in many cases will be
+ a single thread. If nil this is read interactively from the minibuffer.
+ QUERY-CONTEXT: is an additional term for the query. The query used
+ is QUERY and QUERY-CONTEXT unless that does not match any messages
+ in which case we fall back to just QUERY.
+ TARGET: A message ID (with the id: prefix) that will be made
+ current if it appears in the tree view results.
+ BUFFER-NAME: the name of the buffer to display the tree view. If
+ it is nil \"*notmuch-tree\" followed by QUERY is used.
+ OPEN-TARGET: If TRUE open the target message in the message pane.
+ UNTHREADED: If TRUE only show matching messages in an unthreaded view."
+ (interactive)
+ (unless query
+ (setq query (notmuch-read-query (concat "Notmuch "
+ (if unthreaded "unthreaded " "tree ")
+ "view search: "))))
+ (let* ((name
+ (or buffer-name
+ (notmuch-search-buffer-title query
+ (if unthreaded "unthreaded" "tree"))))
+ (buffer (get-buffer-create (generate-new-buffer-name name)))
+ (inhibit-read-only t))
+ (pop-to-buffer-same-window buffer))
+ ;; Don't track undo information for this buffer
+ (setq buffer-undo-list t)
+ (notmuch-tree-worker query query-context target open-target unthreaded oldest-first)
+ (setq notmuch-tree-parent-buffer parent-buffer)
+ (setq truncate-lines t))
+
+(defun notmuch-unthreaded (&optional query query-context target buffer-name
+ open-target)
+ "Display threads matching QUERY in unthreaded view.
+
+See function NOTMUCH-TREE for documentation of the arguments"
+ (interactive)
+ (notmuch-tree query query-context target buffer-name open-target t))
+
+(defun notmuch-tree-filter (query)
+ "Filter or LIMIT the current search results based on an additional query string.
+
+Runs a new tree search matching only messages that match both the
+current search results AND the additional query string provided."
+ (interactive (list (notmuch-read-query "Filter search: ")))
+ (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto))
+ (grouped-query (notmuch-group-disjunctive-query-string query))
+ (grouped-original-query (notmuch-group-disjunctive-query-string
+ (notmuch-tree-get-query))))
+ (notmuch-tree-close-message-window)
+ (notmuch-tree (if (string= grouped-original-query "*")
+ grouped-query
+ (concat grouped-original-query " and " grouped-query)))))
+
+(defun notmuch-tree-filter-by-tag (tag)
+ "Filter the current search results based on a single TAG.
+
+Run a new search matching only messages that match the current
+search results and that are also tagged with the given TAG."
+ (interactive
+ (list (notmuch-select-tag-with-completion "Filter by tag: "
+ notmuch-tree-basic-query)))
+ (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto)))
+ (notmuch-tree-close-message-window)
+ (notmuch-tree (concat notmuch-tree-basic-query " and tag:" tag)
+ notmuch-tree-query-context
+ nil
+ nil
+ nil
+ notmuch-tree-unthreaded
+ nil
+ notmuch-search-oldest-first)))
+
+(defun notmuch-tree-edit-search (query)
+ "Edit the current search"
+ (interactive (list (read-from-minibuffer "Edit search: "
+ notmuch-tree-basic-query)))
+ (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto)))
+ (notmuch-tree-close-message-window)
+ (notmuch-tree query
+ notmuch-tree-query-context
+ nil
+ nil
+ nil
+ notmuch-tree-unthreaded
+ nil
+ notmuch-search-oldest-first)))
+
+;;; Tree outline mode
+;;;; Custom variables
+(defcustom notmuch-tree-outline-enabled nil
+ "Whether to automatically activate `notmuch-tree-outline-mode' in tree views."
+ :type 'boolean)
+
+(defcustom notmuch-tree-outline-visibility 'hide-others
+ "Default state of the forest outline for `notmuch-tree-outline-mode'.
+
+This variable controls the state of a forest initially and after
+a movement command. If set to nil, all trees are displayed while
+the symbol hide-all indicates that all trees in the forest should
+be folded and hide-other that only the first one should be
+unfolded."
+ :type '(choice (const :tag "Show all" nil)
+ (const :tag "Hide others" hide-others)
+ (const :tag "Hide all" hide-all)))
+
+(defcustom notmuch-tree-outline-auto-close nil
+ "Close message and tree windows when moving past the last message."
+ :type 'boolean)
+
+(defcustom notmuch-tree-outline-open-on-next nil
+ "Open new messages under point if they are closed when moving to next one.
+
+When this flag is set, using the command
+`notmuch-tree-outline-next' with point on a header for a new
+message that is not shown will open its `notmuch-show' buffer
+instead of moving point to next matching message."
+ :type 'boolean)
+
+;;;; Helper functions
+(defsubst notmuch-tree-outline--pop-at-end (pop-at-end)
+ (if notmuch-tree-outline-auto-close (not pop-at-end) pop-at-end))
+
+(defun notmuch-tree-outline--set-visibility ()
+ (when (and notmuch-tree-outline-mode (> (point-max) (point-min)))
+ (cl-case notmuch-tree-outline-visibility
+ (hide-others (notmuch-tree-outline-hide-others))
+ (hide-all (outline-hide-body)))))
+
+(defun notmuch-tree-outline--on-exit (proc)
+ (when (eq (process-status proc) 'exit)
+ (notmuch-tree-outline--set-visibility)))
+
+(add-hook 'notmuch-tree-process-exit-functions #'notmuch-tree-outline--on-exit)
+
+(defsubst notmuch-tree-outline--level (&optional props)
+ (or (plist-get (or props (notmuch-tree-get-message-properties)) :level) 0))
+
+(defsubst notmuch-tree-outline--message-open-p ()
+ (and (buffer-live-p notmuch-tree-message-buffer)
+ (get-buffer-window notmuch-tree-message-buffer)
+ (let ((id (notmuch-tree-get-message-id)))
+ (and id
+ (with-current-buffer notmuch-tree-message-buffer
+ (string= (notmuch-show-get-message-id) id))))))
+
+(defsubst notmuch-tree-outline--at-original-match-p ()
+ (and (notmuch-tree-get-prop :match)
+ (equal (notmuch-tree-get-prop :orig-tags)
+ (notmuch-tree-get-prop :tags))))
+
+(defun notmuch-tree-outline--next (prev thread pop-at-end &optional open-new)
+ (cond (thread
+ (notmuch-tree-thread-top)
+ (if prev
+ (outline-backward-same-level 1)
+ (outline-forward-same-level 1))
+ (when (> (notmuch-tree-outline--level) 0) (outline-show-branches))
+ (notmuch-tree-outline--next nil nil pop-at-end t))
+ ((and (or open-new notmuch-tree-outline-open-on-next)
+ (notmuch-tree-outline--at-original-match-p)
+ (not (notmuch-tree-outline--message-open-p)))
+ (notmuch-tree-outline-hide-others t))
+ (t (outline-next-visible-heading (if prev -1 1))
+ (unless (notmuch-tree-get-prop :match)
+ (notmuch-tree-matching-message prev pop-at-end))
+ (notmuch-tree-outline-hide-others t))))
+
+;;;; User commands
+(defun notmuch-tree-outline-hide-others (&optional and-show)
+ "Fold all threads except the one around point.
+If AND-SHOW is t, make the current message visible if it's not."
+ (interactive)
+ (save-excursion
+ (while (and (not (bobp)) (> (notmuch-tree-outline--level) 1))
+ (outline-previous-heading))
+ (outline-hide-sublevels 1))
+ (when (> (notmuch-tree-outline--level) 0)
+ (outline-show-subtree)
+ (when and-show (notmuch-tree-show-message nil))))
+
+(defun notmuch-tree-outline-next (&optional pop-at-end)
+ "Next matching message in a forest, taking care of thread visibility.
+A prefix argument reverses the meaning of `notmuch-tree-outline-auto-close'."
+ (interactive "P")
+ (let ((pop (notmuch-tree-outline--pop-at-end pop-at-end)))
+ (if (null notmuch-tree-outline-visibility)
+ (notmuch-tree-matching-message nil pop)
+ (notmuch-tree-outline--next nil nil pop))))
+
+(defun notmuch-tree-outline-previous (&optional pop-at-end)
+ "Previous matching message in forest, taking care of thread visibility.
+With prefix, quit the tree view if there is no previous message."
+ (interactive "P")
+ (if (null notmuch-tree-outline-visibility)
+ (notmuch-tree-prev-matching-message pop-at-end)
+ (notmuch-tree-outline--next t nil pop-at-end)))
+
+(defun notmuch-tree-outline-next-thread ()
+ "Next matching thread in forest, taking care of thread visibility."
+ (interactive)
+ (if (null notmuch-tree-outline-visibility)
+ (notmuch-tree-next-thread)
+ (notmuch-tree-outline--next nil t nil)))
+
+(defun notmuch-tree-outline-previous-thread ()
+ "Previous matching thread in forest, taking care of thread visibility."
+ (interactive)
+ (if (null notmuch-tree-outline-visibility)
+ (notmuch-tree-prev-thread)
+ (notmuch-tree-outline--next t t nil)))
+
+;;;; Mode definition
+(defvar notmuch-tree-outline-mode-lighter nil
+ "The lighter mark for notmuch-tree-outline mode.
+Usually empty since outline-minor-mode's lighter will be active.")
+
+(define-minor-mode notmuch-tree-outline-mode
+ "Minor mode allowing message trees to be folded as outlines.
+
+When this mode is set, each thread and subthread in the results
+list is treated as a foldable section, with its first message as
+its header.
+
+The mode just makes available in the tree buffer all the
+keybindings in `outline-minor-mode', and binds the following
+additional keys:
+
+\\{notmuch-tree-outline-mode-map}
+
+The customizable variable `notmuch-tree-outline-visibility'
+controls how navigation in the buffer is affected by this mode:
+
+ - If it is set to nil, `notmuch-tree-outline-previous',
+ `notmuch-tree-outline-next', and their thread counterparts
+ behave just as the corresponding notmuch-tree navigation keys
+ when this mode is not enabled.
+
+ - If, on the other hand, `notmuch-tree-outline-visibility' is
+ set to a non-nil value, these commands hiding the outlines of
+ the trees you are not reading as you move to new messages.
+
+To enable notmuch-tree-outline-mode by default in all
+notmuch-tree buffers, just set
+`notmuch-tree-outline-mode-enabled' to t."
+ :lighter notmuch-tree-outline-mode-lighter
+ :keymap `((,(kbd "TAB") . outline-cycle)
+ (,(kbd "M-TAB") . outline-cycle-buffer)
+ ("n" . notmuch-tree-outline-next)
+ ("p" . notmuch-tree-outline-previous)
+ (,(kbd "M-n") . notmuch-tree-outline-next-thread)
+ (,(kbd "M-p") . notmuch-tree-outline-previous-thread))
+ (outline-minor-mode notmuch-tree-outline-mode)
+ (unless (derived-mode-p 'notmuch-tree-mode)
+ (user-error "notmuch-tree-outline-mode is only meaningful for notmuch trees!"))
+ (if notmuch-tree-outline-mode
+ (progn (setq-local outline-regexp "^[^\n]+")
+ (setq-local outline-level #'notmuch-tree-outline--level)
+ (notmuch-tree-outline--set-visibility))
+ (setq-local outline-regexp (default-value 'outline-regexp))
+ (setq-local outline-level (default-value 'outline-level))))
+
+;;; _
+
+(provide 'notmuch-tree)
+
+;;; notmuch-tree.el ends here
blob - /dev/null
blob + 653ecc2ae7d5d4e07ff8a87c9ed95315fb3c30bb (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch-wash.el
+;;; notmuch-wash.el --- cleaning up message bodies -*- lexical-binding: t -*-
+;;
+;; Copyright © Carl Worth
+;; Copyright © David Edmondson
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+;; David Edmondson <dme@dme.org>
+
+;;; Code:
+
+(require 'coolj)
+(require 'diff-mode)
+(require 'notmuch-lib)
+
+(declare-function notmuch-show-insert-bodypart "notmuch-show"
+ (msg part depth &optional hide))
+(defvar notmuch-show-indent-messages-width)
+
+;;; Options
+
+(defgroup notmuch-wash nil
+ "Cleaning up messages for display."
+ :group 'notmuch)
+
+(defcustom notmuch-wash-signature-regexp "^\\(-- ?\\|_+\\)$"
+ "Pattern to match a line that separates content from signature."
+ :type 'regexp
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-citation-regexp "\\(^[[:space:]]*>.*\n\\)+"
+ "Pattern to match citation lines."
+ :type 'regexp
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-original-regexp "^\\(--+\s?[oO]riginal [mM]essage\s?--+\\)$"
+ "Pattern to match a line that separates original message from
+reply in top-posted message."
+ :type 'regexp
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-button-signature-hidden-format
+ "[ %d-line signature. Click/Enter to show. ]"
+ "String used to construct button text for hidden signatures.
+Can use up to one integer format parameter, i.e. %d."
+ :type 'string
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-button-signature-visible-format
+ "[ %d-line signature. Click/Enter to hide. ]"
+ "String used to construct button text for visible signatures.
+Can use up to one integer format parameter, i.e. %d."
+ :type 'string
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-button-citation-hidden-format
+ "[ %d more citation lines. Click/Enter to show. ]"
+ "String used to construct button text for hidden citations.
+Can use up to one integer format parameter, i.e. %d."
+ :type 'string
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-button-citation-visible-format
+ "[ %d more citation lines. Click/Enter to hide. ]"
+ "String used to construct button text for visible citations.
+Can use up to one integer format parameter, i.e. %d."
+ :type 'string
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-button-original-hidden-format
+ "[ %d-line hidden original message. Click/Enter to show. ]"
+ "String used to construct button text for hidden citations.
+Can use up to one integer format parameter, i.e. %d."
+ :type 'string
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-button-original-visible-format
+ "[ %d-line original message. Click/Enter to hide. ]"
+ "String used to construct button text for visible citations.
+Can use up to one integer format parameter, i.e. %d."
+ :type 'string
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-signature-lines-max 12
+ "Maximum length of signature that will be hidden by default."
+ :type 'integer
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-citation-lines-prefix 3
+ "Always show at least this many lines from the start of a citation.
+
+If there is one more line than the sum of
+`notmuch-wash-citation-lines-prefix' and
+`notmuch-wash-citation-lines-suffix', show that, otherwise
+collapse the remaining lines into a button."
+ :type 'integer
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-citation-lines-suffix 3
+ "Always show at least this many lines from the end of a citation.
+
+If there is one more line than the sum of
+`notmuch-wash-citation-lines-prefix' and
+`notmuch-wash-citation-lines-suffix', show that, otherwise
+collapse the remaining lines into a button."
+ :type 'integer
+ :group 'notmuch-wash)
+
+(defcustom notmuch-wash-wrap-lines-length nil
+ "Wrap line after at most this many characters.
+
+If this is nil, lines in messages will be wrapped to fit in the
+current window. If this is a number, lines will be wrapped after
+this many characters (ignoring indentation due to thread depth)
+or at the window width (whichever one is lower)."
+ :type '(choice (const :tag "window width" nil)
+ (integer :tag "number of characters"))
+ :group 'notmuch-wash)
+
+;;; Faces
+
+(defface notmuch-wash-toggle-button
+ '((t (:inherit font-lock-comment-face)))
+ "Face used for buttons toggling the visibility of washed away
+message parts."
+ :group 'notmuch-wash
+ :group 'notmuch-faces)
+
+(defface notmuch-wash-cited-text
+ '((t (:inherit message-cited-text)))
+ "Face used for cited text."
+ :group 'notmuch-wash
+ :group 'notmuch-faces)
+
+;;; Buttons
+
+(defun notmuch-wash-toggle-invisible-action (cite-button)
+ ;; Toggle overlay visibility
+ (let ((overlay (button-get cite-button 'overlay)))
+ (overlay-put overlay 'invisible (not (overlay-get overlay 'invisible))))
+ ;; Update button text
+ (let* ((new-start (button-start cite-button))
+ (overlay (button-get cite-button 'overlay))
+ (button-label (notmuch-wash-button-label overlay))
+ (old-point (point))
+ (properties (text-properties-at (point)))
+ (inhibit-read-only t))
+ (goto-char new-start)
+ (insert button-label)
+ (set-text-properties new-start (point) properties)
+ (let ((old-end (button-end cite-button)))
+ (move-overlay cite-button new-start (point))
+ (delete-region (point) old-end))
+ (goto-char (min old-point (1- (button-end cite-button))))))
+
+(define-button-type 'notmuch-wash-button-invisibility-toggle-type
+ 'action 'notmuch-wash-toggle-invisible-action
+ 'follow-link t
+ 'face 'notmuch-wash-toggle-button
+ :supertype 'notmuch-button-type)
+
+(define-button-type 'notmuch-wash-button-citation-toggle-type
+ 'help-echo "mouse-1, RET: Show citation"
+ :supertype 'notmuch-wash-button-invisibility-toggle-type)
+
+(define-button-type 'notmuch-wash-button-signature-toggle-type
+ 'help-echo "mouse-1, RET: Show signature"
+ :supertype 'notmuch-wash-button-invisibility-toggle-type)
+
+(define-button-type 'notmuch-wash-button-original-toggle-type
+ 'help-echo "mouse-1, RET: Show original message"
+ :supertype 'notmuch-wash-button-invisibility-toggle-type)
+
+(defun notmuch-wash-region-isearch-show (overlay)
+ (notmuch-wash-toggle-invisible-action
+ (overlay-get overlay 'notmuch-wash-button)))
+
+(defun notmuch-wash-button-label (overlay)
+ (let* ((type (overlay-get overlay 'type))
+ (invis-spec (overlay-get overlay 'invisible))
+ (state (if (invisible-p invis-spec) "hidden" "visible"))
+ (label-format (symbol-value
+ (intern-soft
+ (format "notmuch-wash-button-%s-%s-format"
+ type state))))
+ (lines-count (count-lines (overlay-start overlay)
+ (overlay-end overlay))))
+ (format label-format lines-count)))
+
+(defun notmuch-wash-region-to-button (beg end type &optional prefix)
+ "Auxiliary function to do the actual making of overlays and buttons.
+
+BEG and END are buffer locations. TYPE should a string, either
+\"citation\" or \"signature\". Optional PREFIX is some arbitrary
+text to insert before the button, probably for indentation. Note
+that PREFIX should not include a newline."
+ ;; This uses some slightly tricky conversions between strings and
+ ;; symbols because of the way the button code works. Note that
+ ;; replacing intern-soft with make-symbol will cause this to fail,
+ ;; since the newly created symbol has no plist.
+ (let ((overlay (make-overlay beg end))
+ (button-type (intern-soft (concat "notmuch-wash-button-"
+ type "-toggle-type"))))
+ (overlay-put overlay 'invisible t)
+ (overlay-put overlay 'isearch-open-invisible #'notmuch-wash-region-isearch-show)
+ (overlay-put overlay 'type type)
+ (goto-char (1+ end))
+ (save-excursion
+ (goto-char beg)
+ (when prefix
+ (insert-before-markers prefix))
+ (let ((button-beg (point)))
+ (insert-before-markers (notmuch-wash-button-label overlay) "\n")
+ (let ((button (make-button button-beg (1- (point))
+ 'overlay overlay
+ :type button-type)))
+ (overlay-put overlay 'notmuch-wash-button button))))))
+
+;;; Hook functions
+
+(defun notmuch-wash-excerpt-citations (_msg _depth)
+ "Excerpt citations and up to one signature."
+ (goto-char (point-min))
+ (beginning-of-line)
+ (when (and (< (point) (point-max))
+ (re-search-forward notmuch-wash-original-regexp nil t))
+ (notmuch-wash-region-to-button (match-beginning 0)
+ (point-max)
+ "original"))
+ (while (and (< (point) (point-max))
+ (re-search-forward notmuch-wash-citation-regexp nil t))
+ (let* ((cite-start (match-beginning 0))
+ (cite-end (match-end 0))
+ (cite-lines (count-lines cite-start cite-end)))
+ (overlay-put (make-overlay cite-start cite-end)
+ 'face 'notmuch-wash-cited-text)
+ (when (> cite-lines (+ notmuch-wash-citation-lines-prefix
+ notmuch-wash-citation-lines-suffix
+ 1))
+ (goto-char cite-start)
+ (forward-line notmuch-wash-citation-lines-prefix)
+ (let ((hidden-start (point-marker)))
+ (goto-char cite-end)
+ (forward-line (- notmuch-wash-citation-lines-suffix))
+ (notmuch-wash-region-to-button
+ hidden-start (point-marker)
+ "citation")))))
+ (when (and (not (eobp))
+ (re-search-forward notmuch-wash-signature-regexp nil t))
+ (let ((sig-start (match-beginning 0)))
+ (when (<= (count-lines sig-start (point-max))
+ notmuch-wash-signature-lines-max)
+ (let ((sig-start-marker (make-marker))
+ (sig-end-marker (make-marker)))
+ (set-marker sig-start-marker sig-start)
+ (set-marker sig-end-marker (point-max))
+ (overlay-put (make-overlay sig-start-marker sig-end-marker)
+ 'face 'message-cited-text)
+ (notmuch-wash-region-to-button
+ sig-start-marker sig-end-marker
+ "signature"))))))
+
+(defun notmuch-wash-elide-blank-lines (_msg _depth)
+ "Elide leading, trailing and successive blank lines."
+ ;; Algorithm derived from `article-strip-multiple-blank-lines' in
+ ;; `gnus-art.el'.
+ ;; Make all blank lines empty.
+ (goto-char (point-min))
+ (while (re-search-forward "^[[:space:]\t]+$" nil t)
+ (replace-match "" nil t))
+ ;; Replace multiple empty lines with a single empty line.
+ (goto-char (point-min))
+ (while (re-search-forward "^\n\\(\n+\\)" nil t)
+ (delete-region (match-beginning 1) (match-end 1)))
+ ;; Remove a leading blank line.
+ (goto-char (point-min))
+ (when (looking-at "\n")
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Remove a trailing blank line.
+ (goto-char (point-max))
+ (when (looking-at "\n")
+ (delete-region (match-beginning 0) (match-end 0))))
+
+(defun notmuch-wash-tidy-citations (_msg _depth)
+ "Improve the display of cited regions of a message.
+
+Perform several transformations on the message body:
+
+- Remove lines of repeated citation leaders with no other
+ content,
+- Remove citation leaders standing alone before a block of cited
+ text,
+- Remove citation trailers standing alone after a block of cited
+ text."
+ ;; Remove lines of repeated citation leaders with no other content.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(^>[> ]*\n\\)\\{2,\\}" nil t)
+ (replace-match "\\1"))
+ ;; Remove citation leaders standing alone before a block of cited text.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\n\\|^[^>].*\\)\n\\(^>[> ]*\n\\)" nil t)
+ (replace-match "\\1\n"))
+ ;; Remove citation trailers standing alone after a block of cited text.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(^>[> ]*\n\\)\\(^$\\|^[^>].*\\)" nil t)
+ (replace-match "\\2")))
+
+(defun notmuch-wash-wrap-long-lines (_msg depth)
+ "Wrap long lines in the message.
+
+If `notmuch-wash-wrap-lines-length' is a number, this will wrap
+the message lines to the minimum of the width of the window or
+its value. Otherwise, this function will wrap long lines in the
+message at the window width. When doing so, citation leaders in
+the wrapped text are maintained."
+ (let* ((coolj-wrap-follows-window-size nil)
+ (indent (* depth notmuch-show-indent-messages-width))
+ (limit (if (numberp notmuch-wash-wrap-lines-length)
+ (min (+ notmuch-wash-wrap-lines-length indent)
+ (window-width))
+ (window-width)))
+ (fill-column (- limit
+ indent
+ ;; 2 to avoid poor interaction with
+ ;; `word-wrap'.
+ 2)))
+ (coolj-wrap-region (point-min) (point-max))))
+
+;;;; Convert Inline Patches
+
+(defun notmuch-wash-subject-to-filename (subject &optional maxlen)
+ "Convert a mail SUBJECT into a filename.
+
+The resulting filename is similar to the names generated by \"git
+format-patch\", without the leading patch sequence number
+\"0001-\" and \".patch\" extension. Any leading \"[PREFIX]\"
+style strings are removed prior to conversion.
+
+Optional argument MAXLEN is the maximum length of the resulting
+filename, before trimming any trailing . and - characters."
+ (let* ((s (replace-regexp-in-string "^ *\\(\\[[^]]*\\] *\\)*" "" subject))
+ (s (replace-regexp-in-string "[^A-Za-z0-9._]+" "-" s))
+ (s (replace-regexp-in-string "\\.+" "." s))
+ (s (if maxlen (substring s 0 (min (length s) maxlen)) s))
+ (s (replace-regexp-in-string "[.-]*$" "" s)))
+ s))
+
+(defun notmuch-wash-subject-to-patch-sequence-number (subject)
+ "Convert a patch mail SUBJECT into a patch sequence number.
+
+Return the patch sequence number N from the last \"[PATCH N/M]\"
+style prefix in SUBJECT, or nil if such a prefix can't be found."
+ (and (string-match
+ "^ *\\(\\[[^]]*\\] *\\)*\\[[^]]*?\\([0-9]+\\)/[0-9]+[^]]*\\].*"
+ subject)
+ (string-to-number (substring subject (match-beginning 2) (match-end 2)))))
+
+(defun notmuch-wash-subject-to-patch-filename (subject)
+ "Convert a patch mail SUBJECT into a filename.
+
+The resulting filename is similar to the names generated by \"git
+format-patch\". If the patch mail was generated and sent using
+\"git format-patch/send-email\", this should re-create the
+original filename the sender had."
+ (format "%04d-%s.patch"
+ (or (notmuch-wash-subject-to-patch-sequence-number subject) 1)
+ (notmuch-wash-subject-to-filename subject 52)))
+
+(defun notmuch-wash-convert-inline-patch-to-part (msg depth)
+ "Convert an inline patch into a fake 'text/x-diff' attachment.
+
+Given that this function guesses whether a buffer includes a
+patch and then guesses the extent of the patch, there is scope
+for error."
+ (goto-char (point-min))
+ (when (re-search-forward diff-file-header-re nil t)
+ (beginning-of-line -1)
+ (let ((patch-start (point))
+ (patch-end (point-max))
+ part)
+ (goto-char patch-start)
+ (when (or
+ ;; Patch ends with signature.
+ (re-search-forward notmuch-wash-signature-regexp nil t)
+ ;; Patch ends with bugtraq comment.
+ (re-search-forward "^\\*\\*\\* " nil t))
+ (setq patch-end (match-beginning 0)))
+ (save-restriction
+ (narrow-to-region patch-start patch-end)
+ (setq part (plist-put part :content-type "inline patch"))
+ (setq part (plist-put part :content (buffer-string)))
+ (setq part (plist-put part :id -1))
+ (setq part (plist-put part :filename
+ (notmuch-wash-subject-to-patch-filename
+ (plist-get
+ (plist-get msg :headers) :Subject))))
+ (delete-region (point-min) (point-max))
+ (notmuch-show-insert-bodypart nil part depth)))))
+
+;;; _
+
+(provide 'notmuch-wash)
+
+;;; notmuch-wash.el ends here
blob - /dev/null
blob + 6eef4af13341733da81ad4c603c5546c4c9aae8a (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/notmuch.el
+;;; notmuch.el --- run notmuch within emacs -*- lexical-binding: t -*-
+;;
+;; Copyright © Carl Worth
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+;; Homepage: https://notmuchmail.org
+
+;;; Commentary:
+
+;; This is an emacs-based interface to the notmuch mail system.
+;;
+;; You will first need to have the notmuch program installed and have a
+;; notmuch database built in order to use this. See
+;; https://notmuchmail.org for details.
+;;
+;; To install this software, copy it to a directory that is on the
+;; `load-path' variable within emacs (a good candidate is
+;; /usr/local/share/emacs/site-lisp). If you are viewing this from the
+;; notmuch source distribution then you can simply run:
+;;
+;; sudo make install-emacs
+;;
+;; to install it.
+;;
+;; Then, to actually run it, add:
+;;
+;; (autoload 'notmuch "notmuch" "Notmuch mail" t)
+;;
+;; to your ~/.emacs file, and then run "M-x notmuch" from within emacs,
+;; or run:
+;;
+;; emacs -f notmuch
+;;
+;; Have fun, and let us know if you have any comment, questions, or
+;; kudos: Notmuch list <notmuch@notmuchmail.org> (subscription is not
+;; required, but is available from https://notmuchmail.org).
+;;
+;; Note for MELPA users (and others tracking the development version
+;; of notmuch-emacs):
+;;
+;; This emacs package needs a fairly closely matched version of the
+;; notmuch program. If you use the MELPA version of notmuch.el (as
+;; opposed to MELPA stable), you should be prepared to track the
+;; master development branch (i.e. build from git) for the notmuch
+;; program as well. Upgrading notmuch-emacs too far beyond the notmuch
+;; program can CAUSE YOUR EMAIL TO STOP WORKING.
+;;
+;; TL;DR: notmuch-emacs from MELPA and notmuch from distro packages is
+;; NOT SUPPORTED.
+
+;;; Code:
+
+(require 'mm-view)
+(require 'message)
+
+(require 'hl-line)
+
+(require 'notmuch-lib)
+(require 'notmuch-tag)
+(require 'notmuch-show)
+(require 'notmuch-tree)
+(require 'notmuch-mua)
+(require 'notmuch-hello)
+(require 'notmuch-maildir-fcc)
+(require 'notmuch-message)
+(require 'notmuch-parser)
+
+;;; Options
+
+(defcustom notmuch-search-result-format
+ `(("date" . "%12s ")
+ ("count" . "%-7s ")
+ ("authors" . "%-20s ")
+ ("subject" . "%s ")
+ ("tags" . "(%s)"))
+ "Search result formatting.
+
+List of pairs of (field . format-string). Supported field
+strings are: \"date\", \"count\", \"authors\", \"subject\",
+\"tags\". It is also supported to pass a function in place of a
+field name. In this case the function is passed the thread
+object (plist) and format string.
+
+Line breaks are permitted in format strings (though this is
+currently experimental). Note that a line break at the end of an
+\"authors\" field will get elided if the authors list is long;
+place it instead at the beginning of the following field. To
+enter a line break when setting this variable with setq, use \\n.
+To enter a line break in customize, press \\[quoted-insert] C-j."
+ :type '(alist
+ :key-type
+ (choice
+ (const :tag "Date" "date")
+ (const :tag "Count" "count")
+ (const :tag "Authors" "authors")
+ (const :tag "Subject" "subject")
+ (const :tag "Tags" "tags")
+ function)
+ :value-type (string :tag "Format"))
+ :group 'notmuch-search)
+
+;; The name of this variable `notmuch-init-file' is consistent with the
+;; convention used in e.g. emacs and gnus. The value, `notmuch-config[.el[c]]'
+;; is consistent with notmuch cli configuration file `~/.notmuch-config'.
+(defcustom notmuch-init-file (locate-user-emacs-file "notmuch-config")
+ "Your Notmuch Emacs-Lisp configuration file name.
+If a file with one of the suffixes defined by `get-load-suffixes' exists,
+it will be read instead.
+This file is read once when notmuch is loaded; the notmuch hooks added
+there will be called at other points of notmuch execution."
+ :type 'file
+ :group 'notmuch)
+
+(defcustom notmuch-search-hook '(notmuch-hl-line-mode)
+ "List of functions to call when notmuch displays the search results."
+ :type 'hook
+ :options '(notmuch-hl-line-mode)
+ :group 'notmuch-search
+ :group 'notmuch-hooks)
+
+;;; Mime Utilities
+
+(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)))
+ (cl-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))
+
+;;; Keymap
+
+(defvar notmuch-search-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map notmuch-common-keymap)
+ (define-key map "x" 'notmuch-bury-or-kill-this-buffer)
+ (define-key map (kbd "DEL") 'notmuch-search-scroll-down)
+ (define-key map "b" 'notmuch-search-scroll-down)
+ (define-key map " " 'notmuch-search-scroll-up)
+ (define-key map "<" 'notmuch-search-first-thread)
+ (define-key map ">" 'notmuch-search-last-thread)
+ (define-key map "p" 'notmuch-search-previous-thread)
+ (define-key map "n" 'notmuch-search-next-thread)
+ (define-key map "r" 'notmuch-search-reply-to-thread-sender)
+ (define-key map "R" 'notmuch-search-reply-to-thread)
+ (define-key map "o" 'notmuch-search-toggle-order)
+ (define-key map "c" 'notmuch-search-stash-map)
+ (define-key map "t" 'notmuch-search-filter-by-tag)
+ (define-key map "l" 'notmuch-search-filter)
+ (define-key map "E" 'notmuch-search-edit-search)
+ (define-key map [mouse-1] 'notmuch-search-show-thread)
+ (define-key map "k" 'notmuch-tag-jump)
+ (define-key map "*" 'notmuch-search-tag-all)
+ (define-key map "a" 'notmuch-search-archive-thread)
+ (define-key map "-" 'notmuch-search-remove-tag)
+ (define-key map "+" 'notmuch-search-add-tag)
+ (define-key map (kbd "RET") 'notmuch-search-show-thread)
+ (define-key map (kbd "M-RET") 'notmuch-tree-from-search-thread)
+ (define-key map "Z" 'notmuch-tree-from-search-current-query)
+ (define-key map "U" 'notmuch-unthreaded-from-search-current-query)
+ map)
+ "Keymap for \"notmuch search\" buffers.")
+
+;;; Internal Variables
+
+(defvar notmuch-query-history nil
+ "Variable to store minibuffer history for notmuch queries.")
+
+(defvar-local notmuch-search-query-string nil)
+(defvar-local notmuch-search-target-thread nil)
+(defvar-local notmuch-search-target-line nil)
+
+;;; Stashing
+
+(defvar notmuch-search-stash-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "i" 'notmuch-search-stash-thread-id)
+ (define-key map "q" 'notmuch-stash-query)
+ (define-key map "?" 'notmuch-subkeymap-help)
+ map)
+ "Submap for stash commands.")
+(fset 'notmuch-search-stash-map notmuch-search-stash-map)
+
+(defun notmuch-search-stash-thread-id ()
+ "Copy thread ID of current thread to kill-ring."
+ (interactive)
+ (notmuch-common-do-stash (notmuch-search-find-thread-id)))
+
+(defun notmuch-stash-query ()
+ "Copy current query to kill-ring."
+ (interactive)
+ (notmuch-common-do-stash notmuch-search-query-string))
+
+;;; Movement
+
+(defun notmuch-search-scroll-up ()
+ "Move forward through search results by one window's worth."
+ (interactive)
+ (condition-case nil
+ (scroll-up nil)
+ ((end-of-buffer) (notmuch-search-last-thread))))
+
+(defun notmuch-search-scroll-down ()
+ "Move backward through the search results by one window's worth."
+ (interactive)
+ ;; I don't know why scroll-down doesn't signal beginning-of-buffer
+ ;; the way that scroll-up signals end-of-buffer, but c'est la vie.
+ ;;
+ ;; So instead of trapping a signal we instead check whether the
+ ;; window begins on the first line of the buffer and if so, move
+ ;; directly to that position. (We have to count lines since the
+ ;; window-start position is not the same as point-min due to the
+ ;; invisible thread-ID characters on the first line.
+ (if (equal (count-lines (point-min) (window-start)) 0)
+ (goto-char (point-min))
+ (scroll-down nil)))
+
+(defun notmuch-search-next-thread ()
+ "Select the next thread in the search results."
+ (interactive)
+ (when (notmuch-search-get-result)
+ (goto-char (notmuch-search-result-end))))
+
+(defun notmuch-search-previous-thread ()
+ "Select the previous thread in the search results."
+ (interactive)
+ (if (notmuch-search-get-result)
+ (unless (bobp)
+ (goto-char (notmuch-search-result-beginning (- (point) 1))))
+ ;; We must be past the end; jump to the last result
+ (notmuch-search-last-thread)))
+
+(defun notmuch-search-last-thread ()
+ "Select the last thread in the search results."
+ (interactive)
+ (goto-char (point-max))
+ (forward-line -2)
+ (let ((beg (notmuch-search-result-beginning)))
+ (when beg
+ (goto-char beg))))
+
+(defun notmuch-search-first-thread ()
+ "Select the first thread in the search results."
+ (interactive)
+ (goto-char (point-min)))
+
+;;; Faces
+
+(defface notmuch-message-summary-face
+ `((((class color) (background light))
+ ,@(and (>= emacs-major-version 27) '(:extend t))
+ :background "#f0f0f0")
+ (((class color) (background dark))
+ ,@(and (>= emacs-major-version 27) '(:extend t))
+ :background "#303030"))
+ "Face for the single-line message summary in notmuch-show-mode."
+ :group 'notmuch-show
+ :group 'notmuch-faces)
+
+(defface notmuch-search-date
+ '((t :inherit default))
+ "Face used in search mode for dates."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defface notmuch-search-count
+ '((t :inherit default))
+ "Face used in search mode for the count matching the query."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defface notmuch-search-subject
+ '((t :inherit default))
+ "Face used in search mode for subjects."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defface notmuch-search-matching-authors
+ '((t :inherit default))
+ "Face used in search mode for authors matching the query."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defface notmuch-search-non-matching-authors
+ '((((class color)
+ (background dark))
+ (:foreground "grey30"))
+ (((class color)
+ (background light))
+ (:foreground "grey60"))
+ (t
+ (:italic t)))
+ "Face used in search mode for authors not matching the query."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defface notmuch-tag-face
+ '((((class color)
+ (background dark))
+ (:foreground "OliveDrab1"))
+ (((class color)
+ (background light))
+ (:foreground "navy blue" :bold t))
+ (t
+ (:bold t)))
+ "Face used in search mode face for tags."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defface notmuch-search-flagged-face
+ '((((class color)
+ (background dark))
+ (:foreground "LightBlue1"))
+ (((class color)
+ (background light))
+ (:foreground "blue")))
+ "Face used in search mode face for flagged threads.
+
+This face is the default value for the \"flagged\" tag in
+`notmuch-search-line-faces'."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defface notmuch-search-unread-face
+ '((t
+ (:weight bold)))
+ "Face used in search mode for unread threads.
+
+This face is the default value for the \"unread\" tag in
+`notmuch-search-line-faces'."
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+;;; Mode
+
+(define-derived-mode notmuch-search-mode fundamental-mode "notmuch-search"
+ "Major mode displaying results of a notmuch search.
+
+This buffer contains the results of a \"notmuch search\" of your
+email archives. Each line in the buffer represents a single
+thread giving a summary of the thread (a relative date, the
+number of matched messages and total messages in the thread,
+participants in the thread, a representative subject line, and
+any tags).
+
+Pressing \\[notmuch-search-show-thread] on any line displays that
+thread. The '\\[notmuch-search-add-tag]' and
+'\\[notmuch-search-remove-tag]' keys can be used to add or remove
+tags from a thread. The '\\[notmuch-search-archive-thread]' key
+is a convenience for archiving a thread (applying changes in
+`notmuch-archive-tags'). The '\\[notmuch-search-tag-all]' key can
+be used to add and/or remove tags from all messages (as opposed
+to threads) that match the current query. Use with caution, as
+this will also tag matching messages that arrived *after*
+constructing the buffer.
+
+Other useful commands are '\\[notmuch-search-filter]' for
+filtering the current search based on an additional query string,
+'\\[notmuch-search-filter-by-tag]' for filtering to include only
+messages with a given tag, and '\\[notmuch-search]' to execute a
+new, global search.
+
+Complete list of currently available key bindings:
+
+\\{notmuch-search-mode-map}"
+ (setq notmuch-buffer-refresh-function #'notmuch-search-refresh-view)
+ (setq-local scroll-preserve-screen-position t)
+ (add-to-invisibility-spec (cons 'ellipsis t))
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (setq imenu-prev-index-position-function
+ #'notmuch-search-imenu-prev-index-position-function)
+ (setq imenu-extract-index-name-function
+ #'notmuch-search-imenu-extract-index-name-function))
+
+;;; Search Results
+
+(defun notmuch-search-get-result (&optional pos)
+ "Return the result object for the thread at POS (or point).
+
+If there is no thread at POS (or point), returns nil."
+ (get-text-property (or pos (point)) 'notmuch-search-result))
+
+(defun notmuch-search-result-beginning (&optional pos)
+ "Return the point at the beginning of the thread at POS (or point).
+
+If there is no thread at POS (or point), returns nil."
+ (and (notmuch-search-get-result pos)
+ ;; We pass 1+point because previous-single-property-change starts
+ ;; searching one before the position we give it.
+ (previous-single-property-change (1+ (or pos (point)))
+ 'notmuch-search-result nil
+ (point-min))))
+
+(defun notmuch-search-result-end (&optional pos)
+ "Return the point at the end of the thread at POS (or point).
+
+The returned point will be just after the newline character that
+ends the result line. If there is no thread at POS (or point),
+returns nil."
+ (and (notmuch-search-get-result pos)
+ (next-single-property-change (or pos (point))
+ 'notmuch-search-result nil
+ (point-max))))
+
+(defun notmuch-search-foreach-result (beg end fn)
+ "Invoke FN for each result between BEG and END.
+
+FN should take one argument. It will be applied to the character
+position of the beginning of each result that overlaps the region
+between points BEG and END. As a special case, if (= BEG END),
+FN will be applied to the result containing point BEG."
+ (let ((pos (notmuch-search-result-beginning beg))
+ ;; End must be a marker in case fn changes the
+ ;; text.
+ (end (copy-marker end))
+ ;; Make sure we examine at least one result, even if
+ ;; (= beg end).
+ (first t))
+ ;; We have to be careful if the region extends beyond the results.
+ ;; In this case, pos could be null or there could be no result at
+ ;; pos.
+ (while (and pos (or (< pos end) first))
+ (when (notmuch-search-get-result pos)
+ (funcall fn pos))
+ (setq pos (notmuch-search-result-end pos))
+ (setq first nil))))
+;; Unindent the function argument of notmuch-search-foreach-result so
+;; the indentation of callers doesn't get out of hand.
+(put 'notmuch-search-foreach-result 'lisp-indent-function 2)
+
+(defun notmuch-search-properties-in-region (property beg end)
+ (let (output)
+ (notmuch-search-foreach-result beg end
+ (lambda (pos)
+ (push (plist-get (notmuch-search-get-result pos) property) output)))
+ output))
+
+(defun notmuch-search-find-thread-id (&optional bare)
+ "Return the thread for the current thread.
+
+If BARE is set then do not prefix with \"thread:\"."
+ (let ((thread (plist-get (notmuch-search-get-result) :thread)))
+ (when thread
+ (concat (and (not bare) "thread:") thread))))
+
+(defun notmuch-search-find-stable-query ()
+ "Return the stable queries for the current thread.
+
+Return a list (MATCHED-QUERY UNMATCHED-QUERY) for the
+matched and unmatched messages in the current thread."
+ (plist-get (notmuch-search-get-result) :query))
+
+(defun notmuch-search-find-stable-query-region (beg end &optional only-matched)
+ "Return the stable query for the current region.
+
+If ONLY-MATCHED is non-nil, include only matched messages. If it
+is nil, include both matched and unmatched messages. If there are
+no messages in the region then return nil."
+ (let ((query-list nil) (all (not only-matched)))
+ (dolist (queries (notmuch-search-properties-in-region :query beg end))
+ (when (car queries)
+ (push (car queries) query-list))
+ (when (and all (cadr queries))
+ (push (cadr queries) query-list)))
+ (and query-list
+ (concat "(" (mapconcat 'identity query-list ") or (") ")"))))
+
+(defun notmuch-search-find-authors ()
+ "Return the authors for the current thread."
+ (plist-get (notmuch-search-get-result) :authors))
+
+(defun notmuch-search-find-authors-region (beg end)
+ "Return a list of authors for the current region."
+ (notmuch-search-properties-in-region :authors beg end))
+
+(defun notmuch-search-find-subject ()
+ "Return the subject for the current thread."
+ (plist-get (notmuch-search-get-result) :subject))
+
+(defun notmuch-search-find-subject-region (beg end)
+ "Return a list of authors for the current region."
+ (notmuch-search-properties-in-region :subject beg end))
+
+(defun notmuch-search-show-thread (&optional elide-toggle)
+ "Display the currently selected thread.
+
+With a prefix argument, invert the default value of
+`notmuch-show-only-matching-messages' when displaying the
+thread.
+
+Return non-nil on success."
+ (interactive "P")
+ (let ((thread-id (notmuch-search-find-thread-id)))
+ (if thread-id
+ (notmuch-show thread-id
+ elide-toggle
+ (current-buffer)
+ notmuch-search-query-string
+ ;; Name the buffer based on the subject.
+ (format "*%s*" (truncate-string-to-width
+ (notmuch-search-find-subject)
+ 30 nil nil t)))
+ (message "End of search results.")
+ nil)))
+
+(defun notmuch-tree-from-search-current-query ()
+ "Tree view of current query."
+ (interactive)
+ (notmuch-tree notmuch-search-query-string))
+
+(defun notmuch-unthreaded-from-search-current-query ()
+ "Unthreaded view of current query."
+ (interactive)
+ (notmuch-unthreaded notmuch-search-query-string))
+
+(defun notmuch-tree-from-search-thread ()
+ "Show the selected thread with notmuch-tree."
+ (interactive)
+ (notmuch-tree (notmuch-search-find-thread-id)
+ notmuch-search-query-string
+ nil
+ (notmuch-prettify-subject (notmuch-search-find-subject))
+ t nil (current-buffer)))
+
+(defun notmuch-search-reply-to-thread (&optional prompt-for-sender)
+ "Begin composing a reply-all to the entire current thread in a new buffer."
+ (interactive "P")
+ (notmuch-mua-new-reply (notmuch-search-find-thread-id)
+ prompt-for-sender t))
+
+(defun notmuch-search-reply-to-thread-sender (&optional prompt-for-sender)
+ "Begin composing a reply to the entire current thread in a new buffer."
+ (interactive "P")
+ (notmuch-mua-new-reply (notmuch-search-find-thread-id)
+ prompt-for-sender nil))
+
+;;; Tags
+
+(defun notmuch-search-set-tags (tags &optional pos)
+ (notmuch-search-update-result
+ (plist-put (notmuch-search-get-result pos) :tags tags)
+ pos))
+
+(defun notmuch-search-get-tags (&optional pos)
+ (plist-get (notmuch-search-get-result pos) :tags))
+
+(defun notmuch-search-get-tags-region (beg end)
+ (let (output)
+ (notmuch-search-foreach-result beg end
+ (lambda (pos)
+ (setq output (append output (notmuch-search-get-tags pos)))))
+ (delete-dups output)))
+
+(defun notmuch-search-interactive-tag-changes (&optional initial-input)
+ "Prompt for tag changes for the current thread or region.
+
+Return (TAG-CHANGES REGION-BEGIN REGION-END)."
+ (pcase-let ((`(,beg ,end) (notmuch-interactive-region)))
+ (list (notmuch-read-tag-changes (notmuch-search-get-tags-region beg end)
+ (if (= beg end) "Tag thread" "Tag region")
+ initial-input)
+ beg end)))
+
+(defun notmuch-search-tag (tag-changes &optional beg end only-matched)
+ "Change tags for the currently selected thread or region.
+
+See `notmuch-tag' for information on the format of TAG-CHANGES.
+When called interactively, this uses the region if the region is
+active. When called directly, BEG and END provide the region.
+If these are nil or not provided, then, if the region is active
+this applied to all threads meeting the region, and if the region
+is inactive this applies to the thread at point.
+
+If ONLY-MATCHED is non-nil, only tag matched messages."
+ (interactive (notmuch-search-interactive-tag-changes))
+ (unless (and beg end)
+ (setq beg (car (notmuch-interactive-region)))
+ (setq end (cadr (notmuch-interactive-region))))
+ (let ((search-string (notmuch-search-find-stable-query-region
+ beg end only-matched)))
+ (notmuch-tag search-string tag-changes)
+ (notmuch-search-foreach-result beg end
+ (lambda (pos)
+ (notmuch-search-set-tags
+ (notmuch-update-tags (notmuch-search-get-tags pos) tag-changes)
+ pos)))))
+
+(defun notmuch-search-add-tag (tag-changes &optional beg end)
+ "Change tags for the current thread or region (defaulting to add).
+
+Same as `notmuch-search-tag' but sets initial input to '+'."
+ (interactive (notmuch-search-interactive-tag-changes "+"))
+ (notmuch-search-tag tag-changes beg end))
+
+(defun notmuch-search-remove-tag (tag-changes &optional beg end)
+ "Change tags for the current thread or region (defaulting to remove).
+
+Same as `notmuch-search-tag' but sets initial input to '-'."
+ (interactive (notmuch-search-interactive-tag-changes "-"))
+ (notmuch-search-tag tag-changes beg end))
+
+(put 'notmuch-search-archive-thread 'notmuch-prefix-doc
+ "Un-archive the currently selected thread.")
+(defun notmuch-search-archive-thread (&optional unarchive beg end)
+ "Archive the currently selected thread or region.
+
+Archive each message in the currently selected thread by applying
+the tag changes in `notmuch-archive-tags' to each (remove the
+\"inbox\" tag by default). If a prefix argument is given, the
+messages will be \"unarchived\" (i.e. the tag changes in
+`notmuch-archive-tags' will be reversed).
+
+This function advances the next thread when finished."
+ (interactive (cons current-prefix-arg (notmuch-interactive-region)))
+ (when notmuch-archive-tags
+ (notmuch-search-tag
+ (notmuch-tag-change-list notmuch-archive-tags unarchive) beg end))
+ (when (eq beg end)
+ (notmuch-search-next-thread)))
+
+;;; Search Results
+
+(defun notmuch-search-update-result (result &optional pos)
+ "Replace the result object of the thread at POS (or point) by
+RESULT and redraw it.
+
+This will keep point in a reasonable location. However, if there
+are enclosing save-excursions and the saved point is in the
+result being updated, the point will be restored to the beginning
+of the result."
+ (let ((start (notmuch-search-result-beginning pos))
+ (end (notmuch-search-result-end pos))
+ (init-point (point))
+ (inhibit-read-only t))
+ ;; Delete the current thread
+ (delete-region start end)
+ ;; Insert the updated thread
+ (notmuch-search-show-result result start)
+ ;; If point was inside the old result, make an educated guess
+ ;; about where to place it now. Unfortunately, this won't work
+ ;; with save-excursion (or any other markers that would be nice to
+ ;; preserve, such as the window start), but there's nothing we can
+ ;; do about that without a way to retrieve markers in a region.
+ (when (and (>= init-point start) (<= init-point end))
+ (let* ((new-end (notmuch-search-result-end start))
+ (new-point (if (= init-point end)
+ new-end
+ (min init-point (- new-end 1)))))
+ (goto-char new-point)))))
+
+(defun notmuch-search-process-sentinel (proc _msg)
+ "Add a message to let user know when \"notmuch search\" exits."
+ (let ((buffer (process-buffer proc))
+ (status (process-status proc))
+ (exit-status (process-exit-status proc))
+ (never-found-target-thread nil))
+ (when (memq status '(exit signal))
+ (catch 'return
+ (kill-buffer (process-get proc 'parse-buf))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (save-excursion
+ (let ((inhibit-read-only t)
+ (atbob (bobp)))
+ (goto-char (point-max))
+ (when (eq status 'signal)
+ (insert "Incomplete search results (search process was killed).\n"))
+ (when (eq status 'exit)
+ (insert "End of search results.\n")
+ ;; For version mismatch, there's no point in
+ ;; showing the search buffer
+ (when (or (= exit-status 20) (= exit-status 21))
+ (kill-buffer)
+ (throw 'return nil))
+ (when (and atbob
+ (not (string= notmuch-search-target-thread "found")))
+ (setq never-found-target-thread t)))))
+ (when (and never-found-target-thread
+ notmuch-search-target-line)
+ (goto-char (point-min))
+ (forward-line (1- notmuch-search-target-line)))))))))
+
+(define-widget 'notmuch--custom-face-edit 'lazy
+ "Custom face edit with a tag Edit Face"
+ ;; I could not persuage custom-face-edit to respect the :tag
+ ;; property so create a widget specially
+ :tag "Manually specify face"
+ :type 'custom-face-edit)
+
+(defcustom notmuch-search-line-faces
+ '(("unread" . notmuch-search-unread-face)
+ ("flagged" . notmuch-search-flagged-face))
+ "Alist of tags to faces for line highlighting in notmuch-search.
+Each element looks like (TAG . FACE).
+A thread with TAG will have FACE applied.
+
+Here is an example of how to color search results based on tags.
+ (the following text would be placed in your ~/.emacs file):
+
+ (setq notmuch-search-line-faces \\='((\"unread\" . (:foreground \"green\"))
+ (\"deleted\" . (:foreground \"red\"
+ :background \"blue\"))))
+
+The FACE must be a face name (a symbol or string), a property
+list of face attributes, or a list of these. The faces for
+matching tags are merged, with earlier attributes overriding
+later. A message having both \"deleted\" and \"unread\" tags with
+the above settings would have a green foreground and blue
+background."
+ :type '(alist :key-type (string)
+ :value-type (radio (face :tag "Face name")
+ (notmuch--custom-face-edit)))
+ :group 'notmuch-search
+ :group 'notmuch-faces)
+
+(defun notmuch-search-color-line (start end line-tag-list)
+ "Colorize lines in `notmuch-show' based on tags."
+ ;; Reverse the list so earlier entries take precedence
+ (dolist (elem (reverse notmuch-search-line-faces))
+ (let ((tag (car elem))
+ (face (cdr elem)))
+ (when (member tag line-tag-list)
+ (notmuch-apply-face nil face nil start end)))))
+
+(defun notmuch-search-author-propertize (authors)
+ "Split `authors' into matching and non-matching authors and
+propertize appropriately. If no boundary between authors and
+non-authors is found, assume that all of the authors match."
+ (if (string-match "\\(.*\\)|\\(.*\\)" authors)
+ (concat (propertize (concat (match-string 1 authors) ",")
+ 'face 'notmuch-search-matching-authors)
+ (propertize (match-string 2 authors)
+ 'face 'notmuch-search-non-matching-authors))
+ (propertize authors 'face 'notmuch-search-matching-authors)))
+
+(defun notmuch-search-insert-authors (format-string authors)
+ ;; Save the match data to avoid interfering with
+ ;; `notmuch-search-process-filter'.
+ (save-match-data
+ (let* ((formatted-authors (format format-string authors))
+ (formatted-sample (format format-string ""))
+ (visible-string formatted-authors)
+ (invisible-string "")
+ (padding ""))
+ ;; Truncate the author string to fit the specification.
+ (when (> (length formatted-authors)
+ (length formatted-sample))
+ (let ((visible-length (- (length formatted-sample)
+ (length "... "))))
+ ;; Truncate the visible string according to the width of
+ ;; the display string.
+ (setq visible-string (substring formatted-authors 0 visible-length))
+ (setq invisible-string (substring formatted-authors visible-length))
+ ;; If possible, truncate the visible string at a natural
+ ;; break (comma or pipe), as incremental search doesn't
+ ;; match across the visible/invisible border.
+ (when (string-match "\\(.*\\)\\([,|] \\)\\([^,|]*\\)" visible-string)
+ ;; Second clause is destructive on `visible-string', so
+ ;; order is important.
+ (setq invisible-string (concat (match-string 3 visible-string)
+ invisible-string))
+ (setq visible-string (concat (match-string 1 visible-string)
+ (match-string 2 visible-string))))
+ ;; `visible-string' may be shorter than the space allowed
+ ;; by `format-string'. If so we must insert some padding
+ ;; after `invisible-string'.
+ (setq padding (make-string (- (length formatted-sample)
+ (length visible-string)
+ (length "..."))
+ ? ))))
+ ;; Use different faces to show matching and non-matching authors.
+ (if (string-match "\\(.*\\)|\\(.*\\)" visible-string)
+ ;; The visible string contains both matching and
+ ;; non-matching authors.
+ (progn
+ (setq visible-string (notmuch-search-author-propertize visible-string))
+ ;; The invisible string must contain only non-matching
+ ;; authors, as the visible-string contains both.
+ (setq invisible-string (propertize invisible-string
+ 'face 'notmuch-search-non-matching-authors)))
+ ;; The visible string contains only matching authors.
+ (setq visible-string (propertize visible-string
+ 'face 'notmuch-search-matching-authors))
+ ;; The invisible string may contain both matching and
+ ;; non-matching authors.
+ (setq invisible-string (notmuch-search-author-propertize invisible-string)))
+ ;; If there is any invisible text, add it as a tooltip to the
+ ;; visible text.
+ (unless (string-empty-p invisible-string)
+ (setq visible-string
+ (propertize visible-string
+ 'help-echo (concat "..." invisible-string))))
+ ;; Insert the visible and, if present, invisible author strings.
+ (insert visible-string)
+ (unless (string-empty-p invisible-string)
+ (let ((start (point))
+ overlay)
+ (insert invisible-string)
+ (setq overlay (make-overlay start (point)))
+ (overlay-put overlay 'evaporate t)
+ (overlay-put overlay 'invisible 'ellipsis)
+ (overlay-put overlay 'isearch-open-invisible #'delete-overlay)))
+ (insert padding))))
+
+(defun notmuch-search-insert-field (field format-string result)
+ (pcase field
+ ((pred functionp)
+ (insert (funcall field format-string result)))
+ ("date"
+ (insert (propertize (format format-string (plist-get result :date_relative))
+ 'face 'notmuch-search-date)))
+ ("count"
+ (insert (propertize (format format-string
+ (format "[%s/%s]" (plist-get result :matched)
+ (plist-get result :total)))
+ 'face 'notmuch-search-count)))
+ ("subject"
+ (insert (propertize (format format-string
+ (notmuch-sanitize (plist-get result :subject)))
+ 'face 'notmuch-search-subject)))
+ ("authors"
+ (notmuch-search-insert-authors format-string
+ (notmuch-sanitize (plist-get result :authors))))
+ ("tags"
+ (let ((tags (plist-get result :tags))
+ (orig-tags (plist-get result :orig-tags)))
+ (insert (format format-string (notmuch-tag-format-tags tags orig-tags)))))))
+
+(defun notmuch-search-show-result (result pos)
+ "Insert RESULT at POS."
+ ;; Ignore excluded matches
+ (unless (= (plist-get result :matched) 0)
+ (save-excursion
+ (goto-char pos)
+ (dolist (spec notmuch-search-result-format)
+ (notmuch-search-insert-field (car spec) (cdr spec) result))
+ (insert "\n")
+ (notmuch-search-color-line pos (point) (plist-get result :tags))
+ (put-text-property pos (point) 'notmuch-search-result result))))
+
+(defun notmuch-search-append-result (result)
+ "Insert RESULT at the end of the buffer.
+
+This is only called when a result is first inserted so it also
+sets the :orig-tag property."
+ (let ((new-result (plist-put result :orig-tags (plist-get result :tags)))
+ (pos (point-max)))
+ (notmuch-search-show-result new-result pos)
+ (when (string= (plist-get result :thread) notmuch-search-target-thread)
+ (setq notmuch-search-target-thread "found")
+ (goto-char pos))))
+
+(defvar-local notmuch--search-hook-run nil
+ "Flag used to ensure the notmuch-search-hook is only run once per buffer")
+
+(defun notmuch--search-hook-wrapper ()
+ (unless notmuch--search-hook-run
+ (setq notmuch--search-hook-run t)
+ (run-hooks 'notmuch-search-hook)))
+
+(defun notmuch-search-process-filter (proc string)
+ "Process and filter the output of \"notmuch search\"."
+ (let ((results-buf (process-buffer proc))
+ (parse-buf (process-get proc 'parse-buf))
+ (inhibit-read-only t))
+ (when (buffer-live-p results-buf)
+ (with-current-buffer parse-buf
+ ;; Insert new data
+ (save-excursion
+ (goto-char (point-max))
+ (insert string))
+ (notmuch-sexp-parse-partial-list 'notmuch-search-append-result
+ results-buf))
+ (with-current-buffer results-buf
+ (notmuch--search-hook-wrapper)))))
+
+;;; Commands (and some helper functions used by them)
+
+(defun notmuch-search-tag-all (tag-changes)
+ "Add/remove tags from all messages in current search buffer.
+
+See `notmuch-tag' for information on the format of TAG-CHANGES."
+ (interactive
+ (list (notmuch-read-tag-changes
+ (notmuch-search-get-tags-region (point-min) (point-max)) "Tag all")))
+ (notmuch-search-tag tag-changes (point-min) (point-max) t))
+
+(defcustom notmuch-search-buffer-name-format "*notmuch-%t-%s*"
+ "Format for the name of search results buffers.
+
+In this spec, %s will be replaced by a description of the search
+query and %t by its type (search, tree or unthreaded). The
+buffer name is formatted using `format-spec': see its docstring
+for additional parameters for the s and t format specifiers.
+
+See also `notmuch-saved-search-buffer-name-format'"
+ :type 'string
+ :group 'notmuch-search)
+
+(defcustom notmuch-saved-search-buffer-name-format "*notmuch-saved-%t-%s*"
+ "Format for the name of search results buffers for saved searches.
+
+In this spec, %s will be replaced by the saved search name and %t
+by its type (search, tree or unthreaded). The buffer name is
+formatted using `format-spec': see its docstring for additional
+parameters for the s and t format specifiers.
+
+See also `notmuch-search-buffer-name-format'"
+ :type 'string
+ :group 'notmuch-search)
+
+(defun notmuch-search-format-buffer-name (query type saved)
+ "Compose a buffer name for the given QUERY, TYPE (search, tree,
+unthreaded) and whether it's SAVED (t or nil)."
+ (let ((fmt (if saved
+ notmuch-saved-search-buffer-name-format
+ notmuch-search-buffer-name-format)))
+ (format-spec fmt `((?t . ,(or type "search")) (?s . ,query)))))
+
+(defun notmuch-search-buffer-title (query &optional type)
+ "Returns the title for a buffer with notmuch search results."
+ (let* ((saved-search
+ (let (longest
+ (longest-length 0))
+ (cl-loop for tuple in notmuch-saved-searches
+ if (let ((quoted-query
+ (regexp-quote
+ (notmuch-saved-search-get tuple :query))))
+ (and (string-match (concat "^" quoted-query) query)
+ (> (length (match-string 0 query))
+ longest-length)))
+ do (setq longest tuple))
+ longest))
+ (saved-search-name (notmuch-saved-search-get saved-search :name))
+ (saved-search-type (notmuch-saved-search-get saved-search :search-type))
+ (saved-search-query (notmuch-saved-search-get saved-search :query)))
+ (cond ((and saved-search (equal saved-search-query query))
+ ;; Query is the same as saved search (ignoring case)
+ (notmuch-search-format-buffer-name saved-search-name
+ saved-search-type
+ t))
+ (saved-search
+ (let ((query (replace-regexp-in-string
+ (concat "^" (regexp-quote saved-search-query))
+ (concat "[ " saved-search-name " ]")
+ query)))
+ (notmuch-search-format-buffer-name query saved-search-type t)))
+ (t (notmuch-search-format-buffer-name query type nil)))))
+
+(defun notmuch-read-query (prompt)
+ "Read a notmuch-query from the minibuffer with completion.
+
+PROMPT is the string to prompt with."
+ (let* ((all-tags
+ (mapcar (lambda (tag) (notmuch-escape-boolean-term tag))
+ (notmuch--process-lines notmuch-command "search" "--output=tags" "*")))
+ (completions
+ (append (list "folder:" "path:" "thread:" "id:" "date:" "from:" "to:"
+ "subject:" "attachment:")
+ (mapcar (lambda (tag) (concat "tag:" tag)) all-tags)
+ (mapcar (lambda (tag) (concat "is:" tag)) all-tags)
+ (mapcar (lambda (mimetype) (concat "mimetype:" mimetype))
+ (mailcap-mime-types))))
+ (keymap (copy-keymap minibuffer-local-map))
+ (current-query (cl-case major-mode
+ (notmuch-search-mode (notmuch-search-get-query))
+ (notmuch-show-mode (notmuch-show-get-query))
+ (notmuch-tree-mode (notmuch-tree-get-query))))
+ (minibuffer-completion-table
+ (completion-table-dynamic
+ (lambda (string)
+ ;; Generate a list of possible completions for the current input.
+ (cond
+ ;; This ugly regexp is used to get the last word of the input
+ ;; possibly preceded by a '('.
+ ((string-match "\\(^\\|.* (?\\)\\([^ ]*\\)$" string)
+ (mapcar (lambda (compl)
+ (concat (match-string-no-properties 1 string) compl))
+ (all-completions (match-string-no-properties 2 string)
+ completions)))
+ (t (list string)))))))
+ ;; This was simpler than convincing completing-read to accept spaces:
+ (define-key keymap (kbd "TAB") 'minibuffer-complete)
+ (let ((history-delete-duplicates t))
+ (read-from-minibuffer prompt nil keymap nil
+ 'notmuch-search-history current-query nil))))
+
+(defun notmuch-search-get-query ()
+ "Return the current query in this search buffer."
+ notmuch-search-query-string)
+
+(put 'notmuch-search 'notmuch-doc "Search for messages.")
+;;;###autoload
+(defun notmuch-search (&optional query oldest-first target-thread target-line
+ no-display)
+ "Display threads matching QUERY in a notmuch-search buffer.
+
+If QUERY is nil, it is read interactively from the minibuffer.
+Other optional parameters are used as follows:
+
+ OLDEST-FIRST: A Boolean controlling the sort order of returned threads
+ TARGET-THREAD: A thread ID (without the thread: prefix) that will be made
+ current if it appears in the search results.
+ TARGET-LINE: The line number to move to if the target thread does not
+ appear in the search results.
+ NO-DISPLAY: Do not try to foreground the search results buffer. If it is
+ already foregrounded i.e. displayed in a window, this has no
+ effect, meaning the buffer will remain visible.
+
+When called interactively, this will prompt for a query and use
+the configured default sort order."
+ (interactive
+ (list
+ ;; Prompt for a query
+ nil
+ ;; Use the default search order (if we're doing a search from a
+ ;; search buffer, ignore any buffer-local overrides)
+ (default-value 'notmuch-search-oldest-first)))
+
+ (let* ((query (or query (notmuch-read-query "Notmuch search: ")))
+ (buffer (get-buffer-create (notmuch-search-buffer-title query))))
+ (if no-display
+ (set-buffer buffer)
+ (pop-to-buffer-same-window buffer))
+ (notmuch-search-mode)
+ ;; Don't track undo information for this buffer
+ (setq buffer-undo-list t)
+ (setq notmuch-search-query-string query)
+ (setq notmuch-search-oldest-first oldest-first)
+ (setq notmuch-search-target-thread target-thread)
+ (setq notmuch-search-target-line target-line)
+ (notmuch-tag-clear-cache)
+ (when (get-buffer-process buffer)
+ (error "notmuch search process already running for query `%s'" query))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (goto-char (point-min))
+ (save-excursion
+ (let ((proc (notmuch-start-notmuch
+ "notmuch-search" buffer #'notmuch-search-process-sentinel
+ "search" "--format=sexp" "--format-version=5"
+ (if oldest-first
+ "--sort=oldest-first"
+ "--sort=newest-first")
+ query)))
+ ;; Use a scratch buffer to accumulate partial output.
+ ;; This buffer will be killed by the sentinel, which
+ ;; should be called no matter how the process dies.
+ (process-put proc 'parse-buf
+ (generate-new-buffer " *notmuch search parse*"))
+ (set-process-filter proc 'notmuch-search-process-filter)
+ (set-process-query-on-exit-flag proc nil))))))
+
+(defun notmuch-search-refresh-view ()
+ "Refresh the current view.
+
+Erases the current buffer and runs a new search with the same
+query string as the current search. If the current thread is in
+the new search results, then point will be placed on the same
+thread. Otherwise, point will be moved to attempt to be in the
+same relative position within the new buffer."
+ (interactive)
+ (notmuch-search notmuch-search-query-string
+ notmuch-search-oldest-first
+ (notmuch-search-find-thread-id 'bare)
+ (line-number-at-pos)
+ t)
+ (goto-char (point-min)))
+
+(defun notmuch-search-toggle-order ()
+ "Toggle the current search order.
+
+This command toggles the sort order for the current search. The
+default sort order is defined by `notmuch-search-oldest-first'."
+ (interactive)
+ (setq notmuch-search-oldest-first (not notmuch-search-oldest-first))
+ (notmuch-search-refresh-view))
+
+(defun notmuch-group-disjunctive-query-string (query-string)
+ "Group query if it contains a complex expression.
+Enclose QUERY-STRING in parentheses if contains \"OR\" operators."
+ (if (string-match-p "\\<[oO][rR]\\>" query-string)
+ (concat "( " query-string " )")
+ query-string))
+
+(defun notmuch-search-filter (query)
+ "Filter or LIMIT the current search results based on an additional query string.
+
+Runs a new search matching only messages that match both the
+current search results AND the additional query string provided."
+ (interactive (list (notmuch-read-query "Filter search: ")))
+ (let ((grouped-query (notmuch-group-disjunctive-query-string query))
+ (grouped-original-query (notmuch-group-disjunctive-query-string
+ notmuch-search-query-string)))
+ (notmuch-search (if (string= grouped-original-query "*")
+ grouped-query
+ (concat grouped-original-query " and " grouped-query))
+ notmuch-search-oldest-first)))
+
+(defun notmuch-search-filter-by-tag (tag)
+ "Filter the current search results based on a single TAG.
+
+Run a new search matching only messages that match the current
+search results and that are also tagged with the given TAG."
+ (interactive
+ (list (notmuch-select-tag-with-completion "Filter by tag: "
+ notmuch-search-query-string)))
+ (notmuch-search (concat notmuch-search-query-string " and tag:" tag)
+ notmuch-search-oldest-first))
+
+(defun notmuch-search-by-tag (tag)
+ "Display threads matching TAG in a notmuch-search buffer."
+ (interactive
+ (list (notmuch-select-tag-with-completion "Notmuch search tag: ")))
+ (notmuch-search (concat "tag:" tag)))
+
+(defun notmuch-search-edit-search (query)
+ "Edit the current search"
+ (interactive (list (read-from-minibuffer "Edit search: "
+ notmuch-search-query-string)))
+ (notmuch-search query notmuch-search-oldest-first))
+
+;;;###autoload
+(defun notmuch ()
+ "Run notmuch and display saved searches, known tags, etc."
+ (interactive)
+ (notmuch-hello))
+
+(defun notmuch-interesting-buffer (b)
+ "Whether the current buffer's major-mode is a notmuch mode."
+ (with-current-buffer b
+ (memq major-mode '(notmuch-show-mode
+ notmuch-search-mode
+ notmuch-tree-mode
+ notmuch-hello-mode
+ notmuch-message-mode))))
+
+;;;###autoload
+(defun notmuch-cycle-notmuch-buffers ()
+ "Cycle through any existing notmuch buffers (search, show or hello).
+
+If the current buffer is the only notmuch buffer, bury it.
+If no notmuch buffers exist, run `notmuch'."
+ (interactive)
+ (let (start first)
+ ;; If the current buffer is a notmuch buffer, remember it and then
+ ;; bury it.
+ (when (notmuch-interesting-buffer (current-buffer))
+ (setq start (current-buffer))
+ (bury-buffer))
+
+ ;; Find the first notmuch buffer.
+ (setq first (cl-loop for buffer in (buffer-list)
+ if (notmuch-interesting-buffer buffer)
+ return buffer))
+
+ (if first
+ ;; If the first one we found is any other than the starting
+ ;; buffer, switch to it.
+ (unless (eq first start)
+ (pop-to-buffer-same-window first))
+ (notmuch))))
+
+;;; Integrations
+;;;; Hl-line Support
+
+(defun notmuch-hl-line-mode ()
+ (prog1 (hl-line-mode)
+ (when hl-line-overlay
+ (overlay-put hl-line-overlay 'priority 1))))
+
+;;;; Imenu Support
+
+(defun notmuch-search-imenu-prev-index-position-function ()
+ "Move point to previous message in notmuch-search buffer.
+Used as`imenu-prev-index-position-function' in notmuch buffers."
+ (notmuch-search-previous-thread))
+
+(defun notmuch-search-imenu-extract-index-name-function ()
+ "Return imenu name for line at point.
+Used as `imenu-extract-index-name-function' in notmuch buffers.
+Point should be at the beginning of the line."
+ (format "%s (%s)"
+ (notmuch-search-find-subject)
+ (notmuch-search-find-authors)))
+
+;;; _
+
+(provide 'notmuch)
+
+;; After provide to avoid loops if notmuch was require'd via notmuch-init-file.
+(when init-file-user ; don't load init file if the -q option was used.
+ (load notmuch-init-file t t nil t))
+
+;;; notmuch.el ends here
blob - /dev/null
blob + 5b8a9d01311b4d3055bec7af4d6f45832d661f51 (mode 644)
--- /dev/null
+++ elpa/notmuch-0.38.3/rstdoc.el
+;;; rstdoc.el --- help generate documentation from docstrings -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 David Bremner
+
+;; Author: David Bremner <david@tethera.net>
+;; Created: 26 May 2018
+;; Keywords: emacs lisp, documentation
+;; Homepage: https://notmuchmail.org
+
+;; This file is not part of GNU Emacs.
+
+;; rstdoc.el is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; rstdoc.el is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with rstdoc.el. If not, see <https://www.gnu.org/licenses/>.
+;;
+
+;;; Commentary:
+
+;; Rstdoc provides a facility to extract all of the docstrings defined in
+;; an elisp source file. Usage:
+;;
+;; emacs -Q --batch -L . -l rstdoc -f rstdoc-batch-extract foo.el foo.rsti
+
+;;; Code:
+
+(defun rstdoc-batch-extract ()
+ "Extract docstrings to and from the files on the command line."
+ (apply #'rstdoc-extract command-line-args-left))
+
+(defun rstdoc-extract (in-file out-file)
+ "Write docstrings from IN-FILE to OUT-FILE."
+ (load-file in-file)
+ (let* ((definitions (cdr (assoc (expand-file-name in-file) load-history)))
+ (text-quoting-style 'grave)
+ (doc-hash (make-hash-table :test 'eq)))
+ (mapc
+ (lambda (elt)
+ (let ((pair
+ (pcase elt
+ (`(defun . ,name) (cons name (documentation name)))
+ (`(,_ . ,_) nil)
+ (sym (cons sym (get sym 'variable-documentation))))))
+ (when (and pair (cdr pair))
+ (puthash (car pair) (cdr pair) doc-hash))))
+ definitions)
+ (with-temp-buffer
+ (maphash
+ (lambda (key val)
+ (rstdoc--insert-docstring key val))
+ doc-hash)
+ (write-region (point-min) (point-max) out-file))))
+
+(defun rstdoc--insert-docstring (symbol docstring)
+ (insert (format "\n.. |docstring::%s| replace::\n" symbol))
+ (insert (replace-regexp-in-string "^" " "
+ (rstdoc--rst-quote-string docstring)))
+ (insert "\n"))
+
+(defvar rst--escape-alist
+ '( ("\\\\='" . "\001")
+ ("`\\([^\n`']*\\)[`']" . "\002\\1\002") ;; good enough for now...
+ ("`" . "\\\\`")
+ ("\001" . "'")
+ ("\002" . "`")
+ ("[*]" . "\\\\*")
+ ("^[[:space:]]*$" . "|br|")
+ ("^[[:space:]]" . "|indent| "))
+ "list of (regex . replacement) pairs")
+
+(defun rstdoc--rst-quote-string (str)
+ (with-temp-buffer
+ (insert str)
+ (dolist (pair rst--escape-alist)
+ (goto-char (point-min))
+ (while (re-search-forward (car pair) nil t)
+ (replace-match (cdr pair))))
+ (buffer-substring (point-min) (point-max))))
+
+(provide 'rstdoc)
+
+;;; rstdoc.el ends here
blob - 34aa0d5af35063fe54c22b3dbfd8899cf4fc07a8
blob + daa85e67f3c2f3a0238d1563c0faf385776eb714
--- init.el
+++ init.el
("melpa" . "https://melpa.org/packages/")))
'(package-pinned-packages '((sly . "melpa")))
'(package-selected-packages
- '(substitute highlight-function-calls prism modus-themes imenu-list diff-hl embark-consult embark all-the-icons-completion all-the-icons-ibuffer all-the-icons-dired sly-named-readtables sly-macrostep denote-refs denote-menu denote ox-epub ob-powershell powershell web-mode lexic editorconfig elfeed-tube-mpv elfeed-tube restclient-jq graphviz-dot-mode consult-eglot jq-mode ob-restclient restclient deadgrep helpful pdf-tools paredit-menu paredit corfu sly eglot aggressive-indent project nov nhexl-mode elfeed magit yaml-mode json-mode lua-mode go-mode org-contrib org ace-window expand-region consult marginalia uuidgen diminish which-key))
+ '(notmuch substitute highlight-function-calls prism modus-themes imenu-list diff-hl embark-consult embark all-the-icons-completion all-the-icons-ibuffer all-the-icons-dired sly-named-readtables sly-macrostep denote-refs denote-menu denote ox-epub ob-powershell powershell web-mode lexic editorconfig elfeed-tube-mpv elfeed-tube restclient-jq graphviz-dot-mode consult-eglot jq-mode ob-restclient restclient deadgrep helpful pdf-tools paredit-menu paredit corfu sly eglot aggressive-indent project nov nhexl-mode elfeed magit yaml-mode json-mode lua-mode go-mode org-contrib org ace-window expand-region consult marginalia uuidgen diminish which-key))
'(pcomplete-ignore-case t t)
'(pixel-scroll-precision-mode t)
'(prism-parens t)
