X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-show.el;h=59931453a018a4b7a5a58749e7d6447d696f2606;hp=78f1af4710a70dcc4deaa913ddd81b2bc2807781;hb=11ac932a4503872c19987b843d58513c4b9ef76f;hpb=c09aad479464965f5296438eeb3afba0ec64d13b

diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index 78f1af47..59931453 100644
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -23,7 +23,10 @@
 
 ;;; Code:
 
-(eval-when-compile (require 'cl))
+(eval-when-compile
+  (require 'cl-lib)
+  (require 'pcase))
+
 (require 'mm-view)
 (require 'message)
 (require 'mm-decode)
@@ -48,8 +51,10 @@
 (declare-function notmuch-count-attachments "notmuch" (mm-handle))
 (declare-function notmuch-save-attachments "notmuch" (mm-handle &optional queryp))
 (declare-function notmuch-tree "notmuch-tree"
-		  (&optional query query-context target buffer-name open-target))
+		  (&optional query query-context target buffer-name open-target unthreaded))
 (declare-function notmuch-tree-get-message-properties "notmuch-tree" nil)
+(declare-function notmuch-unthreaded
+		  (&optional query query-context target buffer-name open-target))
 (declare-function notmuch-read-query "notmuch" (prompt))
 (declare-function notmuch-draft-resume "notmuch-draft" (id))
 
@@ -427,17 +432,16 @@ parsing fails."
 	(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)
+	(cl-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))
 
-	 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)))
+		 until (string= start-of-loop p-name)))
 
       ;; If the address is 'foo@bar.com <foo@bar.com>' then show just
       ;; 'foo@bar.com'.
@@ -571,13 +575,13 @@ message at DEPTH in the current thread."
   ;; Recurse on sub-parts
   (let ((ctype (notmuch-split-content-type
 		(downcase (plist-get part :content-type)))))
-    (cond ((equal (first ctype) "multipart")
+    (cond ((equal (car ctype) "multipart")
 	   (mapc (apply-partially #'notmuch-show--register-cids msg)
 		 (plist-get part :content)))
 	  ((equal ctype '("message" "rfc822"))
 	   (notmuch-show--register-cids
 	    msg
-	    (first (plist-get (first (plist-get part :content)) :body)))))))
+	    (car (plist-get (car (plist-get part :content)) :body)))))))
 
 (defun notmuch-show--get-cid-content (cid)
   "Return a list (CID-content content-type) or nil.
@@ -588,8 +592,8 @@ enclosing angle brackets, a cid: prefix, or URL encoding.  This
 will return nil if the CID is unknown or cannot be retrieved."
   (let ((descriptor (cdr (assoc cid notmuch-show--cids))))
     (when descriptor
-      (let* ((msg (first descriptor))
-	     (part (second descriptor))
+      (let* ((msg (car descriptor))
+	     (part (cadr descriptor))
 	     ;; Request caching for this content, as some messages
 	     ;; reference the same cid: part many times (hundreds!).
 	     (content (notmuch-get-bodypart-binary
@@ -614,8 +618,8 @@ will return nil if the CID is unknown or cannot be retrieved."
 	  (with-current-buffer w3m-current-buffer
 	    (notmuch-show--get-cid-content cid))))
     (when content-and-type
-      (insert (first content-and-type))
-      (second content-and-type))))
+      (insert (car content-and-type))
+      (cadr content-and-type))))
 
 ;; MIME part renderers
 
@@ -783,7 +787,7 @@ will return nil if the CID is unknown or cannot be retrieved."
       ;; is defined before it will be shadowed by the letf below. Otherwise the version
       ;; in enriched.el may be loaded a bit later and used instead (for the first time).
       (require 'enriched)
-      (letf (((symbol-function 'enriched-decode-display-prop)
+      (cl-letf (((symbol-function 'enriched-decode-display-prop)
 		 (lambda (start end &optional param) (list start end))))
 	(notmuch-show-insert-part-*/* msg part content-type nth depth button))))
 
@@ -841,7 +845,7 @@ will return nil if the CID is unknown or cannot be retrieved."
 	   ;; shr strips the "cid:" part of URL, but doesn't
 	   ;; URL-decode it (see RFC 2392).
 	   (let ((cid (url-unhex-string url)))
-	     (first (notmuch-show--get-cid-content cid))))))
+	     (car (notmuch-show--get-cid-content cid))))))
     (shr-insert-document dom)
     t))
 
@@ -871,15 +875,16 @@ will return nil if the CID is unknown or cannot be retrieved."
 
 (defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth button)
   ;; Run the handlers until one of them succeeds.
-  (loop for handler in (notmuch-show-handlers-for content-type)
-	until (condition-case err
-		  (funcall handler msg part content-type nth depth button)
-		;; Specifying `debug' here lets the debugger run if
-		;; `debug-on-error' is non-nil.
-		((debug error)
-		 (insert "!!! Bodypart handler `" (prin1-to-string handler) "' threw an error:\n"
-			 "!!! " (error-message-string err) "\n")
-		 nil))))
+  (cl-loop for handler in (notmuch-show-handlers-for content-type)
+	   until (condition-case err
+		     (funcall handler msg part content-type nth depth button)
+		   ;; Specifying `debug' here lets the debugger run if
+		   ;; `debug-on-error' is non-nil.
+		   ((debug error)
+		    (insert "!!! Bodypart handler `" (prin1-to-string handler)
+			    "' threw an error:\n"
+			    "!!! " (error-message-string err) "\n")
+		    nil))))
 
 (defun notmuch-show-create-part-overlays (button beg end)
   "Add an overlay to the part between BEG and END"
@@ -905,13 +910,15 @@ will return nil if the CID is unknown or cannot be retrieved."
   ;; 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)))
+			     (lambda (v)
+			       (if (listp v)
+				   (cl-pushnew :notmuch-part v)
+				 v)))
   (notmuch-map-text-property beg end 'rear-nonsticky
-			     (lambda (v) (if (listp v)
-					     (pushnew :notmuch-part v)
-					   v))))
+			     (lambda (v)
+			       (if (listp v)
+				   (cl-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
@@ -939,7 +946,7 @@ will return nil if the CID is unknown or cannot be retrieved."
 	(indent-rigidly part-beg part-end (* notmuch-show-indent-messages-width depth)))
       (goto-char part-end)
       (delete-char 1)
-      (notmuch-show-record-part-information (second part-args)
+      (notmuch-show-record-part-information (cadr part-args)
 					    (button-start button)
 					    part-end)
       ;; Create the overlay. If the lazy-part turned out to be empty/not
@@ -1035,7 +1042,7 @@ is t, hide the part initially and show the button."
   ;; Register all content IDs for this message.  According to RFC
   ;; 2392, content IDs are *global*, but it's okay if an MUA treats
   ;; them as only global within a message.
-  (notmuch-show--register-cids msg (first body))
+  (notmuch-show--register-cids msg (car body))
 
   (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body))
 
@@ -1218,13 +1225,13 @@ buttons for a corresponding notmuch search."
 		      (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)
+      (pcase-dolist (`(,beg ,end ,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)
+	(remove-overlays beg end 'goto-address t)
+	(make-text-button beg end
 			  :type 'notmuch-button-type
 			  'action `(lambda (arg)
-				     (notmuch-show ,(third link) current-prefix-arg))
+				     (notmuch-show ,link current-prefix-arg))
 			  'follow-link t
 			  'help-echo "Mouse-1, RET: search for this message"
 			  'face goto-address-mail-face)))))
@@ -1385,9 +1392,9 @@ This includes:
 (defun notmuch-show-goto-message (msg-id)
   "Go to message with msg-id."
   (goto-char (point-min))
-  (unless (loop if (string= msg-id (notmuch-show-get-message-id))
-		return t
-		until (not (notmuch-show-goto-message-next)))
+  (unless (cl-loop if (string= msg-id (notmuch-show-get-message-id))
+		   return t
+		   until (not (notmuch-show-goto-message-next)))
     (goto-char (point-min))
     (message "Message-id not found."))
   (notmuch-show-message-adjust))
@@ -1404,9 +1411,9 @@ This includes:
 
     ;; 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)))
+    (cl-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)))
 
     (dolist (win-msg-pair win-msg-alist)
       (with-selected-window (car win-msg-pair)
@@ -1471,6 +1478,7 @@ reset based on the original query."
   (let ((map (make-sparse-keymap)))
     (set-keymap-parent map notmuch-common-keymap)
     (define-key map "Z" 'notmuch-tree-from-show-current-query)
+    (define-key map "U" 'notmuch-unthreaded-from-show-current-query)
     (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)
@@ -1511,6 +1519,7 @@ reset based on the original query."
     (define-key map "<" 'notmuch-show-toggle-thread-indentation)
     (define-key map "t" 'toggle-truncate-lines)
     (define-key map "." 'notmuch-show-part-map)
+    (define-key map "B" 'notmuch-show-browse-urls)
     map)
   "Keymap for \"notmuch show\" buffers.")
 (fset 'notmuch-show-mode-map notmuch-show-mode-map)
@@ -1558,6 +1567,13 @@ All currently available key bindings:
 		notmuch-show-query-context
 		(notmuch-show-get-message-id)))
 
+(defun notmuch-unthreaded-from-show-current-query ()
+  "Call notmuch unthreaded with the current query"
+  (interactive)
+  (notmuch-unthreaded notmuch-show-thread-id
+		      notmuch-show-query-context
+		      (notmuch-show-get-message-id)))
+
 (defun notmuch-show-move-to-message-top ()
   (goto-char (notmuch-show-message-top)))
 
@@ -1573,6 +1589,8 @@ All currently available key bindings:
 ;; region a->b is not found when point is at b. We walk backwards
 ;; until finding the property.
 (defun notmuch-show-message-extent ()
+  "Return a cons cell containing the start and end buffer offset
+of the current message."
   (let (r)
     (save-excursion
       (while (not (setq r (get-text-property (point) :notmuch-message-extent)))
@@ -1607,8 +1625,8 @@ All currently available key bindings:
 effects."
   (save-excursion
     (goto-char (point-min))
-    (loop do (funcall function)
-	  while (notmuch-show-goto-message-next))))
+    (cl-loop do (funcall function)
+	     while (notmuch-show-goto-message-next))))
 
 ;; Functions relating to the visibility of messages and their
 ;; components.
@@ -2164,9 +2182,9 @@ 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))))
+    (cl-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 ()
@@ -2253,7 +2271,7 @@ message will be \"unarchived\", i.e. the tag changes in
 	   (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.
+  "Archive current message, then show next open message in current thread.
 
 If at the last open message in the current thread, then exit back
 to search results."
@@ -2262,7 +2280,7 @@ to search results."
   (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.
+  "Archive current message, then show next open message in current or next thread.
 
 If at the last open message in the current thread, then show next
 thread from search."
@@ -2519,6 +2537,36 @@ beginning of the line."
 				    (point))
 				  (line-end-position)))
 
+(defmacro notmuch-show--with-currently-shown-message (&rest body)
+  "Evaluate BODY with display restricted to the currently shown
+message."
+  `(save-excursion
+     (save-restriction
+      (let ((extent (notmuch-show-message-extent)))
+	(narrow-to-region (car extent) (cdr extent))
+	,@body))))
+
+(defun notmuch-show--gather-urls ()
+  "Gather any URLs in the current message."
+  (notmuch-show--with-currently-shown-message
+   (let (urls)
+     (goto-char (point-min))
+     (while (re-search-forward goto-address-url-regexp (point-max) t)
+       (push (match-string-no-properties 0) urls))
+     (reverse urls))))
+
+(defun notmuch-show-browse-urls (&optional kill)
+  "Offer to browse any URLs in the current message.
+With a prefix argument, copy the URL to the kill ring rather than
+browsing."
+  (interactive "P")
+  (let ((urls (notmuch-show--gather-urls))
+	(prompt (if kill "Copy URL to kill ring: " "Browse URL: "))
+	(fn (if kill #'kill-new #'browse-url)))
+    (if urls
+	(funcall fn (completing-read prompt urls nil nil nil nil (car urls)))
+      (message "No URLs found."))))
+
 (provide 'notmuch-show)
 
 ;;; notmuch-show.el ends here