diff options
Diffstat (limited to 'lisp')
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 \ # Set load-prefer-newer for the benefit of the non-bootstrappers. BYTE_COMPILE_FLAGS = \ --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS) +# ... but we must prefer .elc files for those in the early bootstrap. +compile-first: BYTE_COMPILE_FLAGS = $(BYTE_COMPILE_EXTRA_FLAGS) # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. They're ordered by size, so we use @@ -303,9 +305,23 @@ endif # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. ifeq ($(HAVE_NATIVE_COMP),yes) +ifeq ($(ANCIENT),yes) +# The first compilation of compile-first, using an interpreted compiler: +# The resulting .elc files get given a date of 1971-01-01 so that their +# date stamp is earlier than the source files, causing these to be compiled +# into native code at the second recursive invocation of this $(MAKE), +# using these .elc's. This is faster than just compiling the native code +# directly using the interpreted compile-first files. (Note: 1970-01-01 +# fails on some systems.) +.el.elc: + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l comp -f batch-byte-compile $< + touch -t 197101010000 $@ +else .el.elc: $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f batch-byte+native-compile $< +endif else .el.elc: $(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 @@ ;;; Face attributes. (defconst custom-face-attributes - '((:family + `((:family (string :tag "Font Family" :help-echo "Font family or fontset alias name.")) @@ -148,29 +148,29 @@ (const :tag "At Bottom Of Text" t) (integer :tag "Pixels Above Bottom Of Text")))) ;; filter to make value suitable for customize - (lambda (real-value) - (and real-value - (let ((color - (or (and (consp real-value) (plist-get real-value :color)) - (and (stringp real-value) real-value) - 'foreground-color)) - (style - (or (and (consp real-value) (plist-get real-value :style)) - 'line)) - (position (and (consp real-value) - (plist-get real-value :style)))) - (list :color color :style style :position position)))) + ,(lambda (real-value) + (and real-value + (let ((color + (or (and (consp real-value) (plist-get real-value :color)) + (and (stringp real-value) real-value) + 'foreground-color)) + (style + (or (and (consp real-value) (plist-get real-value :style)) + 'line)) + (position (and (consp real-value) + (plist-get real-value :style)))) + (list :color color :style style :position position)))) ;; filter to make customized-value suitable for storing - (lambda (cus-value) - (and cus-value - (let ((color (plist-get cus-value :color)) - (style (plist-get cus-value :style)) - (position (plist-get cus-value :position))) - (cond ((and (eq style 'line) (not position)) - ;; Use simple value for default style - (if (eq color 'foreground-color) t color)) - (t - `(:color ,color :style ,style :position ,position))))))) + ,(lambda (cus-value) + (and cus-value + (let ((color (plist-get cus-value :color)) + (style (plist-get cus-value :style)) + (position (plist-get cus-value :position))) + (cond ((and (eq style 'line) (not position)) + ;; Use simple value for default style + (if (eq color 'foreground-color) t color)) + (t + `(:color ,color :style ,style :position ,position))))))) (:overline (choice :tag "Overline" @@ -206,40 +206,40 @@ (const :tag "Flat" flat-button) (const :tag "None" nil)))) ;; filter to make value suitable for customize - (lambda (real-value) - (and real-value - (let ((lwidth - (or (and (consp real-value) - (if (listp (cdr real-value)) - (plist-get real-value :line-width) - real-value)) - (and (integerp real-value) real-value) - '(1 . 1))) - (color - (or (and (consp real-value) (plist-get real-value :color)) - (and (stringp real-value) real-value) - nil)) - (style - (and (consp real-value) (plist-get real-value :style)))) - (if (integerp lwidth) - (setq lwidth (cons (abs lwidth) lwidth))) - (list :line-width lwidth :color color :style style)))) + ,(lambda (real-value) + (and real-value + (let ((lwidth + (or (and (consp real-value) + (if (listp (cdr real-value)) + (plist-get real-value :line-width) + real-value)) + (and (integerp real-value) real-value) + '(1 . 1))) + (color + (or (and (consp real-value) (plist-get real-value :color)) + (and (stringp real-value) real-value) + nil)) + (style + (and (consp real-value) (plist-get real-value :style)))) + (if (integerp lwidth) + (setq lwidth (cons (abs lwidth) lwidth))) + (list :line-width lwidth :color color :style style)))) ;; filter to make customized-value suitable for storing - (lambda (cus-value) - (and cus-value - (let ((lwidth (plist-get cus-value :line-width)) - (color (plist-get cus-value :color)) - (style (plist-get cus-value :style))) - (cond ((and (null color) (null style)) - lwidth) - ((and (null lwidth) (null style)) - ;; actually can't happen, because LWIDTH is always an int - color) - (t - ;; Keep as a plist, but remove null entries - (nconc (and lwidth `(:line-width ,lwidth)) - (and color `(:color ,color)) - (and style `(:style ,style))))))))) + ,(lambda (cus-value) + (and cus-value + (let ((lwidth (plist-get cus-value :line-width)) + (color (plist-get cus-value :color)) + (style (plist-get cus-value :style))) + (cond ((and (null color) (null style)) + lwidth) + ((and (null lwidth) (null style)) + ;; actually can't happen, because LWIDTH is always an int + color) + (t + ;; Keep as a plist, but remove null entries + (nconc (and lwidth `(:line-width ,lwidth)) + (and color `(:color ,color)) + (and style `(:style ,style))))))))) (:inverse-video (choice :tag "Inverse-video" @@ -276,18 +276,18 @@ :help-echo "List of faces to inherit attributes from." (face :Tag "Face" default)) ;; filter to make value suitable for customize - (lambda (real-value) - (cond ((or (null real-value) (eq real-value 'unspecified)) - nil) - ((symbolp real-value) - (list real-value)) - (t - real-value))) + ,(lambda (real-value) + (cond ((or (null real-value) (eq real-value 'unspecified)) + nil) + ((symbolp real-value) + (list real-value)) + (t + real-value))) ;; filter to make customized-value suitable for storing - (lambda (cus-value) - (if (and (consp cus-value) (null (cdr cus-value))) - (car cus-value) - cus-value)))) + ,(lambda (cus-value) + (if (and (consp cus-value) (null (cdr cus-value))) + (car cus-value) + cus-value)))) "Alist of face attributes. @@ -329,12 +329,12 @@ If FRAME is nil, use the global defaults for FACE." "Apply a list of face specs for user customizations. This works by calling `custom-theme-set-faces' for the `user' theme, a special theme referring to settings made via Customize. -The arguments should be a list where each entry has the form: +The arguments ARGS should be a list where each entry has the form: (FACE SPEC [NOW [COMMENT]]) See the documentation of `custom-theme-set-faces' for details." - (apply 'custom-theme-set-faces 'user args)) + (apply #'custom-theme-set-faces 'user args)) (defun custom-theme-set-faces (theme &rest args) "Apply a list of face specs associated with theme THEME. @@ -419,7 +419,7 @@ Each of the arguments ARGS has this form: (FACE FROM-THEME) This means reset FACE to its value in FROM-THEME." - (apply 'custom-theme-reset-faces 'user args)) + (apply #'custom-theme-reset-faces 'user args)) (define-obsolete-function-alias 'custom-facep #'facep "28.1") 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 (const :tag "Iconify" t)) "26.1") (tooltip-reuse-hidden-frame tooltip boolean "26.1") + (use-system-tooltips tooltip boolean "29.1") ;; fringe.c (overflow-newline-into-fringe fringe boolean) ;; image.c @@ -369,7 +370,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (auto-save-timeout auto-save (choice (const :tag "off" nil) (integer :format "%v"))) (echo-keystrokes minibuffer number) - (polling-period keyboard integer) + (polling-period keyboard float) (double-click-time mouse (restricted-sexp :match-alternatives (integerp 'nil 't))) (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." "Convert PDF-PS to PNG asynchronously." (funcall (pcase doc-view-doc-type - ('pdf doc-view-pdf->png-converter-function) + ((or 'pdf 'odf) doc-view-pdf->png-converter-function) ('djvu #'doc-view-djvu->tiff-converter-ddjvu) (_ #'doc-view-ps->png-converter-ghostscript)) 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." (t (let ((doc-string-elt (function-get (car-safe form) 'doc-string-elt)) (outbuf autoload-print-form-outbuf)) - (if (and doc-string-elt (stringp (nth doc-string-elt form))) + (if (and (numberp doc-string-elt) (stringp (nth doc-string-elt form))) ;; We need to hack the printing because the ;; doc-string must be printed specially for ;; make-docfile (sigh). @@ -410,7 +410,7 @@ FILE's name." ";; version-control: never\n" ";; no-byte-compile: t\n" ;; #$ is byte-compiled into nil. ";; no-update-autoloads: t\n" - ";; coding: utf-8\n" + ";; coding: utf-8-emacs-unix\n" ";; End:\n" ";;; " basename " 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)") "Hash byte-code -> byte-to-native-lambda.") (defvar byte-to-native-top-level-forms nil "List of top level forms.") -(defvar byte-to-native-output-file nil - "Temporary file containing the byte-compilation output.") +(defvar byte-to-native-output-buffer-file nil + "Pair holding byte-compilation output buffer, elc filename.") (defvar byte-to-native-plist-environment nil "To spill `overriding-plist-environment'.") @@ -1986,6 +1986,42 @@ If compilation is needed, this functions returns the result of (defvar byte-compile-level 0 ; bug#13787 "Depth of a recursive byte compilation.") +(defun byte-write-target-file (buffer target-file) + "Write BUFFER into TARGET-FILE." + (with-current-buffer buffer + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #o666)) + (kill-emacs-hook + (cons (lambda () (ignore-errors + (delete-file tempfile))) + kill-emacs-hook))) + (unless (= temp-modes desired-modes) + (set-file-modes tempfile desired-modes 'nofollow)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (if byte-native-compiling + ;; Defer elc final renaming. + (setf byte-to-native-output-buffer-file + (cons tempfile target-file)) + (rename-file tempfile target-file t))))) + ;;;###autoload (defun byte-compile-file (filename &optional load) "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'." ;; Force logging of the file name for each file compiled. (setq byte-compile-last-logged-file nil) - (prog1 - (let ((byte-compile-current-file filename) - (byte-compile-current-group nil) - (set-auto-coding-for-load t) - (byte-compile--seen-defvars nil) - (byte-compile--known-dynamic-vars - (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) - target-file input-buffer output-buffer - byte-compile-dest-file byte-compiler-error-flag) - (setq target-file (byte-compile-dest-file filename)) - (setq byte-compile-dest-file target-file) - (with-current-buffer - ;; It would be cleaner to use a temp buffer, but if there was - ;; an error, we leave this buffer around for diagnostics. - ;; Its name is documented in the lispref. - (setq input-buffer (get-buffer-create - (concat " *Compiler Input*" - (if (zerop byte-compile-level) "" - (format "-%s" byte-compile-level))))) - (erase-buffer) - (setq buffer-file-coding-system nil) - ;; Always compile an Emacs Lisp file as multibyte - ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- - (set-buffer-multibyte t) - (insert-file-contents filename) - ;; Mimic the way after-insert-file-set-coding can make the - ;; buffer unibyte when visiting this file. - (when (or (eq last-coding-system-used 'no-conversion) - (eq (coding-system-type last-coding-system-used) 5)) - ;; For coding systems no-conversion and raw-text..., - ;; edit the buffer as unibyte. - (set-buffer-multibyte nil)) - ;; Run hooks including the uncompression hook. - ;; If they change the file name, then change it for the output also. - (let ((buffer-file-name filename) - (dmm (default-value 'major-mode)) - ;; Ignore unsafe local variables. - ;; We only care about a few of them for our purposes. - (enable-local-variables :safe) - (enable-local-eval nil)) - (unwind-protect - (progn - (setq-default major-mode 'emacs-lisp-mode) - ;; Arg of t means don't alter enable-local-variables. - (delay-mode-hooks (normal-mode t))) - (setq-default major-mode dmm)) - ;; There may be a file local variable setting (bug#10419). - (setq buffer-read-only nil - filename buffer-file-name)) - ;; Don't inherit lexical-binding from caller (bug#12938). - (unless (local-variable-p 'lexical-binding) - (setq-local lexical-binding nil)) - ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory filename))) - ;; Check if the file's local variables explicitly specify not to - ;; compile this file. - (if (with-current-buffer input-buffer no-byte-compile) - (progn - ;; (message "%s not compiled because of `no-byte-compile: %s'" - ;; (byte-compile-abbreviate-file filename) - ;; (with-current-buffer input-buffer no-byte-compile)) - (when (and target-file (file-exists-p target-file)) - (message "%s deleted because of `no-byte-compile: %s'" - (byte-compile-abbreviate-file target-file) - (buffer-local-value 'no-byte-compile input-buffer)) - (condition-case nil (delete-file target-file) (error nil))) - ;; We successfully didn't compile this file. - 'no-byte-compile) - (when byte-compile-verbose - (message "Compiling %s..." filename)) - ;; It is important that input-buffer not be current at this call, - ;; so that the value of point set in input-buffer - ;; within byte-compile-from-buffer lingers in that buffer. - (setq output-buffer - (save-current-buffer - (let ((symbols-with-pos-enabled t) - (byte-compile-level (1+ byte-compile-level))) - (byte-compile-from-buffer input-buffer)))) - (if byte-compiler-error-flag - nil - (when byte-compile-verbose - (message "Compiling %s...done" filename)) - (kill-buffer input-buffer) - (with-current-buffer output-buffer - (when (and target-file - (or (not byte-native-compiling) - (and byte-native-compiling byte+native-compile))) - (goto-char (point-max)) - (insert "\n") ; aaah, unix. - (cond - ((and (file-writable-p target-file) - ;; We attempt to create a temporary file in the - ;; target directory, so the target directory must be - ;; writable. - (file-writable-p - (file-name-directory - ;; Need to expand in case TARGET-FILE doesn't - ;; include a directory (Bug#45287). - (expand-file-name target-file)))) - ;; We must disable any code conversion here. - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (when (file-writable-p target-file) - (expand-file-name target-file)))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #o666)) - (kill-emacs-hook - (cons (lambda () (ignore-errors - (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (if byte-native-compiling - ;; Defer elc final renaming. - (setf byte-to-native-output-file - (cons tempfile target-file)) - (rename-file tempfile target-file t))) - (or noninteractive - byte-native-compiling - (message "Wrote %s" target-file))) - ((file-writable-p target-file) - ;; In case the target directory isn't writable (see e.g. Bug#44631), - ;; try writing to the output file directly. We must disable any - ;; code conversion here. - (let ((coding-system-for-write 'no-conversion)) - (with-file-modes (logand (default-file-modes) #o666) - (write-region (point-min) (point-max) target-file nil 1))) - (or noninteractive (message "Wrote %s" target-file))) - (t - ;; This is just to give a better error message than write-region - (let ((exists (file-exists-p target-file))) - (signal (if exists 'file-error 'file-missing) - (list "Opening output file" - (if exists - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file)))))) - (kill-buffer (current-buffer))) - (if (and byte-compile-generate-call-tree - (or (eq t byte-compile-generate-call-tree) - (y-or-n-p (format "Report call tree for %s? " - filename)))) - (save-excursion - (display-call-tree filename))) - (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) - (when (and gen-dynvars (not (equal gen-dynvars "")) - byte-compile--seen-defvars) - (let ((dynvar-file (concat target-file ".dynvars"))) - (message "Generating %s" dynvar-file) - (with-temp-buffer - (dolist (var (delete-dups byte-compile--seen-defvars)) - (insert (format "%S\n" (cons var filename)))) - (write-region (point-min) (point-max) dynvar-file))))) - (if load - (load target-file)) - t))))) + (let ((byte-compile-current-file filename) + (byte-compile-current-group nil) + (set-auto-coding-for-load t) + (byte-compile--seen-defvars nil) + (byte-compile--known-dynamic-vars + (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) + target-file input-buffer output-buffer + byte-compile-dest-file byte-compiler-error-flag) + (setq target-file (byte-compile-dest-file filename)) + (setq byte-compile-dest-file target-file) + (with-current-buffer + ;; It would be cleaner to use a temp buffer, but if there was + ;; an error, we leave this buffer around for diagnostics. + ;; Its name is documented in the lispref. + (setq input-buffer (get-buffer-create + (concat " *Compiler Input*" + (if (zerop byte-compile-level) "" + (format "-%s" byte-compile-level))))) + (erase-buffer) + (setq buffer-file-coding-system nil) + ;; Always compile an Emacs Lisp file as multibyte + ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- + (set-buffer-multibyte t) + (insert-file-contents filename) + ;; Mimic the way after-insert-file-set-coding can make the + ;; buffer unibyte when visiting this file. + (when (or (eq last-coding-system-used 'no-conversion) + (eq (coding-system-type last-coding-system-used) 5)) + ;; For coding systems no-conversion and raw-text..., + ;; edit the buffer as unibyte. + (set-buffer-multibyte nil)) + ;; Run hooks including the uncompression hook. + ;; If they change the file name, then change it for the output also. + (let ((buffer-file-name filename) + (dmm (default-value 'major-mode)) + ;; Ignore unsafe local variables. + ;; We only care about a few of them for our purposes. + (enable-local-variables :safe) + (enable-local-eval nil)) + (unwind-protect + (progn + (setq-default major-mode 'emacs-lisp-mode) + ;; Arg of t means don't alter enable-local-variables. + (delay-mode-hooks (normal-mode t))) + (setq-default major-mode dmm)) + ;; There may be a file local variable setting (bug#10419). + (setq buffer-read-only nil + filename buffer-file-name)) + ;; Don't inherit lexical-binding from caller (bug#12938). + (unless (local-variable-p 'lexical-binding) + (setq-local lexical-binding nil)) + ;; Set the default directory, in case an eval-when-compile uses it. + (setq default-directory (file-name-directory filename))) + ;; Check if the file's local variables explicitly specify not to + ;; compile this file. + (if (with-current-buffer input-buffer no-byte-compile) + (progn + ;; (message "%s not compiled because of `no-byte-compile: %s'" + ;; (byte-compile-abbreviate-file filename) + ;; (with-current-buffer input-buffer no-byte-compile)) + (when (and target-file (file-exists-p target-file)) + (message "%s deleted because of `no-byte-compile: %s'" + (byte-compile-abbreviate-file target-file) + (buffer-local-value 'no-byte-compile input-buffer)) + (condition-case nil (delete-file target-file) (error nil))) + ;; We successfully didn't compile this file. + 'no-byte-compile) + (when byte-compile-verbose + (message "Compiling %s..." filename)) + ;; It is important that input-buffer not be current at this call, + ;; so that the value of point set in input-buffer + ;; within byte-compile-from-buffer lingers in that buffer. + (setq output-buffer + (save-current-buffer + (let ((byte-compile-level (1+ byte-compile-level))) + (byte-compile-from-buffer input-buffer)))) + (if byte-compiler-error-flag + nil + (when byte-compile-verbose + (message "Compiling %s...done" filename)) + (kill-buffer input-buffer) + (with-current-buffer output-buffer + (when (and target-file + (or (not byte-native-compiling) + (and byte-native-compiling byte+native-compile))) + (goto-char (point-max)) + (insert "\n") ; aaah, unix. + (cond + ((and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; Need to expand in case TARGET-FILE doesn't + ;; include a directory (Bug#45287). + (expand-file-name target-file)))) + (if byte-native-compiling + ;; Defer elc production. + (setf byte-to-native-output-buffer-file + (cons (current-buffer) target-file)) + (byte-write-target-file (current-buffer) target-file)) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) + ((file-writable-p target-file) + ;; In case the target directory isn't writable (see e.g. Bug#44631), + ;; try writing to the output file directly. We must disable any + ;; code conversion here. + (let ((coding-system-for-write 'no-conversion)) + (with-file-modes (logand (default-file-modes) #o666) + (write-region (point-min) (point-max) target-file nil 1))) + (or noninteractive (message "Wrote %s" target-file))) + (t + ;; This is just to give a better error message than write-region + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))))) + (unless byte-native-compiling + (kill-buffer (current-buffer)))) + (if (and byte-compile-generate-call-tree + (or (eq t byte-compile-generate-call-tree) + (y-or-n-p (format "Report call tree for %s? " + filename)))) + (save-excursion + (display-call-tree filename))) + (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) + (when (and gen-dynvars (not (equal gen-dynvars "")) + byte-compile--seen-defvars) + (let ((dynvar-file (concat target-file ".dynvars"))) + (message "Generating %s" dynvar-file) + (with-temp-buffer + (dolist (var (delete-dups byte-compile--seen-defvars)) + (insert (format "%S\n" (cons var filename)))) + (write-region (point-min) (point-max) dynvar-file))))) + (if load + (load target-file)) + t)))) ;;; compiling a single function ;;;###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." (batch-byte-compile) (cl-assert (length= command-line-args-left 1)) (let ((byte+native-compile t) - (byte-to-native-output-file nil)) + (byte-to-native-output-buffer-file nil)) (batch-native-compile) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t))) + (pcase byte-to-native-output-buffer-file + (`(,temp-buffer . ,target-file) + (unwind-protect + (byte-write-target-file temp-buffer target-file)) + (kill-buffer temp-buffer))) (setq command-line-args-left (cdr command-line-args-left))))) ;;;###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 You can use the command `edebug-all-defs' to toggle the value of this variable. You may wish to make it local to each buffer with \(make-local-variable \\='edebug-all-defs) in your -`emacs-lisp-mode-hook'." +`emacs-lisp-mode-hook'. + +Note that this user option has no effect unless the edebug +package has been loaded." + :require 'edebug :type 'boolean) ;;;###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." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (getenv "EMACS_TEST_VERBOSE") + (if (cl-plusp + (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) (message "%s" "")) @@ -1435,7 +1436,8 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (getenv "EMACS_TEST_VERBOSE") + (if (cl-plusp + (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) (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." multisession-edit-mode) (unless id (error "No value on the current line")) - (let* ((object (make-multisession - :package (car id) - :key (cdr id) - :storage multisession-storage)) + (let* ((object (or + ;; If the multisession variable already exists, use + ;; it (so that we update it). + (and (boundp (intern-soft (cdr id))) + (symbol-value (intern (cdr id)))) + ;; Create a new object. + (make-multisession + :package (car id) + :key (cdr id) + :storage multisession-storage))) (value (multisession-value object))) (setf (multisession-value object) (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." (insert "(") (pp--insert start (pop sexp)) (while sexp - (pp--insert " " (pop sexp))) + (if (consp sexp) + (pp--insert " " (pop sexp)) + (pp--insert " . " sexp) + (setq sexp nil))) (insert ")"))) (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 @@ +;;; ranges.el --- range functions -*- lexical-binding: t; -*- + +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; A "range" is a list that represents a list of integers. A range is +;; a list containing cons cells of start/end pairs, as well as integers. +;; +;; ((2 . 5) 9 (11 . 13)) +;; +;; represents the list (2 3 4 5 9 11 12 13). + +;;; Code: + +(defun range-normalize (range) + "Normalize RANGE. +If RANGE is a single range, return (RANGE). Otherwise, return RANGE." + (if (listp (cdr-safe range)) + range + (list range))) + +(defun range-denormalize (range) + "If RANGE contains a single range, then return that. +If not, return RANGE as is." + (if (and (consp (car range)) + (length= range 1)) + (car range) + range)) + +(defun range-difference (range1 range2) + "Return the range of elements in RANGE1 that do not appear in RANGE2. +Both ranges must be in ascending order." + (setq range1 (range-normalize range1)) + (setq range2 (range-normalize range2)) + (let* ((new-range (cons nil (copy-sequence range1))) + (r new-range)) + (while (cdr r) + (let* ((r1 (cadr r)) + (r2 (car range2)) + (min1 (if (numberp r1) r1 (car r1))) + (max1 (if (numberp r1) r1 (cdr r1))) + (min2 (if (numberp r2) r2 (car r2))) + (max2 (if (numberp r2) r2 (cdr r2)))) + + (cond ((> min1 max1) + ;; Invalid range: may result from overlap condition (below) + ;; remove Invalid range + (setcdr r (cddr r))) + ((and (= min1 max1) + (listp r1)) + ;; Inefficient representation: may result from overlap + ;; condition (below) + (setcar (cdr r) min1)) + ((not min2) + ;; All done with range2 + (setq r nil)) + ((< max1 min2) + ;; No overlap: range1 precedes range2 + (pop r)) + ((< max2 min1) + ;; No overlap: range2 precedes range1 + (pop range2)) + ((and (<= min2 min1) (<= max1 max2)) + ;; Complete overlap: range1 removed + (setcdr r (cddr r))) + (t + (setcdr r (nconc (list (cons min1 (1- min2)) + (cons (1+ max2) max1)) + (cddr r))))))) + (cdr new-range))) + +(defun range-intersection (range1 range2) + "Return intersection of RANGE1 and RANGE2." + (let* (out + (min1 (car range1)) + (max1 (if (numberp min1) + (if (numberp (cdr range1)) + (prog1 (cdr range1) + (setq range1 nil)) min1) + (prog1 (cdr min1) + (setq min1 (car min1))))) + (min2 (car range2)) + (max2 (if (numberp min2) + (if (numberp (cdr range2)) + (prog1 (cdr range2) + (setq range2 nil)) min2) + (prog1 (cdr min2) + (setq min2 (car min2)))))) + (setq range1 (cdr range1) + range2 (cdr range2)) + (while (and min1 min2) + (cond ((< max1 min2) ; range1 precedes range2 + (setq range1 (cdr range1) + min1 nil)) + ((< max2 min1) ; range2 precedes range1 + (setq range2 (cdr range2) + min2 nil)) + (t ; some sort of overlap is occurring + (let ((min (max min1 min2)) + (max (min max1 max2))) + (setq out (if (= min max) + (cons min out) + (cons (cons min max) out)))) + (if (< max1 max2) ; range1 ends before range2 + (setq min1 nil) ; incr range1 + (setq min2 nil)))) ; incr range2 + (unless min1 + (setq min1 (car range1) + max1 (if (numberp min1) min1 + (prog1 (cdr min1) (setq min1 (car min1)))) + range1 (cdr range1))) + (unless min2 + (setq min2 (car range2) + max2 (if (numberp min2) min2 + (prog1 (cdr min2) (setq min2 (car min2)))) + range2 (cdr range2)))) + (cond ((cdr out) + (nreverse out)) + ((numberp (car out)) + out) + (t + (car out))))) + +(defun range-compress-list (numbers) + "Convert a sorted list of numbers to a range list." + (let ((first (car numbers)) + (last (car numbers)) + result) + (cond + ((null numbers) + nil) + ((not (listp (cdr numbers))) + numbers) + (t + (while numbers + (cond ((= last (car numbers)) nil) ;Omit duplicated number + ((= (1+ last) (car numbers)) ;Still in sequence + (setq last (car numbers))) + (t ;End of one sequence + (setq result + (cons (if (= first last) first + (cons first last)) + result)) + (setq first (car numbers)) + (setq last (car numbers)))) + (setq numbers (cdr numbers))) + (nreverse (cons (if (= first last) first (cons first last)) + result)))))) + +(defun range-uncompress (ranges) + "Expand a list of ranges into a list of numbers. +RANGES is either a single range on the form `(num . num)' or a list of +these ranges." + (let (first last result) + (cond + ((null ranges) + nil) + ((not (listp (cdr ranges))) + (setq first (car ranges)) + (setq last (cdr ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first))) + (nreverse result)) + (t + (while ranges + (if (atom (car ranges)) + (when (numberp (car ranges)) + (setq result (cons (car ranges) result))) + (setq first (caar ranges)) + (setq last (cdar ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first)))) + (setq ranges (cdr ranges))) + (nreverse result))))) + +(defun range-add-list (ranges list) + "Return a list of ranges that has all articles from both RANGES and LIST. +Note: LIST has to be sorted over `<'." + (if (not ranges) + (range-compress-list list) + (setq list (copy-sequence list)) + (unless (listp (cdr ranges)) + (setq ranges (list ranges))) + (let ((out ranges) + ilist lowest highest temp) + (while (and ranges list) + (setq ilist list) + (setq lowest (or (and (atom (car ranges)) (car ranges)) + (caar ranges))) + (while (and list (cdr list) (< (cadr list) lowest)) + (setq list (cdr list))) + (when (< (car ilist) lowest) + (setq temp list) + (setq list (cdr list)) + (setcdr temp nil) + (setq out (nconc (range-compress-list ilist) out))) + (setq highest (or (and (atom (car ranges)) (car ranges)) + (cdar ranges))) + (while (and list (<= (car list) highest)) + (setq list (cdr list))) + (setq ranges (cdr ranges))) + (when list + (setq out (nconc (range-compress-list list) out))) + (setq out (sort out (lambda (r1 r2) + (< (or (and (atom r1) r1) (car r1)) + (or (and (atom r2) r2) (car r2)))))) + (setq ranges out) + (while ranges + (if (atom (car ranges)) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (car ranges)) (cadr ranges)) + (setcar ranges (cons (car ranges) + (cadr ranges))) + (setcdr ranges (cddr ranges))) + (when (= (1+ (car ranges)) (caadr ranges)) + (setcar (cadr ranges) (car ranges)) + (setcar ranges (cadr ranges)) + (setcdr ranges (cddr ranges))))) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (cdar ranges)) (cadr ranges)) + (setcdr (car ranges) (cadr ranges)) + (setcdr ranges (cddr ranges))) + (when (= (1+ (cdar ranges)) (caadr ranges)) + (setcdr (car ranges) (cdadr ranges)) + (setcdr ranges (cddr ranges)))))) + (setq ranges (cdr ranges))) + out))) + +(defun range-remove (range1 range2) + "Return a range that has all articles from RANGE2 removed from RANGE1. +The returned range is always a list. RANGE2 can also be a unsorted +list of articles. RANGE1 is modified by side effects, RANGE2 is not +modified." + (if (or (null range1) (null range2)) + range1 + (let (out r1 r2 r1-min r1-max r2-min r2-max + (range2 (copy-tree range2))) + (setq range1 (if (listp (cdr range1)) range1 (list range1)) + range2 (sort (if (listp (cdr range2)) range2 (list range2)) + (lambda (e1 e2) + (< (if (consp e1) (car e1) e1) + (if (consp e2) (car e2) e2)))) + r1 (car range1) + r2 (car range2) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2)) + (while (and range1 range2) + (cond ((< r2-max r1-min) ; r2 < r1 + (pop range2) + (setq r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r2-min r1-min) (<= r1-max r2-max)) ; r2 overlap r1 + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + ((and (<= r2-min r1-min) (<= r2-max r1-max)) ; r2 overlap min r1 + (pop range2) + (setq r1-min (1+ r2-max) + r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r1-min r2-min) (<= r2-max r1-max)) ; r2 contained in r1 + (if (eq r1-min (1- r2-min)) + (push r1-min out) + (push (cons r1-min (1- r2-min)) out)) + (pop range2) + (if (< r2-max r1-max) ; finished with r1? + (setq r1-min (1+ r2-max)) + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + (setq r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r2-min r1-max) (<= r1-max r2-max)) ; r2 overlap max r1 + (if (eq r1-min (1- r2-min)) + (push r1-min out) + (push (cons r1-min (1- r2-min)) out)) + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + ((< r1-max r2-min) ; r2 > r1 + (pop range1) + (if (eq r1-min r1-max) + (push r1-min out) + (push (cons r1-min r1-max) out)) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))))) + (when r1 + (if (eq r1-min r1-max) + (push r1-min out) + (push (cons r1-min r1-max) out)) + (pop range1)) + (while range1 + (push (pop range1) out)) + (nreverse out)))) + +(defun range-member-p (number ranges) + "Say whether NUMBER is in RANGES." + (if (not (listp (cdr ranges))) + (and (>= number (car ranges)) + (<= number (cdr ranges))) + (let ((not-stop t)) + (while (and ranges + (if (numberp (car ranges)) + (>= number (car ranges)) + (>= number (caar ranges))) + not-stop) + (when (if (numberp (car ranges)) + (= number (car ranges)) + (and (>= number (caar ranges)) + (<= number (cdar ranges)))) + (setq not-stop nil)) + (setq ranges (cdr ranges))) + (not not-stop)))) + +(defun range-list-intersection (list ranges) + "Return a list of numbers in LIST that are members of RANGES. +oLIST is a sorted list." + (setq ranges (range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (and ranges + (if (numberp (car ranges)) + (= (car ranges) number) + ;; (caar ranges) <= number <= (cdar ranges) + (>= number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defun range-list-difference (list ranges) + "Return a list of numbers in LIST that are not members of RANGES. +LIST is a sorted list." + (setq ranges (range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (or (not ranges) + (if (numberp (car ranges)) + (not (= (car ranges) number)) + ;; not ((caar ranges) <= number <= (cdar ranges)) + (< number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defun range-length (range) + "Return the length RANGE would have if uncompressed." + (cond + ((null range) + 0) + ((not (listp (cdr range))) + (- (cdr range) (car range) -1)) + (t + (let ((sum 0)) + (dolist (x range sum) + (setq sum + (+ sum (if (consp x) (- (cdr x) (car x) -1) 1)))))))) + +(defun range-concat (range1 range2) + "Add RANGE2 to RANGE1 (nondestructively)." + (unless (listp (cdr range1)) + (setq range1 (list range1))) + (unless (listp (cdr range2)) + (setq range2 (list range2))) + (let ((item1 (pop range1)) + (item2 (pop range2)) + range item selector) + (while (or item1 item2) + (setq selector + (cond + ((null item1) nil) + ((null item2) t) + ((and (numberp item1) (numberp item2)) (< item1 item2)) + ((numberp item1) (< item1 (car item2))) + ((numberp item2) (< (car item1) item2)) + (t (< (car item1) (car item2))))) + (setq item + (or + (let ((tmp1 item) (tmp2 (if selector item1 item2))) + (cond + ((null tmp1) tmp2) + ((null tmp2) tmp1) + ((and (numberp tmp1) (numberp tmp2)) + (cond + ((eq tmp1 tmp2) tmp1) + ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2)) + ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1)) + (t nil))) + ((numberp tmp1) + (cond + ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2) + ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2))) + ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1)) + (t nil))) + ((numberp tmp2) + (cond + ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1) + ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1))) + ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2)) + (t nil))) + ((< (1+ (cdr tmp1)) (car tmp2)) nil) + ((< (1+ (cdr tmp2)) (car tmp1)) nil) + (t (cons (min (car tmp1) (car tmp2)) + (max (cdr tmp1) (cdr tmp2)))))) + (progn + (if item (push item range)) + (if selector item1 item2)))) + (if selector + (setq item1 (pop range1)) + (setq item2 (pop range2)))) + (if item (push item range)) + (reverse range))) + +(defun range-map (func range) + "Apply FUNC to each value contained by RANGE." + (setq range (range-normalize range)) + (while range + (let ((span (pop range))) + (if (numberp span) + (funcall func span) + (let ((first (car span)) + (last (cdr span))) + (while (<= first last) + (funcall func first) + (setq first (1+ first)))))))) + +(provide 'range) + +;;; 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 1." (interactive "p") (let ((start (current-column)) + (entry (tabulated-list-get-entry)) (nb-cols (length tabulated-list-format)) (col-nb 0) (total-width 0) @@ -741,9 +742,14 @@ Interactively, N is the prefix numeric argument, and defaults to (if (> start (setq total-width (+ total-width - (setq col-width - (cadr (aref tabulated-list-format - col-nb)))))) + (max (setq col-width + (cadr (aref tabulated-list-format + col-nb))) + (string-width (aref entry col-nb))) + (or (plist-get (nthcdr 3 (aref tabulated-list-format + col-nb)) + :pad-right) + 1)))) (setq col-nb (1+ col-nb)) (setq found t) (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'." It returns a formatted value that should be passed to `eshell-print' or `eshell-printn' for display." (if eshell-plain-echo-behavior - (concat (apply 'eshell-flatten-and-stringify args) "\n") + (progn + ;; If the output does not end in a newline, do not emit one. + (setq eshell-ensure-newline-p nil) + (concat (apply #'eshell-flatten-and-stringify args) + (when output-newline "\n"))) (let ((value (cond ((= (length args) 0) "") @@ -109,18 +113,33 @@ or `eshell-printn' for display." "Implementation of `echo'. See `eshell-plain-echo-behavior'." (eshell-eval-using-options "echo" args - '((?n nil nil output-newline "terminate with a newline") - (?h "help" nil nil "output this help screen") + '((?n nil (nil) output-newline + "do not output the trailing newline") + (?N nil (t) output-newline + "terminate with a newline") + (?E nil nil _disable-escapes + "don't interpret backslash escapes (default)") + (?h "help" nil nil + "output this help screen") :preserve-args - :usage "[-n] [object]") - (eshell-echo args output-newline))) + :usage "[OPTION]... [OBJECT]...") + (if eshell-plain-echo-behavior + (eshell-echo args (if output-newline (car output-newline) t)) + ;; In Emacs 28.1 and earlier, "-n" was used to add a newline to + ;; non-plain echo in Eshell. This caused confusion due to "-n" + ;; generally having the opposite meaning for echo. Retain this + ;; compatibility for the time being. For more info, see + ;; bug#27361. + (when (equal output-newline '(nil)) + (display-warning + :warning "To terminate with a newline, you should use -N instead.")) + (eshell-echo args output-newline)))) (defun eshell/printnl (&rest args) - "Print out each of the arguments, separated by newlines." + "Print out each of the arguments as strings, separated by newlines." (let ((elems (flatten-tree args))) - (while elems - (eshell-printn (eshell-echo (list (car elems)))) - (setq elems (cdr elems))))) + (dolist (elem elems) + (eshell-printn (eshell-stringify elem))))) (defun eshell/listify (&rest args) "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 `#'." (defun eshell/source (&rest args) "Source a file in a subshell environment." - (eshell-eval-using-options - "source" args - '((?h "help" nil nil "show this usage screen") - :show-usage - :usage "FILE [ARGS] -Invoke the Eshell commands in FILE in a subshell, binding ARGS to $1, -$2, etc.") - (eshell-source-file (car args) (cdr args) t))) + (eshell-source-file (car args) (cdr args) t)) (put 'eshell/source 'eshell-no-numeric-conversions t) (defun eshell/. (&rest args) "Source a file in the current environment." - (eshell-eval-using-options - "." args - '((?h "help" nil nil "show this usage screen") - :show-usage - :usage "FILE [ARGS] -Invoke the Eshell commands in FILE within the current shell -environment, binding ARGS to $1, $2, etc.") - (eshell-source-file (car args) (cdr args)))) + (eshell-source-file (car args) (cdr args))) (put 'eshell/. 'eshell-no-numeric-conversions t) 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 @@ (require 'esh-module) (require 'esh-io) (require 'esh-ext) +(require 'generator) (eval-when-compile (require 'cl-lib) @@ -903,21 +904,55 @@ at the moment are: "Completion for the `debug' command." (while (pcomplete-here '("errors" "commands")))) +(iter-defun eshell--find-subcommands (haystack) + "Recursively search for subcommand forms in HAYSTACK. +This yields the SUBCOMMANDs when found in forms like +\"(eshell-as-subcommand SUBCOMMAND)\"." + (dolist (elem haystack) + (cond + ((eq (car-safe elem) 'eshell-as-subcommand) + (iter-yield (cdr elem))) + ((listp elem) + (iter-yield-from (eshell--find-subcommands elem)))))) + +(defun eshell--invoke-command-directly (command) + "Determine whether the given COMMAND can be invoked directly. +COMMAND should be a non-top-level Eshell command in parsed form. + +A command can be invoked directly if all of the following are true: + +* The command is of the form + \"(eshell-trap-errors (eshell-named-command NAME ARGS))\", + where ARGS is optional. + +* NAME is a string referring to an alias function and isn't a + complex command (see `eshell-complex-commands'). + +* Any subcommands in ARGS can also be invoked directly." + (when (and (eq (car command) 'eshell-trap-errors) + (eq (car (cadr command)) 'eshell-named-command)) + (let ((name (cadr (cadr command))) + (args (cdr-safe (nth 2 (cadr command))))) + (and name (stringp name) + (not (member name eshell-complex-commands)) + (catch 'simple + (dolist (pred eshell-complex-commands t) + (when (and (functionp pred) + (funcall pred name)) + (throw 'simple nil)))) + (eshell-find-alias-function name) + (catch 'indirect-subcommand + (iter-do (subcommand (eshell--find-subcommands args)) + (unless (eshell--invoke-command-directly subcommand) + (throw 'indirect-subcommand nil))) + t))))) + (defun eshell-invoke-directly (command) - (let ((base (cadr (nth 2 (nth 2 (cadr command))))) name) - (if (and (eq (car base) 'eshell-trap-errors) - (eq (car (cadr base)) 'eshell-named-command)) - (setq name (cadr (cadr base)))) - (and name (stringp name) - (not (member name eshell-complex-commands)) - (catch 'simple - (progn - (dolist (pred eshell-complex-commands) - (if (and (functionp pred) - (funcall pred name)) - (throw 'simple nil))) - t)) - (eshell-find-alias-function name)))) + "Determine whether the given COMMAND can be invoked directly. +COMMAND should be a top-level Eshell command in parsed form, as +produced by `eshell-parse-command'." + (let ((base (cadr (nth 2 (nth 2 (cadr command)))))) + (eshell--invoke-command-directly base))) (defun eshell-eval-command (command &optional input) "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." remaining (let ((extcmd (memq ':external options))) (when extcmd - (setq extcmd (eshell-search-path (cadr extcmd))) - (if extcmd - (throw 'eshell-ext-command extcmd) - (error (if (characterp (car switch)) "%s: unrecognized option -%c" - "%s: unrecognized option --%s") - name (car switch)))))))) + (setq extcmd (eshell-search-path (cadr extcmd)))) + (if extcmd + (throw 'eshell-ext-command extcmd) + (error (if (characterp (car switch)) "%s: unrecognized option -%c" + "%s: unrecognized option --%s") + name (car switch))))))) (defun eshell--process-args (name args options) "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 @@ :foreground :background :stipple :overline :strike-through :box :font :inherit :fontset :distant-foreground :extend :vector]) +(defun face-attrs--make-indirect-safe () + "Deep-copy the buffer's `face-remapping-alist' upon cloning the buffer." + (setq-local face-remapping-alist + (mapcar #'copy-sequence face-remapping-alist))) + +(add-hook 'clone-indirect-buffer-hook #'face-attrs--make-indirect-safe) + (defun face-attrs-more-relative-p (attrs1 attrs2) "Return true if ATTRS1 contains a greater number of relative face-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." (let ((prompt (if default (format-prompt prompt default) (format "%s: " prompt))) + (completion-extra-properties + '(:affixation-function + (lambda (faces) + (mapcar + (lambda (face) + (list (concat (propertize "SAMPLE" 'face face) + "\t") + "" + face)) + faces)))) aliasfaces nonaliasfaces faces) ;; Build up the completion tables. (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." ;; Discard the prefix. (if (looking-at prefix) (delete-region (point) (match-end 0)) - (error "Local variables entry is missing the prefix")) + (user-error "Local variables entry is missing the prefix")) (end-of-line) ;; Discard the suffix. (if (looking-back suffix (line-beginning-position)) (delete-region (match-beginning 0) (point)) - (error "Local variables entry is missing the suffix")) + (user-error "Local variables entry is missing the suffix")) (forward-line 1)) (goto-char (point-min)) @@ -3981,9 +3981,9 @@ major-mode." (and (eq handle-mode t) result))) ;; Find the variable name; (unless (looking-at hack-local-variable-regexp) - (error "Malformed local variable line: %S" - (buffer-substring-no-properties - (point) (line-end-position)))) + (user-error "Malformed local variable line: %S" + (buffer-substring-no-properties + (point) (line-end-position)))) (goto-char (match-end 1)) (let* ((str (match-string 1)) (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 @@ (require 'gnus-srvr) (require 'gnus-util) (require 'timer) +(require 'range) (eval-when-compile (require 'cl-lib)) (autoload 'gnus-server-update-server "gnus-srvr") @@ -1219,8 +1220,8 @@ This can be added to `gnus-select-article-hook' or (cond ((eq mark 'read) (setf (gnus-info-read info) (funcall (if (eq what 'add) - #'gnus-range-add - #'gnus-remove-from-range) + #'range-concat + #'range-remove) (gnus-info-read info) range)) (gnus-get-unread-articles-in-group @@ -1233,8 +1234,8 @@ This can be added to `gnus-select-article-hook' or (gnus-info-marks info))) (setcdr info-marks (funcall (if (eq what 'add) - #'gnus-range-add - #'gnus-remove-from-range) + #'range-concat + #'range-remove) (cdr info-marks) range)))))))) @@ -1307,7 +1308,7 @@ downloaded into the agent." (let ((read (gnus-info-read info))) (setf (gnus-info-read info) - (gnus-range-add + (range-concat read (list (cons (1+ agent-max) (1- active-min)))))) @@ -1796,13 +1797,13 @@ article numbers will be returned." (articles (if fetch-all (if gnus-newsgroup-maximum-articles (let ((active (gnus-active group))) - (gnus-uncompress-range + (range-uncompress (cons (max (car active) (- (cdr active) gnus-newsgroup-maximum-articles -1)) (cdr active)))) - (gnus-uncompress-range (gnus-active group))) + (range-uncompress (gnus-active group))) (gnus-list-of-unread-articles group))) (gnus-decode-encoded-word-function 'identity) (gnus-decode-encoded-address-function 'identity) @@ -1817,7 +1818,7 @@ article numbers will be returned." ;; because otherwise the agent will remove their marks.) (dolist (arts (gnus-info-marks (gnus-get-info group))) (unless (memq (car arts) '(seen recent killed cache)) - (setq articles (gnus-range-add articles (cdr arts))))) + (setq articles (range-concat articles (cdr arts))))) (setq articles (sort (gnus-uncompress-sequence articles) #'<))) ;; At this point, I have the list of articles to consider for @@ -1851,15 +1852,15 @@ article numbers will be returned." ;; gnus-agent-article-alist) equals (cdr (gnus-active ;; group))}. The addition of one(the 1+ above) then ;; forces Low to be greater than High. When this happens, - ;; gnus-list-range-intersection returns nil which + ;; range-list-intersection returns nil which ;; indicates that no headers need to be fetched. -- Kevin - (setq articles (gnus-list-range-intersection + (setq articles (range-list-intersection articles (list (cons low high))))))) (when articles (gnus-message 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" - (gnus-compress-sequence articles t))) + (range-compress-list articles))) (with-current-buffer nntp-server-buffer (if articles @@ -2060,7 +2061,7 @@ doesn't exist, to valid the overview buffer." (let (state sequence uncomp) (while alist (setq state (caar alist) - sequence (inline (gnus-uncompress-range (cdar alist))) + sequence (inline (range-uncompress (cdar alist))) alist (cdr alist)) (while sequence (push (cons (pop sequence) state) uncomp))) @@ -2404,7 +2405,7 @@ contents, they are first saved to their own file." (let ((arts (cdr (assq mark (gnus-info-marks (setq info (gnus-get-info group))))))) (when arts - (setq marked-articles (nconc (gnus-uncompress-range arts) + (setq marked-articles (nconc (range-uncompress arts) marked-articles)) )))) (setq marked-articles (sort marked-articles #'<)) @@ -2544,7 +2545,7 @@ contents, they are first saved to their own file." (let ((read (gnus-info-read (or info (setq info (gnus-get-info group)))))) (setf (gnus-info-read info) - (gnus-add-to-range read unfetched-articles))) + (range-add-list read unfetched-articles))) (gnus-group-update-group group t) (sit-for 0) @@ -2898,8 +2899,8 @@ The following commands are available: (defun gnus-agent-read-p () "Say whether an article is read or not." - (gnus-member-of-range (mail-header-number gnus-headers) - (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) + (range-member-p (mail-header-number gnus-headers) + (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) (defun gnus-category-make-function (predicate) "Make a function from PREDICATE." @@ -3115,7 +3116,7 @@ FORCE is equivalent to setting the expiration predicates to true." ;; All articles EXCEPT those named by the caller ;; are protected from expiration (gnus-sorted-difference - (gnus-uncompress-range + (range-uncompress (cons (caar alist) (caar (last alist)))) (sort articles #'<))))) @@ -3137,9 +3138,9 @@ FORCE is equivalent to setting the expiration predicates to true." ;; Ticked and/or dormant articles are excluded ;; from expiration (nconc - (gnus-uncompress-range + (range-uncompress (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range + (range-uncompress (cdr (assq 'dormant (gnus-info-marks info)))))))) (nov-file (concat dir ".overview")) @@ -3638,7 +3639,7 @@ has been fetched." (file-name-directory file) t)) (when fetch-old - (setq articles (gnus-uncompress-range + (setq articles (range-uncompress (cons (if (numberp fetch-old) (max 1 (- (car articles) fetch-old)) 1) @@ -3694,7 +3695,7 @@ has been fetched." ;; Clip this list to the headers that will ;; actually be returned - (setq fetched-articles (gnus-list-range-intersection + (setq fetched-articles (range-list-intersection (cdr fetched-articles) (cons min max))) @@ -3703,7 +3704,7 @@ has been fetched." ;; excluded IDs may be fetchable using HEAD. (if (car tail-fetched-articles) (setq uncached-articles - (gnus-list-range-intersection + (range-list-intersection uncached-articles (cons (car uncached-articles) (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 @@ (require 'message) (require 'mouse) (require 'seq) +(require 'range) (autoload 'gnus-msg-mail "gnus-msg" nil t) (autoload 'gnus-button-mailto "gnus-msg") @@ -1394,6 +1395,15 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) +(defcustom gnus-treat-suspicious-headers 'head + "Mark headers that are suspicious. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." + :version "29.1" + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + (defcustom gnus-treat-fold-newsgroups 'head "Fold the Newsgroups and Followup-To headers. Valid values are nil, t, `head', `first', `last', an integer or a @@ -1711,6 +1721,7 @@ regexp." (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) (gnus-treat-fold-headers gnus-article-treat-fold-headers) + (gnus-treat-suspicious-headers gnus-article-treat-suspicious-headers) (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) (gnus-treat-display-smileys gnus-treat-smiley) (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) @@ -2235,6 +2246,20 @@ unfolded." (pixel-fill-region (point) (point-max) (pixel-fill-width))) (goto-char (point-max)))))) +(defun gnus-article-treat-suspicious-headers () + "Mark suspicious headers." + (interactive nil gnus-article-mode gnus-summary-mode) + (gnus-with-article-headers + (let (match) + (while (setq match (text-property-search-forward 'textsec-suspicious)) + (add-text-properties (prop-match-beginning match) + (prop-match-end match) + (list 'help-echo (prop-match-value match) + 'face 'textsec-suspicious)) + (overlay-put (make-overlay (prop-match-end match) + (prop-match-end match)) + 'after-string "⚠️"))))) + (defun gnus-treat-smiley () "Toggle display of textual emoticons (\"smileys\") as small graphical icons." (interactive nil gnus-article-mode gnus-summary-mode) @@ -2611,17 +2636,36 @@ If PROMPT (the prefix), prompt for a coding system to use." (forward-line -1)) (setq end (point)) (while (not (bobp)) - (while (progn - (forward-line -1) - (and (not (bobp)) - (memq (char-after) '(?\t ? ))))) - (setq start (point)) - (if (looking-at "\ + (let (addresses) + (while (progn + (forward-line -1) + (and (not (bobp)) + (memq (char-after) '(?\t ? ))))) + (setq start (point)) + (save-restriction + (narrow-to-region start end) + (if (looking-at "\ \\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\ \\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):") - (funcall gnus-decode-address-function start end) - (funcall gnus-decode-header-function start end)) - (goto-char (setq end start))))) + (progn + (setq addresses (buffer-string)) + (funcall gnus-decode-address-function (point-min) (point-max))) + (funcall gnus-decode-header-function (point-min) (point-max)))) + (when addresses + (article--check-suspicious-addresses addresses)) + (goto-char (point-max)) + (goto-char (setq end start)))))) + +(defun article--check-suspicious-addresses (addresses) + (setq addresses (replace-regexp-in-string "\\`[^:]+:[ \t\n]*" "" addresses)) + (dolist (header (mail-header-parse-addresses addresses t)) + (when-let* ((address (car (ignore-errors + (mail-header-parse-address header)))) + (warning (textsec-suspicious-p address 'email-address))) + (goto-char (point-min)) + (while (search-forward address nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'textsec-suspicious warning))))) (defun article-decode-group-name () "Decode group names in Newsgroups, Followup-To and Xref headers." @@ -7019,7 +7063,7 @@ then we display only bindings that start with that prefix." (setq sumkeys (append (mapcar #'vector - (nreverse (gnus-uncompress-range def))) + (nreverse (range-uncompress def))) sumkeys)))) ((setq def (key-binding key)) (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 @@ (require 'parse-time) (require 'nnimap) +(require 'range) (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' (autoload 'epg-make-context "epg") @@ -404,7 +405,7 @@ When FULL is t, upload everything, not just a difference from the last full." (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) (active (gnus-active group)) headers head) - (when (gnus-retrieve-headers (gnus-uncompress-range active) group) + (when (gnus-retrieve-headers (range-uncompress active) group) (with-current-buffer nntp-server-buffer (goto-char (point-min)) (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." (gnus-activate-group "nndraft:queue") (save-excursion (let* ((articles (nndraft-articles)) - (unsendable (gnus-uncompress-range + (unsendable (range-uncompress (cdr (assq 'unsend (gnus-info-marks (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 @@ (require 'gnus-undo) (require 'gmm-utils) (require 'time-date) +(require 'range) (eval-when-compile (require 'mm-url) @@ -512,8 +513,8 @@ simple manner." ((numberp number) (int-to-string (+ number - (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) - (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) + (range-length (cdr (assq 'dormant gnus-tmp-marked))) + (range-length (cdr (assq 'tick gnus-tmp-marked)))))) (t number)) ?s) (?R gnus-tmp-number-of-read ?s) @@ -523,10 +524,10 @@ simple manner." ?s) (?t gnus-tmp-number-total ?d) (?y gnus-tmp-number-of-unread ?s) - (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) - (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) - (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) - (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) + (?I (range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) + (?T (range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) + (?i (+ (range-length (cdr (assq 'dormant gnus-tmp-marked))) + (range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d) (?g gnus-tmp-group ?s) (?G gnus-tmp-qualified-group ?s) @@ -1482,9 +1483,9 @@ if it is a string, only list groups matching REGEXP." (active (gnus-active group))) (if (not active) 0 - (length (gnus-uncompress-range - (gnus-range-difference - (gnus-range-difference (list active) (gnus-info-read info)) + (length (range-uncompress + (range-difference + (range-difference (list active) (gnus-info-read info)) seen)))))) ;; 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." '(mail post-mail)))) (cons 'level (or (gnus-info-level info) gnus-level-killed)) (cons 'score (or (gnus-info-score info) 0)) - (cons 'ticked (gnus-range-length (cdr (assq 'tick marked)))) + (cons 'ticked (range-length (cdr (assq 'tick marked)))) (cons 'group-age (gnus-group-timestamp-delta group))))) (while (and list (not (eval (caar list) env))) @@ -2065,9 +2066,9 @@ that group." (- (1+ (cdr active)) (car active))))) (gnus-summary-read-group group (or all (and (numberp number) - (zerop (+ number (gnus-range-length + (zerop (+ number (range-length (cdr (assq 'tick marked))) - (gnus-range-length + (range-length (cdr (assq 'dormant marked))))))) no-article nil no-display nil select-articles))) @@ -2832,7 +2833,7 @@ according to the expiry settings. Note that this will delete old not-expirable articles, too." (interactive (list (gnus-group-group-name) current-prefix-arg) gnus-group-mode) - (let ((articles (gnus-uncompress-range (gnus-active group)))) + (let ((articles (range-uncompress (gnus-active group)))) (when (gnus-yes-or-no-p (format "Do you really want to delete these %d articles forever? " (length articles))) @@ -3755,15 +3756,15 @@ or nil if no action could be taken." 'del '(tick)) (list (cdr (assq 'dormant marks)) 'del '(dormant)))) - (setq unread (gnus-range-add (gnus-range-add - unread (cdr (assq 'dormant marks))) - (cdr (assq 'tick marks)))) + (setq unread (range-concat (range-concat + unread (cdr (assq 'dormant marks))) + (cdr (assq 'tick marks)))) (gnus-add-marked-articles group 'tick nil nil 'force) (gnus-add-marked-articles group 'dormant nil nil 'force)) ;; Do auto-expirable marks if that's required. (when (and (gnus-group-auto-expirable-p group) (not (gnus-group-read-only-p group))) - (gnus-range-map + (range-map (lambda (article) (gnus-add-marked-articles group 'expire (list article)) (gnus-request-set-mark group (list (list (list article) @@ -3795,7 +3796,7 @@ Uses the process/prefix convention." (cons nil (gnus-list-of-read-articles group)) (assq 'expire (gnus-info-marks info)))) (articles-to-expire - (gnus-list-range-difference + (range-list-difference (gnus-uncompress-sequence (cdr expirable)) (cdr (assq 'unexist (gnus-info-marks info))))) (expiry-wait (gnus-group-find-parameter group 'expiry-wait)) @@ -4671,23 +4672,22 @@ and the second element is the address." (and (not (setq marked (nthcdr 3 info))) (or (null articles) (setcdr (nthcdr 2 info) - (list (list (cons type (gnus-compress-sequence - articles t))))))) + (list (list (cons type (range-compress-list + articles))))))) (and (not (setq m (assq type (car marked)))) (or (null articles) (setcar marked - (cons (cons type (gnus-compress-sequence articles t) ) + (cons (cons type (range-compress-list articles)) (car marked))))) (if force (if (null articles) (setcar (nthcdr 3 info) (assq-delete-all type (car marked))) - (setcdr m (gnus-compress-sequence articles t))) - (setcdr m (gnus-compress-sequence - (sort (nconc (gnus-uncompress-range (cdr m)) + (setcdr m (range-compress-list articles))) + (setcdr m (range-compress-list + (sort (nconc (range-uncompress (cdr m)) (copy-sequence articles)) - #'<) - t)))))) + #'<))))))) (declare-function gnus-summary-add-mark "gnus-sum" (article type)) 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." (when (> min 1) (let* ((range (if (= min 2) 1 (cons 1 (1- min)))) (read (gnus-info-read info)) - (new-read (gnus-range-add read (list range)))) + (new-read (range-concat read (list range)))) (setf (gnus-info-read info) new-read))) info)))))) 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." (setq gnus-newsgroup-kill-headers (mapcar #'mail-header-number headers)) (while headers - (unless (gnus-member-of-range + (unless (range-member-p (mail-header-number (car headers)) gnus-newsgroup-killed) (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 @@ ;;; List and range functions -(defsubst gnus-range-normalize (range) - "Normalize RANGE. -If RANGE is a single range, return (RANGE). Otherwise, return RANGE." - (if (listp (cdr-safe range)) range (list range))) +(require 'range) +(define-obsolete-function-alias 'gnus-range-normalize #'range-normalize "29.1") (defun gnus-last-element (list) "Return last element of LIST." @@ -56,10 +54,10 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." "Return a range comprising all the RANGES, which are pre-sorted. RANGES will be destructively altered." (setq ranges (delete nil ranges)) - (let* ((result (gnus-range-normalize (pop ranges))) + (let* ((result (range-normalize (pop ranges))) (last (last result))) (dolist (range ranges) - (setq range (gnus-range-normalize range)) + (setq range (range-normalize range)) ;; Normalize the single-number case, so that we don't need to ;; special-case that so much. (when (numberp (car last)) @@ -82,47 +80,8 @@ RANGES will be destructively altered." (car result) result))) -(defun gnus-range-difference (range1 range2) - "Return the range of elements in RANGE1 that do not appear in RANGE2. -Both ranges must be in ascending order." - (setq range1 (gnus-range-normalize range1)) - (setq range2 (gnus-range-normalize range2)) - (let* ((new-range (cons nil (copy-sequence range1))) - (r new-range) - ) ;; (safe t) - (while (cdr r) - (let* ((r1 (cadr r)) - (r2 (car range2)) - (min1 (if (numberp r1) r1 (car r1))) - (max1 (if (numberp r1) r1 (cdr r1))) - (min2 (if (numberp r2) r2 (car r2))) - (max2 (if (numberp r2) r2 (cdr r2)))) - - (cond ((> min1 max1) - ;; Invalid range: may result from overlap condition (below) - ;; remove Invalid range - (setcdr r (cddr r))) - ((and (= min1 max1) - (listp r1)) - ;; Inefficient representation: may result from overlap condition (below) - (setcar (cdr r) min1)) - ((not min2) - ;; All done with range2 - (setq r nil)) - ((< max1 min2) - ;; No overlap: range1 precedes range2 - (pop r)) - ((< max2 min1) - ;; No overlap: range2 precedes range1 - (pop range2)) - ((and (<= min2 min1) (<= max1 max2)) - ;; Complete overlap: range1 removed - (setcdr r (cddr r))) - (t - (setcdr r (nconc (list (cons min1 (1- min2)) (cons (1+ max2) max1)) (cddr r))))))) - (cdr new-range))) - - +(define-obsolete-function-alias 'gnus-range-difference + #'range-difference "29.1") ;;;###autoload (defun gnus-sorted-difference (list1 list2) @@ -200,57 +159,8 @@ LIST1 and LIST2 have to be sorted over <." (setq list2 (cdr list2))))) (nreverse out))) -;;;###autoload -(defun gnus-sorted-range-intersection (range1 range2) - "Return intersection of RANGE1 and RANGE2. -RANGE1 and RANGE2 have to be sorted over <." - (let* (out - (min1 (car range1)) - (max1 (if (numberp min1) - (if (numberp (cdr range1)) - (prog1 (cdr range1) - (setq range1 nil)) min1) - (prog1 (cdr min1) - (setq min1 (car min1))))) - (min2 (car range2)) - (max2 (if (numberp min2) - (if (numberp (cdr range2)) - (prog1 (cdr range2) - (setq range2 nil)) min2) - (prog1 (cdr min2) - (setq min2 (car min2)))))) - (setq range1 (cdr range1) - range2 (cdr range2)) - (while (and min1 min2) - (cond ((< max1 min2) ; range1 precedes range2 - (setq range1 (cdr range1) - min1 nil)) - ((< max2 min1) ; range2 precedes range1 - (setq range2 (cdr range2) - min2 nil)) - (t ; some sort of overlap is occurring - (let ((min (max min1 min2)) - (max (min max1 max2))) - (setq out (if (= min max) - (cons min out) - (cons (cons min max) out)))) - (if (< max1 max2) ; range1 ends before range2 - (setq min1 nil) ; incr range1 - (setq min2 nil)))) ; incr range2 - (unless min1 - (setq min1 (car range1) - max1 (if (numberp min1) min1 (prog1 (cdr min1) (setq min1 (car min1)))) - range1 (cdr range1))) - (unless min2 - (setq min2 (car range2) - max2 (if (numberp min2) min2 (prog1 (cdr min2) (setq min2 (car min2)))) - range2 (cdr range2)))) - (cond ((cdr out) - (nreverse out)) - ((numberp (car out)) - out) - (t - (car out))))) +(define-obsolete-function-alias 'gnus-sorted-range-intersection + #'range-intersection "29.1") ;;;###autoload (defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection) @@ -327,315 +237,33 @@ LIST1 and LIST2 have to be sorted over <." "Convert sorted list of numbers to a list of ranges or a single range. If ALWAYS-LIST is non-nil, this function will always release a list of ranges." - (let* ((first (car numbers)) - (last (car numbers)) - result) - (if (null numbers) - nil - (if (not (listp (cdr numbers))) - numbers - (while numbers - (cond ((= last (car numbers)) nil) ;Omit duplicated number - ((= (1+ last) (car numbers)) ;Still in sequence - (setq last (car numbers))) - (t ;End of one sequence - (setq result - (cons (if (= first last) first - (cons first last)) - result)) - (setq first (car numbers)) - (setq last (car numbers)))) - (setq numbers (cdr numbers))) - (if (and (not always-list) (null result)) - (if (= first last) (list first) (cons first last)) - (nreverse (cons (if (= first last) first (cons first last)) - result))))))) + (if always-list + (range-compress-list numbers) + (range-denormalize (range-compress-list numbers)))) (defalias 'gnus-uncompress-sequence 'gnus-uncompress-range) -(defun gnus-uncompress-range (ranges) - "Expand a list of ranges into a list of numbers. -RANGES is either a single range on the form `(num . num)' or a list of -these ranges." - (let (first last result) - (cond - ((null ranges) - nil) - ((not (listp (cdr ranges))) - (setq first (car ranges)) - (setq last (cdr ranges)) - (while (<= first last) - (setq result (cons first result)) - (setq first (1+ first))) - (nreverse result)) - (t - (while ranges - (if (atom (car ranges)) - (when (numberp (car ranges)) - (setq result (cons (car ranges) result))) - (setq first (caar ranges)) - (setq last (cdar ranges)) - (while (<= first last) - (setq result (cons first result)) - (setq first (1+ first)))) - (setq ranges (cdr ranges))) - (nreverse result))))) - -(defun gnus-add-to-range (ranges list) - "Return a list of ranges that has all articles from both RANGES and LIST. -Note: LIST has to be sorted over `<'." - (if (not ranges) - (gnus-compress-sequence list t) - (setq list (copy-sequence list)) - (unless (listp (cdr ranges)) - (setq ranges (list ranges))) - (let ((out ranges) - ilist lowest highest temp) - (while (and ranges list) - (setq ilist list) - (setq lowest (or (and (atom (car ranges)) (car ranges)) - (caar ranges))) - (while (and list (cdr list) (< (cadr list) lowest)) - (setq list (cdr list))) - (when (< (car ilist) lowest) - (setq temp list) - (setq list (cdr list)) - (setcdr temp nil) - (setq out (nconc (gnus-compress-sequence ilist t) out))) - (setq highest (or (and (atom (car ranges)) (car ranges)) - (cdar ranges))) - (while (and list (<= (car list) highest)) - (setq list (cdr list))) - (setq ranges (cdr ranges))) - (when list - (setq out (nconc (gnus-compress-sequence list t) out))) - (setq out (sort out (lambda (r1 r2) - (< (or (and (atom r1) r1) (car r1)) - (or (and (atom r2) r2) (car r2)))))) - (setq ranges out) - (while ranges - (if (atom (car ranges)) - (when (cdr ranges) - (if (atom (cadr ranges)) - (when (= (1+ (car ranges)) (cadr ranges)) - (setcar ranges (cons (car ranges) - (cadr ranges))) - (setcdr ranges (cddr ranges))) - (when (= (1+ (car ranges)) (caadr ranges)) - (setcar (cadr ranges) (car ranges)) - (setcar ranges (cadr ranges)) - (setcdr ranges (cddr ranges))))) - (when (cdr ranges) - (if (atom (cadr ranges)) - (when (= (1+ (cdar ranges)) (cadr ranges)) - (setcdr (car ranges) (cadr ranges)) - (setcdr ranges (cddr ranges))) - (when (= (1+ (cdar ranges)) (caadr ranges)) - (setcdr (car ranges) (cdadr ranges)) - (setcdr ranges (cddr ranges)))))) - (setq ranges (cdr ranges))) - out))) - -(defun gnus-remove-from-range (range1 range2) - "Return a range that has all articles from RANGE2 removed from RANGE1. -The returned range is always a list. RANGE2 can also be a unsorted -list of articles. RANGE1 is modified by side effects, RANGE2 is not -modified." - (if (or (null range1) (null range2)) - range1 - (let (out r1 r2 r1_min r1_max r2_min r2_max - (range2 (copy-tree range2))) - (setq range1 (if (listp (cdr range1)) range1 (list range1)) - range2 (sort (if (listp (cdr range2)) range2 (list range2)) - (lambda (e1 e2) - (< (if (consp e1) (car e1) e1) - (if (consp e2) (car e2) e2)))) - r1 (car range1) - r2 (car range2) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2)) - (while (and range1 range2) - (cond ((< r2_max r1_min) ; r2 < r1 - (pop range2) - (setq r2 (car range2) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2))) - ((and (<= r2_min r1_min) (<= r1_max r2_max)) ; r2 overlap r1 - (pop range1) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))) - ((and (<= r2_min r1_min) (<= r2_max r1_max)) ; r2 overlap min r1 - (pop range2) - (setq r1_min (1+ r2_max) - r2 (car range2) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2))) - ((and (<= r1_min r2_min) (<= r2_max r1_max)) ; r2 contained in r1 - (if (eq r1_min (1- r2_min)) - (push r1_min out) - (push (cons r1_min (1- r2_min)) out)) - (pop range2) - (if (< r2_max r1_max) ; finished with r1? - (setq r1_min (1+ r2_max)) - (pop range1) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))) - (setq r2 (car range2) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2))) - ((and (<= r2_min r1_max) (<= r1_max r2_max)) ; r2 overlap max r1 - (if (eq r1_min (1- r2_min)) - (push r1_min out) - (push (cons r1_min (1- r2_min)) out)) - (pop range1) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))) - ((< r1_max r2_min) ; r2 > r1 - (pop range1) - (if (eq r1_min r1_max) - (push r1_min out) - (push (cons r1_min r1_max) out)) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))))) - (when r1 - (if (eq r1_min r1_max) - (push r1_min out) - (push (cons r1_min r1_max) out)) - (pop range1)) - (while range1 - (push (pop range1) out)) - (nreverse out)))) - -(defun gnus-member-of-range (number ranges) - (if (not (listp (cdr ranges))) - (and (>= number (car ranges)) - (<= number (cdr ranges))) - (let ((not-stop t)) - (while (and ranges - (if (numberp (car ranges)) - (>= number (car ranges)) - (>= number (caar ranges))) - not-stop) - (when (if (numberp (car ranges)) - (= number (car ranges)) - (and (>= number (caar ranges)) - (<= number (cdar ranges)))) - (setq not-stop nil)) - (setq ranges (cdr ranges))) - (not not-stop)))) - -(defun gnus-list-range-intersection (list ranges) - "Return a list of numbers in LIST that are members of RANGES. -LIST is a sorted list." - (setq ranges (gnus-range-normalize ranges)) - (let (number result) - (while (setq number (pop list)) - (while (and ranges - (if (numberp (car ranges)) - (< (car ranges) number) - (< (cdar ranges) number))) - (setq ranges (cdr ranges))) - (when (and ranges - (if (numberp (car ranges)) - (= (car ranges) number) - ;; (caar ranges) <= number <= (cdar ranges) - (>= number (caar ranges)))) - (push number result))) - (nreverse result))) +(define-obsolete-function-alias 'gnus-uncompress-range + #'range-uncompress "29.1") + +(define-obsolete-function-alias 'gnus-add-to-range + #'range-add-list "29.1") + +(define-obsolete-function-alias 'gnus-remove-from-range + #'range-remove "29.1") + +(define-obsolete-function-alias 'gnus-member-of-range #'range-member-p "29.1") + +(define-obsolete-function-alias 'gnus-list-range-intersection + #'range-list-intersection "29.1") (defalias 'gnus-inverse-list-range-intersection 'gnus-list-range-difference) -(defun gnus-list-range-difference (list ranges) - "Return a list of numbers in LIST that are not members of RANGES. -LIST is a sorted list." - (setq ranges (gnus-range-normalize ranges)) - (let (number result) - (while (setq number (pop list)) - (while (and ranges - (if (numberp (car ranges)) - (< (car ranges) number) - (< (cdar ranges) number))) - (setq ranges (cdr ranges))) - (when (or (not ranges) - (if (numberp (car ranges)) - (not (= (car ranges) number)) - ;; not ((caar ranges) <= number <= (cdar ranges)) - (< number (caar ranges)))) - (push number result))) - (nreverse result))) +(define-obsolete-function-alias 'gnus-list-range-difference + #'range-list-difference "29.1") + +(define-obsolete-function-alias 'gnus-range-length #'range-length "29.1") -(defun gnus-range-length (range) - "Return the length RANGE would have if uncompressed." - (cond - ((null range) - 0) - ((not (listp (cdr range))) - (- (cdr range) (car range) -1)) - (t - (let ((sum 0)) - (dolist (x range sum) - (setq sum - (+ sum (if (consp x) (- (cdr x) (car x) -1) 1)))))))) - -(defun gnus-range-add (range1 range2) - "Add RANGE2 to RANGE1 (nondestructively)." - (unless (listp (cdr range1)) - (setq range1 (list range1))) - (unless (listp (cdr range2)) - (setq range2 (list range2))) - (let ((item1 (pop range1)) - (item2 (pop range2)) - range item selector) - (while (or item1 item2) - (setq selector - (cond - ((null item1) nil) - ((null item2) t) - ((and (numberp item1) (numberp item2)) (< item1 item2)) - ((numberp item1) (< item1 (car item2))) - ((numberp item2) (< (car item1) item2)) - (t (< (car item1) (car item2))))) - (setq item - (or - (let ((tmp1 item) (tmp2 (if selector item1 item2))) - (cond - ((null tmp1) tmp2) - ((null tmp2) tmp1) - ((and (numberp tmp1) (numberp tmp2)) - (cond - ((eq tmp1 tmp2) tmp1) - ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2)) - ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1)) - (t nil))) - ((numberp tmp1) - (cond - ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2) - ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2))) - ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1)) - (t nil))) - ((numberp tmp2) - (cond - ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1) - ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1))) - ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2)) - (t nil))) - ((< (1+ (cdr tmp1)) (car tmp2)) nil) - ((< (1+ (cdr tmp2)) (car tmp1)) nil) - (t (cons (min (car tmp1) (car tmp2)) - (max (cdr tmp1) (cdr tmp2)))))) - (progn - (if item (push item range)) - (if selector item1 item2)))) - (if selector - (setq item1 (pop range1)) - (setq item2 (pop range2)))) - (if item (push item range)) - (reverse range))) +(define-obsolete-function-alias 'gnus-range-add #'range-concat "29.1") ;;;###autoload (defun gnus-add-to-sorted-list (list num) @@ -649,18 +277,7 @@ LIST is a sorted list." (setcdr prev (cons num list))) (cdr top))) -(defun gnus-range-map (func range) - "Apply FUNC to each value contained by RANGE." - (setq range (gnus-range-normalize range)) - (while range - (let ((span (pop range))) - (if (numberp span) - (funcall func span) - (let ((first (car span)) - (last (cdr span))) - (while (<= first last) - (funcall func first) - (setq first (1+ first)))))))) +(define-obsolete-function-alias 'gnus-range-map #'range-map "29.1") (provide 'gnus-range) 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 (ranges (gnus-info-read info)) news article) (while articles - (when (gnus-member-of-range - (setq article (pop articles)) ranges) + (when (range-member-p (setq article (pop articles)) ranges) (push article news))) (when news ;; Enter this list into the group info. (setf (gnus-info-read info) - (gnus-remove-from-range (gnus-info-read info) (nreverse news))) + (range-remove (gnus-info-read info) (nreverse news))) ;; Set the number of unread articles in gnus-newsrc-hashtb. (gnus-get-unread-articles-in-group info (gnus-active group)) @@ -2362,10 +2361,10 @@ The form should return either t or nil." ticked (cdr (assq 'tick marks))) (when (or dormant ticked) (setf (gnus-info-read info) - (gnus-add-to-range + (range-add-list (gnus-info-read info) - (nconc (gnus-uncompress-range dormant) - (gnus-uncompress-range ticked))))))))) + (nconc (range-uncompress dormant) + (range-uncompress ticked))))))))) (defun gnus-load (file) "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." (unless (nthcdr 3 info) (nconc info (list nil))) (setf (gnus-info-marks info) - (list (cons 'tick (gnus-compress-sequence - (sort (cdr m) #'<) t)))))) + (list (cons 'tick (range-compress-list (sort (cdr m) #'<))))))) (setq newsrc killed) (while newsrc (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." ;; (let ((n (cdr (gnus-active group)))) ;; (lambda () (> number (- n display)))) (setq select-articles - (gnus-uncompress-range + (range-uncompress (cons (let ((tmp (- (cdr (gnus-active group)) display))) (if (> tmp 0) tmp @@ -5928,7 +5928,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." "Find out what articles the user wants to read." (let* ((only-read-p t) (articles - (gnus-list-range-difference + (range-list-difference ;; Select all articles if `read-all' is non-nil, or if there ;; are no unread articles. (if (or read-all @@ -5943,13 +5943,13 @@ If SELECT-ARTICLES, only select those articles from GROUP." (or (if gnus-newsgroup-maximum-articles (let ((active (gnus-active group))) - (gnus-uncompress-range + (range-uncompress (cons (max (car active) (- (cdr active) gnus-newsgroup-maximum-articles -1)) (cdr active)))) - (gnus-uncompress-range (gnus-active group))) + (range-uncompress (gnus-active group))) (gnus-cache-articles-in-group group)) ;; Select only the "normal" subset of articles. (setq only-read-p nil) @@ -6040,7 +6040,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (defun gnus-killed-articles (killed articles) (let (out) (while articles - (when (inline (gnus-member-of-range (car articles) killed)) + (when (inline (range-member-p (car articles) killed)) (push (car articles) out)) (setq articles (cdr articles))) out)) @@ -6078,7 +6078,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; Adjust "simple" lists - compressed yet unsorted ((eq mark-type 'list) ;; Simultaneously uncompress and clip to active range - ;; See gnus-uncompress-range for a description of possible marks + ;; See range-uncompress for a description of possible marks (let (l lh) (if (not (cadr marks)) (set var nil) @@ -6177,10 +6177,10 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; When exiting the group, everything that's previously been ;; unseen is now seen. (when (eq (cdr type) 'seen) - (setq list (gnus-range-add list gnus-newsgroup-unseen))) + (setq list (range-concat list gnus-newsgroup-unseen))) (when (eq (gnus-article-mark-to-type (cdr type)) 'list) - (setq list (gnus-compress-sequence (set symbol (sort list #'<)) t))) + (setq list (range-compress-list (set symbol (sort list #'<))))) (when (and (gnus-check-backend-function 'request-set-mark gnus-newsgroup-name) @@ -6189,20 +6189,19 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; Don't do anything about marks for articles we ;; didn't actually get any headers for. (del - (gnus-list-range-intersection + (range-list-intersection gnus-newsgroup-articles - (gnus-remove-from-range (copy-tree old) list))) + (range-remove (copy-tree old) list))) (add - (gnus-list-range-intersection + (range-list-intersection gnus-newsgroup-articles - (gnus-remove-from-range - (copy-tree list) old)))) + (range-remove (copy-tree list) old)))) (when add (push (list add 'add (list (cdr type))) delta-marks)) (when del ;; Don't delete marks from outside the active range. ;; This shouldn't happen, but is a sanity check. - (setq del (gnus-sorted-range-intersection + (setq del (range-intersection (gnus-active gnus-newsgroup-name) del)) (push (list del 'del (list (cdr type))) delta-marks)))) @@ -6386,7 +6385,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (setq ninfo (cons 1 (1- (car active)))) (setq ninfo (gnus-info-read info))) ;; Then we add the read articles to the range. - (gnus-add-to-range + (range-add-list ninfo (setq articles (sort articles #'<)))))) (defun gnus-group-make-articles-read (group articles) @@ -6967,10 +6966,10 @@ displayed, no centering will be performed." (marked (gnus-info-marks info)) (active (gnus-active group))) (and info active - (gnus-list-range-difference - (gnus-list-range-difference + (range-list-difference + (range-list-difference (gnus-sorted-complement - (gnus-uncompress-range + (range-uncompress (if gnus-newsgroup-maximum-articles (cons (max (car active) (- (cdr active) @@ -7129,12 +7128,11 @@ The prefix argument ALL means to select all articles." (when group (when gnus-newsgroup-kill-headers (setq gnus-newsgroup-killed - (gnus-compress-sequence + (range-compress-list (gnus-sorted-union - (gnus-list-range-intersection + (range-list-intersection gnus-newsgroup-unselected gnus-newsgroup-killed) - gnus-newsgroup-unreads) - t))) + gnus-newsgroup-unreads)))) (unless (listp (cdr gnus-newsgroup-killed)) (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) (let ((headers gnus-newsgroup-headers) @@ -10241,8 +10239,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (cdr art-group)) (push 'read to-marks) (setf (gnus-info-read info) - (gnus-add-to-range (gnus-info-read info) - (list (cdr art-group))))) + (range-add-list (gnus-info-read info) + (list (cdr art-group))))) ;; See whether the article is to be put in the cache. (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." ;; This backend supports expiry. (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) (expirable - (gnus-list-range-difference + (range-list-difference (if total (progn ;; We need to update the info for @@ -11898,7 +11896,8 @@ Returns nil if no threads were there to be hidden." (beginning-of-line) (let ((start (point)) (starteol (line-end-position)) - (article (gnus-summary-article-number))) + (article (unless (gnus-summary-article-intangible-p) + (gnus-summary-article-number)))) ;; Go forward until either the buffer ends or the subthread ends. (when (and (not (eobp)) (or (zerop (gnus-summary-next-thread 1 t)) @@ -11912,7 +11911,9 @@ Returns nil if no threads were there to be hidden." (let ((ol (make-overlay starteol (point) nil t nil))) (overlay-put ol 'invisible 'gnus-sum) (overlay-put ol 'evaporate t))) - (gnus-summary-goto-subject article) + (if article + (gnus-summary-goto-subject article) + (gnus-summary-position-point)) ;; We moved backward past the start point (invisible thread?) (when (> start (point)) (goto-char starteol))) @@ -12871,8 +12872,8 @@ UNREAD is a sorted list." (gnus-find-method-for-group group) 'server-marks) (gnus-check-backend-function 'request-set-mark group)) - (let ((del (gnus-remove-from-range (gnus-info-read info) read)) - (add (gnus-remove-from-range read (gnus-info-read info)))) + (let ((del (range-remove (gnus-info-read info) read)) + (add (range-remove read (gnus-info-read info)))) (when (or add del) (unless (gnus-check-group group) (error "Can't open server for %s" group)) @@ -13130,10 +13131,10 @@ If ALL is a number, fetch this number of articles." ;; Some nntp servers lie about their active range. When ;; this happens, the active range can be in the millions. ;; Use a compressed range to avoid creating a huge list. - (gnus-range-difference - (gnus-range-difference (list gnus-newsgroup-active) old) + (range-difference + (range-difference (list gnus-newsgroup-active) old) gnus-newsgroup-unexist)) - (setq len (gnus-range-length older)) + (setq len (range-length older)) (cond ((null older) nil) ((numberp all) @@ -13150,9 +13151,9 @@ If ALL is a number, fetch this number of articles." (push max older) (setq all (1- all) max (1- max)))))) - (setq older (gnus-uncompress-range older)))) + (setq older (range-uncompress older)))) (all - (setq older (gnus-uncompress-range older))) + (setq older (range-uncompress older))) (t (when (and (numberp gnus-large-newsgroup) (> len gnus-large-newsgroup)) @@ -13187,7 +13188,7 @@ If ALL is a number, fetch this number of articles." (push max older) (setq all (1- all) max (1- max)))))))))) - (setq older (gnus-uncompress-range older)))) + (setq older (range-uncompress older)))) (if (not older) (message "No old news.") (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 @@ (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") (require 'mm-util) +(require 'gnus-range) (require 'message) ;; for `message-directory' (defvar display-time-mail-function) @@ -1048,8 +1049,6 @@ This only works when `display-time' is enabled." (autoload 'imap-range-to-message-set "imap") (autoload 'nnheader-ms-strip-cr "nnheader") -(autoload 'gnus-compress-sequence "gnus-range") - (defvar mail-source-imap-file-coding-system 'binary "Coding system for the crashbox made by `mail-source-fetch-imap'.") 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." (defun message-update-smtp-method-header () "Insert an X-Message-SMTP-Method header according to `message-server-alist'." (unless (message-fetch-field "X-Message-SMTP-Method") - (let ((from (cadr (mail-extract-address-components (message-fetch-field "From")))) + (let ((from (cadr (mail-extract-address-components + (save-restriction + (widen) + (message-narrow-to-headers-or-head) + (message-fetch-field "From"))))) method) (catch 'exit (dolist (server message-server-alist) @@ -4901,7 +4905,18 @@ If you always want Gnus to send messages in one piece, set (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t) - (mail-encode-encoded-word-buffer)) + (mail-encode-encoded-word-buffer) + ;; Then check for suspicious addresses. + (dolist (hdr '("To" "Cc" "Bcc")) + (let ((addr (message-fetch-field hdr))) + (when (stringp addr) + (dolist (address (mail-header-parse-addresses addr t)) + (when-let ((warning (textsec-suspicious-p + address 'email-address-header))) + (unless (y-or-n-p + (format "Suspicious address: %s; send anyway?" + warning)) + (user-error "Suspicious address %s" address)))))))) (goto-char (point-max)) ;; require one newline at the end. (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." (setq coding-system (mm-find-buffer-file-coding-system))) (setq text (buffer-string)))) (with-temp-buffer - (buffer-disable-undo) - (mm-enable-multibyte) (insert (cond ((eq charset 'gnus-decoded) (with-current-buffer (mm-handle-buffer handle) (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 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(require 'range) (defvar gnus-decode-encoded-word-function) (defvar gnus-decode-encoded-address-function) @@ -44,8 +45,6 @@ (require 'mm-util) (require 'gnus-util) (autoload 'gnus-remove-odd-characters "gnus-sum") -(autoload 'gnus-range-add "gnus-range") -(autoload 'gnus-remove-from-range "gnus-range") ;; FIXME none of these are used explicitly in this file. (autoload 'gnus-sorted-intersection "gnus-range") (autoload 'gnus-intersection "gnus-range") @@ -1044,10 +1043,9 @@ See `find-file-noselect' for the arguments." mark (cond ((eq what 'add) - (gnus-range-add (cdr (assoc mark backend-marks)) range)) + (range-concat (cdr (assoc mark backend-marks)) range)) ((eq what 'del) - (gnus-remove-from-range - (cdr (assoc mark backend-marks)) range)) + (range-remove (cdr (assoc mark backend-marks)) range)) ((eq what 'set) range)) 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." (cdr (assoc '%Seen flags)) (cdr (assoc '%Deleted flags)))) (cdr (assoc '%Flagged flags))))) - (read (gnus-range-difference + (read (range-difference (cons start-article high) unread))) (when (> start-article 1) (setq read (gnus-range-nconcat (if (> start-article 1) - (gnus-sorted-range-intersection + (range-intersection (cons 1 (1- start-article)) (gnus-info-read info)) (gnus-info-read info)) @@ -1691,7 +1691,7 @@ If LIMIT, first try to limit the search to the N last articles." (pop old-marks) (when (and old-marks (> start-article 1)) - (setq old-marks (gnus-range-difference + (setq old-marks (range-difference old-marks (cons start-article high))) (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." (active (gnus-active group)) (unexists (if completep - (gnus-range-difference + (range-difference active (gnus-compress-sequence existing)) - (gnus-add-to-range + (range-add-list (cdr old-unexists) - (gnus-list-range-difference + (range-list-difference existing (gnus-active group)))))) (when (> (car active) 1) - (setq unexists (gnus-range-add + (setq unexists (range-concat (cons 1 (1- (car active))) unexists))) (if old-unexists @@ -1733,10 +1733,9 @@ If LIMIT, first try to limit the search to the N last articles." (defun nnimap-update-qresync-info (info existing vanished flags) ;; Add all the vanished articles to the list of read articles. (setf (gnus-info-read info) - (gnus-add-to-range - (gnus-add-to-range - (gnus-range-add (gnus-info-read info) - vanished) + (range-add-list + (range-add-list + (range-concat (gnus-info-read info) vanished) (cdr (assq '%Flagged flags))) (cdr (assq '%Seen flags)))) (let ((marks (gnus-info-marks info))) @@ -1750,9 +1749,9 @@ If LIMIT, first try to limit the search to the N last articles." (setq marks (delq ticks marks)) (pop ticks) ;; Add the new marks we got. - (setq ticks (gnus-add-to-range ticks new-marks)) + (setq ticks (range-add-list ticks new-marks)) ;; Remove the marks from messages that don't have them. - (setq ticks (gnus-remove-from-range + (setq ticks (range-remove ticks (gnus-compress-sequence (gnus-sorted-complement existing new-marks)))) @@ -1762,7 +1761,7 @@ If LIMIT, first try to limit the search to the N last articles." ;; Add vanished to the list of unexisting articles. (when vanished (let* ((old-unexists (assq 'unexist marks)) - (unexists (gnus-range-add (cdr old-unexists) vanished))) + (unexists (range-concat (cdr old-unexists) vanished))) (if old-unexists (setcdr old-unexists unexists) (push (cons 'unexist unexists) marks))) @@ -2242,7 +2241,7 @@ Return the server's response to the SELECT or EXAMINE command." (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t) (setq sequence (string-to-number (match-string 1))) (when (setq range (cadr (assq sequence sequences))) - (push (gnus-uncompress-range range) copied))) + (push (range-uncompress range) copied))) (gnus-compress-sequence (sort (apply #'nconc copied) #'<)))) (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'.") existing (nnmaildir--grp-nlist group) existing (mapcar #'car existing) existing (nreverse existing) - existing (gnus-compress-sequence existing 'always-list) + existing (range-compress-list existing) missing (list (cons 1 (nnmaildir--group-maxnum nnmaildir--cur-server group))) - missing (gnus-range-difference missing existing) + missing (range-difference missing existing) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (nnmaildir--nndir dir) @@ -1076,10 +1076,10 @@ This variable is set by `nnmaildir-request-article'.") (let ((article (nnmaildir--flist-art flist prefix))) (when article (push (nnmaildir--art-num article) article-list)))))) - (setq ranges (gnus-add-to-range ranges (sort article-list #'<))))) + (setq ranges (range-add-list ranges (sort article-list #'<))))) (if (eq mark 'read) (setq read ranges) (if ranges (setq marks (cons (cons mark ranges) marks))))) - (setf (gnus-info-read info) (gnus-range-add read missing)) + (setf (gnus-info-read info) (range-concat read missing)) (gnus-info-set-marks info marks 'extend) (setf (nnmaildir--grp-mmth group) new-mmth) info))) @@ -1548,11 +1548,11 @@ This variable is set by `nnmaildir-request-article'.") (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) - (throw 'return (gnus-uncompress-range ranges))) + (throw 'return (range-uncompress ranges))) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname)) (if (nnmaildir--param pgname 'read-only) - (throw 'return (gnus-uncompress-range ranges))) + (throw 'return (range-uncompress ranges))) (setq time (nnmaildir--param pgname 'expire-age)) (unless time (setq time (or (and nnmail-expiry-wait-function @@ -1564,7 +1564,7 @@ This variable is set by `nnmaildir-request-article'.") (setq time (round (* time 86400)))))) (when no-force (unless (integerp time) ;; handle 'never - (throw 'return (gnus-uncompress-range ranges))) + (throw 'return (range-uncompress ranges))) (setq boundary (time-since time))) (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) @@ -1686,7 +1686,7 @@ This variable is set by `nnmaildir-request-article'.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (dolist (action actions) - (setq ranges (gnus-range-add ranges (car action)))) + (setq ranges (range-concat ranges (car action)))) (throw 'return ranges)) (setq nlist (nnmaildir--grp-nlist group) 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.") (dolist (cur actions) (let ((type (nth 1 cur)) (cmdmarks (nth 2 cur)) - (range (gnus-uncompress-range (nth 0 cur))) + (range (range-uncompress (nth 0 cur))) mid ogroup temp) ;; number method (when (and corr (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 @@ ;; add article to index, either by building complete list ;; in reverse order, or as a list of ranges. (if (not nnmbox-group-building-active-articles) - (setcdr entry (gnus-add-to-range (cdr entry) (list article))) + (setcdr entry (range-add-list (cdr entry) (list article))) (when (memq article (cdr entry)) (switch-to-buffer nnmbox-mbox-buffer) (error "Article %s:%d already exists!" group article)) @@ -548,10 +548,10 @@ nnmbox-group-active-articles) (car nnmbox-group-active-articles))))) ;; remove article from index - (setcdr entry (gnus-remove-from-range (cdr entry) (list article))))) + (setcdr entry (range-remove (cdr entry) (list article))))) (defun nnmbox-is-article-active-p (article) - (gnus-member-of-range + (range-member-p article (cdr (assoc nnmbox-current-group 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." ;; #### doing anything on them. ;; 2 a/ read articles: (let ((read (gnus-info-read info))) - (setq read (gnus-remove-from-range read (list new-number))) - (when (gnus-member-of-range old-number read) - (setq read (gnus-remove-from-range read (list old-number))) - (setq read (gnus-add-to-range read (list new-number)))) + (setq read (range-remove read (list new-number))) + (when (range-member-p old-number read) + (setq read (range-remove read (list old-number))) + (setq read (range-add-list read (list new-number)))) (setf (gnus-info-read info) read)) ;; 2 b/ marked articles: (let ((oldmarks (gnus-info-marks info)) mark newmarks) (while (setq mark (pop oldmarks)) - (setcdr mark (gnus-remove-from-range (cdr mark) - (list new-number))) - (when (gnus-member-of-range old-number (cdr mark)) - (setcdr mark (gnus-remove-from-range (cdr mark) - (list old-number))) - (setcdr mark (gnus-add-to-range (cdr mark) + (setcdr mark (range-remove (cdr mark) (list new-number))) + (when (range-member-p old-number (cdr mark)) + (setcdr mark (range-remove (cdr mark) + (list old-number))) + (setcdr mark (range-add-list (cdr mark) (list new-number)))) (push mark newmarks)) (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 (inline-quote (cond ((eq ,type 'range) - (nnselect-categorize (gnus-uncompress-range ,articles) + (nnselect-categorize (range-uncompress ,articles) #'nnselect-article-group #'nnselect-article-number)) ((eq ,type 'tuple) (nnselect-categorize ,articles @@ -542,10 +542,10 @@ If this variable is nil, or if the provided function returns nil, (group-info (gnus-get-info artgroup)) (marks (gnus-info-marks group-info)) (unread (gnus-uncompress-sequence - (gnus-range-difference (gnus-active artgroup) - (gnus-info-read group-info))))) + (range-difference (gnus-active artgroup) + (gnus-info-read group-info))))) (setf (gnus-info-read info) - (gnus-add-to-range + (range-add-list (gnus-info-read info) (delq nil (mapcar (lambda (art) @@ -567,7 +567,7 @@ If this variable is nil, or if the provided function returns nil, artids)) (t (setq mark-list - (gnus-uncompress-range mark-list)) + (range-uncompress mark-list)) (mapcar (lambda (id) (when (memq (cdr id) mark-list) @@ -866,16 +866,16 @@ article came from is also searched." (when (and (gnus-check-backend-function 'request-set-mark artgroup) (not (gnus-article-unpropagatable-p type))) - (let* ((old (gnus-list-range-intersection + (let* ((old (range-list-intersection artlist (alist-get type (gnus-info-marks group-info)))) - (del (gnus-remove-from-range (copy-tree old) list)) - (add (gnus-remove-from-range (copy-tree list) old))) + (del (range-remove (copy-tree old) list)) + (add (range-remove (copy-tree list) old))) (when add (push (list add 'add (list type)) delta-marks)) (when del ;; Don't delete marks from outside the active range. ;; This shouldn't happen, but is a sanity check. - (setq del (gnus-sorted-range-intersection + (setq del (range-intersection (gnus-active artgroup) del)) (push (list del 'del (list type)) delta-marks)))) @@ -910,18 +910,18 @@ article came from is also searched." (< (car elt1) (car elt2)))))) (t (setq list - (gnus-compress-sequence + (range-compress-list (gnus-sorted-union (gnus-sorted-difference (gnus-uncompress-sequence (alist-get type (gnus-info-marks group-info))) artlist) - (sort list #'<)) t))) + (sort list #'<))))) ;; When exiting the group, everything that's previously been ;; unseen is now seen. (when (eq type 'seen) - (setq list (gnus-range-add + (setq list (range-concat list (cdr (assoc artgroup select-unseen)))))) (when (or list (eq type 'unexist)) @@ -944,9 +944,9 @@ article came from is also searched." ;; update read and unread (gnus-update-read-articles artgroup - (gnus-uncompress-range - (gnus-add-to-range - (gnus-remove-from-range + (range-uncompress + (range-add-list + (range-remove old-unread (cdr (assoc artgroup select-reads))) (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.") (lambda (article) (nnvirtual-reverse-map-article group article)) - (gnus-uncompress-range + (range-uncompress (gnus-group-expire-articles-1 group)))))) (sort (delq nil unexpired) #'<))) 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." (let ((pt2 (with-current-buffer standard-output (point))) (remapped (command-remapping function))) (unless (memq remapped '(ignore undefined)) - (let ((keys (where-is-internal - (or remapped function) overriding-local-map nil nil)) - non-modified-keys) + (let* ((all-keys (where-is-internal + (or remapped function) overriding-local-map nil nil)) + (seps (seq-group-by + (lambda (key) + (and (vectorp key) + (eq (elt key 0) 'menu-bar))) + all-keys)) + (keys (cdr (assq nil seps))) + (menus (cdr (assq t seps))) + non-modified-keys) (if (and (eq function 'self-insert-command) (vectorp (car-safe keys)) (consp (aref (car keys) 0))) @@ -522,24 +529,42 @@ suitable file is found, return nil." ;; don't mention them one by one. (if (< (length non-modified-keys) 10) (with-current-buffer standard-output - (insert (mapconcat #'help--key-description-fontified - keys ", "))) + (help-fns--insert-bindings keys)) (dolist (key non-modified-keys) (setq keys (delq key keys))) (if keys (with-current-buffer standard-output - (insert (mapconcat #'help--key-description-fontified - keys ", ")) + (help-fns--insert-bindings keys) (insert ", and many ordinary text characters")) - (princ "many ordinary text characters")))) + (princ "many ordinary text characters.")))) (when (or remapped keys non-modified-keys) (princ ".") - (terpri))))) + (terpri))) - (with-current-buffer standard-output - (fill-region-as-paragraph pt2 (point)) - (unless (looking-back "\n\n" (- (point) 2)) - (terpri)))))) + (with-current-buffer standard-output + (fill-region-as-paragraph pt2 (point)) + (unless (bolp) + (insert "\n")) + (when menus + (let ((start (point))) + (insert (concat "It can " + (and keys "also ") + "be invoked from the menu: ")) + ;; FIXME: Should insert menu names instead of key + ;; binding names. + (help-fns--insert-bindings menus) + (insert ".") + (fill-region-as-paragraph start (point)))) + (ensure-empty-lines))))))) + +(defun help-fns--insert-bindings (keys) + (seq-do-indexed (lambda (key i) + (insert + (cond ((zerop i) "") + ((= i (1- (length keys))) " and ") + (t ", "))) + (insert (help--key-description-fontified key))) + keys)) (defun help-fns--compiler-macro (function) (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." (cdr (member last-used-face hi-lock-face-defaults)) hi-lock-face-defaults)) face) - (if (and hi-lock-auto-select-face (not current-prefix-arg)) + (if (and hi-lock-auto-select-face (not current-prefix-arg)) (setq face (or (pop hi-lock--unused-faces) (car defaults))) - (setq face (completing-read - (format-prompt "Highlight using face" (car defaults)) - obarray 'facep t nil 'face-name-history defaults)) + (setq face (symbol-name + (read-face-name + (format-prompt "Highlight using face" (car defaults)) + defaults))) ;; Update list of un-used faces. (setq hi-lock--unused-faces (remove face hi-lock--unused-faces)) ;; Grow the list of defaults. @@ -855,7 +856,8 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search." nil) ;;; Mouse support -(defun hi-lock-symbol-at-mouse (event) +(defalias 'highlight-symbol-at-mouse 'hi-lock-face-symbol-at-mouse) +(defun hi-lock-face-symbol-at-mouse (event) "Highlight symbol at mouse click EVENT." (interactive "e") (save-excursion @@ -865,13 +867,13 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search." ;;;###autoload (defun hi-lock-context-menu (menu click) "Populate MENU with a menu item to highlight symbol at CLICK." - (save-excursion - (mouse-set-point click) - (when (symbol-at-point) - (define-key-after menu [highlight-search-separator] menu-bar-separator) - (define-key-after menu [highlight-search-mouse] - '(menu-item "Highlight Symbol" highlight-symbol-at-mouse - :help "Highlight symbol at point")))) + (when (thing-at-mouse click 'symbol) + (define-key-after menu [highlight-search-separator] menu-bar-separator + 'middle-separator) + (define-key-after menu [highlight-search-mouse] + '(menu-item "Highlight Symbol" highlight-symbol-at-mouse + :help "Highlight symbol at point") + 'highlight-search-separator)) menu) (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." (interactive) (image-dired--with-marked (image-dired-delete-char) - (backward-char)) + (unless (bobp) + (backward-char))) (image-dired--line-up-with-method) (with-current-buffer (image-dired-associated-dired-buffer) (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'." :group 'indent :type '(choice (const :tag "Always complete" nil) - (const :tag "Unless at the end of a line" 'eol) - (const :tag "Unless looking at a word" 'word) - (const :tag "Unless at a word or parenthesis" 'word-or-paren) - (const :tag "Unless at a word, parenthesis, or punctuation." 'word-or-paren-or-punct)) + (const :tag "Unless at the end of a line" eol) + (const :tag "Unless looking at a word" word) + (const :tag "Unless at a word or parenthesis" word-or-paren) + (const :tag "Unless at a word, parenthesis, or punctuation." + word-or-paren-or-punct)) :version "28.1") (defvar indent-line-ignored-functions '(indent-relative @@ -170,7 +171,7 @@ prefix argument is ignored." (let ((old-tick (buffer-chars-modified-tick)) (old-point (point)) (old-indent (current-indentation)) - (syn `(,(syntax-after (point))))) + (syn (syntax-after (point)))) ;; Indent the line. (or (not (eq (indent--funcall-widened indent-line-function) 'noindent)) @@ -182,21 +183,21 @@ prefix argument is ignored." (cond ;; If the text was already indented right, try completion. ((and (eq tab-always-indent 'complete) - (eq old-point (point)) - (eq old-tick (buffer-chars-modified-tick)) + (eql old-point (point)) + (eql old-tick (buffer-chars-modified-tick)) (or (null tab-first-completion) (eq last-command this-command) - (and (equal tab-first-completion 'eol) + (and (eq tab-first-completion 'eol) (eolp)) - (and (member tab-first-completion - '(word word-or-paren word-or-paren-or-punct)) - (not (member 2 syn))) - (and (member tab-first-completion - '(word-or-paren word-or-paren-or-punct)) - (not (or (member 4 syn) - (member 5 syn)))) - (and (equal tab-first-completion 'word-or-paren-or-punct) - (not (member 1 syn))))) + (and (memq tab-first-completion + '(word word-or-paren word-or-paren-or-punct)) + (not (eql 2 syn))) + (and (memq tab-first-completion + '(word-or-paren word-or-paren-or-punct)) + (not (or (eql 4 syn) + (eql 5 syn)))) + (and (eq tab-first-completion 'word-or-paren-or-punct) + (not (eql 1 syn))))) (completion-at-point)) ;; 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." (set-char-table-range char-script-table range 'tibetan)) 'tibetan) +;; Fix some exceptions that blocks.awk/Blocks.txt couldn't get right. +(set-char-table-range char-script-table '(#x2ea . #x2eb) 'bopomofo) +(set-char-table-range char-script-table #xab65 'greek) + ;;; Setting unicode-category-table. @@ -1522,8 +1526,11 @@ Setup `char-width-table' appropriate for non-CJK language environment." ;; We can't use the \N{name} things here, because this file is used ;; too early in the build process. -(defvar glyphless--bidi-control-characters - '(#x202a ; ?\N{left-to-right embedding} +(defvar bidi-control-characters + '(#x200e ; ?\N{left-to-right mark} + #x200f ; ?\N{right-to-left mark} + #x061c ; ?\N{arabic letter mark} + #x202a ; ?\N{left-to-right embedding} #x202b ; ?\N{right-to-left embedding} #x202d ; ?\N{left-to-right override} #x202e ; ?\N{right-to-left override} @@ -1531,7 +1538,14 @@ Setup `char-width-table' appropriate for non-CJK language environment." #x2067 ; ?\N{right-to-left isolate} #x2068 ; ?\N{first strong isolate} #x202c ; ?\N{pop directional formatting} - #x2069)) ; ?\N{pop directional isolate}) + #x2069) ; ?\N{pop directional isolate} + "List of bidirectional control characters.") + +(defun bidi-string-strip-control-characters (string) + "Strip bidi control characters from STRING and return the result." + (apply #'string (seq-filter (lambda (char) + (not (memq char bidi-control-characters))) + string))) (defun update-glyphless-char-display (&optional variable value) "Make the setting of `glyphless-char-display-control' take effect. @@ -1578,8 +1592,7 @@ option `glyphless-char-display'." (or (aref char-acronym-table from) "UNK"))) (when (or (eq target 'format-control) - (memq from - glyphless--bidi-control-characters)) + (memq from bidi-control-characters)) (set-char-table-range glyphless-char-display from this-method))) (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 @@ "Face for emojis that have derivations." :version "29.1") +(defvar emoji-alternate-names nil + "Alist of emojis and lists of alternate names for the emojis. +Each element in the alist should have the emoji (as a string) as +the first element, and the rest of the elements should be strings +representing names. For instance: + + (\"🤗\" \"hug\" \"hugging\" \"kind\")") + (defvar emoji--labels nil) (defvar emoji--all-bases nil) (defvar emoji--derived nil) @@ -90,8 +98,9 @@ of selecting from emoji display." ;;;###autoload (defun emoji-search () "Choose and insert an emoji glyph by typing its Unicode name. -This command prompts for an emoji name, with completion, and inserts it. -It recognizes the Unicode Standard names of emoji." +This command prompts for an emoji name, with completion, and +inserts it. It recognizes the Unicode Standard names of emoji, +and also consults the `emoji-alternate-names' alist." (interactive "*") (emoji--init) (emoji--choose-emoji)) @@ -647,29 +656,47 @@ We prefer the earliest unique letter." (defun emoji--choose-emoji () ;; Use the list of names. - (let ((name - (completing-read - "Insert emoji: " - (lambda (string pred action) - (if (eq action 'metadata) - (list 'metadata - (cons - 'affixation-function - ;; Add the glyphs to the start of the displayed - ;; strings when TAB-ing. - (lambda (strings) - (mapcar - (lambda (name) - (list name - (concat - (or (gethash name emoji--all-bases) " ") - "\t") - "")) - strings)))) - (complete-with-action action emoji--all-bases string pred))) - nil t))) + (let* ((table + (if (not emoji-alternate-names) + ;; If we don't have alternate names, do the efficient version. + emoji--all-bases + ;; Compute all the (possibly non-unique) names. + (let ((table nil)) + (maphash + (lambda (name glyph) + (push (concat name "\t" glyph) table)) + emoji--all-bases) + (dolist (elem emoji-alternate-names) + (dolist (name (cdr elem)) + (push (concat name "\t" (car elem)) table))) + (sort table #'string<)))) + (name + (completing-read + "Insert emoji: " + (lambda (string pred action) + (if (eq action 'metadata) + (list 'metadata + (cons + 'affixation-function + ;; Add the glyphs to the start of the displayed + ;; strings when TAB-ing. + (lambda (strings) + (mapcar + (lambda (name) + (if emoji-alternate-names + (list name "" "") + (list name + (concat + (or (gethash name emoji--all-bases) " ") + "\t") + ""))) + strings)))) + (complete-with-action action table string pred))) + nil t))) (when (cl-plusp (length name)) - (let* ((glyph (gethash name emoji--all-bases)) + (let* ((glyph (if emoji-alternate-names + (cadr (split-string name "\t")) + (gethash name emoji--all-bases))) (derived (gethash glyph emoji--derived))) (if (not derived) ;; 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 @@ (elymaic #x10FE0) (old-uyghur #x10F70) (mahajani #x11150) - (sinhala-archaic-number #x111E1) (khojki #x11200) (khudawadi #x112B0) (grantha #x11305) @@ -253,7 +252,6 @@ (gunjala-gondi #x11D60) (makasar #x11EE0) (cuneiform #x12000) - (cuneiform-numbers-and-punctuation #x12400) (cypro-minoan #x12F90) (egyptian #x13000) (mro #x16A40) @@ -262,7 +260,6 @@ (pahawh-hmong #x16B11) (medefaidrin #x16E40) (tangut #x17000) - (tangut-components #x18800) (khitan-small-script #x18B00) (nushu #x1B170) (duployan-shorthand #x1BC20) @@ -768,7 +765,6 @@ old-uyghur makasar dives-akuru - cuneiform-numbers-and-punctuation cuneiform egyptian 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 @@ +;;; textsec-check.el --- Check for suspicious texts -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(defgroup textsec nil + "Suspicious text identification." + :group 'security + :version "29.1") + +(defcustom textsec-check t + "If non-nil, perform some security-related checks on text objects. +If nil, these checks are disabled." + :type 'boolean + :version "29.1") + +(defface textsec-suspicious + '((t (:weight bold :background "red"))) + "Face used to highlight suspicious strings.") + +;;;###autoload +(defun textsec-suspicious-p (object type) + "Say whether OBJECT is suspicious for use as TYPE. +If OBJECT is suspicious, return a string explaining the reason +for considering it suspicious, otherwise return nil. + +Available values of TYPE and corresponding OBJECTs are: + + `url' -- a URL; OBJECT should be a URL string. + + `link' -- an HTML link; OBJECT should be a cons cell + of the form (URL . LINK-TEXT). + + `domain' -- a Web domain; OBJECT should be a string. + + `local-address' -- the local part of an email address; OBJECT + should be a string. + `name' -- the \"display name\" part of an email address; + OBJECT should be a string. + +`email-address' -- a full email address; OBJECT should be a string. + + `email-address-header' -- a raw email address header in RFC 2822 format; + OBJECT should be a string. + +If the user option `textsec-check' is nil, these checks are +disabled, and this function always returns nil." + (if (not textsec-check) + nil + (require 'textsec) + (let ((func (intern (format "textsec-%s-suspicious-p" type)))) + (unless (fboundp func) + (error "%s is not a valid function" func)) + (funcall func object)))) + +(provide 'textsec-check) + +;;; 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 @@ +;;; textsec.el --- Functions for handling homoglyphs and the like -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) +(require 'uni-confusable) +(require 'ucs-normalize) +(require 'idna-mapping) +(require 'puny) +(require 'mail-parse) +(require 'url) + +(defvar textsec--char-scripts nil) + +(eval-and-compile + (defun textsec--create-script-table (data) + "Create the textsec--char-scripts char table." + (setq textsec--char-scripts (make-char-table nil)) + (dolist (scripts data) + (dolist (range (cadr scripts)) + (set-char-table-range textsec--char-scripts + range (car scripts))))) + (require 'uni-scripts)) + +(defun textsec-scripts (string) + "Return a list of Unicode scripts used in STRING. +The scripts returned by this function use the Unicode Script property +as defined by the Unicode Standard Annex 24 (UAX#24)." + (seq-map (lambda (char) + (elt textsec--char-scripts char)) + string)) + +(defun textsec-single-script-p (string) + "Return non-nil if STRING is all in a single Unicode script. + +Note that the concept of \"single script\" used by this function +isn't obvious -- some mixtures of scripts count as a \"single +script\". See + + https://www.unicode.org/reports/tr39/#Mixed_Script_Detection + +for details. The Unicode scripts are as defined by the +Unicode Standard Annex 24 (UAX#24)." + (let ((scripts (mapcar + (lambda (s) + (append s + ;; Some scripts used in East Asia are + ;; commonly used across borders, so we add + ;; those. + (mapcan (lambda (script) + (copy-sequence + (textsec--augment-script script))) + s))) + (textsec-scripts string)))) + (catch 'empty + (cl-loop for s1 in scripts + do (cl-loop for s2 in scripts + ;; Common/inherited chars can be used in + ;; text with all scripts. + when (and (not (memq 'common s1)) + (not (memq 'common s2)) + (not (memq 'inherited s1)) + (not (memq 'inherited s2)) + (not (seq-intersection s1 s2))) + do (throw 'empty nil))) + t))) + +(defun textsec--augment-script (script) + (cond + ((eq script 'han) + '(hangul japan korea)) + ((or (eq script 'hiragana) + (eq script 'katakana)) + '(japan)) + ((or (eq script 'hangul) + (eq script 'bopomofo)) + '(korea)))) + +(defun textsec-covering-scripts (string) + "Return a minimal list of scripts used in STRING. +Note that a string may have several different minimal cover sets. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (let* ((scripts (textsec-scripts string)) + (set (car scripts))) + (dolist (s scripts) + (setq set (seq-union set (seq-difference s set)))) + (sort (delq 'common (delq 'inherited set)) #'string<))) + +(defun textsec-restriction-level (string) + "Say what restriction level STRING qualifies for. +Levels are (in decreasing order of restrictiveness) `ascii-only', +`single-script', `highly-restrictive', `moderately-restrictive', +`minimally-restrictive' and `unrestricted'." + (let ((scripts (textsec-covering-scripts string))) + (cond + ((string-match "\\`[[:ascii:]]+\\'" string) + 'ascii-only) + ((textsec-single-script-p string) + 'single-script) + ((or (null (seq-difference scripts '(latin han hiragana katakana))) + (null (seq-difference scripts '(latin han bopomofo))) + (null (seq-difference scripts '(latin han hangul)))) + 'highly-restrictive) + ((and (= (length scripts) 2) + (memq 'latin scripts) + ;; This list comes from + ;; https://www.unicode.org/reports/tr31/#Table_Recommended_Scripts + ;; (but without latin, cyrillic and greek). + (seq-intersection scripts + '(arabic + armenian + bengali + bopomofo + devanagari + ethiopic + georgian + gujarati + gurmukhi + hangul + han + hebrew + hiragana + katakana + kannada + khmer + lao + malayalam + myanmar + oriya + sinhala + tamil + telugu + thaana + thai + tibetan))) + ;; The string is covered by Latin and any one other Recommended + ;; script, except Cyrillic, Greek. + 'moderately-retrictive) + ;; Fixme `minimally-restrictive' -- needs well-formedness criteria + ;; and Identifier Profile. + (t + 'unrestricted)))) + +(defun textsec-mixed-numbers-p (string) + "Return non-nil if STRING includes numbers from different decimal systems." + (> + (length + (seq-uniq + (mapcar + (lambda (char) + ;; Compare zeros in the respective decimal systems. + (- char (get-char-code-property char 'numeric-value))) + (seq-filter (lambda (char) + ;; We're selecting the characters that + ;; have a numeric property. + (eq (get-char-code-property char 'general-category) + 'Nd)) + string)))) + 1)) + +(defun textsec-ascii-confusable-p (string) + "Return non-nil if non-ASCII STRING can be confused with ASCII on display." + (and (not (eq (textsec-restriction-level string) 'ascii-only)) + (eq (textsec-restriction-level (textsec-unconfuse-string string)) + 'ascii-only))) + +(defun textsec-unconfuse-string (string) + "Return a de-confused version of STRING. +This algorithm is described in: + + https://www.unicode.org/reports/tr39/#Confusable_Detection" + (ucs-normalize-NFD-string + (apply #'concat + (seq-map (lambda (char) + (or (gethash char uni-confusable-table) + (string char))) + (ucs-normalize-NFD-string string))))) + +(defun textsec-resolved-script-set (string) + "Return the resolved script set for STRING. +This is the minimal covering script set for STRING, but is nil is +STRING isn't a single script string. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (textsec-single-script-p string) + (textsec-covering-scripts string))) + +(defun textsec-single-script-confusable-p (string1 string2) + "Say whether STRING1 and STRING2 are single-script confusables. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (equal (textsec-unconfuse-string string1) + (textsec-unconfuse-string string2)) + ;; And they have to have at least one resolved script in + ;; common. + (seq-intersection (textsec-resolved-script-set string1) + (textsec-resolved-script-set string2)))) + +(defun textsec-mixed-script-confusable-p (string1 string2) + "Say whether STRING1 and STRING2 are mixed-script confusables. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (equal (textsec-unconfuse-string string1) + (textsec-unconfuse-string string2)) + ;; And they have no resolved scripts in common. + (null (seq-intersection (textsec-resolved-script-set string1) + (textsec-resolved-script-set string2))))) + +(defun textsec-whole-script-confusable-p (string1 string2) + "Say whether STRING1 and STRING2 are whole-script confusables. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (textsec-mixed-script-confusable-p string1 string2) + (textsec-single-script-p string1) + (textsec-single-script-p string2))) + +(defun textsec-domain-suspicious-p (domain) + "Say whether DOMAIN's name looks suspicious. +Return nil if it isn't suspicious. If it is, return a string explaining +the potential problem. + +Domain names are considered suspicious if they use characters +that can look similar to other characters when displayed, or +use characters that are not allowed by Unicode's IDNA mapping, +or use certain other unusual mixtures of characters." + (catch 'found + (seq-do + (lambda (char) + (when (eq (elt idna-mapping-table char) t) + (throw 'found + (format "Disallowed character%s (#x%x, %s)" + (if (eq (get-char-code-property char 'general-category) + 'Cf) + "" + (concat ": " (string char))) + char + (get-char-code-property char 'name))))) + domain) + ;; Does IDNA allow it? + (unless (puny-highly-restrictive-domain-p domain) + (throw + 'found + (format "`%s' mixes characters from different scripts in suspicious ways" + domain))) + ;; Check whether any segment of the domain name is confusable with + ;; an ASCII-only segment. + (dolist (elem (split-string domain "\\.")) + (when (textsec-ascii-confusable-p elem) + (throw 'found (format "`%s' is confusable with ASCII" elem)))) + nil)) + +(defun textsec-local-address-suspicious-p (local) + "Say whether LOCAL part of an email address looks suspicious. +LOCAL is the bit before \"@\" in an email address. + +If it isn't suspicious, return nil. If it is, return a string explaining +the potential problem. + +Email addresses are considered suspicious if they use characters +that can look similar to other characters when displayed, or use +certain other unusual mixtures of characters." + (cond + ((not (equal local (ucs-normalize-NFKC-string local))) + (format "`%s' is not in normalized format `%s'" + local (ucs-normalize-NFKC-string local))) + ((textsec-mixed-numbers-p local) + (format "`%s' contains numbers from different number systems" local)) + ((eq (textsec-restriction-level local) 'unrestricted) + (format "`%s' isn't restrictive enough" local)) + ((string-match-p "\\`\\.\\|\\.\\'\\|\\.\\." local) + (format "`%s' contains invalid dots" local)))) + +(defun textsec-name-suspicious-p (name) + "Say whether NAME looks suspicious. +NAME is (for instance) the free-text display name part of an +email address. + +If it isn't suspicious, return nil. If it is, return a string +explaining the potential problem. + +Names are considered suspicious if they use characters that can +look similar to other characters when displayed, or use certain +other unusual mixtures of characters." + (cond + ((not (equal name (ucs-normalize-NFC-string name))) + (format "`%s' is not in normalized format `%s'" + name (ucs-normalize-NFC-string name))) + ((and (seq-find (lambda (char) + (and (member char bidi-control-characters) + (not (member char + '( ?\N{left-to-right mark} + ?\N{right-to-left mark} + ?\N{arabic letter mark}))))) + name) + ;; We have bidirectional formatting characters, but check + ;; whether they affect LTR characters. If not, it's not + ;; suspicious. + (bidi-find-overridden-directionality 0 (length name) name)) + (format "The string contains bidirectional control characters")) + ((textsec-suspicious-nonspacing-p name)))) + +(defun textsec-suspicious-nonspacing-p (string) + "Say whether STRING uses nonspacing characters in suspicious ways. +If it doesn't, return nil. If it does, return a string explaining +the potential problem. + +Use of nonspacing characters is considered suspicious if there are +two or more consecutive identical nonspacing characters, or too many +consecutive nonspacing characters." + (let ((prev nil) + (nonspace-count 0)) + (catch 'found + (seq-do + (lambda (char) + (let ((nonspacing + (memq (get-char-code-property char 'general-category) + '(Mn Me)))) + (when (and nonspacing + (equal char prev)) + (throw 'found "Two identical consecutive nonspacing characters")) + (setq nonspace-count (if nonspacing + (1+ nonspace-count) + 0)) + (when (> nonspace-count 4) + (throw 'found + "Too many consecutive nonspacing characters")) + (setq prev char))) + string) + nil))) + +(defun textsec-email-address-suspicious-p (address) + "Say whether EMAIL address looks suspicious. +If it isn't, return nil. If it is, return a string explaining the +potential problem. + +An email address is considered suspicious if either of its two +parts -- the local address name or the domain -- are found to be +suspicious by, respectively, `textsec-local-address-suspicious-p' +and `textsec-domain-suspicious-p'." + (pcase-let ((`(,local ,domain) (split-string address "@"))) + (or + (textsec-domain-suspicious-p domain) + (textsec-local-address-suspicious-p local)))) + +(defun textsec-email-address-header-suspicious-p (email) + "Say whether EMAIL looks suspicious. +If it isn't, return nil. If it is, return a string explaining the +potential problem. + +Note that EMAIL has to be a valid email specification according +to RFC2047bis -- strings that can't be parsed will be flagged as +suspicious. + +An email specification is considered suspicious if either of its +two parts -- the address or the name -- are found to be +suspicious by, respectively, `textsec-email-address-suspicious-p' +and `textsec-name-suspicious-p'." + (catch 'end + (pcase-let ((`(,address . ,name) + (condition-case nil + (mail-header-parse-address email t) + (error (throw 'end "Email address can't be parsed."))))) + (or + (textsec-email-address-suspicious-p address) + (and name (textsec-name-suspicious-p name)))))) + +(defun textsec-url-suspicious-p (url) + "Say whether URL looks suspicious. +If it isn't, return nil. If it is, return a string explaining the +potential problem." + (let ((parsed (url-generic-parse-url url))) + ;; The URL may not have a domain. + (and (url-host parsed) + (textsec-domain-suspicious-p (url-host parsed))))) + +(defun textsec-link-suspicious-p (link) + "Say whether LINK is suspicious. +LINK should be a cons cell where the first element is the URL, +and the second element is the link text. + +This function will return non-nil if it seems like the link text +is misleading about where the URL takes you. This is typical +when the link text looks like an URL itself, but doesn't lead to +the same domain as the URL." + (let* ((url (car link)) + (text (string-trim (cdr link)))) + (catch 'found + (let ((udomain (url-host (url-generic-parse-url url))) + (tdomain (url-host (url-generic-parse-url text)))) + (cond + ((and udomain + tdomain + (not (equal udomain tdomain)) + ;; One may be a sub-domain of the other, but don't allow too + ;; short domains. + (not (or (and (string-suffix-p udomain tdomain) + (url-domsuf-cookie-allowed-p udomain)) + (and (string-suffix-p tdomain udomain) + (url-domsuf-cookie-allowed-p tdomain))))) + (throw 'found + (format "Text `%s' doesn't point to link URL `%s'" + text url))) + ((and tdomain + (textsec-domain-suspicious-p tdomain)) + (throw 'found + (format "Domain `%s' in the link text is suspicious" + (bidi-string-strip-control-characters + tdomain))))))))) + +(provide 'textsec) + +;;; 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 Alt-Control-Hyper-Meta-Shift-super" (declare (pure t) (side-effect-free t)) - (and - (stringp keys) - (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) - (save-match-data - (catch 'exit - (let ((prefixes - "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") - (case-fold-search nil)) - (dolist (key (split-string keys " ")) - ;; Every key might have these modifiers, and they should be - ;; in this order. - (when (string-match (concat "\\`" prefixes) key) - (setq key (substring key (match-end 0)))) - (unless (or (and (= (length key) 1) - ;; Don't accept control characters as keys. - (not (< (aref key 0) ?\s)) - ;; Don't accept Meta'd characters as keys. - (or (multibyte-string-p key) - (not (<= 127 (aref key 0) 255)))) - (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) - ;; Don't allow <M-C-down>. - (= (progn - (string-match - (concat "\\`<" prefixes) key) - (match-end 0)) - 1)) - (string-match-p - "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" - key)) - ;; Invalid. - (throw 'exit nil))) - t))))) + (let ((case-fold-search nil)) + (and + (stringp keys) + (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) + (save-match-data + (catch 'exit + (let ((prefixes + "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")) + (dolist (key (split-string keys " ")) + ;; Every key might have these modifiers, and they should be + ;; in this order. + (when (string-match (concat "\\`" prefixes) key) + (setq key (substring key (match-end 0)))) + (unless (or (and (= (length key) 1) + ;; Don't accept control characters as keys. + (not (< (aref key 0) ?\s)) + ;; Don't accept Meta'd characters as keys. + (or (multibyte-string-p key) + (not (<= 127 (aref key 0) 255)))) + (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) + ;; Don't allow <M-C-down>. + (= (progn + (string-match + (concat "\\`<" prefixes) key) + (match-end 0)) + 1)) + (string-match-p + "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" + key)) + ;; Invalid. + (throw 'exit nil))) + t)))))) (defun key-translate (from to) "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'." (skip-syntax-backward "^ ") (and (looking-at "[[:space:]]*\\([[:alnum:]_-]+([[:alnum:]]+)\\)") - (match-string 1))) - (define-key-after menu [man-separator] menu-bar-separator) + (match-string 1))) + (define-key-after menu [man-separator] menu-bar-separator + 'middle-separator) (define-key-after menu [man-at-mouse] - '(menu-item "Open man page" man-at-mouse - :help "Open man page around mouse click")))) + '(menu-item "Open man page" Man-at-mouse + :help "Open man page around mouse click") + 'man-separator))) menu) 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 @@ (bindings--define-key menu [separator-print] menu-bar-separator) - (unless (featurep 'ns) - (bindings--define-key menu [close-tab] - '(menu-item "Close Tab" tab-close - :visible (fboundp 'tab-close) - :help "Close currently selected tab")) - (bindings--define-key menu [make-tab] - '(menu-item "New Tab" tab-new - :visible (fboundp 'tab-new) - :help "Open a new tab")) - - (bindings--define-key menu [separator-tab] - menu-bar-separator)) - - (bindings--define-key menu [enable-undelete-frame-mode] - '(menu-item "Enable Undeleting Frames" undelete-frame-mode - :visible (null undelete-frame-mode) - :help "Enable undeleting frames in this session")) + (bindings--define-key menu [close-tab] + '(menu-item "Close Tab" tab-close + :visible (fboundp 'tab-close) + :help "Close currently selected tab")) + (bindings--define-key menu [make-tab] + '(menu-item "New Tab" tab-new + :visible (fboundp 'tab-new) + :help "Open a new tab")) + + (bindings--define-key menu [separator-tab] + menu-bar-separator) + + (bindings--define-key menu [undelete-frame-mode] + '(menu-item "Allow Undeleting Frames" undelete-frame-mode + :help "Allow frames to be restored after deletion" + :button (:toggle . undelete-frame-mode))) + (bindings--define-key menu [undelete-last-deleted-frame] '(menu-item "Undelete Frame" undelete-frame - :visible (and undelete-frame-mode + :enable (and undelete-frame-mode (car undelete-frame--deleted-frames)) :help "Undelete the most recently deleted frame")) 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: - `styles': the list of `completion-styles' to use for that category. - `cycle': the `completion-cycle-threshold' to use for that category. Categories are symbols such as `buffer' and `file', used when -completing buffer and file names, respectively.") +completing buffer and file names, respectively. + +Also see `completion-category-overrides'.") (defcustom completion-category-overrides nil "List of category-specific user overrides for completion styles. @@ -1014,7 +1016,9 @@ an association list that can specify properties such as: - `cycle': the `completion-cycle-threshold' to use for that category. Categories are symbols such as `buffer' and `file', used when completing buffer and file names, respectively. -This overrides the defaults specified in `completion-category-defaults'." + +If a property in a category is specified by this variable, it +overrides the default specified in `completion-category-defaults'." :version "25.1" :type `(alist :key-type (choice :tag "Category" (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." (function-item context-menu-buffers) (function-item context-menu-vc) (function-item context-menu-ffap) - (function-item Man-context-menu) (function-item hi-lock-context-menu) - (function-item context-menu-online-search) + (function-item occur-context-menu) + (function-item Man-context-menu) + (function-item dictionary-context-menu) (function :tag "Custom function"))) :version "28.1") @@ -323,6 +324,8 @@ the function `context-menu-filter-function'." (fun (mouse-posn-property (event-start click) 'context-menu-function))) + (select-window (posn-window (event-start click))) + (if (functionp fun) (setq menu (funcall fun menu click)) (run-hook-wrapped 'context-menu-functions @@ -534,16 +537,6 @@ Some context functions add menu items below the separator." :help "Find file or URL from text around mouse click")))) menu) -(defun context-menu-online-search (menu click) - "Populate MENU with command to search online." - (save-excursion - (mouse-set-point click) - (define-key-after menu [online-search-separator] menu-bar-separator) - (define-key-after menu [online-search-at-mouse] - '(menu-item "Online search" mouse-online-search-at-point - :help "Search for region or word online"))) - menu) - (defvar context-menu-entry `(menu-item ,(purecopy "Context Menu") ,(make-sparse-keymap) :filter ,(lambda (_) (context-menu-map))) @@ -3230,26 +3223,6 @@ is copied instead of being cut." (with-current-buffer (window-buffer window) (setq cursor-type (nth 3 state))))))) -(defvar eww-search-prefix) -(defun mouse-online-search-at-point (event) - "Query an online search engine at EVENT. -If a region is active, the entire region will be sent, otherwise -the symbol at point will be used. This command uses EWW's -default search engine, as configured by `eww-search-prefix'." - (interactive "e") - (require 'eww) - (let ((query (if (use-region-p) - (buffer-substring (region-beginning) - (region-end)) - (save-excursion - (mouse-set-point event) - (thing-at-point 'symbol))))) - (unless query - (user-error "Nothing to search for")) - (browse-url (concat - eww-search-prefix - (mapconcat #'url-hexify-string (split-string query) "+"))))) - ;;; Bindings for mouse commands. 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." (dictionary-search word))) ;;;###autoload -(defun context-menu-dictionary (menu click) +(defun dictionary-context-menu (menu click) "Populate MENU with dictionary commands at CLICK. When you add this function to `context-menu-functions', the 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: Where VIEWERINFO specifies how the content-type is viewed. Can be a string, in which case it is run through a shell, with appropriate -parameters, or a symbol, in which case the symbol is `funcall'ed if -and only if it exists as a function, with the buffer as an argument. +parameters, or a symbol, in which case the symbol must name a function +of zero arguments which is called in a buffer holding the MIME part's +content. TESTINFO is a test for the viewer's applicability, or nil. If nil, it means 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." (mailcap-parse-mailcaps) (let ((command (mailcap-mime-info (mailcap-extension-to-mime (file-name-extension file))))) - (unless command - (error "No viewer for %s" (file-name-extension file))) - ;; Remove quotes around the file name - we'll use shell-quote-argument. - (while (string-match "['\"]%s['\"]" command) - (setq command (replace-match "%s" t t command))) - (setq command (replace-regexp-in-string - "%s" - (shell-quote-argument (convert-standard-filename file)) - command - nil t)) - ;; Handlers such as "gio open" and kde-open5 start viewer in background - ;; and exit immediately. Avoid `start-process' since it assumes - ;; :connection-type `pty' and kills children processes with SIGHUP - ;; when temporary terminal session is finished (Bug#44824). - ;; An alternative is `process-connection-type' let-bound to nil for - ;; `start-process-shell-command' call (with no chance to report failure). - (make-process - :name "mailcap-view-file" - :connection-type 'pipe - :buffer nil ; "*Messages*" may be suitable for debugging - :sentinel (lambda (proc event) - (when (and (memq (process-status proc) '(exit signal)) - (/= (process-exit-status proc) 0)) - (message - "Command %s: %s." - (mapconcat #'identity (process-command proc) " ") - (substring event 0 -1)))) - :command (list shell-file-name shell-command-switch command)))) + (if (functionp command) + ;; command is a viewer function (a mode) expecting the file + ;; contents to be in the current buffer. + (let ((buf (generate-new-buffer (file-name-nondirectory file)))) + (set-buffer buf) + (insert-file-contents file) + (setq buffer-file-name file) + (funcall command) + (set-buffer-modified-p nil) + (pop-to-buffer buf)) + ;; command is a program to run with file as an argument. + (unless command + (error "No viewer for %s" (file-name-extension file))) + ;; Remove quotes around the file name - we'll use shell-quote-argument. + (while (string-match "['\"]%s['\"]" command) + (setq command (replace-match "%s" t t command))) + (setq command (replace-regexp-in-string + "%s" + (shell-quote-argument (convert-standard-filename file)) + command + nil t)) + ;; Handlers such as "gio open" and kde-open5 start viewer in background + ;; and exit immediately. Avoid `start-process' since it assumes + ;; :connection-type `pty' and kills children processes with SIGHUP + ;; when temporary terminal session is finished (Bug#44824). + ;; An alternative is `process-connection-type' let-bound to nil for + ;; `start-process-shell-command' call (with no chance to report failure). + (make-process + :name "mailcap-view-file" + :connection-type 'pipe + :buffer nil ; "*Messages*" may be suitable for debugging + :sentinel (lambda (proc event) + (when (and (memq (process-status proc) '(exit signal)) + (/= (process-exit-status proc) 0)) + (message + "Command %s: %s." + (mapconcat #'identity (process-command proc) " ") + (substring event 0 -1)))) + :command (list shell-file-name shell-command-switch command))))) (provide 'mailcap) 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." (dom-attr dom 'name)))) ; Obsolete since HTML5. (push (cons id (point)) shr--link-targets)) (when url - (shr-urlify (or shr-start start) (shr-expand-url url) title)))) + (shr-urlify (or shr-start start) (shr-expand-url url) title) + ;; Check whether the URL is suspicious. + (when-let ((warning (or (textsec-suspicious-p + (shr-expand-url url) 'url) + (textsec-suspicious-p + (cons (shr-expand-url url) + (buffer-substring (or shr-start start) + (point))) + 'link)))) + (add-text-properties (or shr-start start) (point) + (list 'face '(shr-link textsec-suspicious))) + (insert (propertize "⚠️" 'help-echo warning)))))) (defun shr-tag-abbr (dom) (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." (defun tramp-adb-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." (with-tramp-connection-property vec "signal-strings" - (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + (let ((default-directory (tramp-make-tramp-file-name vec 'noloc)) ;; `shell-file-name' and `shell-command-switch' are needed ;; for Emacs < 27.1, which doesn't support connection-local ;; variables in `shell-command'. @@ -815,7 +815,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Determine input. (if (null infile) (setq input (tramp-get-remote-null-device v)) - (setq infile (expand-file-name infile)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. (setq input (tramp-file-local-name infile)) @@ -870,7 +870,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq ret (tramp-adb-send-command-and-check v (format "(cd %s; %s)" - (tramp-shell-quote-argument localname) command) + (tramp-unquote-shell-quote-argument localname) + command) t)) (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. @@ -900,8 +901,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - - (unless process-file-side-effects + (when process-file-side-effects (tramp-flush-directory-properties v "")) ;; 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'" ((tramp-archive-file-name-p archive) (let ((archive (tramp-make-tramp-file-name - (tramp-archive-dissect-file-name archive) nil 'noarchive))) + (tramp-archive-dissect-file-name archive)))) (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) (puthash archive (list vec) tramp-archive-hash)) @@ -560,8 +560,7 @@ offered." (defun tramp-archive-gvfs-file-name (name) "Return NAME in GVFS syntax." - (tramp-make-tramp-file-name - (tramp-archive-dissect-file-name name) nil 'nohop)) + (tramp-make-tramp-file-name (tramp-archive-dissect-file-name name))) ;; 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." (dolist (elt tramp-connection-properties) (when (tramp-compat-string-search (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-make-tramp-file-name key 'noloc)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash)))) 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." (when (file-remote-p result) (setq result (tramp-compat-file-name-quote result 'top))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)) - 'nohop))))) + result))))))) ;; Basic functions. @@ -2852,7 +2851,7 @@ implementation will be used." ;; `shell'. We discard hops, if existing, that's why ;; we cannot use `file-remote-p'. (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name v nil 'nohop) + (tramp-make-tramp-file-name v) tramp-initial-end-of-output)) ;; We use as environment the difference to toplevel ;; `process-environment'. @@ -3013,7 +3012,7 @@ implementation will be used." vec (concat "signal-strings-" (tramp-get-method-parameter vec 'tramp-remote-shell)) - (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + (let ((default-directory (tramp-make-tramp-file-name vec 'noloc)) process-file-return-signal-string signals res result) (setq signals (append @@ -3098,13 +3097,13 @@ implementation will be used." ;; Determine input. (if (null infile) (setq input (tramp-get-remote-null-device v)) - (setq infile (expand-file-name infile)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name v input 'nohop)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -3136,7 +3135,7 @@ implementation will be used." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name v stderr 'nohop)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr (tramp-get-remote-null-device v))))) @@ -3153,7 +3152,8 @@ implementation will be used." (setq ret (tramp-send-command-and-check v (format "cd %s && %s" - (tramp-shell-quote-argument localname) command) + (tramp-unquote-shell-quote-argument localname) + command) t t t)) (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. @@ -3184,8 +3184,7 @@ implementation will be used." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - - (unless process-file-side-effects + (when process-file-side-effects (tramp-flush-directory-properties v "")) ;; Return exit status. @@ -3650,8 +3649,7 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-sh-file-name-handler-p (vec) "Whether VEC uses a method from `tramp-sh-file-name-handler'." (and (assoc (tramp-file-name-method vec) tramp-methods) - (eq (tramp-find-foreign-file-name-handler - (tramp-make-tramp-file-name vec nil 'nohop)) + (eq (tramp-find-foreign-file-name-handler vec) 'tramp-sh-file-name-handler))) ;; This must be the last entry, because `identity' always matches. @@ -5441,7 +5439,7 @@ Nonexistent directories are removed from spec." (lambda (x) (and (stringp x) - (file-directory-p (tramp-make-tramp-file-name vec x 'nohop)) + (file-directory-p (tramp-make-tramp-file-name vec x)) x)) remote-path)))))) 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." ;; Determine input. (when infile - (setq infile (expand-file-name infile)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. (setq input (tramp-file-local-name infile)) @@ -1373,8 +1373,7 @@ component is used as the target of the symlink." (when tmpinput (delete-file tmpinput)) (unless outbuf (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) - - (unless process-file-side-effects + (when process-file-side-effects (tramp-flush-directory-properties v "")) ;; 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 @@ (set-file-acl . ignore) (set-file-modes . tramp-sshfs-handle-set-file-modes) (set-file-selinux-context . ignore) - (set-file-times . ignore) + (set-file-times . tramp-sshfs-handle-set-file-times) (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) (shell-command . tramp-handle-shell-command) (start-file-process . tramp-handle-start-file-process) @@ -242,13 +242,28 @@ arguments to pass to the OPERATION." (let ((command (format "cd %s && exec %s" - localname - (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))) + (tramp-unquote-shell-quote-argument localname) + (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) + input tmpinput) + + ;; Determine input. + (if (null infile) + (setq input (tramp-get-remote-null-device v)) + (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) + (if (tramp-equal-remote default-directory infile) + ;; INFILE is on the same remote host. + (setq input (tramp-file-local-name infile)) + ;; INFILE must be copied to remote host. + (setq input (tramp-make-tramp-temp-file v) + tmpinput (tramp-make-tramp-file-name v input)) + (copy-file infile tmpinput t))) + (when input (setq command (format "%s <%s" command input))) + (unwind-protect (apply #'tramp-call-process v (tramp-get-method-parameter v 'tramp-login-program) - infile destination display + nil destination display (tramp-expand-args v 'tramp-login-args ?h (or (tramp-file-name-host v) "") @@ -256,7 +271,11 @@ arguments to pass to the OPERATION." ?p (or (tramp-file-name-port v) "") ?l command)) - (unless process-file-side-effects + ;; Cleanup. We remove all file cache values for the + ;; connection, because the remote process could have changed + ;; them. + (when tmpinput (delete-file tmpinput)) + (when process-file-side-effects (tramp-flush-directory-properties v "")))))) (defun tramp-sshfs-handle-rename-file @@ -285,6 +304,15 @@ arguments to pass to the OPERATION." (tramp-compat-set-file-modes (tramp-fuse-local-file-name filename) mode flag)))) +(defun tramp-sshfs-handle-set-file-times (filename &optional timestamp flag) + "Like `set-file-times' for Tramp files." + (or (file-exists-p filename) (write-region "" nil filename nil 0)) + (with-parsed-tramp-file-name filename nil + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (tramp-compat-set-file-times + (tramp-fuse-local-file-name filename) timestamp flag)))) + (defun tramp-sshfs-handle-write-region (start end filename &optional append visit lockname mustbenew) "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." (when (file-remote-p result) (setq result (tramp-compat-file-name-quote result 'top))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)) - 'nohop))))) + result))))))) (defun tramp-sudoedit-handle-file-writable-p (filename) "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." "Construct a Tramp file name from ARGS. ARGS could have two different signatures. The first one is of -type (VEC &optional LOCALNAME HOP). +type (VEC &optional LOCALNAME). If LOCALNAME is nil, the value in VEC is used. If it is a symbol, a null localname will be used. Otherwise, LOCALNAME is expected to be a string, which will be used. -If HOP is nil, the value in VEC is used. If it is a symbol, a -null hop will be used. Otherwise, HOP is expected to be a -string, which will be used. The other signature exists for backward compatibility. It has the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." @@ -1735,8 +1732,13 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." hop (tramp-file-name-hop (car args))) (when (cadr args) (setq localname (and (stringp (cadr args)) (cadr args)))) - (when (cl-caddr args) - (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + (when hop + (setq hop nil) + ;; Assure that the hops are in `tramp-default-proxies-alist'. + ;; In tramp-archive.el, the slot `hop' is used for the archive + ;; file name. + (unless (string-equal method "archive") + (tramp-add-hops (car args))))) (t (setq method (nth 0 args) user (nth 1 args) @@ -1769,15 +1771,17 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." localname))) (set-advertised-calling-convention - #'tramp-make-tramp-file-name '(vec &optional localname hop) "27.1") + #'tramp-make-tramp-file-name '(vec &optional localname) "29.1") (defun tramp-make-tramp-hop-name (vec) "Construct a Tramp hop name from VEC." - (replace-regexp-in-string - tramp-prefix-regexp "" + (concat + (tramp-file-name-hop vec) (replace-regexp-in-string - (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format - (tramp-make-tramp-file-name vec 'noloc)))) + tramp-prefix-regexp "" + (replace-regexp-in-string + (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format + (tramp-make-tramp-file-name vec 'noloc))))) (defun tramp-completion-make-tramp-file-name (method user host localname) "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." (tramp-get-connection-property vec "process-buffer" nil)) (setq buffer-undo-list t default-directory - (tramp-make-tramp-file-name vec 'noloc 'nohop)) + (tramp-make-tramp-file-name vec 'noloc)) (current-buffer))))) (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." "A predicate for Tramp interactive commands. They are completed by \"M-x TAB\" only in Tramp debug buffers." (with-current-buffer buffer - (string-equal (buffer-substring 1 10) ";; Emacs:"))) + (string-equal (buffer-substring 1 (min 10 (point-max))) ";; Emacs:"))) (put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) @@ -2596,11 +2600,10 @@ Must be handled by the callers." ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) -(defun tramp-find-foreign-file-name-handler (filename &optional _operation) +(defun tramp-find-foreign-file-name-handler (vec &optional _operation) "Return foreign file name handler if exists." - (when (tramp-tramp-file-p filename) + (when (tramp-file-name-p vec) (let ((handler tramp-foreign-file-name-handler-alist) - (vec (tramp-dissect-file-name filename)) elt func res) (while handler (setq elt (car handler) @@ -2633,7 +2636,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (with-parsed-tramp-file-name filename nil (let ((current-connection tramp-current-connection) (foreign - (tramp-find-foreign-file-name-handler filename operation)) + (tramp-find-foreign-file-name-handler v operation)) (signal-hook-function #'tramp-signal-hook-function) result) ;; Set `tramp-current-connection'. @@ -3351,7 +3354,7 @@ User is always nil." (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename) (tramp-make-tramp-file-name vec (concat "~" (substring filename (match-beginning 1)))) - filename))) + (tramp-make-tramp-file-name (tramp-dissect-file-name filename))))) (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." @@ -3678,8 +3681,8 @@ User is always nil." ;; We do not want traces in the debug buffer. (let ((tramp-verbose (min tramp-verbose 3))) (when (tramp-tramp-file-p filename) - (let* ((v (tramp-dissect-file-name filename)) - (p (tramp-get-connection-process v)) + (let* ((o (tramp-dissect-file-name filename)) + (p (tramp-get-connection-process o)) (c (and (process-live-p p) (tramp-get-connection-property p "connected" nil)))) ;; We expand the file name only, if there is already a connection. @@ -3693,7 +3696,8 @@ User is always nil." ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) - ((eq identification 'hop) hop) + ;; Hop exists only in original dissected file name. + ((eq identification 'hop) (tramp-file-name-hop o)) (t (tramp-make-tramp-file-name v 'noloc))))))))) (defun tramp-handle-file-selinux-context (_filename) @@ -3744,8 +3748,7 @@ User is always nil." (expand-file-name symlink-target (file-name-directory v2-localname)))) - v2-localname) - 'nohop))) + v2-localname)))) (when (>= numchase numchase-limit) (tramp-error v1 'file-error @@ -3904,8 +3907,7 @@ User is always nil." (cond ((stringp remote-copy) (file-local-copy - (tramp-make-tramp-file-name - v remote-copy 'nohop))) + (tramp-make-tramp-file-name v remote-copy))) ((stringp tramp-temp-buffer-file-name) (copy-file filename tramp-temp-buffer-file-name 'ok) @@ -3948,7 +3950,7 @@ User is always nil." (or remote-copy (null tramp-temp-buffer-file-name))) (delete-file local-copy)) (when (stringp remote-copy) - (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))) + (delete-file (tramp-make-tramp-file-name v remote-copy)))) ;; Result. (cons filename (cdr result))))) @@ -4088,15 +4090,10 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (and (tramp-sh-file-name-handler-p vec) (not (tramp-get-method-parameter vec 'tramp-copy-program)))) -(defun tramp-compute-multi-hops (vec) - "Expands VEC according to `tramp-default-proxies-alist'." - (let ((saved-tdpa tramp-default-proxies-alist) - (target-alist `(,vec)) - (hops (or (tramp-file-name-hop vec) "")) - (item vec) - choices proxy) - - ;; Ad-hoc proxy definitions. +(defun tramp-add-hops (vec) + "Add ad-hoc proxy definitions to `tramp-default-proxies-alist'." + (when-let ((hops (tramp-file-name-hop vec)) + (item vec)) (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) (let* ((host-port (tramp-file-name-host-port item)) (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'.") (add-to-list 'tramp-default-proxies-alist entry) (setq item (tramp-dissect-file-name proxy)))) ;; Save the new value. - (when (and hops tramp-save-ad-hoc-proxies) + (when tramp-save-ad-hoc-proxies (customize-save-variable - 'tramp-default-proxies-alist tramp-default-proxies-alist)) + 'tramp-default-proxies-alist tramp-default-proxies-alist)))) + +(defun tramp-compute-multi-hops (vec) + "Expands VEC according to `tramp-default-proxies-alist'." + (let ((saved-tdpa tramp-default-proxies-alist) + (target-alist `(,vec)) + (item vec) + choices proxy) + + ;; Ad-hoc proxy definitions. + (tramp-add-hops vec) ;; Look for proxy hosts to be passed. (setq choices tramp-default-proxies-alist) @@ -5462,8 +5469,7 @@ This handles also chrooted environments, which are not regarded as local." (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. (file-writable-p - (tramp-make-tramp-file-name - vec tramp-compat-temporary-file-directory 'nohop)) + (tramp-make-tramp-file-name vec tramp-compat-temporary-file-directory)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) (zerop (tramp-get-remote-uid vec 'integer)))))) @@ -5712,7 +5718,7 @@ Invokes `password-read' if available, `read-passwd' else." ;; multi-hop. (tramp-get-connection-property proc "password-vector" (process-get proc 'vector)) - 'noloc 'nohop)) + 'noloc)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) @@ -5789,7 +5795,7 @@ Invokes `password-read' if available, `read-passwd' else." (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc)))) (put #'tramp-clear-passwd 'tramp-suppress-trace t) 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." (title (cdr (assq :title params))) (lines (cdr (assq :line params))) (sets (cdr (assq :set params))) + (missing (cdr (assq :missing params))) (x-labels (cdr (assq :xlabels params))) (y-labels (cdr (assq :ylabels params))) (timefmt (cdr (assq :timefmt params))) @@ -138,6 +139,7 @@ code." (file-name-directory (buffer-file-name)))) (add-to-body (lambda (text) (setq body (concat text "\n" body))))) ;; append header argument settings to body + (when missing (funcall add-to-body (format "set datafile missing '%s'" missing))) (when title (funcall add-to-body (format "set title '%s'" title))) (when lines (mapc (lambda (el) (funcall add-to-body el)) lines)) (when sets @@ -288,21 +290,14 @@ Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE." (with-temp-file data-file (insert (let ((org-babel-gnuplot-timestamp-fmt (or (plist-get params :timefmt) "%Y-%m-%d-%H:%M:%S"))) - (replace-regexp-in-string - ;; org export backend adds "|" at the beginning/end of - ;; the table lines. Strip those. - "^|\\(.+\\)|$" - "\\1" - (orgtbl-to-generic - table - (org-combine-plists - '( :sep "\t" :fmt org-babel-gnuplot-quote-tsv-field - ;; Two setting below are needed to make :fmt work. - :raw t - ;; Use `org', not `ascii' because `ascii' may - ;; sometimes mishandle quoted strings. - :backend org) - params)))))) + (orgtbl-to-generic + table + (org-combine-plists + '( :sep "\t" :fmt org-babel-gnuplot-quote-tsv-field + ;; Two setting below are needed to make :fmt work. + :raw t + :backend ascii) + params))))) data-file) (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 @@ (declare-function org-capture "org-capture" (&optional goto keys)) (declare-function org-clock-modify-effort-estimate "org-clock" (&optional value)) +(declare-function org-element-type "org-element" (&optional element)) + (defvar calendar-mode-map) (defvar org-clock-current-task) (defvar org-current-tag-alist) @@ -5729,7 +5731,8 @@ displayed in agenda view." (org-at-planning-p) (org-before-first-heading-p) (and org-agenda-include-inactive-timestamps - (org-at-clock-log-p))) + (org-at-clock-log-p)) + (not (eq 'timestamp (org-element-type (org-element-context))))) (throw :skip nil)) (org-agenda-skip)) (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." (defun org-git-version () "The Git version of Org mode. Inserted by installing Org or when a release is made." - (let ((org-git-version "release_9.5.2-3-geb9f34")) + (let ((org-git-version "release_9.5.2-9-g7ba24c")) org-git-version)) (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." "Is S an ID created by UUIDGEN?" (string-match "\\`[0-9a-f]\\{8\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{12\\}\\'" (downcase s))) -(defun org-in-src-block-p (&optional inside) +(defun org-in-src-block-p (&optional inside element) "Whether point is in a code source block. When INSIDE is non-nil, don't consider we are within a source -block when point is at #+BEGIN_SRC or #+END_SRC." - (let ((case-fold-search t)) - (or (and (eq (get-char-property (point) 'src-block) t)) - (and (not inside) - (save-match-data - (save-excursion - (beginning-of-line) - (looking-at ".*#\\+\\(begin\\|end\\)_src"))))))) +block when point is at #+BEGIN_SRC or #+END_SRC. +When ELEMENT is provided, it is considered to be element at point." + (save-match-data (setq element (or element (org-element-at-point)))) + (when (eq 'src-block (org-element-type element)) + (or (not inside) + (not (or (= (line-beginning-position) + (org-element-property :post-affiliated element)) + (= (1+ (line-end-position)) + (- (org-element-property :end element) + (org-element-property :post-blank element)))))))) (defun org-context () "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." (org-export-table-cell-alignment table-cell info))))) (setq contents (concat data - (make-string (- width (string-width (or data ""))) ?\s)))) + ;; FIXME: If CONTENTS was transformed by filters, + ;; the whole width calculation can be wrong. + ;; At least, make sure that we do not throw error + ;; when CONTENTS is larger than width. + (make-string (max 0 (- width (string-width (or data "")))) ?\s)))) ;; Return cell. (concat (format " %s " contents) (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 '(outline-font-lock-keywords t nil nil backward-paragraph)) (setq-local imenu-generic-expression (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0))) - (add-hook 'change-major-mode-hook #'outline-show-all nil t)) + (add-hook 'change-major-mode-hook #'outline-show-all nil t) + (add-hook 'hack-local-variables-hook #'outline-apply-default-state nil t)) (defvar outline-minor-mode-map) @@ -434,7 +435,8 @@ See the command `outline-mode' for more information on this mode." nil t) (setq-local line-move-ignore-invisible t) ;; Cause use of ellipses for invisible text. - (add-to-invisibility-spec '(outline . t))) + (add-to-invisibility-spec '(outline . t)) + (outline-apply-default-state)) (when outline-minor-mode-highlight (if font-lock-fontified (font-lock-remove-keywords nil outline-font-lock-keywords)) @@ -1303,6 +1305,178 @@ convenient way to make a table of contents of the buffer." (insert "\n\n")))))) (kill-new (buffer-string))))))) +(defcustom outline-default-state nil + "If non-nil, some headings are initially outlined. + +Note that the default state is applied when the major mode is set +or when the command `outline-apply-default-state' is called +interactively. + +When nil, headings visibility is left unchanged. + +If equal to `outline-show-all', all text of buffer is shown. + +If equal to `outline-show-only-headings', only headings are shown. + +If equal to a number, show only headings up to and including the +corresponding level. See `outline-default-rules' to customize +visibility of the subtree at the choosen level. + +If equal to a lambda function or function name, this function is +expected to toggle headings visibility, and will be called after +the mode is enabled." + :version "29.1" + :type '(choice (const :tag "Disabled" nil) + (const :tag "Show all" outline-show-all) + (const :tag "Only headings" outline-show-only-headings) + (natnum :tag "Show headings up to level" :value 1) + (function :tag "Custom function"))) + +(defcustom outline-default-rules nil + "Determines visibility of subtree starting at `outline-default-state' level. + +When nil, the subtree is hidden unconditionally. + +When equal to a list, each element should be one of the following: + +- A cons cell with CAR `match-regexp' and CDR a regexp, the + subtree will be hidden when the outline heading match the + regexp. + +- `subtree-has-long-lines' to only show the heading branches when + long lines are detected in its subtree (see + `outline-default-long-line' for the definition of long lines). + +- `subtree-is-long' to only show the heading branches when its + subtree contains more than `outline-default-line-count' lines. + +- A lambda function or function name which will be evaluated with + point at the beginning of the heading and the match data set + appropriately, the function being expected to toggle the + heading visibility." + :version "29.1" + :type '(choice (const :tag "Hide subtree" nil) + (set :tag "Show subtree unless" + (cons :tag "Heading match regexp" + (const match-regexp) string) + (const :tag "Subtree has long lines" + subtree-has-long-lines) + (const :tag "Subtree is long" + subtree-is-long) + (cons :tag "Custom function" + (const custom-function) function)))) + +(defcustom outline-default-long-line 1000 + "Minimal number of characters in a line for a heading to be outlined." + :version "29.1" + :type '(natnum :tag "Number of characters")) + +(defcustom outline-default-line-count 50 + "Minimal number of lines for a heading to be outlined." + :version "29.1" + :type '(natnum :tag "Number of lines")) + +(defun outline-apply-default-state () + "Apply the outline state defined by `outline-default-state'." + (interactive) + (cond + ((integerp outline-default-state) + (outline--show-headings-up-to-level outline-default-state)) + ((functionp outline-default-state) + (funcall outline-default-state)))) + +(defun outline-show-only-headings () + "Show only headings." + (interactive) + (outline-show-all) + (outline-hide-region-body (point-min) (point-max))) + +(eval-when-compile (require 'so-long)) +(autoload 'so-long-detected-long-line-p "so-long") +(defvar so-long-skip-leading-comments) +(defvar so-long-threshold) +(defvar so-long-max-lines) + +(defun outline--show-headings-up-to-level (level) + "Show only headings up to a LEVEL level. + +Like `outline-hide-sublevels' but, for each heading at level +LEVEL, decides of subtree visibility according to +`outline-default-rules'." + (if (not outline-default-rules) + (outline-hide-sublevels level) + (if (< level 1) + (error "Must keep at least one level of headers")) + (save-excursion + (let* (outline-view-change-hook + (beg (progn + (goto-char (point-min)) + ;; Skip the prelude, if any. + (unless (outline-on-heading-p t) (outline-next-heading)) + (point))) + (end (progn + (goto-char (point-max)) + ;; Keep empty last line, if available. + (if (bolp) (1- (point)) (point)))) + (heading-regexp + (cdr-safe + (assoc 'match-regexp outline-default-rules))) + (check-line-count + (memq 'subtree-is-long outline-default-rules)) + (check-long-lines + (memq 'subtree-has-long-lines outline-default-rules)) + (custom-function + (cdr-safe + (assoc 'custom-function outline-default-rules)))) + (if (< end beg) + (setq beg (prog1 end (setq end beg)))) + ;; First hide everything. + (outline-hide-sublevels level) + ;; Then unhide the top level headers. + (outline-map-region + (lambda () + (let ((current-level (funcall outline-level))) + (when (< current-level level) + (outline-show-heading) + (outline-show-entry)) + (when (= current-level level) + (cond + ((and heading-regexp + (let ((beg (point)) + (end (progn (outline-end-of-heading) (point)))) + (string-match-p heading-regexp (buffer-substring beg end)))) + ;; hide entry when heading match regexp + (outline-hide-entry)) + ((and check-line-count + (save-excursion + (let ((beg (point)) + (end (progn (outline-end-of-subtree) (point)))) + (<= outline-default-line-count (count-lines beg end))))) + ;; show only branches when line count of subtree > + ;; threshold + (outline-show-branches)) + ((and check-long-lines + (save-excursion + (let ((beg (point)) + (end (progn (outline-end-of-subtree) (point)))) + (save-restriction + (narrow-to-region beg end) + (let ((so-long-skip-leading-comments nil) + (so-long-threshold outline-default-long-line) + (so-long-max-lines nil)) + (so-long-detected-long-line-p)))))) + ;; show only branches when long lines are detected + ;; in subtree + (outline-show-branches)) + (custom-function + ;; call custom function if defined + (funcall custom-function)) + (t + ;; if no previous clause succeeds, show subtree + (outline-show-subtree)))))) + beg end))) + (run-hooks 'outline-view-change-hook))) + (defun outline--cycle-state () "Return the cycle state of current heading. Return 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'." (let ((open-paren-line-string (blink-paren-open-paren-line-string openparen)) (message-log-max nil)) - (minibuffer-message - "Matches %s" - (substring-no-properties open-paren-line-string))))) + (minibuffer-message "Matches %s" open-paren-line-string)))) ;; Always set the overlay face, since it varies. (overlay-put show-paren--overlay 'priority show-paren-priority) (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." COMMAND is the prefix for which we seek completion. CONTEXT is the text before COMMAND on the line." (let* ((complete-list - (gud-gdb-run-command-fetch-lines (concat "complete " context command) + (gud-gdb-run-command-fetch-lines (concat "server complete " + context command) (current-buffer) ;; From string-match above. (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'." "Use `ruby-encoding-map' to set encoding magic comment if this is non-nil." :type 'boolean :group 'ruby) +(defcustom ruby-toggle-block-space-before-parameters t + "When non-nil, ensure space between the \"toggled\" curly and parameters. +This only affects the output of the command `ruby-toggle-block'." + :type 'boolean + :safe 'booleanp + :version "29.1") + ;;; SMIE support (require 'smie) @@ -1722,13 +1729,14 @@ See `add-log-current-defun-function'." (insert "}") (goto-char orig) (delete-char 2) - ;; Maybe this should be customizable, let's see if anyone asks. - (insert "{ ") - (setq beg-marker (point-marker)) - (when (looking-at "\\s +|") - (delete-char (- (match-end 0) (match-beginning 0) 1)) - (forward-char) - (re-search-forward "|" (line-end-position) t)) + (insert "{") + (if (looking-at "\\s +|") + (progn + (just-one-space (if ruby-toggle-block-space-before-parameters 1 0)) + (setq beg-marker (point-marker)) + (forward-char) + (re-search-forward "|" (line-end-position) t)) + (setq beg-marker (point-marker))) (save-excursion (skip-chars-forward " \t\n\r") (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.") (defcustom xref-file-name-display 'project-relative "Style of file name display in *xref* buffers. -If the value is the symbol `abs', the default, show the file names -in their full absolute form. +If the value is the symbol `abs', show the file names in their +full absolute form. If `nondirectory', show only the nondirectory (a.k.a. \"base name\") part of the file name. -If `project-relative', show only the file name relative to the -current project root. If there is no current project, or if the -file resides outside of its root, show that particular file name -in its full absolute form." +If `project-relative', the default, show only the file name +relative to the current project root. If there is no current +project, or if the file resides outside of its root, show that +particular file name in its full absolute form." :type '(choice (const :tag "absolute file name" abs) (const :tag "nondirectory file name" nondirectory) (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." (let* ((execute-extended-command--last-typed nil) (keymaps ;; The major mode's keymap and any active minor modes. - (cons - (current-local-map) + (nconc + (and (current-local-map) (list (current-local-map))) (mapcar #'cdr (seq-filter @@ -2957,7 +2957,8 @@ undo record: if we undo from 4, `pending-undo-list' will be at 3, (defcustom undo-no-redo nil "If t, `undo' doesn't go through redo entries." - :type 'boolean) + :type 'boolean + :group 'undo) (defvar pending-undo-list nil "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." (defvar clone-buffer-hook nil "Normal hook to run in the new buffer at the end of `clone-buffer'.") -(defvar clone-indirect-buffer-hook nil - "Normal hook to run in the new buffer at the end of `clone-indirect-buffer'.") - (defun clone-process (process &optional newname) "Create a twin copy of PROCESS. If NEWNAME is nil, it defaults to PROCESS' name; @@ -9595,8 +9593,6 @@ Returns the newly created indirect buffer." (setq newname (substring newname 0 (match-beginning 0)))) (let* ((name (generate-new-buffer-name newname)) (buffer (make-indirect-buffer (current-buffer) name t))) - (with-current-buffer buffer - (run-hooks 'clone-indirect-buffer-hook)) (when display-flag (pop-to-buffer buffer nil norecord)) 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." (defmacro with-output-to-temp-buffer (bufname &rest body) "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. -This construct makes buffer BUFNAME empty before running BODY. -It does not make the buffer current for BODY. -Instead it binds `standard-output' to that buffer, so that output -generated with `prin1' and similar functions in BODY goes into -the buffer. +This is a convenience macro meant for displaying help buffers and +the like. It empties the BUFNAME buffer before evaluating BODY +and disables undo in that buffer. + +It does not make the buffer current for BODY. Instead it binds +`standard-output' to that buffer, so that output generated with +`prin1' and similar functions in BODY goes into the buffer. At the end of BODY, this marks buffer BUFNAME unmodified and displays it 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 @@ (declare-function haiku-selection-data "haikuselect.c") (declare-function haiku-selection-put "haikuselect.c") (declare-function haiku-selection-targets "haikuselect.c") +(declare-function haiku-selection-owner-p "haikuselect.c") (declare-function haiku-put-resource "haikufns.c") (defun haiku--handle-x-command-line-resources (command-line-resources) @@ -105,9 +106,8 @@ If TYPE is nil, return \"text/plain\"." &context (window-system haiku)) (haiku-selection-data selection "text/plain")) -(cl-defmethod gui-backend-selection-owner-p (_ - &context (window-system haiku)) - t) +(cl-defmethod gui-backend-selection-owner-p (selection &context (window-system haiku)) + (haiku-selection-owner-p selection)) (declare-function haiku-read-file-name "haikufns.c") @@ -136,6 +136,16 @@ If TYPE is nil, return \"text/plain\"." (define-key special-event-map [drag-n-drop] 'haiku-dnd-handle-drag-n-drop-event) +(defvaralias 'haiku-use-system-tooltips 'use-system-tooltips) + +(defun haiku-use-system-tooltips-watcher (&rest _ignored) + "Variable watcher to force a menu bar update when `use-system-tooltip' changes. +This is necessary because on Haiku `use-system-tooltip' doesn't +take effect on menu items until the menu bar is updated again." + (force-mode-line-update t)) + +(add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher) + (provide 'haiku-win) (provide 'term/haiku-win) 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." (t (popup-menu (mouse-menu-bar-map) last-nonmenu-event)))) +(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) + (provide 'pgtk-win) (provide 'term/pgtk-win) 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." (defvar x-preedit-overlay nil "The overlay currently used to display preedit text from a compose sequence.") +;; With some input methods, text gets inserted before Emacs is told to +;; remove any preedit text that was displayed, which causes both the +;; preedit overlay and the text to be visible for a brief period of +;; time. This pre-command-hook clears the overlay before any command +;; and should be set whenever a preedit overlay is visible. +(defun x-clear-preedit-text () + "Clear the pre-edit overlay and remove itself from pre-command-hook. +This function should be installed in `pre-command-hook' whenever +preedit text is displayed." + (when x-preedit-overlay + (delete-overlay x-preedit-overlay) + (setq x-preedit-overlay nil)) + (remove-hook 'pre-command-hook #'x-clear-preedit-text)) + (defun x-preedit-text (event) "Display preedit text from a compose sequence in EVENT. EVENT is a preedit-text event." (interactive "e") (when x-preedit-overlay (delete-overlay x-preedit-overlay) - (setq x-preedit-overlay nil)) + (setq x-preedit-overlay nil) + (remove-hook 'pre-command-hook #'x-clear-preedit-text)) (when (nth 1 event) (let ((string (propertize (nth 1 event) 'face '(:underline t)))) (setq x-preedit-overlay (make-overlay (point) (point))) + (add-hook 'pre-command-hook #'x-clear-preedit-text) (overlay-put x-preedit-overlay 'window (selected-window)) (overlay-put x-preedit-overlay 'before-string (if x-display-cursor-at-start-of-preedit-string @@ -1545,6 +1561,8 @@ EVENT is a preedit-text event." (define-key special-event-map [preedit-text] 'x-preedit-text) +(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) + (provide 'x-win) (provide 'term/x-win) 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: ("\\\\bibliographystyle" ispell-tex-arg-end) ("\\\\makebox" ispell-tex-arg-end 0) ("\\\\e?psfig" ispell-tex-arg-end) - ("\\\\document\\(class\\|style\\)" . - "\\\\begin[ \t\n]*{[ \t\n]*document[ \t\n]*}")) + ("\\\\document\\(class\\|style\\)" . "\\\\begin[ \t\n]*{document}")) (;; delimited with \begin. In ispell: displaymath, eqnarray, eqnarray*, ;; equation, minipage, picture, tabular, tabular* (ispell) ("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) ("list" ispell-tex-arg-end 2) - ("program" . "\\\\end[ \t\n]*{[ \t\n]*program[ \t\n]*}") - ("verbatim\\*?" . "\\\\end[ \t\n]*{[ \t\n]*verbatim\\*?[ \t\n]*}")))) + ("program" . "\\\\end[ \t]*{program}") + ("verbatim\\*?" . "\\\\end[ \t]*{verbatim\\*?}")))) "Lists of regions to be skipped in TeX mode. First list is used raw. Second 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 (defvar tooltip-previous-message nil "The previous content of the echo area.") +(defvar haiku-use-system-tooltips) + (defun tooltip-show-help-non-mode (help) "Function installed as `show-help-function' when Tooltip mode is off. It 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." "Function installed as `show-help-function'. MSG is either a help string to display, or nil to cancel the display." (if (and (display-graphic-p) - (or (not (eq window-system 'haiku)) ;; On Haiku, there isn't a reliable way to show tooltips - ;; above menus. + ;; On Haiku, system tooltips can't be displayed above + ;; menus. + (or (not (and (eq window-system 'haiku) + haiku-use-system-tooltips)) (not (menu-or-popup-active-p)))) (let ((previous-help tooltip-help-message)) (setq tooltip-help-message msg) @@ -383,9 +387,12 @@ MSG is either a help string to display, or nil to cancel the display." ;; Cancel display. This also cancels a delayed tip, if ;; there is one. (tooltip-hide)) - ((equal-including-properties previous-help msg) - ;; Same help as before (but possibly the mouse has moved). - ;; Keep what we have. + ((equal previous-help msg) + ;; Same help as before (but possibly the mouse has + ;; moved or the text properties have changed). Keep + ;; what we have. If only text properties have changed, + ;; the tooltip won't be updated, but that shouldn't + ;; occur. ) (t ;; 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." (defun url-queue-start-retrieve (job) (setf (url-queue-buffer job) (ignore-errors - (with-current-buffer (if (buffer-live-p (url-queue-context-buffer job)) + (with-current-buffer (if (buffer-live-p + (url-queue-context-buffer job)) (url-queue-context-buffer job) (current-buffer)) - (let ((url-request-noninteractive t)) - (url-retrieve (url-queue-url job) - #'url-queue-callback-function (list job) - (url-queue-silentp job) - (url-queue-inhibit-cookiesp job))))))) + (let ((url-request-noninteractive t) + ;; This will disable querying the user for + ;; credentials if one of the things we're fetching + ;; in the background return a header requesting it. + (url-request-extra-headers '(("Authorization" . "")))) + (url-retrieve (url-queue-url job) + #'url-queue-callback-function (list job) + (url-queue-silentp job) + (url-queue-inhibit-cookiesp job))))))) (defun url-queue-prune-old-entries () (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." "Iterate over all hunks between point and MAX. Call FUN with two args (BEG and END) for each hunk." (save-excursion - (let* ((beg (or (ignore-errors (diff-beginning-of-hunk)) - (ignore-errors (diff-hunk-next) (point)) - max))) - (while (< beg max) - (goto-char beg) - (cl-assert (looking-at diff-hunk-header-re)) - (let ((end - (save-excursion (diff-end-of-hunk) (point)))) - (cl-assert (< beg end)) - (funcall fun beg end) - (goto-char end) - (setq beg (if (looking-at diff-hunk-header-re) - end - (or (ignore-errors (diff-hunk-next) (point)) - max)))))))) + (catch 'malformed + (let* ((beg (or (ignore-errors (diff-beginning-of-hunk)) + (ignore-errors (diff-hunk-next) (point)) + max))) + (while (< beg max) + (goto-char beg) + (unless (looking-at diff-hunk-header-re) + (throw 'malformed nil)) + (let ((end + (save-excursion (diff-end-of-hunk) (point)))) + (unless (< beg end) + (throw 'malformed nil)) + (funcall fun beg end) + (goto-char end) + (setq beg (if (looking-at diff-hunk-header-re) + end + (or (ignore-errors (diff-hunk-next) (point)) + max))))))))) (defun diff--font-lock-refined (max) "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." (defvar cvs-bakprefix ".#" "The prefix that CVS prepends to files when rcsmerge'ing.") -(autoload 'cvs-mode-toggle-mark "pcvs") +(declare-function cvs-mode-toggle-mark "pcvs" (e)) (defvar-keymap cvs-status-map :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." ;; ;; First try: find a responsible backend. If this is for registration, ;; it must be a backend under which FILE is not yet registered. - (let ((dirs (delq nil - (mapcar - (lambda (backend) - (when-let ((dir (vc-call-backend - backend 'responsible-p file))) - (cons backend dir))) - vc-handled-backends)))) + (let* ((file (expand-file-name file)) + (dirs (delq nil + (mapcar + (lambda (backend) + (when-let ((dir (vc-call-backend + backend 'responsible-p file))) + (cons backend dir))) + vc-handled-backends)))) ;; Just a single response (or none); use it. (if (< (length dirs) 2) (caar dirs) |