commit ef05f544dc71c86ff6ce21d2114ced1e19e78e9a from: Lukas Henkel date: Sat Sep 21 15:43:24 2024 UTC Add notmuch instead of using system install commit - 8dd97a29c4e177335407ad098bf917d0552212e3 commit + ef05f544dc71c86ff6ce21d2114ced1e19e78e9a blob - /dev/null blob + 79d2a1b7f03db509b95705b1701fa601cf7987ca (mode 644) --- /dev/null +++ elpa/notmuch-0.38.3/coolj.el @@ -0,0 +1,145 @@ +;;; 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 +;; Alex Schroeder +;; Chong Yidong +;; Maintainer: David Edmondson +;; 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 . + +;;; 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 @@ -0,0 +1,69 @@ +;;; 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 . +;; +;; Authors: Austin Clements + +;;; 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 @@ -0,0 +1,437 @@ +;;; 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 . +;; +;; Authors: David Edmondson + +;;; 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 @@ -0,0 +1,215 @@ +;;; 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 @@ -0,0 +1,106 @@ +;;; 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 . +;; +;; Authors: Trevor Jim +;; Michal Sojka +;; Keywords: mail, completion + +;;; Commentary: + +;; Mail address completion for notmuch via company-mode. To enable +;; this, install company mode from . +;; +;; 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 @@ -0,0 +1,58 @@ +;;; 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 . + +;;; 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 @@ -0,0 +1,272 @@ +;;; 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 . +;; +;; Authors: Jameson Rollins + +;;; 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 @@ -0,0 +1,287 @@ +;;; 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 . +;; +;; Authors: Mark Walters +;; David Bremner +;; Leo Gaspard + +;;; 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 @@ -0,0 +1,1010 @@ +;;; 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 . +;; +;; Authors: David Edmondson + +;;; 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 @@ -0,0 +1,210 @@ +;;; 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 . +;; +;; Authors: Austin Clements +;; David Edmondson + +;;; 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 @@ -0,0 +1,1075 @@ +;;; 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 . +;; +;; Authors: Carl Worth + +;;; 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 @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + + + blob - /dev/null blob + 5102078849d629a2da37bac13c9a3548153ff996 (mode 644) --- /dev/null +++ elpa/notmuch-0.38.3/notmuch-maildir-fcc.el @@ -0,0 +1,362 @@ +;;; 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 . +;; +;; Authors: Jesse Rosenthal + +;;; 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 @@ -0,0 +1,76 @@ +;;; 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 . +;; +;; Authors: Jesse Rosenthal + +;;; 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 @@ -0,0 +1,651 @@ +;;; 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 . +;; +;; Authors: David Edmondson + +;;; 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 @@ -0,0 +1,194 @@ +;;; 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 . +;; +;; Authors: Austin Clements + +;;; 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 @@ -0,0 +1,4 @@ +(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 @@ -0,0 +1,100 @@ +;;; 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 . +;; +;; Authors: David Edmondson + +;;; 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 @@ -0,0 +1,74 @@ +;;; 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 . +;; +;; Authors: David Bremner + +;;; 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 @@ -0,0 +1,2732 @@ +;;; 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 . +;; +;; Authors: Carl Worth +;; David Edmondson + +;;; 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 " style. + ((string-match "\\(.*\\) <\\(.*\\)>" address) + (setq p-name (match-string 1 address)) + (setq p-address (match-string 2 address))) + + ;; "" 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 ' 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:). + "\\\"-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 "") 'widget-backward) + (define-key map (kbd "M-TAB") 'notmuch-show-previous-button) + (define-key map (kbd "") 'notmuch-show-previous-button) + (define-key map (kbd "TAB") 'notmuch-show-next-button) + (define-key map "f" 'notmuch-show-forward-message) + (define-key map "F" 'notmuch-show-forward-open-messages) + (define-key map "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=." + (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 @@ -0,0 +1,587 @@ +;;; 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 . +;; +;; Authors: Carl Worth +;; Damien Cassou + +;;; 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'." + " + + + + +") + +(defun notmuch-tag-star-empty-icon () + "Return SVG data representing an empty star icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-tag-icon () + "Return SVG data representing a tag icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +;;; 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 + ;; 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 @@ -0,0 +1,1464 @@ +;;; 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 . +;; +;; Authors: David Edmondson +;; Mark Walters + +;;; 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 "") '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 @@ -0,0 +1,418 @@ +;;; 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 . +;; +;; Authors: Carl Worth +;; David Edmondson + +;;; 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 @@ -0,0 +1,1239 @@ +;;; 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 . +;; +;; Authors: Carl Worth +;; 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 (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 @@ -0,0 +1,90 @@ +;;; rstdoc.el --- help generate documentation from docstrings -*- lexical-binding: t -*- + +;; Copyright (C) 2018 David Bremner + +;; Author: David Bremner +;; 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 . +;; + +;;; 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 @@ -402,7 +402,7 @@ ("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)