aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorAlan Mackenzie2022-01-22 11:02:50 +0000
committerAlan Mackenzie2022-01-22 11:02:50 +0000
commit14d64a8adcc866deecd758b898e8ef2d836b354a (patch)
tree83cff9669e266f8e283ccb8cd7518e909240f1e1 /lisp
parentbdd9b5b8a0d37dd09ee530c1dab3a44bee09e0f8 (diff)
parentebe334cdc234de2897263aed4c05ac7088c11857 (diff)
downloademacs-scratch/correct-warning-pos.tar.gz
emacs-scratch/correct-warning-pos.zip
Merge branch 'master' into scratch/correct-warning-posscratch/correct-warning-pos
Diffstat (limited to 'lisp')
-rw-r--r--lisp/Makefile.in16
-rw-r--r--lisp/cus-face.el140
-rw-r--r--lisp/cus-start.el3
-rw-r--r--lisp/doc-view.el2
-rw-r--r--lisp/emacs-lisp/autoload.el4
-rw-r--r--lisp/emacs-lisp/bytecomp.el352
-rw-r--r--lisp/emacs-lisp/comp.el10
-rw-r--r--lisp/emacs-lisp/edebug.el6
-rw-r--r--lisp/emacs-lisp/ert.el6
-rw-r--r--lisp/emacs-lisp/multisession.el14
-rw-r--r--lisp/emacs-lisp/pp.el5
-rw-r--r--lisp/emacs-lisp/range.el467
-rw-r--r--lisp/emacs-lisp/tabulated-list.el12
-rw-r--r--lisp/eshell/em-basic.el37
-rw-r--r--lisp/eshell/em-script.el18
-rw-r--r--lisp/eshell/esh-cmd.el63
-rw-r--r--lisp/eshell/esh-opt.el12
-rw-r--r--lisp/face-remap.el7
-rw-r--r--lisp/faces.el10
-rw-r--r--lisp/files.el10
-rw-r--r--lisp/gnus/gnus-agent.el45
-rw-r--r--lisp/gnus/gnus-art.el64
-rw-r--r--lisp/gnus/gnus-cloud.el3
-rw-r--r--lisp/gnus/gnus-draft.el2
-rw-r--r--lisp/gnus/gnus-group.el52
-rw-r--r--lisp/gnus/gnus-int.el2
-rw-r--r--lisp/gnus/gnus-kill.el2
-rw-r--r--lisp/gnus/gnus-range.el443
-rw-r--r--lisp/gnus/gnus-start.el14
-rw-r--r--lisp/gnus/gnus-sum.el71
-rw-r--r--lisp/gnus/mail-source.el3
-rw-r--r--lisp/gnus/message.el19
-rw-r--r--lisp/gnus/mm-view.el2
-rw-r--r--lisp/gnus/nnheader.el8
-rw-r--r--lisp/gnus/nnimap.el29
-rw-r--r--lisp/gnus/nnmaildir.el16
-rw-r--r--lisp/gnus/nnmairix.el2
-rw-r--r--lisp/gnus/nnmbox.el6
-rw-r--r--lisp/gnus/nnml.el19
-rw-r--r--lisp/gnus/nnselect.el30
-rw-r--r--lisp/gnus/nnvirtual.el2
-rw-r--r--lisp/help-fns.el51
-rw-r--r--lisp/hi-lock.el26
-rw-r--r--lisp/image-dired.el3
-rw-r--r--lisp/indent.el35
-rw-r--r--lisp/international/characters.el23
-rw-r--r--lisp/international/emoji.el75
-rw-r--r--lisp/international/fontset.el4
-rw-r--r--lisp/international/textsec-check.el78
-rw-r--r--lisp/international/textsec.el429
-rw-r--r--lisp/keymap.el64
-rw-r--r--lisp/man.el10
-rw-r--r--lisp/menu-bar.el36
-rw-r--r--lisp/minibuffer.el8
-rw-r--r--lisp/mouse.el37
-rw-r--r--lisp/net/dictionary.el2
-rw-r--r--lisp/net/mailcap.el72
-rw-r--r--lisp/net/shr.el13
-rw-r--r--lisp/net/tramp-adb.el10
-rw-r--r--lisp/net/tramp-archive.el5
-rw-r--r--lisp/net/tramp-cache.el2
-rw-r--r--lisp/net/tramp-sh.el24
-rw-r--r--lisp/net/tramp-smb.el5
-rw-r--r--lisp/net/tramp-sshfs.el38
-rw-r--r--lisp/net/tramp-sudoedit.el3
-rw-r--r--lisp/net/tramp.el88
-rw-r--r--lisp/org/ob-gnuplot.el25
-rw-r--r--lisp/org/org-agenda.el5
-rw-r--r--lisp/org/org-version.el2
-rw-r--r--lisp/org/org.el20
-rw-r--r--lisp/org/ox-ascii.el6
-rw-r--r--lisp/outline.el178
-rw-r--r--lisp/paren.el4
-rw-r--r--lisp/progmodes/gud.el3
-rw-r--r--lisp/progmodes/ruby-mode.el22
-rw-r--r--lisp/progmodes/xref.el12
-rw-r--r--lisp/simple.el12
-rw-r--r--lisp/subr.el12
-rw-r--r--lisp/term/haiku-win.el16
-rw-r--r--lisp/term/pgtk-win.el2
-rw-r--r--lisp/term/x-win.el20
-rw-r--r--lisp/textmodes/ispell.el7
-rw-r--r--lisp/tooltip.el17
-rw-r--r--lisp/url/url-queue.el17
-rw-r--r--lisp/vc/diff-mode.el33
-rw-r--r--lisp/vc/pcvs-info.el2
-rw-r--r--lisp/vc/vc.el15
87 files changed, 2336 insertions, 1263 deletions
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 3a72034463c..308407a8bf1 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -77,6 +77,8 @@ AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \
77# Set load-prefer-newer for the benefit of the non-bootstrappers. 77# Set load-prefer-newer for the benefit of the non-bootstrappers.
78BYTE_COMPILE_FLAGS = \ 78BYTE_COMPILE_FLAGS = \
79 --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS) 79 --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS)
80# ... but we must prefer .elc files for those in the early bootstrap.
81compile-first: BYTE_COMPILE_FLAGS = $(BYTE_COMPILE_EXTRA_FLAGS)
80 82
81# Files to compile before others during a bootstrap. This is done to 83# Files to compile before others during a bootstrap. This is done to
82# speed up the bootstrap process. They're ordered by size, so we use 84# speed up the bootstrap process. They're ordered by size, so we use
@@ -303,9 +305,23 @@ endif
303# An old-fashioned suffix rule, which, according to the GNU Make manual, 305# An old-fashioned suffix rule, which, according to the GNU Make manual,
304# cannot have prerequisites. 306# cannot have prerequisites.
305ifeq ($(HAVE_NATIVE_COMP),yes) 307ifeq ($(HAVE_NATIVE_COMP),yes)
308ifeq ($(ANCIENT),yes)
309# The first compilation of compile-first, using an interpreted compiler:
310# The resulting .elc files get given a date of 1971-01-01 so that their
311# date stamp is earlier than the source files, causing these to be compiled
312# into native code at the second recursive invocation of this $(MAKE),
313# using these .elc's. This is faster than just compiling the native code
314# directly using the interpreted compile-first files. (Note: 1970-01-01
315# fails on some systems.)
316.el.elc:
317 $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
318 -l comp -f batch-byte-compile $<
319 touch -t 197101010000 $@
320else
306.el.elc: 321.el.elc:
307 $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ 322 $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
308 -l comp -f batch-byte+native-compile $< 323 -l comp -f batch-byte+native-compile $<
324endif
309else 325else
310.el.elc: 326.el.elc:
311 $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< 327 $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index e905a455570..12ad3910fcb 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -46,7 +46,7 @@
46;;; Face attributes. 46;;; Face attributes.
47 47
48(defconst custom-face-attributes 48(defconst custom-face-attributes
49 '((:family 49 `((:family
50 (string :tag "Font Family" 50 (string :tag "Font Family"
51 :help-echo "Font family or fontset alias name.")) 51 :help-echo "Font family or fontset alias name."))
52 52
@@ -148,29 +148,29 @@
148 (const :tag "At Bottom Of Text" t) 148 (const :tag "At Bottom Of Text" t)
149 (integer :tag "Pixels Above Bottom Of Text")))) 149 (integer :tag "Pixels Above Bottom Of Text"))))
150 ;; filter to make value suitable for customize 150 ;; filter to make value suitable for customize
151 (lambda (real-value) 151 ,(lambda (real-value)
152 (and real-value 152 (and real-value
153 (let ((color 153 (let ((color
154 (or (and (consp real-value) (plist-get real-value :color)) 154 (or (and (consp real-value) (plist-get real-value :color))
155 (and (stringp real-value) real-value) 155 (and (stringp real-value) real-value)
156 'foreground-color)) 156 'foreground-color))
157 (style 157 (style
158 (or (and (consp real-value) (plist-get real-value :style)) 158 (or (and (consp real-value) (plist-get real-value :style))
159 'line)) 159 'line))
160 (position (and (consp real-value) 160 (position (and (consp real-value)
161 (plist-get real-value :style)))) 161 (plist-get real-value :style))))
162 (list :color color :style style :position position)))) 162 (list :color color :style style :position position))))
163 ;; filter to make customized-value suitable for storing 163 ;; filter to make customized-value suitable for storing
164 (lambda (cus-value) 164 ,(lambda (cus-value)
165 (and cus-value 165 (and cus-value
166 (let ((color (plist-get cus-value :color)) 166 (let ((color (plist-get cus-value :color))
167 (style (plist-get cus-value :style)) 167 (style (plist-get cus-value :style))
168 (position (plist-get cus-value :position))) 168 (position (plist-get cus-value :position)))
169 (cond ((and (eq style 'line) (not position)) 169 (cond ((and (eq style 'line) (not position))
170 ;; Use simple value for default style 170 ;; Use simple value for default style
171 (if (eq color 'foreground-color) t color)) 171 (if (eq color 'foreground-color) t color))
172 (t 172 (t
173 `(:color ,color :style ,style :position ,position))))))) 173 `(:color ,color :style ,style :position ,position)))))))
174 174
175 (:overline 175 (:overline
176 (choice :tag "Overline" 176 (choice :tag "Overline"
@@ -206,40 +206,40 @@
206 (const :tag "Flat" flat-button) 206 (const :tag "Flat" flat-button)
207 (const :tag "None" nil)))) 207 (const :tag "None" nil))))
208 ;; filter to make value suitable for customize 208 ;; filter to make value suitable for customize
209 (lambda (real-value) 209 ,(lambda (real-value)
210 (and real-value 210 (and real-value
211 (let ((lwidth 211 (let ((lwidth
212 (or (and (consp real-value) 212 (or (and (consp real-value)
213 (if (listp (cdr real-value)) 213 (if (listp (cdr real-value))
214 (plist-get real-value :line-width) 214 (plist-get real-value :line-width)
215 real-value)) 215 real-value))
216 (and (integerp real-value) real-value) 216 (and (integerp real-value) real-value)
217 '(1 . 1))) 217 '(1 . 1)))
218 (color 218 (color
219 (or (and (consp real-value) (plist-get real-value :color)) 219 (or (and (consp real-value) (plist-get real-value :color))
220 (and (stringp real-value) real-value) 220 (and (stringp real-value) real-value)
221 nil)) 221 nil))
222 (style 222 (style
223 (and (consp real-value) (plist-get real-value :style)))) 223 (and (consp real-value) (plist-get real-value :style))))
224 (if (integerp lwidth) 224 (if (integerp lwidth)
225 (setq lwidth (cons (abs lwidth) lwidth))) 225 (setq lwidth (cons (abs lwidth) lwidth)))
226 (list :line-width lwidth :color color :style style)))) 226 (list :line-width lwidth :color color :style style))))
227 ;; filter to make customized-value suitable for storing 227 ;; filter to make customized-value suitable for storing
228 (lambda (cus-value) 228 ,(lambda (cus-value)
229 (and cus-value 229 (and cus-value
230 (let ((lwidth (plist-get cus-value :line-width)) 230 (let ((lwidth (plist-get cus-value :line-width))
231 (color (plist-get cus-value :color)) 231 (color (plist-get cus-value :color))
232 (style (plist-get cus-value :style))) 232 (style (plist-get cus-value :style)))
233 (cond ((and (null color) (null style)) 233 (cond ((and (null color) (null style))
234 lwidth) 234 lwidth)
235 ((and (null lwidth) (null style)) 235 ((and (null lwidth) (null style))
236 ;; actually can't happen, because LWIDTH is always an int 236 ;; actually can't happen, because LWIDTH is always an int
237 color) 237 color)
238 (t 238 (t
239 ;; Keep as a plist, but remove null entries 239 ;; Keep as a plist, but remove null entries
240 (nconc (and lwidth `(:line-width ,lwidth)) 240 (nconc (and lwidth `(:line-width ,lwidth))
241 (and color `(:color ,color)) 241 (and color `(:color ,color))
242 (and style `(:style ,style))))))))) 242 (and style `(:style ,style)))))))))
243 243
244 (:inverse-video 244 (:inverse-video
245 (choice :tag "Inverse-video" 245 (choice :tag "Inverse-video"
@@ -276,18 +276,18 @@
276 :help-echo "List of faces to inherit attributes from." 276 :help-echo "List of faces to inherit attributes from."
277 (face :Tag "Face" default)) 277 (face :Tag "Face" default))
278 ;; filter to make value suitable for customize 278 ;; filter to make value suitable for customize
279 (lambda (real-value) 279 ,(lambda (real-value)
280 (cond ((or (null real-value) (eq real-value 'unspecified)) 280 (cond ((or (null real-value) (eq real-value 'unspecified))
281 nil) 281 nil)
282 ((symbolp real-value) 282 ((symbolp real-value)
283 (list real-value)) 283 (list real-value))
284 (t 284 (t
285 real-value))) 285 real-value)))
286 ;; filter to make customized-value suitable for storing 286 ;; filter to make customized-value suitable for storing
287 (lambda (cus-value) 287 ,(lambda (cus-value)
288 (if (and (consp cus-value) (null (cdr cus-value))) 288 (if (and (consp cus-value) (null (cdr cus-value)))
289 (car cus-value) 289 (car cus-value)
290 cus-value)))) 290 cus-value))))
291 291
292 "Alist of face attributes. 292 "Alist of face attributes.
293 293
@@ -329,12 +329,12 @@ If FRAME is nil, use the global defaults for FACE."
329 "Apply a list of face specs for user customizations. 329 "Apply a list of face specs for user customizations.
330This works by calling `custom-theme-set-faces' for the `user' 330This works by calling `custom-theme-set-faces' for the `user'
331theme, a special theme referring to settings made via Customize. 331theme, a special theme referring to settings made via Customize.
332The arguments should be a list where each entry has the form: 332The arguments ARGS should be a list where each entry has the form:
333 333
334 (FACE SPEC [NOW [COMMENT]]) 334 (FACE SPEC [NOW [COMMENT]])
335 335
336See the documentation of `custom-theme-set-faces' for details." 336See the documentation of `custom-theme-set-faces' for details."
337 (apply 'custom-theme-set-faces 'user args)) 337 (apply #'custom-theme-set-faces 'user args))
338 338
339(defun custom-theme-set-faces (theme &rest args) 339(defun custom-theme-set-faces (theme &rest args)
340 "Apply a list of face specs associated with theme THEME. 340 "Apply a list of face specs associated with theme THEME.
@@ -419,7 +419,7 @@ Each of the arguments ARGS has this form:
419 (FACE FROM-THEME) 419 (FACE FROM-THEME)
420 420
421This means reset FACE to its value in FROM-THEME." 421This means reset FACE to its value in FROM-THEME."
422 (apply 'custom-theme-reset-faces 'user args)) 422 (apply #'custom-theme-reset-faces 'user args))
423 423
424(define-obsolete-function-alias 'custom-facep #'facep "28.1") 424(define-obsolete-function-alias 'custom-facep #'facep "28.1")
425 425
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index cdadf08a894..afdbd82457b 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -356,6 +356,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
356 (const :tag "Iconify" t)) 356 (const :tag "Iconify" t))
357 "26.1") 357 "26.1")
358 (tooltip-reuse-hidden-frame tooltip boolean "26.1") 358 (tooltip-reuse-hidden-frame tooltip boolean "26.1")
359 (use-system-tooltips tooltip boolean "29.1")
359 ;; fringe.c 360 ;; fringe.c
360 (overflow-newline-into-fringe fringe boolean) 361 (overflow-newline-into-fringe fringe boolean)
361 ;; image.c 362 ;; image.c
@@ -369,7 +370,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
369 (auto-save-timeout auto-save (choice (const :tag "off" nil) 370 (auto-save-timeout auto-save (choice (const :tag "off" nil)
370 (integer :format "%v"))) 371 (integer :format "%v")))
371 (echo-keystrokes minibuffer number) 372 (echo-keystrokes minibuffer number)
372 (polling-period keyboard integer) 373 (polling-period keyboard float)
373 (double-click-time mouse (restricted-sexp 374 (double-click-time mouse (restricted-sexp
374 :match-alternatives (integerp 'nil 't))) 375 :match-alternatives (integerp 'nil 't)))
375 (double-click-fuzz mouse integer "22.1") 376 (double-click-fuzz mouse integer "22.1")
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 5b462b24f5a..5e160f5dff1 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -1189,7 +1189,7 @@ is named like ODF with the extension turned to pdf."
1189 "Convert PDF-PS to PNG asynchronously." 1189 "Convert PDF-PS to PNG asynchronously."
1190 (funcall 1190 (funcall
1191 (pcase doc-view-doc-type 1191 (pcase doc-view-doc-type
1192 ('pdf doc-view-pdf->png-converter-function) 1192 ((or 'pdf 'odf) doc-view-pdf->png-converter-function)
1193 ('djvu #'doc-view-djvu->tiff-converter-ddjvu) 1193 ('djvu #'doc-view-djvu->tiff-converter-ddjvu)
1194 (_ #'doc-view-ps->png-converter-ghostscript)) 1194 (_ #'doc-view-ps->png-converter-ghostscript))
1195 pdf-ps png nil 1195 pdf-ps png nil
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index a51fd8ca255..d0bf342b842 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -340,7 +340,7 @@ put the output in."
340 (t 340 (t
341 (let ((doc-string-elt (function-get (car-safe form) 'doc-string-elt)) 341 (let ((doc-string-elt (function-get (car-safe form) 'doc-string-elt))
342 (outbuf autoload-print-form-outbuf)) 342 (outbuf autoload-print-form-outbuf))
343 (if (and doc-string-elt (stringp (nth doc-string-elt form))) 343 (if (and (numberp doc-string-elt) (stringp (nth doc-string-elt form)))
344 ;; We need to hack the printing because the 344 ;; We need to hack the printing because the
345 ;; doc-string must be printed specially for 345 ;; doc-string must be printed specially for
346 ;; make-docfile (sigh). 346 ;; make-docfile (sigh).
@@ -410,7 +410,7 @@ FILE's name."
410 ";; version-control: never\n" 410 ";; version-control: never\n"
411 ";; no-byte-compile: t\n" ;; #$ is byte-compiled into nil. 411 ";; no-byte-compile: t\n" ;; #$ is byte-compiled into nil.
412 ";; no-update-autoloads: t\n" 412 ";; no-update-autoloads: t\n"
413 ";; coding: utf-8\n" 413 ";; coding: utf-8-emacs-unix\n"
414 ";; End:\n" 414 ";; End:\n"
415 ";;; " basename 415 ";;; " basename
416 " ends here\n"))) 416 " ends here\n")))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 587819f36ed..d6054aef5e1 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -617,8 +617,8 @@ Each element is (INDEX . VALUE)")
617 "Hash byte-code -> byte-to-native-lambda.") 617 "Hash byte-code -> byte-to-native-lambda.")
618(defvar byte-to-native-top-level-forms nil 618(defvar byte-to-native-top-level-forms nil
619 "List of top level forms.") 619 "List of top level forms.")
620(defvar byte-to-native-output-file nil 620(defvar byte-to-native-output-buffer-file nil
621 "Temporary file containing the byte-compilation output.") 621 "Pair holding byte-compilation output buffer, elc filename.")
622(defvar byte-to-native-plist-environment nil 622(defvar byte-to-native-plist-environment nil
623 "To spill `overriding-plist-environment'.") 623 "To spill `overriding-plist-environment'.")
624 624
@@ -1986,6 +1986,42 @@ If compilation is needed, this functions returns the result of
1986(defvar byte-compile-level 0 ; bug#13787 1986(defvar byte-compile-level 0 ; bug#13787
1987 "Depth of a recursive byte compilation.") 1987 "Depth of a recursive byte compilation.")
1988 1988
1989(defun byte-write-target-file (buffer target-file)
1990 "Write BUFFER into TARGET-FILE."
1991 (with-current-buffer buffer
1992 ;; We must disable any code conversion here.
1993 (let* ((coding-system-for-write 'no-conversion)
1994 ;; Write to a tempfile so that if another Emacs
1995 ;; process is trying to load target-file (eg in a
1996 ;; parallel bootstrap), it does not risk getting a
1997 ;; half-finished file. (Bug#4196)
1998 (tempfile
1999 (make-temp-file (when (file-writable-p target-file)
2000 (expand-file-name target-file))))
2001 (default-modes (default-file-modes))
2002 (temp-modes (logand default-modes #o600))
2003 (desired-modes (logand default-modes #o666))
2004 (kill-emacs-hook
2005 (cons (lambda () (ignore-errors
2006 (delete-file tempfile)))
2007 kill-emacs-hook)))
2008 (unless (= temp-modes desired-modes)
2009 (set-file-modes tempfile desired-modes 'nofollow))
2010 (write-region (point-min) (point-max) tempfile nil 1)
2011 ;; This has the intentional side effect that any
2012 ;; hard-links to target-file continue to
2013 ;; point to the old file (this makes it possible
2014 ;; for installed files to share disk space with
2015 ;; the build tree, without causing problems when
2016 ;; emacs-lisp files in the build tree are
2017 ;; recompiled). Previously this was accomplished by
2018 ;; deleting target-file before writing it.
2019 (if byte-native-compiling
2020 ;; Defer elc final renaming.
2021 (setf byte-to-native-output-buffer-file
2022 (cons tempfile target-file))
2023 (rename-file tempfile target-file t)))))
2024
1989;;;###autoload 2025;;;###autoload
1990(defun byte-compile-file (filename &optional load) 2026(defun byte-compile-file (filename &optional load)
1991 "Compile a file of Lisp code named FILENAME into a file of byte code. 2027 "Compile a file of Lisp code named FILENAME into a file of byte code.
@@ -2020,176 +2056,148 @@ See also `emacs-lisp-byte-compile-and-load'."
2020 2056
2021 ;; Force logging of the file name for each file compiled. 2057 ;; Force logging of the file name for each file compiled.
2022 (setq byte-compile-last-logged-file nil) 2058 (setq byte-compile-last-logged-file nil)
2023 (prog1 2059 (let ((byte-compile-current-file filename)
2024 (let ((byte-compile-current-file filename) 2060 (byte-compile-current-group nil)
2025 (byte-compile-current-group nil) 2061 (set-auto-coding-for-load t)
2026 (set-auto-coding-for-load t) 2062 (byte-compile--seen-defvars nil)
2027 (byte-compile--seen-defvars nil) 2063 (byte-compile--known-dynamic-vars
2028 (byte-compile--known-dynamic-vars 2064 (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE")))
2029 (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) 2065 target-file input-buffer output-buffer
2030 target-file input-buffer output-buffer 2066 byte-compile-dest-file byte-compiler-error-flag)
2031 byte-compile-dest-file byte-compiler-error-flag) 2067 (setq target-file (byte-compile-dest-file filename))
2032 (setq target-file (byte-compile-dest-file filename)) 2068 (setq byte-compile-dest-file target-file)
2033 (setq byte-compile-dest-file target-file) 2069 (with-current-buffer
2034 (with-current-buffer 2070 ;; It would be cleaner to use a temp buffer, but if there was
2035 ;; It would be cleaner to use a temp buffer, but if there was 2071 ;; an error, we leave this buffer around for diagnostics.
2036 ;; an error, we leave this buffer around for diagnostics. 2072 ;; Its name is documented in the lispref.
2037 ;; Its name is documented in the lispref. 2073 (setq input-buffer (get-buffer-create
2038 (setq input-buffer (get-buffer-create 2074 (concat " *Compiler Input*"
2039 (concat " *Compiler Input*" 2075 (if (zerop byte-compile-level) ""
2040 (if (zerop byte-compile-level) "" 2076 (format "-%s" byte-compile-level)))))
2041 (format "-%s" byte-compile-level))))) 2077 (erase-buffer)
2042 (erase-buffer) 2078 (setq buffer-file-coding-system nil)
2043 (setq buffer-file-coding-system nil) 2079 ;; Always compile an Emacs Lisp file as multibyte
2044 ;; Always compile an Emacs Lisp file as multibyte 2080 ;; unless the file itself forces unibyte with -*-coding: raw-text;-*-
2045 ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- 2081 (set-buffer-multibyte t)
2046 (set-buffer-multibyte t) 2082 (insert-file-contents filename)
2047 (insert-file-contents filename) 2083 ;; Mimic the way after-insert-file-set-coding can make the
2048 ;; Mimic the way after-insert-file-set-coding can make the 2084 ;; buffer unibyte when visiting this file.
2049 ;; buffer unibyte when visiting this file. 2085 (when (or (eq last-coding-system-used 'no-conversion)
2050 (when (or (eq last-coding-system-used 'no-conversion) 2086 (eq (coding-system-type last-coding-system-used) 5))
2051 (eq (coding-system-type last-coding-system-used) 5)) 2087 ;; For coding systems no-conversion and raw-text...,
2052 ;; For coding systems no-conversion and raw-text..., 2088 ;; edit the buffer as unibyte.
2053 ;; edit the buffer as unibyte. 2089 (set-buffer-multibyte nil))
2054 (set-buffer-multibyte nil)) 2090 ;; Run hooks including the uncompression hook.
2055 ;; Run hooks including the uncompression hook. 2091 ;; If they change the file name, then change it for the output also.
2056 ;; If they change the file name, then change it for the output also. 2092 (let ((buffer-file-name filename)
2057 (let ((buffer-file-name filename) 2093 (dmm (default-value 'major-mode))
2058 (dmm (default-value 'major-mode)) 2094 ;; Ignore unsafe local variables.
2059 ;; Ignore unsafe local variables. 2095 ;; We only care about a few of them for our purposes.
2060 ;; We only care about a few of them for our purposes. 2096 (enable-local-variables :safe)
2061 (enable-local-variables :safe) 2097 (enable-local-eval nil))
2062 (enable-local-eval nil)) 2098 (unwind-protect
2063 (unwind-protect 2099 (progn
2064 (progn 2100 (setq-default major-mode 'emacs-lisp-mode)
2065 (setq-default major-mode 'emacs-lisp-mode) 2101 ;; Arg of t means don't alter enable-local-variables.
2066 ;; Arg of t means don't alter enable-local-variables. 2102 (delay-mode-hooks (normal-mode t)))
2067 (delay-mode-hooks (normal-mode t))) 2103 (setq-default major-mode dmm))
2068 (setq-default major-mode dmm)) 2104 ;; There may be a file local variable setting (bug#10419).
2069 ;; There may be a file local variable setting (bug#10419). 2105 (setq buffer-read-only nil
2070 (setq buffer-read-only nil 2106 filename buffer-file-name))
2071 filename buffer-file-name)) 2107 ;; Don't inherit lexical-binding from caller (bug#12938).
2072 ;; Don't inherit lexical-binding from caller (bug#12938). 2108 (unless (local-variable-p 'lexical-binding)
2073 (unless (local-variable-p 'lexical-binding) 2109 (setq-local lexical-binding nil))
2074 (setq-local lexical-binding nil)) 2110 ;; Set the default directory, in case an eval-when-compile uses it.
2075 ;; Set the default directory, in case an eval-when-compile uses it. 2111 (setq default-directory (file-name-directory filename)))
2076 (setq default-directory (file-name-directory filename))) 2112 ;; Check if the file's local variables explicitly specify not to
2077 ;; Check if the file's local variables explicitly specify not to 2113 ;; compile this file.
2078 ;; compile this file. 2114 (if (with-current-buffer input-buffer no-byte-compile)
2079 (if (with-current-buffer input-buffer no-byte-compile) 2115 (progn
2080 (progn 2116 ;; (message "%s not compiled because of `no-byte-compile: %s'"
2081 ;; (message "%s not compiled because of `no-byte-compile: %s'" 2117 ;; (byte-compile-abbreviate-file filename)
2082 ;; (byte-compile-abbreviate-file filename) 2118 ;; (with-current-buffer input-buffer no-byte-compile))
2083 ;; (with-current-buffer input-buffer no-byte-compile)) 2119 (when (and target-file (file-exists-p target-file))
2084 (when (and target-file (file-exists-p target-file)) 2120 (message "%s deleted because of `no-byte-compile: %s'"
2085 (message "%s deleted because of `no-byte-compile: %s'" 2121 (byte-compile-abbreviate-file target-file)
2086 (byte-compile-abbreviate-file target-file) 2122 (buffer-local-value 'no-byte-compile input-buffer))
2087 (buffer-local-value 'no-byte-compile input-buffer)) 2123 (condition-case nil (delete-file target-file) (error nil)))
2088 (condition-case nil (delete-file target-file) (error nil))) 2124 ;; We successfully didn't compile this file.
2089 ;; We successfully didn't compile this file. 2125 'no-byte-compile)
2090 'no-byte-compile) 2126 (when byte-compile-verbose
2091 (when byte-compile-verbose 2127 (message "Compiling %s..." filename))
2092 (message "Compiling %s..." filename)) 2128 ;; It is important that input-buffer not be current at this call,
2093 ;; It is important that input-buffer not be current at this call, 2129 ;; so that the value of point set in input-buffer
2094 ;; so that the value of point set in input-buffer 2130 ;; within byte-compile-from-buffer lingers in that buffer.
2095 ;; within byte-compile-from-buffer lingers in that buffer. 2131 (setq output-buffer
2096 (setq output-buffer 2132 (save-current-buffer
2097 (save-current-buffer 2133 (let ((byte-compile-level (1+ byte-compile-level)))
2098 (let ((symbols-with-pos-enabled t) 2134 (byte-compile-from-buffer input-buffer))))
2099 (byte-compile-level (1+ byte-compile-level))) 2135 (if byte-compiler-error-flag
2100 (byte-compile-from-buffer input-buffer)))) 2136 nil
2101 (if byte-compiler-error-flag 2137 (when byte-compile-verbose
2102 nil 2138 (message "Compiling %s...done" filename))
2103 (when byte-compile-verbose 2139 (kill-buffer input-buffer)
2104 (message "Compiling %s...done" filename)) 2140 (with-current-buffer output-buffer
2105 (kill-buffer input-buffer) 2141 (when (and target-file
2106 (with-current-buffer output-buffer 2142 (or (not byte-native-compiling)
2107 (when (and target-file 2143 (and byte-native-compiling byte+native-compile)))
2108 (or (not byte-native-compiling) 2144 (goto-char (point-max))
2109 (and byte-native-compiling byte+native-compile))) 2145 (insert "\n") ; aaah, unix.
2110 (goto-char (point-max)) 2146 (cond
2111 (insert "\n") ; aaah, unix. 2147 ((and (file-writable-p target-file)
2112 (cond 2148 ;; We attempt to create a temporary file in the
2113 ((and (file-writable-p target-file) 2149 ;; target directory, so the target directory must be
2114 ;; We attempt to create a temporary file in the 2150 ;; writable.
2115 ;; target directory, so the target directory must be 2151 (file-writable-p
2116 ;; writable. 2152 (file-name-directory
2117 (file-writable-p 2153 ;; Need to expand in case TARGET-FILE doesn't
2118 (file-name-directory 2154 ;; include a directory (Bug#45287).
2119 ;; Need to expand in case TARGET-FILE doesn't 2155 (expand-file-name target-file))))
2120 ;; include a directory (Bug#45287). 2156 (if byte-native-compiling
2121 (expand-file-name target-file)))) 2157 ;; Defer elc production.
2122 ;; We must disable any code conversion here. 2158 (setf byte-to-native-output-buffer-file
2123 (let* ((coding-system-for-write 'no-conversion) 2159 (cons (current-buffer) target-file))
2124 ;; Write to a tempfile so that if another Emacs 2160 (byte-write-target-file (current-buffer) target-file))
2125 ;; process is trying to load target-file (eg in a 2161 (or noninteractive
2126 ;; parallel bootstrap), it does not risk getting a 2162 byte-native-compiling
2127 ;; half-finished file. (Bug#4196) 2163 (message "Wrote %s" target-file)))
2128 (tempfile 2164 ((file-writable-p target-file)
2129 (make-temp-file (when (file-writable-p target-file) 2165 ;; In case the target directory isn't writable (see e.g. Bug#44631),
2130 (expand-file-name target-file)))) 2166 ;; try writing to the output file directly. We must disable any
2131 (default-modes (default-file-modes)) 2167 ;; code conversion here.
2132 (temp-modes (logand default-modes #o600)) 2168 (let ((coding-system-for-write 'no-conversion))
2133 (desired-modes (logand default-modes #o666)) 2169 (with-file-modes (logand (default-file-modes) #o666)
2134 (kill-emacs-hook 2170 (write-region (point-min) (point-max) target-file nil 1)))
2135 (cons (lambda () (ignore-errors 2171 (or noninteractive (message "Wrote %s" target-file)))
2136 (delete-file tempfile))) 2172 (t
2137 kill-emacs-hook))) 2173 ;; This is just to give a better error message than write-region
2138 (unless (= temp-modes desired-modes) 2174 (let ((exists (file-exists-p target-file)))
2139 (set-file-modes tempfile desired-modes 'nofollow)) 2175 (signal (if exists 'file-error 'file-missing)
2140 (write-region (point-min) (point-max) tempfile nil 1) 2176 (list "Opening output file"
2141 ;; This has the intentional side effect that any 2177 (if exists
2142 ;; hard-links to target-file continue to 2178 "Cannot overwrite file"
2143 ;; point to the old file (this makes it possible 2179 "Directory not writable or nonexistent")
2144 ;; for installed files to share disk space with 2180 target-file))))))
2145 ;; the build tree, without causing problems when 2181 (unless byte-native-compiling
2146 ;; emacs-lisp files in the build tree are 2182 (kill-buffer (current-buffer))))
2147 ;; recompiled). Previously this was accomplished by 2183 (if (and byte-compile-generate-call-tree
2148 ;; deleting target-file before writing it. 2184 (or (eq t byte-compile-generate-call-tree)
2149 (if byte-native-compiling 2185 (y-or-n-p (format "Report call tree for %s? "
2150 ;; Defer elc final renaming. 2186 filename))))
2151 (setf byte-to-native-output-file 2187 (save-excursion
2152 (cons tempfile target-file)) 2188 (display-call-tree filename)))
2153 (rename-file tempfile target-file t))) 2189 (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
2154 (or noninteractive 2190 (when (and gen-dynvars (not (equal gen-dynvars ""))
2155 byte-native-compiling 2191 byte-compile--seen-defvars)
2156 (message "Wrote %s" target-file))) 2192 (let ((dynvar-file (concat target-file ".dynvars")))
2157 ((file-writable-p target-file) 2193 (message "Generating %s" dynvar-file)
2158 ;; In case the target directory isn't writable (see e.g. Bug#44631), 2194 (with-temp-buffer
2159 ;; try writing to the output file directly. We must disable any 2195 (dolist (var (delete-dups byte-compile--seen-defvars))
2160 ;; code conversion here. 2196 (insert (format "%S\n" (cons var filename))))
2161 (let ((coding-system-for-write 'no-conversion)) 2197 (write-region (point-min) (point-max) dynvar-file)))))
2162 (with-file-modes (logand (default-file-modes) #o666) 2198 (if load
2163 (write-region (point-min) (point-max) target-file nil 1))) 2199 (load target-file))
2164 (or noninteractive (message "Wrote %s" target-file))) 2200 t))))
2165 (t
2166 ;; This is just to give a better error message than write-region
2167 (let ((exists (file-exists-p target-file)))
2168 (signal (if exists 'file-error 'file-missing)
2169 (list "Opening output file"
2170 (if exists
2171 "Cannot overwrite file"
2172 "Directory not writable or nonexistent")
2173 target-file))))))
2174 (kill-buffer (current-buffer)))
2175 (if (and byte-compile-generate-call-tree
2176 (or (eq t byte-compile-generate-call-tree)
2177 (y-or-n-p (format "Report call tree for %s? "
2178 filename))))
2179 (save-excursion
2180 (display-call-tree filename)))
2181 (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
2182 (when (and gen-dynvars (not (equal gen-dynvars ""))
2183 byte-compile--seen-defvars)
2184 (let ((dynvar-file (concat target-file ".dynvars")))
2185 (message "Generating %s" dynvar-file)
2186 (with-temp-buffer
2187 (dolist (var (delete-dups byte-compile--seen-defvars))
2188 (insert (format "%S\n" (cons var filename))))
2189 (write-region (point-min) (point-max) dynvar-file)))))
2190 (if load
2191 (load target-file))
2192 t)))))
2193 2201
2194;;; compiling a single function 2202;;; compiling a single function
2195;;;###autoload 2203;;;###autoload
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index dd5ad5a440b..74b0b1197be 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -4213,11 +4213,13 @@ variable 'NATIVE_DISABLED' is set, only byte compile."
4213 (batch-byte-compile) 4213 (batch-byte-compile)
4214 (cl-assert (length= command-line-args-left 1)) 4214 (cl-assert (length= command-line-args-left 1))
4215 (let ((byte+native-compile t) 4215 (let ((byte+native-compile t)
4216 (byte-to-native-output-file nil)) 4216 (byte-to-native-output-buffer-file nil))
4217 (batch-native-compile) 4217 (batch-native-compile)
4218 (pcase byte-to-native-output-file 4218 (pcase byte-to-native-output-buffer-file
4219 (`(,tempfile . ,target-file) 4219 (`(,temp-buffer . ,target-file)
4220 (rename-file tempfile target-file t))) 4220 (unwind-protect
4221 (byte-write-target-file temp-buffer target-file))
4222 (kill-buffer temp-buffer)))
4221 (setq command-line-args-left (cdr command-line-args-left))))) 4223 (setq command-line-args-left (cdr command-line-args-left)))))
4222 4224
4223;;;###autoload 4225;;;###autoload
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index fe97804ec4a..1720393b3e5 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -98,7 +98,11 @@ This applies to `eval-defun', `eval-region', `eval-buffer', and
98You can use the command `edebug-all-defs' to toggle the value of this 98You can use the command `edebug-all-defs' to toggle the value of this
99variable. You may wish to make it local to each buffer with 99variable. You may wish to make it local to each buffer with
100\(make-local-variable \\='edebug-all-defs) in your 100\(make-local-variable \\='edebug-all-defs) in your
101`emacs-lisp-mode-hook'." 101`emacs-lisp-mode-hook'.
102
103Note that this user option has no effect unless the edebug
104package has been loaded."
105 :require 'edebug
102 :type 'boolean) 106 :type 'boolean)
103 107
104;;;###autoload 108;;;###autoload
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 9c6b0e15bbe..b6c5b7d6b91 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -1423,7 +1423,8 @@ Returns the stats object."
1423 (message "%9s %S%s" 1423 (message "%9s %S%s"
1424 (ert-string-for-test-result result nil) 1424 (ert-string-for-test-result result nil)
1425 (ert-test-name test) 1425 (ert-test-name test)
1426 (if (getenv "EMACS_TEST_VERBOSE") 1426 (if (cl-plusp
1427 (length (getenv "EMACS_TEST_VERBOSE")))
1427 (ert-reason-for-test-result result) 1428 (ert-reason-for-test-result result)
1428 "")))) 1429 ""))))
1429 (message "%s" "")) 1430 (message "%s" ""))
@@ -1435,7 +1436,8 @@ Returns the stats object."
1435 (message "%9s %S%s" 1436 (message "%9s %S%s"
1436 (ert-string-for-test-result result nil) 1437 (ert-string-for-test-result result nil)
1437 (ert-test-name test) 1438 (ert-test-name test)
1438 (if (getenv "EMACS_TEST_VERBOSE") 1439 (if (cl-plusp
1440 (length (getenv "EMACS_TEST_VERBOSE")))
1439 (ert-reason-for-test-result result) 1441 (ert-reason-for-test-result result)
1440 "")))) 1442 ""))))
1441 (message "%s" "")) 1443 (message "%s" ""))
diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el
index e6a2424c518..4a293796a83 100644
--- a/lisp/emacs-lisp/multisession.el
+++ b/lisp/emacs-lisp/multisession.el
@@ -434,10 +434,16 @@ storage method to list."
434 multisession-edit-mode) 434 multisession-edit-mode)
435 (unless id 435 (unless id
436 (error "No value on the current line")) 436 (error "No value on the current line"))
437 (let* ((object (make-multisession 437 (let* ((object (or
438 :package (car id) 438 ;; If the multisession variable already exists, use
439 :key (cdr id) 439 ;; it (so that we update it).
440 :storage multisession-storage)) 440 (and (boundp (intern-soft (cdr id)))
441 (symbol-value (intern (cdr id))))
442 ;; Create a new object.
443 (make-multisession
444 :package (car id)
445 :key (cdr id)
446 :storage multisession-storage)))
441 (value (multisession-value object))) 447 (value (multisession-value object)))
442 (setf (multisession-value object) 448 (setf (multisession-value object)
443 (car (read-from-string 449 (car (read-from-string
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index d199716b2c5..e782cdb1dab 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -273,7 +273,10 @@ Use the `pp-max-width' variable to control the desired line length."
273 (insert "(") 273 (insert "(")
274 (pp--insert start (pop sexp)) 274 (pp--insert start (pop sexp))
275 (while sexp 275 (while sexp
276 (pp--insert " " (pop sexp))) 276 (if (consp sexp)
277 (pp--insert " " (pop sexp))
278 (pp--insert " . " sexp)
279 (setq sexp nil)))
277 (insert ")"))) 280 (insert ")")))
278 281
279(defun pp--format-function (sexp) 282(defun pp--format-function (sexp)
diff --git a/lisp/emacs-lisp/range.el b/lisp/emacs-lisp/range.el
new file mode 100644
index 00000000000..38c2866cd4c
--- /dev/null
+++ b/lisp/emacs-lisp/range.el
@@ -0,0 +1,467 @@
1;;; ranges.el --- range functions -*- lexical-binding: t; -*-
2
3;; Copyright (C) 1996-2022 Free Software Foundation, Inc.
4
5;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
21
22;;; Commentary:
23
24;; A "range" is a list that represents a list of integers. A range is
25;; a list containing cons cells of start/end pairs, as well as integers.
26;;
27;; ((2 . 5) 9 (11 . 13))
28;;
29;; represents the list (2 3 4 5 9 11 12 13).
30
31;;; Code:
32
33(defun range-normalize (range)
34 "Normalize RANGE.
35If RANGE is a single range, return (RANGE). Otherwise, return RANGE."
36 (if (listp (cdr-safe range))
37 range
38 (list range)))
39
40(defun range-denormalize (range)
41 "If RANGE contains a single range, then return that.
42If not, return RANGE as is."
43 (if (and (consp (car range))
44 (length= range 1))
45 (car range)
46 range))
47
48(defun range-difference (range1 range2)
49 "Return the range of elements in RANGE1 that do not appear in RANGE2.
50Both ranges must be in ascending order."
51 (setq range1 (range-normalize range1))
52 (setq range2 (range-normalize range2))
53 (let* ((new-range (cons nil (copy-sequence range1)))
54 (r new-range))
55 (while (cdr r)
56 (let* ((r1 (cadr r))
57 (r2 (car range2))
58 (min1 (if (numberp r1) r1 (car r1)))
59 (max1 (if (numberp r1) r1 (cdr r1)))
60 (min2 (if (numberp r2) r2 (car r2)))
61 (max2 (if (numberp r2) r2 (cdr r2))))
62
63 (cond ((> min1 max1)
64 ;; Invalid range: may result from overlap condition (below)
65 ;; remove Invalid range
66 (setcdr r (cddr r)))
67 ((and (= min1 max1)
68 (listp r1))
69 ;; Inefficient representation: may result from overlap
70 ;; condition (below)
71 (setcar (cdr r) min1))
72 ((not min2)
73 ;; All done with range2
74 (setq r nil))
75 ((< max1 min2)
76 ;; No overlap: range1 precedes range2
77 (pop r))
78 ((< max2 min1)
79 ;; No overlap: range2 precedes range1
80 (pop range2))
81 ((and (<= min2 min1) (<= max1 max2))
82 ;; Complete overlap: range1 removed
83 (setcdr r (cddr r)))
84 (t
85 (setcdr r (nconc (list (cons min1 (1- min2))
86 (cons (1+ max2) max1))
87 (cddr r)))))))
88 (cdr new-range)))
89
90(defun range-intersection (range1 range2)
91 "Return intersection of RANGE1 and RANGE2."
92 (let* (out
93 (min1 (car range1))
94 (max1 (if (numberp min1)
95 (if (numberp (cdr range1))
96 (prog1 (cdr range1)
97 (setq range1 nil)) min1)
98 (prog1 (cdr min1)
99 (setq min1 (car min1)))))
100 (min2 (car range2))
101 (max2 (if (numberp min2)
102 (if (numberp (cdr range2))
103 (prog1 (cdr range2)
104 (setq range2 nil)) min2)
105 (prog1 (cdr min2)
106 (setq min2 (car min2))))))
107 (setq range1 (cdr range1)
108 range2 (cdr range2))
109 (while (and min1 min2)
110 (cond ((< max1 min2) ; range1 precedes range2
111 (setq range1 (cdr range1)
112 min1 nil))
113 ((< max2 min1) ; range2 precedes range1
114 (setq range2 (cdr range2)
115 min2 nil))
116 (t ; some sort of overlap is occurring
117 (let ((min (max min1 min2))
118 (max (min max1 max2)))
119 (setq out (if (= min max)
120 (cons min out)
121 (cons (cons min max) out))))
122 (if (< max1 max2) ; range1 ends before range2
123 (setq min1 nil) ; incr range1
124 (setq min2 nil)))) ; incr range2
125 (unless min1
126 (setq min1 (car range1)
127 max1 (if (numberp min1) min1
128 (prog1 (cdr min1) (setq min1 (car min1))))
129 range1 (cdr range1)))
130 (unless min2
131 (setq min2 (car range2)
132 max2 (if (numberp min2) min2
133 (prog1 (cdr min2) (setq min2 (car min2))))
134 range2 (cdr range2))))
135 (cond ((cdr out)
136 (nreverse out))
137 ((numberp (car out))
138 out)
139 (t
140 (car out)))))
141
142(defun range-compress-list (numbers)
143 "Convert a sorted list of numbers to a range list."
144 (let ((first (car numbers))
145 (last (car numbers))
146 result)
147 (cond
148 ((null numbers)
149 nil)
150 ((not (listp (cdr numbers)))
151 numbers)
152 (t
153 (while numbers
154 (cond ((= last (car numbers)) nil) ;Omit duplicated number
155 ((= (1+ last) (car numbers)) ;Still in sequence
156 (setq last (car numbers)))
157 (t ;End of one sequence
158 (setq result
159 (cons (if (= first last) first
160 (cons first last))
161 result))
162 (setq first (car numbers))
163 (setq last (car numbers))))
164 (setq numbers (cdr numbers)))
165 (nreverse (cons (if (= first last) first (cons first last))
166 result))))))
167
168(defun range-uncompress (ranges)
169 "Expand a list of ranges into a list of numbers.
170RANGES is either a single range on the form `(num . num)' or a list of
171these ranges."
172 (let (first last result)
173 (cond
174 ((null ranges)
175 nil)
176 ((not (listp (cdr ranges)))
177 (setq first (car ranges))
178 (setq last (cdr ranges))
179 (while (<= first last)
180 (setq result (cons first result))
181 (setq first (1+ first)))
182 (nreverse result))
183 (t
184 (while ranges
185 (if (atom (car ranges))
186 (when (numberp (car ranges))
187 (setq result (cons (car ranges) result)))
188 (setq first (caar ranges))
189 (setq last (cdar ranges))
190 (while (<= first last)
191 (setq result (cons first result))
192 (setq first (1+ first))))
193 (setq ranges (cdr ranges)))
194 (nreverse result)))))
195
196(defun range-add-list (ranges list)
197 "Return a list of ranges that has all articles from both RANGES and LIST.
198Note: LIST has to be sorted over `<'."
199 (if (not ranges)
200 (range-compress-list list)
201 (setq list (copy-sequence list))
202 (unless (listp (cdr ranges))
203 (setq ranges (list ranges)))
204 (let ((out ranges)
205 ilist lowest highest temp)
206 (while (and ranges list)
207 (setq ilist list)
208 (setq lowest (or (and (atom (car ranges)) (car ranges))
209 (caar ranges)))
210 (while (and list (cdr list) (< (cadr list) lowest))
211 (setq list (cdr list)))
212 (when (< (car ilist) lowest)
213 (setq temp list)
214 (setq list (cdr list))
215 (setcdr temp nil)
216 (setq out (nconc (range-compress-list ilist) out)))
217 (setq highest (or (and (atom (car ranges)) (car ranges))
218 (cdar ranges)))
219 (while (and list (<= (car list) highest))
220 (setq list (cdr list)))
221 (setq ranges (cdr ranges)))
222 (when list
223 (setq out (nconc (range-compress-list list) out)))
224 (setq out (sort out (lambda (r1 r2)
225 (< (or (and (atom r1) r1) (car r1))
226 (or (and (atom r2) r2) (car r2))))))
227 (setq ranges out)
228 (while ranges
229 (if (atom (car ranges))
230 (when (cdr ranges)
231 (if (atom (cadr ranges))
232 (when (= (1+ (car ranges)) (cadr ranges))
233 (setcar ranges (cons (car ranges)
234 (cadr ranges)))
235 (setcdr ranges (cddr ranges)))
236 (when (= (1+ (car ranges)) (caadr ranges))
237 (setcar (cadr ranges) (car ranges))
238 (setcar ranges (cadr ranges))
239 (setcdr ranges (cddr ranges)))))
240 (when (cdr ranges)
241 (if (atom (cadr ranges))
242 (when (= (1+ (cdar ranges)) (cadr ranges))
243 (setcdr (car ranges) (cadr ranges))
244 (setcdr ranges (cddr ranges)))
245 (when (= (1+ (cdar ranges)) (caadr ranges))
246 (setcdr (car ranges) (cdadr ranges))
247 (setcdr ranges (cddr ranges))))))
248 (setq ranges (cdr ranges)))
249 out)))
250
251(defun range-remove (range1 range2)
252 "Return a range that has all articles from RANGE2 removed from RANGE1.
253The returned range is always a list. RANGE2 can also be a unsorted
254list of articles. RANGE1 is modified by side effects, RANGE2 is not
255modified."
256 (if (or (null range1) (null range2))
257 range1
258 (let (out r1 r2 r1-min r1-max r2-min r2-max
259 (range2 (copy-tree range2)))
260 (setq range1 (if (listp (cdr range1)) range1 (list range1))
261 range2 (sort (if (listp (cdr range2)) range2 (list range2))
262 (lambda (e1 e2)
263 (< (if (consp e1) (car e1) e1)
264 (if (consp e2) (car e2) e2))))
265 r1 (car range1)
266 r2 (car range2)
267 r1-min (if (consp r1) (car r1) r1)
268 r1-max (if (consp r1) (cdr r1) r1)
269 r2-min (if (consp r2) (car r2) r2)
270 r2-max (if (consp r2) (cdr r2) r2))
271 (while (and range1 range2)
272 (cond ((< r2-max r1-min) ; r2 < r1
273 (pop range2)
274 (setq r2 (car range2)
275 r2-min (if (consp r2) (car r2) r2)
276 r2-max (if (consp r2) (cdr r2) r2)))
277 ((and (<= r2-min r1-min) (<= r1-max r2-max)) ; r2 overlap r1
278 (pop range1)
279 (setq r1 (car range1)
280 r1-min (if (consp r1) (car r1) r1)
281 r1-max (if (consp r1) (cdr r1) r1)))
282 ((and (<= r2-min r1-min) (<= r2-max r1-max)) ; r2 overlap min r1
283 (pop range2)
284 (setq r1-min (1+ r2-max)
285 r2 (car range2)
286 r2-min (if (consp r2) (car r2) r2)
287 r2-max (if (consp r2) (cdr r2) r2)))
288 ((and (<= r1-min r2-min) (<= r2-max r1-max)) ; r2 contained in r1
289 (if (eq r1-min (1- r2-min))
290 (push r1-min out)
291 (push (cons r1-min (1- r2-min)) out))
292 (pop range2)
293 (if (< r2-max r1-max) ; finished with r1?
294 (setq r1-min (1+ r2-max))
295 (pop range1)
296 (setq r1 (car range1)
297 r1-min (if (consp r1) (car r1) r1)
298 r1-max (if (consp r1) (cdr r1) r1)))
299 (setq r2 (car range2)
300 r2-min (if (consp r2) (car r2) r2)
301 r2-max (if (consp r2) (cdr r2) r2)))
302 ((and (<= r2-min r1-max) (<= r1-max r2-max)) ; r2 overlap max r1
303 (if (eq r1-min (1- r2-min))
304 (push r1-min out)
305 (push (cons r1-min (1- r2-min)) out))
306 (pop range1)
307 (setq r1 (car range1)
308 r1-min (if (consp r1) (car r1) r1)
309 r1-max (if (consp r1) (cdr r1) r1)))
310 ((< r1-max r2-min) ; r2 > r1
311 (pop range1)
312 (if (eq r1-min r1-max)
313 (push r1-min out)
314 (push (cons r1-min r1-max) out))
315 (setq r1 (car range1)
316 r1-min (if (consp r1) (car r1) r1)
317 r1-max (if (consp r1) (cdr r1) r1)))))
318 (when r1
319 (if (eq r1-min r1-max)
320 (push r1-min out)
321 (push (cons r1-min r1-max) out))
322 (pop range1))
323 (while range1
324 (push (pop range1) out))
325 (nreverse out))))
326
327(defun range-member-p (number ranges)
328 "Say whether NUMBER is in RANGES."
329 (if (not (listp (cdr ranges)))
330 (and (>= number (car ranges))
331 (<= number (cdr ranges)))
332 (let ((not-stop t))
333 (while (and ranges
334 (if (numberp (car ranges))
335 (>= number (car ranges))
336 (>= number (caar ranges)))
337 not-stop)
338 (when (if (numberp (car ranges))
339 (= number (car ranges))
340 (and (>= number (caar ranges))
341 (<= number (cdar ranges))))
342 (setq not-stop nil))
343 (setq ranges (cdr ranges)))
344 (not not-stop))))
345
346(defun range-list-intersection (list ranges)
347 "Return a list of numbers in LIST that are members of RANGES.
348oLIST is a sorted list."
349 (setq ranges (range-normalize ranges))
350 (let (number result)
351 (while (setq number (pop list))
352 (while (and ranges
353 (if (numberp (car ranges))
354 (< (car ranges) number)
355 (< (cdar ranges) number)))
356 (setq ranges (cdr ranges)))
357 (when (and ranges
358 (if (numberp (car ranges))
359 (= (car ranges) number)
360 ;; (caar ranges) <= number <= (cdar ranges)
361 (>= number (caar ranges))))
362 (push number result)))
363 (nreverse result)))
364
365(defun range-list-difference (list ranges)
366 "Return a list of numbers in LIST that are not members of RANGES.
367LIST is a sorted list."
368 (setq ranges (range-normalize ranges))
369 (let (number result)
370 (while (setq number (pop list))
371 (while (and ranges
372 (if (numberp (car ranges))
373 (< (car ranges) number)
374 (< (cdar ranges) number)))
375 (setq ranges (cdr ranges)))
376 (when (or (not ranges)
377 (if (numberp (car ranges))
378 (not (= (car ranges) number))
379 ;; not ((caar ranges) <= number <= (cdar ranges))
380 (< number (caar ranges))))
381 (push number result)))
382 (nreverse result)))
383
384(defun range-length (range)
385 "Return the length RANGE would have if uncompressed."
386 (cond
387 ((null range)
388 0)
389 ((not (listp (cdr range)))
390 (- (cdr range) (car range) -1))
391 (t
392 (let ((sum 0))
393 (dolist (x range sum)
394 (setq sum
395 (+ sum (if (consp x) (- (cdr x) (car x) -1) 1))))))))
396
397(defun range-concat (range1 range2)
398 "Add RANGE2 to RANGE1 (nondestructively)."
399 (unless (listp (cdr range1))
400 (setq range1 (list range1)))
401 (unless (listp (cdr range2))
402 (setq range2 (list range2)))
403 (let ((item1 (pop range1))
404 (item2 (pop range2))
405 range item selector)
406 (while (or item1 item2)
407 (setq selector
408 (cond
409 ((null item1) nil)
410 ((null item2) t)
411 ((and (numberp item1) (numberp item2)) (< item1 item2))
412 ((numberp item1) (< item1 (car item2)))
413 ((numberp item2) (< (car item1) item2))
414 (t (< (car item1) (car item2)))))
415 (setq item
416 (or
417 (let ((tmp1 item) (tmp2 (if selector item1 item2)))
418 (cond
419 ((null tmp1) tmp2)
420 ((null tmp2) tmp1)
421 ((and (numberp tmp1) (numberp tmp2))
422 (cond
423 ((eq tmp1 tmp2) tmp1)
424 ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2))
425 ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1))
426 (t nil)))
427 ((numberp tmp1)
428 (cond
429 ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2)
430 ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2)))
431 ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1))
432 (t nil)))
433 ((numberp tmp2)
434 (cond
435 ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1)
436 ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1)))
437 ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2))
438 (t nil)))
439 ((< (1+ (cdr tmp1)) (car tmp2)) nil)
440 ((< (1+ (cdr tmp2)) (car tmp1)) nil)
441 (t (cons (min (car tmp1) (car tmp2))
442 (max (cdr tmp1) (cdr tmp2))))))
443 (progn
444 (if item (push item range))
445 (if selector item1 item2))))
446 (if selector
447 (setq item1 (pop range1))
448 (setq item2 (pop range2))))
449 (if item (push item range))
450 (reverse range)))
451
452(defun range-map (func range)
453 "Apply FUNC to each value contained by RANGE."
454 (setq range (range-normalize range))
455 (while range
456 (let ((span (pop range)))
457 (if (numberp span)
458 (funcall func span)
459 (let ((first (car span))
460 (last (cdr span)))
461 (while (<= first last)
462 (funcall func first)
463 (setq first (1+ first))))))))
464
465(provide 'range)
466
467;;; range.el ends here
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index 4a9814b5daf..32a046e0fbd 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -731,6 +731,7 @@ Interactively, N is the prefix numeric argument, and defaults to
7311." 7311."
732 (interactive "p") 732 (interactive "p")
733 (let ((start (current-column)) 733 (let ((start (current-column))
734 (entry (tabulated-list-get-entry))
734 (nb-cols (length tabulated-list-format)) 735 (nb-cols (length tabulated-list-format))
735 (col-nb 0) 736 (col-nb 0)
736 (total-width 0) 737 (total-width 0)
@@ -741,9 +742,14 @@ Interactively, N is the prefix numeric argument, and defaults to
741 (if (> start 742 (if (> start
742 (setq total-width 743 (setq total-width
743 (+ total-width 744 (+ total-width
744 (setq col-width 745 (max (setq col-width
745 (cadr (aref tabulated-list-format 746 (cadr (aref tabulated-list-format
746 col-nb)))))) 747 col-nb)))
748 (string-width (aref entry col-nb)))
749 (or (plist-get (nthcdr 3 (aref tabulated-list-format
750 col-nb))
751 :pad-right)
752 1))))
747 (setq col-nb (1+ col-nb)) 753 (setq col-nb (1+ col-nb))
748 (setq found t) 754 (setq found t)
749 (setf (cadr (aref tabulated-list-format col-nb)) 755 (setf (cadr (aref tabulated-list-format col-nb))
diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el
index 27b343ad398..ba868cee59e 100644
--- a/lisp/eshell/em-basic.el
+++ b/lisp/eshell/em-basic.el
@@ -82,7 +82,11 @@ equivalent of `echo' can always be achieved by using `identity'."
82It returns a formatted value that should be passed to `eshell-print' 82It returns a formatted value that should be passed to `eshell-print'
83or `eshell-printn' for display." 83or `eshell-printn' for display."
84 (if eshell-plain-echo-behavior 84 (if eshell-plain-echo-behavior
85 (concat (apply 'eshell-flatten-and-stringify args) "\n") 85 (progn
86 ;; If the output does not end in a newline, do not emit one.
87 (setq eshell-ensure-newline-p nil)
88 (concat (apply #'eshell-flatten-and-stringify args)
89 (when output-newline "\n")))
86 (let ((value 90 (let ((value
87 (cond 91 (cond
88 ((= (length args) 0) "") 92 ((= (length args) 0) "")
@@ -109,18 +113,33 @@ or `eshell-printn' for display."
109 "Implementation of `echo'. See `eshell-plain-echo-behavior'." 113 "Implementation of `echo'. See `eshell-plain-echo-behavior'."
110 (eshell-eval-using-options 114 (eshell-eval-using-options
111 "echo" args 115 "echo" args
112 '((?n nil nil output-newline "terminate with a newline") 116 '((?n nil (nil) output-newline
113 (?h "help" nil nil "output this help screen") 117 "do not output the trailing newline")
118 (?N nil (t) output-newline
119 "terminate with a newline")
120 (?E nil nil _disable-escapes
121 "don't interpret backslash escapes (default)")
122 (?h "help" nil nil
123 "output this help screen")
114 :preserve-args 124 :preserve-args
115 :usage "[-n] [object]") 125 :usage "[OPTION]... [OBJECT]...")
116 (eshell-echo args output-newline))) 126 (if eshell-plain-echo-behavior
127 (eshell-echo args (if output-newline (car output-newline) t))
128 ;; In Emacs 28.1 and earlier, "-n" was used to add a newline to
129 ;; non-plain echo in Eshell. This caused confusion due to "-n"
130 ;; generally having the opposite meaning for echo. Retain this
131 ;; compatibility for the time being. For more info, see
132 ;; bug#27361.
133 (when (equal output-newline '(nil))
134 (display-warning
135 :warning "To terminate with a newline, you should use -N instead."))
136 (eshell-echo args output-newline))))
117 137
118(defun eshell/printnl (&rest args) 138(defun eshell/printnl (&rest args)
119 "Print out each of the arguments, separated by newlines." 139 "Print out each of the arguments as strings, separated by newlines."
120 (let ((elems (flatten-tree args))) 140 (let ((elems (flatten-tree args)))
121 (while elems 141 (dolist (elem elems)
122 (eshell-printn (eshell-echo (list (car elems)))) 142 (eshell-printn (eshell-stringify elem)))))
123 (setq elems (cdr elems)))))
124 143
125(defun eshell/listify (&rest args) 144(defun eshell/listify (&rest args)
126 "Return the argument(s) as a single list." 145 "Return the argument(s) as a single list."
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index e8459513f39..e0bcd8b099f 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -113,27 +113,13 @@ Comments begin with `#'."
113 113
114(defun eshell/source (&rest args) 114(defun eshell/source (&rest args)
115 "Source a file in a subshell environment." 115 "Source a file in a subshell environment."
116 (eshell-eval-using-options 116 (eshell-source-file (car args) (cdr args) t))
117 "source" args
118 '((?h "help" nil nil "show this usage screen")
119 :show-usage
120 :usage "FILE [ARGS]
121Invoke the Eshell commands in FILE in a subshell, binding ARGS to $1,
122$2, etc.")
123 (eshell-source-file (car args) (cdr args) t)))
124 117
125(put 'eshell/source 'eshell-no-numeric-conversions t) 118(put 'eshell/source 'eshell-no-numeric-conversions t)
126 119
127(defun eshell/. (&rest args) 120(defun eshell/. (&rest args)
128 "Source a file in the current environment." 121 "Source a file in the current environment."
129 (eshell-eval-using-options 122 (eshell-source-file (car args) (cdr args)))
130 "." args
131 '((?h "help" nil nil "show this usage screen")
132 :show-usage
133 :usage "FILE [ARGS]
134Invoke the Eshell commands in FILE within the current shell
135environment, binding ARGS to $1, $2, etc.")
136 (eshell-source-file (car args) (cdr args))))
137 123
138(put 'eshell/. 'eshell-no-numeric-conversions t) 124(put 'eshell/. 'eshell-no-numeric-conversions t)
139 125
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index a2d7d9431a9..04d65df4f33 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -107,6 +107,7 @@
107(require 'esh-module) 107(require 'esh-module)
108(require 'esh-io) 108(require 'esh-io)
109(require 'esh-ext) 109(require 'esh-ext)
110(require 'generator)
110 111
111(eval-when-compile 112(eval-when-compile
112 (require 'cl-lib) 113 (require 'cl-lib)
@@ -903,21 +904,55 @@ at the moment are:
903 "Completion for the `debug' command." 904 "Completion for the `debug' command."
904 (while (pcomplete-here '("errors" "commands")))) 905 (while (pcomplete-here '("errors" "commands"))))
905 906
907(iter-defun eshell--find-subcommands (haystack)
908 "Recursively search for subcommand forms in HAYSTACK.
909This yields the SUBCOMMANDs when found in forms like
910\"(eshell-as-subcommand SUBCOMMAND)\"."
911 (dolist (elem haystack)
912 (cond
913 ((eq (car-safe elem) 'eshell-as-subcommand)
914 (iter-yield (cdr elem)))
915 ((listp elem)
916 (iter-yield-from (eshell--find-subcommands elem))))))
917
918(defun eshell--invoke-command-directly (command)
919 "Determine whether the given COMMAND can be invoked directly.
920COMMAND should be a non-top-level Eshell command in parsed form.
921
922A command can be invoked directly if all of the following are true:
923
924* The command is of the form
925 \"(eshell-trap-errors (eshell-named-command NAME ARGS))\",
926 where ARGS is optional.
927
928* NAME is a string referring to an alias function and isn't a
929 complex command (see `eshell-complex-commands').
930
931* Any subcommands in ARGS can also be invoked directly."
932 (when (and (eq (car command) 'eshell-trap-errors)
933 (eq (car (cadr command)) 'eshell-named-command))
934 (let ((name (cadr (cadr command)))
935 (args (cdr-safe (nth 2 (cadr command)))))
936 (and name (stringp name)
937 (not (member name eshell-complex-commands))
938 (catch 'simple
939 (dolist (pred eshell-complex-commands t)
940 (when (and (functionp pred)
941 (funcall pred name))
942 (throw 'simple nil))))
943 (eshell-find-alias-function name)
944 (catch 'indirect-subcommand
945 (iter-do (subcommand (eshell--find-subcommands args))
946 (unless (eshell--invoke-command-directly subcommand)
947 (throw 'indirect-subcommand nil)))
948 t)))))
949
906(defun eshell-invoke-directly (command) 950(defun eshell-invoke-directly (command)
907 (let ((base (cadr (nth 2 (nth 2 (cadr command))))) name) 951 "Determine whether the given COMMAND can be invoked directly.
908 (if (and (eq (car base) 'eshell-trap-errors) 952COMMAND should be a top-level Eshell command in parsed form, as
909 (eq (car (cadr base)) 'eshell-named-command)) 953produced by `eshell-parse-command'."
910 (setq name (cadr (cadr base)))) 954 (let ((base (cadr (nth 2 (nth 2 (cadr command))))))
911 (and name (stringp name) 955 (eshell--invoke-command-directly base)))
912 (not (member name eshell-complex-commands))
913 (catch 'simple
914 (progn
915 (dolist (pred eshell-complex-commands)
916 (if (and (functionp pred)
917 (funcall pred name))
918 (throw 'simple nil)))
919 t))
920 (eshell-find-alias-function name))))
921 956
922(defun eshell-eval-command (command &optional input) 957(defun eshell-eval-command (command &optional input)
923 "Evaluate the given COMMAND iteratively." 958 "Evaluate the given COMMAND iteratively."
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index bba1c4ad25d..c802bee3af5 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -257,12 +257,12 @@ triggered to say that the switch is unrecognized."
257 remaining 257 remaining
258 (let ((extcmd (memq ':external options))) 258 (let ((extcmd (memq ':external options)))
259 (when extcmd 259 (when extcmd
260 (setq extcmd (eshell-search-path (cadr extcmd))) 260 (setq extcmd (eshell-search-path (cadr extcmd))))
261 (if extcmd 261 (if extcmd
262 (throw 'eshell-ext-command extcmd) 262 (throw 'eshell-ext-command extcmd)
263 (error (if (characterp (car switch)) "%s: unrecognized option -%c" 263 (error (if (characterp (car switch)) "%s: unrecognized option -%c"
264 "%s: unrecognized option --%s") 264 "%s: unrecognized option --%s")
265 name (car switch)))))))) 265 name (car switch)))))))
266 266
267(defun eshell--process-args (name args options) 267(defun eshell--process-args (name args options)
268 "Process the given ARGS using OPTIONS." 268 "Process the given ARGS using OPTIONS."
diff --git a/lisp/face-remap.el b/lisp/face-remap.el
index 00560f9d2e1..3675ea14b4c 100644
--- a/lisp/face-remap.el
+++ b/lisp/face-remap.el
@@ -70,6 +70,13 @@
70 :foreground :background :stipple :overline :strike-through :box 70 :foreground :background :stipple :overline :strike-through :box
71 :font :inherit :fontset :distant-foreground :extend :vector]) 71 :font :inherit :fontset :distant-foreground :extend :vector])
72 72
73(defun face-attrs--make-indirect-safe ()
74 "Deep-copy the buffer's `face-remapping-alist' upon cloning the buffer."
75 (setq-local face-remapping-alist
76 (mapcar #'copy-sequence face-remapping-alist)))
77
78(add-hook 'clone-indirect-buffer-hook #'face-attrs--make-indirect-safe)
79
73(defun face-attrs-more-relative-p (attrs1 attrs2) 80(defun face-attrs-more-relative-p (attrs1 attrs2)
74 "Return true if ATTRS1 contains a greater number of relative 81 "Return true if ATTRS1 contains a greater number of relative
75face-attributes than ATTRS2. A face attribute is considered 82face-attributes than ATTRS2. A face attribute is considered
diff --git a/lisp/faces.el b/lisp/faces.el
index df099787698..bb9b1e979fa 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1107,6 +1107,16 @@ returned. Otherwise, DEFAULT is returned verbatim."
1107 (let ((prompt (if default 1107 (let ((prompt (if default
1108 (format-prompt prompt default) 1108 (format-prompt prompt default)
1109 (format "%s: " prompt))) 1109 (format "%s: " prompt)))
1110 (completion-extra-properties
1111 '(:affixation-function
1112 (lambda (faces)
1113 (mapcar
1114 (lambda (face)
1115 (list (concat (propertize "SAMPLE" 'face face)
1116 "\t")
1117 ""
1118 face))
1119 faces))))
1110 aliasfaces nonaliasfaces faces) 1120 aliasfaces nonaliasfaces faces)
1111 ;; Build up the completion tables. 1121 ;; Build up the completion tables.
1112 (mapatoms (lambda (s) 1122 (mapatoms (lambda (s)
diff --git a/lisp/files.el b/lisp/files.el
index 1d9d450e4d3..51c6968cffd 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -3968,12 +3968,12 @@ major-mode."
3968 ;; Discard the prefix. 3968 ;; Discard the prefix.
3969 (if (looking-at prefix) 3969 (if (looking-at prefix)
3970 (delete-region (point) (match-end 0)) 3970 (delete-region (point) (match-end 0))
3971 (error "Local variables entry is missing the prefix")) 3971 (user-error "Local variables entry is missing the prefix"))
3972 (end-of-line) 3972 (end-of-line)
3973 ;; Discard the suffix. 3973 ;; Discard the suffix.
3974 (if (looking-back suffix (line-beginning-position)) 3974 (if (looking-back suffix (line-beginning-position))
3975 (delete-region (match-beginning 0) (point)) 3975 (delete-region (match-beginning 0) (point))
3976 (error "Local variables entry is missing the suffix")) 3976 (user-error "Local variables entry is missing the suffix"))
3977 (forward-line 1)) 3977 (forward-line 1))
3978 (goto-char (point-min)) 3978 (goto-char (point-min))
3979 3979
@@ -3981,9 +3981,9 @@ major-mode."
3981 (and (eq handle-mode t) result))) 3981 (and (eq handle-mode t) result)))
3982 ;; Find the variable name; 3982 ;; Find the variable name;
3983 (unless (looking-at hack-local-variable-regexp) 3983 (unless (looking-at hack-local-variable-regexp)
3984 (error "Malformed local variable line: %S" 3984 (user-error "Malformed local variable line: %S"
3985 (buffer-substring-no-properties 3985 (buffer-substring-no-properties
3986 (point) (line-end-position)))) 3986 (point) (line-end-position))))
3987 (goto-char (match-end 1)) 3987 (goto-char (match-end 1))
3988 (let* ((str (match-string 1)) 3988 (let* ((str (match-string 1))
3989 (var (intern str)) 3989 (var (intern str))
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index fd66135b5c6..e4704b35c8d 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -31,6 +31,7 @@
31(require 'gnus-srvr) 31(require 'gnus-srvr)
32(require 'gnus-util) 32(require 'gnus-util)
33(require 'timer) 33(require 'timer)
34(require 'range)
34(eval-when-compile (require 'cl-lib)) 35(eval-when-compile (require 'cl-lib))
35 36
36(autoload 'gnus-server-update-server "gnus-srvr") 37(autoload 'gnus-server-update-server "gnus-srvr")
@@ -1219,8 +1220,8 @@ This can be added to `gnus-select-article-hook' or
1219 (cond ((eq mark 'read) 1220 (cond ((eq mark 'read)
1220 (setf (gnus-info-read info) 1221 (setf (gnus-info-read info)
1221 (funcall (if (eq what 'add) 1222 (funcall (if (eq what 'add)
1222 #'gnus-range-add 1223 #'range-concat
1223 #'gnus-remove-from-range) 1224 #'range-remove)
1224 (gnus-info-read info) 1225 (gnus-info-read info)
1225 range)) 1226 range))
1226 (gnus-get-unread-articles-in-group 1227 (gnus-get-unread-articles-in-group
@@ -1233,8 +1234,8 @@ This can be added to `gnus-select-article-hook' or
1233 (gnus-info-marks info))) 1234 (gnus-info-marks info)))
1234 (setcdr info-marks 1235 (setcdr info-marks
1235 (funcall (if (eq what 'add) 1236 (funcall (if (eq what 'add)
1236 #'gnus-range-add 1237 #'range-concat
1237 #'gnus-remove-from-range) 1238 #'range-remove)
1238 (cdr info-marks) 1239 (cdr info-marks)
1239 range)))))))) 1240 range))))))))
1240 1241
@@ -1307,7 +1308,7 @@ downloaded into the agent."
1307 1308
1308 (let ((read (gnus-info-read info))) 1309 (let ((read (gnus-info-read info)))
1309 (setf (gnus-info-read info) 1310 (setf (gnus-info-read info)
1310 (gnus-range-add 1311 (range-concat
1311 read 1312 read
1312 (list (cons (1+ agent-max) 1313 (list (cons (1+ agent-max)
1313 (1- active-min)))))) 1314 (1- active-min))))))
@@ -1796,13 +1797,13 @@ article numbers will be returned."
1796 (articles (if fetch-all 1797 (articles (if fetch-all
1797 (if gnus-newsgroup-maximum-articles 1798 (if gnus-newsgroup-maximum-articles
1798 (let ((active (gnus-active group))) 1799 (let ((active (gnus-active group)))
1799 (gnus-uncompress-range 1800 (range-uncompress
1800 (cons (max (car active) 1801 (cons (max (car active)
1801 (- (cdr active) 1802 (- (cdr active)
1802 gnus-newsgroup-maximum-articles 1803 gnus-newsgroup-maximum-articles
1803 -1)) 1804 -1))
1804 (cdr active)))) 1805 (cdr active))))
1805 (gnus-uncompress-range (gnus-active group))) 1806 (range-uncompress (gnus-active group)))
1806 (gnus-list-of-unread-articles group))) 1807 (gnus-list-of-unread-articles group)))
1807 (gnus-decode-encoded-word-function 'identity) 1808 (gnus-decode-encoded-word-function 'identity)
1808 (gnus-decode-encoded-address-function 'identity) 1809 (gnus-decode-encoded-address-function 'identity)
@@ -1817,7 +1818,7 @@ article numbers will be returned."
1817 ;; because otherwise the agent will remove their marks.) 1818 ;; because otherwise the agent will remove their marks.)
1818 (dolist (arts (gnus-info-marks (gnus-get-info group))) 1819 (dolist (arts (gnus-info-marks (gnus-get-info group)))
1819 (unless (memq (car arts) '(seen recent killed cache)) 1820 (unless (memq (car arts) '(seen recent killed cache))
1820 (setq articles (gnus-range-add articles (cdr arts))))) 1821 (setq articles (range-concat articles (cdr arts)))))
1821 (setq articles (sort (gnus-uncompress-sequence articles) #'<))) 1822 (setq articles (sort (gnus-uncompress-sequence articles) #'<)))
1822 1823
1823 ;; At this point, I have the list of articles to consider for 1824 ;; At this point, I have the list of articles to consider for
@@ -1851,15 +1852,15 @@ article numbers will be returned."
1851 ;; gnus-agent-article-alist) equals (cdr (gnus-active 1852 ;; gnus-agent-article-alist) equals (cdr (gnus-active
1852 ;; group))}. The addition of one(the 1+ above) then 1853 ;; group))}. The addition of one(the 1+ above) then
1853 ;; forces Low to be greater than High. When this happens, 1854 ;; forces Low to be greater than High. When this happens,
1854 ;; gnus-list-range-intersection returns nil which 1855 ;; range-list-intersection returns nil which
1855 ;; indicates that no headers need to be fetched. -- Kevin 1856 ;; indicates that no headers need to be fetched. -- Kevin
1856 (setq articles (gnus-list-range-intersection 1857 (setq articles (range-list-intersection
1857 articles (list (cons low high))))))) 1858 articles (list (cons low high)))))))
1858 1859
1859 (when articles 1860 (when articles
1860 (gnus-message 1861 (gnus-message
1861 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" 1862 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'"
1862 (gnus-compress-sequence articles t))) 1863 (range-compress-list articles)))
1863 1864
1864 (with-current-buffer nntp-server-buffer 1865 (with-current-buffer nntp-server-buffer
1865 (if articles 1866 (if articles
@@ -2060,7 +2061,7 @@ doesn't exist, to valid the overview buffer."
2060 (let (state sequence uncomp) 2061 (let (state sequence uncomp)
2061 (while alist 2062 (while alist
2062 (setq state (caar alist) 2063 (setq state (caar alist)
2063 sequence (inline (gnus-uncompress-range (cdar alist))) 2064 sequence (inline (range-uncompress (cdar alist)))
2064 alist (cdr alist)) 2065 alist (cdr alist))
2065 (while sequence 2066 (while sequence
2066 (push (cons (pop sequence) state) uncomp))) 2067 (push (cons (pop sequence) state) uncomp)))
@@ -2404,7 +2405,7 @@ contents, they are first saved to their own file."
2404 (let ((arts (cdr (assq mark (gnus-info-marks 2405 (let ((arts (cdr (assq mark (gnus-info-marks
2405 (setq info (gnus-get-info group))))))) 2406 (setq info (gnus-get-info group)))))))
2406 (when arts 2407 (when arts
2407 (setq marked-articles (nconc (gnus-uncompress-range arts) 2408 (setq marked-articles (nconc (range-uncompress arts)
2408 marked-articles)) 2409 marked-articles))
2409 )))) 2410 ))))
2410 (setq marked-articles (sort marked-articles #'<)) 2411 (setq marked-articles (sort marked-articles #'<))
@@ -2544,7 +2545,7 @@ contents, they are first saved to their own file."
2544 (let ((read (gnus-info-read 2545 (let ((read (gnus-info-read
2545 (or info (setq info (gnus-get-info group)))))) 2546 (or info (setq info (gnus-get-info group))))))
2546 (setf (gnus-info-read info) 2547 (setf (gnus-info-read info)
2547 (gnus-add-to-range read unfetched-articles))) 2548 (range-add-list read unfetched-articles)))
2548 2549
2549 (gnus-group-update-group group t) 2550 (gnus-group-update-group group t)
2550 (sit-for 0) 2551 (sit-for 0)
@@ -2898,8 +2899,8 @@ The following commands are available:
2898 2899
2899(defun gnus-agent-read-p () 2900(defun gnus-agent-read-p ()
2900 "Say whether an article is read or not." 2901 "Say whether an article is read or not."
2901 (gnus-member-of-range (mail-header-number gnus-headers) 2902 (range-member-p (mail-header-number gnus-headers)
2902 (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) 2903 (gnus-info-read (gnus-get-info gnus-newsgroup-name))))
2903 2904
2904(defun gnus-category-make-function (predicate) 2905(defun gnus-category-make-function (predicate)
2905 "Make a function from PREDICATE." 2906 "Make a function from PREDICATE."
@@ -3115,7 +3116,7 @@ FORCE is equivalent to setting the expiration predicates to true."
3115 ;; All articles EXCEPT those named by the caller 3116 ;; All articles EXCEPT those named by the caller
3116 ;; are protected from expiration 3117 ;; are protected from expiration
3117 (gnus-sorted-difference 3118 (gnus-sorted-difference
3118 (gnus-uncompress-range 3119 (range-uncompress
3119 (cons (caar alist) 3120 (cons (caar alist)
3120 (caar (last alist)))) 3121 (caar (last alist))))
3121 (sort articles #'<))))) 3122 (sort articles #'<)))))
@@ -3137,9 +3138,9 @@ FORCE is equivalent to setting the expiration predicates to true."
3137 ;; Ticked and/or dormant articles are excluded 3138 ;; Ticked and/or dormant articles are excluded
3138 ;; from expiration 3139 ;; from expiration
3139 (nconc 3140 (nconc
3140 (gnus-uncompress-range 3141 (range-uncompress
3141 (cdr (assq 'tick (gnus-info-marks info)))) 3142 (cdr (assq 'tick (gnus-info-marks info))))
3142 (gnus-uncompress-range 3143 (range-uncompress
3143 (cdr (assq 'dormant 3144 (cdr (assq 'dormant
3144 (gnus-info-marks info)))))))) 3145 (gnus-info-marks info))))))))
3145 (nov-file (concat dir ".overview")) 3146 (nov-file (concat dir ".overview"))
@@ -3638,7 +3639,7 @@ has been fetched."
3638 (file-name-directory file) t)) 3639 (file-name-directory file) t))
3639 3640
3640 (when fetch-old 3641 (when fetch-old
3641 (setq articles (gnus-uncompress-range 3642 (setq articles (range-uncompress
3642 (cons (if (numberp fetch-old) 3643 (cons (if (numberp fetch-old)
3643 (max 1 (- (car articles) fetch-old)) 3644 (max 1 (- (car articles) fetch-old))
3644 1) 3645 1)
@@ -3694,7 +3695,7 @@ has been fetched."
3694 3695
3695 ;; Clip this list to the headers that will 3696 ;; Clip this list to the headers that will
3696 ;; actually be returned 3697 ;; actually be returned
3697 (setq fetched-articles (gnus-list-range-intersection 3698 (setq fetched-articles (range-list-intersection
3698 (cdr fetched-articles) 3699 (cdr fetched-articles)
3699 (cons min max))) 3700 (cons min max)))
3700 3701
@@ -3703,7 +3704,7 @@ has been fetched."
3703 ;; excluded IDs may be fetchable using HEAD. 3704 ;; excluded IDs may be fetchable using HEAD.
3704 (if (car tail-fetched-articles) 3705 (if (car tail-fetched-articles)
3705 (setq uncached-articles 3706 (setq uncached-articles
3706 (gnus-list-range-intersection 3707 (range-list-intersection
3707 uncached-articles 3708 uncached-articles
3708 (cons (car uncached-articles) 3709 (cons (car uncached-articles)
3709 (car tail-fetched-articles))))) 3710 (car tail-fetched-articles)))))
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index a286c446724..9bb74e80857 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -42,6 +42,7 @@
42(require 'message) 42(require 'message)
43(require 'mouse) 43(require 'mouse)
44(require 'seq) 44(require 'seq)
45(require 'range)
45 46
46(autoload 'gnus-msg-mail "gnus-msg" nil t) 47(autoload 'gnus-msg-mail "gnus-msg" nil t)
47(autoload 'gnus-button-mailto "gnus-msg") 48(autoload 'gnus-button-mailto "gnus-msg")
@@ -1394,6 +1395,15 @@ predicate. See Info node `(gnus)Customizing Articles'."
1394 :link '(custom-manual "(gnus)Customizing Articles") 1395 :link '(custom-manual "(gnus)Customizing Articles")
1395 :type gnus-article-treat-custom) 1396 :type gnus-article-treat-custom)
1396 1397
1398(defcustom gnus-treat-suspicious-headers 'head
1399 "Mark headers that are suspicious.
1400Valid values are nil, t, `head', `first', `last', an integer or a
1401predicate. See Info node `(gnus)Customizing Articles'."
1402 :version "29.1"
1403 :group 'gnus-article-treat
1404 :link '(custom-manual "(gnus)Customizing Articles")
1405 :type gnus-article-treat-custom)
1406
1397(defcustom gnus-treat-fold-newsgroups 'head 1407(defcustom gnus-treat-fold-newsgroups 'head
1398 "Fold the Newsgroups and Followup-To headers. 1408 "Fold the Newsgroups and Followup-To headers.
1399Valid values are nil, t, `head', `first', `last', an integer or a 1409Valid values are nil, t, `head', `first', `last', an integer or a
@@ -1711,6 +1721,7 @@ regexp."
1711 (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) 1721 (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
1712 (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) 1722 (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
1713 (gnus-treat-fold-headers gnus-article-treat-fold-headers) 1723 (gnus-treat-fold-headers gnus-article-treat-fold-headers)
1724 (gnus-treat-suspicious-headers gnus-article-treat-suspicious-headers)
1714 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) 1725 (gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
1715 (gnus-treat-display-smileys gnus-treat-smiley) 1726 (gnus-treat-display-smileys gnus-treat-smiley)
1716 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) 1727 (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
@@ -2235,6 +2246,20 @@ unfolded."
2235 (pixel-fill-region (point) (point-max) (pixel-fill-width))) 2246 (pixel-fill-region (point) (point-max) (pixel-fill-width)))
2236 (goto-char (point-max)))))) 2247 (goto-char (point-max))))))
2237 2248
2249(defun gnus-article-treat-suspicious-headers ()
2250 "Mark suspicious headers."
2251 (interactive nil gnus-article-mode gnus-summary-mode)
2252 (gnus-with-article-headers
2253 (let (match)
2254 (while (setq match (text-property-search-forward 'textsec-suspicious))
2255 (add-text-properties (prop-match-beginning match)
2256 (prop-match-end match)
2257 (list 'help-echo (prop-match-value match)
2258 'face 'textsec-suspicious))
2259 (overlay-put (make-overlay (prop-match-end match)
2260 (prop-match-end match))
2261 'after-string "⚠️")))))
2262
2238(defun gnus-treat-smiley () 2263(defun gnus-treat-smiley ()
2239 "Toggle display of textual emoticons (\"smileys\") as small graphical icons." 2264 "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
2240 (interactive nil gnus-article-mode gnus-summary-mode) 2265 (interactive nil gnus-article-mode gnus-summary-mode)
@@ -2611,17 +2636,36 @@ If PROMPT (the prefix), prompt for a coding system to use."
2611 (forward-line -1)) 2636 (forward-line -1))
2612 (setq end (point)) 2637 (setq end (point))
2613 (while (not (bobp)) 2638 (while (not (bobp))
2614 (while (progn 2639 (let (addresses)
2615 (forward-line -1) 2640 (while (progn
2616 (and (not (bobp)) 2641 (forward-line -1)
2617 (memq (char-after) '(?\t ? ))))) 2642 (and (not (bobp))
2618 (setq start (point)) 2643 (memq (char-after) '(?\t ? )))))
2619 (if (looking-at "\ 2644 (setq start (point))
2645 (save-restriction
2646 (narrow-to-region start end)
2647 (if (looking-at "\
2620\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\ 2648\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
2621\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):") 2649\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
2622 (funcall gnus-decode-address-function start end) 2650 (progn
2623 (funcall gnus-decode-header-function start end)) 2651 (setq addresses (buffer-string))
2624 (goto-char (setq end start))))) 2652 (funcall gnus-decode-address-function (point-min) (point-max)))
2653 (funcall gnus-decode-header-function (point-min) (point-max))))
2654 (when addresses
2655 (article--check-suspicious-addresses addresses))
2656 (goto-char (point-max))
2657 (goto-char (setq end start))))))
2658
2659(defun article--check-suspicious-addresses (addresses)
2660 (setq addresses (replace-regexp-in-string "\\`[^:]+:[ \t\n]*" "" addresses))
2661 (dolist (header (mail-header-parse-addresses addresses t))
2662 (when-let* ((address (car (ignore-errors
2663 (mail-header-parse-address header))))
2664 (warning (textsec-suspicious-p address 'email-address)))
2665 (goto-char (point-min))
2666 (while (search-forward address nil t)
2667 (put-text-property (match-beginning 0) (match-end 0)
2668 'textsec-suspicious warning)))))
2625 2669
2626(defun article-decode-group-name () 2670(defun article-decode-group-name ()
2627 "Decode group names in Newsgroups, Followup-To and Xref headers." 2671 "Decode group names in Newsgroups, Followup-To and Xref headers."
@@ -7019,7 +7063,7 @@ then we display only bindings that start with that prefix."
7019 (setq sumkeys 7063 (setq sumkeys
7020 (append (mapcar 7064 (append (mapcar
7021 #'vector 7065 #'vector
7022 (nreverse (gnus-uncompress-range def))) 7066 (nreverse (range-uncompress def)))
7023 sumkeys)))) 7067 sumkeys))))
7024 ((setq def (key-binding key)) 7068 ((setq def (key-binding key))
7025 (unless (eq def 'undefined) 7069 (unless (eq def 'undefined)
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index 6ed9e32c919..9bd9f2155f7 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -30,6 +30,7 @@
30 30
31(require 'parse-time) 31(require 'parse-time)
32(require 'nnimap) 32(require 'nnimap)
33(require 'range)
33 34
34(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' 35(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
35(autoload 'epg-make-context "epg") 36(autoload 'epg-make-context "epg")
@@ -404,7 +405,7 @@ When FULL is t, upload everything, not just a difference from the last full."
404 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) 405 (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))
405 (active (gnus-active group)) 406 (active (gnus-active group))
406 headers head) 407 headers head)
407 (when (gnus-retrieve-headers (gnus-uncompress-range active) group) 408 (when (gnus-retrieve-headers (range-uncompress active) group)
408 (with-current-buffer nntp-server-buffer 409 (with-current-buffer nntp-server-buffer
409 (goto-char (point-min)) 410 (goto-char (point-min))
410 (while (setq head (nnheader-parse-head)) 411 (while (setq head (nnheader-parse-head))
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index cd9b025ff0e..56d498cc4d3 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -200,7 +200,7 @@ Obeys the standard process/prefix convention."
200 (gnus-activate-group "nndraft:queue") 200 (gnus-activate-group "nndraft:queue")
201 (save-excursion 201 (save-excursion
202 (let* ((articles (nndraft-articles)) 202 (let* ((articles (nndraft-articles))
203 (unsendable (gnus-uncompress-range 203 (unsendable (range-uncompress
204 (cdr (assq 'unsend 204 (cdr (assq 'unsend
205 (gnus-info-marks 205 (gnus-info-marks
206 (gnus-get-info "nndraft:queue")))))) 206 (gnus-get-info "nndraft:queue"))))))
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index ab874dd0608..d3a94e9f4e0 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -35,6 +35,7 @@
35(require 'gnus-undo) 35(require 'gnus-undo)
36(require 'gmm-utils) 36(require 'gmm-utils)
37(require 'time-date) 37(require 'time-date)
38(require 'range)
38 39
39(eval-when-compile 40(eval-when-compile
40 (require 'mm-url) 41 (require 'mm-url)
@@ -512,8 +513,8 @@ simple manner."
512 ((numberp number) 513 ((numberp number)
513 (int-to-string 514 (int-to-string
514 (+ number 515 (+ number
515 (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) 516 (range-length (cdr (assq 'dormant gnus-tmp-marked)))
516 (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) 517 (range-length (cdr (assq 'tick gnus-tmp-marked))))))
517 (t number)) 518 (t number))
518 ?s) 519 ?s)
519 (?R gnus-tmp-number-of-read ?s) 520 (?R gnus-tmp-number-of-read ?s)
@@ -523,10 +524,10 @@ simple manner."
523 ?s) 524 ?s)
524 (?t gnus-tmp-number-total ?d) 525 (?t gnus-tmp-number-total ?d)
525 (?y gnus-tmp-number-of-unread ?s) 526 (?y gnus-tmp-number-of-unread ?s)
526 (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) 527 (?I (range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d)
527 (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) 528 (?T (range-length (cdr (assq 'tick gnus-tmp-marked))) ?d)
528 (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) 529 (?i (+ (range-length (cdr (assq 'dormant gnus-tmp-marked)))
529 (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) 530 (range-length (cdr (assq 'tick gnus-tmp-marked))))
530 ?d) 531 ?d)
531 (?g gnus-tmp-group ?s) 532 (?g gnus-tmp-group ?s)
532 (?G gnus-tmp-qualified-group ?s) 533 (?G gnus-tmp-qualified-group ?s)
@@ -1482,9 +1483,9 @@ if it is a string, only list groups matching REGEXP."
1482 (active (gnus-active group))) 1483 (active (gnus-active group)))
1483 (if (not active) 1484 (if (not active)
1484 0 1485 0
1485 (length (gnus-uncompress-range 1486 (length (range-uncompress
1486 (gnus-range-difference 1487 (range-difference
1487 (gnus-range-difference (list active) (gnus-info-read info)) 1488 (range-difference (list active) (gnus-info-read info))
1488 seen)))))) 1489 seen))))))
1489 1490
1490;; Moving through the Group buffer (in topic mode) e.g. with C-n doesn't 1491;; Moving through the Group buffer (in topic mode) e.g. with C-n doesn't
@@ -1642,7 +1643,7 @@ Some value are bound so the form can use them."
1642 '(mail post-mail)))) 1643 '(mail post-mail))))
1643 (cons 'level (or (gnus-info-level info) gnus-level-killed)) 1644 (cons 'level (or (gnus-info-level info) gnus-level-killed))
1644 (cons 'score (or (gnus-info-score info) 0)) 1645 (cons 'score (or (gnus-info-score info) 0))
1645 (cons 'ticked (gnus-range-length (cdr (assq 'tick marked)))) 1646 (cons 'ticked (range-length (cdr (assq 'tick marked))))
1646 (cons 'group-age (gnus-group-timestamp-delta group))))) 1647 (cons 'group-age (gnus-group-timestamp-delta group)))))
1647 (while (and list 1648 (while (and list
1648 (not (eval (caar list) env))) 1649 (not (eval (caar list) env)))
@@ -2065,9 +2066,9 @@ that group."
2065 (- (1+ (cdr active)) (car active))))) 2066 (- (1+ (cdr active)) (car active)))))
2066 (gnus-summary-read-group 2067 (gnus-summary-read-group
2067 group (or all (and (numberp number) 2068 group (or all (and (numberp number)
2068 (zerop (+ number (gnus-range-length 2069 (zerop (+ number (range-length
2069 (cdr (assq 'tick marked))) 2070 (cdr (assq 'tick marked)))
2070 (gnus-range-length 2071 (range-length
2071 (cdr (assq 'dormant marked))))))) 2072 (cdr (assq 'dormant marked)))))))
2072 no-article nil no-display nil select-articles))) 2073 no-article nil no-display nil select-articles)))
2073 2074
@@ -2832,7 +2833,7 @@ according to the expiry settings. Note that this will delete old
2832not-expirable articles, too." 2833not-expirable articles, too."
2833 (interactive (list (gnus-group-group-name) current-prefix-arg) 2834 (interactive (list (gnus-group-group-name) current-prefix-arg)
2834 gnus-group-mode) 2835 gnus-group-mode)
2835 (let ((articles (gnus-uncompress-range (gnus-active group)))) 2836 (let ((articles (range-uncompress (gnus-active group))))
2836 (when (gnus-yes-or-no-p 2837 (when (gnus-yes-or-no-p
2837 (format "Do you really want to delete these %d articles forever? " 2838 (format "Do you really want to delete these %d articles forever? "
2838 (length articles))) 2839 (length articles)))
@@ -3755,15 +3756,15 @@ or nil if no action could be taken."
3755 'del '(tick)) 3756 'del '(tick))
3756 (list (cdr (assq 'dormant marks)) 3757 (list (cdr (assq 'dormant marks))
3757 'del '(dormant)))) 3758 'del '(dormant))))
3758 (setq unread (gnus-range-add (gnus-range-add 3759 (setq unread (range-concat (range-concat
3759 unread (cdr (assq 'dormant marks))) 3760 unread (cdr (assq 'dormant marks)))
3760 (cdr (assq 'tick marks)))) 3761 (cdr (assq 'tick marks))))
3761 (gnus-add-marked-articles group 'tick nil nil 'force) 3762 (gnus-add-marked-articles group 'tick nil nil 'force)
3762 (gnus-add-marked-articles group 'dormant nil nil 'force)) 3763 (gnus-add-marked-articles group 'dormant nil nil 'force))
3763 ;; Do auto-expirable marks if that's required. 3764 ;; Do auto-expirable marks if that's required.
3764 (when (and (gnus-group-auto-expirable-p group) 3765 (when (and (gnus-group-auto-expirable-p group)
3765 (not (gnus-group-read-only-p group))) 3766 (not (gnus-group-read-only-p group)))
3766 (gnus-range-map 3767 (range-map
3767 (lambda (article) 3768 (lambda (article)
3768 (gnus-add-marked-articles group 'expire (list article)) 3769 (gnus-add-marked-articles group 'expire (list article))
3769 (gnus-request-set-mark group (list (list (list article) 3770 (gnus-request-set-mark group (list (list (list article)
@@ -3795,7 +3796,7 @@ Uses the process/prefix convention."
3795 (cons nil (gnus-list-of-read-articles group)) 3796 (cons nil (gnus-list-of-read-articles group))
3796 (assq 'expire (gnus-info-marks info)))) 3797 (assq 'expire (gnus-info-marks info))))
3797 (articles-to-expire 3798 (articles-to-expire
3798 (gnus-list-range-difference 3799 (range-list-difference
3799 (gnus-uncompress-sequence (cdr expirable)) 3800 (gnus-uncompress-sequence (cdr expirable))
3800 (cdr (assq 'unexist (gnus-info-marks info))))) 3801 (cdr (assq 'unexist (gnus-info-marks info)))))
3801 (expiry-wait (gnus-group-find-parameter group 'expiry-wait)) 3802 (expiry-wait (gnus-group-find-parameter group 'expiry-wait))
@@ -4671,23 +4672,22 @@ and the second element is the address."
4671 (and (not (setq marked (nthcdr 3 info))) 4672 (and (not (setq marked (nthcdr 3 info)))
4672 (or (null articles) 4673 (or (null articles)
4673 (setcdr (nthcdr 2 info) 4674 (setcdr (nthcdr 2 info)
4674 (list (list (cons type (gnus-compress-sequence 4675 (list (list (cons type (range-compress-list
4675 articles t))))))) 4676 articles)))))))
4676 (and (not (setq m (assq type (car marked)))) 4677 (and (not (setq m (assq type (car marked))))
4677 (or (null articles) 4678 (or (null articles)
4678 (setcar marked 4679 (setcar marked
4679 (cons (cons type (gnus-compress-sequence articles t) ) 4680 (cons (cons type (range-compress-list articles))
4680 (car marked))))) 4681 (car marked)))))
4681 (if force 4682 (if force
4682 (if (null articles) 4683 (if (null articles)
4683 (setcar (nthcdr 3 info) 4684 (setcar (nthcdr 3 info)
4684 (assq-delete-all type (car marked))) 4685 (assq-delete-all type (car marked)))
4685 (setcdr m (gnus-compress-sequence articles t))) 4686 (setcdr m (range-compress-list articles)))
4686 (setcdr m (gnus-compress-sequence 4687 (setcdr m (range-compress-list
4687 (sort (nconc (gnus-uncompress-range (cdr m)) 4688 (sort (nconc (range-uncompress (cdr m))
4688 (copy-sequence articles)) 4689 (copy-sequence articles))
4689 #'<) 4690 #'<)))))))
4690 t))))))
4691 4691
4692(declare-function gnus-summary-add-mark "gnus-sum" (article type)) 4692(declare-function gnus-summary-add-mark "gnus-sum" (article type))
4693 4693
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index 5a619e8f07b..f00f2a0d04e 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -802,7 +802,7 @@ If GROUP is nil, all groups on COMMAND-METHOD are scanned."
802 (when (> min 1) 802 (when (> min 1)
803 (let* ((range (if (= min 2) 1 (cons 1 (1- min)))) 803 (let* ((range (if (= min 2) 1 (cons 1 (1- min))))
804 (read (gnus-info-read info)) 804 (read (gnus-info-read info))
805 (new-read (gnus-range-add read (list range)))) 805 (new-read (range-concat read (list range))))
806 (setf (gnus-info-read info) new-read))) 806 (setf (gnus-info-read info) new-read)))
807 info)))))) 807 info))))))
808 808
diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el
index bee7860efdb..bc49f8385ea 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -349,7 +349,7 @@ Returns the number of articles marked as read."
349 (setq gnus-newsgroup-kill-headers 349 (setq gnus-newsgroup-kill-headers
350 (mapcar #'mail-header-number headers)) 350 (mapcar #'mail-header-number headers))
351 (while headers 351 (while headers
352 (unless (gnus-member-of-range 352 (unless (range-member-p
353 (mail-header-number (car headers)) 353 (mail-header-number (car headers))
354 gnus-newsgroup-killed) 354 gnus-newsgroup-killed)
355 (push (mail-header-number (car headers)) 355 (push (mail-header-number (car headers))
diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el
index da3ff473725..23a71bda209 100644
--- a/lisp/gnus/gnus-range.el
+++ b/lisp/gnus/gnus-range.el
@@ -26,10 +26,8 @@
26 26
27;;; List and range functions 27;;; List and range functions
28 28
29(defsubst gnus-range-normalize (range) 29(require 'range)
30 "Normalize RANGE. 30(define-obsolete-function-alias 'gnus-range-normalize #'range-normalize "29.1")
31If RANGE is a single range, return (RANGE). Otherwise, return RANGE."
32 (if (listp (cdr-safe range)) range (list range)))
33 31
34(defun gnus-last-element (list) 32(defun gnus-last-element (list)
35 "Return last element of LIST." 33 "Return last element of LIST."
@@ -56,10 +54,10 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE."
56 "Return a range comprising all the RANGES, which are pre-sorted. 54 "Return a range comprising all the RANGES, which are pre-sorted.
57RANGES will be destructively altered." 55RANGES will be destructively altered."
58 (setq ranges (delete nil ranges)) 56 (setq ranges (delete nil ranges))
59 (let* ((result (gnus-range-normalize (pop ranges))) 57 (let* ((result (range-normalize (pop ranges)))
60 (last (last result))) 58 (last (last result)))
61 (dolist (range ranges) 59 (dolist (range ranges)
62 (setq range (gnus-range-normalize range)) 60 (setq range (range-normalize range))
63 ;; Normalize the single-number case, so that we don't need to 61 ;; Normalize the single-number case, so that we don't need to
64 ;; special-case that so much. 62 ;; special-case that so much.
65 (when (numberp (car last)) 63 (when (numberp (car last))
@@ -82,47 +80,8 @@ RANGES will be destructively altered."
82 (car result) 80 (car result)
83 result))) 81 result)))
84 82
85(defun gnus-range-difference (range1 range2) 83(define-obsolete-function-alias 'gnus-range-difference
86 "Return the range of elements in RANGE1 that do not appear in RANGE2. 84 #'range-difference "29.1")
87Both ranges must be in ascending order."
88 (setq range1 (gnus-range-normalize range1))
89 (setq range2 (gnus-range-normalize range2))
90 (let* ((new-range (cons nil (copy-sequence range1)))
91 (r new-range)
92 ) ;; (safe t)
93 (while (cdr r)
94 (let* ((r1 (cadr r))
95 (r2 (car range2))
96 (min1 (if (numberp r1) r1 (car r1)))
97 (max1 (if (numberp r1) r1 (cdr r1)))
98 (min2 (if (numberp r2) r2 (car r2)))
99 (max2 (if (numberp r2) r2 (cdr r2))))
100
101 (cond ((> min1 max1)
102 ;; Invalid range: may result from overlap condition (below)
103 ;; remove Invalid range
104 (setcdr r (cddr r)))
105 ((and (= min1 max1)
106 (listp r1))
107 ;; Inefficient representation: may result from overlap condition (below)
108 (setcar (cdr r) min1))
109 ((not min2)
110 ;; All done with range2
111 (setq r nil))
112 ((< max1 min2)
113 ;; No overlap: range1 precedes range2
114 (pop r))
115 ((< max2 min1)
116 ;; No overlap: range2 precedes range1
117 (pop range2))
118 ((and (<= min2 min1) (<= max1 max2))
119 ;; Complete overlap: range1 removed
120 (setcdr r (cddr r)))
121 (t
122 (setcdr r (nconc (list (cons min1 (1- min2)) (cons (1+ max2) max1)) (cddr r)))))))
123 (cdr new-range)))
124
125
126 85
127;;;###autoload 86;;;###autoload
128(defun gnus-sorted-difference (list1 list2) 87(defun gnus-sorted-difference (list1 list2)
@@ -200,57 +159,8 @@ LIST1 and LIST2 have to be sorted over <."
200 (setq list2 (cdr list2))))) 159 (setq list2 (cdr list2)))))
201 (nreverse out))) 160 (nreverse out)))
202 161
203;;;###autoload 162(define-obsolete-function-alias 'gnus-sorted-range-intersection
204(defun gnus-sorted-range-intersection (range1 range2) 163 #'range-intersection "29.1")
205 "Return intersection of RANGE1 and RANGE2.
206RANGE1 and RANGE2 have to be sorted over <."
207 (let* (out
208 (min1 (car range1))
209 (max1 (if (numberp min1)
210 (if (numberp (cdr range1))
211 (prog1 (cdr range1)
212 (setq range1 nil)) min1)
213 (prog1 (cdr min1)
214 (setq min1 (car min1)))))
215 (min2 (car range2))
216 (max2 (if (numberp min2)
217 (if (numberp (cdr range2))
218 (prog1 (cdr range2)
219 (setq range2 nil)) min2)
220 (prog1 (cdr min2)
221 (setq min2 (car min2))))))
222 (setq range1 (cdr range1)
223 range2 (cdr range2))
224 (while (and min1 min2)
225 (cond ((< max1 min2) ; range1 precedes range2
226 (setq range1 (cdr range1)
227 min1 nil))
228 ((< max2 min1) ; range2 precedes range1
229 (setq range2 (cdr range2)
230 min2 nil))
231 (t ; some sort of overlap is occurring
232 (let ((min (max min1 min2))
233 (max (min max1 max2)))
234 (setq out (if (= min max)
235 (cons min out)
236 (cons (cons min max) out))))
237 (if (< max1 max2) ; range1 ends before range2
238 (setq min1 nil) ; incr range1
239 (setq min2 nil)))) ; incr range2
240 (unless min1
241 (setq min1 (car range1)
242 max1 (if (numberp min1) min1 (prog1 (cdr min1) (setq min1 (car min1))))
243 range1 (cdr range1)))
244 (unless min2
245 (setq min2 (car range2)
246 max2 (if (numberp min2) min2 (prog1 (cdr min2) (setq min2 (car min2))))
247 range2 (cdr range2))))
248 (cond ((cdr out)
249 (nreverse out))
250 ((numberp (car out))
251 out)
252 (t
253 (car out)))))
254 164
255;;;###autoload 165;;;###autoload
256(defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection) 166(defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection)
@@ -327,315 +237,33 @@ LIST1 and LIST2 have to be sorted over <."
327 "Convert sorted list of numbers to a list of ranges or a single range. 237 "Convert sorted list of numbers to a list of ranges or a single range.
328If ALWAYS-LIST is non-nil, this function will always release a list of 238If ALWAYS-LIST is non-nil, this function will always release a list of
329ranges." 239ranges."
330 (let* ((first (car numbers)) 240 (if always-list
331 (last (car numbers)) 241 (range-compress-list numbers)
332 result) 242 (range-denormalize (range-compress-list numbers))))
333 (if (null numbers)
334 nil
335 (if (not (listp (cdr numbers)))
336 numbers
337 (while numbers
338 (cond ((= last (car numbers)) nil) ;Omit duplicated number
339 ((= (1+ last) (car numbers)) ;Still in sequence
340 (setq last (car numbers)))
341 (t ;End of one sequence
342 (setq result
343 (cons (if (= first last) first
344 (cons first last))
345 result))
346 (setq first (car numbers))
347 (setq last (car numbers))))
348 (setq numbers (cdr numbers)))
349 (if (and (not always-list) (null result))
350 (if (= first last) (list first) (cons first last))
351 (nreverse (cons (if (= first last) first (cons first last))
352 result)))))))
353 243
354(defalias 'gnus-uncompress-sequence 'gnus-uncompress-range) 244(defalias 'gnus-uncompress-sequence 'gnus-uncompress-range)
355(defun gnus-uncompress-range (ranges) 245(define-obsolete-function-alias 'gnus-uncompress-range
356 "Expand a list of ranges into a list of numbers. 246 #'range-uncompress "29.1")
357RANGES is either a single range on the form `(num . num)' or a list of 247
358these ranges." 248(define-obsolete-function-alias 'gnus-add-to-range
359 (let (first last result) 249 #'range-add-list "29.1")
360 (cond 250
361 ((null ranges) 251(define-obsolete-function-alias 'gnus-remove-from-range
362 nil) 252 #'range-remove "29.1")
363 ((not (listp (cdr ranges))) 253
364 (setq first (car ranges)) 254(define-obsolete-function-alias 'gnus-member-of-range #'range-member-p "29.1")
365 (setq last (cdr ranges)) 255
366 (while (<= first last) 256(define-obsolete-function-alias 'gnus-list-range-intersection
367 (setq result (cons first result)) 257 #'range-list-intersection "29.1")
368 (setq first (1+ first)))
369 (nreverse result))
370 (t
371 (while ranges
372 (if (atom (car ranges))
373 (when (numberp (car ranges))
374 (setq result (cons (car ranges) result)))
375 (setq first (caar ranges))
376 (setq last (cdar ranges))
377 (while (<= first last)
378 (setq result (cons first result))
379 (setq first (1+ first))))
380 (setq ranges (cdr ranges)))
381 (nreverse result)))))
382
383(defun gnus-add-to-range (ranges list)
384 "Return a list of ranges that has all articles from both RANGES and LIST.
385Note: LIST has to be sorted over `<'."
386 (if (not ranges)
387 (gnus-compress-sequence list t)
388 (setq list (copy-sequence list))
389 (unless (listp (cdr ranges))
390 (setq ranges (list ranges)))
391 (let ((out ranges)
392 ilist lowest highest temp)
393 (while (and ranges list)
394 (setq ilist list)
395 (setq lowest (or (and (atom (car ranges)) (car ranges))
396 (caar ranges)))
397 (while (and list (cdr list) (< (cadr list) lowest))
398 (setq list (cdr list)))
399 (when (< (car ilist) lowest)
400 (setq temp list)
401 (setq list (cdr list))
402 (setcdr temp nil)
403 (setq out (nconc (gnus-compress-sequence ilist t) out)))
404 (setq highest (or (and (atom (car ranges)) (car ranges))
405 (cdar ranges)))
406 (while (and list (<= (car list) highest))
407 (setq list (cdr list)))
408 (setq ranges (cdr ranges)))
409 (when list
410 (setq out (nconc (gnus-compress-sequence list t) out)))
411 (setq out (sort out (lambda (r1 r2)
412 (< (or (and (atom r1) r1) (car r1))
413 (or (and (atom r2) r2) (car r2))))))
414 (setq ranges out)
415 (while ranges
416 (if (atom (car ranges))
417 (when (cdr ranges)
418 (if (atom (cadr ranges))
419 (when (= (1+ (car ranges)) (cadr ranges))
420 (setcar ranges (cons (car ranges)
421 (cadr ranges)))
422 (setcdr ranges (cddr ranges)))
423 (when (= (1+ (car ranges)) (caadr ranges))
424 (setcar (cadr ranges) (car ranges))
425 (setcar ranges (cadr ranges))
426 (setcdr ranges (cddr ranges)))))
427 (when (cdr ranges)
428 (if (atom (cadr ranges))
429 (when (= (1+ (cdar ranges)) (cadr ranges))
430 (setcdr (car ranges) (cadr ranges))
431 (setcdr ranges (cddr ranges)))
432 (when (= (1+ (cdar ranges)) (caadr ranges))
433 (setcdr (car ranges) (cdadr ranges))
434 (setcdr ranges (cddr ranges))))))
435 (setq ranges (cdr ranges)))
436 out)))
437
438(defun gnus-remove-from-range (range1 range2)
439 "Return a range that has all articles from RANGE2 removed from RANGE1.
440The returned range is always a list. RANGE2 can also be a unsorted
441list of articles. RANGE1 is modified by side effects, RANGE2 is not
442modified."
443 (if (or (null range1) (null range2))
444 range1
445 (let (out r1 r2 r1_min r1_max r2_min r2_max
446 (range2 (copy-tree range2)))
447 (setq range1 (if (listp (cdr range1)) range1 (list range1))
448 range2 (sort (if (listp (cdr range2)) range2 (list range2))
449 (lambda (e1 e2)
450 (< (if (consp e1) (car e1) e1)
451 (if (consp e2) (car e2) e2))))
452 r1 (car range1)
453 r2 (car range2)
454 r1_min (if (consp r1) (car r1) r1)
455 r1_max (if (consp r1) (cdr r1) r1)
456 r2_min (if (consp r2) (car r2) r2)
457 r2_max (if (consp r2) (cdr r2) r2))
458 (while (and range1 range2)
459 (cond ((< r2_max r1_min) ; r2 < r1
460 (pop range2)
461 (setq r2 (car range2)
462 r2_min (if (consp r2) (car r2) r2)
463 r2_max (if (consp r2) (cdr r2) r2)))
464 ((and (<= r2_min r1_min) (<= r1_max r2_max)) ; r2 overlap r1
465 (pop range1)
466 (setq r1 (car range1)
467 r1_min (if (consp r1) (car r1) r1)
468 r1_max (if (consp r1) (cdr r1) r1)))
469 ((and (<= r2_min r1_min) (<= r2_max r1_max)) ; r2 overlap min r1
470 (pop range2)
471 (setq r1_min (1+ r2_max)
472 r2 (car range2)
473 r2_min (if (consp r2) (car r2) r2)
474 r2_max (if (consp r2) (cdr r2) r2)))
475 ((and (<= r1_min r2_min) (<= r2_max r1_max)) ; r2 contained in r1
476 (if (eq r1_min (1- r2_min))
477 (push r1_min out)
478 (push (cons r1_min (1- r2_min)) out))
479 (pop range2)
480 (if (< r2_max r1_max) ; finished with r1?
481 (setq r1_min (1+ r2_max))
482 (pop range1)
483 (setq r1 (car range1)
484 r1_min (if (consp r1) (car r1) r1)
485 r1_max (if (consp r1) (cdr r1) r1)))
486 (setq r2 (car range2)
487 r2_min (if (consp r2) (car r2) r2)
488 r2_max (if (consp r2) (cdr r2) r2)))
489 ((and (<= r2_min r1_max) (<= r1_max r2_max)) ; r2 overlap max r1
490 (if (eq r1_min (1- r2_min))
491 (push r1_min out)
492 (push (cons r1_min (1- r2_min)) out))
493 (pop range1)
494 (setq r1 (car range1)
495 r1_min (if (consp r1) (car r1) r1)
496 r1_max (if (consp r1) (cdr r1) r1)))
497 ((< r1_max r2_min) ; r2 > r1
498 (pop range1)
499 (if (eq r1_min r1_max)
500 (push r1_min out)
501 (push (cons r1_min r1_max) out))
502 (setq r1 (car range1)
503 r1_min (if (consp r1) (car r1) r1)
504 r1_max (if (consp r1) (cdr r1) r1)))))
505 (when r1
506 (if (eq r1_min r1_max)
507 (push r1_min out)
508 (push (cons r1_min r1_max) out))
509 (pop range1))
510 (while range1
511 (push (pop range1) out))
512 (nreverse out))))
513
514(defun gnus-member-of-range (number ranges)
515 (if (not (listp (cdr ranges)))
516 (and (>= number (car ranges))
517 (<= number (cdr ranges)))
518 (let ((not-stop t))
519 (while (and ranges
520 (if (numberp (car ranges))
521 (>= number (car ranges))
522 (>= number (caar ranges)))
523 not-stop)
524 (when (if (numberp (car ranges))
525 (= number (car ranges))
526 (and (>= number (caar ranges))
527 (<= number (cdar ranges))))
528 (setq not-stop nil))
529 (setq ranges (cdr ranges)))
530 (not not-stop))))
531
532(defun gnus-list-range-intersection (list ranges)
533 "Return a list of numbers in LIST that are members of RANGES.
534LIST is a sorted list."
535 (setq ranges (gnus-range-normalize ranges))
536 (let (number result)
537 (while (setq number (pop list))
538 (while (and ranges
539 (if (numberp (car ranges))
540 (< (car ranges) number)
541 (< (cdar ranges) number)))
542 (setq ranges (cdr ranges)))
543 (when (and ranges
544 (if (numberp (car ranges))
545 (= (car ranges) number)
546 ;; (caar ranges) <= number <= (cdar ranges)
547 (>= number (caar ranges))))
548 (push number result)))
549 (nreverse result)))
550 258
551(defalias 'gnus-inverse-list-range-intersection 'gnus-list-range-difference) 259(defalias 'gnus-inverse-list-range-intersection 'gnus-list-range-difference)
552 260
553(defun gnus-list-range-difference (list ranges) 261(define-obsolete-function-alias 'gnus-list-range-difference
554 "Return a list of numbers in LIST that are not members of RANGES. 262 #'range-list-difference "29.1")
555LIST is a sorted list." 263
556 (setq ranges (gnus-range-normalize ranges)) 264(define-obsolete-function-alias 'gnus-range-length #'range-length "29.1")
557 (let (number result)
558 (while (setq number (pop list))
559 (while (and ranges
560 (if (numberp (car ranges))
561 (< (car ranges) number)
562 (< (cdar ranges) number)))
563 (setq ranges (cdr ranges)))
564 (when (or (not ranges)
565 (if (numberp (car ranges))
566 (not (= (car ranges) number))
567 ;; not ((caar ranges) <= number <= (cdar ranges))
568 (< number (caar ranges))))
569 (push number result)))
570 (nreverse result)))
571 265
572(defun gnus-range-length (range) 266(define-obsolete-function-alias 'gnus-range-add #'range-concat "29.1")
573 "Return the length RANGE would have if uncompressed."
574 (cond
575 ((null range)
576 0)
577 ((not (listp (cdr range)))
578 (- (cdr range) (car range) -1))
579 (t
580 (let ((sum 0))
581 (dolist (x range sum)
582 (setq sum
583 (+ sum (if (consp x) (- (cdr x) (car x) -1) 1))))))))
584
585(defun gnus-range-add (range1 range2)
586 "Add RANGE2 to RANGE1 (nondestructively)."
587 (unless (listp (cdr range1))
588 (setq range1 (list range1)))
589 (unless (listp (cdr range2))
590 (setq range2 (list range2)))
591 (let ((item1 (pop range1))
592 (item2 (pop range2))
593 range item selector)
594 (while (or item1 item2)
595 (setq selector
596 (cond
597 ((null item1) nil)
598 ((null item2) t)
599 ((and (numberp item1) (numberp item2)) (< item1 item2))
600 ((numberp item1) (< item1 (car item2)))
601 ((numberp item2) (< (car item1) item2))
602 (t (< (car item1) (car item2)))))
603 (setq item
604 (or
605 (let ((tmp1 item) (tmp2 (if selector item1 item2)))
606 (cond
607 ((null tmp1) tmp2)
608 ((null tmp2) tmp1)
609 ((and (numberp tmp1) (numberp tmp2))
610 (cond
611 ((eq tmp1 tmp2) tmp1)
612 ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2))
613 ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1))
614 (t nil)))
615 ((numberp tmp1)
616 (cond
617 ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2)
618 ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2)))
619 ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1))
620 (t nil)))
621 ((numberp tmp2)
622 (cond
623 ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1)
624 ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1)))
625 ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2))
626 (t nil)))
627 ((< (1+ (cdr tmp1)) (car tmp2)) nil)
628 ((< (1+ (cdr tmp2)) (car tmp1)) nil)
629 (t (cons (min (car tmp1) (car tmp2))
630 (max (cdr tmp1) (cdr tmp2))))))
631 (progn
632 (if item (push item range))
633 (if selector item1 item2))))
634 (if selector
635 (setq item1 (pop range1))
636 (setq item2 (pop range2))))
637 (if item (push item range))
638 (reverse range)))
639 267
640;;;###autoload 268;;;###autoload
641(defun gnus-add-to-sorted-list (list num) 269(defun gnus-add-to-sorted-list (list num)
@@ -649,18 +277,7 @@ LIST is a sorted list."
649 (setcdr prev (cons num list))) 277 (setcdr prev (cons num list)))
650 (cdr top))) 278 (cdr top)))
651 279
652(defun gnus-range-map (func range) 280(define-obsolete-function-alias 'gnus-range-map #'range-map "29.1")
653 "Apply FUNC to each value contained by RANGE."
654 (setq range (gnus-range-normalize range))
655 (while range
656 (let ((span (pop range)))
657 (if (numberp span)
658 (funcall func span)
659 (let ((first (car span))
660 (last (cdr span)))
661 (while (<= first last)
662 (funcall func first)
663 (setq first (1+ first))))))))
664 281
665(provide 'gnus-range) 282(provide 'gnus-range)
666 283
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 252e6e22299..2cf11fb12f9 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -1884,13 +1884,12 @@ The info element is shared with the same element of
1884 (ranges (gnus-info-read info)) 1884 (ranges (gnus-info-read info))
1885 news article) 1885 news article)
1886 (while articles 1886 (while articles
1887 (when (gnus-member-of-range 1887 (when (range-member-p (setq article (pop articles)) ranges)
1888 (setq article (pop articles)) ranges)
1889 (push article news))) 1888 (push article news)))
1890 (when news 1889 (when news
1891 ;; Enter this list into the group info. 1890 ;; Enter this list into the group info.
1892 (setf (gnus-info-read info) 1891 (setf (gnus-info-read info)
1893 (gnus-remove-from-range (gnus-info-read info) (nreverse news))) 1892 (range-remove (gnus-info-read info) (nreverse news)))
1894 1893
1895 ;; Set the number of unread articles in gnus-newsrc-hashtb. 1894 ;; Set the number of unread articles in gnus-newsrc-hashtb.
1896 (gnus-get-unread-articles-in-group info (gnus-active group)) 1895 (gnus-get-unread-articles-in-group info (gnus-active group))
@@ -2362,10 +2361,10 @@ The form should return either t or nil."
2362 ticked (cdr (assq 'tick marks))) 2361 ticked (cdr (assq 'tick marks)))
2363 (when (or dormant ticked) 2362 (when (or dormant ticked)
2364 (setf (gnus-info-read info) 2363 (setf (gnus-info-read info)
2365 (gnus-add-to-range 2364 (range-add-list
2366 (gnus-info-read info) 2365 (gnus-info-read info)
2367 (nconc (gnus-uncompress-range dormant) 2366 (nconc (range-uncompress dormant)
2368 (gnus-uncompress-range ticked))))))))) 2367 (range-uncompress ticked)))))))))
2369 2368
2370(defun gnus-load (file) 2369(defun gnus-load (file)
2371 "Load FILE, but in such a way that read errors can be reported." 2370 "Load FILE, but in such a way that read errors can be reported."
@@ -2457,8 +2456,7 @@ The form should return either t or nil."
2457 (unless (nthcdr 3 info) 2456 (unless (nthcdr 3 info)
2458 (nconc info (list nil))) 2457 (nconc info (list nil)))
2459 (setf (gnus-info-marks info) 2458 (setf (gnus-info-marks info)
2460 (list (cons 'tick (gnus-compress-sequence 2459 (list (cons 'tick (range-compress-list (sort (cdr m) #'<)))))))
2461 (sort (cdr m) #'<) t))))))
2462 (setq newsrc killed) 2460 (setq newsrc killed)
2463 (while newsrc 2461 (while newsrc
2464 (setcar newsrc (caar newsrc)) 2462 (setcar newsrc (caar newsrc))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index d3e476b5d64..8fb07d5905c 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -5755,7 +5755,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5755 ;; (let ((n (cdr (gnus-active group)))) 5755 ;; (let ((n (cdr (gnus-active group))))
5756 ;; (lambda () (> number (- n display)))) 5756 ;; (lambda () (> number (- n display))))
5757 (setq select-articles 5757 (setq select-articles
5758 (gnus-uncompress-range 5758 (range-uncompress
5759 (cons (let ((tmp (- (cdr (gnus-active group)) display))) 5759 (cons (let ((tmp (- (cdr (gnus-active group)) display)))
5760 (if (> tmp 0) 5760 (if (> tmp 0)
5761 tmp 5761 tmp
@@ -5928,7 +5928,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5928 "Find out what articles the user wants to read." 5928 "Find out what articles the user wants to read."
5929 (let* ((only-read-p t) 5929 (let* ((only-read-p t)
5930 (articles 5930 (articles
5931 (gnus-list-range-difference 5931 (range-list-difference
5932 ;; Select all articles if `read-all' is non-nil, or if there 5932 ;; Select all articles if `read-all' is non-nil, or if there
5933 ;; are no unread articles. 5933 ;; are no unread articles.
5934 (if (or read-all 5934 (if (or read-all
@@ -5943,13 +5943,13 @@ If SELECT-ARTICLES, only select those articles from GROUP."
5943 (or 5943 (or
5944 (if gnus-newsgroup-maximum-articles 5944 (if gnus-newsgroup-maximum-articles
5945 (let ((active (gnus-active group))) 5945 (let ((active (gnus-active group)))
5946 (gnus-uncompress-range 5946 (range-uncompress
5947 (cons (max (car active) 5947 (cons (max (car active)
5948 (- (cdr active) 5948 (- (cdr active)
5949 gnus-newsgroup-maximum-articles 5949 gnus-newsgroup-maximum-articles
5950 -1)) 5950 -1))
5951 (cdr active)))) 5951 (cdr active))))
5952 (gnus-uncompress-range (gnus-active group))) 5952 (range-uncompress (gnus-active group)))
5953 (gnus-cache-articles-in-group group)) 5953 (gnus-cache-articles-in-group group))
5954 ;; Select only the "normal" subset of articles. 5954 ;; Select only the "normal" subset of articles.
5955 (setq only-read-p nil) 5955 (setq only-read-p nil)
@@ -6040,7 +6040,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
6040(defun gnus-killed-articles (killed articles) 6040(defun gnus-killed-articles (killed articles)
6041 (let (out) 6041 (let (out)
6042 (while articles 6042 (while articles
6043 (when (inline (gnus-member-of-range (car articles) killed)) 6043 (when (inline (range-member-p (car articles) killed))
6044 (push (car articles) out)) 6044 (push (car articles) out))
6045 (setq articles (cdr articles))) 6045 (setq articles (cdr articles)))
6046 out)) 6046 out))
@@ -6078,7 +6078,7 @@ If SELECT-ARTICLES, only select those articles from GROUP."
6078 ;; Adjust "simple" lists - compressed yet unsorted 6078 ;; Adjust "simple" lists - compressed yet unsorted
6079 ((eq mark-type 'list) 6079 ((eq mark-type 'list)
6080 ;; Simultaneously uncompress and clip to active range 6080 ;; Simultaneously uncompress and clip to active range
6081 ;; See gnus-uncompress-range for a description of possible marks 6081 ;; See range-uncompress for a description of possible marks
6082 (let (l lh) 6082 (let (l lh)
6083 (if (not (cadr marks)) 6083 (if (not (cadr marks))
6084 (set var nil) 6084 (set var nil)
@@ -6177,10 +6177,10 @@ If SELECT-ARTICLES, only select those articles from GROUP."
6177 ;; When exiting the group, everything that's previously been 6177 ;; When exiting the group, everything that's previously been
6178 ;; unseen is now seen. 6178 ;; unseen is now seen.
6179 (when (eq (cdr type) 'seen) 6179 (when (eq (cdr type) 'seen)
6180 (setq list (gnus-range-add list gnus-newsgroup-unseen))) 6180 (setq list (range-concat list gnus-newsgroup-unseen)))
6181 6181
6182 (when (eq (gnus-article-mark-to-type (cdr type)) 'list) 6182 (when (eq (gnus-article-mark-to-type (cdr type)) 'list)
6183 (setq list (gnus-compress-sequence (set symbol (sort list #'<)) t))) 6183 (setq list (range-compress-list (set symbol (sort list #'<)))))
6184 6184
6185 (when (and (gnus-check-backend-function 6185 (when (and (gnus-check-backend-function
6186 'request-set-mark gnus-newsgroup-name) 6186 'request-set-mark gnus-newsgroup-name)
@@ -6189,20 +6189,19 @@ If SELECT-ARTICLES, only select those articles from GROUP."
6189 ;; Don't do anything about marks for articles we 6189 ;; Don't do anything about marks for articles we
6190 ;; didn't actually get any headers for. 6190 ;; didn't actually get any headers for.
6191 (del 6191 (del
6192 (gnus-list-range-intersection 6192 (range-list-intersection
6193 gnus-newsgroup-articles 6193 gnus-newsgroup-articles
6194 (gnus-remove-from-range (copy-tree old) list))) 6194 (range-remove (copy-tree old) list)))
6195 (add 6195 (add
6196 (gnus-list-range-intersection 6196 (range-list-intersection
6197 gnus-newsgroup-articles 6197 gnus-newsgroup-articles
6198 (gnus-remove-from-range 6198 (range-remove (copy-tree list) old))))
6199 (copy-tree list) old))))
6200 (when add 6199 (when add
6201 (push (list add 'add (list (cdr type))) delta-marks)) 6200 (push (list add 'add (list (cdr type))) delta-marks))
6202 (when del 6201 (when del
6203 ;; Don't delete marks from outside the active range. 6202 ;; Don't delete marks from outside the active range.
6204 ;; This shouldn't happen, but is a sanity check. 6203 ;; This shouldn't happen, but is a sanity check.
6205 (setq del (gnus-sorted-range-intersection 6204 (setq del (range-intersection
6206 (gnus-active gnus-newsgroup-name) del)) 6205 (gnus-active gnus-newsgroup-name) del))
6207 (push (list del 'del (list (cdr type))) delta-marks)))) 6206 (push (list del 'del (list (cdr type))) delta-marks))))
6208 6207
@@ -6386,7 +6385,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
6386 (setq ninfo (cons 1 (1- (car active)))) 6385 (setq ninfo (cons 1 (1- (car active))))
6387 (setq ninfo (gnus-info-read info))) 6386 (setq ninfo (gnus-info-read info)))
6388 ;; Then we add the read articles to the range. 6387 ;; Then we add the read articles to the range.
6389 (gnus-add-to-range 6388 (range-add-list
6390 ninfo (setq articles (sort articles #'<)))))) 6389 ninfo (setq articles (sort articles #'<))))))
6391 6390
6392(defun gnus-group-make-articles-read (group articles) 6391(defun gnus-group-make-articles-read (group articles)
@@ -6967,10 +6966,10 @@ displayed, no centering will be performed."
6967 (marked (gnus-info-marks info)) 6966 (marked (gnus-info-marks info))
6968 (active (gnus-active group))) 6967 (active (gnus-active group)))
6969 (and info active 6968 (and info active
6970 (gnus-list-range-difference 6969 (range-list-difference
6971 (gnus-list-range-difference 6970 (range-list-difference
6972 (gnus-sorted-complement 6971 (gnus-sorted-complement
6973 (gnus-uncompress-range 6972 (range-uncompress
6974 (if gnus-newsgroup-maximum-articles 6973 (if gnus-newsgroup-maximum-articles
6975 (cons (max (car active) 6974 (cons (max (car active)
6976 (- (cdr active) 6975 (- (cdr active)
@@ -7129,12 +7128,11 @@ The prefix argument ALL means to select all articles."
7129 (when group 7128 (when group
7130 (when gnus-newsgroup-kill-headers 7129 (when gnus-newsgroup-kill-headers
7131 (setq gnus-newsgroup-killed 7130 (setq gnus-newsgroup-killed
7132 (gnus-compress-sequence 7131 (range-compress-list
7133 (gnus-sorted-union 7132 (gnus-sorted-union
7134 (gnus-list-range-intersection 7133 (range-list-intersection
7135 gnus-newsgroup-unselected gnus-newsgroup-killed) 7134 gnus-newsgroup-unselected gnus-newsgroup-killed)
7136 gnus-newsgroup-unreads) 7135 gnus-newsgroup-unreads))))
7137 t)))
7138 (unless (listp (cdr gnus-newsgroup-killed)) 7136 (unless (listp (cdr gnus-newsgroup-killed))
7139 (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) 7137 (setq gnus-newsgroup-killed (list gnus-newsgroup-killed)))
7140 (let ((headers gnus-newsgroup-headers) 7138 (let ((headers gnus-newsgroup-headers)
@@ -10241,8 +10239,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
10241 (cdr art-group)) 10239 (cdr art-group))
10242 (push 'read to-marks) 10240 (push 'read to-marks)
10243 (setf (gnus-info-read info) 10241 (setf (gnus-info-read info)
10244 (gnus-add-to-range (gnus-info-read info) 10242 (range-add-list (gnus-info-read info)
10245 (list (cdr art-group))))) 10243 (list (cdr art-group)))))
10246 10244
10247 ;; See whether the article is to be put in the cache. 10245 ;; See whether the article is to be put in the cache.
10248 (let* ((expirable (gnus-group-auto-expirable-p to-group)) 10246 (let* ((expirable (gnus-group-auto-expirable-p to-group))
@@ -10525,7 +10523,7 @@ This will be the case if the article has both been mailed and posted."
10525 ;; This backend supports expiry. 10523 ;; This backend supports expiry.
10526 (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) 10524 (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name))
10527 (expirable 10525 (expirable
10528 (gnus-list-range-difference 10526 (range-list-difference
10529 (if total 10527 (if total
10530 (progn 10528 (progn
10531 ;; We need to update the info for 10529 ;; We need to update the info for
@@ -11898,7 +11896,8 @@ Returns nil if no threads were there to be hidden."
11898 (beginning-of-line) 11896 (beginning-of-line)
11899 (let ((start (point)) 11897 (let ((start (point))
11900 (starteol (line-end-position)) 11898 (starteol (line-end-position))
11901 (article (gnus-summary-article-number))) 11899 (article (unless (gnus-summary-article-intangible-p)
11900 (gnus-summary-article-number))))
11902 ;; Go forward until either the buffer ends or the subthread ends. 11901 ;; Go forward until either the buffer ends or the subthread ends.
11903 (when (and (not (eobp)) 11902 (when (and (not (eobp))
11904 (or (zerop (gnus-summary-next-thread 1 t)) 11903 (or (zerop (gnus-summary-next-thread 1 t))
@@ -11912,7 +11911,9 @@ Returns nil if no threads were there to be hidden."
11912 (let ((ol (make-overlay starteol (point) nil t nil))) 11911 (let ((ol (make-overlay starteol (point) nil t nil)))
11913 (overlay-put ol 'invisible 'gnus-sum) 11912 (overlay-put ol 'invisible 'gnus-sum)
11914 (overlay-put ol 'evaporate t))) 11913 (overlay-put ol 'evaporate t)))
11915 (gnus-summary-goto-subject article) 11914 (if article
11915 (gnus-summary-goto-subject article)
11916 (gnus-summary-position-point))
11916 ;; We moved backward past the start point (invisible thread?) 11917 ;; We moved backward past the start point (invisible thread?)
11917 (when (> start (point)) 11918 (when (> start (point))
11918 (goto-char starteol))) 11919 (goto-char starteol)))
@@ -12871,8 +12872,8 @@ UNREAD is a sorted list."
12871 (gnus-find-method-for-group group) 12872 (gnus-find-method-for-group group)
12872 'server-marks) 12873 'server-marks)
12873 (gnus-check-backend-function 'request-set-mark group)) 12874 (gnus-check-backend-function 'request-set-mark group))
12874 (let ((del (gnus-remove-from-range (gnus-info-read info) read)) 12875 (let ((del (range-remove (gnus-info-read info) read))
12875 (add (gnus-remove-from-range read (gnus-info-read info)))) 12876 (add (range-remove read (gnus-info-read info))))
12876 (when (or add del) 12877 (when (or add del)
12877 (unless (gnus-check-group group) 12878 (unless (gnus-check-group group)
12878 (error "Can't open server for %s" group)) 12879 (error "Can't open server for %s" group))
@@ -13130,10 +13131,10 @@ If ALL is a number, fetch this number of articles."
13130 ;; Some nntp servers lie about their active range. When 13131 ;; Some nntp servers lie about their active range. When
13131 ;; this happens, the active range can be in the millions. 13132 ;; this happens, the active range can be in the millions.
13132 ;; Use a compressed range to avoid creating a huge list. 13133 ;; Use a compressed range to avoid creating a huge list.
13133 (gnus-range-difference 13134 (range-difference
13134 (gnus-range-difference (list gnus-newsgroup-active) old) 13135 (range-difference (list gnus-newsgroup-active) old)
13135 gnus-newsgroup-unexist)) 13136 gnus-newsgroup-unexist))
13136 (setq len (gnus-range-length older)) 13137 (setq len (range-length older))
13137 (cond 13138 (cond
13138 ((null older) nil) 13139 ((null older) nil)
13139 ((numberp all) 13140 ((numberp all)
@@ -13150,9 +13151,9 @@ If ALL is a number, fetch this number of articles."
13150 (push max older) 13151 (push max older)
13151 (setq all (1- all) 13152 (setq all (1- all)
13152 max (1- max)))))) 13153 max (1- max))))))
13153 (setq older (gnus-uncompress-range older)))) 13154 (setq older (range-uncompress older))))
13154 (all 13155 (all
13155 (setq older (gnus-uncompress-range older))) 13156 (setq older (range-uncompress older)))
13156 (t 13157 (t
13157 (when (and (numberp gnus-large-newsgroup) 13158 (when (and (numberp gnus-large-newsgroup)
13158 (> len gnus-large-newsgroup)) 13159 (> len gnus-large-newsgroup))
@@ -13187,7 +13188,7 @@ If ALL is a number, fetch this number of articles."
13187 (push max older) 13188 (push max older)
13188 (setq all (1- all) 13189 (setq all (1- all)
13189 max (1- max)))))))))) 13190 max (1- max))))))))))
13190 (setq older (gnus-uncompress-range older)))) 13191 (setq older (range-uncompress older))))
13191 (if (not older) 13192 (if (not older)
13192 (message "No old news.") 13193 (message "No old news.")
13193 (gnus-summary-insert-articles older) 13194 (gnus-summary-insert-articles older)
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index 9a48f710e55..5d0c0e2654b 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -31,6 +31,7 @@
31(autoload 'pop3-movemail "pop3") 31(autoload 'pop3-movemail "pop3")
32(autoload 'pop3-get-message-count "pop3") 32(autoload 'pop3-get-message-count "pop3")
33(require 'mm-util) 33(require 'mm-util)
34(require 'gnus-range)
34(require 'message) ;; for `message-directory' 35(require 'message) ;; for `message-directory'
35 36
36(defvar display-time-mail-function) 37(defvar display-time-mail-function)
@@ -1048,8 +1049,6 @@ This only works when `display-time' is enabled."
1048(autoload 'imap-range-to-message-set "imap") 1049(autoload 'imap-range-to-message-set "imap")
1049(autoload 'nnheader-ms-strip-cr "nnheader") 1050(autoload 'nnheader-ms-strip-cr "nnheader")
1050 1051
1051(autoload 'gnus-compress-sequence "gnus-range")
1052
1053(defvar mail-source-imap-file-coding-system 'binary 1052(defvar mail-source-imap-file-coding-system 'binary
1054 "Coding system for the crashbox made by `mail-source-fetch-imap'.") 1053 "Coding system for the crashbox made by `mail-source-fetch-imap'.")
1055 1054
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 8f11e538c5a..a6c6a16653d 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -4357,7 +4357,11 @@ it is left unchanged."
4357(defun message-update-smtp-method-header () 4357(defun message-update-smtp-method-header ()
4358 "Insert an X-Message-SMTP-Method header according to `message-server-alist'." 4358 "Insert an X-Message-SMTP-Method header according to `message-server-alist'."
4359 (unless (message-fetch-field "X-Message-SMTP-Method") 4359 (unless (message-fetch-field "X-Message-SMTP-Method")
4360 (let ((from (cadr (mail-extract-address-components (message-fetch-field "From")))) 4360 (let ((from (cadr (mail-extract-address-components
4361 (save-restriction
4362 (widen)
4363 (message-narrow-to-headers-or-head)
4364 (message-fetch-field "From")))))
4361 method) 4365 method)
4362 (catch 'exit 4366 (catch 'exit
4363 (dolist (server message-server-alist) 4367 (dolist (server message-server-alist)
@@ -4901,7 +4905,18 @@ If you always want Gnus to send messages in one piece, set
4901 (message-generate-headers '(Lines))) 4905 (message-generate-headers '(Lines)))
4902 ;; Remove some headers. 4906 ;; Remove some headers.
4903 (message-remove-header message-ignored-mail-headers t) 4907 (message-remove-header message-ignored-mail-headers t)
4904 (mail-encode-encoded-word-buffer)) 4908 (mail-encode-encoded-word-buffer)
4909 ;; Then check for suspicious addresses.
4910 (dolist (hdr '("To" "Cc" "Bcc"))
4911 (let ((addr (message-fetch-field hdr)))
4912 (when (stringp addr)
4913 (dolist (address (mail-header-parse-addresses addr t))
4914 (when-let ((warning (textsec-suspicious-p
4915 address 'email-address-header)))
4916 (unless (y-or-n-p
4917 (format "Suspicious address: %s; send anyway?"
4918 warning))
4919 (user-error "Suspicious address %s" address))))))))
4905 (goto-char (point-max)) 4920 (goto-char (point-max))
4906 ;; require one newline at the end. 4921 ;; require one newline at the end.
4907 (or (= (preceding-char) ?\n) 4922 (or (= (preceding-char) ?\n)
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index b110750c098..c40c38a95f9 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -504,8 +504,6 @@ If MODE is not set, try to find mode automatically."
504 (setq coding-system (mm-find-buffer-file-coding-system))) 504 (setq coding-system (mm-find-buffer-file-coding-system)))
505 (setq text (buffer-string)))) 505 (setq text (buffer-string))))
506 (with-temp-buffer 506 (with-temp-buffer
507 (buffer-disable-undo)
508 (mm-enable-multibyte)
509 (insert (cond ((eq charset 'gnus-decoded) 507 (insert (cond ((eq charset 'gnus-decoded)
510 (with-current-buffer (mm-handle-buffer handle) 508 (with-current-buffer (mm-handle-buffer handle)
511 (buffer-string))) 509 (buffer-string)))
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 8b3718ed7e8..c1c5f00ff7f 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -27,6 +27,7 @@
27;;; Code: 27;;; Code:
28 28
29(eval-when-compile (require 'cl-lib)) 29(eval-when-compile (require 'cl-lib))
30(require 'range)
30 31
31(defvar gnus-decode-encoded-word-function) 32(defvar gnus-decode-encoded-word-function)
32(defvar gnus-decode-encoded-address-function) 33(defvar gnus-decode-encoded-address-function)
@@ -44,8 +45,6 @@
44(require 'mm-util) 45(require 'mm-util)
45(require 'gnus-util) 46(require 'gnus-util)
46(autoload 'gnus-remove-odd-characters "gnus-sum") 47(autoload 'gnus-remove-odd-characters "gnus-sum")
47(autoload 'gnus-range-add "gnus-range")
48(autoload 'gnus-remove-from-range "gnus-range")
49;; FIXME none of these are used explicitly in this file. 48;; FIXME none of these are used explicitly in this file.
50(autoload 'gnus-sorted-intersection "gnus-range") 49(autoload 'gnus-sorted-intersection "gnus-range")
51(autoload 'gnus-intersection "gnus-range") 50(autoload 'gnus-intersection "gnus-range")
@@ -1044,10 +1043,9 @@ See `find-file-noselect' for the arguments."
1044 mark 1043 mark
1045 (cond 1044 (cond
1046 ((eq what 'add) 1045 ((eq what 'add)
1047 (gnus-range-add (cdr (assoc mark backend-marks)) range)) 1046 (range-concat (cdr (assoc mark backend-marks)) range))
1048 ((eq what 'del) 1047 ((eq what 'del)
1049 (gnus-remove-from-range 1048 (range-remove (cdr (assoc mark backend-marks)) range))
1050 (cdr (assoc mark backend-marks)) range))
1051 ((eq what 'set) 1049 ((eq what 'set)
1052 range)) 1050 range))
1053 backend-marks))))) 1051 backend-marks)))))
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index cff628061e9..afd5418912f 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -1660,13 +1660,13 @@ If LIMIT, first try to limit the search to the N last articles."
1660 (cdr (assoc '%Seen flags)) 1660 (cdr (assoc '%Seen flags))
1661 (cdr (assoc '%Deleted flags)))) 1661 (cdr (assoc '%Deleted flags))))
1662 (cdr (assoc '%Flagged flags))))) 1662 (cdr (assoc '%Flagged flags)))))
1663 (read (gnus-range-difference 1663 (read (range-difference
1664 (cons start-article high) unread))) 1664 (cons start-article high) unread)))
1665 (when (> start-article 1) 1665 (when (> start-article 1)
1666 (setq read 1666 (setq read
1667 (gnus-range-nconcat 1667 (gnus-range-nconcat
1668 (if (> start-article 1) 1668 (if (> start-article 1)
1669 (gnus-sorted-range-intersection 1669 (range-intersection
1670 (cons 1 (1- start-article)) 1670 (cons 1 (1- start-article))
1671 (gnus-info-read info)) 1671 (gnus-info-read info))
1672 (gnus-info-read info)) 1672 (gnus-info-read info))
@@ -1691,7 +1691,7 @@ If LIMIT, first try to limit the search to the N last articles."
1691 (pop old-marks) 1691 (pop old-marks)
1692 (when (and old-marks 1692 (when (and old-marks
1693 (> start-article 1)) 1693 (> start-article 1))
1694 (setq old-marks (gnus-range-difference 1694 (setq old-marks (range-difference
1695 old-marks 1695 old-marks
1696 (cons start-article high))) 1696 (cons start-article high)))
1697 (setq new-marks (gnus-range-nconcat old-marks new-marks))) 1697 (setq new-marks (gnus-range-nconcat old-marks new-marks)))
@@ -1702,15 +1702,15 @@ If LIMIT, first try to limit the search to the N last articles."
1702 (active (gnus-active group)) 1702 (active (gnus-active group))
1703 (unexists 1703 (unexists
1704 (if completep 1704 (if completep
1705 (gnus-range-difference 1705 (range-difference
1706 active 1706 active
1707 (gnus-compress-sequence existing)) 1707 (gnus-compress-sequence existing))
1708 (gnus-add-to-range 1708 (range-add-list
1709 (cdr old-unexists) 1709 (cdr old-unexists)
1710 (gnus-list-range-difference 1710 (range-list-difference
1711 existing (gnus-active group)))))) 1711 existing (gnus-active group))))))
1712 (when (> (car active) 1) 1712 (when (> (car active) 1)
1713 (setq unexists (gnus-range-add 1713 (setq unexists (range-concat
1714 (cons 1 (1- (car active))) 1714 (cons 1 (1- (car active)))
1715 unexists))) 1715 unexists)))
1716 (if old-unexists 1716 (if old-unexists
@@ -1733,10 +1733,9 @@ If LIMIT, first try to limit the search to the N last articles."
1733(defun nnimap-update-qresync-info (info existing vanished flags) 1733(defun nnimap-update-qresync-info (info existing vanished flags)
1734 ;; Add all the vanished articles to the list of read articles. 1734 ;; Add all the vanished articles to the list of read articles.
1735 (setf (gnus-info-read info) 1735 (setf (gnus-info-read info)
1736 (gnus-add-to-range 1736 (range-add-list
1737 (gnus-add-to-range 1737 (range-add-list
1738 (gnus-range-add (gnus-info-read info) 1738 (range-concat (gnus-info-read info) vanished)
1739 vanished)
1740 (cdr (assq '%Flagged flags))) 1739 (cdr (assq '%Flagged flags)))
1741 (cdr (assq '%Seen flags)))) 1740 (cdr (assq '%Seen flags))))
1742 (let ((marks (gnus-info-marks info))) 1741 (let ((marks (gnus-info-marks info)))
@@ -1750,9 +1749,9 @@ If LIMIT, first try to limit the search to the N last articles."
1750 (setq marks (delq ticks marks)) 1749 (setq marks (delq ticks marks))
1751 (pop ticks) 1750 (pop ticks)
1752 ;; Add the new marks we got. 1751 ;; Add the new marks we got.
1753 (setq ticks (gnus-add-to-range ticks new-marks)) 1752 (setq ticks (range-add-list ticks new-marks))
1754 ;; Remove the marks from messages that don't have them. 1753 ;; Remove the marks from messages that don't have them.
1755 (setq ticks (gnus-remove-from-range 1754 (setq ticks (range-remove
1756 ticks 1755 ticks
1757 (gnus-compress-sequence 1756 (gnus-compress-sequence
1758 (gnus-sorted-complement existing new-marks)))) 1757 (gnus-sorted-complement existing new-marks))))
@@ -1762,7 +1761,7 @@ If LIMIT, first try to limit the search to the N last articles."
1762 ;; Add vanished to the list of unexisting articles. 1761 ;; Add vanished to the list of unexisting articles.
1763 (when vanished 1762 (when vanished
1764 (let* ((old-unexists (assq 'unexist marks)) 1763 (let* ((old-unexists (assq 'unexist marks))
1765 (unexists (gnus-range-add (cdr old-unexists) vanished))) 1764 (unexists (range-concat (cdr old-unexists) vanished)))
1766 (if old-unexists 1765 (if old-unexists
1767 (setcdr old-unexists unexists) 1766 (setcdr old-unexists unexists)
1768 (push (cons 'unexist unexists) marks))) 1767 (push (cons 'unexist unexists) marks)))
@@ -2242,7 +2241,7 @@ Return the server's response to the SELECT or EXAMINE command."
2242 (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t) 2241 (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t)
2243 (setq sequence (string-to-number (match-string 1))) 2242 (setq sequence (string-to-number (match-string 1)))
2244 (when (setq range (cadr (assq sequence sequences))) 2243 (when (setq range (cadr (assq sequence sequences)))
2245 (push (gnus-uncompress-range range) copied))) 2244 (push (range-uncompress range) copied)))
2246 (gnus-compress-sequence (sort (apply #'nconc copied) #'<)))) 2245 (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
2247 2246
2248(defun nnimap-new-articles (flags) 2247(defun nnimap-new-articles (flags)
diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el
index 690761a2d6c..30f473b1291 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -1006,10 +1006,10 @@ This variable is set by `nnmaildir-request-article'.")
1006 existing (nnmaildir--grp-nlist group) 1006 existing (nnmaildir--grp-nlist group)
1007 existing (mapcar #'car existing) 1007 existing (mapcar #'car existing)
1008 existing (nreverse existing) 1008 existing (nreverse existing)
1009 existing (gnus-compress-sequence existing 'always-list) 1009 existing (range-compress-list existing)
1010 missing (list (cons 1 (nnmaildir--group-maxnum 1010 missing (list (cons 1 (nnmaildir--group-maxnum
1011 nnmaildir--cur-server group))) 1011 nnmaildir--cur-server group)))
1012 missing (gnus-range-difference missing existing) 1012 missing (range-difference missing existing)
1013 dir (nnmaildir--srv-dir nnmaildir--cur-server) 1013 dir (nnmaildir--srv-dir nnmaildir--cur-server)
1014 dir (nnmaildir--srvgrp-dir dir gname) 1014 dir (nnmaildir--srvgrp-dir dir gname)
1015 dir (nnmaildir--nndir dir) 1015 dir (nnmaildir--nndir dir)
@@ -1076,10 +1076,10 @@ This variable is set by `nnmaildir-request-article'.")
1076 (let ((article (nnmaildir--flist-art flist prefix))) 1076 (let ((article (nnmaildir--flist-art flist prefix)))
1077 (when article 1077 (when article
1078 (push (nnmaildir--art-num article) article-list)))))) 1078 (push (nnmaildir--art-num article) article-list))))))
1079 (setq ranges (gnus-add-to-range ranges (sort article-list #'<))))) 1079 (setq ranges (range-add-list ranges (sort article-list #'<)))))
1080 (if (eq mark 'read) (setq read ranges) 1080 (if (eq mark 'read) (setq read ranges)
1081 (if ranges (setq marks (cons (cons mark ranges) marks))))) 1081 (if ranges (setq marks (cons (cons mark ranges) marks)))))
1082 (setf (gnus-info-read info) (gnus-range-add read missing)) 1082 (setf (gnus-info-read info) (range-concat read missing))
1083 (gnus-info-set-marks info marks 'extend) 1083 (gnus-info-set-marks info marks 'extend)
1084 (setf (nnmaildir--grp-mmth group) new-mmth) 1084 (setf (nnmaildir--grp-mmth group) new-mmth)
1085 info))) 1085 info)))
@@ -1548,11 +1548,11 @@ This variable is set by `nnmaildir-request-article'.")
1548 (unless group 1548 (unless group
1549 (setf (nnmaildir--srv-error nnmaildir--cur-server) 1549 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1550 (if gname (concat "No such group: " gname) "No current group")) 1550 (if gname (concat "No such group: " gname) "No current group"))
1551 (throw 'return (gnus-uncompress-range ranges))) 1551 (throw 'return (range-uncompress ranges)))
1552 (setq gname (nnmaildir--grp-name group) 1552 (setq gname (nnmaildir--grp-name group)
1553 pgname (nnmaildir--pgname nnmaildir--cur-server gname)) 1553 pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1554 (if (nnmaildir--param pgname 'read-only) 1554 (if (nnmaildir--param pgname 'read-only)
1555 (throw 'return (gnus-uncompress-range ranges))) 1555 (throw 'return (range-uncompress ranges)))
1556 (setq time (nnmaildir--param pgname 'expire-age)) 1556 (setq time (nnmaildir--param pgname 'expire-age))
1557 (unless time 1557 (unless time
1558 (setq time (or (and nnmail-expiry-wait-function 1558 (setq time (or (and nnmail-expiry-wait-function
@@ -1564,7 +1564,7 @@ This variable is set by `nnmaildir-request-article'.")
1564 (setq time (round (* time 86400)))))) 1564 (setq time (round (* time 86400))))))
1565 (when no-force 1565 (when no-force
1566 (unless (integerp time) ;; handle 'never 1566 (unless (integerp time) ;; handle 'never
1567 (throw 'return (gnus-uncompress-range ranges))) 1567 (throw 'return (range-uncompress ranges)))
1568 (setq boundary (time-since time))) 1568 (setq boundary (time-since time)))
1569 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) 1569 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1570 dir (nnmaildir--srvgrp-dir dir gname) 1570 dir (nnmaildir--srvgrp-dir dir gname)
@@ -1686,7 +1686,7 @@ This variable is set by `nnmaildir-request-article'.")
1686 (setf (nnmaildir--srv-error nnmaildir--cur-server) 1686 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1687 (concat "No such group: " gname)) 1687 (concat "No such group: " gname))
1688 (dolist (action actions) 1688 (dolist (action actions)
1689 (setq ranges (gnus-range-add ranges (car action)))) 1689 (setq ranges (range-concat ranges (car action))))
1690 (throw 'return ranges)) 1690 (throw 'return ranges))
1691 (setq nlist (nnmaildir--grp-nlist group) 1691 (setq nlist (nnmaildir--grp-nlist group)
1692 marksdir (nnmaildir--srv-dir nnmaildir--cur-server) 1692 marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el
index 8ca1cf0fe8b..4e8e329f983 100644
--- a/lisp/gnus/nnmairix.el
+++ b/lisp/gnus/nnmairix.el
@@ -597,7 +597,7 @@ Other back ends might or might not work.")
597 (dolist (cur actions) 597 (dolist (cur actions)
598 (let ((type (nth 1 cur)) 598 (let ((type (nth 1 cur))
599 (cmdmarks (nth 2 cur)) 599 (cmdmarks (nth 2 cur))
600 (range (gnus-uncompress-range (nth 0 cur))) 600 (range (range-uncompress (nth 0 cur)))
601 mid ogroup temp) ;; number method 601 mid ogroup temp) ;; number method
602 (when (and corr 602 (when (and corr
603 (not (zerop (cadr corr)))) 603 (not (zerop (cadr corr))))
diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el
index 5a350aac746..96ecc34e156 100644
--- a/lisp/gnus/nnmbox.el
+++ b/lisp/gnus/nnmbox.el
@@ -529,7 +529,7 @@
529 ;; add article to index, either by building complete list 529 ;; add article to index, either by building complete list
530 ;; in reverse order, or as a list of ranges. 530 ;; in reverse order, or as a list of ranges.
531 (if (not nnmbox-group-building-active-articles) 531 (if (not nnmbox-group-building-active-articles)
532 (setcdr entry (gnus-add-to-range (cdr entry) (list article))) 532 (setcdr entry (range-add-list (cdr entry) (list article)))
533 (when (memq article (cdr entry)) 533 (when (memq article (cdr entry))
534 (switch-to-buffer nnmbox-mbox-buffer) 534 (switch-to-buffer nnmbox-mbox-buffer)
535 (error "Article %s:%d already exists!" group article)) 535 (error "Article %s:%d already exists!" group article))
@@ -548,10 +548,10 @@
548 nnmbox-group-active-articles) 548 nnmbox-group-active-articles)
549 (car nnmbox-group-active-articles))))) 549 (car nnmbox-group-active-articles)))))
550 ;; remove article from index 550 ;; remove article from index
551 (setcdr entry (gnus-remove-from-range (cdr entry) (list article))))) 551 (setcdr entry (range-remove (cdr entry) (list article)))))
552 552
553(defun nnmbox-is-article-active-p (article) 553(defun nnmbox-is-article-active-p (article)
554 (gnus-member-of-range 554 (range-member-p
555 article 555 article
556 (cdr (assoc nnmbox-current-group 556 (cdr (assoc nnmbox-current-group
557 nnmbox-group-active-articles)))) 557 nnmbox-group-active-articles))))
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el
index afdb0c780a5..7fe2b516cce 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -1078,21 +1078,20 @@ Use the nov database for the current group if available."
1078 ;; #### doing anything on them. 1078 ;; #### doing anything on them.
1079 ;; 2 a/ read articles: 1079 ;; 2 a/ read articles:
1080 (let ((read (gnus-info-read info))) 1080 (let ((read (gnus-info-read info)))
1081 (setq read (gnus-remove-from-range read (list new-number))) 1081 (setq read (range-remove read (list new-number)))
1082 (when (gnus-member-of-range old-number read) 1082 (when (range-member-p old-number read)
1083 (setq read (gnus-remove-from-range read (list old-number))) 1083 (setq read (range-remove read (list old-number)))
1084 (setq read (gnus-add-to-range read (list new-number)))) 1084 (setq read (range-add-list read (list new-number))))
1085 (setf (gnus-info-read info) read)) 1085 (setf (gnus-info-read info) read))
1086 ;; 2 b/ marked articles: 1086 ;; 2 b/ marked articles:
1087 (let ((oldmarks (gnus-info-marks info)) 1087 (let ((oldmarks (gnus-info-marks info))
1088 mark newmarks) 1088 mark newmarks)
1089 (while (setq mark (pop oldmarks)) 1089 (while (setq mark (pop oldmarks))
1090 (setcdr mark (gnus-remove-from-range (cdr mark) 1090 (setcdr mark (range-remove (cdr mark) (list new-number)))
1091 (list new-number))) 1091 (when (range-member-p old-number (cdr mark))
1092 (when (gnus-member-of-range old-number (cdr mark)) 1092 (setcdr mark (range-remove (cdr mark)
1093 (setcdr mark (gnus-remove-from-range (cdr mark) 1093 (list old-number)))
1094 (list old-number))) 1094 (setcdr mark (range-add-list (cdr mark)
1095 (setcdr mark (gnus-add-to-range (cdr mark)
1096 (list new-number)))) 1095 (list new-number))))
1097 (push mark newmarks)) 1096 (push mark newmarks))
1098 (setf (gnus-info-marks info) newmarks)) 1097 (setf (gnus-info-marks info) newmarks))
diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el
index 9d744ea411e..205456a57df 100644
--- a/lisp/gnus/nnselect.el
+++ b/lisp/gnus/nnselect.el
@@ -207,7 +207,7 @@ as `(keyfunc member)' and the corresponding element is just
207 (inline-quote 207 (inline-quote
208 (cond 208 (cond
209 ((eq ,type 'range) 209 ((eq ,type 'range)
210 (nnselect-categorize (gnus-uncompress-range ,articles) 210 (nnselect-categorize (range-uncompress ,articles)
211 #'nnselect-article-group #'nnselect-article-number)) 211 #'nnselect-article-group #'nnselect-article-number))
212 ((eq ,type 'tuple) 212 ((eq ,type 'tuple)
213 (nnselect-categorize ,articles 213 (nnselect-categorize ,articles
@@ -542,10 +542,10 @@ If this variable is nil, or if the provided function returns nil,
542 (group-info (gnus-get-info artgroup)) 542 (group-info (gnus-get-info artgroup))
543 (marks (gnus-info-marks group-info)) 543 (marks (gnus-info-marks group-info))
544 (unread (gnus-uncompress-sequence 544 (unread (gnus-uncompress-sequence
545 (gnus-range-difference (gnus-active artgroup) 545 (range-difference (gnus-active artgroup)
546 (gnus-info-read group-info))))) 546 (gnus-info-read group-info)))))
547 (setf (gnus-info-read info) 547 (setf (gnus-info-read info)
548 (gnus-add-to-range 548 (range-add-list
549 (gnus-info-read info) 549 (gnus-info-read info)
550 (delq nil (mapcar 550 (delq nil (mapcar
551 (lambda (art) 551 (lambda (art)
@@ -567,7 +567,7 @@ If this variable is nil, or if the provided function returns nil,
567 artids)) 567 artids))
568 (t 568 (t
569 (setq mark-list 569 (setq mark-list
570 (gnus-uncompress-range mark-list)) 570 (range-uncompress mark-list))
571 (mapcar 571 (mapcar
572 (lambda (id) 572 (lambda (id)
573 (when (memq (cdr id) mark-list) 573 (when (memq (cdr id) mark-list)
@@ -866,16 +866,16 @@ article came from is also searched."
866 (when (and (gnus-check-backend-function 866 (when (and (gnus-check-backend-function
867 'request-set-mark artgroup) 867 'request-set-mark artgroup)
868 (not (gnus-article-unpropagatable-p type))) 868 (not (gnus-article-unpropagatable-p type)))
869 (let* ((old (gnus-list-range-intersection 869 (let* ((old (range-list-intersection
870 artlist 870 artlist
871 (alist-get type (gnus-info-marks group-info)))) 871 (alist-get type (gnus-info-marks group-info))))
872 (del (gnus-remove-from-range (copy-tree old) list)) 872 (del (range-remove (copy-tree old) list))
873 (add (gnus-remove-from-range (copy-tree list) old))) 873 (add (range-remove (copy-tree list) old)))
874 (when add (push (list add 'add (list type)) delta-marks)) 874 (when add (push (list add 'add (list type)) delta-marks))
875 (when del 875 (when del
876 ;; Don't delete marks from outside the active range. 876 ;; Don't delete marks from outside the active range.
877 ;; This shouldn't happen, but is a sanity check. 877 ;; This shouldn't happen, but is a sanity check.
878 (setq del (gnus-sorted-range-intersection 878 (setq del (range-intersection
879 (gnus-active artgroup) del)) 879 (gnus-active artgroup) del))
880 (push (list del 'del (list type)) delta-marks)))) 880 (push (list del 'del (list type)) delta-marks))))
881 881
@@ -910,18 +910,18 @@ article came from is also searched."
910 (< (car elt1) (car elt2)))))) 910 (< (car elt1) (car elt2))))))
911 (t 911 (t
912 (setq list 912 (setq list
913 (gnus-compress-sequence 913 (range-compress-list
914 (gnus-sorted-union 914 (gnus-sorted-union
915 (gnus-sorted-difference 915 (gnus-sorted-difference
916 (gnus-uncompress-sequence 916 (gnus-uncompress-sequence
917 (alist-get type (gnus-info-marks group-info))) 917 (alist-get type (gnus-info-marks group-info)))
918 artlist) 918 artlist)
919 (sort list #'<)) t))) 919 (sort list #'<)))))
920 920
921 ;; When exiting the group, everything that's previously been 921 ;; When exiting the group, everything that's previously been
922 ;; unseen is now seen. 922 ;; unseen is now seen.
923 (when (eq type 'seen) 923 (when (eq type 'seen)
924 (setq list (gnus-range-add 924 (setq list (range-concat
925 list (cdr (assoc artgroup select-unseen)))))) 925 list (cdr (assoc artgroup select-unseen))))))
926 926
927 (when (or list (eq type 'unexist)) 927 (when (or list (eq type 'unexist))
@@ -944,9 +944,9 @@ article came from is also searched."
944 ;; update read and unread 944 ;; update read and unread
945 (gnus-update-read-articles 945 (gnus-update-read-articles
946 artgroup 946 artgroup
947 (gnus-uncompress-range 947 (range-uncompress
948 (gnus-add-to-range 948 (range-add-list
949 (gnus-remove-from-range 949 (range-remove
950 old-unread 950 old-unread
951 (cdr (assoc artgroup select-reads))) 951 (cdr (assoc artgroup select-reads)))
952 (sort (cdr (assoc artgroup select-unreads)) #'<)))) 952 (sort (cdr (assoc artgroup select-unreads)) #'<))))
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 7478a2dd0af..cc87a707ce6 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -365,7 +365,7 @@ It is computed from the marks of individual component groups.")
365 (lambda (article) 365 (lambda (article)
366 (nnvirtual-reverse-map-article 366 (nnvirtual-reverse-map-article
367 group article)) 367 group article))
368 (gnus-uncompress-range 368 (range-uncompress
369 (gnus-group-expire-articles-1 group)))))) 369 (gnus-group-expire-articles-1 group))))))
370 (sort (delq nil unexpired) #'<))) 370 (sort (delq nil unexpired) #'<)))
371 371
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index e000a68a823..98a1b11e088 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -496,9 +496,16 @@ suitable file is found, return nil."
496 (let ((pt2 (with-current-buffer standard-output (point))) 496 (let ((pt2 (with-current-buffer standard-output (point)))
497 (remapped (command-remapping function))) 497 (remapped (command-remapping function)))
498 (unless (memq remapped '(ignore undefined)) 498 (unless (memq remapped '(ignore undefined))
499 (let ((keys (where-is-internal 499 (let* ((all-keys (where-is-internal
500 (or remapped function) overriding-local-map nil nil)) 500 (or remapped function) overriding-local-map nil nil))
501 non-modified-keys) 501 (seps (seq-group-by
502 (lambda (key)
503 (and (vectorp key)
504 (eq (elt key 0) 'menu-bar)))
505 all-keys))
506 (keys (cdr (assq nil seps)))
507 (menus (cdr (assq t seps)))
508 non-modified-keys)
502 (if (and (eq function 'self-insert-command) 509 (if (and (eq function 'self-insert-command)
503 (vectorp (car-safe keys)) 510 (vectorp (car-safe keys))
504 (consp (aref (car keys) 0))) 511 (consp (aref (car keys) 0)))
@@ -522,24 +529,42 @@ suitable file is found, return nil."
522 ;; don't mention them one by one. 529 ;; don't mention them one by one.
523 (if (< (length non-modified-keys) 10) 530 (if (< (length non-modified-keys) 10)
524 (with-current-buffer standard-output 531 (with-current-buffer standard-output
525 (insert (mapconcat #'help--key-description-fontified 532 (help-fns--insert-bindings keys))
526 keys ", ")))
527 (dolist (key non-modified-keys) 533 (dolist (key non-modified-keys)
528 (setq keys (delq key keys))) 534 (setq keys (delq key keys)))
529 (if keys 535 (if keys
530 (with-current-buffer standard-output 536 (with-current-buffer standard-output
531 (insert (mapconcat #'help--key-description-fontified 537 (help-fns--insert-bindings keys)
532 keys ", "))
533 (insert ", and many ordinary text characters")) 538 (insert ", and many ordinary text characters"))
534 (princ "many ordinary text characters")))) 539 (princ "many ordinary text characters."))))
535 (when (or remapped keys non-modified-keys) 540 (when (or remapped keys non-modified-keys)
536 (princ ".") 541 (princ ".")
537 (terpri))))) 542 (terpri)))
538 543
539 (with-current-buffer standard-output 544 (with-current-buffer standard-output
540 (fill-region-as-paragraph pt2 (point)) 545 (fill-region-as-paragraph pt2 (point))
541 (unless (looking-back "\n\n" (- (point) 2)) 546 (unless (bolp)
542 (terpri)))))) 547 (insert "\n"))
548 (when menus
549 (let ((start (point)))
550 (insert (concat "It can "
551 (and keys "also ")
552 "be invoked from the menu: "))
553 ;; FIXME: Should insert menu names instead of key
554 ;; binding names.
555 (help-fns--insert-bindings menus)
556 (insert ".")
557 (fill-region-as-paragraph start (point))))
558 (ensure-empty-lines)))))))
559
560(defun help-fns--insert-bindings (keys)
561 (seq-do-indexed (lambda (key i)
562 (insert
563 (cond ((zerop i) "")
564 ((= i (1- (length keys))) " and ")
565 (t ", ")))
566 (insert (help--key-description-fontified key)))
567 keys))
543 568
544(defun help-fns--compiler-macro (function) 569(defun help-fns--compiler-macro (function)
545 (let ((handler (function-get function 'compiler-macro))) 570 (let ((handler (function-get function 'compiler-macro)))
diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index b70d4a75690..53e6f779b31 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -727,11 +727,12 @@ with completion and history."
727 (cdr (member last-used-face hi-lock-face-defaults)) 727 (cdr (member last-used-face hi-lock-face-defaults))
728 hi-lock-face-defaults)) 728 hi-lock-face-defaults))
729 face) 729 face)
730 (if (and hi-lock-auto-select-face (not current-prefix-arg)) 730 (if (and hi-lock-auto-select-face (not current-prefix-arg))
731 (setq face (or (pop hi-lock--unused-faces) (car defaults))) 731 (setq face (or (pop hi-lock--unused-faces) (car defaults)))
732 (setq face (completing-read 732 (setq face (symbol-name
733 (format-prompt "Highlight using face" (car defaults)) 733 (read-face-name
734 obarray 'facep t nil 'face-name-history defaults)) 734 (format-prompt "Highlight using face" (car defaults))
735 defaults)))
735 ;; Update list of un-used faces. 736 ;; Update list of un-used faces.
736 (setq hi-lock--unused-faces (remove face hi-lock--unused-faces)) 737 (setq hi-lock--unused-faces (remove face hi-lock--unused-faces))
737 ;; Grow the list of defaults. 738 ;; Grow the list of defaults.
@@ -855,7 +856,8 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search."
855 nil) 856 nil)
856 857
857;;; Mouse support 858;;; Mouse support
858(defun hi-lock-symbol-at-mouse (event) 859(defalias 'highlight-symbol-at-mouse 'hi-lock-face-symbol-at-mouse)
860(defun hi-lock-face-symbol-at-mouse (event)
859 "Highlight symbol at mouse click EVENT." 861 "Highlight symbol at mouse click EVENT."
860 (interactive "e") 862 (interactive "e")
861 (save-excursion 863 (save-excursion
@@ -865,13 +867,13 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search."
865;;;###autoload 867;;;###autoload
866(defun hi-lock-context-menu (menu click) 868(defun hi-lock-context-menu (menu click)
867 "Populate MENU with a menu item to highlight symbol at CLICK." 869 "Populate MENU with a menu item to highlight symbol at CLICK."
868 (save-excursion 870 (when (thing-at-mouse click 'symbol)
869 (mouse-set-point click) 871 (define-key-after menu [highlight-search-separator] menu-bar-separator
870 (when (symbol-at-point) 872 'middle-separator)
871 (define-key-after menu [highlight-search-separator] menu-bar-separator) 873 (define-key-after menu [highlight-search-mouse]
872 (define-key-after menu [highlight-search-mouse] 874 '(menu-item "Highlight Symbol" highlight-symbol-at-mouse
873 '(menu-item "Highlight Symbol" highlight-symbol-at-mouse 875 :help "Highlight symbol at point")
874 :help "Highlight symbol at point")))) 876 'highlight-search-separator))
875 menu) 877 menu)
876 878
877(provide 'hi-lock) 879(provide 'hi-lock)
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index b81df8567bd..9b0bbb70df9 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -2353,7 +2353,8 @@ for deletion instead."
2353 (interactive) 2353 (interactive)
2354 (image-dired--with-marked 2354 (image-dired--with-marked
2355 (image-dired-delete-char) 2355 (image-dired-delete-char)
2356 (backward-char)) 2356 (unless (bobp)
2357 (backward-char)))
2357 (image-dired--line-up-with-method) 2358 (image-dired--line-up-with-method)
2358 (with-current-buffer (image-dired-associated-dired-buffer) 2359 (with-current-buffer (image-dired-associated-dired-buffer)
2359 (dired-do-delete))) 2360 (dired-do-delete)))
diff --git a/lisp/indent.el b/lisp/indent.el
index 40669b38424..d20c8053c5f 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -77,10 +77,11 @@ This variable has no effect unless `tab-always-indent' is `complete'."
77 :group 'indent 77 :group 'indent
78 :type '(choice 78 :type '(choice
79 (const :tag "Always complete" nil) 79 (const :tag "Always complete" nil)
80 (const :tag "Unless at the end of a line" 'eol) 80 (const :tag "Unless at the end of a line" eol)
81 (const :tag "Unless looking at a word" 'word) 81 (const :tag "Unless looking at a word" word)
82 (const :tag "Unless at a word or parenthesis" 'word-or-paren) 82 (const :tag "Unless at a word or parenthesis" word-or-paren)
83 (const :tag "Unless at a word, parenthesis, or punctuation." 'word-or-paren-or-punct)) 83 (const :tag "Unless at a word, parenthesis, or punctuation."
84 word-or-paren-or-punct))
84 :version "28.1") 85 :version "28.1")
85 86
86(defvar indent-line-ignored-functions '(indent-relative 87(defvar indent-line-ignored-functions '(indent-relative
@@ -170,7 +171,7 @@ prefix argument is ignored."
170 (let ((old-tick (buffer-chars-modified-tick)) 171 (let ((old-tick (buffer-chars-modified-tick))
171 (old-point (point)) 172 (old-point (point))
172 (old-indent (current-indentation)) 173 (old-indent (current-indentation))
173 (syn `(,(syntax-after (point))))) 174 (syn (syntax-after (point))))
174 175
175 ;; Indent the line. 176 ;; Indent the line.
176 (or (not (eq (indent--funcall-widened indent-line-function) 'noindent)) 177 (or (not (eq (indent--funcall-widened indent-line-function) 'noindent))
@@ -182,21 +183,21 @@ prefix argument is ignored."
182 (cond 183 (cond
183 ;; If the text was already indented right, try completion. 184 ;; If the text was already indented right, try completion.
184 ((and (eq tab-always-indent 'complete) 185 ((and (eq tab-always-indent 'complete)
185 (eq old-point (point)) 186 (eql old-point (point))
186 (eq old-tick (buffer-chars-modified-tick)) 187 (eql old-tick (buffer-chars-modified-tick))
187 (or (null tab-first-completion) 188 (or (null tab-first-completion)
188 (eq last-command this-command) 189 (eq last-command this-command)
189 (and (equal tab-first-completion 'eol) 190 (and (eq tab-first-completion 'eol)
190 (eolp)) 191 (eolp))
191 (and (member tab-first-completion 192 (and (memq tab-first-completion
192 '(word word-or-paren word-or-paren-or-punct)) 193 '(word word-or-paren word-or-paren-or-punct))
193 (not (member 2 syn))) 194 (not (eql 2 syn)))
194 (and (member tab-first-completion 195 (and (memq tab-first-completion
195 '(word-or-paren word-or-paren-or-punct)) 196 '(word-or-paren word-or-paren-or-punct))
196 (not (or (member 4 syn) 197 (not (or (eql 4 syn)
197 (member 5 syn)))) 198 (eql 5 syn))))
198 (and (equal tab-first-completion 'word-or-paren-or-punct) 199 (and (eq tab-first-completion 'word-or-paren-or-punct)
199 (not (member 1 syn))))) 200 (not (eql 1 syn)))))
200 (completion-at-point)) 201 (completion-at-point))
201 202
202 ;; If a prefix argument was given, rigidly indent the following 203 ;; If a prefix argument was given, rigidly indent the following
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index 080e7898c47..63ac455ea6a 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1440,6 +1440,10 @@ Setup `char-width-table' appropriate for non-CJK language environment."
1440 (set-char-table-range char-script-table range 'tibetan)) 1440 (set-char-table-range char-script-table range 'tibetan))
1441 'tibetan) 1441 'tibetan)
1442 1442
1443;; Fix some exceptions that blocks.awk/Blocks.txt couldn't get right.
1444(set-char-table-range char-script-table '(#x2ea . #x2eb) 'bopomofo)
1445(set-char-table-range char-script-table #xab65 'greek)
1446
1443 1447
1444;;; Setting unicode-category-table. 1448;;; Setting unicode-category-table.
1445 1449
@@ -1522,8 +1526,11 @@ Setup `char-width-table' appropriate for non-CJK language environment."
1522 1526
1523;; We can't use the \N{name} things here, because this file is used 1527;; We can't use the \N{name} things here, because this file is used
1524;; too early in the build process. 1528;; too early in the build process.
1525(defvar glyphless--bidi-control-characters 1529(defvar bidi-control-characters
1526 '(#x202a ; ?\N{left-to-right embedding} 1530 '(#x200e ; ?\N{left-to-right mark}
1531 #x200f ; ?\N{right-to-left mark}
1532 #x061c ; ?\N{arabic letter mark}
1533 #x202a ; ?\N{left-to-right embedding}
1527 #x202b ; ?\N{right-to-left embedding} 1534 #x202b ; ?\N{right-to-left embedding}
1528 #x202d ; ?\N{left-to-right override} 1535 #x202d ; ?\N{left-to-right override}
1529 #x202e ; ?\N{right-to-left override} 1536 #x202e ; ?\N{right-to-left override}
@@ -1531,7 +1538,14 @@ Setup `char-width-table' appropriate for non-CJK language environment."
1531 #x2067 ; ?\N{right-to-left isolate} 1538 #x2067 ; ?\N{right-to-left isolate}
1532 #x2068 ; ?\N{first strong isolate} 1539 #x2068 ; ?\N{first strong isolate}
1533 #x202c ; ?\N{pop directional formatting} 1540 #x202c ; ?\N{pop directional formatting}
1534 #x2069)) ; ?\N{pop directional isolate}) 1541 #x2069) ; ?\N{pop directional isolate}
1542 "List of bidirectional control characters.")
1543
1544(defun bidi-string-strip-control-characters (string)
1545 "Strip bidi control characters from STRING and return the result."
1546 (apply #'string (seq-filter (lambda (char)
1547 (not (memq char bidi-control-characters)))
1548 string)))
1535 1549
1536(defun update-glyphless-char-display (&optional variable value) 1550(defun update-glyphless-char-display (&optional variable value)
1537 "Make the setting of `glyphless-char-display-control' take effect. 1551 "Make the setting of `glyphless-char-display-control' take effect.
@@ -1578,8 +1592,7 @@ option `glyphless-char-display'."
1578 (or (aref char-acronym-table from) 1592 (or (aref char-acronym-table from)
1579 "UNK"))) 1593 "UNK")))
1580 (when (or (eq target 'format-control) 1594 (when (or (eq target 'format-control)
1581 (memq from 1595 (memq from bidi-control-characters))
1582 glyphless--bidi-control-characters))
1583 (set-char-table-range glyphless-char-display 1596 (set-char-table-range glyphless-char-display
1584 from this-method))) 1597 from this-method)))
1585 (setq from (1+ from)))))) 1598 (setq from (1+ from))))))
diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el
index 264a1f09dc2..df488708afa 100644
--- a/lisp/international/emoji.el
+++ b/lisp/international/emoji.el
@@ -55,6 +55,14 @@
55 "Face for emojis that have derivations." 55 "Face for emojis that have derivations."
56 :version "29.1") 56 :version "29.1")
57 57
58(defvar emoji-alternate-names nil
59 "Alist of emojis and lists of alternate names for the emojis.
60Each element in the alist should have the emoji (as a string) as
61the first element, and the rest of the elements should be strings
62representing names. For instance:
63
64 (\"🤗\" \"hug\" \"hugging\" \"kind\")")
65
58(defvar emoji--labels nil) 66(defvar emoji--labels nil)
59(defvar emoji--all-bases nil) 67(defvar emoji--all-bases nil)
60(defvar emoji--derived nil) 68(defvar emoji--derived nil)
@@ -90,8 +98,9 @@ of selecting from emoji display."
90;;;###autoload 98;;;###autoload
91(defun emoji-search () 99(defun emoji-search ()
92 "Choose and insert an emoji glyph by typing its Unicode name. 100 "Choose and insert an emoji glyph by typing its Unicode name.
93This command prompts for an emoji name, with completion, and inserts it. 101This command prompts for an emoji name, with completion, and
94It recognizes the Unicode Standard names of emoji." 102inserts it. It recognizes the Unicode Standard names of emoji,
103and also consults the `emoji-alternate-names' alist."
95 (interactive "*") 104 (interactive "*")
96 (emoji--init) 105 (emoji--init)
97 (emoji--choose-emoji)) 106 (emoji--choose-emoji))
@@ -647,29 +656,47 @@ We prefer the earliest unique letter."
647 656
648(defun emoji--choose-emoji () 657(defun emoji--choose-emoji ()
649 ;; Use the list of names. 658 ;; Use the list of names.
650 (let ((name 659 (let* ((table
651 (completing-read 660 (if (not emoji-alternate-names)
652 "Insert emoji: " 661 ;; If we don't have alternate names, do the efficient version.
653 (lambda (string pred action) 662 emoji--all-bases
654 (if (eq action 'metadata) 663 ;; Compute all the (possibly non-unique) names.
655 (list 'metadata 664 (let ((table nil))
656 (cons 665 (maphash
657 'affixation-function 666 (lambda (name glyph)
658 ;; Add the glyphs to the start of the displayed 667 (push (concat name "\t" glyph) table))
659 ;; strings when TAB-ing. 668 emoji--all-bases)
660 (lambda (strings) 669 (dolist (elem emoji-alternate-names)
661 (mapcar 670 (dolist (name (cdr elem))
662 (lambda (name) 671 (push (concat name "\t" (car elem)) table)))
663 (list name 672 (sort table #'string<))))
664 (concat 673 (name
665 (or (gethash name emoji--all-bases) " ") 674 (completing-read
666 "\t") 675 "Insert emoji: "
667 "")) 676 (lambda (string pred action)
668 strings)))) 677 (if (eq action 'metadata)
669 (complete-with-action action emoji--all-bases string pred))) 678 (list 'metadata
670 nil t))) 679 (cons
680 'affixation-function
681 ;; Add the glyphs to the start of the displayed
682 ;; strings when TAB-ing.
683 (lambda (strings)
684 (mapcar
685 (lambda (name)
686 (if emoji-alternate-names
687 (list name "" "")
688 (list name
689 (concat
690 (or (gethash name emoji--all-bases) " ")
691 "\t")
692 "")))
693 strings))))
694 (complete-with-action action table string pred)))
695 nil t)))
671 (when (cl-plusp (length name)) 696 (when (cl-plusp (length name))
672 (let* ((glyph (gethash name emoji--all-bases)) 697 (let* ((glyph (if emoji-alternate-names
698 (cadr (split-string name "\t"))
699 (gethash name emoji--all-bases)))
673 (derived (gethash glyph emoji--derived))) 700 (derived (gethash glyph emoji--derived)))
674 (if (not derived) 701 (if (not derived)
675 ;; Simple glyph with no derivations. 702 ;; Simple glyph with no derivations.
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index a2e0838a427..bd557df180c 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -231,7 +231,6 @@
231 (elymaic #x10FE0) 231 (elymaic #x10FE0)
232 (old-uyghur #x10F70) 232 (old-uyghur #x10F70)
233 (mahajani #x11150) 233 (mahajani #x11150)
234 (sinhala-archaic-number #x111E1)
235 (khojki #x11200) 234 (khojki #x11200)
236 (khudawadi #x112B0) 235 (khudawadi #x112B0)
237 (grantha #x11305) 236 (grantha #x11305)
@@ -253,7 +252,6 @@
253 (gunjala-gondi #x11D60) 252 (gunjala-gondi #x11D60)
254 (makasar #x11EE0) 253 (makasar #x11EE0)
255 (cuneiform #x12000) 254 (cuneiform #x12000)
256 (cuneiform-numbers-and-punctuation #x12400)
257 (cypro-minoan #x12F90) 255 (cypro-minoan #x12F90)
258 (egyptian #x13000) 256 (egyptian #x13000)
259 (mro #x16A40) 257 (mro #x16A40)
@@ -262,7 +260,6 @@
262 (pahawh-hmong #x16B11) 260 (pahawh-hmong #x16B11)
263 (medefaidrin #x16E40) 261 (medefaidrin #x16E40)
264 (tangut #x17000) 262 (tangut #x17000)
265 (tangut-components #x18800)
266 (khitan-small-script #x18B00) 263 (khitan-small-script #x18B00)
267 (nushu #x1B170) 264 (nushu #x1B170)
268 (duployan-shorthand #x1BC20) 265 (duployan-shorthand #x1BC20)
@@ -768,7 +765,6 @@
768 old-uyghur 765 old-uyghur
769 makasar 766 makasar
770 dives-akuru 767 dives-akuru
771 cuneiform-numbers-and-punctuation
772 cuneiform 768 cuneiform
773 egyptian 769 egyptian
774 tangsa 770 tangsa
diff --git a/lisp/international/textsec-check.el b/lisp/international/textsec-check.el
new file mode 100644
index 00000000000..567ef73feb2
--- /dev/null
+++ b/lisp/international/textsec-check.el
@@ -0,0 +1,78 @@
1;;; textsec-check.el --- Check for suspicious texts -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2022 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;;
23
24;;; Code:
25
26(defgroup textsec nil
27 "Suspicious text identification."
28 :group 'security
29 :version "29.1")
30
31(defcustom textsec-check t
32 "If non-nil, perform some security-related checks on text objects.
33If nil, these checks are disabled."
34 :type 'boolean
35 :version "29.1")
36
37(defface textsec-suspicious
38 '((t (:weight bold :background "red")))
39 "Face used to highlight suspicious strings.")
40
41;;;###autoload
42(defun textsec-suspicious-p (object type)
43 "Say whether OBJECT is suspicious for use as TYPE.
44If OBJECT is suspicious, return a string explaining the reason
45for considering it suspicious, otherwise return nil.
46
47Available values of TYPE and corresponding OBJECTs are:
48
49 `url' -- a URL; OBJECT should be a URL string.
50
51 `link' -- an HTML link; OBJECT should be a cons cell
52 of the form (URL . LINK-TEXT).
53
54 `domain' -- a Web domain; OBJECT should be a string.
55
56 `local-address' -- the local part of an email address; OBJECT
57 should be a string.
58 `name' -- the \"display name\" part of an email address;
59 OBJECT should be a string.
60
61`email-address' -- a full email address; OBJECT should be a string.
62
63 `email-address-header' -- a raw email address header in RFC 2822 format;
64 OBJECT should be a string.
65
66If the user option `textsec-check' is nil, these checks are
67disabled, and this function always returns nil."
68 (if (not textsec-check)
69 nil
70 (require 'textsec)
71 (let ((func (intern (format "textsec-%s-suspicious-p" type))))
72 (unless (fboundp func)
73 (error "%s is not a valid function" func))
74 (funcall func object))))
75
76(provide 'textsec-check)
77
78;;; textsec-check.el ends here
diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el
new file mode 100644
index 00000000000..223c0d5c92f
--- /dev/null
+++ b/lisp/international/textsec.el
@@ -0,0 +1,429 @@
1;;; textsec.el --- Functions for handling homoglyphs and the like -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2022 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;;
23
24;;; Code:
25
26(require 'cl-lib)
27(require 'uni-confusable)
28(require 'ucs-normalize)
29(require 'idna-mapping)
30(require 'puny)
31(require 'mail-parse)
32(require 'url)
33
34(defvar textsec--char-scripts nil)
35
36(eval-and-compile
37 (defun textsec--create-script-table (data)
38 "Create the textsec--char-scripts char table."
39 (setq textsec--char-scripts (make-char-table nil))
40 (dolist (scripts data)
41 (dolist (range (cadr scripts))
42 (set-char-table-range textsec--char-scripts
43 range (car scripts)))))
44 (require 'uni-scripts))
45
46(defun textsec-scripts (string)
47 "Return a list of Unicode scripts used in STRING.
48The scripts returned by this function use the Unicode Script property
49as defined by the Unicode Standard Annex 24 (UAX#24)."
50 (seq-map (lambda (char)
51 (elt textsec--char-scripts char))
52 string))
53
54(defun textsec-single-script-p (string)
55 "Return non-nil if STRING is all in a single Unicode script.
56
57Note that the concept of \"single script\" used by this function
58isn't obvious -- some mixtures of scripts count as a \"single
59script\". See
60
61 https://www.unicode.org/reports/tr39/#Mixed_Script_Detection
62
63for details. The Unicode scripts are as defined by the
64Unicode Standard Annex 24 (UAX#24)."
65 (let ((scripts (mapcar
66 (lambda (s)
67 (append s
68 ;; Some scripts used in East Asia are
69 ;; commonly used across borders, so we add
70 ;; those.
71 (mapcan (lambda (script)
72 (copy-sequence
73 (textsec--augment-script script)))
74 s)))
75 (textsec-scripts string))))
76 (catch 'empty
77 (cl-loop for s1 in scripts
78 do (cl-loop for s2 in scripts
79 ;; Common/inherited chars can be used in
80 ;; text with all scripts.
81 when (and (not (memq 'common s1))
82 (not (memq 'common s2))
83 (not (memq 'inherited s1))
84 (not (memq 'inherited s2))
85 (not (seq-intersection s1 s2)))
86 do (throw 'empty nil)))
87 t)))
88
89(defun textsec--augment-script (script)
90 (cond
91 ((eq script 'han)
92 '(hangul japan korea))
93 ((or (eq script 'hiragana)
94 (eq script 'katakana))
95 '(japan))
96 ((or (eq script 'hangul)
97 (eq script 'bopomofo))
98 '(korea))))
99
100(defun textsec-covering-scripts (string)
101 "Return a minimal list of scripts used in STRING.
102Note that a string may have several different minimal cover sets.
103The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)."
104 (let* ((scripts (textsec-scripts string))
105 (set (car scripts)))
106 (dolist (s scripts)
107 (setq set (seq-union set (seq-difference s set))))
108 (sort (delq 'common (delq 'inherited set)) #'string<)))
109
110(defun textsec-restriction-level (string)
111 "Say what restriction level STRING qualifies for.
112Levels are (in decreasing order of restrictiveness) `ascii-only',
113`single-script', `highly-restrictive', `moderately-restrictive',
114`minimally-restrictive' and `unrestricted'."
115 (let ((scripts (textsec-covering-scripts string)))
116 (cond
117 ((string-match "\\`[[:ascii:]]+\\'" string)
118 'ascii-only)
119 ((textsec-single-script-p string)
120 'single-script)
121 ((or (null (seq-difference scripts '(latin han hiragana katakana)))
122 (null (seq-difference scripts '(latin han bopomofo)))
123 (null (seq-difference scripts '(latin han hangul))))
124 'highly-restrictive)
125 ((and (= (length scripts) 2)
126 (memq 'latin scripts)
127 ;; This list comes from
128 ;; https://www.unicode.org/reports/tr31/#Table_Recommended_Scripts
129 ;; (but without latin, cyrillic and greek).
130 (seq-intersection scripts
131 '(arabic
132 armenian
133 bengali
134 bopomofo
135 devanagari
136 ethiopic
137 georgian
138 gujarati
139 gurmukhi
140 hangul
141 han
142 hebrew
143 hiragana
144 katakana
145 kannada
146 khmer
147 lao
148 malayalam
149 myanmar
150 oriya
151 sinhala
152 tamil
153 telugu
154 thaana
155 thai
156 tibetan)))
157 ;; The string is covered by Latin and any one other Recommended
158 ;; script, except Cyrillic, Greek.
159 'moderately-retrictive)
160 ;; Fixme `minimally-restrictive' -- needs well-formedness criteria
161 ;; and Identifier Profile.
162 (t
163 'unrestricted))))
164
165(defun textsec-mixed-numbers-p (string)
166 "Return non-nil if STRING includes numbers from different decimal systems."
167 (>
168 (length
169 (seq-uniq
170 (mapcar
171 (lambda (char)
172 ;; Compare zeros in the respective decimal systems.
173 (- char (get-char-code-property char 'numeric-value)))
174 (seq-filter (lambda (char)
175 ;; We're selecting the characters that
176 ;; have a numeric property.
177 (eq (get-char-code-property char 'general-category)
178 'Nd))
179 string))))
180 1))
181
182(defun textsec-ascii-confusable-p (string)
183 "Return non-nil if non-ASCII STRING can be confused with ASCII on display."
184 (and (not (eq (textsec-restriction-level string) 'ascii-only))
185 (eq (textsec-restriction-level (textsec-unconfuse-string string))
186 'ascii-only)))
187
188(defun textsec-unconfuse-string (string)
189 "Return a de-confused version of STRING.
190This algorithm is described in:
191
192 https://www.unicode.org/reports/tr39/#Confusable_Detection"
193 (ucs-normalize-NFD-string
194 (apply #'concat
195 (seq-map (lambda (char)
196 (or (gethash char uni-confusable-table)
197 (string char)))
198 (ucs-normalize-NFD-string string)))))
199
200(defun textsec-resolved-script-set (string)
201 "Return the resolved script set for STRING.
202This is the minimal covering script set for STRING, but is nil is
203STRING isn't a single script string.
204The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)."
205 (and (textsec-single-script-p string)
206 (textsec-covering-scripts string)))
207
208(defun textsec-single-script-confusable-p (string1 string2)
209 "Say whether STRING1 and STRING2 are single-script confusables.
210The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)."
211 (and (equal (textsec-unconfuse-string string1)
212 (textsec-unconfuse-string string2))
213 ;; And they have to have at least one resolved script in
214 ;; common.
215 (seq-intersection (textsec-resolved-script-set string1)
216 (textsec-resolved-script-set string2))))
217
218(defun textsec-mixed-script-confusable-p (string1 string2)
219 "Say whether STRING1 and STRING2 are mixed-script confusables.
220The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)."
221 (and (equal (textsec-unconfuse-string string1)
222 (textsec-unconfuse-string string2))
223 ;; And they have no resolved scripts in common.
224 (null (seq-intersection (textsec-resolved-script-set string1)
225 (textsec-resolved-script-set string2)))))
226
227(defun textsec-whole-script-confusable-p (string1 string2)
228 "Say whether STRING1 and STRING2 are whole-script confusables.
229The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)."
230 (and (textsec-mixed-script-confusable-p string1 string2)
231 (textsec-single-script-p string1)
232 (textsec-single-script-p string2)))
233
234(defun textsec-domain-suspicious-p (domain)
235 "Say whether DOMAIN's name looks suspicious.
236Return nil if it isn't suspicious. If it is, return a string explaining
237the potential problem.
238
239Domain names are considered suspicious if they use characters
240that can look similar to other characters when displayed, or
241use characters that are not allowed by Unicode's IDNA mapping,
242or use certain other unusual mixtures of characters."
243 (catch 'found
244 (seq-do
245 (lambda (char)
246 (when (eq (elt idna-mapping-table char) t)
247 (throw 'found
248 (format "Disallowed character%s (#x%x, %s)"
249 (if (eq (get-char-code-property char 'general-category)
250 'Cf)
251 ""
252 (concat ": " (string char)))
253 char
254 (get-char-code-property char 'name)))))
255 domain)
256 ;; Does IDNA allow it?
257 (unless (puny-highly-restrictive-domain-p domain)
258 (throw
259 'found
260 (format "`%s' mixes characters from different scripts in suspicious ways"
261 domain)))
262 ;; Check whether any segment of the domain name is confusable with
263 ;; an ASCII-only segment.
264 (dolist (elem (split-string domain "\\."))
265 (when (textsec-ascii-confusable-p elem)
266 (throw 'found (format "`%s' is confusable with ASCII" elem))))
267 nil))
268
269(defun textsec-local-address-suspicious-p (local)
270 "Say whether LOCAL part of an email address looks suspicious.
271LOCAL is the bit before \"@\" in an email address.
272
273If it isn't suspicious, return nil. If it is, return a string explaining
274the potential problem.
275
276Email addresses are considered suspicious if they use characters
277that can look similar to other characters when displayed, or use
278certain other unusual mixtures of characters."
279 (cond
280 ((not (equal local (ucs-normalize-NFKC-string local)))
281 (format "`%s' is not in normalized format `%s'"
282 local (ucs-normalize-NFKC-string local)))
283 ((textsec-mixed-numbers-p local)
284 (format "`%s' contains numbers from different number systems" local))
285 ((eq (textsec-restriction-level local) 'unrestricted)
286 (format "`%s' isn't restrictive enough" local))
287 ((string-match-p "\\`\\.\\|\\.\\'\\|\\.\\." local)
288 (format "`%s' contains invalid dots" local))))
289
290(defun textsec-name-suspicious-p (name)
291 "Say whether NAME looks suspicious.
292NAME is (for instance) the free-text display name part of an
293email address.
294
295If it isn't suspicious, return nil. If it is, return a string
296explaining the potential problem.
297
298Names are considered suspicious if they use characters that can
299look similar to other characters when displayed, or use certain
300other unusual mixtures of characters."
301 (cond
302 ((not (equal name (ucs-normalize-NFC-string name)))
303 (format "`%s' is not in normalized format `%s'"
304 name (ucs-normalize-NFC-string name)))
305 ((and (seq-find (lambda (char)
306 (and (member char bidi-control-characters)
307 (not (member char
308 '( ?\N{left-to-right mark}
309 ?\N{right-to-left mark}
310 ?\N{arabic letter mark})))))
311 name)
312 ;; We have bidirectional formatting characters, but check
313 ;; whether they affect LTR characters. If not, it's not
314 ;; suspicious.
315 (bidi-find-overridden-directionality 0 (length name) name))
316 (format "The string contains bidirectional control characters"))
317 ((textsec-suspicious-nonspacing-p name))))
318
319(defun textsec-suspicious-nonspacing-p (string)
320 "Say whether STRING uses nonspacing characters in suspicious ways.
321If it doesn't, return nil. If it does, return a string explaining
322the potential problem.
323
324Use of nonspacing characters is considered suspicious if there are
325two or more consecutive identical nonspacing characters, or too many
326consecutive nonspacing characters."
327 (let ((prev nil)
328 (nonspace-count 0))
329 (catch 'found
330 (seq-do
331 (lambda (char)
332 (let ((nonspacing
333 (memq (get-char-code-property char 'general-category)
334 '(Mn Me))))
335 (when (and nonspacing
336 (equal char prev))
337 (throw 'found "Two identical consecutive nonspacing characters"))
338 (setq nonspace-count (if nonspacing
339 (1+ nonspace-count)
340 0))
341 (when (> nonspace-count 4)
342 (throw 'found
343 "Too many consecutive nonspacing characters"))
344 (setq prev char)))
345 string)
346 nil)))
347
348(defun textsec-email-address-suspicious-p (address)
349 "Say whether EMAIL address looks suspicious.
350If it isn't, return nil. If it is, return a string explaining the
351potential problem.
352
353An email address is considered suspicious if either of its two
354parts -- the local address name or the domain -- are found to be
355suspicious by, respectively, `textsec-local-address-suspicious-p'
356and `textsec-domain-suspicious-p'."
357 (pcase-let ((`(,local ,domain) (split-string address "@")))
358 (or
359 (textsec-domain-suspicious-p domain)
360 (textsec-local-address-suspicious-p local))))
361
362(defun textsec-email-address-header-suspicious-p (email)
363 "Say whether EMAIL looks suspicious.
364If it isn't, return nil. If it is, return a string explaining the
365potential problem.
366
367Note that EMAIL has to be a valid email specification according
368to RFC2047bis -- strings that can't be parsed will be flagged as
369suspicious.
370
371An email specification is considered suspicious if either of its
372two parts -- the address or the name -- are found to be
373suspicious by, respectively, `textsec-email-address-suspicious-p'
374and `textsec-name-suspicious-p'."
375 (catch 'end
376 (pcase-let ((`(,address . ,name)
377 (condition-case nil
378 (mail-header-parse-address email t)
379 (error (throw 'end "Email address can't be parsed.")))))
380 (or
381 (textsec-email-address-suspicious-p address)
382 (and name (textsec-name-suspicious-p name))))))
383
384(defun textsec-url-suspicious-p (url)
385 "Say whether URL looks suspicious.
386If it isn't, return nil. If it is, return a string explaining the
387potential problem."
388 (let ((parsed (url-generic-parse-url url)))
389 ;; The URL may not have a domain.
390 (and (url-host parsed)
391 (textsec-domain-suspicious-p (url-host parsed)))))
392
393(defun textsec-link-suspicious-p (link)
394 "Say whether LINK is suspicious.
395LINK should be a cons cell where the first element is the URL,
396and the second element is the link text.
397
398This function will return non-nil if it seems like the link text
399is misleading about where the URL takes you. This is typical
400when the link text looks like an URL itself, but doesn't lead to
401the same domain as the URL."
402 (let* ((url (car link))
403 (text (string-trim (cdr link))))
404 (catch 'found
405 (let ((udomain (url-host (url-generic-parse-url url)))
406 (tdomain (url-host (url-generic-parse-url text))))
407 (cond
408 ((and udomain
409 tdomain
410 (not (equal udomain tdomain))
411 ;; One may be a sub-domain of the other, but don't allow too
412 ;; short domains.
413 (not (or (and (string-suffix-p udomain tdomain)
414 (url-domsuf-cookie-allowed-p udomain))
415 (and (string-suffix-p tdomain udomain)
416 (url-domsuf-cookie-allowed-p tdomain)))))
417 (throw 'found
418 (format "Text `%s' doesn't point to link URL `%s'"
419 text url)))
420 ((and tdomain
421 (textsec-domain-suspicious-p tdomain))
422 (throw 'found
423 (format "Domain `%s' in the link text is suspicious"
424 (bidi-string-strip-control-characters
425 tdomain)))))))))
426
427(provide 'textsec)
428
429;;; textsec.el ends here
diff --git a/lisp/keymap.el b/lisp/keymap.el
index ce566fd8afc..c0fdf8721b2 100644
--- a/lisp/keymap.el
+++ b/lisp/keymap.el
@@ -325,38 +325,38 @@ which is
325 325
326 Alt-Control-Hyper-Meta-Shift-super" 326 Alt-Control-Hyper-Meta-Shift-super"
327 (declare (pure t) (side-effect-free t)) 327 (declare (pure t) (side-effect-free t))
328 (and 328 (let ((case-fold-search nil))
329 (stringp keys) 329 (and
330 (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) 330 (stringp keys)
331 (save-match-data 331 (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys)
332 (catch 'exit 332 (save-match-data
333 (let ((prefixes 333 (catch 'exit
334 "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") 334 (let ((prefixes
335 (case-fold-search nil)) 335 "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?"))
336 (dolist (key (split-string keys " ")) 336 (dolist (key (split-string keys " "))
337 ;; Every key might have these modifiers, and they should be 337 ;; Every key might have these modifiers, and they should be
338 ;; in this order. 338 ;; in this order.
339 (when (string-match (concat "\\`" prefixes) key) 339 (when (string-match (concat "\\`" prefixes) key)
340 (setq key (substring key (match-end 0)))) 340 (setq key (substring key (match-end 0))))
341 (unless (or (and (= (length key) 1) 341 (unless (or (and (= (length key) 1)
342 ;; Don't accept control characters as keys. 342 ;; Don't accept control characters as keys.
343 (not (< (aref key 0) ?\s)) 343 (not (< (aref key 0) ?\s))
344 ;; Don't accept Meta'd characters as keys. 344 ;; Don't accept Meta'd characters as keys.
345 (or (multibyte-string-p key) 345 (or (multibyte-string-p key)
346 (not (<= 127 (aref key 0) 255)))) 346 (not (<= 127 (aref key 0) 255))))
347 (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) 347 (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key)
348 ;; Don't allow <M-C-down>. 348 ;; Don't allow <M-C-down>.
349 (= (progn 349 (= (progn
350 (string-match 350 (string-match
351 (concat "\\`<" prefixes) key) 351 (concat "\\`<" prefixes) key)
352 (match-end 0)) 352 (match-end 0))
353 1)) 353 1))
354 (string-match-p 354 (string-match-p
355 "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" 355 "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'"
356 key)) 356 key))
357 ;; Invalid. 357 ;; Invalid.
358 (throw 'exit nil))) 358 (throw 'exit nil)))
359 t))))) 359 t))))))
360 360
361(defun key-translate (from to) 361(defun key-translate (from to)
362 "Translate character FROM to TO on the current terminal. 362 "Translate character FROM to TO on the current terminal.
diff --git a/lisp/man.el b/lisp/man.el
index d6146a2c4dc..a53a696c313 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -1993,11 +1993,13 @@ Uses `Man-name-local-regexp'."
1993 (skip-syntax-backward "^ ") 1993 (skip-syntax-backward "^ ")
1994 (and (looking-at 1994 (and (looking-at
1995 "[[:space:]]*\\([[:alnum:]_-]+([[:alnum:]]+)\\)") 1995 "[[:space:]]*\\([[:alnum:]_-]+([[:alnum:]]+)\\)")
1996 (match-string 1))) 1996 (match-string 1)))
1997 (define-key-after menu [man-separator] menu-bar-separator) 1997 (define-key-after menu [man-separator] menu-bar-separator
1998 'middle-separator)
1998 (define-key-after menu [man-at-mouse] 1999 (define-key-after menu [man-at-mouse]
1999 '(menu-item "Open man page" man-at-mouse 2000 '(menu-item "Open man page" Man-at-mouse
2000 :help "Open man page around mouse click")))) 2001 :help "Open man page around mouse click")
2002 'man-separator)))
2001 menu) 2003 menu)
2002 2004
2003 2005
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 36cbd6a9c51..817c2d485e8 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -96,26 +96,26 @@
96 (bindings--define-key menu [separator-print] 96 (bindings--define-key menu [separator-print]
97 menu-bar-separator) 97 menu-bar-separator)
98 98
99 (unless (featurep 'ns) 99 (bindings--define-key menu [close-tab]
100 (bindings--define-key menu [close-tab] 100 '(menu-item "Close Tab" tab-close
101 '(menu-item "Close Tab" tab-close 101 :visible (fboundp 'tab-close)
102 :visible (fboundp 'tab-close) 102 :help "Close currently selected tab"))
103 :help "Close currently selected tab")) 103 (bindings--define-key menu [make-tab]
104 (bindings--define-key menu [make-tab] 104 '(menu-item "New Tab" tab-new
105 '(menu-item "New Tab" tab-new 105 :visible (fboundp 'tab-new)
106 :visible (fboundp 'tab-new) 106 :help "Open a new tab"))
107 :help "Open a new tab")) 107
108 108 (bindings--define-key menu [separator-tab]
109 (bindings--define-key menu [separator-tab] 109 menu-bar-separator)
110 menu-bar-separator)) 110
111 111 (bindings--define-key menu [undelete-frame-mode]
112 (bindings--define-key menu [enable-undelete-frame-mode] 112 '(menu-item "Allow Undeleting Frames" undelete-frame-mode
113 '(menu-item "Enable Undeleting Frames" undelete-frame-mode 113 :help "Allow frames to be restored after deletion"
114 :visible (null undelete-frame-mode) 114 :button (:toggle . undelete-frame-mode)))
115 :help "Enable undeleting frames in this session")) 115
116 (bindings--define-key menu [undelete-last-deleted-frame] 116 (bindings--define-key menu [undelete-last-deleted-frame]
117 '(menu-item "Undelete Frame" undelete-frame 117 '(menu-item "Undelete Frame" undelete-frame
118 :visible (and undelete-frame-mode 118 :enable (and undelete-frame-mode
119 (car undelete-frame--deleted-frames)) 119 (car undelete-frame--deleted-frames))
120 :help "Undelete the most recently deleted frame")) 120 :help "Undelete the most recently deleted frame"))
121 121
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index ab760a42d15..d58c23af8fb 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -1004,7 +1004,9 @@ an association list that can specify properties such as:
1004- `styles': the list of `completion-styles' to use for that category. 1004- `styles': the list of `completion-styles' to use for that category.
1005- `cycle': the `completion-cycle-threshold' to use for that category. 1005- `cycle': the `completion-cycle-threshold' to use for that category.
1006Categories are symbols such as `buffer' and `file', used when 1006Categories are symbols such as `buffer' and `file', used when
1007completing buffer and file names, respectively.") 1007completing buffer and file names, respectively.
1008
1009Also see `completion-category-overrides'.")
1008 1010
1009(defcustom completion-category-overrides nil 1011(defcustom completion-category-overrides nil
1010 "List of category-specific user overrides for completion styles. 1012 "List of category-specific user overrides for completion styles.
@@ -1014,7 +1016,9 @@ an association list that can specify properties such as:
1014- `cycle': the `completion-cycle-threshold' to use for that category. 1016- `cycle': the `completion-cycle-threshold' to use for that category.
1015Categories are symbols such as `buffer' and `file', used when 1017Categories are symbols such as `buffer' and `file', used when
1016completing buffer and file names, respectively. 1018completing buffer and file names, respectively.
1017This overrides the defaults specified in `completion-category-defaults'." 1019
1020If a property in a category is specified by this variable, it
1021overrides the default specified in `completion-category-defaults'."
1018 :version "25.1" 1022 :version "25.1"
1019 :type `(alist :key-type (choice :tag "Category" 1023 :type `(alist :key-type (choice :tag "Category"
1020 (const buffer) 1024 (const buffer)
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 46dd0397d7f..502683d3d1e 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -298,9 +298,10 @@ and should return the same menu with changes such as added new menu items."
298 (function-item context-menu-buffers) 298 (function-item context-menu-buffers)
299 (function-item context-menu-vc) 299 (function-item context-menu-vc)
300 (function-item context-menu-ffap) 300 (function-item context-menu-ffap)
301 (function-item Man-context-menu)
302 (function-item hi-lock-context-menu) 301 (function-item hi-lock-context-menu)
303 (function-item context-menu-online-search) 302 (function-item occur-context-menu)
303 (function-item Man-context-menu)
304 (function-item dictionary-context-menu)
304 (function :tag "Custom function"))) 305 (function :tag "Custom function")))
305 :version "28.1") 306 :version "28.1")
306 307
@@ -323,6 +324,8 @@ the function `context-menu-filter-function'."
323 (fun (mouse-posn-property (event-start click) 324 (fun (mouse-posn-property (event-start click)
324 'context-menu-function))) 325 'context-menu-function)))
325 326
327 (select-window (posn-window (event-start click)))
328
326 (if (functionp fun) 329 (if (functionp fun)
327 (setq menu (funcall fun menu click)) 330 (setq menu (funcall fun menu click))
328 (run-hook-wrapped 'context-menu-functions 331 (run-hook-wrapped 'context-menu-functions
@@ -534,16 +537,6 @@ Some context functions add menu items below the separator."
534 :help "Find file or URL from text around mouse click")))) 537 :help "Find file or URL from text around mouse click"))))
535 menu) 538 menu)
536 539
537(defun context-menu-online-search (menu click)
538 "Populate MENU with command to search online."
539 (save-excursion
540 (mouse-set-point click)
541 (define-key-after menu [online-search-separator] menu-bar-separator)
542 (define-key-after menu [online-search-at-mouse]
543 '(menu-item "Online search" mouse-online-search-at-point
544 :help "Search for region or word online")))
545 menu)
546
547(defvar context-menu-entry 540(defvar context-menu-entry
548 `(menu-item ,(purecopy "Context Menu") ,(make-sparse-keymap) 541 `(menu-item ,(purecopy "Context Menu") ,(make-sparse-keymap)
549 :filter ,(lambda (_) (context-menu-map))) 542 :filter ,(lambda (_) (context-menu-map)))
@@ -3230,26 +3223,6 @@ is copied instead of being cut."
3230 (with-current-buffer (window-buffer window) 3223 (with-current-buffer (window-buffer window)
3231 (setq cursor-type (nth 3 state))))))) 3224 (setq cursor-type (nth 3 state)))))))
3232 3225
3233(defvar eww-search-prefix)
3234(defun mouse-online-search-at-point (event)
3235 "Query an online search engine at EVENT.
3236If a region is active, the entire region will be sent, otherwise
3237the symbol at point will be used. This command uses EWW's
3238default search engine, as configured by `eww-search-prefix'."
3239 (interactive "e")
3240 (require 'eww)
3241 (let ((query (if (use-region-p)
3242 (buffer-substring (region-beginning)
3243 (region-end))
3244 (save-excursion
3245 (mouse-set-point event)
3246 (thing-at-point 'symbol)))))
3247 (unless query
3248 (user-error "Nothing to search for"))
3249 (browse-url (concat
3250 eww-search-prefix
3251 (mapconcat #'url-hexify-string (split-string query) "+")))))
3252
3253 3226
3254;;; Bindings for mouse commands. 3227;;; Bindings for mouse commands.
3255 3228
diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el
index 507363cc0f8..e0824f39716 100644
--- a/lisp/net/dictionary.el
+++ b/lisp/net/dictionary.el
@@ -1376,7 +1376,7 @@ any buffer where (dictionary-tooltip-mode 1) has been called."
1376 (dictionary-search word))) 1376 (dictionary-search word)))
1377 1377
1378;;;###autoload 1378;;;###autoload
1379(defun context-menu-dictionary (menu click) 1379(defun dictionary-context-menu (menu click)
1380 "Populate MENU with dictionary commands at CLICK. 1380 "Populate MENU with dictionary commands at CLICK.
1381When you add this function to `context-menu-functions', 1381When you add this function to `context-menu-functions',
1382the context menu will contain an item that searches 1382the context menu will contain an item that searches
diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el
index daa2d5a3fb3..b65f7c25b83 100644
--- a/lisp/net/mailcap.el
+++ b/lisp/net/mailcap.el
@@ -319,8 +319,9 @@ attribute name (viewer, test, etc). This looks like:
319 319
320Where VIEWERINFO specifies how the content-type is viewed. Can be 320Where VIEWERINFO specifies how the content-type is viewed. Can be
321a string, in which case it is run through a shell, with appropriate 321a string, in which case it is run through a shell, with appropriate
322parameters, or a symbol, in which case the symbol is `funcall'ed if 322parameters, or a symbol, in which case the symbol must name a function
323and only if it exists as a function, with the buffer as an argument. 323of zero arguments which is called in a buffer holding the MIME part's
324content.
324 325
325TESTINFO is a test for the viewer's applicability, or nil. If nil, it 326TESTINFO is a test for the viewer's applicability, or nil. If nil, it
326means the viewer is always valid. If it is a Lisp function, it is 327means the viewer is always valid. If it is a Lisp function, it is
@@ -1175,34 +1176,45 @@ See \"~/.mailcap\", `mailcap-mime-data' and related files and variables."
1175 (mailcap-parse-mailcaps) 1176 (mailcap-parse-mailcaps)
1176 (let ((command (mailcap-mime-info 1177 (let ((command (mailcap-mime-info
1177 (mailcap-extension-to-mime (file-name-extension file))))) 1178 (mailcap-extension-to-mime (file-name-extension file)))))
1178 (unless command 1179 (if (functionp command)
1179 (error "No viewer for %s" (file-name-extension file))) 1180 ;; command is a viewer function (a mode) expecting the file
1180 ;; Remove quotes around the file name - we'll use shell-quote-argument. 1181 ;; contents to be in the current buffer.
1181 (while (string-match "['\"]%s['\"]" command) 1182 (let ((buf (generate-new-buffer (file-name-nondirectory file))))
1182 (setq command (replace-match "%s" t t command))) 1183 (set-buffer buf)
1183 (setq command (replace-regexp-in-string 1184 (insert-file-contents file)
1184 "%s" 1185 (setq buffer-file-name file)
1185 (shell-quote-argument (convert-standard-filename file)) 1186 (funcall command)
1186 command 1187 (set-buffer-modified-p nil)
1187 nil t)) 1188 (pop-to-buffer buf))
1188 ;; Handlers such as "gio open" and kde-open5 start viewer in background 1189 ;; command is a program to run with file as an argument.
1189 ;; and exit immediately. Avoid `start-process' since it assumes 1190 (unless command
1190 ;; :connection-type `pty' and kills children processes with SIGHUP 1191 (error "No viewer for %s" (file-name-extension file)))
1191 ;; when temporary terminal session is finished (Bug#44824). 1192 ;; Remove quotes around the file name - we'll use shell-quote-argument.
1192 ;; An alternative is `process-connection-type' let-bound to nil for 1193 (while (string-match "['\"]%s['\"]" command)
1193 ;; `start-process-shell-command' call (with no chance to report failure). 1194 (setq command (replace-match "%s" t t command)))
1194 (make-process 1195 (setq command (replace-regexp-in-string
1195 :name "mailcap-view-file" 1196 "%s"
1196 :connection-type 'pipe 1197 (shell-quote-argument (convert-standard-filename file))
1197 :buffer nil ; "*Messages*" may be suitable for debugging 1198 command
1198 :sentinel (lambda (proc event) 1199 nil t))
1199 (when (and (memq (process-status proc) '(exit signal)) 1200 ;; Handlers such as "gio open" and kde-open5 start viewer in background
1200 (/= (process-exit-status proc) 0)) 1201 ;; and exit immediately. Avoid `start-process' since it assumes
1201 (message 1202 ;; :connection-type `pty' and kills children processes with SIGHUP
1202 "Command %s: %s." 1203 ;; when temporary terminal session is finished (Bug#44824).
1203 (mapconcat #'identity (process-command proc) " ") 1204 ;; An alternative is `process-connection-type' let-bound to nil for
1204 (substring event 0 -1)))) 1205 ;; `start-process-shell-command' call (with no chance to report failure).
1205 :command (list shell-file-name shell-command-switch command)))) 1206 (make-process
1207 :name "mailcap-view-file"
1208 :connection-type 'pipe
1209 :buffer nil ; "*Messages*" may be suitable for debugging
1210 :sentinel (lambda (proc event)
1211 (when (and (memq (process-status proc) '(exit signal))
1212 (/= (process-exit-status proc) 0))
1213 (message
1214 "Command %s: %s."
1215 (mapconcat #'identity (process-command proc) " ")
1216 (substring event 0 -1))))
1217 :command (list shell-file-name shell-command-switch command)))))
1206 1218
1207(provide 'mailcap) 1219(provide 'mailcap)
1208 1220
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 7363874cf3c..ff14acfda70 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1467,7 +1467,18 @@ ones, in case fg and bg are nil."
1467 (dom-attr dom 'name)))) ; Obsolete since HTML5. 1467 (dom-attr dom 'name)))) ; Obsolete since HTML5.
1468 (push (cons id (point)) shr--link-targets)) 1468 (push (cons id (point)) shr--link-targets))
1469 (when url 1469 (when url
1470 (shr-urlify (or shr-start start) (shr-expand-url url) title)))) 1470 (shr-urlify (or shr-start start) (shr-expand-url url) title)
1471 ;; Check whether the URL is suspicious.
1472 (when-let ((warning (or (textsec-suspicious-p
1473 (shr-expand-url url) 'url)
1474 (textsec-suspicious-p
1475 (cons (shr-expand-url url)
1476 (buffer-substring (or shr-start start)
1477 (point)))
1478 'link))))
1479 (add-text-properties (or shr-start start) (point)
1480 (list 'face '(shr-link textsec-suspicious)))
1481 (insert (propertize "⚠️" 'help-echo warning))))))
1471 1482
1472(defun shr-tag-abbr (dom) 1483(defun shr-tag-abbr (dom)
1473 (let ((title (dom-attr dom 'title)) 1484 (let ((title (dom-attr dom 'title))
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index ed73a86ef03..75e6b7179b0 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -776,7 +776,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
776(defun tramp-adb-get-signal-strings (vec) 776(defun tramp-adb-get-signal-strings (vec)
777 "Strings to return by `process-file' in case of signals." 777 "Strings to return by `process-file' in case of signals."
778 (with-tramp-connection-property vec "signal-strings" 778 (with-tramp-connection-property vec "signal-strings"
779 (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) 779 (let ((default-directory (tramp-make-tramp-file-name vec 'noloc))
780 ;; `shell-file-name' and `shell-command-switch' are needed 780 ;; `shell-file-name' and `shell-command-switch' are needed
781 ;; for Emacs < 27.1, which doesn't support connection-local 781 ;; for Emacs < 27.1, which doesn't support connection-local
782 ;; variables in `shell-command'. 782 ;; variables in `shell-command'.
@@ -815,7 +815,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
815 ;; Determine input. 815 ;; Determine input.
816 (if (null infile) 816 (if (null infile)
817 (setq input (tramp-get-remote-null-device v)) 817 (setq input (tramp-get-remote-null-device v))
818 (setq infile (expand-file-name infile)) 818 (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
819 (if (tramp-equal-remote default-directory infile) 819 (if (tramp-equal-remote default-directory infile)
820 ;; INFILE is on the same remote host. 820 ;; INFILE is on the same remote host.
821 (setq input (tramp-file-local-name infile)) 821 (setq input (tramp-file-local-name infile))
@@ -870,7 +870,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
870 (setq ret (tramp-adb-send-command-and-check 870 (setq ret (tramp-adb-send-command-and-check
871 v (format 871 v (format
872 "(cd %s; %s)" 872 "(cd %s; %s)"
873 (tramp-shell-quote-argument localname) command) 873 (tramp-unquote-shell-quote-argument localname)
874 command)
874 t)) 875 t))
875 (unless (natnump ret) (setq ret 1)) 876 (unless (natnump ret) (setq ret 1))
876 ;; We should add the output anyway. 877 ;; We should add the output anyway.
@@ -900,8 +901,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
900 ;; Cleanup. We remove all file cache values for the connection, 901 ;; Cleanup. We remove all file cache values for the connection,
901 ;; because the remote process could have changed them. 902 ;; because the remote process could have changed them.
902 (when tmpinput (delete-file tmpinput)) 903 (when tmpinput (delete-file tmpinput))
903 904 (when process-file-side-effects
904 (unless process-file-side-effects
905 (tramp-flush-directory-properties v "")) 905 (tramp-flush-directory-properties v ""))
906 906
907 ;; Return exit status. 907 ;; Return exit status.
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 8a88057d38a..d3f427932f3 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -457,7 +457,7 @@ name is kept in slot `hop'"
457 ((tramp-archive-file-name-p archive) 457 ((tramp-archive-file-name-p archive)
458 (let ((archive 458 (let ((archive
459 (tramp-make-tramp-file-name 459 (tramp-make-tramp-file-name
460 (tramp-archive-dissect-file-name archive) nil 'noarchive))) 460 (tramp-archive-dissect-file-name archive))))
461 (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) 461 (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)))
462 (puthash archive (list vec) tramp-archive-hash)) 462 (puthash archive (list vec) tramp-archive-hash))
463 463
@@ -560,8 +560,7 @@ offered."
560 560
561(defun tramp-archive-gvfs-file-name (name) 561(defun tramp-archive-gvfs-file-name (name)
562 "Return NAME in GVFS syntax." 562 "Return NAME in GVFS syntax."
563 (tramp-make-tramp-file-name 563 (tramp-make-tramp-file-name (tramp-archive-dissect-file-name name)))
564 (tramp-archive-dissect-file-name name) nil 'nohop))
565 564
566 565
567;; File name primitives. 566;; File name primitives.
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index 715b537247f..1ab8f4d335b 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -124,7 +124,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil."
124 (dolist (elt tramp-connection-properties) 124 (dolist (elt tramp-connection-properties)
125 (when (tramp-compat-string-search 125 (when (tramp-compat-string-search
126 (or (nth 0 elt) "") 126 (or (nth 0 elt) "")
127 (tramp-make-tramp-file-name key 'noloc 'nohop)) 127 (tramp-make-tramp-file-name key 'noloc))
128 (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) 128 (tramp-set-connection-property key (nth 1 elt) (nth 2 elt)))))
129 hash)))) 129 hash))))
130 130
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 72b1ebb3e06..f0ceabe568b 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -1149,8 +1149,7 @@ component is used as the target of the symlink."
1149 (when (file-remote-p result) 1149 (when (file-remote-p result)
1150 (setq result (tramp-compat-file-name-quote result 'top))) 1150 (setq result (tramp-compat-file-name-quote result 'top)))
1151 (tramp-message v 4 "True name of `%s' is `%s'" localname result) 1151 (tramp-message v 4 "True name of `%s' is `%s'" localname result)
1152 result)) 1152 result)))))))
1153 'nohop)))))
1154 1153
1155;; Basic functions. 1154;; Basic functions.
1156 1155
@@ -2852,7 +2851,7 @@ implementation will be used."
2852 ;; `shell'. We discard hops, if existing, that's why 2851 ;; `shell'. We discard hops, if existing, that's why
2853 ;; we cannot use `file-remote-p'. 2852 ;; we cannot use `file-remote-p'.
2854 (prompt (format "PS1=%s %s" 2853 (prompt (format "PS1=%s %s"
2855 (tramp-make-tramp-file-name v nil 'nohop) 2854 (tramp-make-tramp-file-name v)
2856 tramp-initial-end-of-output)) 2855 tramp-initial-end-of-output))
2857 ;; We use as environment the difference to toplevel 2856 ;; We use as environment the difference to toplevel
2858 ;; `process-environment'. 2857 ;; `process-environment'.
@@ -3013,7 +3012,7 @@ implementation will be used."
3013 vec 3012 vec
3014 (concat 3013 (concat
3015 "signal-strings-" (tramp-get-method-parameter vec 'tramp-remote-shell)) 3014 "signal-strings-" (tramp-get-method-parameter vec 'tramp-remote-shell))
3016 (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) 3015 (let ((default-directory (tramp-make-tramp-file-name vec 'noloc))
3017 process-file-return-signal-string signals res result) 3016 process-file-return-signal-string signals res result)
3018 (setq signals 3017 (setq signals
3019 (append 3018 (append
@@ -3098,13 +3097,13 @@ implementation will be used."
3098 ;; Determine input. 3097 ;; Determine input.
3099 (if (null infile) 3098 (if (null infile)
3100 (setq input (tramp-get-remote-null-device v)) 3099 (setq input (tramp-get-remote-null-device v))
3101 (setq infile (expand-file-name infile)) 3100 (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
3102 (if (tramp-equal-remote default-directory infile) 3101 (if (tramp-equal-remote default-directory infile)
3103 ;; INFILE is on the same remote host. 3102 ;; INFILE is on the same remote host.
3104 (setq input (tramp-file-local-name infile)) 3103 (setq input (tramp-file-local-name infile))
3105 ;; INFILE must be copied to remote host. 3104 ;; INFILE must be copied to remote host.
3106 (setq input (tramp-make-tramp-temp-file v) 3105 (setq input (tramp-make-tramp-temp-file v)
3107 tmpinput (tramp-make-tramp-file-name v input 'nohop)) 3106 tmpinput (tramp-make-tramp-file-name v input))
3108 (copy-file infile tmpinput t))) 3107 (copy-file infile tmpinput t)))
3109 (when input (setq command (format "%s <%s" command input))) 3108 (when input (setq command (format "%s <%s" command input)))
3110 3109
@@ -3136,7 +3135,7 @@ implementation will be used."
3136 ;; stderr must be copied to remote host. The temporary 3135 ;; stderr must be copied to remote host. The temporary
3137 ;; file must be deleted after execution. 3136 ;; file must be deleted after execution.
3138 (setq stderr (tramp-make-tramp-temp-file v) 3137 (setq stderr (tramp-make-tramp-temp-file v)
3139 tmpstderr (tramp-make-tramp-file-name v stderr 'nohop)))) 3138 tmpstderr (tramp-make-tramp-file-name v stderr))))
3140 ;; stderr to be discarded. 3139 ;; stderr to be discarded.
3141 ((null (cadr destination)) 3140 ((null (cadr destination))
3142 (setq stderr (tramp-get-remote-null-device v))))) 3141 (setq stderr (tramp-get-remote-null-device v)))))
@@ -3153,7 +3152,8 @@ implementation will be used."
3153 (setq ret (tramp-send-command-and-check 3152 (setq ret (tramp-send-command-and-check
3154 v (format 3153 v (format
3155 "cd %s && %s" 3154 "cd %s && %s"
3156 (tramp-shell-quote-argument localname) command) 3155 (tramp-unquote-shell-quote-argument localname)
3156 command)
3157 t t t)) 3157 t t t))
3158 (unless (natnump ret) (setq ret 1)) 3158 (unless (natnump ret) (setq ret 1))
3159 ;; We should add the output anyway. 3159 ;; We should add the output anyway.
@@ -3184,8 +3184,7 @@ implementation will be used."
3184 ;; Cleanup. We remove all file cache values for the connection, 3184 ;; Cleanup. We remove all file cache values for the connection,
3185 ;; because the remote process could have changed them. 3185 ;; because the remote process could have changed them.
3186 (when tmpinput (delete-file tmpinput)) 3186 (when tmpinput (delete-file tmpinput))
3187 3187 (when process-file-side-effects
3188 (unless process-file-side-effects
3189 (tramp-flush-directory-properties v "")) 3188 (tramp-flush-directory-properties v ""))
3190 3189
3191 ;; Return exit status. 3190 ;; Return exit status.
@@ -3650,8 +3649,7 @@ Fall back to normal file name handler if no Tramp handler exists."
3650(defun tramp-sh-file-name-handler-p (vec) 3649(defun tramp-sh-file-name-handler-p (vec)
3651 "Whether VEC uses a method from `tramp-sh-file-name-handler'." 3650 "Whether VEC uses a method from `tramp-sh-file-name-handler'."
3652 (and (assoc (tramp-file-name-method vec) tramp-methods) 3651 (and (assoc (tramp-file-name-method vec) tramp-methods)
3653 (eq (tramp-find-foreign-file-name-handler 3652 (eq (tramp-find-foreign-file-name-handler vec)
3654 (tramp-make-tramp-file-name vec nil 'nohop))
3655 'tramp-sh-file-name-handler))) 3653 'tramp-sh-file-name-handler)))
3656 3654
3657;; This must be the last entry, because `identity' always matches. 3655;; This must be the last entry, because `identity' always matches.
@@ -5441,7 +5439,7 @@ Nonexistent directories are removed from spec."
5441 (lambda (x) 5439 (lambda (x)
5442 (and 5440 (and
5443 (stringp x) 5441 (stringp x)
5444 (file-directory-p (tramp-make-tramp-file-name vec x 'nohop)) 5442 (file-directory-p (tramp-make-tramp-file-name vec x))
5445 x)) 5443 x))
5446 remote-path)))))) 5444 remote-path))))))
5447 5445
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index c5f423fa3f0..6515519680c 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -1281,7 +1281,7 @@ component is used as the target of the symlink."
1281 1281
1282 ;; Determine input. 1282 ;; Determine input.
1283 (when infile 1283 (when infile
1284 (setq infile (expand-file-name infile)) 1284 (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
1285 (if (tramp-equal-remote default-directory infile) 1285 (if (tramp-equal-remote default-directory infile)
1286 ;; INFILE is on the same remote host. 1286 ;; INFILE is on the same remote host.
1287 (setq input (tramp-file-local-name infile)) 1287 (setq input (tramp-file-local-name infile))
@@ -1373,8 +1373,7 @@ component is used as the target of the symlink."
1373 (when tmpinput (delete-file tmpinput)) 1373 (when tmpinput (delete-file tmpinput))
1374 (unless outbuf 1374 (unless outbuf
1375 (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) 1375 (kill-buffer (tramp-get-connection-property v "process-buffer" nil)))
1376 1376 (when process-file-side-effects
1377 (unless process-file-side-effects
1378 (tramp-flush-directory-properties v "")) 1377 (tramp-flush-directory-properties v ""))
1379 1378
1380 ;; Return exit status. 1379 ;; Return exit status.
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 0a5bf2f43b3..72837793de4 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -137,7 +137,7 @@
137 (set-file-acl . ignore) 137 (set-file-acl . ignore)
138 (set-file-modes . tramp-sshfs-handle-set-file-modes) 138 (set-file-modes . tramp-sshfs-handle-set-file-modes)
139 (set-file-selinux-context . ignore) 139 (set-file-selinux-context . ignore)
140 (set-file-times . ignore) 140 (set-file-times . tramp-sshfs-handle-set-file-times)
141 (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) 141 (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
142 (shell-command . tramp-handle-shell-command) 142 (shell-command . tramp-handle-shell-command)
143 (start-file-process . tramp-handle-start-file-process) 143 (start-file-process . tramp-handle-start-file-process)
@@ -242,13 +242,28 @@ arguments to pass to the OPERATION."
242 (let ((command 242 (let ((command
243 (format 243 (format
244 "cd %s && exec %s" 244 "cd %s && exec %s"
245 localname 245 (tramp-unquote-shell-quote-argument localname)
246 (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))) 246 (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))
247 input tmpinput)
248
249 ;; Determine input.
250 (if (null infile)
251 (setq input (tramp-get-remote-null-device v))
252 (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
253 (if (tramp-equal-remote default-directory infile)
254 ;; INFILE is on the same remote host.
255 (setq input (tramp-file-local-name infile))
256 ;; INFILE must be copied to remote host.
257 (setq input (tramp-make-tramp-temp-file v)
258 tmpinput (tramp-make-tramp-file-name v input))
259 (copy-file infile tmpinput t)))
260 (when input (setq command (format "%s <%s" command input)))
261
247 (unwind-protect 262 (unwind-protect
248 (apply 263 (apply
249 #'tramp-call-process 264 #'tramp-call-process
250 v (tramp-get-method-parameter v 'tramp-login-program) 265 v (tramp-get-method-parameter v 'tramp-login-program)
251 infile destination display 266 nil destination display
252 (tramp-expand-args 267 (tramp-expand-args
253 v 'tramp-login-args 268 v 'tramp-login-args
254 ?h (or (tramp-file-name-host v) "") 269 ?h (or (tramp-file-name-host v) "")
@@ -256,7 +271,11 @@ arguments to pass to the OPERATION."
256 ?p (or (tramp-file-name-port v) "") 271 ?p (or (tramp-file-name-port v) "")
257 ?l command)) 272 ?l command))
258 273
259 (unless process-file-side-effects 274 ;; Cleanup. We remove all file cache values for the
275 ;; connection, because the remote process could have changed
276 ;; them.
277 (when tmpinput (delete-file tmpinput))
278 (when process-file-side-effects
260 (tramp-flush-directory-properties v "")))))) 279 (tramp-flush-directory-properties v ""))))))
261 280
262(defun tramp-sshfs-handle-rename-file 281(defun tramp-sshfs-handle-rename-file
@@ -285,6 +304,15 @@ arguments to pass to the OPERATION."
285 (tramp-compat-set-file-modes 304 (tramp-compat-set-file-modes
286 (tramp-fuse-local-file-name filename) mode flag)))) 305 (tramp-fuse-local-file-name filename) mode flag))))
287 306
307(defun tramp-sshfs-handle-set-file-times (filename &optional timestamp flag)
308 "Like `set-file-times' for Tramp files."
309 (or (file-exists-p filename) (write-region "" nil filename nil 0))
310 (with-parsed-tramp-file-name filename nil
311 (unless (and (eq flag 'nofollow) (file-symlink-p filename))
312 (tramp-flush-file-properties v localname)
313 (tramp-compat-set-file-times
314 (tramp-fuse-local-file-name filename) timestamp flag))))
315
288(defun tramp-sshfs-handle-write-region 316(defun tramp-sshfs-handle-write-region
289 (start end filename &optional append visit lockname mustbenew) 317 (start end filename &optional append visit lockname mustbenew)
290 "Like `write-region' for Tramp files." 318 "Like `write-region' for Tramp files."
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index a68d4b3e365..7fbe5412709 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -572,8 +572,7 @@ the result will be a local, non-Tramp, file name."
572 (when (file-remote-p result) 572 (when (file-remote-p result)
573 (setq result (tramp-compat-file-name-quote result 'top))) 573 (setq result (tramp-compat-file-name-quote result 'top)))
574 (tramp-message v 4 "True name of `%s' is `%s'" localname result) 574 (tramp-message v 4 "True name of `%s' is `%s'" localname result)
575 result)) 575 result)))))))
576 'nohop)))))
577 576
578(defun tramp-sudoedit-handle-file-writable-p (filename) 577(defun tramp-sudoedit-handle-file-writable-p (filename)
579 "Like `file-writable-p' for Tramp files." 578 "Like `file-writable-p' for Tramp files."
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 7d6157ed8c2..b258121549d 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1713,13 +1713,10 @@ See `tramp-dissect-file-name' for details."
1713 "Construct a Tramp file name from ARGS. 1713 "Construct a Tramp file name from ARGS.
1714 1714
1715ARGS could have two different signatures. The first one is of 1715ARGS could have two different signatures. The first one is of
1716type (VEC &optional LOCALNAME HOP). 1716type (VEC &optional LOCALNAME).
1717If LOCALNAME is nil, the value in VEC is used. If it is a 1717If LOCALNAME is nil, the value in VEC is used. If it is a
1718symbol, a null localname will be used. Otherwise, LOCALNAME is 1718symbol, a null localname will be used. Otherwise, LOCALNAME is
1719expected to be a string, which will be used. 1719expected to be a string, which will be used.
1720If HOP is nil, the value in VEC is used. If it is a symbol, a
1721null hop will be used. Otherwise, HOP is expected to be a
1722string, which will be used.
1723 1720
1724The other signature exists for backward compatibility. It has 1721The other signature exists for backward compatibility. It has
1725the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." 1722the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
@@ -1735,8 +1732,13 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
1735 hop (tramp-file-name-hop (car args))) 1732 hop (tramp-file-name-hop (car args)))
1736 (when (cadr args) 1733 (when (cadr args)
1737 (setq localname (and (stringp (cadr args)) (cadr args)))) 1734 (setq localname (and (stringp (cadr args)) (cadr args))))
1738 (when (cl-caddr args) 1735 (when hop
1739 (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) 1736 (setq hop nil)
1737 ;; Assure that the hops are in `tramp-default-proxies-alist'.
1738 ;; In tramp-archive.el, the slot `hop' is used for the archive
1739 ;; file name.
1740 (unless (string-equal method "archive")
1741 (tramp-add-hops (car args)))))
1740 1742
1741 (t (setq method (nth 0 args) 1743 (t (setq method (nth 0 args)
1742 user (nth 1 args) 1744 user (nth 1 args)
@@ -1769,15 +1771,17 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
1769 localname))) 1771 localname)))
1770 1772
1771(set-advertised-calling-convention 1773(set-advertised-calling-convention
1772 #'tramp-make-tramp-file-name '(vec &optional localname hop) "27.1") 1774 #'tramp-make-tramp-file-name '(vec &optional localname) "29.1")
1773 1775
1774(defun tramp-make-tramp-hop-name (vec) 1776(defun tramp-make-tramp-hop-name (vec)
1775 "Construct a Tramp hop name from VEC." 1777 "Construct a Tramp hop name from VEC."
1776 (replace-regexp-in-string 1778 (concat
1777 tramp-prefix-regexp "" 1779 (tramp-file-name-hop vec)
1778 (replace-regexp-in-string 1780 (replace-regexp-in-string
1779 (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format 1781 tramp-prefix-regexp ""
1780 (tramp-make-tramp-file-name vec 'noloc)))) 1782 (replace-regexp-in-string
1783 (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format
1784 (tramp-make-tramp-file-name vec 'noloc)))))
1781 1785
1782(defun tramp-completion-make-tramp-file-name (method user host localname) 1786(defun tramp-completion-make-tramp-file-name (method user host localname)
1783 "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. 1787 "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME.
@@ -1811,7 +1815,7 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet."
1811 (tramp-get-connection-property vec "process-buffer" nil)) 1815 (tramp-get-connection-property vec "process-buffer" nil))
1812 (setq buffer-undo-list t 1816 (setq buffer-undo-list t
1813 default-directory 1817 default-directory
1814 (tramp-make-tramp-file-name vec 'noloc 'nohop)) 1818 (tramp-make-tramp-file-name vec 'noloc))
1815 (current-buffer))))) 1819 (current-buffer)))))
1816 1820
1817(defun tramp-get-connection-buffer (vec &optional dont-create) 1821(defun tramp-get-connection-buffer (vec &optional dont-create)
@@ -1926,7 +1930,7 @@ The outline level is equal to the verbosity of the Tramp message."
1926 "A predicate for Tramp interactive commands. 1930 "A predicate for Tramp interactive commands.
1927They are completed by \"M-x TAB\" only in Tramp debug buffers." 1931They are completed by \"M-x TAB\" only in Tramp debug buffers."
1928 (with-current-buffer buffer 1932 (with-current-buffer buffer
1929 (string-equal (buffer-substring 1 10) ";; Emacs:"))) 1933 (string-equal (buffer-substring 1 (min 10 (point-max))) ";; Emacs:")))
1930 1934
1931(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) 1935(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t)
1932 1936
@@ -2596,11 +2600,10 @@ Must be handled by the callers."
2596 ;; Unknown file primitive. 2600 ;; Unknown file primitive.
2597 (t (error "Unknown file I/O primitive: %s" operation)))) 2601 (t (error "Unknown file I/O primitive: %s" operation))))
2598 2602
2599(defun tramp-find-foreign-file-name-handler (filename &optional _operation) 2603(defun tramp-find-foreign-file-name-handler (vec &optional _operation)
2600 "Return foreign file name handler if exists." 2604 "Return foreign file name handler if exists."
2601 (when (tramp-tramp-file-p filename) 2605 (when (tramp-file-name-p vec)
2602 (let ((handler tramp-foreign-file-name-handler-alist) 2606 (let ((handler tramp-foreign-file-name-handler-alist)
2603 (vec (tramp-dissect-file-name filename))
2604 elt func res) 2607 elt func res)
2605 (while handler 2608 (while handler
2606 (setq elt (car handler) 2609 (setq elt (car handler)
@@ -2633,7 +2636,7 @@ Fall back to normal file name handler if no Tramp file name handler exists."
2633 (with-parsed-tramp-file-name filename nil 2636 (with-parsed-tramp-file-name filename nil
2634 (let ((current-connection tramp-current-connection) 2637 (let ((current-connection tramp-current-connection)
2635 (foreign 2638 (foreign
2636 (tramp-find-foreign-file-name-handler filename operation)) 2639 (tramp-find-foreign-file-name-handler v operation))
2637 (signal-hook-function #'tramp-signal-hook-function) 2640 (signal-hook-function #'tramp-signal-hook-function)
2638 result) 2641 result)
2639 ;; Set `tramp-current-connection'. 2642 ;; Set `tramp-current-connection'.
@@ -3351,7 +3354,7 @@ User is always nil."
3351 (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename) 3354 (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename)
3352 (tramp-make-tramp-file-name 3355 (tramp-make-tramp-file-name
3353 vec (concat "~" (substring filename (match-beginning 1)))) 3356 vec (concat "~" (substring filename (match-beginning 1))))
3354 filename))) 3357 (tramp-make-tramp-file-name (tramp-dissect-file-name filename)))))
3355 3358
3356(defun tramp-handle-access-file (filename string) 3359(defun tramp-handle-access-file (filename string)
3357 "Like `access-file' for Tramp files." 3360 "Like `access-file' for Tramp files."
@@ -3678,8 +3681,8 @@ User is always nil."
3678 ;; We do not want traces in the debug buffer. 3681 ;; We do not want traces in the debug buffer.
3679 (let ((tramp-verbose (min tramp-verbose 3))) 3682 (let ((tramp-verbose (min tramp-verbose 3)))
3680 (when (tramp-tramp-file-p filename) 3683 (when (tramp-tramp-file-p filename)
3681 (let* ((v (tramp-dissect-file-name filename)) 3684 (let* ((o (tramp-dissect-file-name filename))
3682 (p (tramp-get-connection-process v)) 3685 (p (tramp-get-connection-process o))
3683 (c (and (process-live-p p) 3686 (c (and (process-live-p p)
3684 (tramp-get-connection-property p "connected" nil)))) 3687 (tramp-get-connection-property p "connected" nil))))
3685 ;; We expand the file name only, if there is already a connection. 3688 ;; We expand the file name only, if there is already a connection.
@@ -3693,7 +3696,8 @@ User is always nil."
3693 ((eq identification 'user) (tramp-file-name-user-domain v)) 3696 ((eq identification 'user) (tramp-file-name-user-domain v))
3694 ((eq identification 'host) (tramp-file-name-host-port v)) 3697 ((eq identification 'host) (tramp-file-name-host-port v))
3695 ((eq identification 'localname) localname) 3698 ((eq identification 'localname) localname)
3696 ((eq identification 'hop) hop) 3699 ;; Hop exists only in original dissected file name.
3700 ((eq identification 'hop) (tramp-file-name-hop o))
3697 (t (tramp-make-tramp-file-name v 'noloc))))))))) 3701 (t (tramp-make-tramp-file-name v 'noloc)))))))))
3698 3702
3699(defun tramp-handle-file-selinux-context (_filename) 3703(defun tramp-handle-file-selinux-context (_filename)
@@ -3744,8 +3748,7 @@ User is always nil."
3744 (expand-file-name 3748 (expand-file-name
3745 symlink-target 3749 symlink-target
3746 (file-name-directory v2-localname)))) 3750 (file-name-directory v2-localname))))
3747 v2-localname) 3751 v2-localname))))
3748 'nohop)))
3749 (when (>= numchase numchase-limit) 3752 (when (>= numchase numchase-limit)
3750 (tramp-error 3753 (tramp-error
3751 v1 'file-error 3754 v1 'file-error
@@ -3904,8 +3907,7 @@ User is always nil."
3904 (cond 3907 (cond
3905 ((stringp remote-copy) 3908 ((stringp remote-copy)
3906 (file-local-copy 3909 (file-local-copy
3907 (tramp-make-tramp-file-name 3910 (tramp-make-tramp-file-name v remote-copy)))
3908 v remote-copy 'nohop)))
3909 ((stringp tramp-temp-buffer-file-name) 3911 ((stringp tramp-temp-buffer-file-name)
3910 (copy-file 3912 (copy-file
3911 filename tramp-temp-buffer-file-name 'ok) 3913 filename tramp-temp-buffer-file-name 'ok)
@@ -3948,7 +3950,7 @@ User is always nil."
3948 (or remote-copy (null tramp-temp-buffer-file-name))) 3950 (or remote-copy (null tramp-temp-buffer-file-name)))
3949 (delete-file local-copy)) 3951 (delete-file local-copy))
3950 (when (stringp remote-copy) 3952 (when (stringp remote-copy)
3951 (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))) 3953 (delete-file (tramp-make-tramp-file-name v remote-copy))))
3952 3954
3953 ;; Result. 3955 ;; Result.
3954 (cons filename (cdr result))))) 3956 (cons filename (cdr result)))))
@@ -4088,15 +4090,10 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
4088 (and (tramp-sh-file-name-handler-p vec) 4090 (and (tramp-sh-file-name-handler-p vec)
4089 (not (tramp-get-method-parameter vec 'tramp-copy-program)))) 4091 (not (tramp-get-method-parameter vec 'tramp-copy-program))))
4090 4092
4091(defun tramp-compute-multi-hops (vec) 4093(defun tramp-add-hops (vec)
4092 "Expands VEC according to `tramp-default-proxies-alist'." 4094 "Add ad-hoc proxy definitions to `tramp-default-proxies-alist'."
4093 (let ((saved-tdpa tramp-default-proxies-alist) 4095 (when-let ((hops (tramp-file-name-hop vec))
4094 (target-alist `(,vec)) 4096 (item vec))
4095 (hops (or (tramp-file-name-hop vec) ""))
4096 (item vec)
4097 choices proxy)
4098
4099 ;; Ad-hoc proxy definitions.
4100 (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) 4097 (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit)))
4101 (let* ((host-port (tramp-file-name-host-port item)) 4098 (let* ((host-port (tramp-file-name-host-port item))
4102 (user-domain (tramp-file-name-user-domain item)) 4099 (user-domain (tramp-file-name-user-domain item))
@@ -4113,9 +4110,19 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
4113 (add-to-list 'tramp-default-proxies-alist entry) 4110 (add-to-list 'tramp-default-proxies-alist entry)
4114 (setq item (tramp-dissect-file-name proxy)))) 4111 (setq item (tramp-dissect-file-name proxy))))
4115 ;; Save the new value. 4112 ;; Save the new value.
4116 (when (and hops tramp-save-ad-hoc-proxies) 4113 (when tramp-save-ad-hoc-proxies
4117 (customize-save-variable 4114 (customize-save-variable
4118 'tramp-default-proxies-alist tramp-default-proxies-alist)) 4115 'tramp-default-proxies-alist tramp-default-proxies-alist))))
4116
4117(defun tramp-compute-multi-hops (vec)
4118 "Expands VEC according to `tramp-default-proxies-alist'."
4119 (let ((saved-tdpa tramp-default-proxies-alist)
4120 (target-alist `(,vec))
4121 (item vec)
4122 choices proxy)
4123
4124 ;; Ad-hoc proxy definitions.
4125 (tramp-add-hops vec)
4119 4126
4120 ;; Look for proxy hosts to be passed. 4127 ;; Look for proxy hosts to be passed.
4121 (setq choices tramp-default-proxies-alist) 4128 (setq choices tramp-default-proxies-alist)
@@ -5462,8 +5469,7 @@ This handles also chrooted environments, which are not regarded as local."
5462 (null tramp-crypt-enabled) 5469 (null tramp-crypt-enabled)
5463 ;; The local temp directory must be writable for the other user. 5470 ;; The local temp directory must be writable for the other user.
5464 (file-writable-p 5471 (file-writable-p
5465 (tramp-make-tramp-file-name 5472 (tramp-make-tramp-file-name vec tramp-compat-temporary-file-directory))
5466 vec tramp-compat-temporary-file-directory 'nohop))
5467 ;; On some systems, chown runs only for root. 5473 ;; On some systems, chown runs only for root.
5468 (or (zerop (user-uid)) 5474 (or (zerop (user-uid))
5469 (zerop (tramp-get-remote-uid vec 'integer)))))) 5475 (zerop (tramp-get-remote-uid vec 'integer))))))
@@ -5712,7 +5718,7 @@ Invokes `password-read' if available, `read-passwd' else."
5712 ;; multi-hop. 5718 ;; multi-hop.
5713 (tramp-get-connection-property 5719 (tramp-get-connection-property
5714 proc "password-vector" (process-get proc 'vector)) 5720 proc "password-vector" (process-get proc 'vector))
5715 'noloc 'nohop)) 5721 'noloc))
5716 (pw-prompt 5722 (pw-prompt
5717 (or prompt 5723 (or prompt
5718 (with-current-buffer (process-buffer proc) 5724 (with-current-buffer (process-buffer proc)
@@ -5789,7 +5795,7 @@ Invokes `password-read' if available, `read-passwd' else."
5789 (auth-source-forget 5795 (auth-source-forget
5790 `(:max 1 ,(and user-domain :user) ,user-domain 5796 `(:max 1 ,(and user-domain :user) ,user-domain
5791 :host ,host-port :port ,method)) 5797 :host ,host-port :port ,method))
5792 (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) 5798 (password-cache-remove (tramp-make-tramp-file-name vec 'noloc))))
5793 5799
5794(put #'tramp-clear-passwd 'tramp-suppress-trace t) 5800(put #'tramp-clear-passwd 'tramp-suppress-trace t)
5795 5801
diff --git a/lisp/org/ob-gnuplot.el b/lisp/org/ob-gnuplot.el
index 69a5f5f91bd..895738822de 100644
--- a/lisp/org/ob-gnuplot.el
+++ b/lisp/org/ob-gnuplot.el
@@ -129,6 +129,7 @@ code."
129 (title (cdr (assq :title params))) 129 (title (cdr (assq :title params)))
130 (lines (cdr (assq :line params))) 130 (lines (cdr (assq :line params)))
131 (sets (cdr (assq :set params))) 131 (sets (cdr (assq :set params)))
132 (missing (cdr (assq :missing params)))
132 (x-labels (cdr (assq :xlabels params))) 133 (x-labels (cdr (assq :xlabels params)))
133 (y-labels (cdr (assq :ylabels params))) 134 (y-labels (cdr (assq :ylabels params)))
134 (timefmt (cdr (assq :timefmt params))) 135 (timefmt (cdr (assq :timefmt params)))
@@ -138,6 +139,7 @@ code."
138 (file-name-directory (buffer-file-name)))) 139 (file-name-directory (buffer-file-name))))
139 (add-to-body (lambda (text) (setq body (concat text "\n" body))))) 140 (add-to-body (lambda (text) (setq body (concat text "\n" body)))))
140 ;; append header argument settings to body 141 ;; append header argument settings to body
142 (when missing (funcall add-to-body (format "set datafile missing '%s'" missing)))
141 (when title (funcall add-to-body (format "set title '%s'" title))) 143 (when title (funcall add-to-body (format "set title '%s'" title)))
142 (when lines (mapc (lambda (el) (funcall add-to-body el)) lines)) 144 (when lines (mapc (lambda (el) (funcall add-to-body el)) lines))
143 (when sets 145 (when sets
@@ -288,21 +290,14 @@ Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE."
288 (with-temp-file data-file 290 (with-temp-file data-file
289 (insert (let ((org-babel-gnuplot-timestamp-fmt 291 (insert (let ((org-babel-gnuplot-timestamp-fmt
290 (or (plist-get params :timefmt) "%Y-%m-%d-%H:%M:%S"))) 292 (or (plist-get params :timefmt) "%Y-%m-%d-%H:%M:%S")))
291 (replace-regexp-in-string 293 (orgtbl-to-generic
292 ;; org export backend adds "|" at the beginning/end of 294 table
293 ;; the table lines. Strip those. 295 (org-combine-plists
294 "^|\\(.+\\)|$" 296 '( :sep "\t" :fmt org-babel-gnuplot-quote-tsv-field
295 "\\1" 297 ;; Two setting below are needed to make :fmt work.
296 (orgtbl-to-generic 298 :raw t
297 table 299 :backend ascii)
298 (org-combine-plists 300 params)))))
299 '( :sep "\t" :fmt org-babel-gnuplot-quote-tsv-field
300 ;; Two setting below are needed to make :fmt work.
301 :raw t
302 ;; Use `org', not `ascii' because `ascii' may
303 ;; sometimes mishandle quoted strings.
304 :backend org)
305 params))))))
306 data-file) 301 data-file)
307 302
308(provide 'ob-gnuplot) 303(provide 'ob-gnuplot)
diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el
index fed36ac9b63..94aea1b0a32 100644
--- a/lisp/org/org-agenda.el
+++ b/lisp/org/org-agenda.el
@@ -86,6 +86,8 @@
86(declare-function org-capture "org-capture" (&optional goto keys)) 86(declare-function org-capture "org-capture" (&optional goto keys))
87(declare-function org-clock-modify-effort-estimate "org-clock" (&optional value)) 87(declare-function org-clock-modify-effort-estimate "org-clock" (&optional value))
88 88
89(declare-function org-element-type "org-element" (&optional element))
90
89(defvar calendar-mode-map) 91(defvar calendar-mode-map)
90(defvar org-clock-current-task) 92(defvar org-clock-current-task)
91(defvar org-current-tag-alist) 93(defvar org-current-tag-alist)
@@ -5729,7 +5731,8 @@ displayed in agenda view."
5729 (org-at-planning-p) 5731 (org-at-planning-p)
5730 (org-before-first-heading-p) 5732 (org-before-first-heading-p)
5731 (and org-agenda-include-inactive-timestamps 5733 (and org-agenda-include-inactive-timestamps
5732 (org-at-clock-log-p))) 5734 (org-at-clock-log-p))
5735 (not (eq 'timestamp (org-element-type (org-element-context)))))
5733 (throw :skip nil)) 5736 (throw :skip nil))
5734 (org-agenda-skip)) 5737 (org-agenda-skip))
5735 (let* ((pos (match-beginning 0)) 5738 (let* ((pos (match-beginning 0))
diff --git a/lisp/org/org-version.el b/lisp/org/org-version.el
index 1053bbe22cc..5337d9df746 100644
--- a/lisp/org/org-version.el
+++ b/lisp/org/org-version.el
@@ -11,7 +11,7 @@ Inserted by installing Org mode or when a release is made."
11(defun org-git-version () 11(defun org-git-version ()
12 "The Git version of Org mode. 12 "The Git version of Org mode.
13Inserted by installing Org or when a release is made." 13Inserted by installing Org or when a release is made."
14 (let ((org-git-version "release_9.5.2-3-geb9f34")) 14 (let ((org-git-version "release_9.5.2-9-g7ba24c"))
15 org-git-version)) 15 org-git-version))
16 16
17(provide 'org-version) 17(provide 'org-version)
diff --git a/lisp/org/org.el b/lisp/org/org.el
index fba45caabe6..f5d4df3d9c6 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -18731,17 +18731,19 @@ With prefix arg UNCOMPILED, load the uncompiled versions."
18731 "Is S an ID created by UUIDGEN?" 18731 "Is S an ID created by UUIDGEN?"
18732 (string-match "\\`[0-9a-f]\\{8\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{12\\}\\'" (downcase s))) 18732 (string-match "\\`[0-9a-f]\\{8\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{12\\}\\'" (downcase s)))
18733 18733
18734(defun org-in-src-block-p (&optional inside) 18734(defun org-in-src-block-p (&optional inside element)
18735 "Whether point is in a code source block. 18735 "Whether point is in a code source block.
18736When INSIDE is non-nil, don't consider we are within a source 18736When INSIDE is non-nil, don't consider we are within a source
18737block when point is at #+BEGIN_SRC or #+END_SRC." 18737block when point is at #+BEGIN_SRC or #+END_SRC.
18738 (let ((case-fold-search t)) 18738When ELEMENT is provided, it is considered to be element at point."
18739 (or (and (eq (get-char-property (point) 'src-block) t)) 18739 (save-match-data (setq element (or element (org-element-at-point))))
18740 (and (not inside) 18740 (when (eq 'src-block (org-element-type element))
18741 (save-match-data 18741 (or (not inside)
18742 (save-excursion 18742 (not (or (= (line-beginning-position)
18743 (beginning-of-line) 18743 (org-element-property :post-affiliated element))
18744 (looking-at ".*#\\+\\(begin\\|end\\)_src"))))))) 18744 (= (1+ (line-end-position))
18745 (- (org-element-property :end element)
18746 (org-element-property :post-blank element))))))))
18745 18747
18746(defun org-context () 18748(defun org-context ()
18747 "Return a list of contexts of the current cursor position. 18749 "Return a list of contexts of the current cursor position.
diff --git a/lisp/org/ox-ascii.el b/lisp/org/ox-ascii.el
index c22bb13b6dd..38b2a5772c1 100644
--- a/lisp/org/ox-ascii.el
+++ b/lisp/org/ox-ascii.el
@@ -1929,7 +1929,11 @@ a communication channel."
1929 (org-export-table-cell-alignment table-cell info))))) 1929 (org-export-table-cell-alignment table-cell info)))))
1930 (setq contents 1930 (setq contents
1931 (concat data 1931 (concat data
1932 (make-string (- width (string-width (or data ""))) ?\s)))) 1932 ;; FIXME: If CONTENTS was transformed by filters,
1933 ;; the whole width calculation can be wrong.
1934 ;; At least, make sure that we do not throw error
1935 ;; when CONTENTS is larger than width.
1936 (make-string (max 0 (- width (string-width (or data "")))) ?\s))))
1933 ;; Return cell. 1937 ;; Return cell.
1934 (concat (format " %s " contents) 1938 (concat (format " %s " contents)
1935 (when (memq 'right (org-export-table-cell-borders table-cell info)) 1939 (when (memq 'right (org-export-table-cell-borders table-cell info))
diff --git a/lisp/outline.el b/lisp/outline.el
index 4027142c94e..8e4af64370b 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -351,7 +351,8 @@ Turning on outline mode calls the value of `text-mode-hook' and then of
351 '(outline-font-lock-keywords t nil nil backward-paragraph)) 351 '(outline-font-lock-keywords t nil nil backward-paragraph))
352 (setq-local imenu-generic-expression 352 (setq-local imenu-generic-expression
353 (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0))) 353 (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0)))
354 (add-hook 'change-major-mode-hook #'outline-show-all nil t)) 354 (add-hook 'change-major-mode-hook #'outline-show-all nil t)
355 (add-hook 'hack-local-variables-hook #'outline-apply-default-state nil t))
355 356
356(defvar outline-minor-mode-map) 357(defvar outline-minor-mode-map)
357 358
@@ -434,7 +435,8 @@ See the command `outline-mode' for more information on this mode."
434 nil t) 435 nil t)
435 (setq-local line-move-ignore-invisible t) 436 (setq-local line-move-ignore-invisible t)
436 ;; Cause use of ellipses for invisible text. 437 ;; Cause use of ellipses for invisible text.
437 (add-to-invisibility-spec '(outline . t))) 438 (add-to-invisibility-spec '(outline . t))
439 (outline-apply-default-state))
438 (when outline-minor-mode-highlight 440 (when outline-minor-mode-highlight
439 (if font-lock-fontified 441 (if font-lock-fontified
440 (font-lock-remove-keywords nil outline-font-lock-keywords)) 442 (font-lock-remove-keywords nil outline-font-lock-keywords))
@@ -1303,6 +1305,178 @@ convenient way to make a table of contents of the buffer."
1303 (insert "\n\n")))))) 1305 (insert "\n\n"))))))
1304 (kill-new (buffer-string))))))) 1306 (kill-new (buffer-string)))))))
1305 1307
1308(defcustom outline-default-state nil
1309 "If non-nil, some headings are initially outlined.
1310
1311Note that the default state is applied when the major mode is set
1312or when the command `outline-apply-default-state' is called
1313interactively.
1314
1315When nil, headings visibility is left unchanged.
1316
1317If equal to `outline-show-all', all text of buffer is shown.
1318
1319If equal to `outline-show-only-headings', only headings are shown.
1320
1321If equal to a number, show only headings up to and including the
1322corresponding level. See `outline-default-rules' to customize
1323visibility of the subtree at the choosen level.
1324
1325If equal to a lambda function or function name, this function is
1326expected to toggle headings visibility, and will be called after
1327the mode is enabled."
1328 :version "29.1"
1329 :type '(choice (const :tag "Disabled" nil)
1330 (const :tag "Show all" outline-show-all)
1331 (const :tag "Only headings" outline-show-only-headings)
1332 (natnum :tag "Show headings up to level" :value 1)
1333 (function :tag "Custom function")))
1334
1335(defcustom outline-default-rules nil
1336 "Determines visibility of subtree starting at `outline-default-state' level.
1337
1338When nil, the subtree is hidden unconditionally.
1339
1340When equal to a list, each element should be one of the following:
1341
1342- A cons cell with CAR `match-regexp' and CDR a regexp, the
1343 subtree will be hidden when the outline heading match the
1344 regexp.
1345
1346- `subtree-has-long-lines' to only show the heading branches when
1347 long lines are detected in its subtree (see
1348 `outline-default-long-line' for the definition of long lines).
1349
1350- `subtree-is-long' to only show the heading branches when its
1351 subtree contains more than `outline-default-line-count' lines.
1352
1353- A lambda function or function name which will be evaluated with
1354 point at the beginning of the heading and the match data set
1355 appropriately, the function being expected to toggle the
1356 heading visibility."
1357 :version "29.1"
1358 :type '(choice (const :tag "Hide subtree" nil)
1359 (set :tag "Show subtree unless"
1360 (cons :tag "Heading match regexp"
1361 (const match-regexp) string)
1362 (const :tag "Subtree has long lines"
1363 subtree-has-long-lines)
1364 (const :tag "Subtree is long"
1365 subtree-is-long)
1366 (cons :tag "Custom function"
1367 (const custom-function) function))))
1368
1369(defcustom outline-default-long-line 1000
1370 "Minimal number of characters in a line for a heading to be outlined."
1371 :version "29.1"
1372 :type '(natnum :tag "Number of characters"))
1373
1374(defcustom outline-default-line-count 50
1375 "Minimal number of lines for a heading to be outlined."
1376 :version "29.1"
1377 :type '(natnum :tag "Number of lines"))
1378
1379(defun outline-apply-default-state ()
1380 "Apply the outline state defined by `outline-default-state'."
1381 (interactive)
1382 (cond
1383 ((integerp outline-default-state)
1384 (outline--show-headings-up-to-level outline-default-state))
1385 ((functionp outline-default-state)
1386 (funcall outline-default-state))))
1387
1388(defun outline-show-only-headings ()
1389 "Show only headings."
1390 (interactive)
1391 (outline-show-all)
1392 (outline-hide-region-body (point-min) (point-max)))
1393
1394(eval-when-compile (require 'so-long))
1395(autoload 'so-long-detected-long-line-p "so-long")
1396(defvar so-long-skip-leading-comments)
1397(defvar so-long-threshold)
1398(defvar so-long-max-lines)
1399
1400(defun outline--show-headings-up-to-level (level)
1401 "Show only headings up to a LEVEL level.
1402
1403Like `outline-hide-sublevels' but, for each heading at level
1404LEVEL, decides of subtree visibility according to
1405`outline-default-rules'."
1406 (if (not outline-default-rules)
1407 (outline-hide-sublevels level)
1408 (if (< level 1)
1409 (error "Must keep at least one level of headers"))
1410 (save-excursion
1411 (let* (outline-view-change-hook
1412 (beg (progn
1413 (goto-char (point-min))
1414 ;; Skip the prelude, if any.
1415 (unless (outline-on-heading-p t) (outline-next-heading))
1416 (point)))
1417 (end (progn
1418 (goto-char (point-max))
1419 ;; Keep empty last line, if available.
1420 (if (bolp) (1- (point)) (point))))
1421 (heading-regexp
1422 (cdr-safe
1423 (assoc 'match-regexp outline-default-rules)))
1424 (check-line-count
1425 (memq 'subtree-is-long outline-default-rules))
1426 (check-long-lines
1427 (memq 'subtree-has-long-lines outline-default-rules))
1428 (custom-function
1429 (cdr-safe
1430 (assoc 'custom-function outline-default-rules))))
1431 (if (< end beg)
1432 (setq beg (prog1 end (setq end beg))))
1433 ;; First hide everything.
1434 (outline-hide-sublevels level)
1435 ;; Then unhide the top level headers.
1436 (outline-map-region
1437 (lambda ()
1438 (let ((current-level (funcall outline-level)))
1439 (when (< current-level level)
1440 (outline-show-heading)
1441 (outline-show-entry))
1442 (when (= current-level level)
1443 (cond
1444 ((and heading-regexp
1445 (let ((beg (point))
1446 (end (progn (outline-end-of-heading) (point))))
1447 (string-match-p heading-regexp (buffer-substring beg end))))
1448 ;; hide entry when heading match regexp
1449 (outline-hide-entry))
1450 ((and check-line-count
1451 (save-excursion
1452 (let ((beg (point))
1453 (end (progn (outline-end-of-subtree) (point))))
1454 (<= outline-default-line-count (count-lines beg end)))))
1455 ;; show only branches when line count of subtree >
1456 ;; threshold
1457 (outline-show-branches))
1458 ((and check-long-lines
1459 (save-excursion
1460 (let ((beg (point))
1461 (end (progn (outline-end-of-subtree) (point))))
1462 (save-restriction
1463 (narrow-to-region beg end)
1464 (let ((so-long-skip-leading-comments nil)
1465 (so-long-threshold outline-default-long-line)
1466 (so-long-max-lines nil))
1467 (so-long-detected-long-line-p))))))
1468 ;; show only branches when long lines are detected
1469 ;; in subtree
1470 (outline-show-branches))
1471 (custom-function
1472 ;; call custom function if defined
1473 (funcall custom-function))
1474 (t
1475 ;; if no previous clause succeeds, show subtree
1476 (outline-show-subtree))))))
1477 beg end)))
1478 (run-hooks 'outline-view-change-hook)))
1479
1306(defun outline--cycle-state () 1480(defun outline--cycle-state ()
1307 "Return the cycle state of current heading. 1481 "Return the cycle state of current heading.
1308Return either 'hide-all, 'headings-only, or 'show-all." 1482Return either 'hide-all, 'headings-only, or 'show-all."
diff --git a/lisp/paren.el b/lisp/paren.el
index a1f74f2097e..0065bba72e7 100644
--- a/lisp/paren.el
+++ b/lisp/paren.el
@@ -330,9 +330,7 @@ It is the default value of `show-paren-data-function'."
330 (let ((open-paren-line-string 330 (let ((open-paren-line-string
331 (blink-paren-open-paren-line-string openparen)) 331 (blink-paren-open-paren-line-string openparen))
332 (message-log-max nil)) 332 (message-log-max nil))
333 (minibuffer-message 333 (minibuffer-message "Matches %s" open-paren-line-string))))
334 "Matches %s"
335 (substring-no-properties open-paren-line-string)))))
336 ;; Always set the overlay face, since it varies. 334 ;; Always set the overlay face, since it varies.
337 (overlay-put show-paren--overlay 'priority show-paren-priority) 335 (overlay-put show-paren--overlay 'priority show-paren-priority)
338 (overlay-put show-paren--overlay 'face face)))))) 336 (overlay-put show-paren--overlay 'face face))))))
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index 3f78c9eb15b..b42279415bc 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -869,7 +869,8 @@ the buffer in which this command was invoked."
869COMMAND is the prefix for which we seek completion. 869COMMAND is the prefix for which we seek completion.
870CONTEXT is the text before COMMAND on the line." 870CONTEXT is the text before COMMAND on the line."
871 (let* ((complete-list 871 (let* ((complete-list
872 (gud-gdb-run-command-fetch-lines (concat "complete " context command) 872 (gud-gdb-run-command-fetch-lines (concat "server complete "
873 context command)
873 (current-buffer) 874 (current-buffer)
874 ;; From string-match above. 875 ;; From string-match above.
875 (length context)))) 876 (length context))))
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index 72631a6557f..eb54ffe05a8 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -325,6 +325,13 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'."
325 "Use `ruby-encoding-map' to set encoding magic comment if this is non-nil." 325 "Use `ruby-encoding-map' to set encoding magic comment if this is non-nil."
326 :type 'boolean :group 'ruby) 326 :type 'boolean :group 'ruby)
327 327
328(defcustom ruby-toggle-block-space-before-parameters t
329 "When non-nil, ensure space between the \"toggled\" curly and parameters.
330This only affects the output of the command `ruby-toggle-block'."
331 :type 'boolean
332 :safe 'booleanp
333 :version "29.1")
334
328;;; SMIE support 335;;; SMIE support
329 336
330(require 'smie) 337(require 'smie)
@@ -1722,13 +1729,14 @@ See `add-log-current-defun-function'."
1722 (insert "}") 1729 (insert "}")
1723 (goto-char orig) 1730 (goto-char orig)
1724 (delete-char 2) 1731 (delete-char 2)
1725 ;; Maybe this should be customizable, let's see if anyone asks. 1732 (insert "{")
1726 (insert "{ ") 1733 (if (looking-at "\\s +|")
1727 (setq beg-marker (point-marker)) 1734 (progn
1728 (when (looking-at "\\s +|") 1735 (just-one-space (if ruby-toggle-block-space-before-parameters 1 0))
1729 (delete-char (- (match-end 0) (match-beginning 0) 1)) 1736 (setq beg-marker (point-marker))
1730 (forward-char) 1737 (forward-char)
1731 (re-search-forward "|" (line-end-position) t)) 1738 (re-search-forward "|" (line-end-position) t))
1739 (setq beg-marker (point-marker)))
1732 (save-excursion 1740 (save-excursion
1733 (skip-chars-forward " \t\n\r") 1741 (skip-chars-forward " \t\n\r")
1734 (setq beg-pos (point)) 1742 (setq beg-pos (point))
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 066c051cfc3..37e2159782f 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -118,16 +118,16 @@ When it is a file name, it should be the \"expanded\" version.")
118(defcustom xref-file-name-display 'project-relative 118(defcustom xref-file-name-display 'project-relative
119 "Style of file name display in *xref* buffers. 119 "Style of file name display in *xref* buffers.
120 120
121If the value is the symbol `abs', the default, show the file names 121If the value is the symbol `abs', show the file names in their
122in their full absolute form. 122full absolute form.
123 123
124If `nondirectory', show only the nondirectory (a.k.a. \"base name\") 124If `nondirectory', show only the nondirectory (a.k.a. \"base name\")
125part of the file name. 125part of the file name.
126 126
127If `project-relative', show only the file name relative to the 127If `project-relative', the default, show only the file name
128current project root. If there is no current project, or if the 128relative to the current project root. If there is no current
129file resides outside of its root, show that particular file name 129project, or if the file resides outside of its root, show that
130in its full absolute form." 130particular file name in its full absolute form."
131 :type '(choice (const :tag "absolute file name" abs) 131 :type '(choice (const :tag "absolute file name" abs)
132 (const :tag "nondirectory file name" nondirectory) 132 (const :tag "nondirectory file name" nondirectory)
133 (const :tag "relative to project root" project-relative)) 133 (const :tag "relative to project root" project-relative))
diff --git a/lisp/simple.el b/lisp/simple.el
index c73c94b53ad..801a3c992c8 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2306,8 +2306,8 @@ maps."
2306 (let* ((execute-extended-command--last-typed nil) 2306 (let* ((execute-extended-command--last-typed nil)
2307 (keymaps 2307 (keymaps
2308 ;; The major mode's keymap and any active minor modes. 2308 ;; The major mode's keymap and any active minor modes.
2309 (cons 2309 (nconc
2310 (current-local-map) 2310 (and (current-local-map) (list (current-local-map)))
2311 (mapcar 2311 (mapcar
2312 #'cdr 2312 #'cdr
2313 (seq-filter 2313 (seq-filter
@@ -2957,7 +2957,8 @@ undo record: if we undo from 4, `pending-undo-list' will be at 3,
2957 2957
2958(defcustom undo-no-redo nil 2958(defcustom undo-no-redo nil
2959 "If t, `undo' doesn't go through redo entries." 2959 "If t, `undo' doesn't go through redo entries."
2960 :type 'boolean) 2960 :type 'boolean
2961 :group 'undo)
2961 2962
2962(defvar pending-undo-list nil 2963(defvar pending-undo-list nil
2963 "Within a run of consecutive undo commands, list remaining to be undone. 2964 "Within a run of consecutive undo commands, list remaining to be undone.
@@ -9440,9 +9441,6 @@ PREFIX is the string that represents this modifier in an event type symbol."
9440(defvar clone-buffer-hook nil 9441(defvar clone-buffer-hook nil
9441 "Normal hook to run in the new buffer at the end of `clone-buffer'.") 9442 "Normal hook to run in the new buffer at the end of `clone-buffer'.")
9442 9443
9443(defvar clone-indirect-buffer-hook nil
9444 "Normal hook to run in the new buffer at the end of `clone-indirect-buffer'.")
9445
9446(defun clone-process (process &optional newname) 9444(defun clone-process (process &optional newname)
9447 "Create a twin copy of PROCESS. 9445 "Create a twin copy of PROCESS.
9448If NEWNAME is nil, it defaults to PROCESS' name; 9446If NEWNAME is nil, it defaults to PROCESS' name;
@@ -9595,8 +9593,6 @@ Returns the newly created indirect buffer."
9595 (setq newname (substring newname 0 (match-beginning 0)))) 9593 (setq newname (substring newname 0 (match-beginning 0))))
9596 (let* ((name (generate-new-buffer-name newname)) 9594 (let* ((name (generate-new-buffer-name newname))
9597 (buffer (make-indirect-buffer (current-buffer) name t))) 9595 (buffer (make-indirect-buffer (current-buffer) name t)))
9598 (with-current-buffer buffer
9599 (run-hooks 'clone-indirect-buffer-hook))
9600 (when display-flag 9596 (when display-flag
9601 (pop-to-buffer buffer nil norecord)) 9597 (pop-to-buffer buffer nil norecord))
9602 buffer)) 9598 buffer))
diff --git a/lisp/subr.el b/lisp/subr.el
index dd260dfe418..81c02338531 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4294,11 +4294,13 @@ in which case `save-window-excursion' cannot help."
4294(defmacro with-output-to-temp-buffer (bufname &rest body) 4294(defmacro with-output-to-temp-buffer (bufname &rest body)
4295 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. 4295 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
4296 4296
4297This construct makes buffer BUFNAME empty before running BODY. 4297This is a convenience macro meant for displaying help buffers and
4298It does not make the buffer current for BODY. 4298the like. It empties the BUFNAME buffer before evaluating BODY
4299Instead it binds `standard-output' to that buffer, so that output 4299and disables undo in that buffer.
4300generated with `prin1' and similar functions in BODY goes into 4300
4301the buffer. 4301It does not make the buffer current for BODY. Instead it binds
4302`standard-output' to that buffer, so that output generated with
4303`prin1' and similar functions in BODY goes into the buffer.
4302 4304
4303At the end of BODY, this marks buffer BUFNAME unmodified and displays 4305At the end of BODY, this marks buffer BUFNAME unmodified and displays
4304it in a window, but does not select it. The normal way to do this is 4306it in a window, but does not select it. The normal way to do this is
diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
index ff9402c4acb..4c06f7f58aa 100644
--- a/lisp/term/haiku-win.el
+++ b/lisp/term/haiku-win.el
@@ -50,6 +50,7 @@
50(declare-function haiku-selection-data "haikuselect.c") 50(declare-function haiku-selection-data "haikuselect.c")
51(declare-function haiku-selection-put "haikuselect.c") 51(declare-function haiku-selection-put "haikuselect.c")
52(declare-function haiku-selection-targets "haikuselect.c") 52(declare-function haiku-selection-targets "haikuselect.c")
53(declare-function haiku-selection-owner-p "haikuselect.c")
53(declare-function haiku-put-resource "haikufns.c") 54(declare-function haiku-put-resource "haikufns.c")
54 55
55(defun haiku--handle-x-command-line-resources (command-line-resources) 56(defun haiku--handle-x-command-line-resources (command-line-resources)
@@ -105,9 +106,8 @@ If TYPE is nil, return \"text/plain\"."
105 &context (window-system haiku)) 106 &context (window-system haiku))
106 (haiku-selection-data selection "text/plain")) 107 (haiku-selection-data selection "text/plain"))
107 108
108(cl-defmethod gui-backend-selection-owner-p (_ 109(cl-defmethod gui-backend-selection-owner-p (selection &context (window-system haiku))
109 &context (window-system haiku)) 110 (haiku-selection-owner-p selection))
110 t)
111 111
112(declare-function haiku-read-file-name "haikufns.c") 112(declare-function haiku-read-file-name "haikufns.c")
113 113
@@ -136,6 +136,16 @@ If TYPE is nil, return \"text/plain\"."
136(define-key special-event-map [drag-n-drop] 136(define-key special-event-map [drag-n-drop]
137 'haiku-dnd-handle-drag-n-drop-event) 137 'haiku-dnd-handle-drag-n-drop-event)
138 138
139(defvaralias 'haiku-use-system-tooltips 'use-system-tooltips)
140
141(defun haiku-use-system-tooltips-watcher (&rest _ignored)
142 "Variable watcher to force a menu bar update when `use-system-tooltip' changes.
143This is necessary because on Haiku `use-system-tooltip' doesn't
144take effect on menu items until the menu bar is updated again."
145 (force-mode-line-update t))
146
147(add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher)
148
139(provide 'haiku-win) 149(provide 'haiku-win)
140(provide 'term/haiku-win) 150(provide 'term/haiku-win)
141 151
diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el
index 9bcf3eac646..25f3a851dcc 100644
--- a/lisp/term/pgtk-win.el
+++ b/lisp/term/pgtk-win.el
@@ -510,6 +510,8 @@ This uses `icon-map-list' to map icon file names to stock icon names."
510 (t 510 (t
511 (popup-menu (mouse-menu-bar-map) last-nonmenu-event)))) 511 (popup-menu (mouse-menu-bar-map) last-nonmenu-event))))
512 512
513(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips)
514
513(provide 'pgtk-win) 515(provide 'pgtk-win)
514(provide 'term/pgtk-win) 516(provide 'term/pgtk-win)
515 517
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index e52e488edab..019a01e22ca 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1527,16 +1527,32 @@ This uses `icon-map-list' to map icon file names to stock icon names."
1527(defvar x-preedit-overlay nil 1527(defvar x-preedit-overlay nil
1528 "The overlay currently used to display preedit text from a compose sequence.") 1528 "The overlay currently used to display preedit text from a compose sequence.")
1529 1529
1530;; With some input methods, text gets inserted before Emacs is told to
1531;; remove any preedit text that was displayed, which causes both the
1532;; preedit overlay and the text to be visible for a brief period of
1533;; time. This pre-command-hook clears the overlay before any command
1534;; and should be set whenever a preedit overlay is visible.
1535(defun x-clear-preedit-text ()
1536 "Clear the pre-edit overlay and remove itself from pre-command-hook.
1537This function should be installed in `pre-command-hook' whenever
1538preedit text is displayed."
1539 (when x-preedit-overlay
1540 (delete-overlay x-preedit-overlay)
1541 (setq x-preedit-overlay nil))
1542 (remove-hook 'pre-command-hook #'x-clear-preedit-text))
1543
1530(defun x-preedit-text (event) 1544(defun x-preedit-text (event)
1531 "Display preedit text from a compose sequence in EVENT. 1545 "Display preedit text from a compose sequence in EVENT.
1532EVENT is a preedit-text event." 1546EVENT is a preedit-text event."
1533 (interactive "e") 1547 (interactive "e")
1534 (when x-preedit-overlay 1548 (when x-preedit-overlay
1535 (delete-overlay x-preedit-overlay) 1549 (delete-overlay x-preedit-overlay)
1536 (setq x-preedit-overlay nil)) 1550 (setq x-preedit-overlay nil)
1551 (remove-hook 'pre-command-hook #'x-clear-preedit-text))
1537 (when (nth 1 event) 1552 (when (nth 1 event)
1538 (let ((string (propertize (nth 1 event) 'face '(:underline t)))) 1553 (let ((string (propertize (nth 1 event) 'face '(:underline t))))
1539 (setq x-preedit-overlay (make-overlay (point) (point))) 1554 (setq x-preedit-overlay (make-overlay (point) (point)))
1555 (add-hook 'pre-command-hook #'x-clear-preedit-text)
1540 (overlay-put x-preedit-overlay 'window (selected-window)) 1556 (overlay-put x-preedit-overlay 'window (selected-window))
1541 (overlay-put x-preedit-overlay 'before-string 1557 (overlay-put x-preedit-overlay 'before-string
1542 (if x-display-cursor-at-start-of-preedit-string 1558 (if x-display-cursor-at-start-of-preedit-string
@@ -1545,6 +1561,8 @@ EVENT is a preedit-text event."
1545 1561
1546(define-key special-event-map [preedit-text] 'x-preedit-text) 1562(define-key special-event-map [preedit-text] 'x-preedit-text)
1547 1563
1564(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips)
1565
1548(provide 'x-win) 1566(provide 'x-win)
1549(provide 'term/x-win) 1567(provide 'term/x-win)
1550 1568
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index ae3b18ed179..6382b402c06 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -1673,14 +1673,13 @@ Valid forms include:
1673 ("\\\\bibliographystyle" ispell-tex-arg-end) 1673 ("\\\\bibliographystyle" ispell-tex-arg-end)
1674 ("\\\\makebox" ispell-tex-arg-end 0) 1674 ("\\\\makebox" ispell-tex-arg-end 0)
1675 ("\\\\e?psfig" ispell-tex-arg-end) 1675 ("\\\\e?psfig" ispell-tex-arg-end)
1676 ("\\\\document\\(class\\|style\\)" . 1676 ("\\\\document\\(class\\|style\\)" . "\\\\begin[ \t\n]*{document}"))
1677 "\\\\begin[ \t\n]*{[ \t\n]*document[ \t\n]*}"))
1678 (;; delimited with \begin. In ispell: displaymath, eqnarray, eqnarray*, 1677 (;; delimited with \begin. In ispell: displaymath, eqnarray, eqnarray*,
1679 ;; equation, minipage, picture, tabular, tabular* (ispell) 1678 ;; equation, minipage, picture, tabular, tabular* (ispell)
1680 ("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) 1679 ("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0)
1681 ("list" ispell-tex-arg-end 2) 1680 ("list" ispell-tex-arg-end 2)
1682 ("program" . "\\\\end[ \t\n]*{[ \t\n]*program[ \t\n]*}") 1681 ("program" . "\\\\end[ \t]*{program}")
1683 ("verbatim\\*?" . "\\\\end[ \t\n]*{[ \t\n]*verbatim\\*?[ \t\n]*}")))) 1682 ("verbatim\\*?" . "\\\\end[ \t]*{verbatim\\*?}"))))
1684 "Lists of regions to be skipped in TeX mode. 1683 "Lists of regions to be skipped in TeX mode.
1685First list is used raw. 1684First list is used raw.
1686Second list has key placed inside \\begin{}. 1685Second list has key placed inside \\begin{}.
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
index 1cf16fdb5d2..2aa487d0454 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -339,6 +339,8 @@ This is used by `tooltip-show-help' and
339(defvar tooltip-previous-message nil 339(defvar tooltip-previous-message nil
340 "The previous content of the echo area.") 340 "The previous content of the echo area.")
341 341
342(defvar haiku-use-system-tooltips)
343
342(defun tooltip-show-help-non-mode (help) 344(defun tooltip-show-help-non-mode (help)
343 "Function installed as `show-help-function' when Tooltip mode is off. 345 "Function installed as `show-help-function' when Tooltip mode is off.
344It is also called if Tooltip mode is on, for text-only displays." 346It is also called if Tooltip mode is on, for text-only displays."
@@ -374,8 +376,10 @@ It is also called if Tooltip mode is on, for text-only displays."
374 "Function installed as `show-help-function'. 376 "Function installed as `show-help-function'.
375MSG is either a help string to display, or nil to cancel the display." 377MSG is either a help string to display, or nil to cancel the display."
376 (if (and (display-graphic-p) 378 (if (and (display-graphic-p)
377 (or (not (eq window-system 'haiku)) ;; On Haiku, there isn't a reliable way to show tooltips 379 ;; On Haiku, system tooltips can't be displayed above
378 ;; above menus. 380 ;; menus.
381 (or (not (and (eq window-system 'haiku)
382 haiku-use-system-tooltips))
379 (not (menu-or-popup-active-p)))) 383 (not (menu-or-popup-active-p))))
380 (let ((previous-help tooltip-help-message)) 384 (let ((previous-help tooltip-help-message))
381 (setq tooltip-help-message msg) 385 (setq tooltip-help-message msg)
@@ -383,9 +387,12 @@ MSG is either a help string to display, or nil to cancel the display."
383 ;; Cancel display. This also cancels a delayed tip, if 387 ;; Cancel display. This also cancels a delayed tip, if
384 ;; there is one. 388 ;; there is one.
385 (tooltip-hide)) 389 (tooltip-hide))
386 ((equal-including-properties previous-help msg) 390 ((equal previous-help msg)
387 ;; Same help as before (but possibly the mouse has moved). 391 ;; Same help as before (but possibly the mouse has
388 ;; Keep what we have. 392 ;; moved or the text properties have changed). Keep
393 ;; what we have. If only text properties have changed,
394 ;; the tooltip won't be updated, but that shouldn't
395 ;; occur.
389 ) 396 )
390 (t 397 (t
391 ;; A different help. Remove a previous tooltip, and 398 ;; A different help. Remove a previous tooltip, and
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index 8741bca9423..d353f0c0117 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -155,14 +155,19 @@ The variable `url-queue-timeout' sets a timeout."
155(defun url-queue-start-retrieve (job) 155(defun url-queue-start-retrieve (job)
156 (setf (url-queue-buffer job) 156 (setf (url-queue-buffer job)
157 (ignore-errors 157 (ignore-errors
158 (with-current-buffer (if (buffer-live-p (url-queue-context-buffer job)) 158 (with-current-buffer (if (buffer-live-p
159 (url-queue-context-buffer job))
159 (url-queue-context-buffer job) 160 (url-queue-context-buffer job)
160 (current-buffer)) 161 (current-buffer))
161 (let ((url-request-noninteractive t)) 162 (let ((url-request-noninteractive t)
162 (url-retrieve (url-queue-url job) 163 ;; This will disable querying the user for
163 #'url-queue-callback-function (list job) 164 ;; credentials if one of the things we're fetching
164 (url-queue-silentp job) 165 ;; in the background return a header requesting it.
165 (url-queue-inhibit-cookiesp job))))))) 166 (url-request-extra-headers '(("Authorization" . ""))))
167 (url-retrieve (url-queue-url job)
168 #'url-queue-callback-function (list job)
169 (url-queue-silentp job)
170 (url-queue-inhibit-cookiesp job)))))))
166 171
167(defun url-queue-prune-old-entries () 172(defun url-queue-prune-old-entries ()
168 (let (dead-jobs) 173 (let (dead-jobs)
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 37eaf254fdb..731d1e8256f 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -2272,21 +2272,24 @@ Return new point, if it was moved."
2272 "Iterate over all hunks between point and MAX. 2272 "Iterate over all hunks between point and MAX.
2273Call FUN with two args (BEG and END) for each hunk." 2273Call FUN with two args (BEG and END) for each hunk."
2274 (save-excursion 2274 (save-excursion
2275 (let* ((beg (or (ignore-errors (diff-beginning-of-hunk)) 2275 (catch 'malformed
2276 (ignore-errors (diff-hunk-next) (point)) 2276 (let* ((beg (or (ignore-errors (diff-beginning-of-hunk))
2277 max))) 2277 (ignore-errors (diff-hunk-next) (point))
2278 (while (< beg max) 2278 max)))
2279 (goto-char beg) 2279 (while (< beg max)
2280 (cl-assert (looking-at diff-hunk-header-re)) 2280 (goto-char beg)
2281 (let ((end 2281 (unless (looking-at diff-hunk-header-re)
2282 (save-excursion (diff-end-of-hunk) (point)))) 2282 (throw 'malformed nil))
2283 (cl-assert (< beg end)) 2283 (let ((end
2284 (funcall fun beg end) 2284 (save-excursion (diff-end-of-hunk) (point))))
2285 (goto-char end) 2285 (unless (< beg end)
2286 (setq beg (if (looking-at diff-hunk-header-re) 2286 (throw 'malformed nil))
2287 end 2287 (funcall fun beg end)
2288 (or (ignore-errors (diff-hunk-next) (point)) 2288 (goto-char end)
2289 max)))))))) 2289 (setq beg (if (looking-at diff-hunk-header-re)
2290 end
2291 (or (ignore-errors (diff-hunk-next) (point))
2292 max)))))))))
2290 2293
2291(defun diff--font-lock-refined (max) 2294(defun diff--font-lock-refined (max)
2292 "Apply hunk refinement from font-lock." 2295 "Apply hunk refinement from font-lock."
diff --git a/lisp/vc/pcvs-info.el b/lisp/vc/pcvs-info.el
index 341fa243cfa..b48a4a1cbf1 100644
--- a/lisp/vc/pcvs-info.el
+++ b/lisp/vc/pcvs-info.el
@@ -130,7 +130,7 @@ to confuse some users sometimes."
130(defvar cvs-bakprefix ".#" 130(defvar cvs-bakprefix ".#"
131 "The prefix that CVS prepends to files when rcsmerge'ing.") 131 "The prefix that CVS prepends to files when rcsmerge'ing.")
132 132
133(autoload 'cvs-mode-toggle-mark "pcvs") 133(declare-function cvs-mode-toggle-mark "pcvs" (e))
134 134
135(defvar-keymap cvs-status-map 135(defvar-keymap cvs-status-map
136 :doc "Local keymap for text properties of status." 136 :doc "Local keymap for text properties of status."
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index ef3354701c2..54457a21433 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -1004,13 +1004,14 @@ responsible for the given file."
1004 ;; 1004 ;;
1005 ;; First try: find a responsible backend. If this is for registration, 1005 ;; First try: find a responsible backend. If this is for registration,
1006 ;; it must be a backend under which FILE is not yet registered. 1006 ;; it must be a backend under which FILE is not yet registered.
1007 (let ((dirs (delq nil 1007 (let* ((file (expand-file-name file))
1008 (mapcar 1008 (dirs (delq nil
1009 (lambda (backend) 1009 (mapcar
1010 (when-let ((dir (vc-call-backend 1010 (lambda (backend)
1011 backend 'responsible-p file))) 1011 (when-let ((dir (vc-call-backend
1012 (cons backend dir))) 1012 backend 'responsible-p file)))
1013 vc-handled-backends)))) 1013 (cons backend dir)))
1014 vc-handled-backends))))
1014 ;; Just a single response (or none); use it. 1015 ;; Just a single response (or none); use it.
1015 (if (< (length dirs) 2) 1016 (if (< (length dirs) 2)
1016 (caar dirs) 1017 (caar dirs)