]> git.notmuchmail.org Git - notmuch/blobdiff - emacs/notmuch-show.el
emacs: add support for stashing the thread id in show view
[notmuch] / emacs / notmuch-show.el
index 1c1cf9c7de02f6e651ec6f0090f29dd209e6e72d..7d9f8a905f9103e378249069948c33709daca4dd 100644 (file)
@@ -47,8 +47,8 @@
 
 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-headers'. For a closed message, only
-the first header in the list will be visible."
+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)
 
@@ -58,8 +58,8 @@ the first header in the list will be visible."
 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-headers' can be used to make the visible for
-any given message."
+`notmuch-show-toggle-visibility-headers' can be used to make them
+visible for any given message."
   :type 'boolean
   :group 'notmuch-show)
 
@@ -203,9 +203,10 @@ For example, if you wanted to remove an \"unread\" tag and add a
      (let ((id (notmuch-show-get-message-id)))
        (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*"))))
          (with-current-buffer buf
-           (call-process notmuch-command nil t nil "show" "--format=raw" id)
-           ,@body)
-        (kill-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."
@@ -365,9 +366,10 @@ operation on the contents of the current buffer."
                                             'face 'notmuch-tag-face)
                                 ")"))))))
 
-(defun notmuch-show-clean-address (address)
-  "Try to clean a single email ADDRESS for display.  Return
-unchanged ADDRESS if parsing fails."
+(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',
@@ -415,12 +417,20 @@ unchanged ADDRESS if parsing fails."
       (when (string= p-name p-address)
        (setq p-name nil))
 
-      ;; If no name results, return just the address.
-      (if (not p-name)
-         p-address
-       ;; Otherwise format the name and address together.
-       (concat p-name " <" p-address ">")))
-    (error address)))
+      (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
@@ -747,17 +757,22 @@ message at DEPTH in the current thread."
   (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename))
   (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)
-             (icalendar--convert-ical-to-diary
-              (icalendar--read-element nil nil)
-              file t)
-             (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)
+             (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)
 
@@ -815,7 +830,12 @@ message at DEPTH in the current thread."
     ;; Run the content handlers until one of them returns a non-nil
     ;; value.
     (while (and handlers
-               (not (funcall (car handlers) msg part content-type nth depth declared-type)))
+               (not (condition-case err
+                        (funcall (car handlers) msg part content-type nth depth declared-type)
+                      (error (progn
+                               (insert "!!! Bodypart insert error: ")
+                               (insert (error-message-string err))
+                               (insert " !!!\n") nil)))))
       (setq handlers (cdr handlers))))
   t)
 
@@ -991,23 +1011,62 @@ message at DEPTH in the current thread."
   "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 into buttons for
-a corresponding notmuch search."
+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
-    (goto-char start)
-    (while (re-search-forward "id:\\(\"?\\)[^[:space:]\"]+\\1" end t)
-      ;; remove the overlay created by goto-address-mode
-      (remove-overlays (match-beginning 0) (match-end 0) 'goto-address t)
-      (make-text-button (match-beginning 0) (match-end 0)
-                       'action `(lambda (arg)
-                                  (notmuch-show ,(match-string-no-properties 0)))
-                       'follow-link t
-                       'help-echo "Mouse-1, RET: search for this message"
-                       'face goto-address-mail-face))))
+    (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)
+                         '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)
@@ -1077,10 +1136,10 @@ function is used."
 
       (jit-lock-register #'notmuch-show-buttonise-links)
 
-      (run-hooks 'notmuch-show-hook))
+      ;; Set the header line to the subject of the first message.
+      (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject)))
 
-    ;; 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.
@@ -1126,6 +1185,10 @@ reset based on the original query."
   (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
@@ -1170,7 +1233,7 @@ reset based on the original query."
        (define-key map "v" 'notmuch-show-view-all-mime-parts)
        (define-key map "c" 'notmuch-show-stash-map)
        (define-key map "=" 'notmuch-show-refresh-view)
-       (define-key map "h" 'notmuch-show-toggle-headers)
+       (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)
@@ -1709,7 +1772,7 @@ See `notmuch-tag' for information on the format of TAG-CHANGES."
   (interactive)
   (notmuch-show-tag "-"))
 
-(defun notmuch-show-toggle-headers ()
+(defun notmuch-show-toggle-visibility-headers ()
   "Toggle the visibility of the current message headers."
   (interactive)
   (let ((props (notmuch-show-get-message-properties)))
@@ -1842,10 +1905,16 @@ thread from search."
   (interactive)
   (notmuch-common-do-stash (notmuch-show-get-from)))
 
-(defun notmuch-show-stash-message-id ()
-  "Copy id: query matching the current message to kill-ring."
-  (interactive)
-  (notmuch-common-do-stash (notmuch-show-get-message-id)))
+(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."