bug#41133: 28.0.50; Respect browse-url user options in shr/eww

["Basil L. Contovounesios" <contovob@tcd.ie>]

[-- Attachment #1: Type: text/plain, Size: 1513 bytes --]

Eli Zaretskii <eliz@gnu.org> writes:

>> ++++
>> +*** 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 which function is invoked can
>> +now be customized via the user options 'browse-url-mailto-function'
>> +and 'browse-url-handlers'.
>
> I'd rephrase the last sentence like this:
>
>   This is still the case by default, but if you customized
>   'browse-url-mailto-function' to call some other function, it will
>   now be called instead of the default.

Should it not also mention browse-url-handlers as per the attached?

> Also, the "+++" means the change is documented in some manual, but no
> changes for the manual are part of the patch, so I guess you meant
> "---" instead.

Oops, I misremembered "+++" as meaning "all necessary doc changes made"
instead of just "doc changes made".

>> +** EWW
>> +
>> ++++
>> +*** The command 'eww-follow-link' now supports custom mailto handlers.
>> +Clicking on or otherwise following a 'mailto:' link in an EWW buffer
>> +previously invoked the command 'browse-url-mailto'.  This is still the
>> +case by default, but which function is invoked can now be customized
>> +via the user options 'browse-url-mailto-function' and
>> +'browse-url-handlers'.
>
> Maybe we should point to the SHR entry instead of repeating almost the
> same text.

Sure, how's this?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Improve-shr-eww-handling-of-mailto-URLs.patch --]
[-- Type: text/x-diff, Size: 12249 bytes --]

From 6ab52e1f5c13a231199045acac8f42fca40cb4d5 Mon Sep 17 00:00:00 2001
From: "Basil L. Contovounesios" <contovob@tcd.ie>
Date: Wed, 6 May 2020 18:02:32 +0100
Subject: [PATCH] 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.
---
 etc/NEWS        | 18 +++++++++++
 lisp/net/eww.el | 30 +++++++++---------
 lisp/net/shr.el | 84 +++++++++++++++++++++----------------------------
 3 files changed, 70 insertions(+), 62 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index ae676a9bf8..f4c0890663 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -348,6 +348,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.
+
 \f
 * New Modes and Packages in Emacs 28.1
 
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index a6c1abdbb1..2a70560ca7 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -307,10 +307,10 @@ eww
     (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 @@ eww-search-words
       (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 @@ eww-reload
 	  (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 @@ eww-follow-link
     (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 @@ eww-download
                  (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 @@ eww-desktop-misc-data
 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 1f80ab74db..03260c9e70 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -135,7 +135,7 @@ shr-content-function
 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 @@ shr-maybe-probe-and-copy-url
     (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 @@ shr-insert-image
     (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 @@ shr-zoom-image
 	(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 @@ shr-indirect-call
 	  ((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 @@ shr-fill-line
         (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 @@ shr-ensure-paragraph
 
 (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 @@ shr-browse-url
     (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 @@ shr-save-contents
     (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 @@ shr-rescale-image
 
 ;; 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 @@ shr-image-displayer
 		   (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 @@ shr-tag-img
              (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 @@ shr-table-body
     (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 @@ shr-table-widths
 	(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
-- 
2.26.2


[-- Attachment #3: Type: text/plain, Size: 20 bytes --]


Thanks,

-- 
Basil