unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#39980: [PATCH] gnus-shorten-url: Improve and avoid args-out-of-range error
@ 2020-03-08  9:06 Štěpán Němec
  2020-03-14 11:41 ` Lars Ingebrigtsen
  0 siblings, 1 reply; 19+ messages in thread
From: Štěpán Němec @ 2020-03-08  9:06 UTC (permalink / raw)
  To: 39980

'gnus-shorten-url' (used by 'gnus-summary-browse-url') ignored
fragment identifiers and didn't check substring bounds, in some cases
leading to runtime errors, e.g.:

  (gnus-shorten-url "https://some.url.with/path/and#also_a_long_target" 40)
  ;; => Lisp error: (args-out-of-range "/path/and" -18 nil)

This commit makes it account for #fragments and fixes faulty string
computation, reusing existing helper function.

* lisp/vc/ediff-init.el
(ediff-truncate-string-left): Rename to 'string-truncate-left'.
* lisp/emacs-lisp/subr-x.el (string-truncate-left): Move here.
* lisp/vc/ediff-mult.el (ediff-meta-insert-file-info1) (ediff-draw-dir-diffs):
'ediff-draw-dir-diffs' renamed to 'string-truncate-left'.
* lisp/gnus/gnus-sum.el (gnus-shorten-url): Fix args-out-of-range
error, don't drop #fragments, use 'string-truncate-left'.
---
 lisp/emacs-lisp/subr-x.el |  8 ++++++++
 lisp/gnus/gnus-sum.el     | 14 +++++++-------
 lisp/vc/ediff-init.el     | 10 ----------
 lisp/vc/ediff-mult.el     | 10 ++++++----
 4 files changed, 21 insertions(+), 21 deletions(-)

diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 044c9aada0..baf20131cc 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -236,6 +236,14 @@ string-trim
 TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
   (string-trim-left (string-trim-right string trim-right) trim-left))
 
+(defsubst string-truncate-left (string length)
+  "Truncate STRING to LENGTH, replacing initial surplus with \"...\"."
+  (let ((strlen (length string)))
+    (if (<= strlen length)
+	string
+      (setq length (max 0 (- length 3)))
+      (concat "..." (substring string (max 0 (- strlen 1 length)))))))
+
 (defsubst string-blank-p (string)
   "Check whether STRING is either empty or only whitespace.
 The following characters count as whitespace here: space, tab, newline and
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index a47e657623..6f367692dd 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -9494,15 +9494,15 @@ gnus-collect-urls
     (delete-dups urls)))
 
 (defun gnus-shorten-url (url max)
-  "Return an excerpt from URL."
+  "Return an excerpt from URL not exceeding MAX characters."
   (if (<= (length url) max)
       url
-    (let ((parsed (url-generic-parse-url url)))
-      (concat (url-host parsed)
-	      "..."
-	      (substring (url-filename parsed)
-			 (- (length (url-filename parsed))
-			    (max (- max (length (url-host parsed))) 0)))))))
+    (let* ((parsed (url-generic-parse-url url))
+           (host (url-host parsed))
+           (rest (concat (url-filename parsed)
+                         (when-let ((target (url-target parsed)))
+                           (concat "#" target)))))
+      (concat host (string-truncate-left rest (- max (length host)))))))
 
 (defun gnus-summary-browse-url (&optional external)
   "Scan the current article body for links, and offer to browse them.
diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el
index cbd8c0d322..c7498064dc 100644
--- a/lisp/vc/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -1524,16 +1524,6 @@ ediff-strip-last-dir
 	(setq dir (substring dir 0 pos)))
     (ediff-abbreviate-file-name (file-name-directory dir))))
 
-(defun ediff-truncate-string-left (str newlen)
-  ;; leave space for ... on the left
-  (let ((len (length str))
-	substr)
-    (if (<= len newlen)
-	str
-      (setq newlen (max 0 (- newlen 3)))
-      (setq substr (substring str (max 0 (- len 1 newlen))))
-      (concat "..." substr))))
-
 (defsubst ediff-nonempty-string-p (string)
   (and (stringp string) (not (string= string ""))))
 
diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el
index fee87e8352..5dcb42eb64 100644
--- a/lisp/vc/ediff-mult.el
+++ b/lisp/vc/ediff-mult.el
@@ -113,6 +113,8 @@ ediff-mult
 (require 'ediff-wind)
 (require 'ediff-util)
 
+(eval-when-compile
+  (require 'subr-x))                    ; string-truncate-left
 
 ;; meta-buffer
 (ediff-defvar-local ediff-meta-buffer nil "")
@@ -1172,7 +1174,7 @@ ediff-meta-insert-file-info1
 	  ;; abbreviate the file name, if file exists
 	  (if (and (not (stringp fname)) (< file-size -1))
 	      "-------"		; file doesn't exist
-	    (ediff-truncate-string-left
+	    (string-truncate-left
 	     (ediff-abbreviate-file-name fname)
 	     max-filename-width)))))))
 
@@ -1266,7 +1268,7 @@ ediff-draw-dir-diffs
 	(if (= (mod membership-code ediff-membership-code1) 0) ; dir1
 	    (let ((beg (point)))
 	      (insert (format "%-27s"
-			      (ediff-truncate-string-left
+			      (string-truncate-left
 			       (ediff-abbreviate-file-name
 				(if (file-directory-p (concat dir1 file))
 				    (file-name-as-directory file)
@@ -1281,7 +1283,7 @@ ediff-draw-dir-diffs
 	(if (= (mod membership-code ediff-membership-code2) 0) ; dir2
 	    (let ((beg (point)))
 	      (insert (format "%-26s"
-			      (ediff-truncate-string-left
+			      (string-truncate-left
 			       (ediff-abbreviate-file-name
 				(if (file-directory-p (concat dir2 file))
 				    (file-name-as-directory file)
@@ -1295,7 +1297,7 @@ ediff-draw-dir-diffs
 	    (if (= (mod membership-code ediff-membership-code3) 0) ; dir3
 		(let ((beg (point)))
 		  (insert (format " %-25s"
-				  (ediff-truncate-string-left
+				  (string-truncate-left
 				   (ediff-abbreviate-file-name
 				    (if (file-directory-p (concat dir3 file))
 					(file-name-as-directory file)
-- 
2.25.1






^ permalink raw reply related	[flat|nested] 19+ messages in thread

end of thread, other threads:[~2020-04-13 10:31 UTC | newest]

Thread overview: 19+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2020-03-08  9:06 bug#39980: [PATCH] gnus-shorten-url: Improve and avoid args-out-of-range error Štěpán Němec
2020-03-14 11:41 ` Lars Ingebrigtsen
2020-03-14 16:34   ` Štěpán Němec
2020-03-14 18:03     ` Lars Ingebrigtsen
2020-03-14 18:12       ` Štěpán Němec
2020-03-14 18:15       ` Eli Zaretskii
2020-03-28 14:17         ` Štěpán Němec
2020-04-02 11:01           ` Lars Ingebrigtsen
2020-04-12  9:53             ` Štěpán Němec
2020-04-12 10:33               ` Eli Zaretskii
2020-04-12 10:49                 ` Štěpán Němec
2020-04-12 11:05                   ` Eli Zaretskii
2020-04-12 11:47                     ` Štěpán Němec
2020-04-12 13:38                       ` Eli Zaretskii
2020-04-12 14:13                         ` Štěpán Němec
2020-04-12 14:35                           ` Eli Zaretskii
2020-04-12 20:02                             ` Štěpán Němec
2020-04-13  4:26                               ` Eli Zaretskii
2020-04-13 10:31                                 ` Štěpán Němec

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).