[Emacs-diffs] master 1b4f0a9 2/2: Split shr-copy-url dwim behavior into separate functions (Bug#26826)

[Noam Postavsky]

branch: master
commit 1b4f0a92ff3505ef9a465b9b391756e3a73a6443
Author: Noam Postavsky <address@hidden>
Commit: Noam Postavsky <address@hidden>

    Split shr-copy-url dwim behavior into separate functions (Bug#26826)
    
    * lisp/net/shr.el (shr-url-at-point, shr-probe-url)
    (shr-probe-and-copy-url, shr-maybe-probe-and-copy-url): New functions,
    split out from `shr-copy-url'.
    (shr-copy-url): Only copy the url, don't fetch it.
    (shr-map): Bind 'w' and 'u' to `shr-maybe-probe-and-copy-url', which
    has the same behavior as the old `shr-copy-url'.
    * etc/NEWS: Announce changes.
---
 etc/NEWS        |  7 +++++
 lisp/net/shr.el | 86 ++++++++++++++++++++++++++++++++++-----------------------
 2 files changed, 58 insertions(+), 35 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 3f68111..39c88c6 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -676,6 +676,13 @@ replaced by the real images asynchronously, which will 
also now
 respect width/height HTML specs (unless they specify widths/heights
 bigger than the current window).
 
+---
+*** The 'w' command on links is now 'shr-maybe-probe-and-copy-url'.
+'shr-copy-url' now only copies the url at point; users who wish to
+avoid accidentally accessing remote links may rebind 'w' and 'u' in
+'eww-link-keymap' to it.
+
+
 ** Ido
 
 *** The commands 'find-alternate-file-other-window',
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 45ef379..4d4e8a8 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -185,8 +185,8 @@ and other things:
     (define-key map [follow-link] 'mouse-face)
     (define-key map [mouse-2] 'shr-browse-url)
     (define-key map "I" 'shr-insert-image)
-    (define-key map "w" 'shr-copy-url)
-    (define-key map "u" 'shr-copy-url)
+    (define-key map "w" 'shr-maybe-probe-and-copy-url)
+    (define-key map "u" 'shr-maybe-probe-and-copy-url)
     (define-key map "v" 'shr-browse-url)
     (define-key map "O" 'shr-save-contents)
     (define-key map "\r" 'shr-browse-url)
@@ -290,43 +290,59 @@ DOM should be a parse tree as generated by
         (forward-line 1)
         (delete-region (point) (point-max))))))
 
-(defun shr-copy-url (&optional image-url)
+(defun shr-url-at-point (image-url)
+  "Return the URL under point as a string.
+If IMAGE-URL is non-nil, or there is no link under point, but
+there is an image under point then copy the URL of the image
+under point instead."
+  (if image-url
+      (get-text-property (point) 'image-url)
+    (or (get-text-property (point) 'shr-url)
+        (get-text-property (point) 'image-url))))
+
+(defun shr-copy-url (url)
   "Copy the URL under point to the kill ring.
 If IMAGE-URL (the prefix) is non-nil, or there is no link under
 point, but there is an image under point then copy the URL of the
-image under point instead.
-If called twice, then try to fetch the URL and see whether it
-redirects somewhere else."
+image under point instead."
+  (interactive (list (shr-url-at-point current-prefix-arg)))
+  (if (not url)
+      (message "No URL under point")
+    (setq url (url-encode-url url))
+    (kill-new url)
+    (message "Copied %s" url)))
+
+(defun shr-probe-url (url cont)
+  "Pass URL's redirect destination to CONT, if it has one.
+CONT should be a function of one argument, the redirect
+destination URL.  If URL is not redirected, then CONT is never
+called."
   (interactive "P")
-  (let ((url (if image-url
-                 (get-text-property (point) 'image-url)
-               (or (get-text-property (point) 'shr-url)
-                   (get-text-property (point) 'image-url)))))
-    (cond
-     ((not url)
-      (message "No URL under point"))
-     ;; Resolve redirected URLs.
-     ((equal url (car kill-ring))
-      (url-retrieve
-       url
-       (lambda (a)
-        (when (and (consp a)
-                   (eq (car a) :redirect))
-          (with-temp-buffer
-            (insert (cadr a))
-            (goto-char (point-min))
-            ;; Remove common tracking junk from the URL.
-            (when (re-search-forward ".utm_.*" nil t)
-              (replace-match "" t t))
-            (message "Copied %s" (buffer-string))
-            (copy-region-as-kill (point-min) (point-max)))))
-       nil t))
-     ;; Copy the URL to the kill ring.
-     (t
-      (with-temp-buffer
-       (insert (url-encode-url url))
-       (copy-region-as-kill (point-min) (point-max))
-       (message "Copied %s" (buffer-string)))))))
+  (url-retrieve
+   url (lambda (a)
+         (pcase a
+           (`(:redirect ,destination . ,_)
+            ;; Remove common tracking junk from the URL.
+            (funcall cont (replace-regexp-in-string
+                           ".utm_.*" "" destination)))))
+   nil t))
+
+(defun shr-probe-and-copy-url (url)
+  "Copy the URL under point to the kill ring.
+Like `shr-copy-url', but additionally fetch URL and use its
+redirection destination if it has one."
+  (interactive (list (shr-url-at-point current-prefix-arg)))
+  (if url (shr-probe-url url #'shr-copy-url)
+    (shr-copy-url url)))
+
+(defun shr-maybe-probe-and-copy-url (url)
+  "Copy the URL under point to the kill ring.
+If the URL is already at the front of the kill ring act like
+`shr-probe-and-copy-url', otherwise like `shr-copy-url'."
+  (interactive (list (shr-url-at-point current-prefix-arg)))
+  (if (equal url (car kill-ring))
+      (shr-probe-and-copy-url url)
+    (shr-copy-url url)))
 
 (defun shr-next-link ()
   "Skip to the next link."