From 7d3f680e204d8525f4d518777f7ace76ce000192 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 11 May 2017 19:40:45 -0400
Subject: [PATCH v2] 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'.
---
 lisp/net/shr.el | 85 +++++++++++++++++++++++++++++++++------------------------
 1 file changed, 50 insertions(+), 35 deletions(-)

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 2a6b3960c4..749d250022 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -185,8 +185,8 @@ (defvar shr-map
     (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,58 @@ (defun shr--remove-blank-lines-at-the-end (start end)
         (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.  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."
-- 
2.11.1