Improve shr/eww handling of mailto URLs

* lisp/net/eww.el (eww): Use function-put in place of put, as
recommended in "(elisp) Symbol Plists".
(eww-follow-link):
* lisp/net/shr.el (shr-browse-url): Rather than call browse-url-mail
directly, call browse-url which respects the user options
browse-url-handlers and browse-url-mailto-function.  (Bug#41133)
(shr--current-link-region): Return nil if there is no link at point.
(shr--blink-link): Adapt accordingly.
(shr-fill-line, shr-indent, shr-table-body): Refactor to avoid some
unnecessary allocations.
* etc/NEWS: Announce that eww-follow-link and shr-browse-url support
custom URL handlers.

diff --git a/etc/NEWS b/etc/NEWS
index 4533dc46c56dde09e876b4b55b5a4f9bd514f982..eb73bd64e054bd0f8d7e3d66f61c93728b01cadd 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -356,6 +356,24 @@ symbol property to the browsing functions.  With a new command
 'browse-url-with-browser-kind', an URL can explicitly be browsed with
 either an internal or external browser.
 
+** SHR
+
+---
+*** The command 'shr-browse-url' now supports custom mailto handlers.
+Clicking on or otherwise following a 'mailto:' link in a HTML buffer
+rendered by SHR previously invoked the command 'browse-url-mailto'.
+This is still the case by default, but if you customize
+'browse-url-mailto-function' or 'browse-url-handlers' to call some
+other function, it will now be called instead of the default.
+
+** EWW
+
+---
+*** The command 'eww-follow-link' now supports custom mailto handlers.
+The function that is invoked when clicking on or otherwise following a
+'mailto:' link in an EWW buffer can now be customized.  For more
+information, see the related entry about 'shr-browse-url' above.
+
 ** Project
 
 *** New user option 'project-vc-merge-submodules'.

diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index a6c1abdbb19bad67971faedd95630ef1b8a24299..2a70560ca7bb8a16d0dc96d709ce97300d160b65 100644 (file)
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -307,10 +307,10 @@ the default EWW buffer."
     (insert (format "Loading %s..." url))
     (goto-char (point-min)))
   (let ((url-mime-accept-string eww-accept-content-types))
-    (url-retrieve url 'eww-render
+    (url-retrieve url #'eww-render
                   (list url nil (current-buffer)))))
 
-(put 'eww 'browse-url-browser-kind 'internal)
+(function-put 'eww 'browse-url-browser-kind 'internal)
 
 (defun eww--dwim-expand-url (url)
   (setq url (string-trim url))
@@ -375,8 +375,8 @@ engine used."
       (let ((region-string (buffer-substring (region-beginning) (region-end))))
         (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string))
             (eww region-string)
-          (call-interactively 'eww)))
-    (call-interactively 'eww)))
+          (call-interactively #'eww)))
+    (call-interactively #'eww)))
 
 (defun eww-open-in-new-buffer ()
   "Fetch link at point in a new EWW buffer."
@@ -1013,7 +1013,7 @@ just re-display the HTML already fetched."
          (eww-display-html 'utf-8 url (plist-get eww-data :dom)
                            (point) (current-buffer)))
       (let ((url-mime-accept-string eww-accept-content-types))
-        (url-retrieve url 'eww-render
+        (url-retrieve url #'eww-render
                      (list url (point) (current-buffer) encode))))))
 
 ;; Form support.
@@ -1576,8 +1576,10 @@ If EXTERNAL is double prefix, browse in new buffer."
     (cond
      ((not url)
       (message "No link under point"))
-     ((string-match "^mailto:" url)
-      (browse-url-mail url))
+     ((string-match-p "\\`mailto:" url)
+      ;; This respects the user options `browse-url-handlers'
+      ;; and `browse-url-mailto-function'.
+      (browse-url url))
      ((and (consp external) (<= (car external) 4))
       (funcall browse-url-secondary-browser-function url)
       (shr--blink-link))
@@ -1615,7 +1617,7 @@ Use link at point if there is one, else the current page's URL."
                  (eww-current-url))))
     (if (not url)
         (message "No URL under point")
-      (url-retrieve url 'eww-download-callback (list url)))))
+      (url-retrieve url #'eww-download-callback (list url)))))
 
 (defun eww-download-callback (status url)
   (unless (plist-get status :error)
@@ -2128,12 +2130,12 @@ entries (if any) will be removed from the list.
 Only the properties listed in `eww-desktop-data-save' are included.
 Generally, the list should not include the (usually overly large)
 :dom, :source and :text properties."
-  (let ((history  (mapcar 'eww-desktop-data-1
-                         (cons eww-data eww-history))))
-    (list :history  (if eww-desktop-remove-duplicates
-                       (cl-remove-duplicates
-                        history :test 'eww-desktop-history-duplicate)
-                     history))))
+  (let ((history (mapcar #'eww-desktop-data-1
+                         (cons eww-data eww-history))))
+    (list :history (if eww-desktop-remove-duplicates
+                       (cl-remove-duplicates
+                        history :test #'eww-desktop-history-duplicate)
+                     history))))
 
 (defun eww-restore-desktop (file-name buffer-name misc-data)
   "Restore an eww buffer from its desktop file record.

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 1f80ab74db5efaca8bcf56b06ab2d07bd35f5210..03260c9e70a5eca6fec0680a5611da4697b1318f 100644 (file)
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -135,7 +135,7 @@ same domain as the main data."
 This is used for cid: URLs, and the function is called with the
 cid: URL as the argument.")
 
-(defvar shr-put-image-function 'shr-put-image
+(defvar shr-put-image-function #'shr-put-image
   "Function called to put image and alt string.")
 
 (defface shr-strike-through '((t :strike-through t))
@@ -365,25 +365,20 @@ If the URL is already at the front of the kill ring act like
     (shr-copy-url url)))
 
 (defun shr--current-link-region ()
-  (let ((current (get-text-property (point) 'shr-url))
-        start)
-    (save-excursion
-      ;; Go to the beginning.
-      (while (and (not (bobp))
-                 (equal (get-text-property (point) 'shr-url) current))
-        (forward-char -1))
-      (unless (equal (get-text-property (point) 'shr-url) current)
-        (forward-char 1))
-      (setq start (point))
-      ;; Go to the end.
-      (while (and (not (eobp))
-                  (equal (get-text-property (point) 'shr-url) current))
-        (forward-char 1))
-      (list start (point)))))
+  "Return the start and end positions of the URL at point, if any.
+Value is a pair of positions (START . END) if there is a non-nil
+`shr-url' text property at point; otherwise nil."
+  (when (get-text-property (point) 'shr-url)
+    (let* ((end (or (next-single-property-change (point) 'shr-url)
+                    (point-max)))
+           (beg (or (previous-single-property-change end 'shr-url)
+                    (point-min))))
+      (cons beg end))))
 
 (defun shr--blink-link ()
-  (let* ((region (shr--current-link-region))
-         (overlay (make-overlay (car region) (cadr region))))
+  "Briefly fontify URL at point with the face `shr-selected-link'."
+  (when-let* ((region  (shr--current-link-region))
+              (overlay (make-overlay (car region) (cdr region))))
     (overlay-put overlay 'face 'shr-selected-link)
     (run-at-time 1 nil (lambda ()
                          (delete-overlay overlay)))))
@@ -437,7 +432,7 @@ the URL of the image to the kill buffer instead."
     (if (not url)
        (message "No image under point")
       (message "Inserting %s..." url)
-      (url-retrieve url 'shr-image-fetched
+      (url-retrieve url #'shr-image-fetched
                    (list (current-buffer) (1- (point)) (point-marker))
                    t))))
 
@@ -463,7 +458,7 @@ size, and full-buffer size."
        (when (> (- (point) start) 2)
          (delete-region start (1- (point)))))
       (message "Inserting %s..." url)
-      (url-retrieve url 'shr-image-fetched
+      (url-retrieve url #'shr-image-fetched
                    (list (current-buffer) (1- (point)) (point-marker)
                          (list (cons 'size
                                      (cond ((or (eq size 'default)
@@ -493,7 +488,7 @@ size, and full-buffer size."
          ((fboundp function)
           (apply function dom args))
          (t
-          (apply 'shr-generic dom args)))))
+           (apply #'shr-generic dom args)))))
 
 (defun shr-descend (dom)
   (let ((function
@@ -730,9 +725,10 @@ size, and full-buffer size."
         (let ((gap-start (point))
               (face (get-text-property (point) 'face)))
           ;; Extend the background to the end of the line.
-          (if face
-              (insert (propertize "\n" 'face (shr-face-background face)))
-            (insert "\n"))
+          (insert ?\n)
+          (when face
+            (put-text-property (1- (point)) (point)
+                               'face (shr-face-background face)))
          (shr-indent)
           (when (and (> (1- gap-start) (point-min))
                      (get-text-property (point) 'shr-url)
@@ -935,12 +931,11 @@ size, and full-buffer size."
 
 (defun shr-indent ()
   (when (> shr-indentation 0)
-    (insert
-     (if (not shr-use-fonts)
-        (make-string shr-indentation ?\s)
-       (propertize " "
-                  'display
-                  `(space :width (,shr-indentation)))))))
+    (if (not shr-use-fonts)
+        (insert-char ?\s shr-indentation)
+      (insert ?\s)
+      (put-text-property (1- (point)) (point)
+                         'display `(space :width (,shr-indentation))))))
 
 (defun shr-fontize-dom (dom &rest types)
   (let ((start (point)))
@@ -987,16 +982,11 @@ the mouse click event."
     (cond
      ((not url)
       (message "No link under point"))
-     ((string-match "^mailto:" url)
-      (browse-url-mail url))
+     (external
+      (funcall browse-url-secondary-browser-function url)
+      (shr--blink-link))
      (t
-      (if external
-          (progn
-           (funcall browse-url-secondary-browser-function url)
-            (shr--blink-link))
-       (browse-url url (if new-window
-                           (not browse-url-new-window-flag)
-                         browse-url-new-window-flag)))))))
+      (browse-url url (xor new-window browse-url-new-window-flag))))))
 
 (defun shr-save-contents (directory)
   "Save the contents from URL in a file."
@@ -1005,7 +995,7 @@ the mouse click event."
     (if (not url)
        (message "No link under point")
       (url-retrieve (shr-encode-url url)
-                   'shr-store-contents (list url directory)))))
+                    #'shr-store-contents (list url directory)))))
 
 (defun shr-store-contents (status url directory)
   (unless (plist-get status :error)
@@ -1156,7 +1146,6 @@ width/height instead."
 
 ;; url-cache-extract autoloads url-cache.
 (declare-function url-cache-create-filename "url-cache" (url))
-(autoload 'browse-url-mail "browse-url")
 
 (defun shr-get-image-data (url)
   "Get image data for URL.
@@ -1230,7 +1219,7 @@ START, and END.  Note that START and END should be markers."
                   (funcall shr-put-image-function
                            image (buffer-substring start end))
                   (delete-region (point) end))))
-        (url-retrieve url 'shr-image-fetched
+         (url-retrieve url #'shr-image-fetched
                       (list (current-buffer) start end)
                       t t)))))
 
@@ -1679,7 +1668,7 @@ The preference is a float determined from `shr-prefer-media-type'."
              (or alt "")))
           (insert " ")
          (url-queue-retrieve
-          (shr-encode-url url) 'shr-image-fetched
+           (shr-encode-url url) #'shr-image-fetched
           (list (current-buffer) start (set-marker (make-marker) (point))
                  (list :width width :height height))
           t
@@ -2006,12 +1995,11 @@ BASE is the URL of the HTML being rendered."
     (cond
      ((null tbodies)
       dom)
-     ((= (length tbodies) 1)
+     ((null (cdr tbodies))
       (car tbodies))
      (t
       ;; Table with multiple tbodies.  Convert into a single tbody.
-      `(tbody nil ,@(cl-reduce 'append
-                               (mapcar 'dom-non-text-children tbodies)))))))
+      `(tbody nil ,@(mapcan #'dom-non-text-children tbodies))))))
 
 (defun shr--fix-tbody (tbody)
   (nconc (list 'tbody (dom-attributes tbody))
@@ -2311,8 +2299,8 @@ flags that control whether to collect or render objects."
        (dolist (column row)
          (aset natural-widths i (max (aref natural-widths i) column))
          (setq i (1+ i)))))
-    (let ((extra (- (apply '+ (append suggested-widths nil))
-                   (apply '+ (append widths nil))
+    (let ((extra (- (apply #'+ (append suggested-widths nil))
+                    (apply #'+ (append widths nil))
                    (* shr-table-separator-pixel-width (1+ (length widths)))))
          (expanded-columns 0))
       ;; We have extra, unused space, so divide this space amongst the