sync Wed, 12 Feb 2025 17:54:47 +0000
This commit is contained in:
commit
4e2176da44
23 changed files with 11800 additions and 0 deletions
145
coolj.el
Normal file
145
coolj.el
Normal 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
69
make-deps.el
Normal 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
436
notmuch-address.el
Normal 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
106
notmuch-company.el
Normal 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
58
notmuch-compat.el
Normal 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
272
notmuch-crypto.el
Normal 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
287
notmuch-draft.el
Normal 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
1027
notmuch-hello.el
Normal file
File diff suppressed because it is too large
Load diff
216
notmuch-jump.el
Normal file
216
notmuch-jump.el
Normal 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
1085
notmuch-lib.el
Normal file
File diff suppressed because it is too large
Load diff
364
notmuch-maildir-fcc.el
Normal file
364
notmuch-maildir-fcc.el
Normal 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
76
notmuch-message.el
Normal 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
679
notmuch-mua.el
Normal 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
194
notmuch-parser.el
Normal 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
100
notmuch-print.el
Normal 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
74
notmuch-query.el
Normal 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
2737
notmuch-show.el
Normal file
File diff suppressed because it is too large
Load diff
587
notmuch-tag.el
Normal file
587
notmuch-tag.el
Normal 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
1506
notmuch-tree.el
Normal file
File diff suppressed because it is too large
Load diff
418
notmuch-wash.el
Normal file
418
notmuch-wash.el
Normal 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
1269
notmuch.el
Normal file
File diff suppressed because it is too large
Load diff
90
rstdoc.el
Normal file
90
rstdoc.el
Normal 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
5
sync.sh
Executable file
|
|
@ -0,0 +1,5 @@
|
|||
#!/bin/sh
|
||||
|
||||
git clone https://git.notmuchmail.org/git/notmuch ./_src
|
||||
cp ./_src/emacs/*.el .
|
||||
rm -rf ./_src
|
||||
Loading…
Reference in a new issue