--- /dev/null
+.eldeps*
+*.elc
--- /dev/null
+# See Makefile.local for the list of files to be compiled in this
+# directory.
+all:
+ $(MAKE) -C .. all
+
+.DEFAULT:
+ $(MAKE) -C .. $@
--- /dev/null
+# -*- 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)
--- /dev/null
+;;; 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 <Kai.Grossjohann@CS.Uni-Dortmund.DE>
+;; Alex Schroeder <alex@gnu.org>
+;; Chong Yidong <cyd@stupidchicken.com>
+;; Maintainer: David Edmondson <dme@dme.org>
+;; Keywords: convenience, wp
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; This is a simple derivative of some functionality from
+;;; `longlines.el'. The key difference is that this version will
+;;; insert a prefix at the head of each wrapped line. The prefix is
+;;; calculated from the originating long line.
+
+;;; No minor-mode is provided, the caller is expected to call
+;;; `coolj-wrap-region' to wrap the region of interest.
+
+;;; Code:
+
+(defgroup coolj nil
+ "Wrapping of long lines with prefix."
+ :group 'fill)
+
+(defcustom coolj-wrap-follows-window-size t
+ "Non-nil means wrap text to the window size.
+Otherwise respect `fill-column'."
+ :group 'coolj
+ :type 'boolean)
+
+(defcustom coolj-line-prefix-regexp "^\\(>+ \\)*"
+ "Regular expression that matches line prefixes."
+ :group 'coolj
+ :type 'regexp)
+
+(defvar 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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Austin Clements <aclements@csail.mit.edu>
+
+(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))))
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+(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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Jameson Rollins <jrollins@finestructure.net>
+
+(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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+(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 "<C-tab>") '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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+
+;; 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:
--- /dev/null
+;; 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)
+
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Jesse Rosenthal <jrosenthal@jhu.edu>
+
+(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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+(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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Austin Clements <aclements@csail.mit.edu>
+
+(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:
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: David Edmondson <dme@dme.org>
+
+(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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: David Bremner <david@tethera.net>
+
+(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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+;; David Edmondson <dme@dme.org>
+
+(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 <user@dom.ain>" style.
+ ((string-match "\\(.*\\) <\\(.*\\)>" address)
+ (setq p-name (match-string 1 address)
+ p-address (match-string 2 address)))
+
+ ;; "<user@dom.ain>" style.
+ ((string-match "<\\(.*\\)>" address)
+ (setq p-address (match-string 1 address)))
+
+ ;; Everything else.
+ (t
+ (setq p-address address)))
+
+ (when p-name
+ ;; Remove elements of the mailbox part that are not relevant for
+ ;; display, even if they are required during transport:
+ ;;
+ ;; Backslashes.
+ (setq p-name (replace-regexp-in-string "\\\\" "" p-name))
+
+ ;; Outer single and double quotes, which might be nested.
+ (loop
+ with start-of-loop
+ do (setq start-of-loop p-name)
+
+ when (string-match "^\"\\(.*\\)\"$" p-name)
+ do (setq p-name (match-string 1 p-name))
+
+ when (string-match "^'\\(.*\\)'$" p-name)
+ do (setq p-name (match-string 1 p-name))
+
+ until (string= start-of-loop p-name)))
+
+ ;; If the address is 'foo@bar.com <foo@bar.com>' then show just
+ ;; 'foo@bar.com'.
+ (when (string= p-name p-address)
+ (setq p-name nil))
+
+ (cons p-address p-name))
+ (error (cons address nil))))
+
+(defun notmuch-show-clean-address (address)
+ "Try to clean a single email ADDRESS for display. Return
+unchanged ADDRESS if parsing fails."
+ (let* ((clean-address (notmuch-clean-address address))
+ (p-address (car clean-address))
+ (p-name (cdr clean-address)))
+ ;; If no name, return just the address.
+ (if (not p-name)
+ p-address
+ ;; Otherwise format the name and address together.
+ (concat p-name " <" p-address ">"))))
+
+(defun notmuch-show-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))
+
+;; \f
+
+(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:).
+ "\\<id:\\("
+ ;; If the term starts with a ", then parse Xapian's quoted boolean
+ ;; term syntax, which allows for anything as long as embedded
+ ;; double quotes escaped by doubling them. We also disallow
+ ;; newlines (which Xapian allows) to prevent runaway terms.
+ "\"\\([^\"\n]\\|\"\"\\)*\""
+ ;; Otherwise, parse Xapian's unquoted syntax, which goes up to the
+ ;; next space or ). We disallow [.,;] as the last character
+ ;; because these are probably part of the surrounding text, and not
+ ;; part of the id. This doesn't match single character ids; meh.
+ "\\|[^\"[:space:])][^[:space:])]*[^])[:space:].,:;?!]"
+ "\\)")
+ "The regexp used to match id: links in messages.")
+
+(defvar notmuch-mid-regexp
+ ;; goto-address-url-regexp matched cid: links, which have the same
+ ;; grammar as the message ID part of a mid: link. Construct the
+ ;; regexp using the same technique as goto-address-url-regexp.
+ (concat "\\<mid:\\(" thing-at-point-url-path-regexp "\\)")
+ "The regexp used to match mid: links in messages.
+
+See RFC 2392.")
+
+(defun notmuch-show-buttonise-links (start end)
+ "Buttonise URLs and mail addresses between START and END.
+
+This also turns id:\"<message id>\"-parts and mid: links into
+buttons for a corresponding notmuch search."
+ (goto-address-fontify-region start end)
+ (save-excursion
+ (let (links)
+ (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 "<C-tab>") 'widget-backward)
+ (define-key map (kbd "M-TAB") 'notmuch-show-previous-button)
+ (define-key map (kbd "<backtab>") 'notmuch-show-previous-button)
+ (define-key map (kbd "TAB") 'notmuch-show-next-button)
+ (define-key map "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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+;; Damien Cassou <damien.cassou@gmail.com>
+;;
+;;; 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'."
+"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
+<svg version=\"1.1\" width=\"16\" height=\"16\">
+ <g transform=\"translate(-242.81601,-315.59635)\">
+ <path
+ d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
+ transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
+ style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
+ </g>
+</svg>")
+
+(defun notmuch-tag-star-empty-icon ()
+ "Return SVG data representing an empty star icon.
+This can be used with `notmuch-tag-format-image-data'."
+ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
+<svg version=\"1.1\" width=\"16\" height=\"16\">
+ <g transform=\"translate(-242.81601,-315.59635)\">
+ <path
+ d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
+ transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
+ style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
+ </g>
+</svg>")
+
+(defun notmuch-tag-tag-icon ()
+ "Return SVG data representing a tag icon.
+This can be used with `notmuch-tag-format-image-data'."
+ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
+<svg version=\"1.1\" width=\"16\" height=\"16\">
+ <g transform=\"translate(0,-1036.3622)\">
+ <path
+ d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
+ style=\"fill:#ffff00;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.25;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-opacity:1\" />
+ </g>
+</svg>")
+
+(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 <tab>
+ ;; still does the completion.
+ (crm-local-completion-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map crm-local-completion-map)
+ (define-key map " " 'self-insert-command)
+ map)))
+ (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:
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+;; David Edmondson <dme@dme.org>
+
+(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)
--- /dev/null
+;; 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 <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Carl Worth <cworth@cworth.org>
+
+;; 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 <notmuch@notmuchmail.org> (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 "<DEL>") 'notmuch-search-scroll-down)
+ (define-key map "b" 'notmuch-search-scroll-down)
+ (define-key map " " 'notmuch-search-scroll-up)
+ (define-key map "<" 'notmuch-search-first-thread)
+ (define-key map ">" 'notmuch-search-last-thread)
+ (define-key map "p" 'notmuch-search-previous-thread)
+ (define-key map "n" 'notmuch-search-next-thread)
+ (define-key map "r" 'notmuch-search-reply-to-thread-sender)
+ (define-key map "R" 'notmuch-search-reply-to-thread)
+ (define-key map "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)
projects / .emacs.d.git / commitdiff
