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.
parent 3f082af5
Pipeline #5640 passed with stage
in 59 minutes and 54 seconds
......@@ -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'.
......
......@@ -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.
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment