From 1b4f0a92ff3505ef9a465b9b391756e3a73a6443 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Thu, 11 May 2017 19:40:45 -0400 Subject: [PATCH] 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 3f6811198d1..39c88c60e77 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 45ef379af54..4d4e8a809e1 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." -- 2.39.2