916b39e390e59af47cee1a838cadbed1463401ee
[notmuch] / emacs / notmuch-show.el
1 ;; notmuch-show.el --- displaying notmuch forests.
2 ;;
3 ;; Copyright © Carl Worth
4 ;; Copyright © David Edmondson
5 ;;
6 ;; This file is part of Notmuch.
7 ;;
8 ;; Notmuch is free software: you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
12 ;;
13 ;; Notmuch is distributed in the hope that it will be useful, but
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16 ;; General Public License for more details.
17 ;;
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
20 ;;
21 ;; Authors: Carl Worth <cworth@cworth.org>
22 ;;          David Edmondson <dme@dme.org>
23
24 (require 'cl)
25 (require 'mm-view)
26 (require 'message)
27 (require 'mm-decode)
28 (require 'mailcap)
29
30 (require 'notmuch-lib)
31 (require 'notmuch-query)
32 (require 'notmuch-wash)
33
34 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
35 (declare-function notmuch-reply "notmuch" (query-string))
36 (declare-function notmuch-fontify-headers "notmuch" nil)
37 (declare-function notmuch-select-tag-with-completion "notmuch" (prompt &rest search-terms))
38 (declare-function notmuch-search-show-thread "notmuch" nil)
39
40 (defvar notmuch-show-headers '("Subject" "To" "Cc" "From" "Date")
41   "Headers that should be shown in a message, in this order. Note
42 that if this order is changed the headers shown when a message is
43 collapsed will change.")
44
45 (defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers)
46   "A list of functions called to decorate the headers listed in
47 `notmuch-show-headers'.")
48
49 (defvar notmuch-show-hook '(notmuch-show-pretty-hook)
50   "A list of functions called after populating a
51 `notmuch-show' buffer.")
52
53 (defvar notmuch-show-insert-text/plain-hook '(notmuch-wash-text/plain-citations)
54   "A list of functions called to clean up text/plain body parts.")
55
56 (defun notmuch-show-pretty-hook ()
57   (goto-address-mode 1)
58   (visual-line-mode))
59
60 (defmacro with-current-notmuch-show-message (&rest body)
61   "Evaluate body with current buffer set to the text of current message"
62   `(save-excursion
63      (let ((filename (notmuch-show-get-filename)))
64        (let ((buf (generate-new-buffer (concat "*notmuch-msg-" filename "*"))))
65          (with-current-buffer buf
66            (insert-file-contents filename nil nil nil t)
67            ,@body)
68          (kill-buffer buf)))))
69
70 (defun notmuch-show-view-all-mime-parts ()
71   "Use external viewers to view all attachments from the current message."
72   (interactive)
73   (with-current-notmuch-show-message
74    ; We ovverride the mm-inline-media-tests to indicate which message
75    ; parts are already sufficiently handled by the original
76    ; presentation of the message in notmuch-show mode. These parts
77    ; will be inserted directly into the temporary buffer of
78    ; with-current-notmuch-show-message and silently discarded.
79    ;
80    ; Any MIME part not explicitly mentioned here will be handled by an
81    ; external viewer as configured in the various mailcap files.
82    (let ((mm-inline-media-tests '(
83                                   ("text/.*" ignore identity)
84                                   ("application/pgp-signature" ignore identity)
85                                   ("multipart/alternative" ignore identity)
86                                   ("multipart/mixed" ignore identity)
87                                   ("multipart/related" ignore identity)
88                                  )))
89      (mm-display-parts (mm-dissect-buffer)))))
90
91 (defun notmuch-foreach-mime-part (function mm-handle)
92   (cond ((stringp (car mm-handle))
93          (dolist (part (cdr mm-handle))
94            (notmuch-foreach-mime-part function part)))
95         ((bufferp (car mm-handle))
96          (funcall function mm-handle))
97         (t (dolist (part mm-handle)
98              (notmuch-foreach-mime-part function part)))))
99
100 (defun notmuch-count-attachments (mm-handle)
101   (let ((count 0))
102     (notmuch-foreach-mime-part
103      (lambda (p)
104        (let ((disposition (mm-handle-disposition p)))
105          (and (listp disposition)
106               (or (equal (car disposition) "attachment")
107                   (and (equal (car disposition) "inline")
108                        (assq 'filename disposition)))
109               (incf count))))
110      mm-handle)
111     count))
112
113 (defun notmuch-save-attachments (mm-handle &optional queryp)
114   (notmuch-foreach-mime-part
115    (lambda (p)
116      (let ((disposition (mm-handle-disposition p)))
117        (and (listp disposition)
118             (or (equal (car disposition) "attachment")
119                 (and (equal (car disposition) "inline")
120                      (assq 'filename disposition)))
121             (or (not queryp)
122                 (y-or-n-p
123                  (concat "Save '" (cdr (assq 'filename disposition)) "' ")))
124             (mm-save-part p))))
125    mm-handle))
126
127 (defun notmuch-show-save-attachments ()
128   "Save all attachments from the current message."
129   (interactive)
130   (with-current-notmuch-show-message
131    (let ((mm-handle (mm-dissect-buffer)))
132      (notmuch-save-attachments
133       mm-handle (> (notmuch-count-attachments mm-handle) 1))))
134   (message "Done"))
135
136 (defun notmuch-show-fontify-header ()
137   (let ((face (cond
138                ((looking-at "[Tt]o:")
139                 'message-header-to)
140                ((looking-at "[Bb]?[Cc][Cc]:")
141                 'message-header-cc)
142                ((looking-at "[Ss]ubject:")
143                 'message-header-subject)
144                ((looking-at "[Ff]rom:")
145                 'message-header-from)
146                (t
147                 'message-header-other))))
148
149     (overlay-put (make-overlay (point) (re-search-forward ":"))
150                  'face 'message-header-name)
151     (overlay-put (make-overlay (point) (re-search-forward ".*$"))
152                  'face face)))
153
154 (defun notmuch-show-colour-headers ()
155   "Apply some colouring to the current headers."
156   (goto-char (point-min))
157   (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:")
158     (notmuch-show-fontify-header)
159     (forward-line)))
160
161 (defun notmuch-show-spaces-n (n)
162   "Return a string comprised of `n' spaces."
163   (make-string n ? ))
164
165 (defun notmuch-show-update-tags (tags)
166   "Update the displayed tags of the current message."
167   (save-excursion
168     (goto-char (notmuch-show-message-top))
169     (if (re-search-forward "(\\([^()]*\\))$" (line-end-position) t)
170         (let ((inhibit-read-only t))
171           (replace-match (concat "("
172                                  (mapconcat 'identity tags " ")
173                                  ")"))))))
174
175 (defun notmuch-show-insert-headerline (headers date tags depth)
176   "Insert a notmuch style headerline based on HEADERS for a
177 message at DEPTH in the current thread."
178   (let ((start (point)))
179     (insert (notmuch-show-spaces-n depth)
180             (plist-get headers :From)
181             " ("
182             date
183             ") ("
184             (mapconcat 'identity tags " ")
185             ")\n")
186     (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face)))
187
188 (defun notmuch-show-insert-header (header header-value)
189   "Insert a single header."
190   (insert header ": " header-value "\n"))
191
192 (defun notmuch-show-insert-headers (headers)
193   "Insert the headers of the current message."
194   (let ((start (point)))
195     (mapc '(lambda (header)
196              (let* ((header-symbol (intern (concat ":" header)))
197                     (header-value (plist-get headers header-symbol)))
198                (if (and header-value
199                         (not (string-equal "" header-value)))
200                    (notmuch-show-insert-header header header-value))))
201           notmuch-show-headers)
202     (save-excursion
203       (save-restriction
204         (narrow-to-region start (point-max))
205         (run-hooks 'notmuch-show-markup-headers-hook)))))
206
207 (define-button-type 'notmuch-show-part-button-type
208   'action 'notmuch-show-part-button-action
209   'follow-link t
210   'face 'message-mml)
211
212 (defun notmuch-show-insert-part-header (nth content-type declared-type &optional name)
213   (insert-button
214    (concat "[ "
215            (if name (concat name ": ") "")
216            declared-type
217            (if (not (string-equal declared-type content-type))
218                (concat " (as " content-type ")")
219              "")
220            " ]\n")
221    :type 'notmuch-show-part-button-type
222    :notmuch-part nth
223    :notmuch-filename name))
224
225 ;; Functions handling particular MIME parts.
226
227 (defun notmuch-show-save-part (message-id nth &optional filename)
228   (with-temp-buffer
229     ;; Always acquires the part via `notmuch part', even if it is
230     ;; available in the JSON output.
231     (insert (notmuch-show-get-bodypart-internal message-id nth))
232     (let ((file (read-file-name
233                  "Filename to save as: "
234                  (or mailcap-download-directory "~/")
235                  nil nil
236                  filename))
237           (require-final-newline nil)
238           (coding-system-for-write 'no-conversion))
239       (write-region (point-min) (point-max) file))))
240
241 (defun notmuch-show-mm-display-part-inline (msg part content-type content)
242   "Use the mm-decode/mm-view functions to display a part in the
243 current buffer, if possible."
244   (let ((display-buffer (current-buffer)))
245     (with-temp-buffer
246       (insert content)
247       (let ((handle (mm-make-handle (current-buffer) (list content-type))))
248         (set-buffer display-buffer)
249         (if (and (mm-inlinable-p handle)
250                  (mm-inlined-p handle))
251             (progn
252               (mm-display-part handle)
253               t)
254           nil)))))
255
256 (defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type)
257   (let ((start (point)))
258     ;; If this text/plain part is not the first part in the message,
259     ;; insert a header to make this clear.
260     (if (> nth 1)
261         (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)))
262     (insert (notmuch-show-get-bodypart-content msg part nth))
263     (save-excursion
264       (save-restriction
265         (narrow-to-region start (point-max))
266         (run-hook-with-args 'notmuch-show-insert-text/plain-hook depth))))
267   t)
268
269 (defun notmuch-show-insert-part-application/octet-stream (msg part content-type nth depth declared-type)
270   ;; If we can deduce a MIME type from the filename of the attachment,
271   ;; do so and pass it on to the handler for that type.
272   (if (plist-get part :filename)
273       (let ((extension (file-name-extension (plist-get part :filename)))
274             mime-type)
275         (if extension
276             (progn
277               (mailcap-parse-mimetypes)
278               (setq mime-type (mailcap-extension-to-mime extension))
279               (if (and mime-type
280                        (not (string-equal mime-type "application/octet-stream")))
281                   (notmuch-show-insert-bodypart-internal msg part mime-type nth depth content-type)
282                 nil))
283           nil))))
284
285 (defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type)
286   ;; This handler _must_ succeed - it is the handler of last resort.
287   (notmuch-show-insert-part-header nth content-type declared-type (plist-get part :filename))
288   (let ((content (notmuch-show-get-bodypart-content msg part nth)))
289     (if content
290         (notmuch-show-mm-display-part-inline msg part content-type content)))
291   t)
292
293 ;; Functions for determining how to handle MIME parts.
294
295 (defun notmuch-show-split-content-type (content-type)
296   (split-string content-type "/"))
297
298 (defun notmuch-show-handlers-for (content-type)
299   "Return a list of content handlers for a part of type CONTENT-TYPE."
300   (let (result)
301     (mapc (lambda (func)
302             (if (functionp func)
303                 (push func result)))
304           ;; Reverse order of prefrence.
305           (list (intern (concat "notmuch-show-insert-part-*/*"))
306                 (intern (concat
307                          "notmuch-show-insert-part-"
308                          (car (notmuch-show-split-content-type content-type))
309                          "/*"))
310                 (intern (concat "notmuch-show-insert-part-" content-type))))
311     result))
312
313 ;; Helper for parts which are generally not included in the default
314 ;; JSON output.
315
316 (defun notmuch-show-get-bodypart-internal (message-id part-number)
317   (with-temp-buffer
318     (let ((coding-system-for-read 'no-conversion))
319       (call-process notmuch-command nil t nil
320                     "part" (format "--part=%s" part-number) message-id)
321       (buffer-string))))
322
323 (defun notmuch-show-get-bodypart-content (msg part nth)
324   (or (plist-get part :content)
325       (notmuch-show-get-bodypart-internal (concat "id:" (plist-get msg :id)) nth)))
326
327 ;; \f
328
329 (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type)
330   (let ((handlers (notmuch-show-handlers-for content-type)))
331     ;; Run the content handlers until one of them returns a non-nil
332     ;; value.
333     (while (and handlers
334                 (not (funcall (car handlers) msg part content-type nth depth declared-type)))
335       (setq handlers (cdr handlers))))
336   t)
337
338 (defun notmuch-show-insert-bodypart (msg part depth)
339   "Insert the body part PART at depth DEPTH in the current thread."
340   (let ((content-type (downcase (plist-get part :content-type)))
341         (nth (plist-get part :id)))
342     (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type))
343   ;; Some of the body part handlers leave point somewhere up in the
344   ;; part, so we make sure that we're down at the end.
345   (goto-char (point-max))
346   ;; Ensure that the part ends with a carriage return.
347   (if (not (bolp))
348       (insert "\n")))
349
350 (defun notmuch-show-insert-body (msg body depth)
351   "Insert the body BODY at depth DEPTH in the current thread."
352   (mapc '(lambda (part) (notmuch-show-insert-bodypart msg part depth)) body))
353
354 (defun notmuch-show-make-symbol (type)
355   (make-symbol (concat "notmuch-show-" type)))
356
357 (defun notmuch-show-insert-msg (msg depth)
358   "Insert the message MSG at depth DEPTH in the current thread."
359   (let ((headers (plist-get msg :headers))
360         ;; Indentation causes the buffer offset of the start/end
361         ;; points to move, so we must use markers.
362         message-start message-end
363         content-start content-end
364         headers-start headers-end
365         body-start body-end
366         (headers-invis-spec (notmuch-show-make-symbol "header"))
367         (message-invis-spec (notmuch-show-make-symbol "message")))
368
369     (setq message-start (point-marker))
370
371     (notmuch-show-insert-headerline headers
372                                     (or (plist-get msg :date_relative)
373                                         (plist-get headers :Date))
374                                     (plist-get msg :tags) depth)
375
376     (setq content-start (point-marker))
377
378     ;; Set `headers-start' to point after the 'Subject:' header to be
379     ;; compatible with the existing implementation. This just sets it
380     ;; to after the first header.
381     (notmuch-show-insert-headers headers)
382     ;; Headers should include a blank line (backwards compatibility).
383     (insert "\n")
384     (save-excursion
385       (goto-char content-start)
386       (forward-line 1)
387       (setq headers-start (point-marker)))
388     (setq headers-end (point-marker))
389
390     (setq body-start (point-marker))
391     (notmuch-show-insert-body msg (plist-get msg :body) depth)
392     ;; Ensure that the body ends with a newline.
393     (if (not (bolp))
394         (insert "\n"))
395     (setq body-end (point-marker))
396     (setq content-end (point-marker))
397
398     ;; Indent according to the depth in the thread.
399     (indent-rigidly content-start content-end depth)
400
401     (setq message-end (point-max-marker))
402
403     ;; Save the extents of this message over the whole text of the
404     ;; message.
405     (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end))
406
407     (plist-put msg :headers-invis-spec headers-invis-spec)
408     (overlay-put (make-overlay headers-start headers-end) 'invisible headers-invis-spec)
409
410     (plist-put msg :message-invis-spec message-invis-spec)
411     (overlay-put (make-overlay body-start body-end) 'invisible message-invis-spec)
412
413     ;; Save the properties for this message. Currently this saves the
414     ;; entire message (augmented it with other stuff), which seems
415     ;; like overkill. We might save a reduced subset (for example, not
416     ;; the content).
417     (notmuch-show-set-message-properties msg)
418
419     ;; Headers are hidden by default.
420     (notmuch-show-headers-visible msg nil)
421
422     ;; Message visibility depends on whether it matched the search
423     ;; criteria.
424     (notmuch-show-message-visible msg (plist-get msg :match))))
425
426 (defun notmuch-show-insert-tree (tree depth)
427   "Insert the message tree TREE at depth DEPTH in the current thread."
428   (let ((msg (car tree))
429         (replies (cadr tree)))
430     (notmuch-show-insert-msg msg depth)
431     (notmuch-show-insert-thread replies (1+ depth))))
432
433 (defun notmuch-show-insert-thread (thread depth)
434   "Insert the thread THREAD at depth DEPTH in the current forest."
435   (mapc '(lambda (tree) (notmuch-show-insert-tree tree depth)) thread))
436
437 (defun notmuch-show-insert-forest (forest)
438   "Insert the forest of threads FOREST."
439   (mapc '(lambda (thread) (notmuch-show-insert-thread thread 0)) forest))
440
441 (defvar notmuch-show-parent-buffer nil)
442
443 ;;;###autoload
444 (defun notmuch-show (thread-id &optional parent-buffer query-context buffer-name)
445   "Run \"notmuch show\" with the given thread ID and display results.
446
447 The optional PARENT-BUFFER is the notmuch-search buffer from
448 which this notmuch-show command was executed, (so that the
449 next thread from that buffer can be show when done with this
450 one).
451
452 The optional QUERY-CONTEXT is a notmuch search term. Only
453 messages from the thread matching this search term are shown if
454 non-nil.
455
456 The optional BUFFER-NAME provides the neame of the buffer in
457 which the message thread is shown. If it is nil (which occurs
458 when the command is called interactively) the argument to the
459 function is used. "
460   (interactive "sNotmuch show: ")
461   (let ((buffer (get-buffer-create (generate-new-buffer-name
462                                     (or buffer-name
463                                         (concat "*notmuch-" thread-id "*")))))
464         (inhibit-read-only t))
465     (switch-to-buffer buffer)
466     (notmuch-show-mode)
467     (set (make-local-variable 'notmuch-show-parent-buffer) parent-buffer)
468     (erase-buffer)
469     (goto-char (point-min))
470     (save-excursion
471       (let* ((basic-args (list thread-id))
472              (args (if query-context
473                        (append basic-args (list "and (" query-context ")"))
474                      basic-args)))
475         (notmuch-show-insert-forest (notmuch-query-get-threads args))
476         ;; If the query context reduced the results to nothing, run
477         ;; the basic query.
478         (when (and (eq (buffer-size) 0)
479                    query-context)
480           (notmuch-show-insert-forest
481            (notmuch-query-get-threads basic-args))))
482       (run-hooks 'notmuch-show-hook))
483
484     ;; Move straight to the first open message
485     (if (not (notmuch-show-message-visible-p))
486         (notmuch-show-next-open-message))
487     (notmuch-show-mark-read)))
488
489 (defvar notmuch-show-stash-map
490   (let ((map (make-sparse-keymap)))
491     (define-key map "c" 'notmuch-show-stash-cc)
492     (define-key map "d" 'notmuch-show-stash-date)
493     (define-key map "F" 'notmuch-show-stash-filename)
494     (define-key map "f" 'notmuch-show-stash-from)
495     (define-key map "i" 'notmuch-show-stash-message-id)
496     (define-key map "s" 'notmuch-show-stash-subject)
497     (define-key map "T" 'notmuch-show-stash-tags)
498     (define-key map "t" 'notmuch-show-stash-to)
499     map)
500   "Submap for stash commands")
501 (fset 'notmuch-show-stash-map notmuch-show-stash-map)
502
503 (defvar notmuch-show-mode-map
504       (let ((map (make-sparse-keymap)))
505         (define-key map "?" 'notmuch-help)
506         (define-key map "q" 'kill-this-buffer)
507         (define-key map (kbd "M-TAB") 'notmuch-show-previous-button)
508         (define-key map (kbd "TAB") 'notmuch-show-next-button)
509         (define-key map "s" 'notmuch-search)
510         (define-key map "m" 'message-mail)
511         (define-key map "f" 'notmuch-show-forward-message)
512         (define-key map "r" 'notmuch-show-reply)
513         (define-key map "|" 'notmuch-show-pipe-message)
514         (define-key map "w" 'notmuch-show-save-attachments)
515         (define-key map "V" 'notmuch-show-view-raw-message)
516         (define-key map "v" 'notmuch-show-view-all-mime-parts)
517         (define-key map "c" 'notmuch-show-stash-map)
518         (define-key map "h" 'notmuch-show-toggle-headers)
519         (define-key map "-" 'notmuch-show-remove-tag)
520         (define-key map "+" 'notmuch-show-add-tag)
521         (define-key map "x" 'notmuch-show-archive-thread-then-exit)
522         (define-key map "a" 'notmuch-show-archive-thread)
523         (define-key map "N" 'notmuch-show-next-message)
524         (define-key map "P" 'notmuch-show-previous-message)
525         (define-key map "n" 'notmuch-show-next-open-message)
526         (define-key map "p" 'notmuch-show-previous-open-message)
527         (define-key map (kbd "DEL") 'notmuch-show-rewind)
528         (define-key map " " 'notmuch-show-advance-and-archive)
529         (define-key map (kbd "RET") 'notmuch-show-toggle-message)
530         map)
531       "Keymap for \"notmuch show\" buffers.")
532 (fset 'notmuch-show-mode-map notmuch-show-mode-map)
533
534 ;;;###autoload
535 (defun notmuch-show-mode ()
536   "Major mode for viewing a thread with notmuch.
537
538 This buffer contains the results of the \"notmuch show\" command
539 for displaying a single thread of email from your email archives.
540
541 By default, various components of email messages, (citations,
542 signatures, already-read messages), are hidden. You can make
543 these parts visible by clicking with the mouse button or by
544 pressing RET after positioning the cursor on a hidden part, (for
545 which \\[notmuch-show-next-button] and
546 \\[notmuch-show-previous-button] are helpful).
547
548 Reading the thread sequentially is well-supported by pressing
549 \\[notmuch-show-advance-and-archive]. This will scroll the
550 current message (if necessary), advance to the next message, or
551 advance to the next thread (if already on the last message of a
552 thread).
553
554 Other commands are available to read or manipulate the thread
555 more selectively, (such as '\\[notmuch-show-next-message]' and
556 '\\[notmuch-show-previous-message]' to advance to messages
557 without removing any tags, and '\\[notmuch-show-archive-thread]'
558 to archive an entire thread without scrolling through with
559 \\[notmuch-show-advance-and-archive]).
560
561 You can add or remove arbitary tags from the current message with
562 '\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'.
563
564 All currently available key bindings:
565
566 \\{notmuch-show-mode-map}"
567   (interactive)
568   (kill-all-local-variables)
569   (use-local-map notmuch-show-mode-map)
570   (setq major-mode 'notmuch-show-mode
571         mode-name "notmuch-show")
572   (setq buffer-read-only t))
573
574 (defun notmuch-show-move-to-message-top ()
575   (goto-char (notmuch-show-message-top)))
576
577 (defun notmuch-show-move-to-message-bottom ()
578   (goto-char (notmuch-show-message-bottom)))
579
580 (defun notmuch-show-message-adjust ()
581   (recenter 0))
582
583 ;; Movement related functions.
584
585 ;; There's some strangeness here where a text property applied to a
586 ;; region a->b is not found when point is at b. We walk backwards
587 ;; until finding the property.
588 (defun notmuch-show-message-extent ()
589   (let (r)
590     (save-excursion
591       (while (not (setq r (get-text-property (point) :notmuch-message-extent)))
592         (backward-char)))
593     r))
594
595 (defun notmuch-show-message-top ()
596   (car (notmuch-show-message-extent)))
597
598 (defun notmuch-show-message-bottom ()
599   (cdr (notmuch-show-message-extent)))
600
601 (defun notmuch-show-goto-message-next ()
602   (let ((start (point)))
603     (notmuch-show-move-to-message-bottom)
604     (if (not (eobp))
605         t
606       (goto-char start)
607       nil)))
608
609 (defun notmuch-show-goto-message-previous ()
610   (notmuch-show-move-to-message-top)
611   (if (bobp)
612       nil
613     (backward-char)
614     (notmuch-show-move-to-message-top)
615     t))
616
617 (defun notmuch-show-move-past-invisible-forward ()
618   (while (point-invisible-p)
619     (forward-char)))
620
621 (defun notmuch-show-move-past-invisible-backward ()
622   (while (point-invisible-p)
623     (backward-char)))
624
625 ;; Functions relating to the visibility of messages and their
626 ;; components.
627
628 (defun notmuch-show-element-visible (props visible-p spec-property)
629   (let ((spec (plist-get props spec-property)))
630     (if visible-p
631         (remove-from-invisibility-spec spec)
632       (add-to-invisibility-spec spec))))
633
634 (defun notmuch-show-message-visible (props visible-p)
635   (if visible-p
636       ;; When making the message visible, the headers may or not be
637       ;; visible. So we check that property separately.
638       (let ((headers-visible (plist-get props :headers-visible)))
639         (notmuch-show-element-visible props headers-visible :headers-invis-spec)
640         (notmuch-show-element-visible props t :message-invis-spec))
641     (notmuch-show-element-visible props nil :headers-invis-spec)
642     (notmuch-show-element-visible props nil :message-invis-spec))
643
644   (notmuch-show-set-prop :message-visible visible-p props))
645
646 (defun notmuch-show-headers-visible (props visible-p)
647   (if (plist-get props :message-visible)
648       (notmuch-show-element-visible props visible-p :headers-invis-spec))
649   (notmuch-show-set-prop :headers-visible visible-p props))
650
651 ;; Functions for setting and getting attributes of the current
652 ;; message.
653
654 (defun notmuch-show-set-message-properties (props)
655   (save-excursion
656     (notmuch-show-move-to-message-top)
657     (put-text-property (point) (+ (point) 1) :notmuch-message-properties props)))
658
659 (defun notmuch-show-get-message-properties ()
660   (save-excursion
661     (notmuch-show-move-to-message-top)
662     (get-text-property (point) :notmuch-message-properties)))
663
664 (defun notmuch-show-set-prop (prop val &optional props)
665   (let ((inhibit-read-only t)
666         (props (or props
667                    (notmuch-show-get-message-properties))))
668     (plist-put props prop val)
669     (notmuch-show-set-message-properties props)))
670
671 (defun notmuch-show-get-prop (prop &optional props)
672   (let ((props (or props
673                    (notmuch-show-get-message-properties))))
674     (plist-get props prop)))
675
676 (defun notmuch-show-get-message-id ()
677   "Return the message id of the current message."
678   (concat "id:" (notmuch-show-get-prop :id)))
679
680 ;; dme: Would it make sense to use a macro for many of these?
681
682 (defun notmuch-show-get-filename ()
683   "Return the filename of the current message."
684   (notmuch-show-get-prop :filename))
685
686 (defun notmuch-show-get-header (header)
687   "Return the named header of the current message, if any."
688   (plist-get (notmuch-show-get-prop :headers) header))
689
690 (defun notmuch-show-get-cc ()
691   (notmuch-show-get-header :Cc))
692
693 (defun notmuch-show-get-date ()
694   (notmuch-show-get-header :Date))
695
696 (defun notmuch-show-get-from ()
697   (notmuch-show-get-header :From))
698
699 (defun notmuch-show-get-subject ()
700   (notmuch-show-get-header :Subject))
701
702 (defun notmuch-show-get-to ()
703   (notmuch-show-get-header :To))
704
705 (defun notmuch-show-set-tags (tags)
706   "Set the tags of the current message."
707   (notmuch-show-set-prop :tags tags)
708   (notmuch-show-update-tags tags))
709
710 (defun notmuch-show-get-tags ()
711   "Return the tags of the current message."
712   (notmuch-show-get-prop :tags))
713
714 (defun notmuch-show-message-visible-p ()
715   "Is the current message visible?"
716   (notmuch-show-get-prop :message-visible))
717
718 (defun notmuch-show-headers-visible-p ()
719   "Are the headers of the current message visible?"
720   (notmuch-show-get-prop :headers-visible))
721
722 (defun notmuch-show-mark-read ()
723   "Mark the current message as read."
724   (notmuch-show-remove-tag "unread"))
725
726 ;; Commands typically bound to keys.
727
728 (defun notmuch-show-advance-and-archive ()
729   "Advance through thread and archive.
730
731 This command is intended to be one of the simplest ways to
732 process a thread of email. It does the following:
733
734 If the current message in the thread is not yet fully visible,
735 scroll by a near screenful to read more of the message.
736
737 Otherwise, (the end of the current message is already within the
738 current window), advance to the next open message.
739
740 Finally, if there is no further message to advance to, and this
741 last message is already read, then archive the entire current
742 thread, (remove the \"inbox\" tag from each message). Also kill
743 this buffer, and display the next thread from the search from
744 which this thread was originally shown."
745   (interactive)
746   (let ((end-of-this-message (notmuch-show-message-bottom)))
747     (cond
748      ;; Ideally we would test `end-of-this-message' against the result
749      ;; of `window-end', but that doesn't account for the fact that
750      ;; the end of the message might be hidden, so we have to actually
751      ;; go to the end, walk back over invisible text and then see if
752      ;; point is visible.
753      ((save-excursion
754         (goto-char (- end-of-this-message 1))
755         (notmuch-show-move-past-invisible-backward)
756         (> (point) (window-end)))
757       ;; The bottom of this message is not visible - scroll.
758       (scroll-up nil))
759
760      ((not (= end-of-this-message (point-max)))
761       ;; This is not the last message - move to the next visible one.
762       (notmuch-show-next-open-message))
763
764      (t
765       ;; This is the last message - archive the thread.
766       (notmuch-show-archive-thread)))))
767
768 (defun notmuch-show-rewind ()
769   "Backup through the thread, (reverse scrolling compared to \\[notmuch-show-advance-and-archive]).
770
771 Specifically, if the beginning of the previous email is fewer
772 than `window-height' lines from the current point, move to it
773 just like `notmuch-show-previous-message'.
774
775 Otherwise, just scroll down a screenful of the current message.
776
777 This command does not modify any message tags, (it does not undo
778 any effects from previous calls to
779 `notmuch-show-advance-and-archive'."
780   (interactive)
781   (let ((start-of-message (notmuch-show-message-top))
782         (start-of-window (window-start)))
783     (cond
784       ;; Either this message is properly aligned with the start of the
785       ;; window or the start of this message is not visible on the
786       ;; screen - scroll.
787      ((or (= start-of-message start-of-window)
788           (< start-of-message start-of-window))
789       (scroll-down)
790       ;; If a small number of lines from the previous message are
791       ;; visible, realign so that the top of the current message is at
792       ;; the top of the screen.
793       (if (< (count-lines (window-start) (notmuch-show-message-top))
794              next-screen-context-lines)
795           (progn
796             (goto-char (notmuch-show-message-top))
797             (notmuch-show-message-adjust)))
798       ;; Move to the top left of the window.
799       (goto-char (window-start)))
800      (t
801       ;; Move to the previous message.
802       (notmuch-show-previous-message)))))
803
804 (defun notmuch-show-reply ()
805   "Reply to the current message."
806   (interactive)
807   (notmuch-reply (notmuch-show-get-message-id)))
808
809 (defun notmuch-show-forward-message ()
810   "Forward the current message."
811   (interactive)
812   (with-current-notmuch-show-message
813    (message-forward)))
814
815 (defun notmuch-show-next-message ()
816   "Show the next message."
817   (interactive)
818   (notmuch-show-goto-message-next)
819   (notmuch-show-mark-read)
820   (notmuch-show-message-adjust))
821
822 (defun notmuch-show-previous-message ()
823   "Show the previous message."
824   (interactive)
825   (notmuch-show-goto-message-previous)
826   (notmuch-show-mark-read)
827   (notmuch-show-message-adjust))
828
829 (defun notmuch-show-next-open-message ()
830   "Show the next message."
831   (interactive)
832   (while (and (notmuch-show-goto-message-next)
833               (not (notmuch-show-message-visible-p))))
834   (notmuch-show-mark-read)
835   (notmuch-show-message-adjust))
836
837 (defun notmuch-show-previous-open-message ()
838   "Show the previous message."
839   (interactive)
840   (while (and (notmuch-show-goto-message-previous)
841               (not (notmuch-show-message-visible-p))))
842   (notmuch-show-mark-read)
843   (notmuch-show-message-adjust))
844
845 (defun notmuch-show-view-raw-message ()
846   "View the file holding the current message."
847   (interactive)
848   (view-file (notmuch-show-get-filename)))
849
850 (defun notmuch-show-pipe-message (command)
851   "Pipe the contents of the current message to the given command.
852
853 The given command will be executed with the raw contents of the
854 current email message as stdin. Anything printed by the command
855 to stdout or stderr will appear in the *Messages* buffer."
856   (interactive "sPipe message to command: ")
857   (apply 'start-process-shell-command "notmuch-pipe-command" "*notmuch-pipe*"
858          (list command " < "
859                (shell-quote-argument (notmuch-show-get-filename)))))
860
861 (defun notmuch-show-add-tag (&rest toadd)
862   "Add a tag to the current message."
863   (interactive
864    (list (notmuch-select-tag-with-completion "Tag to add: ")))
865   (apply 'notmuch-call-notmuch-process
866          (append (cons "tag"
867                        (mapcar (lambda (s) (concat "+" s)) toadd))
868                  (cons (notmuch-show-get-message-id) nil)))
869   (notmuch-show-set-tags (sort (union toadd (notmuch-show-get-tags) :test 'string=) 'string<)))
870
871 (defun notmuch-show-remove-tag (&rest toremove)
872   "Remove a tag from the current message."
873   (interactive
874    (list (notmuch-select-tag-with-completion
875           "Tag to remove: " (notmuch-show-get-message-id))))
876   (let ((tags (notmuch-show-get-tags)))
877     (if (intersection tags toremove :test 'string=)
878         (progn
879           (apply 'notmuch-call-notmuch-process
880                  (append (cons "tag"
881                                (mapcar (lambda (s) (concat "-" s)) toremove))
882                          (cons (notmuch-show-get-message-id) nil)))
883           (notmuch-show-set-tags (sort (set-difference tags toremove :test 'string=) 'string<))))))
884
885 (defun notmuch-show-toggle-headers ()
886   "Toggle the visibility of the current message headers."
887   (interactive)
888   (let ((props (notmuch-show-get-message-properties)))
889     (notmuch-show-headers-visible
890      props
891      (not (plist-get props :headers-visible))))
892   (force-window-update))
893
894 (defun notmuch-show-toggle-message ()
895   "Toggle the visibility of the current message."
896   (interactive)
897   (let ((props (notmuch-show-get-message-properties)))
898     (notmuch-show-message-visible
899      props
900      (not (plist-get props :message-visible))))
901   (force-window-update))
902
903 (defun notmuch-show-next-button ()
904   "Advance point to the next button in the buffer."
905   (interactive)
906   (forward-button 1))
907
908 (defun notmuch-show-previous-button ()
909   "Move point back to the previous button in the buffer."
910   (interactive)
911   (backward-button 1))
912
913 (defun notmuch-show-archive-thread-internal (show-next)
914   ;; Remove the tag from the current set of messages.
915   (goto-char (point-min))
916   (loop do (notmuch-show-remove-tag "inbox")
917         until (not (notmuch-show-goto-message-next)))
918   ;; Move to the next item in the search results, if any.
919   (let ((parent-buffer notmuch-show-parent-buffer))
920     (kill-this-buffer)
921     (if parent-buffer
922         (progn
923           (switch-to-buffer parent-buffer)
924           (forward-line)
925           (if show-next
926               (notmuch-search-show-thread))))))
927
928 (defun notmuch-show-archive-thread ()
929   "Archive each message in thread, then show next thread from search.
930
931 Archive each message currently shown by removing the \"inbox\"
932 tag from each. Then kill this buffer and show the next thread
933 from the search from which this thread was originally shown.
934
935 Note: This command is safe from any race condition of new messages
936 being delivered to the same thread. It does not archive the
937 entire thread, but only the messages shown in the current
938 buffer."
939   (interactive)
940   (notmuch-show-archive-thread-internal t))
941
942 (defun notmuch-show-archive-thread-then-exit ()
943   "Archive each message in thread, then exit back to search results."
944   (interactive)
945   (notmuch-show-archive-thread-internal nil))
946
947 (defun notmuch-show-do-stash (text)
948   (kill-new text)
949   (message "Saved: %s" text))
950
951 (defun notmuch-show-stash-cc ()
952   "Copy CC field of current message to kill-ring."
953   (interactive)
954   (notmuch-show-do-stash (notmuch-show-get-cc)))
955
956 (defun notmuch-show-stash-date ()
957   "Copy date of current message to kill-ring."
958   (interactive)
959   (notmuch-show-do-stash (notmuch-show-get-date)))
960
961 (defun notmuch-show-stash-filename ()
962   "Copy filename of current message to kill-ring."
963   (interactive)
964   (notmuch-show-do-stash (notmuch-show-get-filename)))
965
966 (defun notmuch-show-stash-from ()
967   "Copy From address of current message to kill-ring."
968   (interactive)
969   (notmuch-show-do-stash (notmuch-show-get-from)))
970
971 (defun notmuch-show-stash-message-id ()
972   "Copy message ID of current message to kill-ring."
973   (interactive)
974   (notmuch-show-do-stash (notmuch-show-get-message-id)))
975
976 (defun notmuch-show-stash-subject ()
977   "Copy Subject field of current message to kill-ring."
978   (interactive)
979   (notmuch-show-do-stash (notmuch-show-get-subject)))
980
981 (defun notmuch-show-stash-tags ()
982   "Copy tags of current message to kill-ring as a comma separated list."
983   (interactive)
984   (notmuch-show-do-stash (mapconcat 'identity (notmuch-show-get-tags) ",")))
985
986 (defun notmuch-show-stash-to ()
987   "Copy To address of current message to kill-ring."
988   (interactive)
989   (notmuch-show-do-stash (notmuch-show-get-to)))
990
991 ;; Commands typically bound to buttons.
992
993 (defun notmuch-show-part-button-action (button)
994   (let ((nth (button-get button :notmuch-part)))
995     (if nth
996         (notmuch-show-save-part (notmuch-show-get-message-id) nth
997                                 (button-get button :notmuch-filename))
998       (message "Not a valid part (is it a fake part?)."))))
999
1000 ;;
1001
1002 (provide 'notmuch-show)