X-Git-Url: https://git.notmuchmail.org/git?p=notmuch;a=blobdiff_plain;f=emacs%2Fnotmuch-show.el;h=dc86b43b986cf71b98c5ad6bc2d9a8c37de243c1;hp=1c1cf9c7de02f6e651ec6f0090f29dd209e6e72d;hb=0c3a63f1afbe1fae08602196b68c4c6a3af57240;hpb=8a22e2875049b47ebf7058e93bd2d12747838519

diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index 1c1cf9c7..dc86b43b 100644
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -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
@@ -473,17 +483,17 @@ message at DEPTH in the current thread."
 (fset 'notmuch-show-part-button-map notmuch-show-part-button-map)
 
 (defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment)
-  (let ((button))
+  (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 "[ "
-		   (if name (concat name ": ") "")
-		   declared-type
-		   (if (not (string-equal declared-type content-type))
-		       (concat " (as " content-type ")")
-		     "")
-		   (or comment "")
-		   " ]")
+	   (concat "[ " base-label " ]")
+	   :base-label base-label
 	   :type 'notmuch-show-part-button-type
 	   :notmuch-part nth
 	   :notmuch-filename name
@@ -557,11 +567,10 @@ message at DEPTH in the current thread."
     ;; 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)))
-	      (if (or notmuch-show-all-multipart/alternative-parts
-		      (string= chosen-type inner-type))
-		  (notmuch-show-insert-bodypart msg inner-part depth)
-		(notmuch-show-insert-part-header (plist-get inner-part :id) inner-type inner-type nil " (not shown)"))))
+	    (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
@@ -747,17 +756,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,21 +829,42 @@ 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)
 
-(defun notmuch-show-insert-bodypart (msg part depth)
-  "Insert the body part PART at depth DEPTH in the current thread."
+(defun notmuch-show-create-part-overlays (msg beg end hide)
+  "Add an overlay to the part between BEG and END"
+  (let* ((button (button-at beg))
+	 (part-beg (and button (1+ (button-end button)))))
+
+    ;; If the part contains no text we do not make it toggleable. We
+    ;; also need to check that the button is a genuine part button not
+    ;; a notmuch-wash button.
+    (when (and button (/= part-beg end) (button-get button :base-label))
+	(button-put button 'overlay (make-overlay part-beg 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)))
-	(nth (plist-get part :id)))
-    (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type))
-  ;; 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")))
+	(nth (plist-get part :id))
+	(beg (point)))
+
+    (notmuch-show-insert-bodypart-internal msg part content-type nth depth content-type)
+    ;; 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"))
+    (notmuch-show-create-part-overlays msg beg (point) hide)))
 
 (defun notmuch-show-insert-body (msg body depth)
   "Insert the body BODY at depth DEPTH in the current thread."
@@ -852,27 +887,8 @@ message at DEPTH in the current thread."
 	 message-start message-end
 	 content-start content-end
 	 headers-start headers-end
-	 body-start body-end
-	 (headers-invis-spec (notmuch-show-make-symbol "header"))
-	 (message-invis-spec (notmuch-show-make-symbol "message"))
 	 (bare-subject (notmuch-show-strip-re (plist-get headers :Subject))))
 
-    ;; Set `buffer-invisibility-spec' to `nil' (a list), otherwise
-    ;; removing items from `buffer-invisibility-spec' (which is what
-    ;; `notmuch-show-headers-visible' and
-    ;; `notmuch-show-message-visible' do) is a no-op and has no
-    ;; effect. This caused threads with only matching messages to have
-    ;; those messages hidden initially because
-    ;; `buffer-invisibility-spec' stayed `t'.
-    ;;
-    ;; This needs to be set here (rather than just above the call to
-    ;; `notmuch-show-headers-visible') because some of the part
-    ;; rendering or body washing functions
-    ;; (e.g. `notmuch-wash-text/plain-citations') manipulate
-    ;; `buffer-invisibility-spec').
-    (when (eq buffer-invisibility-spec t)
-      (setq buffer-invisibility-spec nil))
-
     (setq message-start (point-marker))
 
     (notmuch-show-insert-headerline headers
@@ -884,9 +900,6 @@ message at DEPTH in the current thread."
 
     (setq content-start (point-marker))
 
-    (plist-put msg :headers-invis-spec headers-invis-spec)
-    (plist-put msg :message-invis-spec message-invis-spec)
-
     ;; 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.
@@ -904,7 +917,6 @@ message at DEPTH in the current thread."
 
     (setq notmuch-show-previous-subject bare-subject)
 
-    (setq body-start (point-marker))
     ;; A blank line between the headers and the body.
     (insert "\n")
     (notmuch-show-insert-body msg (plist-get msg :body)
@@ -912,7 +924,6 @@ message at DEPTH in the current thread."
     ;; Ensure that the body ends with a newline.
     (unless (bolp)
       (insert "\n"))
-    (setq body-end (point-marker))
     (setq content-end (point-marker))
 
     ;; Indent according to the depth in the thread.
@@ -925,11 +936,9 @@ message at DEPTH in the current thread."
     ;; message.
     (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end))
 
-    (let ((headers-overlay (make-overlay headers-start headers-end))
-          (invis-specs (list headers-invis-spec message-invis-spec)))
-      (overlay-put headers-overlay 'invisible invis-specs)
-      (overlay-put headers-overlay 'priority 10))
-    (overlay-put (make-overlay body-start body-end) 'invisible message-invis-spec)
+    ;; 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)
 
@@ -991,23 +1000,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 +1125,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 +1174,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 +1222,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)
@@ -1286,18 +1338,12 @@ effects."
 ;; Functions relating to the visibility of messages and their
 ;; components.
 
-(defun notmuch-show-element-visible (props visible-p spec-property)
-  (let ((spec (plist-get props spec-property)))
-    (if visible-p
-	(remove-from-invisibility-spec spec)
-      (add-to-invisibility-spec spec))))
-
 (defun notmuch-show-message-visible (props visible-p)
-  (notmuch-show-element-visible props visible-p :message-invis-spec)
+  (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)
-  (notmuch-show-element-visible props visible-p :headers-invis-spec)
+  (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
@@ -1709,7 +1755,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 +1888,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."