From: Ramakrishnan Muthukrishnan Date: Sun, 4 Aug 2013 03:54:20 +0000 (+0530) Subject: temporarily commiting emacs/notmuch X-Git-Url: https://git.rkrishnan.org/webform_css?a=commitdiff_plain;h=763ee60ec47d32dc93730814c4b7de5be6af76b3;p=.emacs.d.git temporarily commiting emacs/notmuch --- diff --git a/emacs/notmuch/.gitignore b/emacs/notmuch/.gitignore new file mode 100644 index 0000000..5421301 --- /dev/null +++ b/emacs/notmuch/.gitignore @@ -0,0 +1,2 @@ +.eldeps* +*.elc diff --git a/emacs/notmuch/Makefile b/emacs/notmuch/Makefile new file mode 100644 index 0000000..de492a7 --- /dev/null +++ b/emacs/notmuch/Makefile @@ -0,0 +1,7 @@ +# See Makefile.local for the list of files to be compiled in this +# directory. +all: + $(MAKE) -C .. all + +.DEFAULT: + $(MAKE) -C .. $@ diff --git a/emacs/notmuch/Makefile.local b/emacs/notmuch/Makefile.local new file mode 100644 index 0000000..a910aff --- /dev/null +++ b/emacs/notmuch/Makefile.local @@ -0,0 +1,59 @@ +# -*- makefile -*- + +dir := emacs +emacs_sources := \ + $(dir)/notmuch-lib.el \ + $(dir)/notmuch-parser.el \ + $(dir)/notmuch.el \ + $(dir)/notmuch-query.el \ + $(dir)/notmuch-show.el \ + $(dir)/notmuch-wash.el \ + $(dir)/notmuch-hello.el \ + $(dir)/notmuch-mua.el \ + $(dir)/notmuch-address.el \ + $(dir)/notmuch-maildir-fcc.el \ + $(dir)/notmuch-message.el \ + $(dir)/notmuch-crypto.el \ + $(dir)/notmuch-tag.el \ + $(dir)/coolj.el \ + $(dir)/notmuch-print.el + +emacs_images := \ + $(srcdir)/$(dir)/notmuch-logo.png + +emacs_bytecode = $(emacs_sources:.el=.elc) + +# Because of defmacro's and defsubst's, we have to account for load +# dependencies between Elisp files when byte compiling. Otherwise, +# the byte compiler may load an old .elc file when processing a +# "require" or we may fail to rebuild a .elc that depended on a macro +# from an updated file. +$(dir)/.eldeps: $(dir)/Makefile.local $(dir)/make-deps.el $(emacs_sources) + $(call quiet,EMACS) --directory emacs -batch -l make-deps.el \ + -f batch-make-deps $(emacs_sources) > $@.tmp && \ + (cmp -s $@.tmp $@ || mv $@.tmp $@) +-include $(dir)/.eldeps +CLEAN+=$(dir)/.eldeps $(dir)/.eldeps.tmp + +%.elc: %.el $(global_deps) + $(call quiet,EMACS) --directory emacs -batch -f batch-byte-compile $< + +ifeq ($(WITH_EMACS),1) +ifeq ($(HAVE_EMACS),1) +all: $(emacs_bytecode) +endif + +install: install-emacs +endif + +.PHONY: install-emacs +install-emacs: + mkdir -p "$(DESTDIR)$(emacslispdir)" + install -m0644 $(emacs_sources) "$(DESTDIR)$(emacslispdir)" +ifeq ($(HAVE_EMACS),1) + install -m0644 $(emacs_bytecode) "$(DESTDIR)$(emacslispdir)" +endif + mkdir -p "$(DESTDIR)$(emacsetcdir)" + install -m0644 $(emacs_images) "$(DESTDIR)$(emacsetcdir)" + +CLEAN := $(CLEAN) $(emacs_bytecode) diff --git a/emacs/notmuch/coolj.el b/emacs/notmuch/coolj.el new file mode 100644 index 0000000..60af60a --- /dev/null +++ b/emacs/notmuch/coolj.el @@ -0,0 +1,145 @@ +;;; coolj.el --- automatically wrap long lines -*- coding:utf-8 -*- + +;; Copyright (C) 2000, 2001, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Authors: Kai Grossjohann +;; Alex Schroeder +;; Chong Yidong +;; Maintainer: David Edmondson +;; Keywords: convenience, wp + +;; This file is not part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; This is a simple derivative of some functionality from +;;; `longlines.el'. The key difference is that this version will +;;; insert a prefix at the head of each wrapped line. The prefix is +;;; calculated from the originating long line. + +;;; No minor-mode is provided, the caller is expected to call +;;; `coolj-wrap-region' to wrap the region of interest. + +;;; Code: + +(defgroup coolj nil + "Wrapping of long lines with prefix." + :group 'fill) + +(defcustom coolj-wrap-follows-window-size t + "Non-nil means wrap text to the window size. +Otherwise respect `fill-column'." + :group 'coolj + :type 'boolean) + +(defcustom coolj-line-prefix-regexp "^\\(>+ \\)*" + "Regular expression that matches line prefixes." + :group 'coolj + :type 'regexp) + +(defvar coolj-wrap-point nil) + +(make-variable-buffer-local 'coolj-wrap-point) + +(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) + (if (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) diff --git a/emacs/notmuch/make-deps.el b/emacs/notmuch/make-deps.el new file mode 100644 index 0000000..a1cd731 --- /dev/null +++ b/emacs/notmuch/make-deps.el @@ -0,0 +1,66 @@ +;; make-deps.el --- compute make dependencies for Elisp sources +;; +;; Copyright © Austin Clements +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Austin Clements + +(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'." + + (setq dir (or 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)))) diff --git a/emacs/notmuch/notmuch-address.el b/emacs/notmuch/notmuch-address.el new file mode 100644 index 0000000..fa65cd5 --- /dev/null +++ b/emacs/notmuch/notmuch-address.el @@ -0,0 +1,118 @@ +;; notmuch-address.el --- address completion with notmuch +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: David Edmondson + +(require 'message) + +;; + +(defcustom notmuch-address-command "notmuch-addresses" + "The command which generates possible addresses. It must take a +single argument and output a list of possible matches, one per +line." + :type 'string + :group 'notmuch-send + :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-external) + +(defun notmuch-address-selection-function (prompt collection initial-input) + "Call (`completing-read' + PROMPT COLLECTION nil nil INITIAL-INPUT 'notmuch-address-history)" + (completing-read + prompt collection nil nil initial-input 'notmuch-address-history)) + +(defvar notmuch-address-message-alist-member + '("^\\(Resent-\\)?\\(To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" + . notmuch-address-expand-name)) + +(defvar notmuch-address-history nil) + +(defun notmuch-address-message-insinuate () + (unless (memq notmuch-address-message-alist-member message-completion-alist) + (setq message-completion-alist + (push notmuch-address-message-alist-member message-completion-alist)))) + +(defun notmuch-address-options (original) + (process-lines notmuch-address-command original)) + +(defun notmuch-address-expand-name () + (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 (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) + (cdr options) (car options)))))) + (if chosen + (progn + (push chosen notmuch-address-history) + (delete-region beg end) + (insert chosen)) + (message "No matches.") + (ding)))) + +;; Copied from `w3m-which-command'. +(defun notmuch-address-locate-command (command) + "Return non-nil if `command' is an executable either on +`exec-path' or an absolute pathname." + (when (stringp command) + (if (and (file-name-absolute-p command) + (file-executable-p command)) + command + (setq command (file-name-nondirectory command)) + (catch 'found-command + (let (bin) + (dolist (dir exec-path) + (setq bin (expand-file-name command dir)) + (when (or (and (file-executable-p bin) + (not (file-directory-p bin))) + (and (file-executable-p (setq bin (concat bin ".exe"))) + (not (file-directory-p bin)))) + (throw 'found-command bin)))))))) + +;; If we can find the program specified by `notmuch-address-command', +;; insinuate ourselves into `message-mode'. +(when (notmuch-address-locate-command notmuch-address-command) + (notmuch-address-message-insinuate)) + +;; + +(provide 'notmuch-address) diff --git a/emacs/notmuch/notmuch-crypto.el b/emacs/notmuch/notmuch-crypto.el new file mode 100644 index 0000000..5233824 --- /dev/null +++ b/emacs/notmuch/notmuch-crypto.el @@ -0,0 +1,175 @@ +;; notmuch-crypto.el --- functions for handling display of cryptographic metadata. +;; +;; Copyright © Jameson Rollins +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Jameson Rollins + +(require 'notmuch-lib) + +(defcustom notmuch-crypto-process-mime nil + "Should cryptographic MIME parts be processed? + +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 + :group 'notmuch-crypto) + +(defface notmuch-crypto-part-header + '((t (: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) + +(define-button-type 'notmuch-crypto-status-button-type + 'action (lambda (button) (message (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) + (let* ((status (plist-get sigstatus :status)) + (help-msg nil) + (label "Signature not processed") + (face 'notmuch-crypto-signature-unknown) + (button-action (lambda (button) (message (button-get button 'help-echo))))) + (cond + ((string= status "good") + (let ((fingerprint (concat "0x" (plist-get sigstatus :fingerprint)))) + ;; if userid present, userid has full or greater validity + (if (plist-member sigstatus :userid) + (let ((userid (plist-get sigstatus :userid))) + (setq label (concat "Good signature by: " userid)) + (setq face 'notmuch-crypto-signature-good)) + (progn + (setq label (concat "Good signature by key: " fingerprint)) + (setq face 'notmuch-crypto-signature-good-key))) + (setq button-action 'notmuch-crypto-sigstatus-good-callback) + (setq help-msg (concat "Click to list key ID 0x" fingerprint ".")))) + ((string= status "error") + (let ((keyid (concat "0x" (plist-get sigstatus :keyid)))) + (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 keyserver and redisplay.")))) + ((string= status "bad") + (let ((keyid (concat "0x" (plist-get sigstatus :keyid)))) + (setq label (concat "Bad signature (claimed key ID " keyid ")")) + (setq face 'notmuch-crypto-signature-bad))) + (t + (setq label "Unknown signature status") + (if status (setq label (concat label " \"" status "\""))))) + (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"))) + +(declare-function notmuch-show-refresh-view "notmuch-show" (&optional reset-state)) + +(defun notmuch-crypto-sigstatus-good-callback (button) + (let* ((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 t nil))) + (with-selected-window window + (with-current-buffer buffer + (goto-char (point-max)) + (call-process "gpg" nil t t "--list-keys" fingerprint)) + (recenter -1)))) + +(defun notmuch-crypto-sigstatus-error-callback (button) + (let* ((sigstatus (button-get button :notmuch-sigstatus)) + (keyid (concat "0x" (plist-get sigstatus :keyid))) + (buffer (get-buffer-create "*notmuch-crypto-gpg-out*")) + (window (display-buffer buffer t nil))) + (with-selected-window window + (with-current-buffer buffer + (goto-char (point-max)) + (call-process "gpg" nil t t "--recv-keys" keyid) + (insert "\n") + (call-process "gpg" nil t t "--list-keys" keyid)) + (recenter -1)) + (notmuch-show-refresh-view))) + +(defun notmuch-crypto-insert-encstatus-button (encstatus) + (let* ((status (plist-get encstatus :status)) + (help-msg nil) + (label "Decryption not attempted") + (face 'notmuch-crypto-decryption)) + (cond + ((string= status "good") + (setq label "Decryption successful")) + ((string= status "bad") + (setq label "Decryption error")) + (t + (setq label (concat "Unknown encstatus \"" status "\"")))) + (insert-button + (concat "[ " label " ]") + :type 'notmuch-crypto-status-button-type + 'help-echo help-msg + 'face face + 'mouse-face face) + (insert "\n"))) + +;; + +(provide 'notmuch-crypto) diff --git a/emacs/notmuch/notmuch-hello.el b/emacs/notmuch/notmuch-hello.el new file mode 100644 index 0000000..9db8c99 --- /dev/null +++ b/emacs/notmuch/notmuch-hello.el @@ -0,0 +1,821 @@ +;; notmuch-hello.el --- welcome to notmuch, a frontend +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: David Edmondson + +(eval-when-compile (require 'cl)) +(require 'widget) +(require 'wid-edit) ; For `widget-forward'. + +(require 'notmuch-lib) +(require 'notmuch-mua) + +(declare-function notmuch-search "notmuch" (&optional query oldest-first target-thread target-line continuation)) +(declare-function notmuch-poll "notmuch" ()) + +(defcustom notmuch-hello-recent-searches-max 10 + "The number of recent searches to display." + :type 'integer + :group 'notmuch-hello) + +(defcustom notmuch-show-empty-saved-searches nil + "Should saved searches with no messages be listed?" + :type 'boolean + :group 'notmuch-hello) + +(defun notmuch-sort-saved-searches (alist) + "Generate an alphabetically sorted saved searches alist." + (sort (copy-sequence alist) (lambda (a b) (string< (car a) (car b))))) + +(defcustom notmuch-saved-search-sort-function nil + "Function used to sort the saved searches for the notmuch-hello view. + +This variable controls how saved searches should be sorted. No +sorting (nil) displays the saved searches in the order they are +stored in `notmuch-saved-searches'. Sort alphabetically sorts the +saved searches in alphabetical order. Custom sort function should +be a function or a lambda expression that takes the saved +searches alist as a parameter, and returns a new saved searches +alist to be used." + :type '(choice (const :tag "No sorting" nil) + (const :tag "Sort alphabetically" notmuch-sort-saved-searches) + (function :tag "Custom sort function" + :value notmuch-sort-saved-searches)) + :group 'notmuch-hello) + +(defvar notmuch-hello-indent 4 + "How much to indent non-headers.") + +(defcustom notmuch-show-logo t + "Should the notmuch logo be shown?" + :type 'boolean + :group 'notmuch-hello) + +(defcustom notmuch-show-all-tags-list nil + "Should all tags be shown in the notmuch-hello view?" + :type 'boolean + :group 'notmuch-hello) + +(defcustom notmuch-hello-tag-list-make-query nil + "Function or string to generate queries for the all tags list. + +This variable controls which query results are shown for each tag +in the \"all tags\" list. If nil, it will use all messages with +that tag. If this is set to a string, it is used as a filter for +messages having that tag (equivalent to \"tag:TAG and (THIS-VARIABLE)\"). +Finally this can be a function that will be called for each tag and +should return a filter for that tag, or nil to hide the tag." + :type '(choice (const :tag "All messages" nil) + (const :tag "Unread messages" "tag:unread") + (string :tag "Custom filter" + :value "tag:unread") + (function :tag "Custom filter function")) + :group 'notmuch-hello) + +(defcustom notmuch-hello-hide-tags nil + "List of tags to be hidden in the \"all tags\"-section." + :type '(repeat string) + :group 'notmuch-hello) + +(defface notmuch-hello-logo-background + '((((class color) + (background dark)) + (:background "#5f5f5f")) + (((class color) + (background light)) + (:background "white"))) + "Background colour for the notmuch logo." + :group 'notmuch-hello + :group 'notmuch-faces) + +(defcustom notmuch-column-control t + "Controls the number of columns for saved searches/tags in notmuch view. + +This variable has three potential sets of values: + +- t: automatically calculate the number of columns possible based + on the tags to be shown and the window width, +- an integer: a lower bound on the number of characters that will + be used to display each column, +- a float: a fraction of the window width that is the lower bound + on the number of characters that should be used for each + column. + +So: +- if you would like two columns of tags, set this to 0.5. +- if you would like a single column of tags, set this to 1.0. +- if you would like tags to be 30 characters wide, set this to + 30. +- if you don't want to worry about all of this nonsense, leave + this set to `t'." + :type '(choice + (const :tag "Automatically calculated" t) + (integer :tag "Number of characters") + (float :tag "Fraction of window")) + :group 'notmuch-hello) + +(defcustom notmuch-hello-thousands-separator " " + "The string used as a thousands separator. + +Typically \",\" in the US and UK and \".\" or \" \" in Europe. +The latter is recommended in the SI/ISO 31-0 standard and by the +International Bureau of Weights and Measures." + :type 'string + :group 'notmuch-hello) + +(defcustom notmuch-hello-mode-hook nil + "Functions called after entering `notmuch-hello-mode'." + :type 'hook + :group 'notmuch-hello + :group 'notmuch-hooks) + +(defcustom notmuch-hello-refresh-hook nil + "Functions called after updating a `notmuch-hello' buffer." + :type 'hook + :group 'notmuch-hello + :group 'notmuch-hooks) + +(defvar notmuch-hello-url "http://notmuchmail.org" + "The `notmuch' web site.") + +(defvar notmuch-hello-custom-section-options + '((:filter (string :tag "Filter for each tag")) + (:filter-count (string :tag "Different filter to generate message counts")) + (:initially-hidden (const :tag "Hide this section on startup" t)) + (:show-empty-searches (const :tag "Show queries with no matching messages" t)) + (:hide-if-empty (const :tag "Hide this section if all queries are empty +\(and not shown by show-empty-searches)" t))) + "Various customization-options for notmuch-hello-tags/query-section.") + +(define-widget 'notmuch-hello-tags-section 'lazy + "Customize-type for notmuch-hello tag-list sections." + :tag "Customized tag-list section (see docstring for details)" + :type + `(list :tag "" + (const :tag "" notmuch-hello-insert-tags-section) + (string :tag "Title for this section") + (plist + :inline t + :options + ,(append notmuch-hello-custom-section-options + '((:hide-tags (repeat :tag "Tags that will be hidden" + string))))))) + +(define-widget 'notmuch-hello-query-section 'lazy + "Customize-type for custom saved-search-like sections" + :tag "Customized queries section (see docstring for details)" + :type + `(list :tag "" + (const :tag "" notmuch-hello-insert-searches) + (string :tag "Title for this section") + (repeat :tag "Queries" + (cons (string :tag "Name") (string :tag "Query"))) + (plist :inline t :options ,notmuch-hello-custom-section-options))) + +(defcustom notmuch-hello-sections + (list #'notmuch-hello-insert-header + #'notmuch-hello-insert-saved-searches + #'notmuch-hello-insert-search + #'notmuch-hello-insert-recent-searches + #'notmuch-hello-insert-alltags + #'notmuch-hello-insert-footer) + "Sections for notmuch-hello. + +The list contains functions which are used to construct sections in +notmuch-hello buffer. When notmuch-hello buffer is constructed, +these functions are run in the order they appear in this list. Each +function produces a section simply by adding content to the current +buffer. A section should not end with an empty line, because a +newline will be inserted after each section by `notmuch-hello'. + +Each function should take no arguments. The return value is +ignored. + +For convenience an element can also be a list of the form (FUNC ARG1 +ARG2 .. ARGN) in which case FUNC will be applied to the rest of the +list. + +A \"Customized tag-list section\" item in the customize-interface +displays a list of all tags, optionally hiding some of them. It +is also possible to filter the list of messages matching each tag +by an additional filter query. Similarly, the count of messages +displayed next to the buttons can be generated by applying a +different filter to the tag query. These filters are also +supported for \"Customized queries section\" items." + :group 'notmuch-hello + :type + '(repeat + (choice (function-item notmuch-hello-insert-header) + (function-item notmuch-hello-insert-saved-searches) + (function-item notmuch-hello-insert-search) + (function-item notmuch-hello-insert-recent-searches) + (function-item notmuch-hello-insert-alltags) + (function-item notmuch-hello-insert-footer) + (function-item notmuch-hello-insert-inbox) + notmuch-hello-tags-section + notmuch-hello-query-section + (function :tag "Custom section")))) + +(defvar notmuch-hello-hidden-sections nil + "List of sections titles whose contents are hidden") + +(defvar notmuch-hello-first-run t + "True if `notmuch-hello' is run for the first time, set to nil +afterwards.") + +(defun notmuch-hello-nice-number (n) + (let (result) + (while (> n 0) + (push (% n 1000) result) + (setq n (/ n 1000))) + (setq result (or result '(0))) + (apply #'concat + (number-to-string (car result)) + (mapcar (lambda (elem) + (format "%s%03d" notmuch-hello-thousands-separator elem)) + (cdr result))))) + +(defun notmuch-hello-trim (search) + "Trim whitespace." + (if (string-match "^[[:space:]]*\\(.*[^[:space:]]\\)[[:space:]]*$" search) + (match-string 1 search) + search)) + +(defun notmuch-hello-search (&optional search) + (interactive) + (unless (null search) + (setq search (notmuch-hello-trim search)) + (let ((history-delete-duplicates t)) + (add-to-history 'notmuch-search-history search))) + (notmuch-search search notmuch-search-oldest-first nil nil + #'notmuch-hello-search-continuation)) + +(defun notmuch-hello-add-saved-search (widget) + (interactive) + (let ((search (widget-value + (symbol-value + (widget-get widget :notmuch-saved-search-widget)))) + (name (completing-read "Name for saved search: " + notmuch-saved-searches))) + ;; If an existing saved search with this name exists, remove it. + (setq notmuch-saved-searches + (loop for elem in notmuch-saved-searches + if (not (equal name + (car elem))) + collect elem)) + ;; Add the new one. + (customize-save-variable 'notmuch-saved-searches + (add-to-list 'notmuch-saved-searches + (cons name search) t)) + (message "Saved '%s' as '%s'." search name) + (notmuch-hello-update))) + +(defun notmuch-hello-delete-search-from-history (widget) + (interactive) + (let ((search (widget-value + (symbol-value + (widget-get widget :notmuch-saved-search-widget))))) + (setq notmuch-search-history (delete search + notmuch-search-history)) + (notmuch-hello-update))) + +(defun notmuch-hello-longest-label (searches-alist) + (or (loop for elem in searches-alist + maximize (length (car elem))) + 0)) + +(defun notmuch-hello-reflect-generate-row (ncols nrows row list) + (let ((len (length list))) + (loop for col from 0 to (- ncols 1) + collect (let ((offset (+ (* nrows col) row))) + (if (< offset len) + (nth offset list) + ;; Don't forget to insert an empty slot in the + ;; output matrix if there is no corresponding + ;; value in the input matrix. + nil))))) + +(defun notmuch-hello-reflect (list ncols) + "Reflect a `ncols' wide matrix represented by `list' along the +diagonal." + ;; Not very lispy... + (let ((nrows (ceiling (length list) ncols))) + (loop for row from 0 to (- nrows 1) + append (notmuch-hello-reflect-generate-row ncols nrows row list)))) + +(defun notmuch-hello-widget-search (widget &rest ignore) + (notmuch-search (widget-get widget + :notmuch-search-terms) + notmuch-search-oldest-first + nil nil #'notmuch-hello-search-continuation)) + +(defun notmuch-saved-search-count (search) + (car (process-lines notmuch-command "count" search))) + +(defun notmuch-hello-tags-per-line (widest) + "Determine how many tags to show per line and how wide they +should be. Returns a cons cell `(tags-per-line width)'." + (let ((tags-per-line + (cond + ((integerp notmuch-column-control) + (max 1 + (/ (- (window-width) notmuch-hello-indent) + ;; Count is 9 wide (8 digits plus space), 1 for the space + ;; after the name. + (+ 9 1 (max notmuch-column-control widest))))) + + ((floatp notmuch-column-control) + (let* ((available-width (- (window-width) notmuch-hello-indent)) + (proposed-width (max (* available-width notmuch-column-control) widest))) + (floor available-width proposed-width))) + + (t + (max 1 + (/ (- (window-width) notmuch-hello-indent) + ;; Count is 9 wide (8 digits plus space), 1 for the space + ;; after the name. + (+ 9 1 widest))))))) + + (cons tags-per-line (/ (max 1 + (- (window-width) notmuch-hello-indent + ;; Count is 9 wide (8 digits plus + ;; space), 1 for the space after the + ;; name. + (* tags-per-line (+ 9 1)))) + tags-per-line)))) + +(defun notmuch-hello-filtered-query (query filter) + "Constructs a query to search all messages matching QUERY and FILTER. + +If FILTER is a string, it is directly used in the returned query. + +If FILTER is a function, it is called with QUERY as a parameter and +the string it returns is used as the query. If nil is returned, +the entry is hidden. + +Otherwise, FILTER is ignored. +" + (cond + ((functionp filter) (funcall filter query)) + ((stringp filter) + (concat "(" query ") and (" filter ")")) + (t query))) + +(defun notmuch-hello-query-counts (query-alist &rest options) + "Compute list of counts of matched messages from QUERY-ALIST. + +QUERY-ALIST must be a list containing elements of the form (NAME . QUERY) +or (NAME QUERY COUNT-QUERY). If the latter form is used, +COUNT-QUERY specifies an alternate query to be used to generate +the count for the associated query. + +The result is the list of elements of the form (NAME QUERY COUNT). + +The values :show-empty-searches, :filter and :filter-count from +options will be handled as specified for +`notmuch-hello-insert-searches'." + (with-temp-buffer + (dolist (elem query-alist nil) + (let ((count-query (if (consp (cdr elem)) + ;; do we have a different query for the message count? + (third elem) + (cdr elem)))) + (insert + (notmuch-hello-filtered-query count-query + (or (plist-get options :filter-count) + (plist-get options :filter))) + "\n"))) + + (unless (= (call-process-region (point-min) (point-max) notmuch-command + t t nil "count" "--batch") 0) + (notmuch-logged-error "notmuch count --batch failed" + "Please check that the notmuch CLI is new enough to support `count +--batch'. In general we recommend running matching versions of +the CLI and emacs interface.")) + + (goto-char (point-min)) + + (notmuch-remove-if-not + #'identity + (mapcar + (lambda (elem) + (let ((name (car elem)) + (search-query (if (consp (cdr elem)) + ;; do we have a different query for the message count? + (second elem) + (cdr elem))) + (message-count (prog1 (read (current-buffer)) + (forward-line 1)))) + (and (or (plist-get options :show-empty-searches) (> message-count 0)) + (list name (notmuch-hello-filtered-query + search-query (plist-get options :filter)) + message-count)))) + query-alist)))) + +(defun notmuch-hello-insert-buttons (searches) + "Insert buttons for SEARCHES. + +SEARCHES must be a list containing lists of the form (NAME QUERY COUNT), where +QUERY is the query to start when the button for the corresponding entry is +activated. COUNT should be the number of messages matching the query. +Such a list can be computed with `notmuch-hello-query-counts'." + (let* ((widest (notmuch-hello-longest-label searches)) + (tags-and-width (notmuch-hello-tags-per-line widest)) + (tags-per-line (car tags-and-width)) + (column-width (cdr tags-and-width)) + (column-indent 0) + (count 0) + (reordered-list (notmuch-hello-reflect searches tags-per-line)) + ;; Hack the display of the buttons used. + (widget-push-button-prefix "") + (widget-push-button-suffix "")) + ;; dme: It feels as though there should be a better way to + ;; implement this loop than using an incrementing counter. + (mapc (lambda (elem) + ;; (not elem) indicates an empty slot in the matrix. + (when elem + (if (> column-indent 0) + (widget-insert (make-string column-indent ? ))) + (let* ((name (first elem)) + (query (second elem)) + (msg-count (third elem))) + (widget-insert (format "%8s " + (notmuch-hello-nice-number msg-count))) + (widget-create 'push-button + :notify #'notmuch-hello-widget-search + :notmuch-search-terms query + name) + (setq column-indent + (1+ (max 0 (- column-width (length name))))))) + (setq count (1+ count)) + (when (eq (% count tags-per-line) 0) + (setq column-indent 0) + (widget-insert "\n"))) + reordered-list) + + ;; If the last line was not full (and hence did not include a + ;; carriage return), insert one now. + (unless (eq (% count tags-per-line) 0) + (widget-insert "\n")))) + +(defimage notmuch-hello-logo ((:type png :file "notmuch-logo.png"))) + +(defun notmuch-hello-search-continuation() + (notmuch-hello-update t)) + +(defun notmuch-hello-update (&optional no-display) + "Update the current notmuch view." + ;; Lazy - rebuild everything. + (interactive) + (notmuch-hello no-display)) + +(defun notmuch-hello-poll-and-update () + "Invoke `notmuch-poll' to import mail, then refresh the current view." + (interactive) + (notmuch-poll) + (notmuch-hello-update)) + + +(defvar notmuch-hello-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-keymap) + (define-key map "v" (lambda () "Display the notmuch version" (interactive) + (message "notmuch version %s" (notmuch-version)))) + (define-key map "?" 'notmuch-help) + (define-key map "q" 'notmuch-kill-this-buffer) + (define-key map "=" 'notmuch-hello-update) + (define-key map "G" 'notmuch-hello-poll-and-update) + (define-key map (kbd "") 'widget-backward) + (define-key map "m" 'notmuch-mua-new-mail) + (define-key map "s" 'notmuch-hello-search) + map) + "Keymap for \"notmuch hello\" buffers.") +(fset 'notmuch-hello-mode-map notmuch-hello-mode-map) + +(defun notmuch-hello-mode () + "Major mode for convenient notmuch navigation. This is your entry portal into notmuch. + +Complete list of currently available key bindings: + +\\{notmuch-hello-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map notmuch-hello-mode-map) + (setq major-mode 'notmuch-hello-mode + mode-name "notmuch-hello") + (run-mode-hooks 'notmuch-hello-mode-hook) + ;;(setq buffer-read-only t) +) + +(defun notmuch-hello-generate-tag-alist (&optional hide-tags) + "Return an alist from tags to queries to display in the all-tags section." + (mapcar (lambda (tag) + (cons tag (concat "tag:" (notmuch-escape-boolean-term tag)))) + (notmuch-remove-if-not + (lambda (tag) + (not (member tag hide-tags))) + (process-lines notmuch-command "search" "--output=tags" "*")))) + +(defun notmuch-hello-insert-header () + "Insert the default notmuch-hello header." + (when notmuch-show-logo + (let ((image notmuch-hello-logo)) + ;; The notmuch logo uses transparency. That can display poorly + ;; when inserting the image into an emacs buffer (black logo on + ;; a black background), so force the background colour of the + ;; image. We use a face to represent the colour so that + ;; `defface' can be used to declare the different possible + ;; colours, which depend on whether the frame has a light or + ;; dark background. + (setq image (cons 'image + (append (cdr image) + (list :background (face-background 'notmuch-hello-logo-background))))) + (insert-image image)) + (widget-insert " ")) + + (widget-insert "Welcome to ") + ;; Hack the display of the links used. + (let ((widget-link-prefix "") + (widget-link-suffix "")) + (widget-create 'link + :notify (lambda (&rest ignore) + (browse-url notmuch-hello-url)) + :help-echo "Visit the notmuch website." + "notmuch") + (widget-insert ". ") + (widget-insert "You have ") + (widget-create 'link + :notify (lambda (&rest ignore) + (notmuch-hello-update)) + :help-echo "Refresh" + (notmuch-hello-nice-number + (string-to-number (car (process-lines notmuch-command "count"))))) + (widget-insert " messages.\n"))) + + +(defun notmuch-hello-insert-saved-searches () + "Insert the saved-searches section." + (let ((searches (notmuch-hello-query-counts + (if notmuch-saved-search-sort-function + (funcall notmuch-saved-search-sort-function + notmuch-saved-searches) + notmuch-saved-searches) + :show-empty-searches notmuch-show-empty-saved-searches))) + (when searches + (widget-insert "Saved searches: ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (customize-variable 'notmuch-saved-searches)) + "edit") + (widget-insert "\n\n") + (let ((start (point))) + (notmuch-hello-insert-buttons searches) + (indent-rigidly start (point) notmuch-hello-indent))))) + +(defun notmuch-hello-insert-search () + "Insert a search widget." + (widget-insert "Search: ") + (widget-create 'editable-field + ;; Leave some space at the start and end of the + ;; search boxes. + :size (max 8 (- (window-width) notmuch-hello-indent + (length "Search: "))) + :action (lambda (widget &rest ignore) + (notmuch-hello-search (widget-value widget)))) + ;; Add an invisible dot to make `widget-end-of-line' ignore + ;; trailing spaces in the search widget field. A dot is used + ;; instead of a space to make `show-trailing-whitespace' + ;; happy, i.e. avoid it marking the whole line as trailing + ;; spaces. + (widget-insert ".") + (put-text-property (1- (point)) (point) 'invisible t) + (widget-insert "\n")) + +(defun notmuch-hello-insert-recent-searches () + "Insert recent searches." + (when notmuch-search-history + (widget-insert "Recent searches: ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (when (y-or-n-p "Are you sure you want to clear the searches? ") + (setq notmuch-search-history nil) + (notmuch-hello-update))) + "clear") + (widget-insert "\n\n") + (let ((start (point))) + (loop for i from 1 to notmuch-hello-recent-searches-max + for search in notmuch-search-history do + (let ((widget-symbol (intern (format "notmuch-hello-search-%d" i)))) + (set widget-symbol + (widget-create 'editable-field + ;; Don't let the search boxes be + ;; less than 8 characters wide. + :size (max 8 + (- (window-width) + ;; Leave some space + ;; at the start and + ;; end of the + ;; boxes. + (* 2 notmuch-hello-indent) + ;; 1 for the space + ;; before the + ;; `[save]' button. 6 + ;; for the `[save]' + ;; button. + 1 6 + ;; 1 for the space + ;; before the `[del]' + ;; button. 5 for the + ;; `[del]' button. + 1 5)) + :action (lambda (widget &rest ignore) + (notmuch-hello-search (widget-value widget))) + search)) + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (widget &rest ignore) + (notmuch-hello-add-saved-search widget)) + :notmuch-saved-search-widget widget-symbol + "save") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (widget &rest ignore) + (when (y-or-n-p "Are you sure you want to delete this search? ") + (notmuch-hello-delete-search-from-history widget))) + :notmuch-saved-search-widget widget-symbol + "del")) + (widget-insert "\n")) + (indent-rigidly start (point) notmuch-hello-indent)) + nil)) + +(defun notmuch-hello-insert-searches (title query-alist &rest options) + "Insert a section with TITLE showing a list of buttons made from QUERY-ALIST. + +QUERY-ALIST must be a list containing elements of the form (NAME . QUERY) +or (NAME QUERY COUNT-QUERY). If the latter form is used, +COUNT-QUERY specifies an alternate query to be used to generate +the count for the associated item. + +Supports the following entries in OPTIONS as a plist: +:initially-hidden - if non-nil, section will be hidden on startup +:show-empty-searches - show buttons with no matching messages +:hide-if-empty - hide if no buttons would be shown + (only makes sense without :show-empty-searches) +:filter - This can be a function that takes the search query as its argument and + returns a filter to be used in conjuction with the query for that search or nil + to hide the element. This can also be a string that is used as a combined with + each query using \"and\". +:filter-count - Separate filter to generate the count displayed each search. Accepts + the same values as :filter. If :filter and :filter-count are specified, this + will be used instead of :filter, not in conjunction with it." + (widget-insert title ": ") + (if (and notmuch-hello-first-run (plist-get options :initially-hidden)) + (add-to-list 'notmuch-hello-hidden-sections title)) + (let ((is-hidden (member title notmuch-hello-hidden-sections)) + (start (point))) + (if is-hidden + (widget-create 'push-button + :notify `(lambda (widget &rest ignore) + (setq notmuch-hello-hidden-sections + (delete ,title notmuch-hello-hidden-sections)) + (notmuch-hello-update)) + "show") + (widget-create 'push-button + :notify `(lambda (widget &rest ignore) + (add-to-list 'notmuch-hello-hidden-sections + ,title) + (notmuch-hello-update)) + "hide")) + (widget-insert "\n") + (when (not is-hidden) + (let ((searches (apply 'notmuch-hello-query-counts query-alist options))) + (when (or (not (plist-get options :hide-if-empty)) + searches) + (widget-insert "\n") + (notmuch-hello-insert-buttons searches) + (indent-rigidly start (point) notmuch-hello-indent)))))) + +(defun notmuch-hello-insert-tags-section (&optional title &rest options) + "Insert a section displaying all tags with message counts. + +TITLE defaults to \"All tags\". +Allowed options are those accepted by `notmuch-hello-insert-searches' and the +following: + +:hide-tags - List of tags that should be excluded." + (apply 'notmuch-hello-insert-searches + (or title "All tags") + (notmuch-hello-generate-tag-alist (plist-get options :hide-tags)) + options)) + +(defun notmuch-hello-insert-inbox () + "Show an entry for each saved search and inboxed messages for each tag" + (notmuch-hello-insert-searches "What's in your inbox" + (append + notmuch-saved-searches + (notmuch-hello-generate-tag-alist)) + :filter "tag:inbox")) + +(defun notmuch-hello-insert-alltags () + "Insert a section displaying all tags and associated message counts" + (notmuch-hello-insert-tags-section + nil + :initially-hidden (not notmuch-show-all-tags-list) + :hide-tags notmuch-hello-hide-tags + :filter notmuch-hello-tag-list-make-query)) + +(defun notmuch-hello-insert-footer () + "Insert the notmuch-hello footer." + (let ((start (point))) + (widget-insert "Type a search query and hit RET to view matching threads.\n") + (when notmuch-search-history + (widget-insert "Hit RET to re-submit a previous search. Edit it first if you like.\n") + (widget-insert "Save recent searches with the `save' button.\n")) + (when notmuch-saved-searches + (widget-insert "Edit saved searches with the `edit' button.\n")) + (widget-insert "Hit RET or click on a saved search or tag name to view matching threads.\n") + (widget-insert "`=' to refresh this screen. `s' to search messages. `q' to quit.\n") + (widget-create 'link + :notify (lambda (&rest ignore) + (customize-variable 'notmuch-hello-sections)) + :button-prefix "" :button-suffix "" + "Customize") + (widget-insert " this page.") + (let ((fill-column (- (window-width) notmuch-hello-indent))) + (center-region start (point))))) + +;;;###autoload +(defun notmuch-hello (&optional no-display) + "Run notmuch and display saved searches, known tags, etc." + (interactive) + + (if no-display + (set-buffer "*notmuch-hello*") + (switch-to-buffer "*notmuch-hello*")) + + (let ((target-line (line-number-at-pos)) + (target-column (current-column)) + (inhibit-read-only t)) + + ;; Delete all editable widget fields. Editable widget fields are + ;; tracked in a buffer local variable `widget-field-list' (and + ;; others). If we do `erase-buffer' without properly deleting the + ;; widgets, some widget-related functions are confused later. + (mapc 'widget-delete widget-field-list) + + (erase-buffer) + + (unless (eq major-mode 'notmuch-hello-mode) + (notmuch-hello-mode)) + + (let ((all (overlay-lists))) + ;; Delete all the overlays. + (mapc 'delete-overlay (car all)) + (mapc 'delete-overlay (cdr all))) + + (mapc + (lambda (section) + (let ((point-before (point))) + (if (functionp section) + (funcall section) + (apply (car section) (cdr section))) + ;; don't insert a newline when the previous section didn't + ;; show anything. + (unless (eq (point) point-before) + (widget-insert "\n")))) + notmuch-hello-sections) + (widget-setup) + + ;; Move point back to where it was before refresh. Use line and + ;; column instead of point directly to be insensitive to additions + ;; and removals of text within earlier lines. + (goto-char (point-min)) + (forward-line (1- target-line)) + (move-to-column target-column)) + (run-hooks 'notmuch-hello-refresh-hook) + (setq notmuch-hello-first-run nil)) + +(defun notmuch-folder () + "Deprecated function for invoking notmuch---calling `notmuch' is preferred now." + (interactive) + (notmuch-hello)) + +;; + +(provide 'notmuch-hello) diff --git a/emacs/notmuch/notmuch-lib.el b/emacs/notmuch/notmuch-lib.el new file mode 100644 index 0000000..4796f17 --- /dev/null +++ b/emacs/notmuch/notmuch-lib.el @@ -0,0 +1,566 @@ +;; notmuch-lib.el --- common variables, functions and function declarations +;; +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Carl Worth + +;; This is an part of an emacs-based interface to the notmuch mail system. + +(require 'mm-view) +(require 'mm-decode) +(require 'cl) + +(defvar notmuch-command "notmuch" + "Command to run the notmuch binary.") + +(defgroup notmuch nil + "Notmuch mail reader for Emacs." + :group 'mail) + +(defgroup notmuch-hello nil + "Overview of saved searches, tags, etc." + :group 'notmuch) + +(defgroup notmuch-search nil + "Searching and sorting mail." + :group 'notmuch) + +(defgroup notmuch-show nil + "Showing messages and threads." + :group 'notmuch) + +(defgroup notmuch-send nil + "Sending messages from Notmuch." + :group 'notmuch) + +(custom-add-to-group 'notmuch-send 'message 'custom-group) + +(defgroup notmuch-crypto nil + "Processing and display of cryptographic MIME parts." + :group 'notmuch) + +(defgroup notmuch-hooks nil + "Running custom code on well-defined occasions." + :group 'notmuch) + +(defgroup notmuch-external nil + "Running external commands from within Notmuch." + :group 'notmuch) + +(defgroup notmuch-faces nil + "Graphical attributes for displaying text" + :group 'notmuch) + +(defcustom notmuch-search-oldest-first t + "Show the oldest mail first when searching. + +This variable defines the default sort order for displaying +search results. Note that any filtered searches created by +`notmuch-search-filter' retain the search order of the parent +search." + :type 'boolean + :group 'notmuch-search) + +;; + +(defvar notmuch-search-history nil + "Variable to store notmuch searches history.") + +(defcustom notmuch-saved-searches '(("inbox" . "tag:inbox") + ("unread" . "tag:unread")) + "A list of saved searches to display." + :type '(alist :key-type string :value-type string) + :group 'notmuch-hello) + +(defcustom notmuch-archive-tags '("-inbox") + "List of tag changes to apply to a message or a thread when it is archived. + +Tags starting with \"+\" (or not starting with either \"+\" or +\"-\") in the list will be added, and tags starting with \"-\" +will be removed from the message or thread being archived. + +For example, if you wanted to remove an \"inbox\" tag and add an +\"archived\" tag, you would set: + (\"-inbox\" \"+archived\")" + :type '(repeat string) + :group 'notmuch-search + :group 'notmuch-show) + +;; By default clicking on a button does not select the window +;; containing the button (as opposed to clicking on a widget which +;; does). This means that the button action is then executed in the +;; current selected window which can cause problems if the button +;; changes the buffer (e.g., id: links) or moves point. +;; +;; This provides a button type which overrides mouse-action so that +;; the button's window is selected before the action is run. Other +;; notmuch buttons can get the same behaviour by inheriting from this +;; button type. +(define-button-type 'notmuch-button-type + 'mouse-action (lambda (button) + (select-window (posn-window (event-start last-input-event))) + (button-activate button))) + +(defun notmuch-command-to-string (&rest args) + "Synchronously invoke \"notmuch\" with the given list of arguments. + +If notmuch exits with a non-zero status, output from the process +will appear in a buffer named \"*Notmuch errors*\" and an error +will be signaled. + +Otherwise the output will be returned" + (with-temp-buffer + (let* ((status (apply #'call-process notmuch-command nil t nil args)) + (output (buffer-string))) + (notmuch-check-exit-status status (cons notmuch-command args) output) + output))) + +(defun notmuch-version () + "Return a string with the notmuch version number." + (let ((long-string + ;; Trim off the trailing newline. + (substring (notmuch-command-to-string "--version") 0 -1))) + (if (string-match "^notmuch\\( version\\)? \\(.*\\)$" + long-string) + (match-string 2 long-string) + "unknown"))) + +(defun notmuch-config-get (item) + "Return a value from the notmuch configuration." + ;; Trim off the trailing newline + (substring (notmuch-command-to-string "config" "get" item) 0 -1)) + +(defun notmuch-database-path () + "Return the database.path value from the notmuch configuration." + (notmuch-config-get "database.path")) + +(defun notmuch-user-name () + "Return the user.name value from the notmuch configuration." + (notmuch-config-get "user.name")) + +(defun notmuch-user-primary-email () + "Return the user.primary_email value from the notmuch configuration." + (notmuch-config-get "user.primary_email")) + +(defun notmuch-user-other-email () + "Return the user.other_email value (as a list) from the notmuch configuration." + (split-string (notmuch-config-get "user.other_email") "\n")) + +(defun notmuch-kill-this-buffer () + "Kill the current buffer." + (interactive) + (kill-buffer (current-buffer))) + +(defun notmuch-prettify-subject (subject) + ;; This function is used by `notmuch-search-process-filter' which + ;; requires that we not disrupt its' matching state. + (save-match-data + (if (and subject + (string-match "^[ \t]*$" subject)) + "[No Subject]" + subject))) + +(defun notmuch-escape-boolean-term (term) + "Escape a boolean term for use in a query. + +The caller is responsible for prepending the term prefix and a +colon. This performs minimal escaping in order to produce +user-friendly queries." + + (save-match-data + (if (or (equal term "") + (string-match "[ ()]\\|^\"" term)) + ;; Requires escaping + (concat "\"" (replace-regexp-in-string "\"" "\"\"" term t t) "\"") + term))) + +(defun notmuch-id-to-query (id) + "Return a query that matches the message with id ID." + (concat "id:" (notmuch-escape-boolean-term id))) + +;; + +(defun notmuch-common-do-stash (text) + "Common function to stash text in kill ring, and display in minibuffer." + (if text + (progn + (kill-new text) + (message "Stashed: %s" text)) + ;; There is nothing to stash so stash an empty string so the user + ;; doesn't accidentally paste something else somewhere. + (kill-new "") + (message "Nothing to stash!"))) + +;; + +(defun notmuch-remove-if-not (predicate list) + "Return a copy of LIST with all items not satisfying PREDICATE removed." + (let (out) + (while list + (when (funcall predicate (car list)) + (push (car list) out)) + (setq list (cdr list))) + (nreverse out))) + +(defun notmuch-split-content-type (content-type) + "Split content/type into 'content' and 'type'" + (split-string content-type "/")) + +(defun notmuch-match-content-type (t1 t2) + "Return t if t1 and t2 are matching content types, taking wildcards into account" + (let ((st1 (notmuch-split-content-type t1)) + (st2 (notmuch-split-content-type t2))) + (if (or (string= (cadr st1) "*") + (string= (cadr st2) "*")) + ;; Comparison of content types should be case insensitive. + (string= (downcase (car st1)) (downcase (car st2))) + (string= (downcase t1) (downcase t2))))) + +(defvar notmuch-multipart/alternative-discouraged + '( + ;; Avoid HTML parts. + "text/html" + ;; multipart/related usually contain a text/html part and some associated graphics. + "multipart/related" + )) + +(defun notmuch-multipart/alternative-choose (types) + "Return a list of preferred types from the given list of types" + ;; Based on `mm-preferred-alternative-precedence'. + (let ((seq types)) + (dolist (pref (reverse notmuch-multipart/alternative-discouraged)) + (dolist (elem (copy-sequence seq)) + (when (string-match pref elem) + (setq seq (nconc (delete elem seq) (list elem)))))) + seq)) + +(defun notmuch-parts-filter-by-type (parts type) + "Given a list of message parts, return a list containing the ones matching +the given type." + (remove-if-not + (lambda (part) (notmuch-match-content-type (plist-get part :content-type) type)) + parts)) + +;; Helper for parts which are generally not included in the default +;; SEXP output. +(defun notmuch-get-bodypart-internal (query part-number process-crypto) + (let ((args '("show" "--format=raw")) + (part-arg (format "--part=%s" part-number))) + (setq args (append args (list part-arg))) + (if process-crypto + (setq args (append args '("--decrypt")))) + (setq args (append args (list query))) + (with-temp-buffer + (let ((coding-system-for-read 'no-conversion)) + (progn + (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args)) + (buffer-string)))))) + +(defun notmuch-get-bodypart-content (msg part nth process-crypto) + (or (plist-get part :content) + (notmuch-get-bodypart-internal (notmuch-id-to-query (plist-get msg :id)) nth process-crypto))) + +;; Workaround: The call to `mm-display-part' below triggers a bug in +;; Emacs 24 if it attempts to use the shr renderer to display an HTML +;; part with images in it (demonstrated in 24.1 and 24.2 on Debian and +;; Fedora 17, though unreproducable in other configurations). +;; `mm-shr' references the variable `gnus-inhibit-images' without +;; first loading gnus-art, which defines it, resulting in a +;; void-variable error. Hence, we advise `mm-shr' to ensure gnus-art +;; is loaded. +(if (>= emacs-major-version 24) + (defadvice mm-shr (before load-gnus-arts activate) + (require 'gnus-art nil t) + (ad-disable-advice 'mm-shr 'before 'load-gnus-arts))) + +(defun notmuch-mm-display-part-inline (msg part nth content-type process-crypto) + "Use the mm-decode/mm-view functions to display a part in the +current buffer, if possible." + (let ((display-buffer (current-buffer))) + (with-temp-buffer + ;; In case there is :content, the content string is already converted + ;; into emacs internal format. `gnus-decoded' is a fake charset, + ;; which means no further decoding (to be done by mm- functions). + (let* ((charset (if (plist-member part :content) + 'gnus-decoded + (plist-get part :content-charset))) + (handle (mm-make-handle (current-buffer) `(,content-type (charset . ,charset))))) + ;; If the user wants the part inlined, insert the content and + ;; test whether we are able to inline it (which includes both + ;; capability and suitability tests). + (when (mm-inlined-p handle) + (insert (notmuch-get-bodypart-content msg part nth process-crypto)) + (when (mm-inlinable-p handle) + (set-buffer display-buffer) + (mm-display-part handle) + t)))))) + +;; Converts a plist of headers to an alist of headers. The input plist should +;; have symbols of the form :Header as keys, and the resulting alist will have +;; symbols of the form 'Header as keys. +(defun notmuch-headers-plist-to-alist (plist) + (loop for (key value . rest) on plist by #'cddr + collect (cons (intern (substring (symbol-name key) 1)) value))) + +(defun notmuch-face-ensure-list-form (face) + "Return FACE in face list form. + +If FACE is already a face list, it will be returned as-is. If +FACE is a face name or face plist, it will be returned as a +single element face list." + (if (and (listp face) (not (keywordp (car face)))) + face + (list face))) + +(defun notmuch-combine-face-text-property (start end face &optional below object) + "Combine FACE into the 'face text property between START and END. + +This function combines FACE with any existing faces between START +and END in OBJECT (which defaults to the current buffer). +Attributes specified by FACE take precedence over existing +attributes unless BELOW is non-nil. FACE must be a face name (a +symbol or string), a property list of face attributes, or a list +of these. For convenience when applied to strings, this returns +OBJECT." + + ;; A face property can have three forms: a face name (a string or + ;; symbol), a property list, or a list of these two forms. In the + ;; list case, the faces will be combined, with the earlier faces + ;; taking precedent. Here we canonicalize everything to list form + ;; to make it easy to combine. + (let ((pos start) + (face-list (notmuch-face-ensure-list-form face))) + (while (< pos end) + (let* ((cur (get-text-property pos 'face object)) + (cur-list (notmuch-face-ensure-list-form cur)) + (new (cond ((null cur-list) face) + (below (append cur-list face-list)) + (t (append face-list cur-list)))) + (next (next-single-property-change pos 'face object end))) + (put-text-property pos next 'face new object) + (setq pos next)))) + object) + +(defun notmuch-combine-face-text-property-string (string face &optional below) + (notmuch-combine-face-text-property + 0 + (length string) + face + below + string)) + +(defun notmuch-map-text-property (start end prop func &optional object) + "Transform text property PROP using FUNC. + +Applies FUNC to each distinct value of the text property PROP +between START and END of OBJECT, setting PROP to the value +returned by FUNC." + (while (< start end) + (let ((value (get-text-property start prop object)) + (next (next-single-property-change start prop object end))) + (put-text-property start next prop (funcall func value) object) + (setq start next)))) + +(defun notmuch-logged-error (msg &optional extra) + "Log MSG and EXTRA to *Notmuch errors* and signal MSG. + +This logs MSG and EXTRA to the *Notmuch errors* buffer and +signals MSG as an error. If EXTRA is non-nil, text referring the +user to the *Notmuch errors* buffer will be appended to the +signaled error. This function does not return." + + (with-current-buffer (get-buffer-create "*Notmuch errors*") + (goto-char (point-max)) + (unless (bobp) + (newline)) + (save-excursion + (insert "[" (current-time-string) "]\n" msg) + (unless (bolp) + (newline)) + (when extra + (insert extra) + (unless (bolp) + (newline))))) + (error "%s" (concat msg (when extra + " (see *Notmuch errors* for more details)")))) + +(defun notmuch-check-async-exit-status (proc msg &optional command err-file) + "If PROC exited abnormally, pop up an error buffer and signal an error. + +This is a wrapper around `notmuch-check-exit-status' for +asynchronous process sentinels. PROC and MSG must be the +arguments passed to the sentinel. COMMAND and ERR-FILE, if +provided, are passed to `notmuch-check-exit-status'. If COMMAND +is not provided, it is taken from `process-command'." + (let ((exit-status + (case (process-status proc) + ((exit) (process-exit-status proc)) + ((signal) msg)))) + (when exit-status + (notmuch-check-exit-status exit-status (or command (process-command proc)) + nil err-file)))) + +(defun notmuch-check-exit-status (exit-status command &optional output err-file) + "If EXIT-STATUS is non-zero, pop up an error buffer and signal an error. + +If EXIT-STATUS is non-zero, pop up a notmuch error buffer +describing the error and signal an Elisp error. EXIT-STATUS must +be a number indicating the exit status code of a process or a +string describing the signal that terminated the process (such as +returned by `call-process'). COMMAND must be a list giving the +command and its arguments. OUTPUT, if provided, is a string +giving the output of command. ERR-FILE, if provided, is the name +of a file containing the error output of command. OUTPUT and the +contents of ERR-FILE will be included in the error message." + + (cond + ((eq exit-status 0) t) + ((eq exit-status 20) + (notmuch-logged-error "notmuch CLI version mismatch +Emacs requested an older output format than supported by the notmuch CLI. +You may need to restart Emacs or upgrade your notmuch Emacs package.")) + ((eq exit-status 21) + (notmuch-logged-error "notmuch CLI version mismatch +Emacs requested a newer output format than supported by the notmuch CLI. +You may need to restart Emacs or upgrade your notmuch package.")) + (t + (let* ((err (when err-file + (with-temp-buffer + (insert-file-contents err-file) + (unless (eobp) + (buffer-string))))) + (extra + (concat + "command: " (mapconcat #'shell-quote-argument command " ") "\n" + (if (integerp exit-status) + (format "exit status: %s\n" exit-status) + (format "exit signal: %s\n" exit-status)) + (when err + (concat "stderr:\n" err)) + (when output + (concat "stdout:\n" output))))) + (if err + ;; We have an error message straight from the CLI. + (notmuch-logged-error + (replace-regexp-in-string "[ \n\r\t\f]*\\'" "" err) extra) + ;; We only have combined output from the CLI; don't inundate + ;; the user with it. Mimic `process-lines'. + (notmuch-logged-error (format "%s exited with status %s" + (car command) exit-status) + extra)) + ;; `notmuch-logged-error' does not return. + )))) + +(defun notmuch-call-notmuch-sexp (&rest args) + "Invoke `notmuch-command' with ARGS and return the parsed S-exp output. + +If notmuch exits with a non-zero status, this will pop up a +buffer containing notmuch's output and signal an error." + + (with-temp-buffer + (let ((err-file (make-temp-file "nmerr"))) + (unwind-protect + (let ((status (apply #'call-process + notmuch-command nil (list t err-file) nil args))) + (notmuch-check-exit-status status (cons notmuch-command args) + (buffer-string) err-file) + (goto-char (point-min)) + (read (current-buffer))) + (delete-file err-file))))) + +(defun notmuch-start-notmuch (name buffer sentinel &rest args) + "Start and return an asynchronous notmuch command. + +This starts and returns an asynchronous process running +`notmuch-command' with ARGS. The exit status is checked via +`notmuch-check-async-exit-status'. Output written to stderr is +redirected and displayed when the process exits (even if the +process exits successfully). NAME and BUFFER are the same as in +`start-process'. SENTINEL is a process sentinel function to call +when the process exits, or nil for none. The caller must *not* +invoke `set-process-sentinel' directly on the returned process, +as that will interfere with the handling of stderr and the exit +status." + + ;; There is no way (as of Emacs 24.3) to capture stdout and stderr + ;; separately for asynchronous processes, or even to redirect stderr + ;; to a file, so we use a trivial shell wrapper to send stderr to a + ;; temporary file and clean things up in the sentinel. + (let* ((err-file (make-temp-file "nmerr")) + ;; Use a pipe + (process-connection-type nil) + ;; Find notmuch using Emacs' `exec-path' + (command (or (executable-find notmuch-command) + (error "command not found: %s" notmuch-command))) + (proc (apply #'start-process name buffer + "/bin/sh" "-c" + "exec 2>\"$1\"; shift; exec \"$0\" \"$@\"" + command err-file args))) + (process-put proc 'err-file err-file) + (process-put proc 'sub-sentinel sentinel) + (process-put proc 'real-command (cons notmuch-command args)) + (set-process-sentinel proc #'notmuch-start-notmuch-sentinel) + proc)) + +(defun notmuch-start-notmuch-sentinel (proc event) + (let ((err-file (process-get proc 'err-file)) + (sub-sentinel (process-get proc 'sub-sentinel)) + (real-command (process-get proc 'real-command))) + (condition-case err + (progn + ;; Invoke the sub-sentinel, if any + (when sub-sentinel + (funcall sub-sentinel proc event)) + ;; Check the exit status. This will signal an error if the + ;; exit status is non-zero. Don't do this if the process + ;; buffer is dead since that means Emacs killed the process + ;; and there's no point in telling the user that (but we + ;; still check for and report stderr output below). + (when (buffer-live-p (process-buffer proc)) + (notmuch-check-async-exit-status proc event real-command err-file)) + ;; If that didn't signal an error, then any error output was + ;; really warning output. Show warnings, if any. + (let ((warnings + (with-temp-buffer + (unless (= (second (insert-file-contents err-file)) 0) + (end-of-line) + ;; Show first line; stuff remaining lines in the + ;; errors buffer. + (let ((l1 (buffer-substring (point-min) (point)))) + (skip-chars-forward "\n") + (cons l1 (unless (eobp) + (buffer-substring (point) (point-max))))))))) + (when warnings + (notmuch-logged-error (car warnings) (cdr warnings))))) + (error + ;; Emacs behaves strangely if an error escapes from a sentinel, + ;; so turn errors into messages. + (message "%s" (error-message-string err)))) + (ignore-errors (delete-file err-file)))) + +;; This variable is used only buffer local, but it needs to be +;; declared globally first to avoid compiler warnings. +(defvar notmuch-show-process-crypto nil) +(make-variable-buffer-local 'notmuch-show-process-crypto) + + +(provide 'notmuch-lib) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/emacs/notmuch/notmuch-logo.png b/emacs/notmuch/notmuch-logo.png new file mode 100644 index 0000000..53b5e6a Binary files /dev/null and b/emacs/notmuch/notmuch-logo.png differ diff --git a/emacs/notmuch/notmuch-maildir-fcc.el b/emacs/notmuch/notmuch-maildir-fcc.el new file mode 100644 index 0000000..07eedba --- /dev/null +++ b/emacs/notmuch/notmuch-maildir-fcc.el @@ -0,0 +1,218 @@ +;; This file 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 2, or (at your +;; option) any later version. + +;; This program 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;; +;; To use this as the fcc handler for message-mode, +;; customize the notmuch-fcc-dirs variable + +(eval-when-compile (require 'cl)) +(require 'message) + +(require 'notmuch-lib) + +(defvar notmuch-maildir-fcc-count 0) + +(defcustom notmuch-fcc-dirs "sent" + "Determines the maildir directory in which 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 name of the + folder to use, + +- a list: the folder is chosen based on the From address of the + current message using a list of regular expressions and + corresponding folders: + + ((\"Sebastian@SSpaeth.de\" . \"privat\") + (\"spaetz@sspaeth.de\" . \"OUTBOX.OSS\") + (\".*\" . \"defaultinbox\")) + + If none of the regular expressions match the From address, no + Fcc header will be added. + +In all cases, a relative FCC 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). + +You will be prompted to create the 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 (string :tag "Folder")))) + :require 'notmuch-fcc-initialization + :group 'notmuch-send) + +(defun notmuch-fcc-initialization () + "If notmuch-fcc-directories is set, + hook them into the message-fcc-handler-function" + ;; Set up the message-fcc-handler to move mails to the maildir in Fcc + ;; The parameter is set to mark messages as "seen" + (setq message-fcc-handler-function + (lambda (destdir) + (notmuch-maildir-fcc-write-buffer-to-maildir destdir t))) + ;; add a hook to actually insert the Fcc header when sending + (add-hook 'message-header-setup-hook 'notmuch-fcc-header-setup)) + +(defun notmuch-fcc-header-setup () + "Add an Fcc header to the current message buffer. + +Can be added to `message-send-hook' and will set the Fcc header +based on the values of `notmuch-fcc-dirs'. An existing Fcc header +will NOT be removed or replaced." + + (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) + (let* ((from (message-field-value "From")) + (match + (catch 'first-match + (dolist (re-folder notmuch-fcc-dirs) + (when (string-match-p (car re-folder) from) + (throw 'first-match re-folder)))))) + (if match + (cdr match) + (message "No Fcc header added.") + nil))) + + (t + (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)"))))) + + (when 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))))) + + ;; finally test if fcc points to a valid maildir + (let ((fcc-header (message-field-value "Fcc"))) + (unless (notmuch-maildir-fcc-dir-is-maildir-p fcc-header) + (cond ((not (file-writable-p fcc-header)) + (error (format "No permission to create %s, which does not exist" + fcc-header))) + ((y-or-n-p (format "%s is not a maildir. Create it? " + fcc-header)) + (notmuch-maildir-fcc-create-maildir fcc-header)) + (t + (error "Message not sent")))))))) + +(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))) + (setq notmuch-maildir-fcc-count (+ notmuch-maildir-fcc-count 1)) + (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 (format "Can't write to %s. Not a maildir." + destdir)) + nil)))) + +(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," (when mark-seen "S")))) + +(defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen) + "Writes the current buffer to maildir destdir. If mark-seen is +non-nil, it will write it to cur/, and mark it as read. It should +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 + (cond (mark-seen + (condition-case err + (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t) + (file-already-exists + (throw 'link-error nil)))) + (t + (condition-case err + (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))) + +(notmuch-fcc-initialization) +(provide 'notmuch-maildir-fcc) + diff --git a/emacs/notmuch/notmuch-message.el b/emacs/notmuch/notmuch-message.el new file mode 100644 index 0000000..914bdd1 --- /dev/null +++ b/emacs/notmuch/notmuch-message.el @@ -0,0 +1,48 @@ +;; notmuch-message.el --- message-mode functions specific to notmuch +;; +;; Copyright © Jesse Rosenthal +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Jesse Rosenthal + +(require 'message) +(require 'notmuch-tag) +(require 'notmuch-mua) + +(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) + +(defun notmuch-message-mark-replied () + ;; get the in-reply-to header and parse it for the message id. + (let ((rep (mail-header-parse-addresses (message-field-value "In-Reply-To")))) + (when (and notmuch-message-replied-tags rep) + (notmuch-tag (notmuch-id-to-query (car (car rep))) + (notmuch-tag-change-list notmuch-message-replied-tags))))) + +(add-hook 'message-send-hook 'notmuch-message-mark-replied) + +(provide 'notmuch-message) diff --git a/emacs/notmuch/notmuch-mua.el b/emacs/notmuch/notmuch-mua.el new file mode 100644 index 0000000..2baae5f --- /dev/null +++ b/emacs/notmuch/notmuch-mua.el @@ -0,0 +1,364 @@ +;; notmuch-mua.el --- emacs style mail-user-agent +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: David Edmondson + +(require 'message) +(require 'mm-view) +(require 'format-spec) + +(require 'notmuch-lib) +(require 'notmuch-address) + +(eval-when-compile (require 'cl)) + +;; + +(defcustom notmuch-mua-send-hook '(notmuch-mua-message-send-hook) + "Hook run before sending messages." + :type 'hook + :group 'notmuch-send + :group 'notmuch-hooks) + +(defcustom notmuch-mua-compose-in 'current-window + (concat + "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." + (when (< emacs-major-version 24) + " Due to a known bug in Emacs 23, you should not set +this to `new-window' if `message-kill-buffer-on-exit' is +disabled: this would result in an incorrect behavior.")) + :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 'notmuch-mua-user-agent-full + "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 '("^User-Agent:") + "Headers that are added to the `message-mode' hidden headers +list." + :type '(repeat string) + :group 'notmuch-send) + +;; + +(defun notmuch-mua-get-switch-function () + "Get a switch function according to `notmuch-mua-compose-in'." + (cond ((eq notmuch-mua-compose-in 'current-window) + 'switch-to-buffer) + ((eq notmuch-mua-compose-in 'new-window) + 'switch-to-buffer-other-window) + ((eq notmuch-mua-compose-in 'new-frame) + 'switch-to-buffer-other-frame) + (t (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." + (concat "Notmuch/" (notmuch-version) " (http://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) + (when (not (member header message-hidden-headers)) + (push header message-hidden-headers))) + notmuch-mua-hidden-headers)) + +(defun notmuch-mua-get-quotable-parts (parts) + (loop for part in parts + if (notmuch-match-content-type (plist-get part :content-type) "multipart/alternative") + collect (let* ((subparts (plist-get part :content)) + (types (mapcar (lambda (part) (plist-get part :content-type)) subparts)) + (chosen-type (car (notmuch-multipart/alternative-choose types)))) + (loop for part in (reverse subparts) + if (notmuch-match-content-type (plist-get part :content-type) chosen-type) + return part)) + else if (notmuch-match-content-type (plist-get part :content-type) "multipart/*") + append (notmuch-mua-get-quotable-parts (plist-get part :content)) + else if (notmuch-match-content-type (plist-get part :content-type) "text/*") + collect part)) + +(defun notmuch-mua-insert-quotable-part (message part) + (save-restriction + (narrow-to-region (point) (point)) + (notmuch-mm-display-part-inline message part (plist-get part :id) + (plist-get part :content-type) + notmuch-show-process-crypto) + (goto-char (point-max)))) + +;; There is a bug in emacs 23's 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"))) + +(defun notmuch-mua-reply (query-string &optional sender reply-all) + (let ((args '("reply" "--format=sexp" "--format-version=1")) + reply + original) + (when notmuch-show-process-crypto + (setq args (append args '("--decrypt")))) + + (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 + (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) + (plist-get reply-headers :Subject) + (notmuch-headers-plist-to-alist reply-headers) + nil (notmuch-mua-get-switch-function)))) + + ;; Insert the message body - but put it in front of the signature + ;; if one is present + (goto-char (point-max)) + (if (re-search-backward message-signature-separator nil t) + (forward-line -1) + (goto-char (point-max))) + + (let ((from (plist-get original-headers :From)) + (date (plist-get original-headers :Date)) + (start (point))) + + ;; message-cite-original 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") + + ;; Get the parts of the original message that should be quoted; this includes + ;; all the text parts, except the non-preferred ones in a multipart/alternative. + (let ((quotable-parts (notmuch-mua-get-quotable-parts (plist-get original :body)))) + (mapc (apply-partially 'notmuch-mua-insert-quotable-part original) quotable-parts)) + + (set-mark (point)) + (goto-char start) + ;; Quote the original message according to the user's configured style. + (message-cite-original)))) + + (goto-char (point-max)) + (push-mark) + (message-goto-body) + (set-buffer-modified-p nil)) + +(defun notmuch-mua-forward-message () + (funcall (notmuch-mua-get-switch-function) (current-buffer)) + (message-forward) + + (when notmuch-mua-user-agent-function + (let ((user-agent (funcall notmuch-mua-user-agent-function))) + (when (not (string= "" user-agent)) + (message-add-header (format "User-Agent: %s" user-agent))))) + (message-sort-headers) + (message-hide-headers) + (set-buffer-modified-p nil) + (notmuch-mua-maybe-set-window-dedicated) + + (message-goto-to)) + +(defun notmuch-mua-mail (&optional to subject other-headers &rest other-args) + "Invoke the notmuch mail composition window. + +OTHER-ARGS are passed through to `message-mail'." + (interactive) + + (when notmuch-mua-user-agent-function + (let ((user-agent (funcall notmuch-mua-user-agent-function))) + (when (not (string= "" user-agent)) + (push (cons 'User-Agent user-agent) other-headers)))) + + (unless (assq 'From other-headers) + (push (cons 'From (concat + (notmuch-user-name) " <" (notmuch-user-primary-email) ">")) other-headers)) + + (apply #'message-mail to subject other-headers other-args) + (message-sort-headers) + (message-hide-headers) + (set-buffer-modified-p nil) + (notmuch-mua-maybe-set-window-dedicated) + + (message-goto-to)) + +(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) + +(defvar notmuch-mua-sender-history nil) + +(defun notmuch-mua-prompt-for-sender () + (interactive) + (let (name addresses one-name-only) + ;; If notmuch-identities is non-nil, check if there is a fixed user name. + (if notmuch-identities + (let ((components (mapcar 'mail-extract-address-components notmuch-identities))) + (setq name (caar components) + addresses (mapcar 'cadr components) + one-name-only (eval + (cons 'and + (mapcar (lambda (identity) + (string-equal name (car identity))) + components))))) + ;; If notmuch-identities is nil, use values from the notmuch configuration file. + (setq name (notmuch-user-name) + addresses (cons (notmuch-user-primary-email) (notmuch-user-other-email)) + one-name-only t)) + ;; Now prompt the user, either for an email address only or for a full identity. + (if one-name-only + (let ((address + (ido-completing-read (concat "Sender address for " name ": ") addresses + nil nil nil 'notmuch-mua-sender-history (car addresses)))) + (concat name " <" address ">")) + (ido-completing-read "Send mail From: " notmuch-identities + nil nil nil 'notmuch-mua-sender-history (car notmuch-identities))))) + +(defun notmuch-mua-new-mail (&optional prompt-for-sender) + "Invoke the notmuch mail composition window. + +If PROMPT-FOR-SENDER is non-nil, the user will be prompted for +the From: address first." + (interactive "P") + (let ((other-headers + (when (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-message (&optional prompt-for-sender) + "Invoke the notmuch message forwarding window. + +If PROMPT-FOR-SENDER is non-nil, the user will be prompted for +the From: address first." + (interactive "P") + (if (or prompt-for-sender notmuch-always-prompt-for-sender) + (let* ((sender (notmuch-mua-prompt-for-sender)) + (address-components (mail-extract-address-components sender)) + (user-full-name (car address-components)) + (user-mail-address (cadr address-components))) + (notmuch-mua-forward-message)) + (notmuch-mua-forward-message))) + +(defun notmuch-mua-new-reply (query-string &optional prompt-for-sender reply-all) + "Invoke the notmuch reply window." + (interactive "P") + (let ((sender + (when prompt-for-sender + (notmuch-mua-prompt-for-sender)))) + (notmuch-mua-reply query-string sender reply-all))) + +(defun notmuch-mua-send-and-exit (&optional arg) + (interactive "P") + (message-send-and-exit arg)) + +(defun notmuch-mua-kill-buffer () + (interactive) + (message-kill-buffer)) + +(defun notmuch-mua-message-send-hook () + "The default function used for `notmuch-mua-send-hook', this +simply runs the corresponding `message-mode' hook functions." + (run-hooks 'message-send-hook)) + +;; + +(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) diff --git a/emacs/notmuch/notmuch-parser.el b/emacs/notmuch/notmuch-parser.el new file mode 100644 index 0000000..d59c0e1 --- /dev/null +++ b/emacs/notmuch/notmuch-parser.el @@ -0,0 +1,207 @@ +;; notmuch-parser.el --- streaming S-expression parser +;; +;; Copyright © Austin Clements +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Austin Clements + +(require 'cl) + +(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 + ;; List depth + 0 + ;; Partial parse position marker + nil + ;; Partial parse state + nil)) + +(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 + (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 + (when (null (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 (first new-state))) + (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) + (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))))))) + +(defun notmuch-sexp-eof (sp) + "Signal an error if there is more data in SP's buffer. + +Moves point to the beginning of any trailing data or to the end +of the buffer if there is only trailing whitespace." + + (skip-chars-forward " \n\r\t") + (unless (eobp) + (error "Trailing garbage following expression"))) + +(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) + (set (make-local-variable 'notmuch-sexp--parser) + (notmuch-sexp-create-parser)) + (set (make-local-variable 'notmuch-sexp--state) 'begin)) + (let (done) + (while (not done) + (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))) + (case result + (retry (setq done t)) + (end (setq notmuch-sexp--state 'end)) + (t (with-current-buffer result-buffer + (funcall result-function result)))))) + (end + ;; Any trailing data is unexpected + (notmuch-sexp-eof notmuch-sexp--parser) + (setq done t))))) + ;; Clear out what we've parsed + (delete-region (point-min) (point))) + +(provide 'notmuch-parser) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/emacs/notmuch/notmuch-print.el b/emacs/notmuch/notmuch-print.el new file mode 100644 index 0000000..8c18f4b --- /dev/null +++ b/emacs/notmuch/notmuch-print.el @@ -0,0 +1,92 @@ +;; notmuch-print.el --- printing messages from notmuch. +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: David Edmondson + +(require 'notmuch-lib) + +(declare-function notmuch-show-get-prop "notmuch-show" (prop &optional props)) + +(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 #'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")) + (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"))) + (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) diff --git a/emacs/notmuch/notmuch-query.el b/emacs/notmuch/notmuch-query.el new file mode 100644 index 0000000..d1daffc --- /dev/null +++ b/emacs/notmuch/notmuch-query.el @@ -0,0 +1,76 @@ +;; notmuch-query.el --- provide an emacs api to query notmuch +;; +;; Copyright © David Bremner +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: David Bremner + +(require 'notmuch-lib) + +(defun notmuch-query-get-threads (search-terms) + "Return a list of threads of messages matching SEARCH-TERMS. + +A thread is a forest or list of trees. A tree is a two element +list where the first element is a message, and the second element +is a possibly empty forest of replies. +" + (let ((args '("show" "--format=sexp" "--format-version=1"))) + (if notmuch-show-process-crypto + (setq args (append args '("--decrypt")))) + (setq args (append args search-terms)) + (apply #'notmuch-call-notmuch-sexp args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Mapping functions across collections of messages. + +(defun notmuch-query-map-aux (mapper function seq) + "private function to do the actual mapping and flattening" + (apply 'append + (mapcar + (lambda (tree) + (funcall mapper function tree)) + seq))) + +(defun notmuch-query-map-threads (fn threads) + "apply 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 to every message in a 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-query-get-threads 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-query-get-threads search-terms))) + +(provide 'notmuch-query) diff --git a/emacs/notmuch/notmuch-show.el b/emacs/notmuch/notmuch-show.el new file mode 100644 index 0000000..c4e0a99 --- /dev/null +++ b/emacs/notmuch/notmuch-show.el @@ -0,0 +1,2105 @@ +;; notmuch-show.el --- displaying notmuch forests. +;; +;; Copyright © Carl Worth +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Carl Worth +;; David Edmondson + +(eval-when-compile (require 'cl)) +(require 'mm-view) +(require 'message) +(require 'mm-decode) +(require 'mailcap) +(require 'icalendar) +(require 'goto-addr) + +(require 'notmuch-lib) +(require 'notmuch-tag) +(require 'notmuch-query) +(require 'notmuch-wash) +(require 'notmuch-mua) +(require 'notmuch-crypto) +(require 'notmuch-print) + +(declare-function notmuch-call-notmuch-process "notmuch" (&rest args)) +(declare-function notmuch-search-next-thread "notmuch" nil) +(declare-function notmuch-search-previous-thread "notmuch" nil) +(declare-function notmuch-search-show-thread "notmuch" nil) + +(defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date") + "Headers that should be shown in a message, in this order. + +For an open message, all of these headers will be made visible +according to `notmuch-message-headers-visible' or can be toggled +with `notmuch-show-toggle-visibility-headers'. For a closed message, +only the first header in the list will be visible." + :type '(repeat string) + :group 'notmuch-show) + +(defcustom notmuch-message-headers-visible t + "Should the headers be visible by default? + +If this value is non-nil, then all of the headers defined in +`notmuch-message-headers' will be visible by default in the display +of each message. Otherwise, these headers will be hidden and +`notmuch-show-toggle-visibility-headers' can be used to make them +visible for any given message." + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-relative-dates t + "Display relative dates in the message summary line." + :type 'boolean + :group 'notmuch-show) + +(defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers) + "A list of functions called to decorate the headers listed in +`notmuch-message-headers'.") + +(defcustom notmuch-show-hook '(notmuch-show-turn-on-visual-line-mode) + "Functions called after populating a `notmuch-show' buffer." + :type 'hook + :options '(notmuch-show-turn-on-visual-line-mode) + :group 'notmuch-show + :group 'notmuch-hooks) + +(defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-wrap-long-lines + notmuch-wash-tidy-citations + notmuch-wash-elide-blank-lines + notmuch-wash-excerpt-citations) + "Functions used to improve the display of text/plain parts." + :type 'hook + :options '(notmuch-wash-convert-inline-patch-to-part + notmuch-wash-wrap-long-lines + notmuch-wash-tidy-citations + notmuch-wash-elide-blank-lines + notmuch-wash-excerpt-citations) + :group 'notmuch-show + :group 'notmuch-hooks) + +;; Mostly useful for debugging. +(defcustom notmuch-show-all-multipart/alternative-parts nil + "Should all parts of multipart/alternative parts be shown?" + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-indent-messages-width 1 + "Width of message indentation in threads. + +Messages are shown indented according to their depth in a thread. +This variable determines the width of this indentation measured +in number of blanks. Defaults to `1', choose `0' to disable +indentation." + :type 'integer + :group 'notmuch-show) + +(defcustom notmuch-show-indent-multipart nil + "Should the sub-parts of a multipart/* part be indented?" + ;; dme: Not sure which is a good default. + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-part-button-default-action 'notmuch-show-save-part + "Default part header button action (on ENTER or mouse click)." + :group 'notmuch-show + :type '(choice (const :tag "Save part" + notmuch-show-save-part) + (const :tag "View part" + notmuch-show-view-part) + (const :tag "View interactively" + notmuch-show-interactively-view-part))) + +(defcustom notmuch-show-only-matching-messages nil + "Only matching messages are shown by default." + :type 'boolean + :group 'notmuch-show) + +(defvar notmuch-show-thread-id nil) +(make-variable-buffer-local 'notmuch-show-thread-id) +(put 'notmuch-show-thread-id 'permanent-local t) + +(defvar notmuch-show-parent-buffer nil) +(make-variable-buffer-local 'notmuch-show-parent-buffer) +(put 'notmuch-show-parent-buffer 'permanent-local t) + +(defvar notmuch-show-query-context nil) +(make-variable-buffer-local 'notmuch-show-query-context) +(put 'notmuch-show-query-context 'permanent-local t) + +(defvar notmuch-show-process-crypto nil) +(make-variable-buffer-local 'notmuch-show-process-crypto) +(put 'notmuch-show-process-crypto 'permanent-local t) + +(defvar notmuch-show-elide-non-matching-messages nil) +(make-variable-buffer-local 'notmuch-show-elide-non-matching-messages) +(put 'notmuch-show-elide-non-matching-messages 'permanent-local t) + +(defvar notmuch-show-indent-content t) +(make-variable-buffer-local 'notmuch-show-indent-content) +(put 'notmuch-show-indent-content 'permanent-local t) + +(defcustom notmuch-show-stash-mlarchive-link-alist + '(("Gmane" . "http://mid.gmane.org/") + ("MARC" . "http://marc.info/?i=") + ("Mail Archive, The" . "http://mail-archive.com/search?l=mid&q=") + ("LKML" . "http://lkml.kernel.org/r/") + ;; FIXME: can these services be searched by `Message-Id' ? + ;; ("MarkMail" . "http://markmail.org/") + ;; ("Nabble" . "http://nabble.com/") + ;; ("opensubscriber" . "http://opensubscriber.com/") + ) + "List of Mailing List Archives to use when stashing links. + +These URIs are concatenated with the current message's +Message-Id in `notmuch-show-stash-mlarchive-link'." + :type '(alist :key-type (string :tag "Name") + :value-type (string :tag "URL")) + :group 'notmuch-show) + +(defcustom notmuch-show-stash-mlarchive-link-default "Gmane" + "Default Mailing List Archive to use when stashing links. + +This is used when `notmuch-show-stash-mlarchive-link' isn't +provided with an MLA argument nor `completing-read' input." + :type `(choice + ,@(mapcar + (lambda (mla) + (list 'const :tag (car mla) :value (car mla))) + notmuch-show-stash-mlarchive-link-alist)) + :group 'notmuch-show) + +(defcustom notmuch-show-mark-read-tags '("-unread") + "List of tag changes to apply to a message when it is marked as read. + +Tags starting with \"+\" (or not starting with either \"+\" or +\"-\") in the list will be added, and tags starting with \"-\" +will be removed from the message being marked as read. + +For example, if you wanted to remove an \"unread\" tag and add a +\"read\" tag (which would make little sense), you would set: + (\"-unread\" \"+read\")" + :type '(repeat string) + :group 'notmuch-show) + + +(defmacro with-current-notmuch-show-message (&rest body) + "Evaluate body with current buffer set to the text of current message" + `(save-excursion + (let ((id (notmuch-show-get-message-id))) + (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*")))) + (with-current-buffer buf + (let ((coding-system-for-read 'no-conversion)) + (call-process notmuch-command nil t nil "show" "--format=raw" id) + ,@body) + (kill-buffer buf)))))) + +(defun notmuch-show-turn-on-visual-line-mode () + "Enable Visual Line mode." + (visual-line-mode t)) + +;; DEPRECATED in Notmuch 0.16 since we now have convenient part +;; commands. We'll keep the command around for a version or two in +;; case people want to bind it themselves. +(defun notmuch-show-view-all-mime-parts () + "Use external viewers to view all attachments from the current message." + (interactive) + (with-current-notmuch-show-message + ;; We override the mm-inline-media-tests to indicate which message + ;; parts are already sufficiently handled by the original + ;; presentation of the message in notmuch-show mode. These parts + ;; will be inserted directly into the temporary buffer of + ;; with-current-notmuch-show-message and silently discarded. + ;; + ;; Any MIME part not explicitly mentioned here will be handled by an + ;; external viewer as configured in the various mailcap files. + (let ((mm-inline-media-tests '( + ("text/.*" ignore identity) + ("application/pgp-signature" ignore identity) + ("multipart/alternative" ignore identity) + ("multipart/mixed" ignore identity) + ("multipart/related" ignore identity) + ))) + (mm-display-parts (mm-dissect-buffer))))) + +(defun notmuch-foreach-mime-part (function mm-handle) + (cond ((stringp (car mm-handle)) + (dolist (part (cdr mm-handle)) + (notmuch-foreach-mime-part function part))) + ((bufferp (car mm-handle)) + (funcall function mm-handle)) + (t (dolist (part mm-handle) + (notmuch-foreach-mime-part function part))))) + +(defun notmuch-count-attachments (mm-handle) + (let ((count 0)) + (notmuch-foreach-mime-part + (lambda (p) + (let ((disposition (mm-handle-disposition p))) + (and (listp disposition) + (or (equal (car disposition) "attachment") + (and (equal (car disposition) "inline") + (assq 'filename disposition))) + (incf count)))) + mm-handle) + count)) + +(defun notmuch-save-attachments (mm-handle &optional queryp) + (notmuch-foreach-mime-part + (lambda (p) + (let ((disposition (mm-handle-disposition p))) + (and (listp disposition) + (or (equal (car disposition) "attachment") + (and (equal (car disposition) "inline") + (assq 'filename disposition))) + (or (not queryp) + (y-or-n-p + (concat "Save '" (cdr (assq 'filename disposition)) "' "))) + (mm-save-part p)))) + mm-handle)) + +(defun notmuch-show-save-attachments () + "Save all attachments from the current message." + (interactive) + (with-current-notmuch-show-message + (let ((mm-handle (mm-dissect-buffer))) + (notmuch-save-attachments + mm-handle (> (notmuch-count-attachments mm-handle) 1)))) + (message "Done")) + +(defun notmuch-show-with-message-as-text (fn) + "Apply FN to a text representation of the current message. + +FN is called with one argument, the message properties. It should +operation on the contents of the current buffer." + + ;; Remake the header to ensure that all information is available. + (let* ((to (notmuch-show-get-to)) + (cc (notmuch-show-get-cc)) + (from (notmuch-show-get-from)) + (subject (notmuch-show-get-subject)) + (date (notmuch-show-get-date)) + (tags (notmuch-show-get-tags)) + (depth (notmuch-show-get-depth)) + + (header (concat + "Subject: " subject "\n" + "To: " to "\n" + (if (not (string= cc "")) + (concat "Cc: " cc "\n") + "") + "From: " from "\n" + "Date: " date "\n" + (if tags + (concat "Tags: " + (mapconcat #'identity tags ", ") "\n") + ""))) + (all (buffer-substring (notmuch-show-message-top) + (notmuch-show-message-bottom))) + + (props (notmuch-show-get-message-properties)) + (indenting notmuch-show-indent-content)) + (with-temp-buffer + (insert all) + (if indenting + (indent-rigidly (point-min) (point-max) (- depth))) + ;; Remove the original header. + (goto-char (point-min)) + (re-search-forward "^$" (point-max) nil) + (delete-region (point-min) (point)) + (insert header) + (funcall fn props)))) + +(defun notmuch-show-print-message () + "Print the current message." + (interactive) + (notmuch-show-with-message-as-text 'notmuch-print-message)) + +(defun notmuch-show-fontify-header () + (let ((face (cond + ((looking-at "[Tt]o:") + 'message-header-to) + ((looking-at "[Bb]?[Cc][Cc]:") + 'message-header-cc) + ((looking-at "[Ss]ubject:") + 'message-header-subject) + ((looking-at "[Ff]rom:") + 'message-header-from) + (t + 'message-header-other)))) + + (overlay-put (make-overlay (point) (re-search-forward ":")) + 'face 'message-header-name) + (overlay-put (make-overlay (point) (re-search-forward ".*$")) + 'face face))) + +(defun notmuch-show-colour-headers () + "Apply some colouring to the current headers." + (goto-char (point-min)) + (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:") + (notmuch-show-fontify-header) + (forward-line))) + +(defun notmuch-show-spaces-n (n) + "Return a string comprised of `n' spaces." + (make-string n ? )) + +(defun notmuch-show-update-tags (tags) + "Update the displayed tags of the current message." + (save-excursion + (goto-char (notmuch-show-message-top)) + (if (re-search-forward "(\\([^()]*\\))$" (line-end-position) t) + (let ((inhibit-read-only t)) + (replace-match (concat "(" + (notmuch-tag-format-tags tags) + ")")))))) + +(defun notmuch-clean-address (address) + "Try to clean a single email ADDRESS for display. Return a cons +cell of (AUTHOR_EMAIL AUTHOR_NAME). Return (ADDRESS nil) if +parsing fails." + (condition-case nil + (let (p-name p-address) + ;; It would be convenient to use `mail-header-parse-address', + ;; but that expects un-decoded mailbox parts, whereas our + ;; mailbox parts are already decoded (and hence may contain + ;; UTF-8). Given that notmuch should handle most of the awkward + ;; cases, some simple string deconstruction should be sufficient + ;; here. + (cond + ;; "User " style. + ((string-match "\\(.*\\) <\\(.*\\)>" address) + (setq p-name (match-string 1 address) + p-address (match-string 2 address))) + + ;; "" style. + ((string-match "<\\(.*\\)>" address) + (setq p-address (match-string 1 address))) + + ;; Everything else. + (t + (setq p-address address))) + + (when p-name + ;; Remove elements of the mailbox part that are not relevant for + ;; display, even if they are required during transport: + ;; + ;; Backslashes. + (setq p-name (replace-regexp-in-string "\\\\" "" p-name)) + + ;; Outer single and double quotes, which might be nested. + (loop + with start-of-loop + do (setq start-of-loop p-name) + + when (string-match "^\"\\(.*\\)\"$" p-name) + do (setq p-name (match-string 1 p-name)) + + when (string-match "^'\\(.*\\)'$" p-name) + do (setq p-name (match-string 1 p-name)) + + until (string= start-of-loop p-name))) + + ;; If the address is 'foo@bar.com ' then show just + ;; 'foo@bar.com'. + (when (string= p-name p-address) + (setq p-name nil)) + + (cons p-address p-name)) + (error (cons address nil)))) + +(defun notmuch-show-clean-address (address) + "Try to clean a single email ADDRESS for display. Return +unchanged ADDRESS if parsing fails." + (let* ((clean-address (notmuch-clean-address address)) + (p-address (car clean-address)) + (p-name (cdr clean-address))) + ;; If no name, return just the address. + (if (not p-name) + p-address + ;; Otherwise format the name and address together. + (concat p-name " <" p-address ">")))) + +(defun notmuch-show-insert-headerline (headers date tags depth) + "Insert a notmuch style headerline based on HEADERS for a +message at DEPTH in the current thread." + (let ((start (point))) + (insert (notmuch-show-spaces-n (* notmuch-show-indent-messages-width depth)) + (notmuch-show-clean-address (plist-get headers :From)) + " (" + date + ") (" + (notmuch-tag-format-tags tags) + ")\n") + (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face))) + +(defun notmuch-show-insert-header (header header-value) + "Insert a single header." + (insert header ": " header-value "\n")) + +(defun notmuch-show-insert-headers (headers) + "Insert the headers of the current message." + (let ((start (point))) + (mapc (lambda (header) + (let* ((header-symbol (intern (concat ":" header))) + (header-value (plist-get headers header-symbol))) + (if (and header-value + (not (string-equal "" header-value))) + (notmuch-show-insert-header header header-value)))) + notmuch-message-headers) + (save-excursion + (save-restriction + (narrow-to-region start (point-max)) + (run-hooks 'notmuch-show-markup-headers-hook))))) + +(define-button-type 'notmuch-show-part-button-type + 'action 'notmuch-show-part-button-default + 'follow-link t + 'face 'message-mml + :supertype 'notmuch-button-type) + +(defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment) + (let ((button) + (base-label (concat (when name (concat name ": ")) + declared-type + (unless (string-equal declared-type content-type) + (concat " (as " content-type ")")) + comment))) + + (setq button + (insert-button + (concat "[ " base-label " ]") + :base-label base-label + :type 'notmuch-show-part-button-type + :notmuch-part-hidden nil)) + (insert "\n") + ;; return button + button)) + +(defun notmuch-show-toggle-part-invisibility (&optional button) + (interactive) + (let* ((button (or button (button-at (point)))) + (overlay (button-get button 'overlay)) + (lazy-part (button-get button :notmuch-lazy-part))) + ;; We have a part to toggle if there is an overlay or if there is a lazy part. + ;; If neither is present we cannot toggle the part so we just return nil. + (when (or overlay lazy-part) + (let* ((show (button-get button :notmuch-part-hidden)) + (new-start (button-start button)) + (button-label (button-get button :base-label)) + (old-point (point)) + (properties (text-properties-at (point))) + (inhibit-read-only t)) + ;; Toggle the button itself. + (button-put button :notmuch-part-hidden (not show)) + (goto-char new-start) + (insert "[ " button-label (if show " ]" " (hidden) ]")) + (set-text-properties new-start (point) properties) + (let ((old-end (button-end button))) + (move-overlay button new-start (point)) + (delete-region (point) old-end)) + (goto-char (min old-point (1- (button-end button)))) + ;; Return nil if there is a lazy-part, it is empty, and we are + ;; trying to show it. In all other cases return t. + (if lazy-part + (when show + (button-put button :notmuch-lazy-part nil) + (notmuch-show-lazy-part lazy-part button)) + ;; else there must be an overlay. + (overlay-put overlay 'invisible (not show)) + t))))) + +;; MIME part renderers + +(defun notmuch-show-multipart/*-to-list (part) + (mapcar (lambda (inner-part) (plist-get inner-part :content-type)) + (plist-get part :content))) + +(defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth button) + (let ((chosen-type (car (notmuch-multipart/alternative-choose (notmuch-show-multipart/*-to-list part)))) + (inner-parts (plist-get part :content)) + (start (point))) + ;; This inserts all parts of the chosen type rather than just one, + ;; but it's not clear that this is the wrong thing to do - which + ;; should be chosen if there are more than one that match? + (mapc (lambda (inner-part) + (let* ((inner-type (plist-get inner-part :content-type)) + (hide (not (or notmuch-show-all-multipart/alternative-parts + (string= chosen-type inner-type))))) + (notmuch-show-insert-bodypart msg inner-part depth hide))) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-setup-w3m () + "Instruct w3m how to retrieve content from a \"related\" part of a message." + (interactive) + (if (boundp 'w3m-cid-retrieve-function-alist) + (unless (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist) + (push (cons 'notmuch-show-mode 'notmuch-show-w3m-cid-retrieve) + w3m-cid-retrieve-function-alist))) + (setq mm-inline-text-html-with-images t)) + +(defvar w3m-current-buffer) ;; From `w3m.el'. +(defvar notmuch-show-w3m-cid-store nil) +(make-variable-buffer-local 'notmuch-show-w3m-cid-store) + +(defun notmuch-show-w3m-cid-store-internal (content-id + message-id + part-number + content-type + content) + (push (list content-id + message-id + part-number + content-type + content) + notmuch-show-w3m-cid-store)) + +(defun notmuch-show-w3m-cid-store (msg part) + (let ((content-id (plist-get part :content-id))) + (when content-id + (notmuch-show-w3m-cid-store-internal (concat "cid:" content-id) + (plist-get msg :id) + (plist-get part :id) + (plist-get part :content-type) + nil)))) + +(defun notmuch-show-w3m-cid-retrieve (url &rest args) + (let ((matching-part (with-current-buffer w3m-current-buffer + (assoc url notmuch-show-w3m-cid-store)))) + (if matching-part + (let ((message-id (nth 1 matching-part)) + (part-number (nth 2 matching-part)) + (content-type (nth 3 matching-part)) + (content (nth 4 matching-part))) + ;; If we don't already have the content, get it and cache + ;; it, as some messages reference the same cid: part many + ;; times (hundreds!), which results in many calls to + ;; `notmuch part'. + (unless content + (setq content (notmuch-get-bodypart-internal (notmuch-id-to-query message-id) + part-number notmuch-show-process-crypto)) + (with-current-buffer w3m-current-buffer + (notmuch-show-w3m-cid-store-internal url + message-id + part-number + content-type + content))) + (insert content) + content-type) + nil))) + +(defun notmuch-show-insert-part-multipart/related (msg part content-type nth depth button) + (let ((inner-parts (plist-get part :content)) + (start (point))) + + ;; We assume that the first part is text/html and the remainder + ;; things that it references. + + ;; Stash the non-primary parts. + (mapc (lambda (part) + (notmuch-show-w3m-cid-store msg part)) + (cdr inner-parts)) + + ;; Render the primary part. + (notmuch-show-insert-bodypart msg (car inner-parts) depth) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/signed (msg part content-type nth depth button) + (button-put button 'face 'notmuch-crypto-part-header) + ;; add signature status button if sigstatus provided + (if (plist-member part :sigstatus) + (let* ((from (notmuch-show-get-header :From msg)) + (sigstatus (car (plist-get part :sigstatus)))) + (notmuch-crypto-insert-sigstatus-button sigstatus from)) + ;; if we're not adding sigstatus, tell the user how they can get it + (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts.")) + + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/encrypted (msg part content-type nth depth button) + (button-put button 'face 'notmuch-crypto-part-header) + ;; add encryption status button if encstatus specified + (if (plist-member part :encstatus) + (let ((encstatus (car (plist-get part :encstatus)))) + (notmuch-crypto-insert-encstatus-button encstatus) + ;; add signature status button if sigstatus specified + (if (plist-member part :sigstatus) + (let* ((from (notmuch-show-get-header :From msg)) + (sigstatus (car (plist-get part :sigstatus)))) + (notmuch-crypto-insert-sigstatus-button sigstatus from)))) + ;; if we're not adding encstatus, tell the user how they can get it + (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts.")) + + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth button) + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth button) + (let* ((message (car (plist-get part :content))) + (body (car (plist-get message :body))) + (start (point))) + + ;; Override `notmuch-message-headers' to force `From' to be + ;; displayed. + (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date"))) + (notmuch-show-insert-headers (plist-get message :headers))) + + ;; Blank line after headers to be compatible with the normal + ;; message display. + (insert "\n") + + ;; Show the body + (notmuch-show-insert-bodypart msg body depth) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-text/plain (msg part content-type nth depth button) + ;; For backward compatibility we want to apply the text/plain hook + ;; to the whole of the part including the part button if there is + ;; one. + (let ((start (if button + (button-start button) + (point)))) + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) + (save-excursion + (save-restriction + (narrow-to-region start (point-max)) + (run-hook-with-args 'notmuch-show-insert-text/plain-hook msg depth)))) + t) + +(defun notmuch-show-insert-part-text/calendar (msg part content-type nth depth button) + (insert (with-temp-buffer + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) + ;; notmuch-get-bodypart-content provides "raw", non-converted + ;; data. Replace CRLF with LF before icalendar can use it. + (goto-char (point-min)) + (while (re-search-forward "\r\n" nil t) + (replace-match "\n" nil nil)) + (let ((file (make-temp-file "notmuch-ical")) + result) + (unwind-protect + (progn + (unless (icalendar-import-buffer file t) + (error "Icalendar import error. See *icalendar-errors* for more information")) + (set-buffer (get-file-buffer file)) + (setq result (buffer-substring (point-min) (point-max))) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (delete-file file)) + result))) + t) + +;; For backwards compatibility. +(defun notmuch-show-insert-part-text/x-vcalendar (msg part content-type nth depth button) + (notmuch-show-insert-part-text/calendar msg part content-type nth depth button)) + +(defun notmuch-show-get-mime-type-of-application/octet-stream (part) + ;; If we can deduce a MIME type from the filename of the attachment, + ;; we return that. + (if (plist-get part :filename) + (let ((extension (file-name-extension (plist-get part :filename))) + mime-type) + (if extension + (progn + (mailcap-parse-mimetypes) + (setq mime-type (mailcap-extension-to-mime extension)) + (if (and mime-type + (not (string-equal mime-type "application/octet-stream"))) + mime-type + nil)) + nil)))) + +(defun notmuch-show-insert-part-text/html (msg part content-type nth depth button) + ;; text/html handler to work around bugs in renderers and our + ;; invisibile parts code. In particular w3m sets up a keymap which + ;; "leaks" outside the invisible region and causes strange effects + ;; in notmuch. We set mm-inline-text-html-with-w3m-keymap to nil to + ;; tell w3m not to set a keymap (so the normal notmuch-show-mode-map + ;; remains). + (let ((mm-inline-text-html-with-w3m-keymap nil)) + (notmuch-show-insert-part-*/* msg part content-type nth depth button))) + +(defun notmuch-show-insert-part-*/* (msg part content-type nth depth button) + ;; This handler _must_ succeed - it is the handler of last resort. + (notmuch-mm-display-part-inline msg part nth content-type notmuch-show-process-crypto) + t) + +;; Functions for determining how to handle MIME parts. + +(defun notmuch-show-handlers-for (content-type) + "Return a list of content handlers for a part of type CONTENT-TYPE." + (let (result) + (mapc (lambda (func) + (if (functionp func) + (push func result))) + ;; Reverse order of prefrence. + (list (intern (concat "notmuch-show-insert-part-*/*")) + (intern (concat + "notmuch-show-insert-part-" + (car (notmuch-split-content-type content-type)) + "/*")) + (intern (concat "notmuch-show-insert-part-" content-type)))) + result)) + +;; + +(defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth button) + (let ((handlers (notmuch-show-handlers-for content-type))) + ;; Run the content handlers until one of them returns a non-nil + ;; value. + (while (and handlers + (not (condition-case err + (funcall (car handlers) msg part content-type nth depth button) + (error (progn + (insert "!!! Bodypart insert error: ") + (insert (error-message-string err)) + (insert " !!!\n") nil))))) + (setq handlers (cdr handlers)))) + t) + +(defun notmuch-show-create-part-overlays (button beg end) + "Add an overlay to the part between BEG and END" + + ;; If there is no button (i.e., the part is text/plain and the first + ;; part) or if the part has no content then we don't make the part + ;; toggleable. + (when (and button (/= beg end)) + (button-put button 'overlay (make-overlay beg end)) + ;; Return true if we created an overlay. + t)) + +(defun notmuch-show-record-part-information (part beg end) + "Store PART as a text property from BEG to END" + + ;; Record part information. Since we already inserted subparts, + ;; don't override existing :notmuch-part properties. + (notmuch-map-text-property beg end :notmuch-part + (lambda (v) (or v part))) + ;; Make :notmuch-part front sticky and rear non-sticky so it stays + ;; applied to the beginning of each line when we indent the + ;; message. Since we're operating on arbitrary renderer output, + ;; watch out for sticky specs of t, which means all properties are + ;; front-sticky/rear-nonsticky. + (notmuch-map-text-property beg end 'front-sticky + (lambda (v) (if (listp v) + (pushnew :notmuch-part v) + v))) + (notmuch-map-text-property beg end 'rear-nonsticky + (lambda (v) (if (listp v) + (pushnew :notmuch-part v) + v)))) + +(defun notmuch-show-lazy-part (part-args button) + ;; Insert the lazy part after the button for the part. We would just + ;; move to the start of the new line following the button and insert + ;; the part but that point might have text properties (eg colours + ;; from a message header etc) so instead we start from the last + ;; character of the button by adding a newline and finish by + ;; removing the extra newline from the end of the part. + (save-excursion + (goto-char (button-end button)) + (insert "\n") + (let* ((inhibit-read-only t) + ;; We need to use markers for the start and end of the part + ;; because the part insertion functions do not guarantee + ;; to leave point at the end of the part. + (part-beg (copy-marker (point) nil)) + (part-end (copy-marker (point) t)) + ;; We have to save the depth as we can't find the depth + ;; when narrowed. + (depth (notmuch-show-get-depth))) + (save-restriction + (narrow-to-region part-beg part-end) + (delete-region part-beg part-end) + (apply #'notmuch-show-insert-bodypart-internal part-args) + (indent-rigidly part-beg part-end depth)) + (goto-char part-end) + (delete-char 1) + (notmuch-show-record-part-information (second part-args) + (button-start button) + part-end) + ;; Create the overlay. If the lazy-part turned out to be empty/not + ;; showable this returns nil. + (notmuch-show-create-part-overlays button part-beg part-end)))) + +(defun notmuch-show-insert-bodypart (msg part depth &optional hide) + "Insert the body part PART at depth DEPTH in the current thread. + +If HIDE is non-nil then initially hide this part." + + (let* ((content-type (downcase (plist-get part :content-type))) + (mime-type (or (and (string= content-type "application/octet-stream") + (notmuch-show-get-mime-type-of-application/octet-stream part)) + (and (string= content-type "inline patch") + "text/x-diff") + content-type)) + (nth (plist-get part :id)) + (beg (point)) + ;; We omit the part button for the first (or only) part if this is text/plain. + (button (unless (and (string= mime-type "text/plain") (<= nth 1)) + (notmuch-show-insert-part-header nth mime-type content-type (plist-get part :filename)))) + (content-beg (point))) + + (if (not hide) + (notmuch-show-insert-bodypart-internal msg part mime-type nth depth button) + (button-put button :notmuch-lazy-part + (list msg part mime-type nth depth button))) + + ;; Some of the body part handlers leave point somewhere up in the + ;; part, so we make sure that we're down at the end. + (goto-char (point-max)) + ;; Ensure that the part ends with a carriage return. + (unless (bolp) + (insert "\n")) + ;; We do not create the overlay for hidden (lazy) parts until + ;; they are inserted. + (if (not hide) + (notmuch-show-create-part-overlays button content-beg (point)) + (save-excursion + (notmuch-show-toggle-part-invisibility button))) + (notmuch-show-record-part-information part beg (point)))) + +(defun notmuch-show-insert-body (msg body depth) + "Insert the body BODY at depth DEPTH in the current thread." + (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body)) + +(defun notmuch-show-make-symbol (type) + (make-symbol (concat "notmuch-show-" type))) + +(defun notmuch-show-strip-re (string) + (replace-regexp-in-string "^\\([Rr]e: *\\)+" "" string)) + +(defvar notmuch-show-previous-subject "") +(make-variable-buffer-local 'notmuch-show-previous-subject) + +(defun notmuch-show-insert-msg (msg depth) + "Insert the message MSG at depth DEPTH in the current thread." + (let* ((headers (plist-get msg :headers)) + ;; Indentation causes the buffer offset of the start/end + ;; points to move, so we must use markers. + message-start message-end + content-start content-end + headers-start headers-end + (bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))) + + (setq message-start (point-marker)) + + (notmuch-show-insert-headerline headers + (or (if notmuch-show-relative-dates + (plist-get msg :date_relative) + nil) + (plist-get headers :Date)) + (plist-get msg :tags) depth) + + (setq content-start (point-marker)) + + ;; Set `headers-start' to point after the 'Subject:' header to be + ;; compatible with the existing implementation. This just sets it + ;; to after the first header. + (notmuch-show-insert-headers headers) + (save-excursion + (goto-char content-start) + ;; If the subject of this message is the same as that of the + ;; previous message, don't display it when this message is + ;; collapsed. + (when (not (string= notmuch-show-previous-subject + bare-subject)) + (forward-line 1)) + (setq headers-start (point-marker))) + (setq headers-end (point-marker)) + + (setq notmuch-show-previous-subject bare-subject) + + ;; A blank line between the headers and the body. + (insert "\n") + (notmuch-show-insert-body msg (plist-get msg :body) + (if notmuch-show-indent-content depth 0)) + ;; Ensure that the body ends with a newline. + (unless (bolp) + (insert "\n")) + (setq content-end (point-marker)) + + ;; Indent according to the depth in the thread. + (if notmuch-show-indent-content + (indent-rigidly content-start content-end (* notmuch-show-indent-messages-width depth))) + + (setq message-end (point-max-marker)) + + ;; Save the extents of this message over the whole text of the + ;; message. + (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end)) + + ;; Create overlays used to control visibility + (plist-put msg :headers-overlay (make-overlay headers-start headers-end)) + (plist-put msg :message-overlay (make-overlay headers-start content-end)) + + (plist-put msg :depth depth) + + ;; Save the properties for this message. Currently this saves the + ;; entire message (augmented it with other stuff), which seems + ;; like overkill. We might save a reduced subset (for example, not + ;; the content). + (notmuch-show-set-message-properties msg) + + ;; Set header visibility. + (notmuch-show-headers-visible msg notmuch-message-headers-visible) + + ;; Message visibility depends on whether it matched the search + ;; criteria. + (notmuch-show-message-visible msg (and (plist-get msg :match) + (not (plist-get msg :excluded)))))) + +(defun notmuch-show-toggle-process-crypto () + "Toggle the processing of cryptographic MIME parts." + (interactive) + (setq notmuch-show-process-crypto (not notmuch-show-process-crypto)) + (message (if notmuch-show-process-crypto + "Processing cryptographic MIME parts." + "Not processing cryptographic MIME parts.")) + (notmuch-show-refresh-view)) + +(defun notmuch-show-toggle-elide-non-matching () + "Toggle the display of non-matching messages." + (interactive) + (setq notmuch-show-elide-non-matching-messages (not notmuch-show-elide-non-matching-messages)) + (message (if notmuch-show-elide-non-matching-messages + "Showing matching messages only." + "Showing all messages.")) + (notmuch-show-refresh-view)) + +(defun notmuch-show-toggle-thread-indentation () + "Toggle the indentation of threads." + (interactive) + (setq notmuch-show-indent-content (not notmuch-show-indent-content)) + (message (if notmuch-show-indent-content + "Content is indented." + "Content is not indented.")) + (notmuch-show-refresh-view)) + +(defun notmuch-show-insert-tree (tree depth) + "Insert the message tree TREE at depth DEPTH in the current thread." + (let ((msg (car tree)) + (replies (cadr tree))) + ;; We test whether there is a message or just some replies. + (when msg + (notmuch-show-insert-msg msg depth)) + (notmuch-show-insert-thread replies (1+ depth)))) + +(defun notmuch-show-insert-thread (thread depth) + "Insert the thread THREAD at depth DEPTH in the current forest." + (mapc (lambda (tree) (notmuch-show-insert-tree tree depth)) thread)) + +(defun notmuch-show-insert-forest (forest) + "Insert the forest of threads FOREST." + (mapc (lambda (thread) (notmuch-show-insert-thread thread 0)) forest)) + +(defvar notmuch-id-regexp + (concat + ;; Match the id: prefix only if it begins a word (to disallow, for + ;; example, matching cid:). + "\\\"-parts and mid: links into +buttons for a corresponding notmuch search." + (goto-address-fontify-region start end) + (save-excursion + (let (links) + (goto-char start) + (while (re-search-forward notmuch-id-regexp end t) + (push (list (match-beginning 0) (match-end 0) + (match-string-no-properties 0)) links)) + (goto-char start) + (while (re-search-forward notmuch-mid-regexp end t) + (let* ((mid-cid (match-string-no-properties 1)) + (mid (save-match-data + (string-match "^[^/]*" mid-cid) + (url-unhex-string (match-string 0 mid-cid))))) + (push (list (match-beginning 0) (match-end 0) + (notmuch-id-to-query mid)) links))) + (dolist (link links) + ;; Remove the overlay created by goto-address-mode + (remove-overlays (first link) (second link) 'goto-address t) + (make-text-button (first link) (second link) + :type 'notmuch-button-type + 'action `(lambda (arg) + (notmuch-show ,(third link))) + 'follow-link t + 'help-echo "Mouse-1, RET: search for this message" + 'face goto-address-mail-face))))) + +;;;###autoload +(defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name) + "Run \"notmuch show\" with the given thread ID and display results. + +The optional PARENT-BUFFER is the notmuch-search buffer from +which this notmuch-show command was executed, (so that the +next thread from that buffer can be show when done with this +one). + +The optional QUERY-CONTEXT is a notmuch search term. Only +messages from the thread matching this search term are shown if +non-nil. + +The optional BUFFER-NAME provides the name of the buffer in +which the message thread is shown. If it is nil (which occurs +when the command is called interactively) the argument to the +function is used." + (interactive "sNotmuch show: ") + (let ((buffer-name (generate-new-buffer-name + (or buffer-name + (concat "*notmuch-" thread-id "*"))))) + (switch-to-buffer (get-buffer-create buffer-name)) + ;; Set the default value for `notmuch-show-process-crypto' in this + ;; buffer. + (setq notmuch-show-process-crypto notmuch-crypto-process-mime) + ;; Set the default value for + ;; `notmuch-show-elide-non-matching-messages' in this buffer. If + ;; there is a prefix argument, invert the default. + (setq notmuch-show-elide-non-matching-messages notmuch-show-only-matching-messages) + (if current-prefix-arg + (setq notmuch-show-elide-non-matching-messages (not notmuch-show-elide-non-matching-messages))) + + (setq notmuch-show-thread-id thread-id + notmuch-show-parent-buffer parent-buffer + notmuch-show-query-context query-context) + (notmuch-show-build-buffer) + (notmuch-show-goto-first-wanted-message) + (current-buffer))) + +(defun notmuch-show-build-buffer () + (let ((inhibit-read-only t)) + + (notmuch-show-mode) + ;; Don't track undo information for this buffer + (set 'buffer-undo-list t) + + (erase-buffer) + (goto-char (point-min)) + (save-excursion + (let* ((basic-args (list notmuch-show-thread-id)) + (args (if notmuch-show-query-context + (append (list "\'") basic-args + (list "and (" notmuch-show-query-context ")\'")) + (append (list "\'") basic-args (list "\'")))) + (cli-args (cons "--exclude=false" + (when notmuch-show-elide-non-matching-messages + (list "--entire-thread=false"))))) + + (notmuch-show-insert-forest (notmuch-query-get-threads (append cli-args args))) + ;; If the query context reduced the results to nothing, run + ;; the basic query. + (when (and (eq (buffer-size) 0) + notmuch-show-query-context) + (notmuch-show-insert-forest + (notmuch-query-get-threads (append cli-args basic-args))))) + + (jit-lock-register #'notmuch-show-buttonise-links) + + ;; Set the header line to the subject of the first message. + (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject))) + + (run-hooks 'notmuch-show-hook)))) + +(defun notmuch-show-capture-state () + "Capture the state of the current buffer. + +This includes: + - the list of open messages, + - the current message." + (list (notmuch-show-get-message-id) (notmuch-show-get-message-ids-for-open-messages))) + +(defun notmuch-show-apply-state (state) + "Apply STATE to the current buffer. + +This includes: + - opening the messages previously opened, + - closing all other messages, + - moving to the correct current message." + (let ((current (car state)) + (open (cadr state))) + + ;; Open those that were open. + (goto-char (point-min)) + (loop do (notmuch-show-message-visible (notmuch-show-get-message-properties) + (member (notmuch-show-get-message-id) open)) + until (not (notmuch-show-goto-message-next))) + + ;; Go to the previously open message. + (goto-char (point-min)) + (unless (loop if (string= current (notmuch-show-get-message-id)) + return t + until (not (notmuch-show-goto-message-next))) + (goto-char (point-min)) + (message "Previously current message not found.")) + (notmuch-show-message-adjust))) + +(defun notmuch-show-refresh-view (&optional reset-state) + "Refresh the current view. + +Refreshes the current view, observing changes in display +preferences. If invoked with a prefix argument (or RESET-STATE is +non-nil) then the state of the buffer (open/closed messages) is +reset based on the original query." + (interactive "P") + (let ((inhibit-read-only t) + (state (unless reset-state + (notmuch-show-capture-state)))) + ;; erase-buffer does not seem to remove overlays, which can lead + ;; to weird effects such as remaining images, so remove them + ;; manually. + (remove-overlays) + (erase-buffer) + (notmuch-show-build-buffer) + (if state + (notmuch-show-apply-state state) + ;; We're resetting state, so navigate to the first open message + ;; and mark it read, just like opening a new show buffer. + (notmuch-show-goto-first-wanted-message)))) + +(defvar notmuch-show-stash-map + (let ((map (make-sparse-keymap))) + (define-key map "c" 'notmuch-show-stash-cc) + (define-key map "d" 'notmuch-show-stash-date) + (define-key map "F" 'notmuch-show-stash-filename) + (define-key map "f" 'notmuch-show-stash-from) + (define-key map "i" 'notmuch-show-stash-message-id) + (define-key map "I" 'notmuch-show-stash-message-id-stripped) + (define-key map "s" 'notmuch-show-stash-subject) + (define-key map "T" 'notmuch-show-stash-tags) + (define-key map "t" 'notmuch-show-stash-to) + (define-key map "l" 'notmuch-show-stash-mlarchive-link) + (define-key map "L" 'notmuch-show-stash-mlarchive-link-and-go) + map) + "Submap for stash commands") +(fset 'notmuch-show-stash-map notmuch-show-stash-map) + +(defvar notmuch-show-part-map + (let ((map (make-sparse-keymap))) + (define-key map "s" 'notmuch-show-save-part) + (define-key map "v" 'notmuch-show-view-part) + (define-key map "o" 'notmuch-show-interactively-view-part) + (define-key map "|" 'notmuch-show-pipe-part) + map) + "Submap for part commands") +(fset 'notmuch-show-part-map notmuch-show-part-map) + +(defvar notmuch-show-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "?" 'notmuch-help) + (define-key map "q" 'notmuch-kill-this-buffer) + (define-key map (kbd "") 'widget-backward) + (define-key map (kbd "M-TAB") 'notmuch-show-previous-button) + (define-key map (kbd "") 'notmuch-show-previous-button) + (define-key map (kbd "TAB") 'notmuch-show-next-button) + (define-key map "s" 'notmuch-search) + (define-key map "m" 'notmuch-mua-new-mail) + (define-key map "f" 'notmuch-show-forward-message) + (define-key map "r" 'notmuch-show-reply-sender) + (define-key map "R" 'notmuch-show-reply) + (define-key map "|" 'notmuch-show-pipe-message) + (define-key map "w" 'notmuch-show-save-attachments) + (define-key map "V" 'notmuch-show-view-raw-message) + (define-key map "c" 'notmuch-show-stash-map) + (define-key map "=" 'notmuch-show-refresh-view) + (define-key map "h" 'notmuch-show-toggle-visibility-headers) + (define-key map "*" 'notmuch-show-tag-all) + (define-key map "-" 'notmuch-show-remove-tag) + (define-key map "+" 'notmuch-show-add-tag) + (define-key map "X" 'notmuch-show-archive-thread-then-exit) + (define-key map "x" 'notmuch-show-archive-message-then-next-or-exit) + (define-key map "A" 'notmuch-show-archive-thread-then-next) + (define-key map "a" 'notmuch-show-archive-message-then-next-or-next-thread) + (define-key map "N" 'notmuch-show-next-message) + (define-key map "P" 'notmuch-show-previous-message) + (define-key map "n" 'notmuch-show-next-open-message) + (define-key map "p" 'notmuch-show-previous-open-message) + (define-key map (kbd "M-n") 'notmuch-show-next-thread-show) + (define-key map (kbd "M-p") 'notmuch-show-previous-thread-show) + (define-key map (kbd "DEL") 'notmuch-show-rewind) + (define-key map " " 'notmuch-show-advance-and-archive) + (define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all) + (define-key map (kbd "RET") 'notmuch-show-toggle-message) + (define-key map "#" 'notmuch-show-print-message) + (define-key map "!" 'notmuch-show-toggle-elide-non-matching) + (define-key map "$" 'notmuch-show-toggle-process-crypto) + (define-key map "<" 'notmuch-show-toggle-thread-indentation) + (define-key map "t" 'toggle-truncate-lines) + (define-key map "." 'notmuch-show-part-map) + map) + "Keymap for \"notmuch show\" buffers.") +(fset 'notmuch-show-mode-map notmuch-show-mode-map) + +(defun notmuch-show-mode () + "Major mode for viewing a thread with notmuch. + +This buffer contains the results of the \"notmuch show\" command +for displaying a single thread of email from your email archives. + +By default, various components of email messages, (citations, +signatures, already-read messages), are hidden. You can make +these parts visible by clicking with the mouse button or by +pressing RET after positioning the cursor on a hidden part, (for +which \\[notmuch-show-next-button] and \\[notmuch-show-previous-button] are helpful). + +Reading the thread sequentially is well-supported by pressing +\\[notmuch-show-advance-and-archive]. This will scroll the current message (if necessary), advance +to the next message, or advance to the next thread (if already on +the last message of a thread). + +Other commands are available to read or manipulate the thread +more selectively, (such as '\\[notmuch-show-next-message]' and '\\[notmuch-show-previous-message]' to advance to messages +without removing any tags, and '\\[notmuch-show-archive-thread]' to archive an entire thread +without scrolling through with \\[notmuch-show-advance-and-archive]). + +You can add or remove arbitrary tags from the current message with +'\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'. + +All currently available key bindings: + +\\{notmuch-show-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map notmuch-show-mode-map) + (setq major-mode 'notmuch-show-mode + mode-name "notmuch-show") + (setq buffer-read-only t + truncate-lines t)) + +(defun notmuch-show-move-to-message-top () + (goto-char (notmuch-show-message-top))) + +(defun notmuch-show-move-to-message-bottom () + (goto-char (notmuch-show-message-bottom))) + +(defun notmuch-show-message-adjust () + (recenter 0)) + +;; Movement related functions. + +;; There's some strangeness here where a text property applied to a +;; region a->b is not found when point is at b. We walk backwards +;; until finding the property. +(defun notmuch-show-message-extent () + (let (r) + (save-excursion + (while (not (setq r (get-text-property (point) :notmuch-message-extent))) + (backward-char))) + r)) + +(defun notmuch-show-message-top () + (car (notmuch-show-message-extent))) + +(defun notmuch-show-message-bottom () + (cdr (notmuch-show-message-extent))) + +(defun notmuch-show-goto-message-next () + (let ((start (point))) + (notmuch-show-move-to-message-bottom) + (if (not (eobp)) + t + (goto-char start) + nil))) + +(defun notmuch-show-goto-message-previous () + (notmuch-show-move-to-message-top) + (if (bobp) + nil + (backward-char) + (notmuch-show-move-to-message-top) + t)) + +(defun notmuch-show-mapc (function) + "Iterate through all messages in the current thread with +`notmuch-show-goto-message-next' and call FUNCTION for side +effects." + (save-excursion + (goto-char (point-min)) + (loop do (funcall function) + while (notmuch-show-goto-message-next)))) + +;; Functions relating to the visibility of messages and their +;; components. + +(defun notmuch-show-message-visible (props visible-p) + (overlay-put (plist-get props :message-overlay) 'invisible (not visible-p)) + (notmuch-show-set-prop :message-visible visible-p props)) + +(defun notmuch-show-headers-visible (props visible-p) + (overlay-put (plist-get props :headers-overlay) 'invisible (not visible-p)) + (notmuch-show-set-prop :headers-visible visible-p props)) + +;; Functions for setting and getting attributes of the current +;; message. + +(defun notmuch-show-set-message-properties (props) + (save-excursion + (notmuch-show-move-to-message-top) + (put-text-property (point) (+ (point) 1) :notmuch-message-properties props))) + +(defun notmuch-show-get-message-properties () + "Return the properties of the current message as a plist. + +Some useful entries are: +:headers - Property list containing the headers :Date, :Subject, :From, etc. +:body - Body of the message +:tags - Tags for this message" + (save-excursion + (notmuch-show-move-to-message-top) + (get-text-property (point) :notmuch-message-properties))) + +(defun notmuch-show-get-part-properties () + "Return the properties of the innermost part containing point. + +This is the part property list retrieved from the CLI. Signals +an error if there is no part containing point." + (or (get-text-property (point) :notmuch-part) + (error "No message part here"))) + +(defun notmuch-show-set-prop (prop val &optional props) + (let ((inhibit-read-only t) + (props (or props + (notmuch-show-get-message-properties)))) + (plist-put props prop val) + (notmuch-show-set-message-properties props))) + +(defun notmuch-show-get-prop (prop &optional props) + (let ((props (or props + (notmuch-show-get-message-properties)))) + (plist-get props prop))) + +(defun notmuch-show-get-message-id (&optional bare) + "Return an id: query for the Message-Id of the current message. + +If optional argument BARE is non-nil, return +the Message-Id without id: prefix and escaping." + (if bare + (notmuch-show-get-prop :id) + (notmuch-id-to-query (notmuch-show-get-prop :id)))) + +(defun notmuch-show-get-messages-ids () + "Return all id: queries of messages in the current thread." + (let ((message-ids)) + (notmuch-show-mapc + (lambda () (push (notmuch-show-get-message-id) message-ids))) + message-ids)) + +(defun notmuch-show-get-messages-ids-search () + "Return a search string for all message ids of messages in the +current thread." + (mapconcat 'identity (notmuch-show-get-messages-ids) " or ")) + +;; dme: Would it make sense to use a macro for many of these? + +(defun notmuch-show-get-filename () + "Return the filename of the current message." + (notmuch-show-get-prop :filename)) + +(defun notmuch-show-get-header (header &optional props) + "Return the named header of the current message, if any." + (plist-get (notmuch-show-get-prop :headers props) header)) + +(defun notmuch-show-get-cc () + (notmuch-show-get-header :Cc)) + +(defun notmuch-show-get-date () + (notmuch-show-get-header :Date)) + +(defun notmuch-show-get-from () + (notmuch-show-get-header :From)) + +(defun notmuch-show-get-subject () + (notmuch-show-get-header :Subject)) + +(defun notmuch-show-get-to () + (notmuch-show-get-header :To)) + +(defun notmuch-show-get-depth () + (notmuch-show-get-prop :depth)) + +(defun notmuch-show-set-tags (tags) + "Set the tags of the current message." + (notmuch-show-set-prop :tags tags) + (notmuch-show-update-tags tags)) + +(defun notmuch-show-get-tags () + "Return the tags of the current message." + (notmuch-show-get-prop :tags)) + +(defun notmuch-show-message-visible-p () + "Is the current message visible?" + (notmuch-show-get-prop :message-visible)) + +(defun notmuch-show-headers-visible-p () + "Are the headers of the current message visible?" + (notmuch-show-get-prop :headers-visible)) + +(defun notmuch-show-mark-read (&optional unread) + "Mark the current message as read. + +Mark the current message as read by applying the tag changes in +`notmuch-show-mark-read-tags' to it (remove the \"unread\" tag by +default). If a prefix argument is given, the message will be +marked as unread, i.e. the tag changes in +`notmuch-show-mark-read-tags' will be reversed." + (interactive "P") + (when notmuch-show-mark-read-tags + (apply 'notmuch-show-tag-message + (notmuch-tag-change-list notmuch-show-mark-read-tags unread)))) + +;; Functions for getting attributes of several messages in the current +;; thread. + +(defun notmuch-show-get-message-ids-for-open-messages () + "Return a list of all id: queries for open messages in the current thread." + (save-excursion + (let (message-ids done) + (goto-char (point-min)) + (while (not done) + (if (notmuch-show-message-visible-p) + (setq message-ids (append message-ids (list (notmuch-show-get-message-id))))) + (setq done (not (notmuch-show-goto-message-next))) + ) + message-ids + ))) + +;; Commands typically bound to keys. + +(defun notmuch-show-advance () + "Advance through thread. + +If the current message in the thread is not yet fully visible, +scroll by a near screenful to read more of the message. + +Otherwise, (the end of the current message is already within the +current window), advance to the next open message." + (interactive) + (let* ((end-of-this-message (notmuch-show-message-bottom)) + (visible-end-of-this-message (1- end-of-this-message)) + (ret nil)) + (while (invisible-p visible-end-of-this-message) + (setq visible-end-of-this-message + (max (point-min) + (1- (previous-single-char-property-change + visible-end-of-this-message 'invisible))))) + (cond + ;; Ideally we would test `end-of-this-message' against the result + ;; of `window-end', but that doesn't account for the fact that + ;; the end of the message might be hidden. + ((and visible-end-of-this-message + (> visible-end-of-this-message (window-end))) + ;; The bottom of this message is not visible - scroll. + (scroll-up nil)) + + ((not (= end-of-this-message (point-max))) + ;; This is not the last message - move to the next visible one. + (notmuch-show-next-open-message)) + + ((not (= (point) (point-max))) + ;; This is the last message, but the cursor is not at the end of + ;; the buffer. Move it there. + (goto-char (point-max))) + + (t + ;; This is the last message - change the return value + (setq ret t))) + ret)) + +(defun notmuch-show-advance-and-archive () + "Advance through thread and archive. + +This command is intended to be one of the simplest ways to +process a thread of email. It works exactly like +notmuch-show-advance, in that it scrolls through messages in a +show buffer, except that when it gets to the end of the buffer it +archives the entire current thread, (apply changes in +`notmuch-archive-tags'), kills the buffer, and displays the next +thread from the search from which this thread was originally +shown." + (interactive) + (if (notmuch-show-advance) + (notmuch-show-archive-thread-then-next))) + +(defun notmuch-show-rewind () + "Backup through the thread, (reverse scrolling compared to \\[notmuch-show-advance-and-archive]). + +Specifically, if the beginning of the previous email is fewer +than `window-height' lines from the current point, move to it +just like `notmuch-show-previous-message'. + +Otherwise, just scroll down a screenful of the current message. + +This command does not modify any message tags, (it does not undo +any effects from previous calls to +`notmuch-show-advance-and-archive'." + (interactive) + (let ((start-of-message (notmuch-show-message-top)) + (start-of-window (window-start))) + (cond + ;; Either this message is properly aligned with the start of the + ;; window or the start of this message is not visible on the + ;; screen - scroll. + ((or (= start-of-message start-of-window) + (< start-of-message start-of-window)) + (scroll-down) + ;; If a small number of lines from the previous message are + ;; visible, realign so that the top of the current message is at + ;; the top of the screen. + (when (<= (count-screen-lines (window-start) start-of-message) + next-screen-context-lines) + (goto-char (notmuch-show-message-top)) + (notmuch-show-message-adjust)) + ;; Move to the top left of the window. + (goto-char (window-start))) + (t + ;; Move to the previous message. + (notmuch-show-previous-message))))) + +(defun notmuch-show-reply (&optional prompt-for-sender) + "Reply to the sender and all recipients of the current message." + (interactive "P") + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender t)) + +(defun notmuch-show-reply-sender (&optional prompt-for-sender) + "Reply to the sender of the current message." + (interactive "P") + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender nil)) + +(defun notmuch-show-forward-message (&optional prompt-for-sender) + "Forward the current message." + (interactive "P") + (with-current-notmuch-show-message + (notmuch-mua-new-forward-message prompt-for-sender))) + +(defun notmuch-show-next-message (&optional pop-at-end) + "Show the next message. + +If a prefix argument is given and this is the last message in the +thread, navigate to the next thread in the parent search buffer." + (interactive "P") + (if (notmuch-show-goto-message-next) + (progn + (notmuch-show-mark-read) + (notmuch-show-message-adjust)) + (if pop-at-end + (notmuch-show-next-thread) + (goto-char (point-max))))) + +(defun notmuch-show-previous-message () + "Show the previous message or the start of the current message." + (interactive) + (if (= (point) (notmuch-show-message-top)) + (notmuch-show-goto-message-previous) + (notmuch-show-move-to-message-top)) + (notmuch-show-mark-read) + (notmuch-show-message-adjust)) + +(defun notmuch-show-next-open-message (&optional pop-at-end) + "Show the next open message. + +If a prefix argument is given and this is the last open message +in the thread, navigate to the next thread in the parent search +buffer. Return t if there was a next open message in the thread +to show, nil otherwise." + (interactive "P") + (let (r) + (while (and (setq r (notmuch-show-goto-message-next)) + (not (notmuch-show-message-visible-p)))) + (if r + (progn + (notmuch-show-mark-read) + (notmuch-show-message-adjust)) + (if pop-at-end + (notmuch-show-next-thread) + (goto-char (point-max)))) + r)) + +(defun notmuch-show-next-matching-message () + "Show the next matching message." + (interactive) + (let (r) + (while (and (setq r (notmuch-show-goto-message-next)) + (not (notmuch-show-get-prop :match)))) + (if r + (progn + (notmuch-show-mark-read) + (notmuch-show-message-adjust)) + (goto-char (point-max))))) + +(defun notmuch-show-open-if-matched () + "Open a message if it is matched (whether or not excluded)." + (let ((props (notmuch-show-get-message-properties))) + (notmuch-show-message-visible props (plist-get props :match)))) + +(defun notmuch-show-goto-first-wanted-message () + "Move to the first open message and mark it read" + (goto-char (point-min)) + (if (notmuch-show-message-visible-p) + (notmuch-show-mark-read) + (notmuch-show-next-open-message)) + (when (eobp) + ;; There are no matched non-excluded messages so open all matched + ;; (necessarily excluded) messages and go to the first. + (notmuch-show-mapc 'notmuch-show-open-if-matched) + (force-window-update) + (goto-char (point-min)) + (if (notmuch-show-message-visible-p) + (notmuch-show-mark-read) + (notmuch-show-next-open-message)))) + +(defun notmuch-show-previous-open-message () + "Show the previous open message." + (interactive) + (while (and (if (= (point) (notmuch-show-message-top)) + (notmuch-show-goto-message-previous) + (notmuch-show-move-to-message-top)) + (not (notmuch-show-message-visible-p)))) + (notmuch-show-mark-read) + (notmuch-show-message-adjust)) + +(defun notmuch-show-view-raw-message () + "View the file holding the current message." + (interactive) + (let* ((id (notmuch-show-get-message-id)) + (buf (get-buffer-create (concat "*notmuch-raw-" id "*")))) + (call-process notmuch-command nil buf nil "show" "--format=raw" id) + (switch-to-buffer buf) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (view-buffer buf 'kill-buffer-if-not-modified))) + +(defun notmuch-show-pipe-message (entire-thread command) + "Pipe the contents of the current message (or thread) to the given command. + +The given command will be executed with the raw contents of the +current email message as stdin. Anything printed by the command +to stdout or stderr will appear in the *notmuch-pipe* buffer. + +When invoked with a prefix argument, the command will receive all +open messages in the current thread (formatted as an mbox) rather +than only the current message." + (interactive (let ((query-string (if current-prefix-arg + "Pipe all open messages to command: " + "Pipe message to command: "))) + (list current-prefix-arg (read-string query-string)))) + (let (shell-command) + (if entire-thread + (setq shell-command + (concat notmuch-command " show --format=mbox --exclude=false " + (shell-quote-argument + (mapconcat 'identity (notmuch-show-get-message-ids-for-open-messages) " OR ")) + " | " command)) + (setq shell-command + (concat notmuch-command " show --format=raw " + (shell-quote-argument (notmuch-show-get-message-id)) " | " command))) + (let ((buf (get-buffer-create (concat "*notmuch-pipe*")))) + (with-current-buffer buf + (setq buffer-read-only nil) + (erase-buffer) + (let ((exit-code (call-process-shell-command shell-command nil buf))) + (goto-char (point-max)) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (unless (zerop exit-code) + (switch-to-buffer-other-window buf) + (message (format "Command '%s' exited abnormally with code %d" + shell-command exit-code)))))))) + +(defun notmuch-show-tag-message (&rest tag-changes) + "Change tags for the current message. + +TAG-CHANGES is a list of tag operations for `notmuch-tag'." + (let* ((current-tags (notmuch-show-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes))) + (unless (equal current-tags new-tags) + (notmuch-tag (notmuch-show-get-message-id) tag-changes) + (notmuch-show-set-tags new-tags)))) + +(defun notmuch-show-tag (&optional tag-changes) + "Change tags for the current message. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (let* ((tag-changes (notmuch-tag (notmuch-show-get-message-id) tag-changes)) + (current-tags (notmuch-show-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes))) + (unless (equal current-tags new-tags) + (notmuch-show-set-tags new-tags)))) + +(defun notmuch-show-tag-all (&optional tag-changes) + "Change tags for all messages in the current show buffer. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (setq tag-changes (notmuch-tag (notmuch-show-get-messages-ids-search) tag-changes)) + (notmuch-show-mapc + (lambda () + (let* ((current-tags (notmuch-show-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes))) + (unless (equal current-tags new-tags) + (notmuch-show-set-tags new-tags)))))) + +(defun notmuch-show-add-tag () + "Same as `notmuch-show-tag' but sets initial input to '+'." + (interactive) + (notmuch-show-tag "+")) + +(defun notmuch-show-remove-tag () + "Same as `notmuch-show-tag' but sets initial input to '-'." + (interactive) + (notmuch-show-tag "-")) + +(defun notmuch-show-toggle-visibility-headers () + "Toggle the visibility of the current message headers." + (interactive) + (let ((props (notmuch-show-get-message-properties))) + (notmuch-show-headers-visible + props + (not (plist-get props :headers-visible)))) + (force-window-update)) + +(defun notmuch-show-toggle-message () + "Toggle the visibility of the current message." + (interactive) + (let ((props (notmuch-show-get-message-properties))) + (notmuch-show-message-visible + props + (not (plist-get props :message-visible)))) + (force-window-update)) + +(defun notmuch-show-open-or-close-all () + "Set the visibility all of the messages in the current thread. +By default make all of the messages visible. With a prefix +argument, hide all of the messages." + (interactive) + (save-excursion + (goto-char (point-min)) + (loop do (notmuch-show-message-visible (notmuch-show-get-message-properties) + (not current-prefix-arg)) + until (not (notmuch-show-goto-message-next)))) + (force-window-update)) + +(defun notmuch-show-next-button () + "Advance point to the next button in the buffer." + (interactive) + (forward-button 1)) + +(defun notmuch-show-previous-button () + "Move point back to the previous button in the buffer." + (interactive) + (backward-button 1)) + +(defun notmuch-show-next-thread (&optional show previous) + "Move to the next item in the search results, if any. + +If SHOW is non-nil, open the next item in a show +buffer. Otherwise just highlight the next item in the search +buffer. If PREVIOUS is non-nil, move to the previous item in the +search results instead." + (interactive "P") + (let ((parent-buffer notmuch-show-parent-buffer)) + (notmuch-kill-this-buffer) + (when (buffer-live-p parent-buffer) + (switch-to-buffer parent-buffer) + (and (if previous + (notmuch-search-previous-thread) + (notmuch-search-next-thread)) + show + (notmuch-search-show-thread))))) + +(defun notmuch-show-next-thread-show () + "Show the next thread in the search results, if any." + (interactive) + (notmuch-show-next-thread t)) + +(defun notmuch-show-previous-thread-show () + "Show the previous thread in the search results, if any." + (interactive) + (notmuch-show-next-thread t t)) + +(defun notmuch-show-archive-thread (&optional unarchive) + "Archive each message in thread. + +Archive each message currently shown by applying the tag changes +in `notmuch-archive-tags' to each. If a prefix argument is given, +the messages will be \"unarchived\", i.e. the tag changes in +`notmuch-archive-tags' will be reversed. + +Note: This command is safe from any race condition of new messages +being delivered to the same thread. It does not archive the +entire thread, but only the messages shown in the current +buffer." + (interactive "P") + (when notmuch-archive-tags + (notmuch-show-tag-all + (notmuch-tag-change-list notmuch-archive-tags unarchive)))) + +(defun notmuch-show-archive-thread-then-next () + "Archive all messages in the current buffer, then show next thread from search." + (interactive) + (notmuch-show-archive-thread) + (notmuch-show-next-thread t)) + +(defun notmuch-show-archive-thread-then-exit () + "Archive all messages in the current buffer, then exit back to search results." + (interactive) + (notmuch-show-archive-thread) + (notmuch-show-next-thread)) + +(defun notmuch-show-archive-message (&optional unarchive) + "Archive the current message. + +Archive the current message by applying the tag changes in +`notmuch-archive-tags' to it. If a prefix argument is given, the +message will be \"unarchived\", i.e. the tag changes in +`notmuch-archive-tags' will be reversed." + (interactive "P") + (when notmuch-archive-tags + (apply 'notmuch-show-tag-message + (notmuch-tag-change-list notmuch-archive-tags unarchive)))) + +(defun notmuch-show-archive-message-then-next-or-exit () + "Archive the current message, then show the next open message in the current thread. + +If at the last open message in the current thread, then exit back +to search results." + (interactive) + (notmuch-show-archive-message) + (notmuch-show-next-open-message t)) + +(defun notmuch-show-archive-message-then-next-or-next-thread () + "Archive the current message, then show the next open message in the current thread. + +If at the last open message in the current thread, then show next +thread from search." + (interactive) + (notmuch-show-archive-message) + (unless (notmuch-show-next-open-message) + (notmuch-show-next-thread t))) + +(defun notmuch-show-stash-cc () + "Copy CC field of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-cc))) + +(defun notmuch-show-stash-date () + "Copy date of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-date))) + +(defun notmuch-show-stash-filename () + "Copy filename of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-filename))) + +(defun notmuch-show-stash-from () + "Copy From address of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-from))) + +(defun notmuch-show-stash-message-id (&optional stash-thread-id) + "Copy id: query matching the current message to kill-ring. + +If invoked with a prefix argument (or STASH-THREAD-ID is +non-nil), copy thread: query matching the current thread to +kill-ring." + (interactive "P") + (if stash-thread-id + (notmuch-common-do-stash notmuch-show-thread-id) + (notmuch-common-do-stash (notmuch-show-get-message-id)))) + +(defun notmuch-show-stash-message-id-stripped () + "Copy message ID of current message (sans `id:' prefix) to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-message-id t))) + +(defun notmuch-show-stash-subject () + "Copy Subject field of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-subject))) + +(defun notmuch-show-stash-tags () + "Copy tags of current message to kill-ring as a comma separated list." + (interactive) + (notmuch-common-do-stash (mapconcat 'identity (notmuch-show-get-tags) ","))) + +(defun notmuch-show-stash-to () + "Copy To address of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-to))) + +(defun notmuch-show-stash-mlarchive-link (&optional mla) + "Copy an ML Archive URI for the current message to the kill-ring. + +This presumes that the message is available at the selected Mailing List Archive. + +If optional argument MLA is non-nil, use the provided key instead of prompting +the user (see `notmuch-show-stash-mlarchive-link-alist')." + (interactive) + (notmuch-common-do-stash + (concat (cdr (assoc + (or mla + (let ((completion-ignore-case t)) + (completing-read + "Mailing List Archive: " + notmuch-show-stash-mlarchive-link-alist + nil t nil nil notmuch-show-stash-mlarchive-link-default))) + notmuch-show-stash-mlarchive-link-alist)) + (notmuch-show-get-message-id t)))) + +(defun notmuch-show-stash-mlarchive-link-and-go (&optional mla) + "Copy an ML Archive URI for the current message to the kill-ring and visit it. + +This presumes that the message is available at the selected Mailing List Archive. + +If optional argument MLA is non-nil, use the provided key instead of prompting +the user (see `notmuch-show-stash-mlarchive-link-alist')." + (interactive) + (notmuch-show-stash-mlarchive-link mla) + (browse-url (current-kill 0 t))) + +;; Interactive part functions and their helpers + +(defun notmuch-show-generate-part-buffer (message-id nth) + "Return a temporary buffer containing the specified part's content." + (let ((buf (generate-new-buffer " *notmuch-part*")) + (process-crypto notmuch-show-process-crypto)) + (with-current-buffer buf + (setq notmuch-show-process-crypto process-crypto) + ;; Always acquires the part via `notmuch part', even if it is + ;; available in the SEXP output. + (insert (notmuch-get-bodypart-internal message-id nth notmuch-show-process-crypto))) + buf)) + +(defun notmuch-show-current-part-handle () + "Return an mm-handle for the part containing point. + +This creates a temporary buffer for the part's content; the +caller is responsible for killing this buffer as appropriate." + (let* ((part (notmuch-show-get-part-properties)) + (message-id (notmuch-show-get-message-id)) + (nth (plist-get part :id)) + (buf (notmuch-show-generate-part-buffer message-id nth)) + (content-type (plist-get part :content-type)) + (filename (plist-get part :filename)) + (disposition (if filename `(attachment (filename . ,filename))))) + (mm-make-handle buf (list content-type) nil nil disposition))) + +(defun notmuch-show-apply-to-current-part-handle (fn) + "Apply FN to an mm-handle for the part containing point. + +This ensures that the temporary buffer created for the mm-handle +is destroyed when FN returns." + (let ((handle (notmuch-show-current-part-handle))) + (unwind-protect + (funcall fn handle) + (kill-buffer (mm-handle-buffer handle))))) + +(defun notmuch-show-part-button-default (&optional button) + (interactive) + (let ((button (or button (button-at (point))))) + ;; Try to toggle the part, if that fails then call the default + ;; action. The toggle fails if the part has no emacs renderable + ;; content. + (unless (notmuch-show-toggle-part-invisibility button) + (call-interactively notmuch-show-part-button-default-action)))) + +(defun notmuch-show-save-part () + "Save the MIME part containing point to a file." + (interactive) + (notmuch-show-apply-to-current-part-handle #'mm-save-part)) + +(defun notmuch-show-view-part () + "View the MIME part containing point in an external viewer." + (interactive) + ;; Set mm-inlined-types to nil to force an external viewer + (let ((mm-inlined-types nil)) + (notmuch-show-apply-to-current-part-handle #'mm-display-part))) + +(defun notmuch-show-interactively-view-part () + "View the MIME part containing point, prompting for a viewer." + (interactive) + (notmuch-show-apply-to-current-part-handle #'mm-interactively-view-part)) + +(defun notmuch-show-pipe-part () + "Pipe the MIME part containing point to an external command." + (interactive) + (notmuch-show-apply-to-current-part-handle #'mm-pipe-part)) + + +(provide 'notmuch-show) diff --git a/emacs/notmuch/notmuch-tag.el b/emacs/notmuch/notmuch-tag.el new file mode 100644 index 0000000..064cfa8 --- /dev/null +++ b/emacs/notmuch/notmuch-tag.el @@ -0,0 +1,298 @@ +;; notmuch-tag.el --- tag messages within emacs +;; +;; Copyright © Damien Cassou +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Carl Worth +;; Damien Cassou +;; +;;; Code: +;; + +(require 'cl) +(require 'crm) +(require 'notmuch-lib) + +(defcustom notmuch-tag-formats + '(("unread" (propertize tag 'face '(:foreground "red"))) + ("flagged" (notmuch-tag-format-image-data tag (notmuch-tag-star-icon)))) + "Custom formats for individual tags. + +This gives a list that maps from tag names to lists of formatting +expressions. The car of each element gives a tag name and the +cdr gives a list of Elisp expressions that modify the tag. If +the list is empty, the tag will simply be hidden. Otherwise, +each expression will be evaluated in order: for the first +expression, the variable `tag' will be bound to the tag name; for +each later expression, the variable `tag' will be 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 will 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 + :type '(alist :key-type (string :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 + (propertize tag 'face)) + (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"))))) + +(defun notmuch-tag-format-image-data (tag data) + "Replace TAG with image DATA, if available. + +This function returns a propertized string that will display image +DATA in place of TAG.This is designed for use in +`notmuch-tag-formats'. + +DATA is the content of an SVG picture (e.g., as returned by +`notmuch-tag-star-icon')." + (propertize tag 'display + `(image :type svg + :data ,data + :ascent center + :mask heuristic))) + +(defun notmuch-tag-star-icon () + "Return SVG data representing a star icon. +This can be used with `notmuch-tag-format-image-data'." +" + + + + +") + +(defun notmuch-tag-star-empty-icon () + "Return SVG data representing an empty star icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-tag-icon () + "Return SVG data representing a tag icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-format-tag (tag) + "Format TAG by looking into `notmuch-tag-formats'." + (let ((formats (assoc tag notmuch-tag-formats))) + (cond + ((null formats) ;; - Tag not in `notmuch-tag-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, + (let ((tag tag)) ;; we must apply all the formats. + (dolist (format (cdr formats) tag) + (setq tag (eval format)))))))) + +(defun notmuch-tag-format-tags (tags) + "Return a string representing formatted TAGS." + (notmuch-combine-face-text-property-string + (mapconcat #'identity + ;; nil indicated that the tag was deliberately hidden + (delq nil (mapcar #'notmuch-tag-format-tag tags)) + " ") + 'notmuch-tag-face + t)) + +(defcustom notmuch-before-tag-hook nil + "Hooks that are run before tags of a message are modified. + +'tags' 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. + +'tags' 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) + +(defvar notmuch-select-tag-history nil + "Variable to store minibuffer history for +`notmuch-select-tag-with-completion' function.") + +(defvar notmuch-read-tag-changes-history nil + "Variable to store minibuffer history for +`notmuch-read-tag-changes' function.") + +(defun notmuch-tag-completions (&optional search-terms) + (if (null search-terms) + (setq search-terms (list "*"))) + (split-string + (with-output-to-string + (with-current-buffer standard-output + (apply '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) + (let ((tag-list (notmuch-tag-completions search-terms))) + (completing-read prompt tag-list nil nil nil 'notmuch-select-tag-history))) + +(defun notmuch-read-tag-changes (&optional initial-input &rest search-terms) + (let* ((all-tag-list (notmuch-tag-completions)) + (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list)) + (remove-tag-list (mapcar (apply-partially 'concat "-") + (if (null search-terms) + all-tag-list + (notmuch-tag-completions search-terms)))) + (tag-list (append add-tag-list remove-tag-list)) + (crm-separator " ") + ;; By default, space is bound to "complete word" function. + ;; Re-bind it to insert a space instead. Note that + ;; still does the completion. + (crm-local-completion-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map crm-local-completion-map) + (define-key map " " 'self-insert-command) + map))) + (delete "" (completing-read-multiple "Tags (+add -drop): " + tag-list nil nil initial-input + 'notmuch-read-tag-changes-history)))) + +(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 ((op (string-to-char tag-change)) + (tag (unless (string= tag-change "") (substring tag-change 1)))) + (case op + (?+ (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<))) + +(defun notmuch-tag (query &optional tag-changes) + "Add/remove tags in TAG-CHANGES to messages matching QUERY. + +QUERY should be a string containing the search-terms. +TAG-CHANGES can take multiple forms. If TAG-CHANGES is a list of +strings of the form \"+tag\" or \"-tag\" then those are the tag +changes applied. If TAG-CHANGES is a string then it is +interpreted as a single tag change. If TAG-CHANGES is the string +\"-\" or \"+\", or null, then the user is prompted to enter the +tag changes. + +Note: Other code should always use this function 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 + (if (string-or-null-p tag-changes) + (if (or (string= tag-changes "-") (string= tag-changes "+") (null tag-changes)) + (setq tag-changes (notmuch-read-tag-changes tag-changes query)) + (setq tag-changes (list tag-changes)))) + (mapc (lambda (tag-change) + (unless (string-match-p "^[-+]\\S-+$" tag-change) + (error "Tag must be of the form `+this_tag' or `-that_tag'"))) + tag-changes) + (unless (null tag-changes) + (run-hooks 'notmuch-before-tag-hook) + (apply 'notmuch-call-notmuch-process "tag" + (append tag-changes (list "--" query))) + (run-hooks 'notmuch-after-tag-hook)) + ;; in all cases we return tag-changes as a list + tag-changes) + +(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)) + + +;; + +(provide 'notmuch-tag) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: diff --git a/emacs/notmuch/notmuch-wash.el b/emacs/notmuch/notmuch-wash.el new file mode 100644 index 0000000..8fe91e1 --- /dev/null +++ b/emacs/notmuch/notmuch-wash.el @@ -0,0 +1,382 @@ +;; notmuch-wash.el --- cleaning up message bodies +;; +;; Copyright © Carl Worth +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Carl Worth +;; David Edmondson + +(require 'coolj) + +(declare-function notmuch-show-insert-bodypart "notmuch-show" (msg part depth &optional hide)) + +;; + +(defvar notmuch-wash-signature-regexp + "^\\(-- ?\\|_+\\)$" + "Pattern to match a line that separates content from signature.") + +(defvar notmuch-wash-citation-regexp + "\\(^[[:space:]]*>.*\n\\)+" + "Pattern to match citation lines.") + +(defvar 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.") + +(defvar 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") + +(defvar 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") + +(defvar 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") + +(defvar 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") + +(defvar 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") + +(defvar 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") + +(defvar notmuch-wash-signature-lines-max 12 + "Maximum length of signature that will be hidden by default.") + +(defvar 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.") + +(defvar 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.") + +(defvar 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 or at the window width (whichever one is +lower).") + +(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 'font-lock-comment-face + :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 (concat "notmuch-wash-button-" + type "-" state "-format")))) + (lines-count (count-lines (overlay-start overlay) (overlay-end overlay)))) + (format label-format lines-count))) + +(defun notmuch-wash-region-to-button (msg 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) + (if 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)))))) + +(defun notmuch-wash-excerpt-citations (msg depth) + "Excerpt citations and up to one signature." + (goto-char (point-min)) + (beginning-of-line) + (if (and (< (point) (point-max)) + (re-search-forward notmuch-wash-original-regexp nil t)) + (let* ((msg-start (match-beginning 0)) + (msg-end (point-max)) + (msg-lines (count-lines msg-start msg-end))) + (notmuch-wash-region-to-button + msg msg-start msg-end "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 'message-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 + msg hidden-start (point-marker) + "citation"))))) + (if (and (not (eobp)) + (re-search-forward notmuch-wash-signature-regexp nil t)) + (let* ((sig-start (match-beginning 0)) + (sig-end (match-end 0)) + (sig-lines (count-lines sig-start (point-max)))) + (if (<= sig-lines 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 + msg 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)) + (if (looking-at "\n") + (delete-region (match-beginning 0) (match-end 0))) + + ;; Remove a trailing blank line. + (goto-char (point-max)) + (if (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) + (limit (if (numberp notmuch-wash-wrap-lines-length) + (min notmuch-wash-wrap-lines-length + (window-width)) + (window-width))) + (fill-column (- limit + depth + ;; 2 to avoid poor interaction with + ;; `word-wrap'. + 2))) + (coolj-wrap-region (point-min) (point-max)))) + +;; + +(require 'diff-mode) + +(defvar diff-file-header-re) ; From `diff-mode.el'. + +(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." + (when (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) + (if (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) diff --git a/emacs/notmuch/notmuch.el b/emacs/notmuch/notmuch.el new file mode 100644 index 0000000..f3ce840 --- /dev/null +++ b/emacs/notmuch/notmuch.el @@ -0,0 +1,1082 @@ +;; notmuch.el --- run notmuch within emacs +;; +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Notmuch. If not, see . +;; +;; Authors: Carl Worth + +;; This is an emacs-based interface to the notmuch mail system. +;; +;; You will first need to have the notmuch program installed and have a +;; notmuch database built in order to use this. See +;; http://notmuchmail.org for details. +;; +;; To install this software, copy it to a directory that is on the +;; `load-path' variable within emacs (a good candidate is +;; /usr/local/share/emacs/site-lisp). If you are viewing this from the +;; notmuch source distribution then you can simply run: +;; +;; sudo make install-emacs +;; +;; to install it. +;; +;; Then, to actually run it, add: +;; +;; (require 'notmuch) +;; +;; to your ~/.emacs file, and then run "M-x notmuch" from within emacs, +;; or run: +;; +;; emacs -f notmuch +;; +;; Have fun, and let us know if you have any comment, questions, or +;; kudos: Notmuch list (subscription is not +;; required, but is available from http://notmuchmail.org). + +(eval-when-compile (require 'cl)) +(require 'mm-view) +(require 'message) + +(require 'notmuch-lib) +(require 'notmuch-tag) +(require 'notmuch-show) +(require 'notmuch-mua) +(require 'notmuch-hello) +(require 'notmuch-maildir-fcc) +(require 'notmuch-message) +(require 'notmuch-parser) + +(defcustom notmuch-search-result-format + `(("date" . "%12s ") + ("count" . "%-7s ") + ("authors" . "%-20s ") + ("subject" . "%s ") + ("tags" . "(%s)")) + "Search result formatting. Supported fields are: + date, count, authors, subject, tags +For example: + (setq notmuch-search-result-format \(\(\"authors\" . \"%-40s\"\) + \(\"subject\" . \"%s\"\)\)\) +Line breaks are permitted in format strings (though this is +currently experimental). Note that a line break at the end of an +\"authors\" field will get elided if the authors list is long; +place it instead at the beginning of the following field. To +enter a line break when setting this variable with setq, use \\n. +To enter a line break in customize, press \\[quoted-insert] C-j." + :type '(alist :key-type (string) :value-type (string)) + :group 'notmuch-search) + +(defvar notmuch-query-history nil + "Variable to store minibuffer history for notmuch queries") + +(defun notmuch-foreach-mime-part (function mm-handle) + (cond ((stringp (car mm-handle)) + (dolist (part (cdr mm-handle)) + (notmuch-foreach-mime-part function part))) + ((bufferp (car mm-handle)) + (funcall function mm-handle)) + (t (dolist (part mm-handle) + (notmuch-foreach-mime-part function part))))) + +(defun notmuch-count-attachments (mm-handle) + (let ((count 0)) + (notmuch-foreach-mime-part + (lambda (p) + (let ((disposition (mm-handle-disposition p))) + (and (listp disposition) + (or (equal (car disposition) "attachment") + (and (equal (car disposition) "inline") + (assq 'filename disposition))) + (incf count)))) + mm-handle) + count)) + +(defun notmuch-save-attachments (mm-handle &optional queryp) + (notmuch-foreach-mime-part + (lambda (p) + (let ((disposition (mm-handle-disposition p))) + (and (listp disposition) + (or (equal (car disposition) "attachment") + (and (equal (car disposition) "inline") + (assq 'filename disposition))) + (or (not queryp) + (y-or-n-p + (concat "Save '" (cdr (assq 'filename disposition)) "' "))) + (mm-save-part p)))) + mm-handle)) + +(defun notmuch-documentation-first-line (symbol) + "Return the first line of the documentation string for SYMBOL." + (let ((doc (documentation symbol))) + (if doc + (with-temp-buffer + (insert (documentation symbol t)) + (goto-char (point-min)) + (let ((beg (point))) + (end-of-line) + (buffer-substring beg (point)))) + ""))) + +(defun notmuch-prefix-key-description (key) + "Given a prefix key code, return a human-readable string representation. + +This is basically just `format-kbd-macro' but we also convert ESC to M-." + (let ((desc (format-kbd-macro (vector key)))) + (if (string= desc "ESC") + "M-" + (concat desc " ")))) + +;; I would think that emacs would have code handy for walking a keymap +;; and generating strings for each key, and I would prefer to just call +;; that. But I couldn't find any (could be all implemented in C I +;; suppose), so I wrote my own here. +(defun notmuch-substitute-one-command-key-with-prefix (prefix binding) + "For a key binding, return a string showing a human-readable +representation of the prefixed key as well as the first line of +documentation from the bound function. + +For a mouse binding, return nil." + (let ((key (car binding)) + (action (cdr binding))) + (if (mouse-event-p key) + nil + (if (keymapp action) + (let ((substitute (apply-partially 'notmuch-substitute-one-command-key-with-prefix (notmuch-prefix-key-description key))) + (as-list)) + (map-keymap (lambda (a b) + (push (cons a b) as-list)) + action) + (mapconcat substitute as-list "\n")) + (concat prefix (format-kbd-macro (vector key)) + "\t" + (notmuch-documentation-first-line action)))))) + +(defun notmuch-substitute-command-keys-one (key) + ;; A `keymap' key indicates inheritance from a parent keymap - the + ;; inherited mappings follow, so there is nothing to print for + ;; `keymap' itself. + (when (not (eq key 'keymap)) + (notmuch-substitute-one-command-key-with-prefix nil key))) + +(defun notmuch-substitute-command-keys (doc) + "Like `substitute-command-keys' but with documentation, not function names." + (let ((beg 0)) + (while (string-match "\\\\{\\([^}[:space:]]*\\)}" doc beg) + (let* ((keymap-name (substring doc (match-beginning 1) (match-end 1))) + (keymap (symbol-value (intern keymap-name)))) + (setq doc (replace-match + (mapconcat #'notmuch-substitute-command-keys-one + (cdr keymap) "\n") + 1 1 doc))) + (setq beg (match-end 0))) + doc)) + +(defun notmuch-help () + "Display help for the current notmuch mode." + (interactive) + (let* ((mode major-mode) + (doc (substitute-command-keys (notmuch-substitute-command-keys (documentation mode t))))) + (with-current-buffer (generate-new-buffer "*notmuch-help*") + (insert doc) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (view-buffer (current-buffer) 'kill-buffer-if-not-modified)))) + +(require 'hl-line) + +(defun notmuch-hl-line-mode () + (prog1 (hl-line-mode) + (when hl-line-overlay + (overlay-put hl-line-overlay 'priority 1)))) + +(defcustom notmuch-search-hook '(notmuch-hl-line-mode) + "List of functions to call when notmuch displays the search results." + :type 'hook + :options '(notmuch-hl-line-mode) + :group 'notmuch-search + :group 'notmuch-hooks) + +(defvar notmuch-search-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "?" 'notmuch-help) + (define-key map "q" 'notmuch-search-quit) + (define-key map "x" 'notmuch-search-quit) + (define-key map (kbd "") 'notmuch-search-scroll-down) + (define-key map "b" 'notmuch-search-scroll-down) + (define-key map " " 'notmuch-search-scroll-up) + (define-key map "<" 'notmuch-search-first-thread) + (define-key map ">" 'notmuch-search-last-thread) + (define-key map "p" 'notmuch-search-previous-thread) + (define-key map "n" 'notmuch-search-next-thread) + (define-key map "r" 'notmuch-search-reply-to-thread-sender) + (define-key map "R" 'notmuch-search-reply-to-thread) + (define-key map "m" 'notmuch-mua-new-mail) + (define-key map "s" 'notmuch-search) + (define-key map "o" 'notmuch-search-toggle-order) + (define-key map "c" 'notmuch-search-stash-map) + (define-key map "=" 'notmuch-search-refresh-view) + (define-key map "G" 'notmuch-search-poll-and-refresh-view) + (define-key map "t" 'notmuch-search-filter-by-tag) + (define-key map "f" 'notmuch-search-filter) + (define-key map [mouse-1] 'notmuch-search-show-thread) + (define-key map "*" 'notmuch-search-tag-all) + (define-key map "a" 'notmuch-search-archive-thread) + (define-key map "-" 'notmuch-search-remove-tag) + (define-key map "+" 'notmuch-search-add-tag) + (define-key map (kbd "RET") 'notmuch-search-show-thread) + map) + "Keymap for \"notmuch search\" buffers.") +(fset 'notmuch-search-mode-map notmuch-search-mode-map) + +(defvar notmuch-search-stash-map + (let ((map (make-sparse-keymap))) + (define-key map "i" 'notmuch-search-stash-thread-id) + map) + "Submap for stash commands") +(fset 'notmuch-search-stash-map notmuch-search-stash-map) + +(defun notmuch-search-stash-thread-id () + "Copy thread ID of current thread to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-search-find-thread-id))) + +(defvar notmuch-search-query-string) +(defvar notmuch-search-target-thread) +(defvar notmuch-search-target-line) +(defvar notmuch-search-continuation) + +(defvar notmuch-search-disjunctive-regexp "\\<[oO][rR]\\>") + +(defun notmuch-search-quit () + "Exit the search buffer, calling any defined continuation function." + (interactive) + (let ((continuation notmuch-search-continuation)) + (notmuch-kill-this-buffer) + (when continuation + (funcall continuation)))) + +(defun notmuch-search-scroll-up () + "Move forward through search results by one window's worth." + (interactive) + (condition-case nil + (scroll-up nil) + ((end-of-buffer) (notmuch-search-last-thread)))) + +(defun notmuch-search-scroll-down () + "Move backward through the search results by one window's worth." + (interactive) + ;; I don't know why scroll-down doesn't signal beginning-of-buffer + ;; the way that scroll-up signals end-of-buffer, but c'est la vie. + ;; + ;; So instead of trapping a signal we instead check whether the + ;; window begins on the first line of the buffer and if so, move + ;; directly to that position. (We have to count lines since the + ;; window-start position is not the same as point-min due to the + ;; invisible thread-ID characters on the first line. + (if (equal (count-lines (point-min) (window-start)) 0) + (goto-char (point-min)) + (scroll-down nil))) + +(defun notmuch-search-next-thread () + "Select the next thread in the search results." + (interactive) + (when (notmuch-search-get-result) + (goto-char (notmuch-search-result-end)))) + +(defun notmuch-search-previous-thread () + "Select the previous thread in the search results." + (interactive) + (if (notmuch-search-get-result) + (unless (bobp) + (goto-char (notmuch-search-result-beginning (- (point) 1)))) + ;; We must be past the end; jump to the last result + (notmuch-search-last-thread))) + +(defun notmuch-search-last-thread () + "Select the last thread in the search results." + (interactive) + (goto-char (point-max)) + (forward-line -2) + (let ((beg (notmuch-search-result-beginning))) + (when beg (goto-char beg)))) + +(defun notmuch-search-first-thread () + "Select the first thread in the search results." + (interactive) + (goto-char (point-min))) + +(defface notmuch-message-summary-face + '((((class color) (background light)) (:background "#f0f0f0")) + (((class color) (background dark)) (:background "#303030"))) + "Face for the single-line message summary in notmuch-show-mode." + :group 'notmuch-show + :group 'notmuch-faces) + +(defface notmuch-search-date + '((t :inherit default)) + "Face used in search mode for dates." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-count + '((t :inherit default)) + "Face used in search mode for the count matching the query." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-subject + '((t :inherit default)) + "Face used in search mode for subjects." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-matching-authors + '((t :inherit default)) + "Face used in search mode for authors matching the query." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-non-matching-authors + '((((class color) + (background dark)) + (:foreground "grey30")) + (((class color) + (background light)) + (:foreground "grey60")) + (t + (:italic t))) + "Face used in search mode for authors not matching the query." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-tag-face + '((((class color) + (background dark)) + (:foreground "OliveDrab1")) + (((class color) + (background light)) + (:foreground "navy blue" :bold t)) + (t + (:bold t))) + "Face used in search mode face for tags." + :group 'notmuch-search + :group 'notmuch-faces) + +(defun notmuch-search-mode () + "Major mode displaying results of a notmuch search. + +This buffer contains the results of a \"notmuch search\" of your +email archives. Each line in the buffer represents a single +thread giving a summary of the thread (a relative date, the +number of matched messages and total messages in the thread, +participants in the thread, a representative subject line, and +any tags). + +Pressing \\[notmuch-search-show-thread] on any line displays that +thread. The '\\[notmuch-search-add-tag]' and +'\\[notmuch-search-remove-tag]' keys can be used to add or remove +tags from a thread. The '\\[notmuch-search-archive-thread]' key +is a convenience for archiving a thread (applying changes in +`notmuch-archive-tags'). The '\\[notmuch-search-tag-all]' key can +be used to add and/or remove tags from all messages (as opposed +to threads) that match the current query. Use with caution, as +this will also tag matching messages that arrived *after* +constructing the buffer. + +Other useful commands are '\\[notmuch-search-filter]' for +filtering the current search based on an additional query string, +'\\[notmuch-search-filter-by-tag]' for filtering to include only +messages with a given tag, and '\\[notmuch-search]' to execute a +new, global search. + +Complete list of currently available key bindings: + +\\{notmuch-search-mode-map}" + (interactive) + (kill-all-local-variables) + (make-local-variable 'notmuch-search-query-string) + (make-local-variable 'notmuch-search-oldest-first) + (make-local-variable 'notmuch-search-target-thread) + (make-local-variable 'notmuch-search-target-line) + (set (make-local-variable 'notmuch-search-continuation) nil) + (set (make-local-variable 'scroll-preserve-screen-position) t) + (add-to-invisibility-spec (cons 'ellipsis t)) + (use-local-map notmuch-search-mode-map) + (setq truncate-lines t) + (setq major-mode 'notmuch-search-mode + mode-name "notmuch-search") + (setq buffer-read-only t)) + +(defun notmuch-search-get-result (&optional pos) + "Return the result object for the thread at POS (or point). + +If there is no thread at POS (or point), returns nil." + (get-text-property (or pos (point)) 'notmuch-search-result)) + +(defun notmuch-search-result-beginning (&optional pos) + "Return the point at the beginning of the thread at POS (or point). + +If there is no thread at POS (or point), returns nil." + (when (notmuch-search-get-result pos) + ;; We pass 1+point because previous-single-property-change starts + ;; searching one before the position we give it. + (previous-single-property-change (1+ (or pos (point))) + 'notmuch-search-result nil (point-min)))) + +(defun notmuch-search-result-end (&optional pos) + "Return the point at the end of the thread at POS (or point). + +The returned point will be just after the newline character that +ends the result line. If there is no thread at POS (or point), +returns nil" + (when (notmuch-search-get-result pos) + (next-single-property-change (or pos (point)) 'notmuch-search-result + nil (point-max)))) + +(defun notmuch-search-foreach-result (beg end function) + "Invoke FUNCTION for each result between BEG and END. + +FUNCTION should take one argument. It will be applied to the +character position of the beginning of each result that overlaps +the region between points BEG and END. As a special case, if (= +BEG END), FUNCTION will be applied to the result containing point +BEG." + + (lexical-let ((pos (notmuch-search-result-beginning beg)) + ;; End must be a marker in case function changes the + ;; text. + (end (copy-marker end)) + ;; Make sure we examine at least one result, even if + ;; (= beg end). + (first t)) + ;; We have to be careful if the region extends beyond the results. + ;; In this case, pos could be null or there could be no result at + ;; pos. + (while (and pos (or (< pos end) first)) + (when (notmuch-search-get-result pos) + (funcall function pos)) + (setq pos (notmuch-search-result-end pos) + first nil)))) +;; Unindent the function argument of notmuch-search-foreach-result so +;; the indentation of callers doesn't get out of hand. +(put 'notmuch-search-foreach-result 'lisp-indent-function 2) + +(defun notmuch-search-properties-in-region (property beg end) + (let (output) + (notmuch-search-foreach-result beg end + (lambda (pos) + (push (plist-get (notmuch-search-get-result pos) property) output))) + output)) + +(defun notmuch-search-find-thread-id (&optional bare) + "Return the thread for the current thread + +If BARE is set then do not prefix with \"thread:\"" + (let ((thread (plist-get (notmuch-search-get-result) :thread))) + (when thread (concat (unless bare "thread:") thread)))) + +(defun notmuch-search-find-thread-id-region (beg end) + "Return a list of threads for the current region" + (mapcar (lambda (thread) (concat "thread:" thread)) + (notmuch-search-properties-in-region :thread beg end))) + +(defun notmuch-search-find-thread-id-region-search (beg end) + "Return a search string for threads for the current region" + (mapconcat 'identity (notmuch-search-find-thread-id-region beg end) " or ")) + +(defun notmuch-search-find-authors () + "Return the authors for the current thread" + (plist-get (notmuch-search-get-result) :authors)) + +(defun notmuch-search-find-authors-region (beg end) + "Return a list of authors for the current region" + (notmuch-search-properties-in-region :authors beg end)) + +(defun notmuch-search-find-subject () + "Return the subject for the current thread" + (plist-get (notmuch-search-get-result) :subject)) + +(defun notmuch-search-find-subject-region (beg end) + "Return a list of authors for the current region" + (notmuch-search-properties-in-region :subject beg end)) + +(defun notmuch-search-show-thread () + "Display the currently selected thread." + (interactive) + (let ((thread-id (notmuch-search-find-thread-id)) + (subject (notmuch-search-find-subject))) + (if (> (length thread-id) 0) + (notmuch-show thread-id + (current-buffer) + notmuch-search-query-string + ;; Name the buffer based on the subject. + (concat "*" (truncate-string-to-width subject 30 nil nil t) "*")) + (message "End of search results.")))) + +(defun notmuch-search-reply-to-thread (&optional prompt-for-sender) + "Begin composing a reply-all to the entire current thread in a new buffer." + (interactive "P") + (let ((message-id (notmuch-search-find-thread-id))) + (notmuch-mua-new-reply message-id prompt-for-sender t))) + +(defun notmuch-search-reply-to-thread-sender (&optional prompt-for-sender) + "Begin composing a reply to the entire current thread in a new buffer." + (interactive "P") + (let ((message-id (notmuch-search-find-thread-id))) + (notmuch-mua-new-reply message-id prompt-for-sender nil))) + +(defun notmuch-call-notmuch-process (&rest args) + "Synchronously invoke \"notmuch\" with the given list of arguments. + +If notmuch exits with a non-zero status, output from the process +will appear in a buffer named \"*Notmuch errors*\" and an error +will be signaled." + (with-temp-buffer + (let ((status (apply #'call-process notmuch-command nil t nil args))) + (notmuch-check-exit-status status (cons notmuch-command args) + (buffer-string))))) + +(defun notmuch-search-set-tags (tags &optional pos) + (let ((new-result (plist-put (notmuch-search-get-result pos) :tags tags))) + (notmuch-search-update-result new-result pos))) + +(defun notmuch-search-get-tags (&optional pos) + (plist-get (notmuch-search-get-result pos) :tags)) + +(defun notmuch-search-get-tags-region (beg end) + (let (output) + (notmuch-search-foreach-result beg end + (lambda (pos) + (setq output (append output (notmuch-search-get-tags pos))))) + output)) + +(defun notmuch-search-tag-region (beg end &optional tag-changes) + "Change tags for threads in the given region." + (let ((search-string (notmuch-search-find-thread-id-region-search beg end))) + (setq tag-changes (notmuch-tag search-string tag-changes)) + (notmuch-search-foreach-result beg end + (lambda (pos) + (notmuch-search-set-tags + (notmuch-update-tags (notmuch-search-get-tags pos) tag-changes) + pos))))) + +(defun notmuch-search-tag (&optional tag-changes) + "Change tags for the currently selected thread or region. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (let* ((beg (if (region-active-p) (region-beginning) (point))) + (end (if (region-active-p) (region-end) (point)))) + (notmuch-search-tag-region beg end tag-changes))) + +(defun notmuch-search-add-tag () + "Same as `notmuch-search-tag' but sets initial input to '+'." + (interactive) + (notmuch-search-tag "+")) + +(defun notmuch-search-remove-tag () + "Same as `notmuch-search-tag' but sets initial input to '-'." + (interactive) + (notmuch-search-tag "-")) + +(defun notmuch-search-archive-thread (&optional unarchive) + "Archive the currently selected thread. + +Archive each message in the currently selected thread by applying +the tag changes in `notmuch-archive-tags' to each (remove the +\"inbox\" tag by default). If a prefix argument is given, the +messages will be \"unarchived\" (i.e. the tag changes in +`notmuch-archive-tags' will be reversed). + +This function advances the next thread when finished." + (interactive "P") + (when notmuch-archive-tags + (notmuch-search-tag + (notmuch-tag-change-list notmuch-archive-tags unarchive))) + (notmuch-search-next-thread)) + +(defun notmuch-search-update-result (result &optional pos) + "Replace the result object of the thread at POS (or point) by +RESULT and redraw it. + +This will keep point in a reasonable location. However, if there +are enclosing save-excursions and the saved point is in the +result being updated, the point will be restored to the beginning +of the result." + (let ((start (notmuch-search-result-beginning pos)) + (end (notmuch-search-result-end pos)) + (init-point (point)) + (inhibit-read-only t)) + ;; Delete the current thread + (delete-region start end) + ;; Insert the updated thread + (notmuch-search-show-result result start) + ;; If point was inside the old result, make an educated guess + ;; about where to place it now. Unfortunately, this won't work + ;; with save-excursion (or any other markers that would be nice to + ;; preserve, such as the window start), but there's nothing we can + ;; do about that without a way to retrieve markers in a region. + (when (and (>= init-point start) (<= init-point end)) + (let* ((new-end (notmuch-search-result-end start)) + (new-point (if (= init-point end) + new-end + (min init-point (- new-end 1))))) + (goto-char new-point))))) + +(defun notmuch-search-process-sentinel (proc msg) + "Add a message to let user know when \"notmuch search\" exits" + (let ((buffer (process-buffer proc)) + (status (process-status proc)) + (exit-status (process-exit-status proc)) + (never-found-target-thread nil)) + (when (memq status '(exit signal)) + (catch 'return + (kill-buffer (process-get proc 'parse-buf)) + (if (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (let ((inhibit-read-only t) + (atbob (bobp))) + (goto-char (point-max)) + (if (eq status 'signal) + (insert "Incomplete search results (search process was killed).\n")) + (when (eq status 'exit) + (insert "End of search results.\n") + ;; For version mismatch, there's no point in + ;; showing the search buffer + (when (or (= exit-status 20) (= exit-status 21)) + (kill-buffer) + (throw 'return nil)) + (if (and atbob + (not (string= notmuch-search-target-thread "found"))) + (set 'never-found-target-thread t))))) + (when (and never-found-target-thread + notmuch-search-target-line) + (goto-char (point-min)) + (forward-line (1- notmuch-search-target-line))))))))) + +(defcustom notmuch-search-line-faces '(("unread" :weight bold) + ("flagged" :foreground "blue")) + "Tag/face mapping for line highlighting in notmuch-search. + +Here is an example of how to color search results based on tags. + (the following text would be placed in your ~/.emacs file): + + (setq notmuch-search-line-faces '((\"deleted\" . (:foreground \"red\" + :background \"blue\")) + (\"unread\" . (:foreground \"green\")))) + +The attributes defined for matching tags are merged, with later +attributes overriding earlier. A message having both \"deleted\" +and \"unread\" tags with the above settings would have a green +foreground and blue background." + :type '(alist :key-type (string) :value-type (custom-face-edit)) + :group 'notmuch-search + :group 'notmuch-faces) + +(defun notmuch-search-color-line (start end line-tag-list) + "Colorize lines in `notmuch-show' based on tags." + (mapc (lambda (elem) + (let ((tag (car elem)) + (attributes (cdr elem))) + (when (member tag line-tag-list) + (notmuch-combine-face-text-property start end attributes)))) + ;; Reverse the list so earlier entries take precedence + (reverse notmuch-search-line-faces))) + +(defun notmuch-search-author-propertize (authors) + "Split `authors' into matching and non-matching authors and +propertize appropriately. If no boundary between authors and +non-authors is found, assume that all of the authors match." + (if (string-match "\\(.*\\)|\\(.*\\)" authors) + (concat (propertize (concat (match-string 1 authors) ",") + 'face 'notmuch-search-matching-authors) + (propertize (match-string 2 authors) + 'face 'notmuch-search-non-matching-authors)) + (propertize authors 'face 'notmuch-search-matching-authors))) + +(defun notmuch-search-insert-authors (format-string authors) + ;; Save the match data to avoid interfering with + ;; `notmuch-search-process-filter'. + (save-match-data + (let* ((formatted-authors (format format-string authors)) + (formatted-sample (format format-string "")) + (visible-string formatted-authors) + (invisible-string "") + (padding "")) + + ;; Truncate the author string to fit the specification. + (if (> (length formatted-authors) + (length formatted-sample)) + (let ((visible-length (- (length formatted-sample) + (length "... ")))) + ;; Truncate the visible string according to the width of + ;; the display string. + (setq visible-string (substring formatted-authors 0 visible-length) + invisible-string (substring formatted-authors visible-length)) + ;; If possible, truncate the visible string at a natural + ;; break (comma or pipe), as incremental search doesn't + ;; match across the visible/invisible border. + (when (string-match "\\(.*\\)\\([,|] \\)\\([^,|]*\\)" visible-string) + ;; Second clause is destructive on `visible-string', so + ;; order is important. + (setq invisible-string (concat (match-string 3 visible-string) + invisible-string) + visible-string (concat (match-string 1 visible-string) + (match-string 2 visible-string)))) + ;; `visible-string' may be shorter than the space allowed + ;; by `format-string'. If so we must insert some padding + ;; after `invisible-string'. + (setq padding (make-string (- (length formatted-sample) + (length visible-string) + (length "...")) + ? )))) + + ;; Use different faces to show matching and non-matching authors. + (if (string-match "\\(.*\\)|\\(.*\\)" visible-string) + ;; The visible string contains both matching and + ;; non-matching authors. + (setq visible-string (notmuch-search-author-propertize visible-string) + ;; The invisible string must contain only non-matching + ;; authors, as the visible-string contains both. + invisible-string (propertize invisible-string + 'face 'notmuch-search-non-matching-authors)) + ;; The visible string contains only matching authors. + (setq visible-string (propertize visible-string + 'face 'notmuch-search-matching-authors) + ;; The invisible string may contain both matching and + ;; non-matching authors. + invisible-string (notmuch-search-author-propertize invisible-string))) + + ;; If there is any invisible text, add it as a tooltip to the + ;; visible text. + (when (not (string= invisible-string "")) + (setq visible-string (propertize visible-string 'help-echo (concat "..." invisible-string)))) + + ;; Insert the visible and, if present, invisible author strings. + (insert visible-string) + (when (not (string= invisible-string "")) + (let ((start (point)) + overlay) + (insert invisible-string) + (setq overlay (make-overlay start (point))) + (overlay-put overlay 'invisible 'ellipsis) + (overlay-put overlay 'isearch-open-invisible #'delete-overlay))) + (insert padding)))) + +(defun notmuch-search-insert-field (field format-string result) + (cond + ((string-equal field "date") + (insert (propertize (format format-string (plist-get result :date_relative)) + 'face 'notmuch-search-date))) + ((string-equal field "count") + (insert (propertize (format format-string + (format "[%s/%s]" (plist-get result :matched) + (plist-get result :total))) + 'face 'notmuch-search-count))) + ((string-equal field "subject") + (insert (propertize (format format-string (plist-get result :subject)) + 'face 'notmuch-search-subject))) + + ((string-equal field "authors") + (notmuch-search-insert-authors format-string (plist-get result :authors))) + + ((string-equal field "tags") + (let ((tags (plist-get result :tags))) + (insert (format format-string (notmuch-tag-format-tags tags))))))) + +(defun notmuch-search-show-result (result &optional pos) + "Insert RESULT at POS or the end of the buffer if POS is null." + ;; Ignore excluded matches + (unless (= (plist-get result :matched) 0) + (let ((beg (or pos (point-max)))) + (save-excursion + (goto-char beg) + (dolist (spec notmuch-search-result-format) + (notmuch-search-insert-field (car spec) (cdr spec) result)) + (insert "\n") + (notmuch-search-color-line beg (point) (plist-get result :tags)) + (put-text-property beg (point) 'notmuch-search-result result)) + (when (string= (plist-get result :thread) notmuch-search-target-thread) + (setq notmuch-search-target-thread "found") + (goto-char beg))))) + +(defun notmuch-search-process-filter (proc string) + "Process and filter the output of \"notmuch search\"" + (let ((results-buf (process-buffer proc)) + (parse-buf (process-get proc 'parse-buf)) + (inhibit-read-only t) + done) + (when (buffer-live-p results-buf) + (with-current-buffer parse-buf + ;; Insert new data + (save-excursion + (goto-char (point-max)) + (insert string)) + (notmuch-sexp-parse-partial-list 'notmuch-search-show-result + results-buf))))) + +(defun notmuch-search-tag-all (&optional tag-changes) + "Add/remove tags from all messages in current search buffer. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive) + (apply 'notmuch-tag notmuch-search-query-string tag-changes)) + +(defun notmuch-search-buffer-title (query) + "Returns the title for a buffer with notmuch search results." + (let* ((saved-search + (let (longest + (longest-length 0)) + (loop for tuple in notmuch-saved-searches + if (let ((quoted-query (regexp-quote (cdr tuple)))) + (and (string-match (concat "^" quoted-query) query) + (> (length (match-string 0 query)) + longest-length))) + do (setq longest tuple)) + longest)) + (saved-search-name (car saved-search)) + (saved-search-query (cdr saved-search))) + (cond ((and saved-search (equal saved-search-query query)) + ;; Query is the same as saved search (ignoring case) + (concat "*notmuch-saved-search-" saved-search-name "*")) + (saved-search + (concat "*notmuch-search-" + (replace-regexp-in-string (concat "^" (regexp-quote saved-search-query)) + (concat "[ " saved-search-name " ]") + query) + "*")) + (t + (concat "*notmuch-search-" query "*")) + ))) + +(defun notmuch-read-query (prompt) + "Read a notmuch-query from the minibuffer with completion. + +PROMPT is the string to prompt with." + (lexical-let + ((completions + (append (list "folder:" "thread:" "id:" "date:" "from:" "to:" + "subject:" "attachment:") + (mapcar (lambda (tag) + (concat "tag:" (notmuch-escape-boolean-term tag))) + (process-lines notmuch-command "search" "--output=tags" "*"))))) + (let ((keymap (copy-keymap minibuffer-local-map)) + (minibuffer-completion-table + (completion-table-dynamic + (lambda (string) + ;; generate a list of possible completions for the current input + (cond + ;; this ugly regexp is used to get the last word of the input + ;; possibly preceded by a '(' + ((string-match "\\(^\\|.* (?\\)\\([^ ]*\\)$" string) + (mapcar (lambda (compl) + (concat (match-string-no-properties 1 string) compl)) + (all-completions (match-string-no-properties 2 string) + completions))) + (t (list string))))))) + ;; this was simpler than convincing completing-read to accept spaces: + (define-key keymap (kbd "TAB") 'minibuffer-complete) + (let ((history-delete-duplicates t)) + (read-from-minibuffer prompt nil keymap nil + 'notmuch-search-history nil nil))))) + +;;;###autoload +(defun notmuch-search (&optional query oldest-first target-thread target-line continuation) + "Run \"notmuch search\" with the given `query' and display results. + +If `query' is nil, it is read interactively from the minibuffer. +Other optional parameters are used as follows: + + oldest-first: A Boolean controlling the sort order of returned threads + target-thread: A thread ID (without the thread: prefix) that will be made + current if it appears in the search results. + target-line: The line number to move to if the target thread does not + appear in the search results." + (interactive) + (let* ((query (or query (notmuch-read-query "Notmuch search: "))) + (buffer (get-buffer-create (notmuch-search-buffer-title query)))) + (switch-to-buffer buffer) + (notmuch-search-mode) + ;; Don't track undo information for this buffer + (set 'buffer-undo-list t) + (set 'notmuch-search-query-string query) + (set 'notmuch-search-oldest-first oldest-first) + (set 'notmuch-search-target-thread target-thread) + (set 'notmuch-search-target-line target-line) + (set 'notmuch-search-continuation continuation) + (let ((proc (get-buffer-process (current-buffer))) + (inhibit-read-only t)) + (if proc + (error "notmuch search process already running for query `%s'" query) + ) + (erase-buffer) + (goto-char (point-min)) + (save-excursion + (let ((proc (notmuch-start-notmuch + "notmuch-search" buffer #'notmuch-search-process-sentinel + "search" "--format=sexp" "--format-version=1" + (if oldest-first + "--sort=oldest-first" + "--sort=newest-first") + query)) + ;; Use a scratch buffer to accumulate partial output. + ;; This buffer will be killed by the sentinel, which + ;; should be called no matter how the process dies. + (parse-buf (generate-new-buffer " *notmuch search parse*"))) + (process-put proc 'parse-buf parse-buf) + (set-process-filter proc 'notmuch-search-process-filter) + (set-process-query-on-exit-flag proc nil)))) + (run-hooks 'notmuch-search-hook))) + +(defun notmuch-search-refresh-view () + "Refresh the current view. + +Kills the current buffer and runs a new search with the same +query string as the current search. If the current thread is in +the new search results, then point will be placed on the same +thread. Otherwise, point will be moved to attempt to be in the +same relative position within the new buffer." + (interactive) + (let ((target-line (line-number-at-pos)) + (oldest-first notmuch-search-oldest-first) + (target-thread (notmuch-search-find-thread-id 'bare)) + (query notmuch-search-query-string) + (continuation notmuch-search-continuation)) + (notmuch-kill-this-buffer) + (notmuch-search query oldest-first target-thread target-line continuation) + (goto-char (point-min)))) + +(defcustom notmuch-poll-script nil + "An external script to incorporate new mail into the notmuch database. + +This variable controls the action invoked by +`notmuch-search-poll-and-refresh-view' and +`notmuch-hello-poll-and-update' (each have a default keybinding +of 'G') to incorporate new mail into the notmuch database. + +If set to nil (the default), new mail is processed by invoking +\"notmuch new\". Otherwise, this should be set to a string that +gives the name of an external script that processes new mail. If +set to the empty string, no command will be run. + +The external script could do any of the following depending on +the user's needs: + +1. Invoke a program to transfer mail to the local mail store +2. Invoke \"notmuch new\" to incorporate the new mail +3. Invoke one or more \"notmuch tag\" commands to classify the mail + +Note that the recommended way of achieving the same is using +\"notmuch new\" hooks." + :type '(choice (const :tag "notmuch new" nil) + (const :tag "Disabled" "") + (string :tag "Custom script")) + :group 'notmuch-external) + +(defun notmuch-poll () + "Run \"notmuch new\" or an external script to import mail. + +Invokes `notmuch-poll-script', \"notmuch new\", or does nothing +depending on the value of `notmuch-poll-script'." + (interactive) + (if (stringp notmuch-poll-script) + (unless (string= notmuch-poll-script "") + (call-process notmuch-poll-script nil nil)) + (call-process notmuch-command nil nil nil "new"))) + +(defun notmuch-search-poll-and-refresh-view () + "Invoke `notmuch-poll' to import mail, then refresh the current view." + (interactive) + (notmuch-poll) + (notmuch-search-refresh-view)) + +(defun notmuch-search-toggle-order () + "Toggle the current search order. + +This command toggles the sort order for the current search. The +default sort order is defined by `notmuch-search-oldest-first'." + (interactive) + (set 'notmuch-search-oldest-first (not notmuch-search-oldest-first)) + (notmuch-search-refresh-view)) + +(defun notmuch-search-filter (query) + "Filter the current search results based on an additional query string. + +Runs a new search matching only messages that match both the +current search results AND the additional query string provided." + (interactive (list (notmuch-read-query "Filter search: "))) + (let ((grouped-query (if (string-match-p notmuch-search-disjunctive-regexp query) + (concat "( " query " )") + query))) + (notmuch-search (if (string= notmuch-search-query-string "*") + grouped-query + (concat notmuch-search-query-string " and " grouped-query)) notmuch-search-oldest-first))) + +(defun notmuch-search-filter-by-tag (tag) + "Filter the current search results based on a single tag. + +Runs a new search matching only messages that match both the +current search results AND that are tagged with the given tag." + (interactive + (list (notmuch-select-tag-with-completion "Filter by tag: "))) + (notmuch-search (concat notmuch-search-query-string " and tag:" tag) notmuch-search-oldest-first)) + +;;;###autoload +(defun notmuch () + "Run notmuch and display saved searches, known tags, etc." + (interactive) + (notmuch-hello)) + +(defun notmuch-interesting-buffer (b) + "Is the current buffer of interest to a notmuch user?" + (with-current-buffer b + (memq major-mode '(notmuch-show-mode + notmuch-search-mode + notmuch-hello-mode + message-mode)))) + +;;;###autoload +(defun notmuch-cycle-notmuch-buffers () + "Cycle through any existing notmuch buffers (search, show or hello). + +If the current buffer is the only notmuch buffer, bury it. If no +notmuch buffers exist, run `notmuch'." + (interactive) + + (let (start first) + ;; If the current buffer is a notmuch buffer, remember it and then + ;; bury it. + (when (notmuch-interesting-buffer (current-buffer)) + (setq start (current-buffer)) + (bury-buffer)) + + ;; Find the first notmuch buffer. + (setq first (loop for buffer in (buffer-list) + if (notmuch-interesting-buffer buffer) + return buffer)) + + (if first + ;; If the first one we found is any other than the starting + ;; buffer, switch to it. + (unless (eq first start) + (switch-to-buffer first)) + (notmuch)))) + +(setq mail-user-agent 'notmuch-user-agent) + +(provide 'notmuch)