AdeAttwood/ElNotmuch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sync Wed, 12 Feb 2025 17:54:47 +0000

Browse source
This commit is contained in:
Ade Attwood 2025-02-12 17:54:47 +00:00
commit 4e2176da44
23 changed files with 11800 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

145
coolj.el Normal file
View file

@ -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 <Kai.Grossjohann@CS.Uni-Dortmund.DE>
;; Alex Schroeder <alex@gnu.org>
;; Chong Yidong <cyd@stupidchicken.com>
;; Maintainer: David Edmondson <dme@dme.org>
;; Keywords: convenience, wp
;; This file is not part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This is a simple derivative of some functionality from
;; `longlines.el'. The key difference is that this version will
;; insert a prefix at the head of each wrapped line. The prefix is
;; calculated from the originating long line.
;; No minor-mode is provided, the caller is expected to call
;; `coolj-wrap-region' to wrap the region of interest.
;;; Code:
(defgroup coolj nil
"Wrapping of long lines with prefix."
:group 'fill)
(defcustom coolj-wrap-follows-window-size t
"Non-nil means wrap text to the window size.
Otherwise respect `fill-column'."
:group 'coolj
:type 'boolean)
(defcustom coolj-line-prefix-regexp "^\\(>+ ?\\)*"
"Regular expression that matches line prefixes."
:group 'coolj
:type 'regexp)
(defvar-local coolj-wrap-point nil)
(defun coolj-determine-prefix ()
"Determine the prefix for the current line."
(save-excursion
(beginning-of-line)
(if (re-search-forward coolj-line-prefix-regexp nil t)
(buffer-substring (match-beginning 0) (match-end 0))
"")))
(defun coolj-wrap-buffer ()
"Wrap the current buffer."
(coolj-wrap-region (point-min) (point-max)))
(defun coolj-wrap-region (beg end)
"Wrap each successive line, starting with the line before BEG.
Stop when we reach lines after END that don't need wrapping, or the
end of the buffer."
(setq fill-column (if coolj-wrap-follows-window-size
(window-width)
fill-column))
(let ((mod (buffer-modified-p)))
(setq coolj-wrap-point (point))
(goto-char beg)
(forward-line -1)
;; Two successful coolj-wrap-line's in a row mean successive
;; lines don't need wrapping.
(while (null (and (coolj-wrap-line)
(or (eobp)
(and (>= (point) end)
(coolj-wrap-line))))))
(goto-char coolj-wrap-point)
(set-buffer-modified-p mod)))
(defun coolj-wrap-line ()
"If the current line needs to be wrapped, wrap it and return nil.
If wrapping is performed, point remains on the line. If the line does
not need to be wrapped, move point to the next line and return t."
(let ((prefix (coolj-determine-prefix)))
(if (coolj-set-breakpoint prefix)
(progn
(insert-before-markers ?\n)
(backward-char 1)
(delete-char -1)
(forward-char 1)
(insert-before-markers prefix)
nil)
(forward-line 1)
t)))
(defun coolj-set-breakpoint (prefix)
"Place point where we should break the current line, and return t.
If the line should not be broken, return nil; point remains on the
line."
(move-to-column fill-column)
(and (re-search-forward "[^ ]" (line-end-position) 1)
(> (current-column) fill-column)
;; This line is too long. Can we break it?
(or (coolj-find-break-backward prefix)
(progn (move-to-column fill-column)
(coolj-find-break-forward)))))
(defun coolj-find-break-backward (prefix)
"Move point backward to the first available breakpoint and return t.
If no breakpoint is found, return nil."
(let ((end-of-prefix (+ (line-beginning-position) (length prefix))))
(and (search-backward " " end-of-prefix 1)
(save-excursion
(skip-chars-backward " " end-of-prefix)
(null (bolp)))
(progn (forward-char 1)
(if (and fill-nobreak-predicate
(run-hook-with-args-until-success
'fill-nobreak-predicate))
(progn (skip-chars-backward " " end-of-prefix)
(coolj-find-break-backward prefix))
t)))))
(defun coolj-find-break-forward ()
"Move point forward to the first available breakpoint and return t.
If no break point is found, return nil."
(and (search-forward " " (line-end-position) 1)
(progn (skip-chars-forward " " (line-end-position))
(null (eolp)))
(if (and fill-nobreak-predicate
(run-hook-with-args-until-success
'fill-nobreak-predicate))
(coolj-find-break-forward)
t)))
(provide 'coolj)
;;; coolj.el ends here

69
make-deps.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Austin Clements <aclements@csail.mit.edu>
;;; Code:
(defun batch-make-deps ()
"Invoke `make-deps' for each file on the command line."
(setq debug-on-error t)
(dolist (file command-line-args-left)
(let ((default-directory command-line-default-directory))
(find-file-literally file))
(make-deps command-line-default-directory))
(kill-emacs))
(defun make-deps (&optional dir)
"Print make dependencies for the current buffer.
This prints make dependencies to `standard-output' based on the
top-level `require' expressions in the current buffer. Paths in
rules will be given relative to DIR, or `default-directory'."
(unless dir
(setq dir default-directory))
(save-excursion
(goto-char (point-min))
(condition-case nil
(while t
(let ((form (read (current-buffer))))
;; Is it a (require 'x) form?
(when (and (listp form) (= (length form) 2)
(eq (car form) 'require)
(listp (cadr form)) (= (length (cadr form)) 2)
(eq (car (cadr form)) 'quote)
(symbolp (cadr (cadr form))))
;; Find the required library
(let* ((name (cadr (cadr form)))
(fname (locate-library (symbol-name name))))
;; Is this file and the library in the same directory?
;; If not, assume it's a system library and don't
;; bother depending on it.
(when (and fname
(string= (file-name-directory (buffer-file-name))
(file-name-directory fname)))
;; Print the dependency
(princ (format "%s.elc: %s.elc\n"
(file-name-sans-extension
(file-relative-name (buffer-file-name) dir))
(file-name-sans-extension
(file-relative-name fname dir)))))))))
(end-of-file nil))))
;;; make-deps.el ends here

436
notmuch-address.el Normal file
View file

@ -0,0 +1,436 @@
;;; notmuch-address.el --- address completion with notmuch -*- lexical-binding: t -*-
;;
;; Copyright © David Edmondson
;;
;; This file is part of Notmuch.
;;
;; Notmuch is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Notmuch is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
;;
;; Authors: David Edmondson <dme@dme.org>
;;; Code:
(require 'message)
(require 'notmuch-parser)
(require 'notmuch-lib)
(require 'notmuch-company)
(declare-function company-manual-begin "company")
;;; Cache internals
(defvar notmuch-address-last-harvest 0
"Time of last address harvest.")
(defvar notmuch-address-completions (make-hash-table :test 'equal)
"Hash of email addresses for completion during email composition.
This variable is set by calling `notmuch-address-harvest'.")
(defvar notmuch-address-full-harvest-finished nil
"Whether full completion address harvesting has finished.
Use `notmuch-address--harvest-ready' to access as that will load
a saved hash if necessary (and available).")
(defun notmuch-address--harvest-ready ()
"Return t if there is a full address hash available.
If the hash is not present it attempts to load a saved hash."
(or notmuch-address-full-harvest-finished
(notmuch-address--load-address-hash)))
;;; Options
(defcustom notmuch-address-command 'internal
"Determines how address completion candidates are generated.
If this is a string, then that string should be an external
program, which must take a single argument (searched string)
and output a list of completion candidates, one per line.
If this is the symbol `internal', then an implementation is used
that relies on the \"notmuch address\" command, but does not use
any third-party (i.e. \"external\") programs.
If this is the symbol `as-is', then Notmuch does not modify the
value of `message-completion-alist'. This option has to be set to
this value before `notmuch' is loaded, otherwise the modification
to `message-completion-alist' may already have taken place. This
setting obviously does not prevent `message-completion-alist'
from being modified at all; the user or some third-party package
may still modify it.
Finally, if this is nil, then address completion is disabled."
:type '(radio
(const :tag "Use internal address completion" internal)
(string :tag "Use external completion command")
(const :tag "Disable address completion" nil)
(const :tag "Use default or third-party mechanism" as-is))
:group 'notmuch-send
:group 'notmuch-address
:group 'notmuch-external)
(defcustom notmuch-address-internal-completion '(sent nil)
"Determines how internal address completion generates candidates.
This should be a list of the form (DIRECTION FILTER), where
DIRECTION is either sent or received and specifies whether the
candidates are searched in messages sent by the user or received
by the user (note received by is much faster), and FILTER is
either nil or a filter-string, such as \"date:1y..\" to append to
the query."
:type '(list :tag "Use internal address completion"
(radio
:tag "Base completion on messages you have"
:value sent
(const :tag "sent (more accurate)" sent)
(const :tag "received (faster)" received))
(radio :tag "Filter messages used for completion"
(const :tag "Use all messages" nil)
(string :tag "Filter query")))
;; We override set so that we can clear the cache when this changes
:set (lambda (symbol value)
(set-default symbol value)
(setq notmuch-address-last-harvest 0)
(setq notmuch-address-completions (clrhash notmuch-address-completions))
(setq notmuch-address-full-harvest-finished nil))
:group 'notmuch-send
:group 'notmuch-address
:group 'notmuch-external)
(defcustom notmuch-address-save-filename nil
"Filename to save the cached completion addresses.
All the addresses notmuch uses for address completion will be
cached in this file. This has obvious privacy implications so
you should make sure it is not somewhere publicly readable."
:type '(choice (const :tag "Off" nil)
(file :tag "Filename"))
:group 'notmuch-send
:group 'notmuch-address
:group 'notmuch-external)
(defcustom notmuch-address-selection-function 'notmuch-address-selection-function
"The function to select address from given list.
The function is called with PROMPT, COLLECTION, and INITIAL-INPUT
as arguments (subset of what `completing-read' can be called
with). While executed the value of `completion-ignore-case'
is t. See documentation of function
`notmuch-address-selection-function' to know how address
selection is made by default."
:type 'function
:group 'notmuch-send
:group 'notmuch-address
:group 'notmuch-external)
(defcustom notmuch-address-post-completion-functions nil
"Functions called after completing address.
The completed address is passed as an argument to each function.
Note that this hook will be invoked for completion in headers
matching `notmuch-address-completion-headers-regexp'."
:type 'hook
:group 'notmuch-address
:group 'notmuch-hooks)
(defcustom notmuch-address-use-company t
"If available, use company mode for address completion."
:type 'boolean
:group 'notmuch-send
:group 'notmuch-address)
;;; Setup
(defun notmuch-address-selection-function (prompt collection initial-input)
"Default address selection function: delegate to completing read."
(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

106
notmuch-company.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Trevor Jim <tjim@mac.com>
;; Michal Sojka <sojkam1@fel.cvut.cz>
;; Keywords: mail, completion
;;; Commentary:
;; Mail address completion for notmuch via company-mode. To enable
;; this, install company mode from <https://company-mode.github.io/>.
;;
;; NB company-minimum-prefix-length defaults to 3 so you don't get
;; completion unless you type 3 characters.
;;; Code:
(require 'notmuch-lib)
(defvar-local notmuch-company-last-prefix nil)
(declare-function company-begin-backend "company")
(declare-function company-grab "company")
(declare-function company-mode "company")
(declare-function company-manual-begin "company")
(defvar company-backends)
(defvar company-idle-delay)
(declare-function notmuch-address-harvest "notmuch-address")
(declare-function notmuch-address-harvest-trigger "notmuch-address")
(declare-function notmuch-address-matching "notmuch-address")
(declare-function notmuch-address--harvest-ready "notmuch-address")
(defvar notmuch-address-completion-headers-regexp)
(defvar notmuch-address-command)
;;;###autoload
(defun notmuch-company-setup ()
(company-mode)
(setq-local company-backends '(notmuch-company))
;; Disable automatic company completion unless an internal
;; completion method is configured. Company completion (using
;; internal completion) can still be accessed via standard company
;; functions, e.g., company-complete.
(unless (eq notmuch-address-command 'internal)
(setq-local company-idle-delay nil)))
;;;###autoload
(defun notmuch-company (command &optional arg &rest _ignore)
"`company-mode' completion back-end for `notmuch'."
(interactive (list 'interactive))
(require 'company)
(let ((case-fold-search t)
(completion-ignore-case t))
(cl-case command
(interactive (company-begin-backend 'notmuch-company))
(prefix (and (or (derived-mode-p 'message-mode)
(derived-mode-p 'org-msg-edit-mode))
(looking-back
(concat notmuch-address-completion-headers-regexp ".*")
(line-beginning-position))
(setq notmuch-company-last-prefix
(company-grab "[:,][ \t]*\\(.*\\)" 1 (point-at-bol)))))
(candidates (cond
((notmuch-address--harvest-ready)
;; Update harvested addressed from time to time
(notmuch-address-harvest-trigger)
(notmuch-address-matching arg))
(t
(cons :async
(lambda (callback)
;; First run quick asynchronous harvest
;; based on what the user entered so far
(notmuch-address-harvest
arg nil
(lambda (_proc _event)
(funcall callback (notmuch-address-matching arg))
;; Then start the (potentially long-running)
;; full asynchronous harvest if necessary
(notmuch-address-harvest-trigger))))))))
(match (if (string-match notmuch-company-last-prefix arg)
(match-end 0)
0))
(post-completion
(run-hook-with-args 'notmuch-address-post-completion-functions arg))
(no-cache t))))
(provide 'notmuch-company)
;;; notmuch-company.el ends here

58
notmuch-compat.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;; Code:
;; Before Emacs 26.1 lines that are longer than 998 octets were not.
;; folded. Commit 77bbca8c82f6e553c42abbfafca28f55fc995d00 fixed
;; that. Until we drop support for Emacs 25 we have to backport that
;; fix. To avoid interfering with Gnus we only run the hook when
;; called from notmuch-message-mode.
(declare-function mail-header-fold-field "mail-parse" nil)
(defun notmuch-message--fold-long-headers ()
(when (eq major-mode 'notmuch-message-mode)
(goto-char (point-min))
(while (not (eobp))
(when (and (looking-at "[^:]+:")
(> (- (line-end-position) (point)) 998))
(mail-header-fold-field))
(forward-line 1))))
(unless (fboundp 'message--fold-long-headers)
(add-hook 'message-header-hook 'notmuch-message--fold-long-headers))
;; `dlet' isn't available until Emacs 28.1. Below is a copy, with the
;; addition of `with-no-warnings'.
(defmacro notmuch-dlet (binders &rest body)
"Like `let*' but using dynamic scoping."
(declare (indent 1) (debug let))
`(let (_)
(with-no-warnings ; Quiet "lacks a prefix" warning.
,@(mapcar (lambda (binder)
`(defvar ,(if (consp binder) (car binder) binder)))
binders))
(let* ,binders ,@body)))
(provide 'notmuch-compat)
;;; notmuch-compat.el ends here

272
notmuch-crypto.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Jameson Rollins <jrollins@finestructure.net>
;;; Code:
(require 'epg)
(require 'notmuch-lib)
(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare))
;;; Options
(defcustom notmuch-crypto-process-mime t
"Whether to process cryptographic MIME parts.
If this variable is non-nil signatures in multipart/signed
messages will be verified and multipart/encrypted parts will be
decrypted. The result of the crypto operation will be displayed
in a specially colored header button at the top of the processed
part. Signed parts will have variously colored headers depending
on the success or failure of the verification process and on the
validity of user ID of the signer.
The effect of setting this variable can be seen temporarily by
providing a prefix when viewing a signed or encrypted message, or
by providing a prefix when reloading the message in notmuch-show
mode."
:type 'boolean
:package-version '(notmuch . "0.25")
:group 'notmuch-crypto)
(defcustom notmuch-crypto-get-keys-asynchronously t
"Whether to retrieve openpgp keys asynchronously."
:type 'boolean
:group 'notmuch-crypto)
(defcustom notmuch-crypto-gpg-program epg-gpg-program
"The gpg executable."
:type 'string
:group 'notmuch-crypto)
;;; Faces
(defface notmuch-crypto-part-header
'((((class color)
(background dark))
(:foreground "LightBlue1"))
(((class color)
(background light))
(:foreground "blue")))
"Face used for crypto parts headers."
:group 'notmuch-crypto
:group 'notmuch-faces)
(defface notmuch-crypto-signature-good
'((t (:background "green" :foreground "black")))
"Face used for good signatures."
:group 'notmuch-crypto
:group 'notmuch-faces)
(defface notmuch-crypto-signature-good-key
'((t (:background "orange" :foreground "black")))
"Face used for good signatures."
:group 'notmuch-crypto
:group 'notmuch-faces)
(defface notmuch-crypto-signature-bad
'((t (:background "red" :foreground "black")))
"Face used for bad signatures."
:group 'notmuch-crypto
:group 'notmuch-faces)
(defface notmuch-crypto-signature-unknown
'((t (:background "red" :foreground "black")))
"Face used for signatures of unknown status."
:group 'notmuch-crypto
:group 'notmuch-faces)
(defface notmuch-crypto-decryption
'((t (:background "purple" :foreground "black")))
"Face used for encryption/decryption status messages."
:group 'notmuch-crypto
:group 'notmuch-faces)
;;; Functions
(define-button-type 'notmuch-crypto-status-button-type
'action (lambda (button) (message "%s" (button-get button 'help-echo)))
'follow-link t
'help-echo "Set notmuch-crypto-process-mime to process cryptographic mime parts."
:supertype 'notmuch-button-type)
(defun notmuch-crypto-insert-sigstatus-button (sigstatus from)
"Insert a button describing the signature status SIGSTATUS sent by user FROM."
(let* ((status (plist-get sigstatus :status))
(show-button t)
(face 'notmuch-crypto-signature-unknown)
(button-action (lambda (button) (message (button-get button 'help-echo))))
(keyid (concat "0x" (plist-get sigstatus :keyid)))
label help-msg)
(cond
((string= status "good")
(let ((fingerprint (concat "0x" (plist-get sigstatus :fingerprint)))
(email-or-userid (or (plist-get sigstatus :email)
(plist-get sigstatus :userid))))
;; If email or userid are present, they have full or greater validity.
(setq label (concat "Good signature by key: " fingerprint))
(setq face 'notmuch-crypto-signature-good-key)
(when email-or-userid
(setq label (concat "Good signature by: " email-or-userid))
(setq face 'notmuch-crypto-signature-good))
(setq button-action 'notmuch-crypto-sigstatus-good-callback)
(setq help-msg (concat "Click to list key ID 0x" fingerprint "."))))
((string= status "error")
(setq label (concat "Unknown key ID " keyid " or unsupported algorithm"))
(setq button-action 'notmuch-crypto-sigstatus-error-callback)
(setq help-msg (concat "Click to retrieve key ID " keyid
" from key server.")))
((string= status "bad")
(setq label (concat "Bad signature (claimed key ID " keyid ")"))
(setq face 'notmuch-crypto-signature-bad))
(status
(setq label (concat "Unknown signature status: " status)))
(t
(setq show-button nil)))
(when show-button
(insert-button
(concat "[ " label " ]")
:type 'notmuch-crypto-status-button-type
'help-echo help-msg
'face face
'mouse-face face
'action button-action
:notmuch-sigstatus sigstatus
:notmuch-from from)
(insert "\n"))))
(defun notmuch-crypto-sigstatus-good-callback (button)
(let* ((id (notmuch-show-get-message-id))
(sigstatus (button-get button :notmuch-sigstatus))
(fingerprint (concat "0x" (plist-get sigstatus :fingerprint)))
(buffer (get-buffer-create "*notmuch-crypto-gpg-out*"))
(window (display-buffer buffer)))
(with-selected-window window
(with-current-buffer buffer
(goto-char (point-max))
(insert (format "-- Key %s in message %s:\n"
fingerprint id))
(notmuch--call-process notmuch-crypto-gpg-program nil t t
"--batch" "--no-tty" "--list-keys" fingerprint))
(recenter -1))))
(declare-function notmuch-show-refresh-view "notmuch-show" (&optional reset-state))
(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare))
(defun notmuch-crypto--async-key-sentinel (process _event)
"When the user asks for a GPG key to be retrieved
asynchronously, handle completion of that task.
If the retrieval is successful, the thread where the retrieval
was initiated is still displayed and the cursor has not moved,
redisplay the thread."
(let ((status (process-status process))
(exit-status (process-exit-status process))
(keyid (process-get process :gpg-key-id)))
(when (memq status '(exit signal))
(message "Getting the GPG key %s asynchronously...%s."
keyid
(if (= exit-status 0)
"completed"
"failed"))
;; If the original buffer is still alive and point didn't move
;; (i.e. the user didn't move on or away), refresh the buffer to
;; show the updated signature status.
(let ((show-buffer (process-get process :notmuch-show-buffer))
(show-point (process-get process :notmuch-show-point)))
(when (and (bufferp show-buffer)
(buffer-live-p show-buffer)
(= show-point
(with-current-buffer show-buffer
(point))))
(with-current-buffer show-buffer
(notmuch-show-refresh-view)))))))
(defun notmuch-crypto--set-button-label (button label)
"Set the text displayed in BUTTON to LABEL."
(save-excursion
(let ((inhibit-read-only t))
;; This knows rather too much about how we typically format
;; buttons.
(goto-char (button-start button))
(forward-char 2)
(delete-region (point) (- (button-end button) 2))
(insert label))))
(defun notmuch-crypto-sigstatus-error-callback (button)
"When signature validation has failed, try to retrieve the
corresponding key when the status button is pressed."
(let* ((sigstatus (button-get button :notmuch-sigstatus))
(keyid (concat "0x" (plist-get sigstatus :keyid)))
(buffer (get-buffer-create "*notmuch-crypto-gpg-out*")))
(if notmuch-crypto-get-keys-asynchronously
(progn
(notmuch-crypto--set-button-label
button (format "Retrieving key %s asynchronously..." keyid))
(with-current-buffer buffer
(goto-char (point-max))
(insert (format "--- Retrieving key %s:\n" keyid)))
(let ((p (notmuch--make-process
:name "notmuch GPG key retrieval"
:connection-type 'pipe
:buffer buffer
:stderr buffer
:command (list notmuch-crypto-gpg-program "--recv-keys" keyid)
:sentinel #'notmuch-crypto--async-key-sentinel)))
(process-put p :gpg-key-id keyid)
(process-put p :notmuch-show-buffer (current-buffer))
(process-put p :notmuch-show-point (point))
(message "Getting the GPG key %s asynchronously..." keyid)))
(let ((window (display-buffer buffer)))
(with-selected-window window
(with-current-buffer buffer
(goto-char (point-max))
(insert (format "--- Retrieving key %s:\n" keyid))
(notmuch--call-process notmuch-crypto-gpg-program nil t t "--recv-keys" keyid)
(insert "\n")
(notmuch--call-process notmuch-crypto-gpg-program nil t t "--list-keys" keyid))
(recenter -1))
(notmuch-show-refresh-view)))))
(defun notmuch-crypto-insert-encstatus-button (encstatus)
"Insert a button describing the encryption status ENCSTATUS."
(insert-button
(concat "[ "
(let ((status (plist-get encstatus :status)))
(cond
((string= status "good")
"Decryption successful")
((string= status "bad")
"Decryption error")
(t
(concat "Unknown encryption status"
(and status (concat ": " status))))))
" ]")
:type 'notmuch-crypto-status-button-type
'face 'notmuch-crypto-decryption
'mouse-face 'notmuch-crypto-decryption)
(insert "\n"))
;;; _
(provide 'notmuch-crypto)
;;; notmuch-crypto.el ends here

287
notmuch-draft.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Mark Walters <markwalters1009@gmail.com>
;; David Bremner <david@tethera.net>
;; Leo Gaspard <leo@gaspard.io>
;;; Code:
(require 'cl-lib)
(require 'pcase)
(require 'subr-x)
(require 'notmuch-maildir-fcc)
(require 'notmuch-tag)
(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare))
(declare-function notmuch-message-mode "notmuch-mua")
;;; Options
(defgroup notmuch-draft nil
"Saving and editing drafts in Notmuch."
:group 'notmuch)
(defcustom notmuch-draft-tags '("+draft")
"List of tag changes to apply when saving a draft message in the database.
Tags starting with \"+\" (or not starting with either \"+\" or
\"-\") in the list will be added, and tags starting with \"-\"
will be removed from the message being stored.
For example, if you wanted to give the message a \"draft\" tag
but not the (normally added by default) \"inbox\" tag, you would
set:
(\"+draft\" \"-inbox\")"
:type '(repeat string)
:group 'notmuch-draft)
(defcustom notmuch-draft-folder "drafts"
"Folder to save draft messages in.
This should be specified relative to the root of the notmuch
database. It will be created if necessary."
:type 'string
:group 'notmuch-draft)
(defcustom notmuch-draft-quoted-tags '()
"Mml tags to quote.
This should be a list of mml tags to quote before saving. You do
not need to include \"secure\" as that is handled separately.
If you include \"part\" then attachments will not be saved with
the draft -- if not then they will be saved with the draft. The
former means the attachments may not still exist when you resume
the message, the latter means that the attachments as they were
when you postponed will be sent with the resumed message.
Note you may get strange results if you change this between
postponing and resuming a message."
:type '(repeat string)
:group 'notmuch-send)
(defcustom notmuch-draft-save-plaintext 'ask
"Whether to allow saving plaintext when it seems encryption is intended.
When a message contains mml tags, then that suggest it is
intended to be encrypted. If the user requests that such a
message is saved locally, then this option controls whether
that is allowed. Beside a boolean, this can also be `ask'."
:type '(radio
(const :tag "Never" nil)
(const :tag "Ask every time" ask)
(const :tag "Always" t))
:group 'notmuch-draft
:group 'notmuch-crypto)
;;; Internal
(defvar notmuch-draft-encryption-tag-regex
"<#\\(part encrypt\\|secure.*mode=.*encrypt>\\)"
"Regular expression matching mml tags indicating encryption of part or message.")
(defvar-local notmuch-draft-id nil
"Message-id of the most recent saved draft of this message.")
(defun notmuch-draft--mark-deleted ()
"Tag the last saved draft deleted.
Used when a new version is saved, or the message is sent."
(when notmuch-draft-id
(notmuch-tag notmuch-draft-id '("+deleted"))))
(defun notmuch-draft-quote-some-mml ()
"Quote the mml tags in `notmuch-draft-quoted-tags'."
(save-excursion
;; First we deal with any secure tag separately.
(message-goto-body)
(when (looking-at "<#secure[^\n]*>\n")
(let ((secure-tag (match-string 0)))
(delete-region (match-beginning 0) (match-end 0))
(message-add-header (concat "X-Notmuch-Emacs-Secure: " secure-tag))))
;; This is copied from mml-quote-region but only quotes the
;; specified tags.
(when notmuch-draft-quoted-tags
(let ((re (concat "<#!*/?\\("
(mapconcat 'regexp-quote notmuch-draft-quoted-tags "\\|")
"\\)")))
(message-goto-body)
(while (re-search-forward re nil t)
;; Insert ! after the #.
(goto-char (+ (match-beginning 0) 2))
(insert "!"))))))
(defun notmuch-draft-unquote-some-mml ()
"Unquote the mml tags in `notmuch-draft-quoted-tags'."
(save-excursion
(when notmuch-draft-quoted-tags
(let ((re (concat "<#!+/?\\("
(mapconcat 'regexp-quote notmuch-draft-quoted-tags "\\|")
"\\)")))
(message-goto-body)
(while (re-search-forward re nil t)
;; Remove one ! from after the #.
(goto-char (+ (match-beginning 0) 2))
(delete-char 1))))
(let (secure-tag)
(save-restriction
(message-narrow-to-headers)
(setq secure-tag (message-fetch-field "X-Notmuch-Emacs-Secure" t))
(message-remove-header "X-Notmuch-Emacs-Secure"))
(message-goto-body)
(when secure-tag
(insert secure-tag "\n")))))
(defun notmuch-draft--has-encryption-tag ()
"Return non-nil if there is an mml secure tag."
(save-excursion
(message-goto-body)
(re-search-forward notmuch-draft-encryption-tag-regex nil t)))
(defun notmuch-draft--query-encryption ()
"Return non-nil if we should save a message that should be encrypted.
`notmuch-draft-save-plaintext' controls the behaviour."
(cl-case notmuch-draft-save-plaintext
((ask)
(unless (yes-or-no-p
"(Customize `notmuch-draft-save-plaintext' to avoid this warning)
This message contains mml tags that suggest it is intended to be encrypted.
Really save and index an unencrypted copy? ")
(error "Save aborted")))
((nil)
(error "Refusing to save draft with encryption tags (see `%s')"
'notmuch-draft-save-plaintext))
((t)
(ignore))))
(defun notmuch-draft--make-message-id ()
;; message-make-message-id gives the id inside a "<" ">" pair,
;; but notmuch doesn't want that form, so remove them.
(concat "draft-" (substring (message-make-message-id) 1 -1)))
;;; Commands
(defun notmuch-draft-save ()
"Save the current draft message in the notmuch database.
This saves the current message in the database with tags
`notmuch-draft-tags' (in addition to any default tags
applied to newly inserted messages)."
(interactive)
(when (notmuch-draft--has-encryption-tag)
(notmuch-draft--query-encryption))
(let ((id (notmuch-draft--make-message-id)))
(with-temporary-notmuch-message-buffer
;; We insert a Date header and a Message-ID header, the former
;; so that it is easier to search for the message, and the
;; latter so we have a way of accessing the saved message (for
;; example to delete it at a later time). We check that the
;; user has these in `message-deletable-headers' (the default)
;; as otherwise they are doing something strange and we
;; shouldn't interfere. Note, since we are doing this in a new
;; buffer we don't change the version in the compose buffer.
(cond
((member 'Message-ID message-deletable-headers)
(message-remove-header "Message-ID")
(message-add-header (concat "Message-ID: <" id ">")))
(t
(message "You have customized emacs so Message-ID is not a %s"
"deletable header, so not changing it")
(setq id nil)))
(cond
((member 'Date message-deletable-headers)
(message-remove-header "Date")
(message-add-header (concat "Date: " (message-make-date))))
(t
(message "You have customized emacs so Date is not a deletable %s"
"header, so not changing it")))
(message-add-header "X-Notmuch-Emacs-Draft: True")
(notmuch-draft-quote-some-mml)
(notmuch-maildir-setup-message-for-saving)
(notmuch-maildir-notmuch-insert-current-buffer
notmuch-draft-folder t notmuch-draft-tags))
;; We are now back in the original compose buffer. Note the
;; function notmuch-call-notmuch-process (called by
;; notmuch-maildir-notmuch-insert-current-buffer) signals an error
;; on failure, so to get to this point it must have
;; succeeded. Also, notmuch-draft-id is still the id of the
;; previous draft, so it is safe to mark it deleted.
(notmuch-draft--mark-deleted)
(setq notmuch-draft-id (concat "id:" id))
(set-buffer-modified-p nil)))
(defun notmuch-draft-postpone ()
"Save the draft message in the notmuch database and exit buffer."
(interactive)
(notmuch-draft-save)
(kill-buffer))
(defun notmuch-draft-resume (id)
"Resume editing of message with id ID."
;; Used by command `notmuch-show-resume-message'.
(let* ((tags (notmuch--process-lines notmuch-command "search" "--output=tags"
"--exclude=false" id))
(draft (equal tags (notmuch-update-tags tags notmuch-draft-tags))))
(when (or draft
(yes-or-no-p "Message does not appear to be a draft: edit as new? "))
(pop-to-buffer-same-window
(get-buffer-create (concat "*notmuch-draft-" id "*")))
(setq buffer-read-only nil)
(erase-buffer)
(let ((coding-system-for-read 'no-conversion))
(notmuch--call-process notmuch-command nil t nil "show" "--format=raw" id))
(mime-to-mml)
(goto-char (point-min))
(when (re-search-forward "^$" nil t)
(replace-match mail-header-separator t t))
;; Remove the Date and Message-ID headers (unless the user has
;; explicitly customized emacs to tell us not to) as they will
;; be replaced when the message is sent.
(save-restriction
(message-narrow-to-headers)
(when (member 'Message-ID message-deletable-headers)
(message-remove-header "Message-ID"))
(when (member 'Date message-deletable-headers)
(message-remove-header "Date"))
(unless draft (notmuch-fcc-header-setup))
;; The X-Notmuch-Emacs-Draft header is a more reliable
;; indication of whether the message really is a draft.
(setq draft (> (message-remove-header "X-Notmuch-Emacs-Draft") 0)))
;; If the message is not a draft we should not unquote any mml.
(when draft
(notmuch-draft-unquote-some-mml))
(notmuch-message-mode)
(message-goto-body)
(set-buffer-modified-p nil)
;; If the resumed message was a draft then set the draft
;; message-id so that we can delete the current saved draft if the
;; message is resaved or sent.
(setq notmuch-draft-id (and draft id)))))
;;; _
(add-hook 'message-send-hook 'notmuch-draft--mark-deleted)
(provide 'notmuch-draft)
;;; notmuch-draft.el ends here

1027
notmuch-hello.el Normal file
View file

File diff suppressed because it is too large Load diff

216
notmuch-jump.el Normal file
View file

@ -0,0 +1,216 @@
;;; notmuch-jump.el --- User-friendly shortcut keys -*- lexical-binding: t -*-
;;
;; Copyright © Austin Clements
;;
;; This file is part of Notmuch.
;;
;; Notmuch is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Notmuch is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
;;
;; Authors: Austin Clements <aclements@csail.mit.edu>
;; David Edmondson <dme@dme.org>
;;; Code:
(require 'notmuch-lib)
(require 'notmuch-hello)
(declare-function notmuch-search "notmuch")
(declare-function notmuch-tree "notmuch-tree")
(declare-function notmuch-unthreaded "notmuch-tree")
;;;###autoload
(defun notmuch-jump-search ()
"Jump to a saved search by shortcut key.
This prompts for and performs a saved search using the shortcut
keys configured in the :key property of `notmuch-saved-searches'.
Typically these shortcuts are a single key long, so this is a
fast way to jump to a saved search from anywhere in Notmuch."
(interactive)
;; Build the action map
(let (action-map)
(dolist (saved-search notmuch-saved-searches)
(let* ((saved-search (notmuch-hello-saved-search-to-plist saved-search))
(key (plist-get saved-search :key)))
(when key
(let ((name (plist-get saved-search :name))
(query (plist-get saved-search :query))
(oldest-first
(cl-case (plist-get saved-search :sort-order)
(newest-first nil)
(oldest-first t)
(otherwise (default-value 'notmuch-search-oldest-first))))
(exclude (cl-case (plist-get saved-search :excluded)
(hide t)
(show nil)
(otherwise notmuch-search-hide-excluded))))
(push (list key name
(cond
((eq (plist-get saved-search :search-type) 'tree)
(lambda () (notmuch-tree query nil nil nil nil nil nil
oldest-first exclude)))
((eq (plist-get saved-search :search-type) 'unthreaded)
(lambda () (notmuch-unthreaded query nil nil nil nil
oldest-first exclude)))
(t
(lambda () (notmuch-search query oldest-first exclude)))))
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

1085
notmuch-lib.el Normal file
View file

File diff suppressed because it is too large Load diff

364
notmuch-maildir-fcc.el Normal file
View file

@ -0,0 +1,364 @@
;;; notmuch-maildir-fcc.el --- inserting using a fcc handler -*- lexical-binding: t -*-
;; Copyright © Jesse Rosenthal
;;
;; This file is part of Notmuch.
;;
;; Notmuch is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Notmuch is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
;;
;; Authors: Jesse Rosenthal <jrosenthal@jhu.edu>
;;; Code:
(require 'seq)
(require 'message)
(require 'notmuch-lib)
(defvar notmuch-maildir-fcc-count 0)
;;; Options
(defcustom notmuch-fcc-dirs "sent"
"Determines the Fcc Header which says where to save outgoing mail.
Three types of values are permitted:
- nil: no Fcc header is added,
- a string: the value of `notmuch-fcc-dirs' is the Fcc header to
be used.
- an alist: the folder is chosen based on the From address of
the current message according to an alist mapping regular
expressions to folders or nil:
((\"Sebastian@SSpaeth.de\" . \"privat\")
(\"spaetz@sspaeth.de\" . \"OUTBOX.OSS\")
(\".*\" . \"defaultinbox\"))
If none of the regular expressions match the From address, or
if the cdr of the matching entry is nil, then no Fcc header
will be added.
If `notmuch-maildir-use-notmuch-insert' is set (the default) then
the header should be of the form \"folder +tag1 -tag2\" where
folder is the folder (relative to the notmuch mailstore) to store
the message in, and tag1 and tag2 are tag changes to apply to the
stored message. This string is split using `split-string-and-unquote',
so a folder name containing spaces can be specified by
quoting each space with an immediately preceding backslash
or surrounding the entire folder name in double quotes.
If `notmuch-maildir-use-notmuch-insert' is nil then the Fcc
header should be the directory where the message should be
saved. A relative directory will be understood to specify a
directory within the notmuch mail store, (as set by the
database.path option in the notmuch configuration file).
In all cases you will be prompted to create the folder or
directory if it does not exist yet when sending a mail."
:type '(choice
(const :tag "No FCC header" nil)
(string :tag "A single folder")
(repeat :tag "A folder based on the From header"
(cons regexp (choice (const :tag "No FCC header" nil)
(string :tag "Folder")))))
:require 'notmuch-fcc-initialization
:group 'notmuch-send)
(defcustom notmuch-maildir-use-notmuch-insert t
"Should fcc use notmuch insert instead of simple fcc."
:type '(choice :tag "Fcc Method"
(const :tag "Use notmuch insert" t)
(const :tag "Use simple fcc" nil))
:group 'notmuch-send)
;;; Functions which set up the fcc header in the message buffer.
(defun notmuch-fcc-header-setup ()
"Add an Fcc header to the current message buffer.
If the Fcc header is already set, then keep it as-is.
Otherwise set it according to `notmuch-fcc-dirs'."
(let ((subdir
(cond
((or (not notmuch-fcc-dirs)
(message-field-value "Fcc"))
;; Nothing set or an existing header.
nil)
((stringp notmuch-fcc-dirs)
notmuch-fcc-dirs)
((and (listp notmuch-fcc-dirs)
(stringp (car notmuch-fcc-dirs)))
;; Old style - no longer works.
(error "Invalid `notmuch-fcc-dirs' setting (old style)"))
((listp notmuch-fcc-dirs)
(if-let ((match (seq-some (let ((from (message-field-value "From")))
(pcase-lambda (`(,regexp . ,folder))
(and (string-match-p regexp from)
(cons t folder))))
notmuch-fcc-dirs)))
(cdr match)
(message "No Fcc header added.")
nil))
(t
(error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)")))))
(when subdir
(if notmuch-maildir-use-notmuch-insert
(notmuch-maildir-add-notmuch-insert-style-fcc-header subdir)
(notmuch-maildir-add-file-style-fcc-header subdir)))))
(defun notmuch-maildir-add-notmuch-insert-style-fcc-header (subdir)
;; Notmuch insert does not accept absolute paths, so check the user
;; really want this header inserted.
(when (or (not (= (elt subdir 0) ?/))
(y-or-n-p (format "Fcc header %s is an absolute path %s %s" subdir
"and notmuch insert is requested."
"Insert header anyway? ")))
(message-add-header (concat "Fcc: " subdir))))
(defun notmuch-maildir-add-file-style-fcc-header (subdir)
(message-add-header
(concat "Fcc: "
(file-truename
;; If the resulting directory is not an absolute path,
;; prepend the standard notmuch database path.
(if (= (elt subdir 0) ?/)
subdir
(concat (notmuch-database-path) "/" subdir))))))
;;; Functions for saving a message using either method.
(defmacro with-temporary-notmuch-message-buffer (&rest body)
"Set-up a temporary copy of the current message-mode buffer."
`(save-restriction
(widen)
(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

76
notmuch-message.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Jesse Rosenthal <jrosenthal@jhu.edu>
;;; Code:
(require 'cl-lib)
(require 'pcase)
(require 'subr-x)
(require 'message)
(require 'notmuch-tag)
(defcustom notmuch-message-replied-tags '("+replied")
"List of tag changes to apply to a message when it has been replied to.
Tags starting with \"+\" (or not starting with either \"+\" or
\"-\") in the list will be added, and tags starting with \"-\"
will be removed from the message being replied to.
For example, if you wanted to add a \"replied\" tag and remove
the \"inbox\" and \"todo\" tags, you would set:
(\"+replied\" \"-inbox\" \"-todo\")"
:type '(repeat string)
:group 'notmuch-send)
(defcustom notmuch-message-forwarded-tags '("+forwarded")
"List of tag changes to apply to a message when it has been forwarded.
Tags starting with \"+\" (or not starting with either \"+\" or
\"-\") in the list will be added, and tags starting with \"-\"
will be removed from the message being forwarded.
For example, if you wanted to add a \"forwarded\" tag and remove
the \"inbox\" tag, you would set:
(\"+forwarded\" \"-inbox\")"
:type '(repeat string)
:group 'notmuch-send)
(defvar-local notmuch-message-queued-tag-changes nil
"List of tag changes to be applied when sending a message.
A list of queries and tag changes that are to be applied to them
when the message that was composed in the current buffer is being
send. Each item in this list is a list of strings, where the
first is a notmuch query and the rest are the tag changes to be
applied to the matching messages.")
(defun notmuch-message-apply-queued-tag-changes ()
;; Apply the tag changes queued in the buffer-local variable
;; notmuch-message-queued-tag-changes.
(pcase-dolist (`(,query . ,tags) notmuch-message-queued-tag-changes)
(notmuch-tag query tags)))
(add-hook 'message-send-hook 'notmuch-message-apply-queued-tag-changes)
(provide 'notmuch-message)
;;; notmuch-message.el ends here

679
notmuch-mua.el Normal file
View file

@ -0,0 +1,679 @@
;;; notmuch-mua.el --- emacs style mail-user-agent -*- lexical-binding: t -*-
;;
;; Copyright © David Edmondson
;;
;; This file is part of Notmuch.
;;
;; Notmuch is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Notmuch is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>.
;;
;; Authors: David Edmondson <dme@dme.org>
;;; Code:
(eval-when-compile (require 'subr-x))
(require 'message)
(require 'gmm-utils)
(require 'mm-view)
(require 'format-spec)
(require 'notmuch-lib)
(require 'notmuch-address)
(require 'notmuch-draft)
(require 'notmuch-message)
(declare-function notmuch-show-insert-body "notmuch-show" (msg body depth))
(declare-function notmuch-fcc-header-setup "notmuch-maildir-fcc" ())
(declare-function notmuch-maildir-message-do-fcc "notmuch-maildir-fcc" ())
(declare-function notmuch-draft-postpone "notmuch-draft" ())
(declare-function notmuch-draft-save "notmuch-draft" ())
(defvar notmuch-show-indent-multipart)
(defvar notmuch-show-insert-header-p-function)
(defvar notmuch-show-max-text-part-size)
(defvar notmuch-show-insert-text/plain-hook)
;;; Options
(defcustom notmuch-mua-send-hook nil
"Hook run before sending messages."
:type 'hook
:group 'notmuch-send
:group 'notmuch-hooks)
(defcustom notmuch-mua-compose-in 'current-window
"Where to create the mail buffer used to compose a new message.
Possible values are `current-window' (default), `new-window' and
`new-frame'. If set to `current-window', the mail buffer will be
displayed in the current window, so the old buffer will be
restored when the mail buffer is killed. If set to `new-window'
or `new-frame', the mail buffer will be displayed in a new
window/frame that will be destroyed when the buffer is killed.
You may want to customize `message-kill-buffer-on-exit'
accordingly."
:group 'notmuch-send
:type '(choice (const :tag "Compose in the current window" current-window)
(const :tag "Compose mail in a new window" new-window)
(const :tag "Compose mail in a new frame" new-frame)))
(defcustom notmuch-mua-user-agent-function nil
"Function used to generate a `User-Agent:' string.
If this is `nil' then no `User-Agent:' will be generated."
:type '(choice (const :tag "No user agent string" nil)
(const :tag "Full" notmuch-mua-user-agent-full)
(const :tag "Notmuch" notmuch-mua-user-agent-notmuch)
(const :tag "Emacs" notmuch-mua-user-agent-emacs)
(function :tag "Custom user agent function"
:value notmuch-mua-user-agent-full))
:group 'notmuch-send)
(defcustom notmuch-mua-hidden-headers nil
"Headers that are added to the `message-mode' hidden headers list."
:type '(repeat string)
:group 'notmuch-send)
(defcustom notmuch-identities nil
"Identities that can be used as the From: address when composing a new message.
If this variable is left unset, then a list will be constructed from the
name and addresses configured in the notmuch configuration file."
:type '(repeat string)
:group 'notmuch-send)
(defcustom notmuch-always-prompt-for-sender nil
"Always prompt for the From: address when composing or forwarding a message.
This is not taken into account when replying to a message, because in that case
the From: header is already filled in by notmuch."
:type 'boolean
:group 'notmuch-send)
(defgroup notmuch-reply nil
"Replying to messages in notmuch."
:group 'notmuch)
(defcustom notmuch-mua-cite-function 'message-cite-original
"Function for citing an original message.
Predefined functions include `message-cite-original' and
`message-cite-original-without-signature'. Note that these
functions use `mail-citation-hook' if that is non-nil."
:type '(radio (function-item message-cite-original)
(function-item message-cite-original-without-signature)
(function-item sc-cite-original)
(function :tag "Other"))
:link '(custom-manual "(message)Insertion Variables")
:group 'notmuch-reply)
(defcustom notmuch-mua-reply-insert-header-p-function
'notmuch-show-reply-insert-header-p-never
"Function to decide which parts get a header when replying.
This function specifies which parts of a mime message with
multiple parts get a header."
:type '(radio (const :tag "No part headers"
notmuch-show-reply-insert-header-p-never)
(const :tag "All except multipart/* and hidden parts"
notmuch-show-reply-insert-header-p-trimmed)
(const :tag "Only for included text parts"
notmuch-show-reply-insert-header-p-minimal)
(const :tag "Exactly as in show view"
notmuch-show-insert-header-p)
(function :tag "Other"))
:group 'notmuch-reply)
(defcustom notmuch-mua-attachment-regexp
"\\b\\(attache\?ment\\|attached\\|attach\\|pi[èe]ce\s+jointe?\\)\\b"
"Message body text indicating that an attachment is expected.
This is not used unless `notmuch-mua-attachment-check' is added
to `notmuch-mua-send-hook'."
:type 'regexp
:group 'notmuch-send)
(defcustom notmuch-mua-subject-regexp
"[[:blank:]]*$"
"Message subject indicating that something may be amiss.
By default, this checks for empty subject lines.
This is not used unless `notmuch-mua-subject-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-subject-check ()
"Signal an error if the subject seems amiss.
More precisely, if the subject conforms to
`notmuch-mua-subject-regexp'.
Typically this is added to `notmuch-mua-send-hook'."
(or (save-excursion
(message-goto-subject)
(message-beginning-of-header t)
(not (looking-at-p notmuch-mua-subject-regexp)))
(y-or-n-p "Subject may be erroneous – is that okay?")
(error "Erroneous subject")))
(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))))))
;;;###autoload
(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)))))
;;;###autoload
(defun notmuch-mua-send-and-exit (&optional arg)
(interactive "P")
(notmuch-mua-send-common arg t))
;;;###autoload
(defun notmuch-mua-send (&optional arg)
(interactive "P")
(notmuch-mua-send-common arg))
;;;###autoload
(defun notmuch-mua-kill-buffer ()
(interactive)
(message-kill-buffer))
;;; _
;;;###autoload
(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

194
notmuch-parser.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Austin Clements <aclements@csail.mit.edu>
;;; Code:
(require 'cl-lib)
(require 'pcase)
(require 'subr-x)
(defun notmuch-sexp-create-parser ()
"Return a new streaming S-expression parser.
This parser is designed to incrementally read an S-expression
whose structure is known to the caller. Like a typical
S-expression parsing interface, it provides a function to read a
complete S-expression from the input. However, it extends this
with an additional function that requires the next value in the
input to be a list and descends into it, allowing its elements to
be read one at a time or further descended into. Both functions
can return \\='retry to indicate that not enough input is available.
The parser always consumes input from point in the current
buffer. Hence, the caller is allowed to delete any data before
point and may resynchronize after an error by moving point."
(vector 'notmuch-sexp-parser
0 ; List depth
nil ; Partial parse position marker
nil)) ; Partial parse state
(defmacro notmuch-sexp--depth (sp) `(aref ,sp 1))
(defmacro notmuch-sexp--partial-pos (sp) `(aref ,sp 2))
(defmacro notmuch-sexp--partial-state (sp) `(aref ,sp 3))
(defun notmuch-sexp-read (sp)
"Consume and return the value at point in the current buffer.
Returns \\='retry if there is insufficient input to parse a complete
value (though it may still move point over whitespace). If the
parser is currently inside a list and the next token ends the
list, this moves point just past the terminator and returns \\='end.
Otherwise, this moves point to just past the end of the value and
returns the value."
(skip-chars-forward " \n\r\t")
(cond ((eobp) 'retry)
((= (char-after) ?\))
;; We've reached the end of a list
(if (= (notmuch-sexp--depth sp) 0)
;; .. but we weren't in a list. Let read signal the
;; error to be consistent with all other code paths.
(read (current-buffer))
;; Go up a level and return an end token
(cl-decf (notmuch-sexp--depth sp))
(forward-char)
'end))
((= (char-after) ?\()
;; We're at the beginning of a list. If we haven't started
;; a partial parse yet, attempt to read the list in its
;; entirety. If this fails, or we've started a partial
;; parse, extend the partial parse to figure out when we
;; have a complete list.
(catch 'return
(unless (notmuch-sexp--partial-state sp)
(let ((start (point)))
(condition-case nil
(throw 'return (read (current-buffer)))
(end-of-file (goto-char start)))))
;; Extend the partial parse
(let (is-complete)
(save-excursion
(let* ((new-state (parse-partial-sexp
(or (notmuch-sexp--partial-pos sp) (point))
(point-max) 0 nil
(notmuch-sexp--partial-state sp)))
;; A complete value is available if we've
;; reached depth 0.
(depth (car new-state)))
(cl-assert (>= depth 0))
(if (= depth 0)
;; Reset partial parse state
(setf (notmuch-sexp--partial-state sp) nil
(notmuch-sexp--partial-pos sp) nil
is-complete t)
;; Update partial parse state
(setf (notmuch-sexp--partial-state sp) new-state
(notmuch-sexp--partial-pos sp) (point-marker)))))
(if is-complete
(read (current-buffer))
'retry))))
(t
;; Attempt to read a non-compound value
(let ((start (point)))
(condition-case nil
(let ((val (read (current-buffer))))
;; We got what looks like a complete read, but if
;; we reached the end of the buffer in the process,
;; we may not actually have all of the input we
;; need (unless it's a string, which is delimited).
(if (or (stringp val) (not (eobp)))
val
;; We can't be sure the input was complete
(goto-char start)
'retry))
(end-of-file
(goto-char start)
'retry))))))
(defun notmuch-sexp-begin-list (sp)
"Parse the beginning of a list value and enter the list.
Returns \\='retry if there is insufficient input to parse the
beginning of the list. If this is able to parse the beginning of
a list, it moves point past the token that opens the list and
returns t. Later calls to `notmuch-sexp-read' will return the
elements inside the list. If the input in buffer is not the
beginning of a list, throw invalid-read-syntax."
(skip-chars-forward " \n\r\t")
(cond ((eobp) 'retry)
((= (char-after) ?\()
(forward-char)
(cl-incf (notmuch-sexp--depth sp))
t)
(t
;; Skip over the bad character like `read' does
(forward-char)
(signal 'invalid-read-syntax (list (string (char-before)))))))
(defvar notmuch-sexp--parser nil
"The buffer-local notmuch-sexp-parser instance.
Used by `notmuch-sexp-parse-partial-list'.")
(defvar notmuch-sexp--state nil
"The buffer-local `notmuch-sexp-parse-partial-list' state.")
(defun notmuch-sexp-parse-partial-list (result-function result-buffer)
"Incrementally parse an S-expression list from the current buffer.
This function consumes an S-expression list from the current
buffer, applying RESULT-FUNCTION in RESULT-BUFFER to each
complete value in the list. It operates incrementally and should
be called whenever the input buffer has been extended with
additional data. The caller just needs to ensure it does not
move point in the input buffer."
;; Set up the initial state
(unless (local-variable-p 'notmuch-sexp--parser)
(setq-local notmuch-sexp--parser (notmuch-sexp-create-parser))
(setq-local notmuch-sexp--state 'begin))
(let (done)
(while (not done)
(cl-case notmuch-sexp--state
(begin
;; Enter the list
(if (eq (notmuch-sexp-begin-list notmuch-sexp--parser) 'retry)
(setq done t)
(setq notmuch-sexp--state 'result)))
(result
;; Parse a result
(let ((result (notmuch-sexp-read notmuch-sexp--parser)))
(cl-case result
(retry (setq done t))
(end (setq notmuch-sexp--state 'end))
(t (with-current-buffer result-buffer
(funcall result-function result))))))
(end
;; Skip over trailing whitespace.
(skip-chars-forward " \n\r\t")
;; Any trailing data is unexpected.
(unless (eobp)
(error "Trailing garbage following expression"))
(setq done t)))))
;; Clear out what we've parsed
(delete-region (point-min) (point)))
(provide 'notmuch-parser)
;;; notmuch-parser.el ends here

100
notmuch-print.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: David Edmondson <dme@dme.org>
;;; Code:
(require 'notmuch-lib)
(declare-function notmuch-show-get-prop "notmuch-show" (prop &optional props))
;;; Options
(defcustom notmuch-print-mechanism 'notmuch-print-lpr
"How should printing be done?"
:group 'notmuch-show
:type '(choice
(function :tag "Use lpr" notmuch-print-lpr)
(function :tag "Use ps-print" notmuch-print-ps-print)
(function :tag "Use ps-print then evince" notmuch-print-ps-print/evince)
(function :tag "Use muttprint" notmuch-print-muttprint)
(function :tag "Use muttprint then evince" notmuch-print-muttprint/evince)
(function :tag "Using a custom function")))
;;; Utility functions
(defun notmuch-print-run-evince (file)
"View FILE using `evince'."
(start-process "evince" nil "evince" file))
(defun notmuch-print-run-muttprint (&optional output)
"Pass the contents of the current buffer to `muttprint'.
Optional OUTPUT allows passing a list of flags to muttprint."
(apply #'notmuch--call-process-region (point-min) (point-max)
;; Reads from stdin.
"muttprint"
nil nil nil
;; Show the tags.
"--printed-headers" "Date_To_From_CC_Newsgroups_*Subject*_/Tags/"
output))
;;; User-visible functions
(defun notmuch-print-lpr (_msg)
"Print a message buffer using lpr."
(lpr-buffer))
(defun notmuch-print-ps-print (msg)
"Print a message buffer using the ps-print package."
(let ((subject (notmuch-prettify-subject
(plist-get (notmuch-show-get-prop :headers msg) :Subject))))
(rename-buffer subject t)
(ps-print-buffer)))
(defun notmuch-print-ps-print/evince (msg)
"Preview a message buffer using ps-print and evince."
(let ((ps-file (make-temp-file "notmuch" nil ".ps"))
(subject (notmuch-prettify-subject
(plist-get (notmuch-show-get-prop :headers msg) :Subject))))
(rename-buffer subject t)
(ps-print-buffer ps-file)
(notmuch-print-run-evince ps-file)))
(defun notmuch-print-muttprint (_msg)
"Print a message using muttprint."
(notmuch-print-run-muttprint))
(defun notmuch-print-muttprint/evince (_msg)
"Preview a message buffer using muttprint and evince."
(let ((ps-file (make-temp-file "notmuch" nil ".ps")))
(notmuch-print-run-muttprint (list "--printer" (concat "TO_FILE:" ps-file)))
(notmuch-print-run-evince ps-file)))
(defun notmuch-print-message (msg)
"Print a message using the user-selected mechanism."
(set-buffer-modified-p nil)
(funcall notmuch-print-mechanism msg))
;;; _
(provide 'notmuch-print)
;;; notmuch-print.el ends here

74
notmuch-query.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: David Bremner <david@tethera.net>
;;; Code:
(require 'notmuch-lib)
;;; Basic query function
(define-obsolete-function-alias
'notmuch-query-get-threads
#'notmuch--run-show
"notmuch 0.37")
;;; Mapping functions across collections of messages
(defun notmuch-query-map-aux (mapper function seq)
"Private function to do the actual mapping and flattening."
(cl-mapcan (lambda (tree)
(funcall mapper function tree))
seq))
(defun notmuch-query-map-threads (fn threads)
"Apply function FN to every thread in THREADS.
Flatten results to a list. See the function
`notmuch-query-get-threads' for more information."
(notmuch-query-map-aux 'notmuch-query-map-forest fn threads))
(defun notmuch-query-map-forest (fn forest)
"Apply function FN to every message in FOREST.
Flatten results to a list. See the function
`notmuch-query-get-threads' for more information."
(notmuch-query-map-aux 'notmuch-query-map-tree fn forest))
(defun notmuch-query-map-tree (fn tree)
"Apply function FN to every message in TREE.
Flatten results to a list. See the function
`notmuch--run-show' for more information."
(cons (funcall fn (car tree))
(notmuch-query-map-forest fn (cadr tree))))
;;; Predefined queries
(defun notmuch-query-get-message-ids (&rest search-terms)
"Return a list of message-ids of messages that match SEARCH-TERMS."
(notmuch-query-map-threads
(lambda (msg) (plist-get msg :id))
(notmuch--run-show search-terms)))
;;; Everything in this library is obsolete
(dolist (fun '(map-aux map-threads map-forest map-tree get-message-ids))
(make-obsolete (intern (format "notmuch-query-%s" fun)) nil "notmuch 0.37"))
(provide 'notmuch-query)
;;; notmuch-query.el ends here

2737
notmuch-show.el Normal file
View file

File diff suppressed because it is too large Load diff

587
notmuch-tag.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Carl Worth <cworth@cworth.org>
;; Damien Cassou <damien.cassou@gmail.com>
;;; Code:
(require 'crm)
(require 'notmuch-lib)
(declare-function notmuch-search-tag "notmuch"
(tag-changes &optional beg end only-matched))
(declare-function notmuch-show-tag "notmuch-show" (tag-changes))
(declare-function notmuch-tree-tag "notmuch-tree" (tag-changes))
(declare-function notmuch-jump "notmuch-jump" (action-map prompt))
;;; Keys
(define-widget 'notmuch-tag-key-type 'list
"A single key tagging binding."
:format "%v"
:args '((list :inline t
:format "%v"
(key-sequence :tag "Key")
(radio :tag "Tag operations"
(repeat :tag "Tag list"
(string :format "%v" :tag "change"))
(variable :tag "Tag variable"))
(string :tag "Name"))))
(defcustom notmuch-tagging-keys
`((,(kbd "a") notmuch-archive-tags "Archive")
(,(kbd "u") notmuch-show-mark-read-tags "Mark read")
(,(kbd "f") ("+flagged") "Flag")
(,(kbd "s") ("+spam" "-inbox") "Mark as spam")
(,(kbd "d") ("+deleted" "-inbox") "Delete"))
"A list of keys and corresponding tagging operations.
For each key (or key sequence) you can specify a sequence of
tagging operations to apply, or a variable which contains a list
of tagging operations such as `notmuch-archive-tags'. The final
element is a name for this tagging operation. If the name is
omitted or empty then the list of tag changes, or the variable
name is used as the name.
The key `notmuch-tag-jump-reverse-key' (k by default) should not
be used (either as a key, or as the start of a key sequence) as
it is already bound: it switches the menu to a menu of the
reverse tagging operations. The reverse of a tagging operation is
the same list of individual tag-ops but with `+tag' replaced by
`-tag' and vice versa.
If setting this variable outside of customize then it should be a
list of triples (lists of three elements). Each triple should be
of the form (key-binding tagging-operations name). KEY-BINDING
can be a single character or a key sequence; TAGGING-OPERATIONS
should either be a list of individual tag operations each of the
form `+tag' or `-tag', or the variable name of a variable that is
a list of tagging operations; NAME should be a name for the
tagging operation, if omitted or empty than then name is taken
from TAGGING-OPERATIONS."
:tag "List of tagging bindings"
:type '(repeat notmuch-tag-key-type)
:group 'notmuch-tag)
;;; Faces and Formats
(define-widget 'notmuch-tag-format-type 'lazy
"Customize widget for notmuch-tag-format and friends."
:type '(alist :key-type (regexp :tag "Tag")
:extra-offset -3
:value-type
(radio :format "%v"
(const :tag "Hidden" nil)
(set :tag "Modified"
(string :tag "Display as")
(list :tag "Face" :extra-offset -4
(const :format "" :inline t
(notmuch-apply-face tag))
(list :format "%v"
(const :format "" quote)
custom-face-edit))
(list :format "%v" :extra-offset -4
(const :format "" :inline t
(notmuch-tag-format-image-data tag))
(choice :tag "Image"
(const :tag "Star"
(notmuch-tag-star-icon))
(const :tag "Empty star"
(notmuch-tag-star-empty-icon))
(const :tag "Tag"
(notmuch-tag-tag-icon))
(string :tag "Custom")))
(sexp :tag "Custom")))))
(defface notmuch-tag-unread
'((t :foreground "red"))
"Default face used for the unread tag.
Used in the default value of `notmuch-tag-formats'."
:group 'notmuch-faces)
(defface notmuch-tag-flagged
'((((class color)
(background dark))
(:foreground "LightBlue1"))
(((class color)
(background light))
(:foreground "blue")))
"Face used for the flagged tag.
Used in the default value of `notmuch-tag-formats'."
:group 'notmuch-faces)
(defcustom notmuch-tag-formats
'(("unread" (propertize tag 'face 'notmuch-tag-unread))
("flagged" (propertize tag 'face 'notmuch-tag-flagged)
(notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
"Custom formats for individual tags.
This is an association list of the form ((MATCH EXPR...)...),
mapping tag name regexps to lists of formatting expressions.
The first entry whose MATCH regexp-matches a tag is used to
format that tag. The regexp is implicitly anchored, so to match
a literal tag name, just use that tag name (if it contains
special regexp characters like \".\" or \"*\", these have to be
escaped).
The cdr of the matching entry gives a list of Elisp expressions
that modify the tag. If the list is empty, the tag is simply
hidden. Otherwise, each expression EXPR is evaluated in order:
for the first expression, the variable `tag' is bound to the tag
name; for each later expression, the variable `tag' is bound to
the result of the previous expression. In this way, each
expression can build on the formatting performed by the previous
expression. The result of the last expression is displayed in
place of the tag.
For example, to replace a tag with another string, simply use
that string as a formatting expression. To change the foreground
of a tag to red, use the expression
(propertize tag \\='face \\='(:foreground \"red\"))
See also `notmuch-tag-format-image', which can help replace tags
with images."
:group 'notmuch-search
:group 'notmuch-show
:group 'notmuch-faces
:type 'notmuch-tag-format-type)
(defface notmuch-tag-deleted
'((((class color) (supports :strike-through "red")) :strike-through "red")
(t :inverse-video t))
"Face used to display deleted tags.
Used in the default value of `notmuch-tag-deleted-formats'."
:group 'notmuch-faces)
(defcustom notmuch-tag-deleted-formats
'(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted))
(".*" (notmuch-apply-face tag `notmuch-tag-deleted)))
"Custom formats for tags when deleted.
For deleted tags the formats in `notmuch-tag-formats' are applied
first and then these formats are applied on top; that is `tag'
passed to the function is the tag with all these previous
formattings applied. The formatted can access the original
unformatted tag as `bare-tag'.
By default this shows deleted tags with strike-through in red,
unless strike-through is not available (e.g., emacs is running in
a terminal) in which case it uses inverse video. To hide deleted
tags completely set this to
\\='((\".*\" nil))
See `notmuch-tag-formats' for full documentation."
:group 'notmuch-show
:group 'notmuch-faces
:type 'notmuch-tag-format-type)
(defface notmuch-tag-added
'((t :underline "green"))
"Default face used for added tags.
Used in the default value for `notmuch-tag-added-formats'."
:group 'notmuch-faces)
(defcustom notmuch-tag-added-formats
'((".*" (notmuch-apply-face tag 'notmuch-tag-added)))
"Custom formats for tags when added.
For added tags the formats in `notmuch-tag-formats' are applied
first and then these formats are applied on top.
To disable special formatting of added tags, set this variable to
nil.
See `notmuch-tag-formats' for full documentation."
:group 'notmuch-show
:group 'notmuch-faces
:type 'notmuch-tag-format-type)
;;; Icons
(defun notmuch-tag-format-image-data (tag data)
"Replace TAG with image DATA, if available.
This function returns a propertized string that will display image
DATA in place of TAG.This is designed for use in
`notmuch-tag-formats'.
DATA is the content of an SVG picture (e.g., as returned by
`notmuch-tag-star-icon')."
(propertize tag 'display
`(image :type svg
:data ,data
:ascent center
:mask heuristic)))
(defun notmuch-tag-star-icon ()
"Return SVG data representing a star icon.
This can be used with `notmuch-tag-format-image-data'."
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
<g transform=\"translate(-242.81601,-315.59635)\">
<path
d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
</g>
</svg>")
(defun notmuch-tag-star-empty-icon ()
"Return SVG data representing an empty star icon.
This can be used with `notmuch-tag-format-image-data'."
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
<g transform=\"translate(-242.81601,-315.59635)\">
<path
d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
</g>
</svg>")
(defun notmuch-tag-tag-icon ()
"Return SVG data representing a tag icon.
This can be used with `notmuch-tag-format-image-data'."
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
<svg version=\"1.1\" width=\"16\" height=\"16\" xmlns=\"http://www.w3.org/2000/svg\">
<g transform=\"translate(0,-1036.3622)\">
<path
d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
style=\"fill:#ffff00;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.25;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-opacity:1\" />
</g>
</svg>")
;;; track history of tag operations
(defvar-local notmuch-tag-history nil
"Buffer local history of `notmuch-tag' function.")
(put 'notmuch-tag-history 'permanent-local t)
;;; Format Handling
(defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
"Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.")
(defun notmuch-tag-clear-cache ()
"Clear the internal cache of tag formats."
(clrhash notmuch-tag--format-cache))
(defun notmuch-tag--get-formats (tag alist)
"Find the first item whose car regexp-matches TAG."
(save-match-data
;; Don't use assoc-default since there's no way to distinguish a
;; missing key from a present key with a null cdr.
(cl-assoc tag alist
:test (lambda (tag key)
(and (eq (string-match key tag) 0)
(= (match-end 0) (length tag)))))))
(defun notmuch-tag--do-format (bare-tag tag formats)
"Apply a tag-formats entry to TAG."
(cond ((null formats) ;; - Tag not in `formats',
tag) ;; the format is the tag itself.
((null (cdr formats)) ;; - Tag was deliberately hidden,
nil) ;; no format must be returned
(t
;; Tag was found and has formats, we must apply all the
;; formats. TAG may be null so treat that as a special case.
(let ((return-tag (copy-sequence (or tag ""))))
(dolist (format (cdr formats))
(setq return-tag
(eval format
`((bare-tag . ,bare-tag)
(tag . ,return-tag)))))
(if (and (null tag) (equal return-tag ""))
nil
return-tag)))))
(defun notmuch-tag-format-tag (tags orig-tags tag)
"Format TAG according to `notmuch-tag-formats'.
TAGS and ORIG-TAGS are lists of the current tags and the original
tags; tags which have been deleted (i.e., are in ORIG-TAGS but
are not in TAGS) are shown using formats from
`notmuch-tag-deleted-formats'; tags which have been added (i.e.,
are in TAGS but are not in ORIG-TAGS) are shown using formats
from `notmuch-tag-added-formats' and tags which have not been
changed (the normal case) are shown using formats from
`notmuch-tag-formats'."
(let* ((tag-state (cond ((not (member tag tags)) 'deleted)
((not (member tag orig-tags)) 'added)))
(formatted-tag (gethash (cons tag tag-state)
notmuch-tag--format-cache
'missing)))
(when (eq formatted-tag 'missing)
(let ((base (notmuch-tag--get-formats tag notmuch-tag-formats))
(over (cl-case tag-state
(deleted (notmuch-tag--get-formats
tag notmuch-tag-deleted-formats))
(added (notmuch-tag--get-formats
tag notmuch-tag-added-formats))
(otherwise nil))))
(setq formatted-tag (notmuch-tag--do-format tag tag base))
(setq formatted-tag (notmuch-tag--do-format tag formatted-tag over))
(puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache)))
formatted-tag))
(defun notmuch-tag-format-tags (tags orig-tags &optional face)
"Return a string representing formatted TAGS."
(let ((face (or face 'notmuch-tag-face))
(all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<)))
(notmuch-apply-face
(mapconcat #'identity
;; nil indicated that the tag was deliberately hidden
(delq nil (mapcar (apply-partially #'notmuch-tag-format-tag
tags orig-tags)
all-tags))
" ")
face
t)))
;;; Hooks
(defcustom notmuch-before-tag-hook nil
"Hooks that are run before tags of a message are modified.
`tag-changes' will contain the tags that are about to be added or removed as
a list of strings of the form \"+TAG\" or \"-TAG\".
`query' will be a string containing the search query that determines
the messages that are about to be tagged."
:type 'hook
:options '(notmuch-hl-line-mode)
:group 'notmuch-hooks)
(defcustom notmuch-after-tag-hook nil
"Hooks that are run after tags of a message are modified.
`tag-changes' will contain the tags that were added or removed as
a list of strings of the form \"+TAG\" or \"-TAG\".
`query' will be a string containing the search query that determines
the messages that were tagged."
:type 'hook
:options '(notmuch-hl-line-mode)
:group 'notmuch-hooks)
;;; User Input
(defvar notmuch-select-tag-history nil
"Minibuffer history of `notmuch-select-tag-with-completion' function.")
(defvar notmuch-read-tag-changes-history nil
"Minibuffer history of `notmuch-read-tag-changes' function.")
(defun notmuch-tag-completions (&rest search-terms)
"Return a list of tags for messages matching SEARCH-TERMS.
Return all tags if no search terms are given."
(unless search-terms
(setq search-terms (list "*")))
(split-string
(with-output-to-string
(with-current-buffer standard-output
(apply 'notmuch--call-process notmuch-command nil t
nil "search" "--output=tags" "--exclude=false" search-terms)))
"\n+" t))
(defun notmuch-select-tag-with-completion (prompt &rest search-terms)
(completing-read prompt
(apply #'notmuch-tag-completions search-terms)
nil nil nil 'notmuch-select-tag-history))
(defun notmuch-read-tag-changes (current-tags &optional prompt initial-input)
"Prompt for tag changes in the minibuffer.
CURRENT-TAGS is a list of tags that are present on the message
or messages to be changed. These are offered as tag removal
completions. CURRENT-TAGS may contain duplicates. PROMPT, if
non-nil, is the query string to present in the minibuffer. It
defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the
initial input in the minibuffer."
(let* ((all-tag-list (notmuch-tag-completions))
(add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list))
(remove-tag-list (mapcar (apply-partially 'concat "-") current-tags))
(tag-list (append add-tag-list remove-tag-list))
(prompt (concat (or prompt "Tags") " (+add -drop): "))
(crm-separator " ")
;; By default, space is bound to "complete word" function.
;; Re-bind it to insert a space instead. Note that <tab>
;; still does the completion.
(crm-local-completion-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map crm-local-completion-map)
(define-key map " " 'self-insert-command)
map)))
(completing-read-multiple prompt tag-list
nil nil initial-input
'notmuch-read-tag-changes-history)))
;;; Tagging
(defun notmuch-update-tags (tags tag-changes)
"Return a copy of TAGS with additions and removals from TAG-CHANGES.
TAG-CHANGES must be a list of tags names, each prefixed with
either a \"+\" to indicate the tag should be added to TAGS if not
present or a \"-\" to indicate that the tag should be removed
from TAGS if present."
(let ((result-tags (copy-sequence tags)))
(dolist (tag-change tag-changes)
(let ((tag (and (not (string-empty-p tag-change))
(substring tag-change 1))))
(cl-case (aref tag-change 0)
(?+ (unless (member tag result-tags)
(push tag result-tags)))
(?- (setq result-tags (delete tag result-tags)))
(otherwise
(error "Changed tag must be of the form `+this_tag' or `-that_tag'")))))
(sort result-tags 'string<)))
(defconst notmuch-tag-argument-limit 1000
"Use batch tagging if the tagging query is longer than this.
This limits the length of arguments passed to the notmuch CLI to
avoid system argument length limits and performance problems.
NOTE: this variable is no longer used.")
(make-obsolete-variable 'notmuch-tag-argument-limit nil "notmuch 0.36")
(defun notmuch-tag (query tag-changes &optional omit-hist)
"Add/remove tags in TAG-CHANGES to messages matching QUERY.
QUERY should be a string containing the search-terms.
TAG-CHANGES is a list of strings of the form \"+tag\" or \"-tag\"
to add or remove tags, respectively. OMIT-HIST disables history
tracking if non-nil.
Note: Other code should always use this function to alter tags of
messages instead of running (notmuch-call-notmuch-process \"tag\" ..)
directly, so that hooks specified in notmuch-before-tag-hook and
notmuch-after-tag-hook will be run."
;; Perform some validation
(dolist (tag-change tag-changes)
(unless (string-match-p "^[-+]\\S-+$" tag-change)
(error "Tag must be of the form `+this_tag' or `-that_tag'")))
(unless query
(error "Nothing to tag!"))
(when tag-changes
(notmuch-dlet ((tag-changes tag-changes)
(query query))
(run-hooks 'notmuch-before-tag-hook))
(with-temp-buffer
(insert (concat (mapconcat #'notmuch-hex-encode tag-changes " ") " -- " query))
(unless (= 0
(notmuch--call-process-region
(point-min) (point-max) notmuch-command t t nil "tag" "--batch"))
(notmuch-logged-error "notmuch tag failed" (buffer-string))))
(unless omit-hist
(push (list :query query :tag-changes tag-changes) notmuch-tag-history)))
(notmuch-dlet ((tag-changes tag-changes)
(query query))
(run-hooks 'notmuch-after-tag-hook)))
(defun notmuch-tag-undo ()
"Undo the previous tagging operation in the current buffer. Uses
buffer local variable `notmuch-tag-history' to determine what
that operation was."
(interactive)
(when (null notmuch-tag-history)
(error "no further notmuch undo information"))
(let* ((action (pop notmuch-tag-history))
(query (plist-get action :query))
(changes (notmuch-tag-change-list (plist-get action :tag-changes) t)))
(notmuch-tag query changes t))
(notmuch-refresh-this-buffer))
(defun notmuch-tag-change-list (tags &optional reverse)
"Convert TAGS into a list of tag changes.
Add a \"+\" prefix to any tag in TAGS list that doesn't already
begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all
\"+\" prefixes with \"-\" and vice versa in the result."
(mapcar (lambda (str)
(let ((s (if (string-match "^[+-]" str) str (concat "+" str))))
(if reverse
(concat (if (= (string-to-char s) ?-) "+" "-")
(substring s 1))
s)))
tags))
(defvar notmuch-tag-jump-reverse-key "k"
"The key in tag-jump to switch to the reverse tag changes.")
(defun notmuch-tag-jump (reverse)
"Create a jump menu for tagging operations.
Creates and displays a jump menu for the tagging operations
specified in `notmuch-tagging-keys'. If REVERSE is set then it
offers a menu of the reverses of the operations specified in
`notmuch-tagging-keys'; i.e. each `+tag' is replaced by `-tag'
and vice versa."
;; In principle this function is simple, but it has to deal with
;; lots of cases: different modes (search/show/tree), whether a name
;; is specified, whether the tagging operations is a list of
;; tag-ops, or a symbol that evaluates to such a list, and whether
;; REVERSE is specified.
(interactive "P")
(let (action-map)
(pcase-dolist (`(,key ,tag ,name) notmuch-tagging-keys)
(let* ((tag-function (cl-case major-mode
(notmuch-search-mode #'notmuch-search-tag)
(notmuch-show-mode #'notmuch-show-tag)
(notmuch-tree-mode #'notmuch-tree-tag)))
(tag (if (symbolp tag)
(symbol-value tag)
tag))
(tag-change (if reverse
(notmuch-tag-change-list tag t)
tag))
(name (or (and (not (string= name ""))
name)
(and (symbolp name)
(symbol-name name))))
(name-string (if name
(if reverse
(concat "Reverse " name)
name)
(mapconcat #'identity tag-change " "))))
(push (list key name-string
(lambda () (funcall tag-function tag-change)))
action-map)))
(push (list notmuch-tag-jump-reverse-key
(if reverse
"Forward tag changes "
"Reverse tag changes")
(apply-partially 'notmuch-tag-jump (not reverse)))
action-map)
(setq action-map (nreverse action-map))
(notmuch-jump action-map "Tag: ")))
;;; _
(provide 'notmuch-tag)
;;; notmuch-tag.el ends here

1506
notmuch-tree.el Normal file
View file

File diff suppressed because it is too large Load diff

418
notmuch-wash.el Normal file
View file

@ -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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Carl Worth <cworth@cworth.org>
;; David Edmondson <dme@dme.org>
;;; Code:
(require 'coolj)
(require 'diff-mode)
(require 'notmuch-lib)
(declare-function notmuch-show-insert-bodypart "notmuch-show"
(msg part depth &optional hide))
(defvar notmuch-show-indent-messages-width)
;;; Options
(defgroup notmuch-wash nil
"Cleaning up messages for display."
:group 'notmuch)
(defcustom notmuch-wash-signature-regexp "^\\(-- ?\\|_+\\)$"
"Pattern to match a line that separates content from signature."
:type 'regexp
:group 'notmuch-wash)
(defcustom notmuch-wash-citation-regexp "\\(^[[:space:]]*>.*\n\\)+"
"Pattern to match citation lines."
:type 'regexp
:group 'notmuch-wash)
(defcustom notmuch-wash-original-regexp "^\\(--+\s?[oO]riginal [mM]essage\s?--+\\)$"
"Pattern to match a line that separates original message from
reply in top-posted message."
:type 'regexp
:group 'notmuch-wash)
(defcustom notmuch-wash-button-signature-hidden-format
"[ %d-line signature. Click/Enter to show. ]"
"String used to construct button text for hidden signatures.
Can use up to one integer format parameter, i.e. %d."
:type 'string
:group 'notmuch-wash)
(defcustom notmuch-wash-button-signature-visible-format
"[ %d-line signature. Click/Enter to hide. ]"
"String used to construct button text for visible signatures.
Can use up to one integer format parameter, i.e. %d."
:type 'string
:group 'notmuch-wash)
(defcustom notmuch-wash-button-citation-hidden-format
"[ %d more citation lines. Click/Enter to show. ]"
"String used to construct button text for hidden citations.
Can use up to one integer format parameter, i.e. %d."
:type 'string
:group 'notmuch-wash)
(defcustom notmuch-wash-button-citation-visible-format
"[ %d more citation lines. Click/Enter to hide. ]"
"String used to construct button text for visible citations.
Can use up to one integer format parameter, i.e. %d."
:type 'string
:group 'notmuch-wash)
(defcustom notmuch-wash-button-original-hidden-format
"[ %d-line hidden original message. Click/Enter to show. ]"
"String used to construct button text for hidden citations.
Can use up to one integer format parameter, i.e. %d."
:type 'string
:group 'notmuch-wash)
(defcustom notmuch-wash-button-original-visible-format
"[ %d-line original message. Click/Enter to hide. ]"
"String used to construct button text for visible citations.
Can use up to one integer format parameter, i.e. %d."
:type 'string
:group 'notmuch-wash)
(defcustom notmuch-wash-signature-lines-max 12
"Maximum length of signature that will be hidden by default."
:type 'integer
:group 'notmuch-wash)
(defcustom notmuch-wash-citation-lines-prefix 3
"Always show at least this many lines from the start of a citation.
If there is one more line than the sum of
`notmuch-wash-citation-lines-prefix' and
`notmuch-wash-citation-lines-suffix', show that, otherwise
collapse the remaining lines into a button."
:type 'integer
:group 'notmuch-wash)
(defcustom notmuch-wash-citation-lines-suffix 3
"Always show at least this many lines from the end of a citation.
If there is one more line than the sum of
`notmuch-wash-citation-lines-prefix' and
`notmuch-wash-citation-lines-suffix', show that, otherwise
collapse the remaining lines into a button."
:type 'integer
:group 'notmuch-wash)
(defcustom notmuch-wash-wrap-lines-length nil
"Wrap line after at most this many characters.
If this is nil, lines in messages will be wrapped to fit in the
current window. If this is a number, lines will be wrapped after
this many characters (ignoring indentation due to thread depth)
or at the window width (whichever one is lower)."
:type '(choice (const :tag "window width" nil)
(integer :tag "number of characters"))
:group 'notmuch-wash)
;;; Faces
(defface notmuch-wash-toggle-button
'((t (:inherit font-lock-comment-face)))
"Face used for buttons toggling the visibility of washed away
message parts."
:group 'notmuch-wash
:group 'notmuch-faces)
(defface notmuch-wash-cited-text
'((t (:inherit message-cited-text)))
"Face used for cited text."
:group 'notmuch-wash
:group 'notmuch-faces)
;;; Buttons
(defun notmuch-wash-toggle-invisible-action (cite-button)
;; Toggle overlay visibility
(let ((overlay (button-get cite-button 'overlay)))
(overlay-put overlay 'invisible (not (overlay-get overlay 'invisible))))
;; Update button text
(let* ((new-start (button-start cite-button))
(overlay (button-get cite-button 'overlay))
(button-label (notmuch-wash-button-label overlay))
(old-point (point))
(properties (text-properties-at (point)))
(inhibit-read-only t))
(goto-char new-start)
(insert button-label)
(set-text-properties new-start (point) properties)
(let ((old-end (button-end cite-button)))
(move-overlay cite-button new-start (point))
(delete-region (point) old-end))
(goto-char (min old-point (1- (button-end cite-button))))))
(define-button-type 'notmuch-wash-button-invisibility-toggle-type
'action 'notmuch-wash-toggle-invisible-action
'follow-link t
'face 'notmuch-wash-toggle-button
:supertype 'notmuch-button-type)
(define-button-type 'notmuch-wash-button-citation-toggle-type
'help-echo "mouse-1, RET: Show citation"
:supertype 'notmuch-wash-button-invisibility-toggle-type)
(define-button-type 'notmuch-wash-button-signature-toggle-type
'help-echo "mouse-1, RET: Show signature"
:supertype 'notmuch-wash-button-invisibility-toggle-type)
(define-button-type 'notmuch-wash-button-original-toggle-type
'help-echo "mouse-1, RET: Show original message"
:supertype 'notmuch-wash-button-invisibility-toggle-type)
(defun notmuch-wash-region-isearch-show (overlay)
(notmuch-wash-toggle-invisible-action
(overlay-get overlay 'notmuch-wash-button)))
(defun notmuch-wash-button-label (overlay)
(let* ((type (overlay-get overlay 'type))
(invis-spec (overlay-get overlay 'invisible))
(state (if (invisible-p invis-spec) "hidden" "visible"))
(label-format (symbol-value
(intern-soft
(format "notmuch-wash-button-%s-%s-format"
type state))))
(lines-count (count-lines (overlay-start overlay)
(overlay-end overlay))))
(format label-format lines-count)))
(defun notmuch-wash-region-to-button (beg end type &optional prefix)
"Auxiliary function to do the actual making of overlays and buttons.
BEG and END are buffer locations. TYPE should a string, either
\"citation\" or \"signature\". Optional PREFIX is some arbitrary
text to insert before the button, probably for indentation. Note
that PREFIX should not include a newline."
;; This uses some slightly tricky conversions between strings and
;; symbols because of the way the button code works. Note that
;; replacing intern-soft with make-symbol will cause this to fail,
;; since the newly created symbol has no plist.
(let ((overlay (make-overlay beg end))
(button-type (intern-soft (concat "notmuch-wash-button-"
type "-toggle-type"))))
(overlay-put overlay 'invisible t)
(overlay-put overlay 'isearch-open-invisible #'notmuch-wash-region-isearch-show)
(overlay-put overlay 'type type)
(goto-char (1+ end))
(save-excursion
(goto-char beg)
(when prefix
(insert-before-markers prefix))
(let ((button-beg (point)))
(insert-before-markers (notmuch-wash-button-label overlay) "\n")
(let ((button (make-button button-beg (1- (point))
'overlay overlay
:type button-type)))
(overlay-put overlay 'notmuch-wash-button button))))))
;;; Hook functions
(defun notmuch-wash-excerpt-citations (_msg _depth)
"Excerpt citations and up to one signature."
(goto-char (point-min))
(beginning-of-line)
(when (and (< (point) (point-max))
(re-search-forward notmuch-wash-original-regexp nil t))
(notmuch-wash-region-to-button (match-beginning 0)
(point-max)
"original"))
(while (and (< (point) (point-max))
(re-search-forward notmuch-wash-citation-regexp nil t))
(let* ((cite-start (match-beginning 0))
(cite-end (match-end 0))
(cite-lines (count-lines cite-start cite-end)))
(overlay-put (make-overlay cite-start cite-end)
'face 'notmuch-wash-cited-text)
(when (> cite-lines (+ notmuch-wash-citation-lines-prefix
notmuch-wash-citation-lines-suffix
1))
(goto-char cite-start)
(forward-line notmuch-wash-citation-lines-prefix)
(let ((hidden-start (point-marker)))
(goto-char cite-end)
(forward-line (- notmuch-wash-citation-lines-suffix))
(notmuch-wash-region-to-button
hidden-start (point-marker)
"citation")))))
(when (and (not (eobp))
(re-search-forward notmuch-wash-signature-regexp nil t))
(let ((sig-start (match-beginning 0)))
(when (<= (count-lines sig-start (point-max))
notmuch-wash-signature-lines-max)
(let ((sig-start-marker (make-marker))
(sig-end-marker (make-marker)))
(set-marker sig-start-marker sig-start)
(set-marker sig-end-marker (point-max))
(overlay-put (make-overlay sig-start-marker sig-end-marker)
'face 'message-cited-text)
(notmuch-wash-region-to-button
sig-start-marker sig-end-marker
"signature"))))))
(defun notmuch-wash-elide-blank-lines (_msg _depth)
"Elide leading, trailing and successive blank lines."
;; Algorithm derived from `article-strip-multiple-blank-lines' in
;; `gnus-art.el'.
;; Make all blank lines empty.
(goto-char (point-min))
(while (re-search-forward "^[[:space:]\t]+$" nil t)
(replace-match "" nil t))
;; Replace multiple empty lines with a single empty line.
(goto-char (point-min))
(while (re-search-forward "^\n\\(\n+\\)" nil t)
(delete-region (match-beginning 1) (match-end 1)))
;; Remove a leading blank line.
(goto-char (point-min))
(when (looking-at "\n")
(delete-region (match-beginning 0) (match-end 0)))
;; Remove a trailing blank line.
(goto-char (point-max))
(when (looking-at "\n")
(delete-region (match-beginning 0) (match-end 0))))
(defun notmuch-wash-tidy-citations (_msg _depth)
"Improve the display of cited regions of a message.
Perform several transformations on the message body:
- Remove lines of repeated citation leaders with no other
content,
- Remove citation leaders standing alone before a block of cited
text,
- Remove citation trailers standing alone after a block of cited
text."
;; Remove lines of repeated citation leaders with no other content.
(goto-char (point-min))
(while (re-search-forward "\\(^>[> ]*\n\\)\\{2,\\}" nil t)
(replace-match "\\1"))
;; Remove citation leaders standing alone before a block of cited text.
(goto-char (point-min))
(while (re-search-forward "\\(\n\\|^[^>].*\\)\n\\(^>[> ]*\n\\)" nil t)
(replace-match "\\1\n"))
;; Remove citation trailers standing alone after a block of cited text.
(goto-char (point-min))
(while (re-search-forward "\\(^>[> ]*\n\\)\\(^$\\|^[^>].*\\)" nil t)
(replace-match "\\2")))
(defun notmuch-wash-wrap-long-lines (_msg depth)
"Wrap long lines in the message.
If `notmuch-wash-wrap-lines-length' is a number, this will wrap
the message lines to the minimum of the width of the window or
its value. Otherwise, this function will wrap long lines in the
message at the window width. When doing so, citation leaders in
the wrapped text are maintained."
(let* ((coolj-wrap-follows-window-size nil)
(indent (* depth notmuch-show-indent-messages-width))
(limit (if (numberp notmuch-wash-wrap-lines-length)
(min (+ notmuch-wash-wrap-lines-length indent)
(window-width))
(window-width)))
(fill-column (- limit
indent
;; 2 to avoid poor interaction with
;; `word-wrap'.
2)))
(coolj-wrap-region (point-min) (point-max))))
;;;; Convert Inline Patches
(defun notmuch-wash-subject-to-filename (subject &optional maxlen)
"Convert a mail SUBJECT into a filename.
The resulting filename is similar to the names generated by \"git
format-patch\", without the leading patch sequence number
\"0001-\" and \".patch\" extension. Any leading \"[PREFIX]\"
style strings are removed prior to conversion.
Optional argument MAXLEN is the maximum length of the resulting
filename, before trimming any trailing . and - characters."
(let* ((s (replace-regexp-in-string "^ *\\(\\[[^]]*\\] *\\)*" "" subject))
(s (replace-regexp-in-string "[^A-Za-z0-9._]+" "-" s))
(s (replace-regexp-in-string "\\.+" "." s))
(s (if maxlen (substring s 0 (min (length s) maxlen)) s))
(s (replace-regexp-in-string "[.-]*$" "" s)))
s))
(defun notmuch-wash-subject-to-patch-sequence-number (subject)
"Convert a patch mail SUBJECT into a patch sequence number.
Return the patch sequence number N from the last \"[PATCH N/M]\"
style prefix in SUBJECT, or nil if such a prefix can't be found."
(and (string-match
"^ *\\(\\[[^]]*\\] *\\)*\\[[^]]*?\\([0-9]+\\)/[0-9]+[^]]*\\].*"
subject)
(string-to-number (substring subject (match-beginning 2) (match-end 2)))))
(defun notmuch-wash-subject-to-patch-filename (subject)
"Convert a patch mail SUBJECT into a filename.
The resulting filename is similar to the names generated by \"git
format-patch\". If the patch mail was generated and sent using
\"git format-patch/send-email\", this should re-create the
original filename the sender had."
(format "%04d-%s.patch"
(or (notmuch-wash-subject-to-patch-sequence-number subject) 1)
(notmuch-wash-subject-to-filename subject 52)))
(defun notmuch-wash-convert-inline-patch-to-part (msg depth)
"Convert an inline patch into a fake `text/x-diff' attachment.
Given that this function guesses whether a buffer includes a
patch and then guesses the extent of the patch, there is scope
for error."
(goto-char (point-min))
(when (re-search-forward diff-file-header-re nil t)
(beginning-of-line -1)
(let ((patch-start (point))
(patch-end (point-max))
part)
(goto-char patch-start)
(when (or
;; Patch ends with signature.
(re-search-forward notmuch-wash-signature-regexp nil t)
;; Patch ends with bugtraq comment.
(re-search-forward "^\\*\\*\\* " nil t))
(setq patch-end (match-beginning 0)))
(save-restriction
(narrow-to-region patch-start patch-end)
(setq part (plist-put part :content-type "inline patch"))
(setq part (plist-put part :content (buffer-string)))
(setq part (plist-put part :id -1))
(setq part (plist-put part :filename
(notmuch-wash-subject-to-patch-filename
(plist-get
(plist-get msg :headers) :Subject))))
(delete-region (point-min) (point-max))
(notmuch-show-insert-bodypart nil part depth)))))
;;; _
(provide 'notmuch-wash)
;;; notmuch-wash.el ends here

1269
notmuch.el Normal file
View file

File diff suppressed because it is too large Load diff

90
rstdoc.el Normal file
View file

@ -0,0 +1,90 @@
;;; rstdoc.el --- help generate documentation from docstrings -*- lexical-binding: t -*-
;; Copyright (C) 2018 David Bremner
;; Author: David Bremner <david@tethera.net>
;; Created: 26 May 2018
;; Keywords: emacs lisp, documentation
;; Homepage: https://notmuchmail.org
;; This file is not part of GNU Emacs.
;; rstdoc.el is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; rstdoc.el is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with rstdoc.el. If not, see <https://www.gnu.org/licenses/>.
;;
;;; Commentary:
;; Rstdoc provides a facility to extract all of the docstrings defined in
;; an elisp source file. Usage:
;;
;; emacs -Q --batch -L . -l rstdoc -f rstdoc-batch-extract foo.el foo.rsti
;;; Code:
(defun rstdoc-batch-extract ()
"Extract docstrings to and from the files on the command line."
(apply #'rstdoc-extract command-line-args-left))
(defun rstdoc-extract (in-file out-file)
"Write docstrings from IN-FILE to OUT-FILE."
(load-file in-file)
(let* ((definitions (cdr (assoc (expand-file-name in-file) load-history)))
(text-quoting-style 'grave)
(doc-hash (make-hash-table :test 'eq)))
(mapc
(lambda (elt)
(let ((pair
(pcase elt
(`(defun . ,name) (cons name (documentation name)))
(`(,_ . ,_) nil)
(sym (cons sym (get sym 'variable-documentation))))))
(when (and pair (cdr pair))
(puthash (car pair) (cdr pair) doc-hash))))
definitions)
(with-temp-buffer
(maphash
(lambda (key val)
(rstdoc--insert-docstring key val))
doc-hash)
(write-region (point-min) (point-max) out-file))))
(defun rstdoc--insert-docstring (symbol docstring)
(insert (format "\n.. |docstring::%s| replace::\n" symbol))
(insert (replace-regexp-in-string "^" " "
(rstdoc--rst-quote-string docstring)))
(insert "\n"))
(defvar rst--escape-alist
'( ("\\\\='" . "\001")
("`\\([^\n`']*\\)[`']" . "\002\\1\002") ;; good enough for now...
("`" . "\\\\`")
("\001" . "'")
("\002" . "`")
("[*]" . "\\\\*")
("^[[:space:]]*$" . "|br|")
("^[[:space:]]" . "|indent| "))
"list of (regex . replacement) pairs")
(defun rstdoc--rst-quote-string (str)
(with-temp-buffer
(insert str)
(dolist (pair rst--escape-alist)
(goto-char (point-min))
(while (re-search-forward (car pair) nil t)
(replace-match (cdr pair))))
(buffer-substring (point-min) (point-max))))
(provide 'rstdoc)
;;; rstdoc.el ends here

5
sync.sh Executable file
View file

@ -0,0 +1,5 @@
#!/bin/sh
git clone https://git.notmuchmail.org/git/notmuch ./_src
cp ./_src/emacs/*.el .
rm -rf ./_src