diff --git a/.dir-locals.el b/.dir-locals.el index af92eac5bba..d9ccf82b166 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -15,7 +15,12 @@ "/[ \t]*DEFVAR_[A-Z_ \t(]+\"[^\"]+\",[ \t]\\([A-Za-z0-9_]+\\)/\\1/")))) (etags-regen-ignores . ("test/manual/etags/")) (vc-prepare-patches-separately . nil) - (vc-default-patch-addressee . "bug-gnu-emacs@gnu.org"))) + (vc-default-patch-addressee . "bug-gnu-emacs@gnu.org") + ;; Uncomment these later once people's builds are likely to know + ;; they're safe local variable values. + ;; (vc-trunk-branch-regexps . ("master" "\\`emacs-[0-9]+\\'")) + ;; (vc-topic-branch-regexps . ("\\`feature/")) + )) (c-mode . ((c-file-style . "GNU") (c-noise-macro-names . ("INLINE" "NO_INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "ATTRIBUTE_NO_SANITIZE_ADDRESS" diff --git a/.mailmap b/.mailmap index 5350eadca67..c75dc4ed2f1 100644 --- a/.mailmap +++ b/.mailmap @@ -158,6 +158,7 @@ Philip Kaludercic Philip Kaludercic Philip Kaludercic Philip Kaludercic +Philip Kaludercic Philipp Stephani Philipp Stephani Phillip Lord diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES index c07fdc487ee..bdd5a097ab7 100644 --- a/admin/CPP-DEFINES +++ b/admin/CPP-DEFINES @@ -34,7 +34,9 @@ __ANDROID_API__ A numerical "API level" indicating the version of HAVE_NTGUI Use the native W32 GUI for windows, frames, menus&scrollbars. HAVE_NS Use the NeXT/OpenStep/Cocoa UI under macOS or GNUstep. NS_IMPL_GNUSTEP Compile support for GNUstep implementation of NS GUI API. + Only true on systems other than macOS. NS_IMPL_COCOA Compile support for Cocoa (Apple) implementation of NS GUI API. + Only true on macOS. HAVE_X11 Compile support for the X11 GUI. HAVE_PGTK Compile support for using GTK itself without directly using X Windows APIs. HAVE_HAIKU Compile support for the Haiku window system. diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index ea6622ef86a..dd339f9af80 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -235,7 +235,6 @@ Philip Kaludercic lisp/emacs-lisp/package.el lisp/emacs-lisp/package-vc.el lisp/emacs-lisp/compat.el - lisp/net/rcirc.el Yuan Fu src/treesit.c @@ -390,6 +389,7 @@ Juri Linkov lisp/repeat.el Philip Kaludercic + lisp/net/rcirc.el lisp/epa-ks.el Harald Jörg diff --git a/admin/README b/admin/README index 3e86319f2a3..3f2aae3fe84 100644 --- a/admin/README +++ b/admin/README @@ -53,6 +53,10 @@ be used to debug Emacs with dense colormaps (PseudoColor). Check doc strings against documentation. +** cl-lib-deps-report.el + +Audit Lisp files for cl-lib usage and missing requires. + ** cus-test.el Tests for custom types and load problems. diff --git a/admin/cl-lib-deps-report.el b/admin/cl-lib-deps-report.el new file mode 100755 index 00000000000..37d741161ac --- /dev/null +++ b/admin/cl-lib-deps-report.el @@ -0,0 +1,162 @@ +:;exec emacs -Q --batch -l "$0" -- "$@" # -*- lexical-binding: t -*- +;;; cl-lib-deps-report.el --- report cl-lib dependencies in lisp files -*- lexical-binding: t -*- + +;; Copyright (C) 2026 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 . + +;;; Commentary: + +;; Generate an Org report of cl-lib macro/function usage and missing +;; compile-time/runtime requires for files under lisp/. + +;;; Code: + +(require 'cl-lib) +(require 'org) + +(setq debug-on-error nil) + +(defun cl-lib-deps-report--scan-file (file symbol-re macros funcs) + "Return cl-lib usage data for FILE using SYMBOL-RE, MACROS, and FUNCS. +Exclude tokens found in strings or comments, and return a list with +dependency flags, require kind, and sorted symbol lists." + (with-temp-buffer + (insert-file-contents file) + (with-syntax-table emacs-lisp-mode-syntax-table + (let ((tokens '()) + (total-req 0) + (eval-req 0)) + (goto-char (point-min)) + (while (re-search-forward symbol-re nil t) + (let ((ppss (syntax-ppss))) + (unless (or (nth 3 ppss) (nth 4 ppss)) + (push (match-string 0) tokens)))) + (setq tokens (cl-delete-duplicates tokens :test #'string=)) + (let* ((macro-toks (cl-remove-if-not (lambda (tok) (member tok macros)) tokens)) + (func-toks (cl-remove-if-not (lambda (tok) (member tok funcs)) tokens)) + (macro-dep (and macro-toks t)) + (func-dep (and func-toks t))) + (goto-char (point-min)) + (while (re-search-forward "(require[[:space:]\n]*'cl-lib" nil t) + (let ((ppss (syntax-ppss))) + (unless (or (nth 3 ppss) (nth 4 ppss)) + (setq total-req (1+ total-req))))) + (goto-char (point-min)) + (while (re-search-forward "(eval-when-compile[[:space:]\n]*(require[[:space:]\n]*'cl-lib" nil t) + (let ((ppss (syntax-ppss))) + (unless (or (nth 3 ppss) (nth 4 ppss)) + (setq eval-req (1+ eval-req))))) + (let* ((runtime-req (> total-req eval-req)) + (eval-req-present (> eval-req 0)) + (require-kind + (cond + ((and (= total-req 0) (= eval-req 0)) "no") + ((> total-req eval-req) "runtime") + (t "compile-time")))) + (list macro-dep func-dep require-kind runtime-req eval-req-present + (sort macro-toks #'string<) + (sort func-toks #'string<)))))))) + +(defun cl-lib-deps-report--main (args) + "Generate an Org report of cl-lib dependencies under a Lisp directory. +ARGS should be `command-line-args-left', which starts with \"--\" when +invoked via the file's exec stub." + (let* ((script-dir (file-name-directory (or load-file-name buffer-file-name))) + (default-root (expand-file-name "../lisp" script-dir)) + ;; `command-line-args-left' includes a \"--\" sentinel from the exec stub. + (args (if (and args (string= (car args) "--")) (cdr args) args)) + (root (or (car args) default-root))) + (unless (file-directory-p root) + (princ (format "%s: Directory not found: %s\n" (or load-file-name "cl-lib-deps-report.el") root)) + (kill-emacs 1)) + (let* ((candidate-re "cl-[[:alnum:]-]+\\*?") + (symbol-re "\\_") + (pattern (format "%s|\\(require[[:space:]]*'cl-lib|\\(eval-when-compile[[:space:]]*\\(require[[:space:]]*'cl-lib" + candidate-re)) + (files + (let ((cmd (format "find %s -type f -name '*.el' -print0 | xargs -0 grep -l -E %s || true" + (shell-quote-argument root) + (shell-quote-argument pattern)))) + (with-temp-buffer + (call-process "sh" nil t nil "-c" cmd) + (split-string (buffer-string) "\n" t)))) + (macros '()) + (funcs '())) + (mapatoms + (lambda (sym) + (when (and (symbolp sym) + (string-prefix-p "cl-" (symbol-name sym))) + (cond + ((macrop sym) (push (symbol-name sym) macros)) + ((fboundp sym) (push (symbol-name sym) funcs)))))) + (setq macros (sort macros #'string<)) + (setq funcs (sort funcs #'string<)) + (setq files (sort files #'string<)) + (with-temp-buffer + (org-mode) + (insert (format "* cl-lib dependency report (%s)\n" root)) + (insert "** files\n") + (insert "| file | cl- macros used | cl- functions used | require |\n") + (insert "|------|-----------------|--------------------|---------|\n") + (let (runtime-missing compile-missing require-unneeded) + (dolist (file files) + (when (file-regular-p file) + (cl-destructuring-bind (macro-dep func-dep require-kind runtime-req eval-req-present macro-toks func-toks) + (cl-lib-deps-report--scan-file file symbol-re macros funcs) + (when (and func-dep (not runtime-req)) + (push (list file func-toks) runtime-missing)) + (when (and macro-dep (not eval-req-present)) + (push (list file macro-toks) compile-missing)) + (when (and (not func-dep) (not macro-dep) + (or runtime-req eval-req-present)) + (push file require-unneeded)) + (let ((skip + (or (and (not macro-dep) (not func-dep) + (string= require-kind "no")) + (and func-dep (string= require-kind "runtime")) + (and macro-dep (not func-dep) + (string= require-kind "compile-time"))))) + (unless skip + (insert (format "| %s | %s | %s | %s |\n" + file + (if macro-dep "yes" "no") + (if func-dep "yes" "no") + require-kind))))))) + (org-table-align) + (insert "** runtime dependency missing require\n") + (dolist (entry (sort runtime-missing (lambda (a b) (string< (car a) (car b))))) + (insert (format "- %s (%s)\n" + (car entry) + (mapconcat (lambda (s) (format "~%s~" s)) (cadr entry) ", ")))) + (insert "\n** compile-time dependency missing eval-when-compile require\n") + (dolist (entry (sort compile-missing (lambda (a b) (string< (car a) (car b))))) + (insert (format "- %s (%s)\n" + (car entry) + (mapconcat (lambda (s) (format "~%s~" s)) (cadr entry) ", ")))) + (insert "\n** no dependency but require present\n") + (dolist (f (sort require-unneeded #'string<)) + (insert (format "- %s\n" f))) + (insert "\n* Summary\n") + (insert (format "- Total files audited: %d\n" (length files))) + (insert (format "- Redundant requires found: %d\n" (length require-unneeded))) + (insert (format "- Missing runtime requires: %d\n" (length runtime-missing))) + (insert (format "- Missing compile-time requires: %d\n" (length compile-missing)))) + (princ (buffer-string)))))) + +(cl-lib-deps-report--main command-line-args-left) + +;;; cl-lib-deps-report.el ends here diff --git a/admin/download-android-deps.sh b/admin/download-android-deps.sh index e40392381d7..f2578e284d9 100644 --- a/admin/download-android-deps.sh +++ b/admin/download-android-deps.sh @@ -61,7 +61,7 @@ download_tarball () # 1c8f3b0cbad474da0ab09018c4ecf2119ac4a52d pixman-0.38.4-emacs.tar.gz # b687c8439d51634d921674dd009645e24873ca36 rsvg-2.40.21-emacs.tar.gz # eda251614598aacb06f5984a0a280833de456b29 tiff-4.5.1-emacs.tar.gz -# c00d0ea9c6e848f5cce350cb3ed742024f2bdb8b tree-sitter-0.20.7-emacs.tar.gz +# 9d032de89c874354c22d304f7e968f4ca6de8c0a tree-sitter-0.26.3-emacs.tar.gz download_tarball "giflib-5.2.1-emacs.tar.gz" "giflib-5.2.1" \ "a407c568961d729bb2d0175a34e0d4ed4a269978" @@ -90,8 +90,8 @@ download_tarball "libtasn1-4.19.0-emacs.tar.gz" "libtasn1-4.19.0" \ "fdc827211075d9b70a8ba6ceffa02eb48d6741e9" download_tarball "libselinux-3.6-emacs.tar.gz" "libselinux-3.6" \ "8361966e19fe25ae987b08799f1442393ae6366b" -download_tarball "tree-sitter-0.20.7-emacs.tar.gz" "tree-sitter-0.20.7" \ - "c00d0ea9c6e848f5cce350cb3ed742024f2bdb8b" +download_tarball "tree-sitter-0.26.3-emacs.tar.gz" "tree-sitter-0.26.3" \ + "9d032de89c874354c22d304f7e968f4ca6de8c0a" download_tarball "harfbuzz-7.1.0-emacs.tar.gz" "harfbuzz-7.1.0" \ "22dc71d503ab2eb263dc8411de9da1db144520f5" download_tarball "tiff-4.5.1-emacs.tar.gz" "tiff-4.5.1" \ diff --git a/admin/notes/elpa b/admin/notes/elpa deleted file mode 100644 index afcda71d1dd..00000000000 --- a/admin/notes/elpa +++ /dev/null @@ -1,35 +0,0 @@ -NOTES ON THE EMACS PACKAGE ARCHIVE - -The GNU Emacs package archive, at elpa.gnu.org, is managed using a Git -repository named "elpa", hosted on Savannah. To check it out: - - git clone https://git.savannah.gnu.org/git/emacs/elpa - cd elpa - make setup - -That leaves the elpa/packages directory empty; you must check out the -ones you want. - -If you wish to check out all the packages into the packages directory, -you can run the command: - - make worktrees - -You can check out a specific package into the packages -directory with: - - make packages/ - - -Changes to this repository propagate to elpa.gnu.org via a -"deployment" script run daily. This script generates the content -visible at https://elpa.gnu.org/packages. - -A new package is released as soon as the "version number" of that -package is changed. So you can use 'elpa' to work on a package -without fear of releasing those changes prematurely. And once the -code is ready, just bump the version number to make a new release of -the package. - -It is easy to use the elpa branch to deploy a "local" copy of the -package archive. For details, see the README file in the elpa branch. diff --git a/admin/notes/elpa.md b/admin/notes/elpa.md new file mode 100644 index 00000000000..791f0dec677 --- /dev/null +++ b/admin/notes/elpa.md @@ -0,0 +1,43 @@ +# NOTES ON THE EMACS PACKAGE ARCHIVE + +The Emacs package archives at `elpa.gnu.org` (GNU ELPA and NonGNU ELPA) +are managed using two Git repositories named `gnu.git` and `nongnu.git` +hosted in the `elpa` group on Savannah. +To check them out: + + git clone https://git.savannah.gnu.org/git/elpa/gnu.git + cd gnu + make setup + +resp. + + git clone https://git.savannah.gnu.org/git/elpa/nongnu.git + cd nongnu + make setup + +That leaves the `(non)gnu/packages` directory empty; you must check out the +ones you want. + +If you wish to check out all the packages into the packages directory, +you can run the command: + + make worktrees + +You can check out a specific package into the packages +directory with: + + make packages/ + +Changes to this repository propagate to `elpa.gnu.org` via a +"deployment" script run daily. This script generates the content +visible at https://elpa.gnu.org/packages and https://elpa.nongnu.org/nongnu + +A new package is released as soon as the "version number" of that +package is changed (as found in the `;; Version:` header of the main +ELisp file of the package). So you can use `elpa/(non)gnu.git` to work +on a package without fear of releasing those changes prematurely. +And once the code is ready, just bump the version number to make a new +release of the package. + +It is easy to use these repositories to deploy a "local" copy of the +package archive. For details, see the README file after cloning them. diff --git a/admin/tree-sitter/treesit-admin.el b/admin/tree-sitter/treesit-admin.el index c15768a9c0d..5e78f930443 100644 --- a/admin/tree-sitter/treesit-admin.el +++ b/admin/tree-sitter/treesit-admin.el @@ -138,14 +138,12 @@ This is done by `require'ing all of the features that extend it." (lambda (source) (cond ((or (memq :revision source) (memq :commit source)) - (when (memq :revision source) - (let ((unversioned-source (copy-sequence source))) - (setcar (cdr (memq :revision unversioned-source)) nil) - unversioned-source)) - (when (memq :commit source) - (let ((unversioned-source (copy-sequence source))) - (setcar (cdr (memq :commit unversioned-source)) nil) - unversioned-source))) + (let ((unversioned-source (copy-sequence source))) + (when (memq :revision source) + (setcar (cdr (memq :revision unversioned-source)) nil)) + (when (memq :commit source) + (setcar (cdr (memq :commit unversioned-source)) nil)) + unversioned-source)) ((nthcdr 2 source) (let ((unversioned-source (copy-sequence source))) (setcar (nthcdr 2 unversioned-source) nil) diff --git a/build-aux/config.guess b/build-aux/config.guess index f4a333427ca..a9d01fde461 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess @@ -1,6 +1,6 @@ #! /bin/sh # Attempt to guess a canonical system name. -# Copyright 1992-2026 Free Software Foundation, Inc. +# Copyright 1992-2025 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale @@ -60,7 +60,7 @@ version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright 1992-2026 Free Software Foundation, Inc. +Copyright 1992-2025 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." diff --git a/build-aux/config.sub b/build-aux/config.sub index b764eb80841..3d35cde174d 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub @@ -1,6 +1,6 @@ #! /bin/sh # Configuration validation subroutine script. -# Copyright 1992-2026 Free Software Foundation, Inc. +# Copyright 1992-2025 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268,SC2162 # see below for rationale @@ -76,7 +76,7 @@ Report bugs and patches to ." version="\ GNU config.sub ($timestamp) -Copyright 1992-2026 Free Software Foundation, Inc. +Copyright 1992-2025 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." diff --git a/configure.ac b/configure.ac index d8a421bbd75..8e15cbc966b 100644 --- a/configure.ac +++ b/configure.ac @@ -1819,6 +1819,7 @@ AS_IF([test $gl_gcc_warnings = no], nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations nw="$nw -Wbad-function-cast" # These casts are no worse than others. + nw="$nw -Wzero-as-null-pointer-constant" # Emacs is not yet C2y-safe. # Emacs doesn't care about shadowing; see # . @@ -2901,6 +2902,11 @@ Mac OS X 12.x or later. [Define to use native OS APIs for images.]) NATIVE_IMAGE_API="yes (ns)" fi + + if test "${NS_IMPL_GNUSTEP}" = yes; then + AC_CHECK_DECLS([NSImageNameCaution], [], [], + [[#import ]]) + fi fi AC_SUBST([LIBS_GNUSTEP]) @@ -3605,21 +3611,25 @@ if test "${with_webp}" != "no"; then || test "${HAVE_BE_APP}" = "yes" || test "${HAVE_PGTK}" = "yes" \ || test "${REALLY_ANDROID}" = "yes"; then WEBP_REQUIRED=0.6.0 - WEBP_MODULE="libwebpdemux >= $WEBP_REQUIRED" + # Definitions from webp/decode.h are in libwebp, and those from + # webp/demux.h in libwebpdemux, which depends on libwebp. + WEBP_MODULE="libwebpdemux >= $WEBP_REQUIRED libwebp >= $WEBP_REQUIRED" EMACS_CHECK_MODULES([WEBP], [$WEBP_MODULE]) - # WebPGetInfo is sometimes not present inside libwebpdemux, so - # if it does not link, also check for libwebpdecoder. + # If for some reason we still don't have functions from + # webp/decode.h, try libwebpdecoder as well, which is the + # decoder-only subset of libwebp (bug#61988, bug#66221). OLD_CFLAGS=$CFLAGS OLD_LIBS=$LIBS CFLAGS="$CFLAGS $WEBP_CFLAGS" - LIBS="$LIBS $WEBP_LIBS" + LIBS="$WEBP_LIBS $LIBS" AS_IF([test "$REALLY_ANDROID" != "yes"], [ - AC_CHECK_FUNC([WebPGetInfo], [], - [WEBP_MODULE="$WEBP_MODULE libwebpdecoder >= $WEBP_REQUIRED" + AC_CHECK_FUNC([WebPDecodeRGBA], [], + [WEBP_MODULE="libwebpdemux >= $WEBP_REQUIRED" + WEBP_MODULE="$WEBP_MODULE libwebpdecoder >= $WEBP_REQUIRED" HAVE_WEBP=no AS_UNSET([WEBP_LIBS]) AS_UNSET([WEBP_CFLAGS]) @@ -4074,39 +4084,15 @@ TREE_SITTER_OBJ= NEED_DYNLIB=no if test "${with_tree_sitter}" != "no"; then - dnl Tree-sitter 0.20.2 added support to change the malloc it uses - dnl at runtime, we need that feature. However, tree-sitter's - dnl Makefile has problems, until that's fixed, all tree-sitter - dnl libraries distributed are versioned 0.6.3. We try to - dnl accept a tree-sitter library that has incorrect version as long - dnl as it supports changing malloc. - EMACS_CHECK_MODULES([TREE_SITTER], [tree-sitter >= 0.20.2], + dnl Tree-sitter 0.20.10 added ts_tree_cursor_goto_previous_sibling, we + dnl need it for a more efficient implementation for traversing the + dnl parse tree backwards (bug#80108). + EMACS_CHECK_MODULES([TREE_SITTER], [tree-sitter >= 0.20.10], [HAVE_TREE_SITTER=yes], [HAVE_TREE_SITTER=no]) if test "${HAVE_TREE_SITTER}" = yes; then AC_DEFINE(HAVE_TREE_SITTER, 1, [Define if using tree-sitter.]) NEED_DYNLIB=yes - else - EMACS_CHECK_MODULES([TREE_SITTER], [tree-sitter >= 0.6.3], - [HAVE_TREE_SITTER=yes], [HAVE_TREE_SITTER=no]) - if test "${HAVE_TREE_SITTER}" = yes; then - OLD_CFLAGS=$CFLAGS - OLD_LIBS=$LIBS - CFLAGS="$CFLAGS $TREE_SITTER_CFLAGS" - LIBS="$TREE_SITTER_LIBS $LIBS" - AC_CHECK_FUNCS([ts_set_allocator]) - CFLAGS=$OLD_CFLAGS - LIBS=$OLD_LIBS - if test "$ac_cv_func_ts_set_allocator" = yes; then - AC_DEFINE(HAVE_TREE_SITTER, 1, [Define if using tree-sitter.]) - NEED_DYNLIB=yes - else - AC_MSG_ERROR([Tree-sitter library exists but its version is too old]); - TREE_SITTER_CFLAGS= - TREE_SITTER_LIBS= - fi - fi fi - # Windows loads tree-sitter dynamically if test "${opsys}" = "mingw32"; then TREE_SITTER_LIBS= @@ -7236,6 +7222,9 @@ AC_SUBST([ns_appsrc]) AC_SUBST([GNU_OBJC_CFLAGS]) AC_SUBST([OTHER_FILES]) +AS_IF([test $prefix = "NONE"], [_prefix=/usr/local], [_prefix=$prefix]) +AC_DEFINE_UNQUOTED([BINDIR], ["${_prefix}/bin/"], [Executables directory.]) + if test -n "${term_header}"; then AC_DEFINE_UNQUOTED([TERM_HEADER], ["${term_header}"], [Define to the header for the built-in window system.]) diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index e90fdce7598..2fd3ccc6d87 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi @@ -64,6 +64,12 @@ named @file{*compilation*}. The current buffer's default directory is used as the working directory for the execution of the command, so by default compilation takes place in that directory. + When invoked with a prefix argument, the @file{*compilation*} buffer +is using Comint mode as its major mode (@pxref{Shell Mode}). By default +Comint mode has the nice property of looking for any credential prompts +in its contents and make Emacs asks for a password if this happens. +This is useful should the compilation command need such a credential. + @vindex compile-command The default compilation command is @samp{make -k}, which is usually correct for programs compiled using the @command{make} utility (the diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 05a25323543..dde6cc4f1b6 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -2048,20 +2048,41 @@ variable @code{visible-cursor} is @code{nil} when Emacs starts or resumes, it uses the normal cursor. @vindex cursor-type - On a graphical display, many more properties of the text cursor can -be altered. To customize its color, change the @code{:background} -attribute of the face named @code{cursor} (@pxref{Face -Customization}). (The other attributes of this face have no effect; -the text shown under the cursor is drawn using the frame's background -color.) To change its shape, customize the buffer-local variable -@code{cursor-type}; possible values are @code{box} (the default), -@code{(box . @var{size})} (box cursor becoming a hollow box under -masked images larger than @var{size} pixels in either dimension), -@code{hollow} (a hollow box), @code{bar} (a vertical bar), @code{(bar -. @var{n})} (a vertical bar @var{n} pixels wide), @code{hbar} (a -horizontal bar), @code{(hbar . @var{n})} (a horizontal bar @var{n} + On a graphical display and many Xterm-compatible text terminals, the +color and shape of the text cursor can be altered. To customize its +color, change the @code{:background} attribute of the face named +@code{cursor} (@pxref{Face Customization}). (The other attributes of +this face have no effect; the text shown under the cursor is drawn using +the frame's background color.) To change its shape, customize the +buffer-local variable @code{cursor-type}; possible values are @code{box} +(the default), @code{(box . @var{size})} (box cursor becoming a hollow +box under masked images larger than @var{size} pixels in either +dimension), @code{hollow} (a hollow box), @code{bar} (a vertical bar), +@code{(bar . @var{n})} (a vertical bar @var{n} pixels wide), @code{hbar} +(a horizontal bar), @code{(hbar . @var{n})} (a horizontal bar @var{n} pixels tall), or @code{nil} (no cursor at all). +@vindex xterm-update-cursor + On Xterm-compatible text terminals cursor customization is controlled +by the user option @code{xterm-update-cursor}. Valid values are +@code{t} to update the cursor's color and shape, @code{type} to update +the cursor's shape only, @code{color} to update the cursor's color only, +and @code{nil} to not update the cursor's appearance. Text terminals +can not display a hollow box and instead use a filled box. Similarly, +all text terminals ignore the pixel sizes for @code{bar} and +@code{hbar}. + +@findex hl-line-mode +@findex global-hl-line-mode +@cindex highlight current line + To make the cursor even more visible, you can use HL Line mode, a +minor mode that highlights the line containing point. Use @kbd{M-x +hl-line-mode} to enable or disable it in the current buffer. @kbd{M-x +global-hl-line-mode} enables or disables the same mode globally. + + The remaining controls only work on graphical displays where Emacs can +fully control the way the cursor appears. + @findex blink-cursor-mode @cindex cursor, blinking @cindex blinking cursor @@ -2105,14 +2126,6 @@ non-blinking hollow box. (For a bar cursor, it instead appears as a thinner bar.) To turn off cursors in non-selected windows, change the variable @code{cursor-in-non-selected-windows} to @code{nil}. -@findex hl-line-mode -@findex global-hl-line-mode -@cindex highlight current line - To make the cursor even more visible, you can use HL Line mode, a -minor mode that highlights the line containing point. Use @kbd{M-x -hl-line-mode} to enable or disable it in the current buffer. @kbd{M-x -global-hl-line-mode} enables or disables the same mode globally. - @node Line Truncation @section Line Truncation @@ -2338,6 +2351,16 @@ of lines which are a multiple of certain numbers. Customize @code{display-line-numbers-minor-tick} respectively to set those numbers. +@vindex line-spacing + The variable @code{line-spacing} controls the vertical spacing between +lines. It can be set to an integer (specifying pixels) or a float +(specifying spacing relative to the default frame font height). You can +also set this variable to a cons cell of integers or floats, such as +@code{(@var{top} . @var{bottom})}. When set to a cons cell, the spacing +is distributed above and below the line, allowing for text to be +vertically centered within the line height. See also @ref{Line Height,,, +elisp, The Emacs Lisp Reference Manual}. + @vindex visible-bell If the variable @code{visible-bell} is non-@code{nil}, Emacs attempts to make the whole screen blink when it would normally make an audible bell diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index a7f5751ca4a..567c1492518 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -1000,17 +1000,17 @@ File Shadowing is not available on MS Windows. @cindex modification dates @cindex last modified time -You can arrange to have a time stamp in a file be updated -automatically each time you save the file. -(A time stamp may also be called a date stamp or a last modified time.) Having a time stamp in the text of a file ensures that the time the file was written will be preserved even if the file is copied or transformed in a way that loses the file system's modification time. +A time stamp may also be called a date stamp or a last modified time. +You can arrange to have a time stamp in a file update +automatically each time you save the file. There are two steps to setting up automatic time stamping. -First, the file needs a time stamp template -somewhere in the first eight lines. -The template looks like this: +First, the file needs a time stamp template. +By default, the template occurs somewhere in the first eight lines +and looks like this: @example Time-stamp: <> @@ -1026,10 +1026,9 @@ Time-stamp: " " @findex time-stamp With that template in place, you can update the current buffer's time stamp once immediately with the command @kbd{M-x time-stamp}. -Emacs will check for a template; if a template is found, +The Emacs editor will check for a template; if a template is found, Emacs will write the current date, time, author, and/or -other info between the brackets or quotes. -(If the buffer has no template, @code{time-stamp} does nothing.) +other info between the angle brackets or quotes. After the first time stamp, the line might look like this: @example @@ -1039,13 +1038,25 @@ Time-stamp: <1993-07-06 11:05:14 terryg> Second, configure your Emacs to run @code{time-stamp} whenever it saves a file, by adding @code{time-stamp} to @code{before-save-hook} (@pxref{Hooks}). -You can either use @kbd{M-x customize-option} (@pxref{Specific -Customization}) to customize the option @code{before-save-hook}, -or you can edit your init file adding this line: +There are two ways to do this: you can +@itemize +@item +use @kbd{M-x customize-option} (@pxref{Specific Customization}) +to customize the option @code{before-save-hook}, or + +@item +edit your initialization file (@pxref{Init File}), +adding this line: @example (add-hook 'before-save-hook 'time-stamp) @end example +@end itemize + +Now every time you save a file, Emacs will look for a time stamp. +If the buffer has no template, @code{time-stamp} does nothing; +any file that does have a time stamp will have it kept up to date +automatically. @menu * Time Stamp Customization:: How to customize with time-stamp-pattern. @@ -1064,14 +1075,17 @@ identify a template and where in the file to look for the pattern using @code{time-stamp-pattern}; for details, see the variable's built-in documentation (with @kbd{C-h v}, @pxref{Name Help}). -As a simple example, if this line occurs near the top of a file: +As a simple example, suppose you want a manuscript to say the year +and city of publication. +You would like the year updated as you make revisions. +You could have this line near the top of a file: @example publishing_year_and_city = "Published nnnn in Boston, Mass."; @end example @noindent -then the following comment at the end of the same file tells +and the following comment at the end of the same file to tell @code{time-stamp} how to identify and update that custom template: @example @@ -1084,12 +1098,24 @@ then the following comment at the end of the same file tells This pattern says that the text before the start of the time stamp is ``Published '', and the text after the end is `` in Boston''. -If @code{time-stamp} finds both in one of the first eight lines, -what is between will be replaced by the current year, as requested by -the @code{%Y} format. +If @code{time-stamp} finds both the start and the end in one of the +first eight lines, +what is between will be updated as specified by the format, @code{%Y} in +this example. Since @code{%Y} requests the year, the result might look +like this: -After any change to file-local variables, -type @kbd{M-x normal-mode} to re-read them. +@example +publishing_year_and_city = "Published 2025 in Boston, Mass."; +@end example + +By specifying a format of @code{%Y}, we get exactly the year +substituted; other parts of the default format (day, time and +author) are not part of this example pattern and so do not appear in the +result. + +After changing the value of @code{time-stamp-pattern} +(or any file-local variable), +type @kbd{M-x normal-mode} so that Emacs notices. Here is another example, with the time stamp inserted into the last paragraph of an HTML document. @@ -1126,7 +1152,7 @@ for specifics on formatting and other variables that affect it. If you are working on a file with multiple authors, and you cannot be sure the other authors have enabled time-stamping globally in -their Emacs init files, you can force it to be enabled for a +their Emacs initialization files, you can force it to be enabled for a particular file by adding @code{time-stamp} to that buffer's @code{before-save-hook} in that file's local variables list. To extend one of the previous examples: @@ -1140,11 +1166,13 @@ To extend one of the previous examples: @end group @end example -@noindent Although this example shows them both set together, you can use @code{eval} without also setting @code{time-stamp-pattern} if you like the default pattern. +The extra arguments to @code{add-hook} used here, @code{nil} and @code{t}, +are necessary to have the added hook affect only this buffer. + @node Reverting @section Reverting a Buffer @findex revert-buffer @@ -2743,10 +2771,16 @@ are shown in the Customize buffer. Remember to select @samp{Save for future sessions} if you want to use the same filesets in future Emacs sessions. +@findex filesets-open +@findex filesets-close +@findex filesets-run-cmd +@vindex filesets-commands You can use the command @kbd{M-x filesets-open} to visit all the files in a fileset, and @kbd{M-x filesets-close} to close them. Use -@kbd{M-x filesets-run-cmd} to run a shell command on all the files in -a fileset. These commands are also available from the @samp{Filesets} +@kbd{M-x filesets-run-cmd} to run a command (such as +@code{multi-isearch-files} or @command{grep}) on all the files in +a fileset. These commands, which are specified in +@code{filesets-commands}, are also available from the @samp{Filesets} menu, where each existing fileset is represented by a submenu. @xref{Version Control}, for a different concept of filesets: diff --git a/doc/emacs/fixit.texi b/doc/emacs/fixit.texi index 131fcd1d6ae..36a27a78dda 100644 --- a/doc/emacs/fixit.texi +++ b/doc/emacs/fixit.texi @@ -418,6 +418,20 @@ Suspend Emacs or iconify the selected frame. Show the list of options. @end table +@vindex ispell-save-corrections-as-abbrevs + You can have Ispell remember your spelling corrections so that they +are applied automatically when Abbrev mode is enabled (@pxref{Abbrevs}). +If you customize @code{ispell-save-corrections-as-abbrevs} to a non-nil +value, then each time you correct a misspelled word, Emacs saves the +correction as a global abbrev. Then, whenever you type the misspelling +and then a word-separator (@key{SPC}, comma, etc.) in a buffer with +Abbrev mode enabled, Emacs expands the misspelling to its correction. +You can override this and disable saving a particular correction by +supplying a @kbd{C-u} prefix argument when selecting a replacement. If +@code{ispell-save-corrections-as-abbrevs} has its default value of nil, +the meaning of a prefix argument is inverted, in that typing @kbd{C-u} +before selecting a replacement @emph{does} save a global abbrev. + Use the command @kbd{M-@key{TAB}} (@code{completion-at-point}) to complete the word at point. Insert the beginning of a word, and then type @kbd{M-@key{TAB}} to select from a list of completions. (If your diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi index 657356cd825..c16e94df5aa 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -422,8 +422,9 @@ search for noninteractive functions too. Search for functions and variables. Both interactive functions (commands) and noninteractive functions can be found by this. -@item M-x apropos-user-option +@kindex C-h u @findex apropos-user-option +@item C-h u Search for user-customizable variables. With a prefix argument, search for non-customizable variables too. diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 37a475be668..aebe31b478e 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -1066,12 +1066,12 @@ Display the change history for the current repository on another branch @item C-x v I Display log entries for the changes that a ``pull'' operation will -retrieve (@code{vc-log-incoming}). +retrieve (@code{vc-root-log-incoming}). @vindex vc-use-incoming-outgoing-prefixes If you customize @code{vc-use-incoming-outgoing-prefixes} to non-@code{nil}, @kbd{C-x v I} becomes a prefix key, and -@code{vc-log-incoming} becomes bound to @kbd{C-x v I L}. +@code{vc-root-log-incoming} becomes bound to @kbd{C-x v I L}. @item M-x vc-root-diff-incoming Display a diff of all changes that a pull operation will retrieve. @@ -1088,11 +1088,11 @@ non-@code{nil}, this command becomes available on @kbd{C-x v I =}. @item C-x v O Display log entries for the changes that will be sent by the next -``push'' operation (@code{vc-log-outgoing}). +``push'' operation (@code{vc-root-log-outgoing}). If you customize @code{vc-use-incoming-outgoing-prefixes} to non-@code{nil}, @kbd{C-x v O} becomes a prefix key, and -@code{vc-log-outgoing} becomes bound to @kbd{C-x v O L}. +@code{vc-root-log-outgoing} becomes bound to @kbd{C-x v O L}. @item M-x vc-root-diff-outgoing Display a diff of all changes that will be sent by the next push @@ -1188,31 +1188,31 @@ or the remote branch references supported by Git. @kindex C-x v I @kindex C-x v O -@findex vc-log-incoming -@findex vc-log-outgoing +@findex vc-root-log-incoming +@findex vc-root-log-outgoing On a decentralized version control system, the @kbd{C-x v I} -(@code{vc-log-incoming}) command displays a log buffer showing the +(@code{vc-root-log-incoming}) command displays a log buffer showing the changes that will be applied the next time you run the version control system's pull command to get new revisions from another remote location (@pxref{Pulling / Pushing}). This other remote location is the default one from which changes are pulled, as defined by the version control -system; with a prefix argument, @code{vc-log-incoming} prompts for a -particular remote location. Similarly, @kbd{C-x v O} -(@code{vc-log-outgoing}) shows the changes that will be sent to another -remote location, the next time you run the push command; with a prefix -argument, it prompts for a particular destination that in case of some -version control system can be a branch name. +system; with a prefix argument, @code{vc-root-log-incoming} prompts for +a particular remote location. Similarly, @kbd{C-x v O} +(@code{vc-root-log-outgoing}) shows the changes that will be sent to +another remote location, the next time you run the push command; with a +prefix argument, it prompts for a particular destination that in case of +some version control system can be a branch name. @findex vc-root-diff-incoming @findex vc-root-diff-outgoing The closely related commands @code{vc-root-diff-incoming} and @code{vc-root-diff-outgoing} are the diff analogues of -@code{vc-log-incoming} and @code{vc-log-outgoing}. These display diff -buffers reporting the changes that would be pulled or pushed. You can -use a prefix argument here too to specify a particular remote location. -@code{vc-root-diff-outgoing} is useful as a way to preview your push and -quickly check that all and only the changes you intended to include were -committed and will be pushed. +@code{vc-root-log-incoming} and @code{vc-root-log-outgoing}. These +display diff buffers reporting the changes that would be pulled or +pushed. You can use a prefix argument here too to specify a particular +remote location. @code{vc-root-diff-outgoing} is useful as a way to +preview your push and quickly check that all and only the changes you +intended to include were committed and will be pushed. @findex vc-diff-incoming @findex vc-diff-outgoing @@ -1360,6 +1360,7 @@ also prompt for a specific VCS shell command to run for this purpose. @table @kbd @item C-x v u +@item C-x v @@ Revert the work file(s) in the current VC fileset to the last revision (@code{vc-revert}). @@ -1374,24 +1375,25 @@ Delete an unpushed commit from the revision history. @end table @kindex C-x v u +@kindex C-x v @@ @findex vc-revert @vindex vc-revert-show-diff - If you want to discard all the changes you have made to the current -VC fileset, type @kbd{C-x v u} (@code{vc-revert}). This will ask you -for confirmation before discarding the changes. If you agree, the -fileset is reverted. + If you want to discard all the changes you have made to the current VC +fileset, type @kbd{C-x v u} or @kbd{C-x v @@} (@code{vc-revert}). This +will ask you for confirmation before discarding the changes. If you +agree, the fileset is reverted. If @code{vc-revert-show-diff} is non-@code{nil}, this command will -show you a diff between the work file(s) and the revision from which -you started editing. Afterwards, the diff buffer will either be -killed (if this variable is @code{kill}), or the buffer will be buried -(any other non-@code{nil} value). If you don't want @kbd{C-x v u} to -show a diff, set this variable to @code{nil} (you can still view the -diff directly with @kbd{C-x v =}; @pxref{Old Revisions}). +show you a diff between the work file(s) and the revision from which you +started editing. Afterwards, the diff buffer will either be killed (if +this variable is @code{kill}), or the buffer will be buried (any other +non-@code{nil} value). If you don't want @code{vc-revert} to show you +diffs, set this variable to @code{nil} (you can still view the diff +directly with @kbd{C-x v =}; @pxref{Old Revisions}). - On locking-based version control systems, @kbd{C-x v u} leaves files -unlocked; you must lock again to resume editing. You can also use -@kbd{C-x v u} to unlock a file if you lock it and then decide not to + On locking-based version control systems, @code{vc-revert} leaves +files unlocked; you must lock again to resume editing. You can also use +@code{vc-revert} to unlock a file if you lock it and then decide not to change it. @findex vc-revert-or-delete-revision @@ -1562,8 +1564,8 @@ repository, such as the name of the backend in use and the working directory. In addition, for decentralized VCS, if you have outgoing commits (@pxref{VC Change Log}), Emacs displays a line @w{"Outgoing : N unpushed revisions"} where @var{N} is a number. You can click on this -text to execute the @code{vc-log-outgoing} command (@pxref{VC Change -Log}). +text to execute the @code{vc-root-log-outgoing} command (@pxref{VC +Change Log}). @vindex vc-dir-show-outgoing-count Emacs tries to use cached information to determine the number of @@ -1641,6 +1643,10 @@ ignore (@code{vc-dir-ignore}). For instance, if the VC is Git, it will append this file to the @file{.gitignore} file. If given a prefix, do this with all the marked files. +@item @@ +Discard all the changes you have made to the current fileset +(@code{vc-revert}). + @item q Quit the VC Directory buffer, and bury it (@code{quit-window}). @@ -1706,6 +1712,9 @@ Do an incremental regular expression search on the fileset Apart from acting on multiple files, these commands behave much like their single-buffer counterparts (@pxref{Search}). +@c Outstanding changes commands under 'T' are not mentioned because +@c these are an advanced feature documented only in vc1-xtra.texi. + The VC Directory buffer additionally defines some branch-related commands starting with the prefix @kbd{b}: @@ -1840,9 +1849,9 @@ with Git, and @kbd{hg push} with Mercurial. The default commands always push to the repository in the default location determined by the version control system from your branch configuration. -Prior to pushing, you can use @kbd{C-x v O} (@code{vc-log-outgoing}) -to view a log buffer of the changes to be sent upstream. @xref{VC -Change Log}. +Prior to pushing, you can use @kbd{C-x v O} +(@code{vc-root-log-outgoing}) to view a log buffer of the changes to be +sent upstream. @xref{VC Change Log}. @cindex bound branch (Bazaar VCS) This command is currently supported only by Bazaar, Git, and Mercurial. @@ -1876,9 +1885,9 @@ it into the current branch. With Mercurial, it calls @kbd{hg pull -u} to fetch changesets from the default remote repository and update the working directory. - Prior to pulling, you can use @kbd{C-x v I} (@code{vc-log-incoming}) -to view a log buffer of the changes to be applied. @xref{VC Change -Log}. + Prior to pulling, you can use @kbd{C-x v I} +(@code{vc-root-log-incoming}) to view a log buffer of the changes to be +applied. @xref{VC Change Log}. With a centralized version control system like CVS, @kbd{C-x v +} updates the current VC fileset from the repository. @@ -2049,7 +2058,10 @@ project. See its entry below for description and related options. If this user option is non-@code{nil}, Emacs displays the name of the current project (if any) on the mode line; clicking @kbd{mouse-1} on the project name pops up the menu with the project-related commands. -The default value is @code{nil}. +The default value is @code{nil}. If the value is @code{non-remote}, +Emacs will show the name of the project only for local files; this comes +in handy when updating the mode line for projects on remote systems is +slow due to network latencies. @end defopt @menu diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi index bd39fe550d8..7936712d31c 100644 --- a/doc/emacs/mini.texi +++ b/doc/emacs/mini.texi @@ -500,7 +500,7 @@ completion buffer and delete the window showing it @vindex minibuffer-visible-completions If the variable @code{minibuffer-visible-completions} is customized to -a non-@code{nil} value, it changes the commands bound to the arrow keys: +the value @code{t}, it changes the commands bound to the arrow keys: instead of moving in the minibuffer, they move between completion candidates, like meta-arrow keys do by default (but note that, just as when the window showing the completion list is selected, here too, @@ -509,7 +509,11 @@ when the window showing the completion list is selected, here too, regardless of the completion list format). Similarly, @kbd{@key{RET}} selects the current candidate, like @kbd{M-@key{RET}} does normally. @code{C-g} hides the completion window, but leaves the minibuffer -active, so you can continue typing at the prompt. +active, so you can continue typing at the prompt. If the value of this +variable is @code{up-down}, only the @kbd{@key{UP}} and @kbd{@key{DOWN}} +arrow keys move point between completion candidates, while +@kbd{@key{RIGHT}} and @kbd{@key{LEFT}} move point in the minibuffer +window. @node Completion Exit @subsection Completion Exit diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index 2de3d25e7f9..e6432678c62 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -402,6 +402,17 @@ package is somehow unavailable, Emacs signals an error and stops installation.) A package's requirements list is shown in its help buffer. +@cindex review +@vindex package-review-policy + If you are cautious when it comes to installing and upgrading packages +from package archives, you can configure @code{package-review-policy} to +give you a chance to review packages before installing them. By setting +the user option to @code{t}, you get to review all packages (including +dependencies), during which you can browse the source code, examine a +diff between the downloaded package and a previous installation or read +a changelog. You can also configure @code{package-review-policy} to +selectively trust or distrust specific packages or archives. + @cindex GNU ELPA @cindex NonGNU ELPA By default, Emacs downloads packages from two archives: diff --git a/doc/emacs/vc1-xtra.texi b/doc/emacs/vc1-xtra.texi index 8f9d3bf34e5..2bb695025db 100644 --- a/doc/emacs/vc1-xtra.texi +++ b/doc/emacs/vc1-xtra.texi @@ -298,22 +298,31 @@ yet merged into the target branch. @cindex outstanding changes @table @kbd -@item C-x v o = +@item C-x v T = Display diffs of changes to the VC fileset since the merge base of this branch and its upstream counterpart (@code{vc-diff-outgoing-base}). -@item C-x v o D -Display all changes since the merge base of this branch and its upstream -counterpart (@code{vc-root-diff-outgoing-base}). +@item C-x v T D +Display a diff of all changes since the merge base of this branch and +its upstream counterpart (@code{vc-root-diff-outgoing-base}). + +@item C-x v T l +Display log messages for changes to the VC fileset since the merge base +of this branch and its upstream counterpart +(@code{vc-log-outgoing-base}). + +@item C-x v T L +Display log messages for all changes since the merge base of this branch +and its upstream counterpart (@code{vc-root-log-outgoing-base}). @end table For decentralized version control systems (@pxref{VCS Repositories}), -these commands provide specialized versions of @kbd{C-x v M D} (see -@pxref{Merge Bases}) which also take into account the state of upstream -repositories. These commands are useful both when working on a single -branch and when developing features on a separate branch -(@pxref{Branches}). These two cases involve using the commands -differently, and so we will describe them separately. +these commands provide specialized versions of @kbd{C-x v M L} and +@w{@kbd{C-x v M D}} (see @pxref{Merge Bases}) which also take into +account the state of upstream repositories. These commands are useful +both when working on a single branch and when developing features on a +separate branch (@pxref{Branches}). These two cases are conceptually +distinct, and so we will introduce them separately. First, consider working on a single branch. @dfn{Outstanding changes} are those which you haven't yet pushed upstream. This includes both @@ -321,17 +330,17 @@ unpushed commits and uncommitted changes in your working tree. In many cases the reason these changes are not pushed yet is that they are not finished: the changes committed so far don't make sense in isolation. -@kindex C-x v o = +@kindex C-x v T = @findex vc-diff-outgoing-base -@kindex C-x v o D +@kindex C-x v T D @findex vc-root-diff-outgoing-base -Type @kbd{C-x v o D} (@code{vc-root-diff-outgoing-base}) to display a +Type @kbd{C-x v T D} (@code{vc-root-diff-outgoing-base}) to display a summary of all these changes, committed and uncommitted. This summary is in the form of a diff of what committing and pushing (@pxref{Pulling / Pushing}) all these changes would do to the upstream repository. You -can use @kbd{C-x v o =} (@code{vc-diff-outgoing-base}) instead to limit +can use @kbd{C-x v T =} (@code{vc-diff-outgoing-base}) instead to limit the display of changes to the current VC fileset. (The difference -between @w{@kbd{C-x v o D}} and @w{@kbd{C-x v o =}} is like the +between @w{@kbd{C-x v T D}} and @w{@kbd{C-x v T =}} is like the difference between @kbd{C-x v D} and @kbd{C-x v =} (@pxref{Old Revisions}).)@footnote{Another point of comparison is that these commands are like @w{@kbd{C-x v O =}} (@code{vc-fileset-diff-outgoing}) @@ -340,13 +349,25 @@ include uncommitted changes in the reported diffs. Like those other commands, you can use a prefix argument to specify a particular upstream location.} +@kindex C-x v T l +@findex vc-log-outgoing-base +@kindex C-x v T L +@findex vc-root-log-outgoing-base +Type @kbd{C-x v T L} (@code{vc-root-log-outgoing-base}) to display a +summary of the same changes in the form of a revision log; this does not +include uncommitted changes. You can use @kbd{C-x v T l} +(@code{vc-log-outgoing-base}) instead to limit the display of changes to +the current VC fileset. + Second, consider developing a feature on a separate branch. Call this -the @dfn{topic branch},@footnote{Topic branches are sometimes called -``feature branches''. It is also common for the term ``feature branch'' -to be reserved for a particular kind of topic branch, one that another -branch or other branches are repeatedly merged into.} and call the -branch from which the topic branch was originally created the -@dfn{trunk} or @dfn{development trunk}. +the @dfn{topic branch},@footnote{What we mean by a topic branch is any +shorter-lived branch used for work which will later be merged into a +longer-lived branch. Topic branches are sometimes called ``feature +branches''. It is also common for the term ``feature branch'' to be +reserved for a particular kind of topic branch, one that another branch +or other branches are repeatedly merged into.} and call the branch from +which the topic branch was originally created the @dfn{trunk} or +@dfn{development trunk}. In this case, outstanding changes is a more specific notion than just unpushed and uncommitted changes on the topic branch. You're not @@ -357,20 +378,106 @@ upstream repository's development trunk. That means committed changes on the topic branch that haven't yet been merged into the trunk, plus uncommitted changes. -@cindex outgoing base, version control -The @dfn{outgoing base} is the upstream location for which the changes -are destined once they are no longer outstanding. In this case, that's -the upstream version of the trunk, to which you and your collaborators -push finished work. +When the current branch is a topic branch and you type @kbd{C-x v T D}, +Emacs displays a summary of all the changes that are outstanding against +the trunk to which the current branch will be merged. This summary is +in the form of a diff of what committing and pushing all the changes, +@emph{and} subsequently merging the topic branch, would do to the trunk. +As above, you can use @kbd{C-x v T =} instead to limit the display of +changes to the current VC fileset. @kbd{C-x v T L} and @kbd{C-x v T l} +show the corresponding revision logs, excluding uncommitted changes as +above. -To display a summary of outgoing changes in this multi-branch example, -supply a prefix argument, by typing @w{@kbd{C-u C-x v o =}} or -@w{@kbd{C-u C-x v o D}}. When prompted, enter the outgoing base. -Exactly what you must supply here depends on the name of your -development trunk and the version control system in use. For example, -with Git, usually you will enter @kbd{origin/master}. We hope to -improve these commands such that no prefix argument is required in the -multi-branch case, too. +This functionality relies on Emacs correctly detecting whether the +current branch is a trunk or a topic branch, and in the latter case, +correctly determining the branch to which the topic branch will +eventually be merged. If the autodetection doesn't produce the right +results, there are several options to tweak and override it. + +@vindex vc-trunk-branch-regexps +@vindex vc-topic-branch-regexps +The variables @code{vc-trunk-branch-regexps} and +@code{vc-topic-branch-regexps} contain lists of regular expressions +matching the names of branches that should always be considered trunk +and topic branches, respectively. You can also specify prefix arguments +to @kbd{C-x v T @dots{}}. Here is a summary of how to use these +controls: + +@enumerate +@item +If the problem is that Emacs thinks your topic branch is a trunk, you +can add either its name, or a regular expression matching its name +(@pxref{Regexps}), to the @code{vc-topic-branch-regexps} variable. +There are a few special kinds of value to simplify common use cases: + +@itemize +@item +If an element contains no characters that are special in regular +expressions, then the regular expression is implictly anchored at both +ends, i.e., it matches only a branch with exactly that name. + +@item +If the first element of @code{vc-topic-branch-regexps} is the symbol +@code{not}, then the meaning of @code{vc-topic-branch-regexps} is +inverted, in that Emacs treats all branches whose names @emph{don't} +match any element of @code{vc-topic-branch-regexps} to be topic +branches. + +@item +If instead of a list of regular expressions the +@code{vc-topic-branch-regexps} variable has the special value @code{t}, +then Emacs treats as a topic branch any branch that the +@code{vc-trunk-branch-regexps} variable doesn't positively identify as a +trunk. +@end itemize + +@xref{Directory Variables}, regarding how to specify values of +@code{vc-topic-branch-regexps} and @code{vc-trunk-branch-regexps} for a +single VC repository. + +@item +If the problem is that Emacs thinks your trunk is a topic branch, you +can add either its name, or a regular expression matching its name, to +the @code{vc-trunk-branch-regexps} variable. This works just like +@code{vc-topic-branch-regexps} with the same special values we just +described. E.g., if the value of @code{vc-trunk-branch-regexps} is +@code{t}, Emacs treats as a trunk any branch that the +@code{vc-topic-branch-regexps} variable doesn't identify as a topic +branch. + +@item +Supply a double prefix argument, i.e. @w{@kbd{C-u C-u C-x v T @dots{}}}, +and Emacs will treat the current branch as a trunk, no matter what. +This is useful when you simply want to obtain a diff of all outgoing +changes (@pxref{VC Change Log}) plus uncommitted changes. + +@item +@cindex outgoing base, version control +Finally, you can take full manual control by supplying a single prefix +argument, i.e. @w{@kbd{C-u C-x v T @dots{}}}. Emacs will prompt you for +the @dfn{outgoing base}, which is the upstream location for which the +changes are destined once they are no longer outstanding. + +To treat the current branch as a trunk specify a reference to the +upstream version of the current branch, to which you and your +collaborators push finished work. To treat the current branch as a +topic branch specify a reference to the upstream version of the trunk to +which the topic branch will later be merged. + +Exactly how to specify a reference to the upstream version of a branch +depends on the version control system in use. For example, with Git, to +refer to the upstream version of a branch @var{foo}, you would supply +@kbd{origin/@var{foo}}. So if @var{foo} is the current branch then you +would enter an outgoing base of @kbd{origin/@var{foo}} to treat +@var{foo} as a trunk, or an outgoing base of @kbd{origin/@var{bar}} to +treat @var{foo} as a topic branch which will later be merged into a +trunk named @var{bar}. + +If there is a default option, it is what Emacs thinks you need to enter +in order to treat the current branch as a topic branch. If there is no +default, then entering nothing at the prompt means to treat the current +branch as a trunk. +@end enumerate @node Other Working Trees @subsubsection Multiple Working Trees for One Repository diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi index 937ea386650..8500e3b7731 100644 --- a/doc/emacs/windows.texi +++ b/doc/emacs/windows.texi @@ -519,6 +519,8 @@ selected frame, and display the buffer in that new window. @vindex split-height-threshold @vindex split-width-threshold @vindex split-window-preferred-direction +@cindex portrait frame +@cindex landscape frame The split can be either vertical or horizontal, depending on the variables @code{split-height-threshold} and @code{split-width-threshold}. These variables should have integer @@ -528,8 +530,14 @@ window's height, the split puts the new window below. Otherwise, if split puts the new window on the right. If neither condition holds, Emacs tries to split so that the new window is below---but only if the window was not split before (to avoid excessive splitting). Whether -Emacs tries first to split vertically or horizontally, is -determined by the value of @code{split-window-preferred-direction}. +Emacs tries first to split vertically or horizontally when both +conditions hold is determined by the value of +@code{split-window-preferred-direction}. Its default is @code{longest}, +which means to split vertically if the window's frame is taller than it +is wide (a @dfn{portrait} frame), and split horizontally if its wider +than it's tall (a @dfn{landscape} frame). The values @code{vertical} +and @code{horizontal} always prefer, respectively, the vertical or the +horizontal split. @item Otherwise, display the buffer in a window previously showing it. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 892ed241cfe..4211b435db5 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -486,7 +486,7 @@ A convenient way to do this is to use a @dfn{progress reporter}. (progress-reporter-done progress-reporter)) @end smallexample -@defun make-progress-reporter message &optional min-value max-value current-value min-change min-time +@defun make-progress-reporter message &optional min-value max-value current-value min-change min-time context This function creates and returns a progress reporter object, which you will use as an argument for the other functions listed below. The idea is to precompute as much data as possible to make progress @@ -513,13 +513,19 @@ If @var{min-value} and @var{max-value} are numbers, you can give the argument @var{current-value} a numerical value specifying the initial progress; if omitted, this defaults to @var{min-value}. -The remaining arguments control the rate of echo area updates. The -progress reporter will wait for at least @var{min-change} more -percents of the operation to be completed before printing next -message; the default is one percent. @var{min-time} specifies the -minimum time in seconds to pass between successive prints; the default -is 0.2 seconds. (On some operating systems, the progress reporter may -handle fractions of seconds with varying precision). +The arguments @var{min-change} and @var{min-time} control the rate of +echo area updates. The progress reporter will wait for at least +@var{min-change} more percents of the operation to be completed before +printing next message; the default is one percent. @var{min-time} +specifies the minimum time in seconds to pass between successive prints; +the default is 0.2 seconds. (On some operating systems, the progress +reporter may handle fractions of seconds with varying precision). + +If @var{context} is the symbol @code{async}, it announces that the updates +will occur asynchronously. Backends can use that info to prevent the +progress updates from interfering with other data. For example, the +backend that displays the progress in the echo area will not display +those async updates when the echo area is in use. This function calls @code{progress-reporter-update}, so the first message is printed immediately. @@ -2576,10 +2582,13 @@ the spacing relative to the frame's default line height. @vindex line-spacing You can specify the line spacing for all lines in a buffer via the -buffer-local @code{line-spacing} variable. An integer specifies -the number of pixels put below lines. A floating-point number -specifies the spacing relative to the default frame line height. This -overrides line spacings specified for the frame. +buffer-local @code{line-spacing} variable. An integer specifies the +number of pixels put below lines. A floating-point number specifies the +spacing relative to the default frame line height. A cons cell of +integers or floating-point numbers specifies the spacing put above and +below the line, allowing for vertically centering text. This overrides +line spacings specified for the frame. + @kindex line-spacing @r{(text property)} Finally, a newline can have a @code{line-spacing} text or overlay @@ -4905,7 +4914,7 @@ either a string or a vector of integers, where each element (an integer) corresponds to one row of the bitmap. Each bit of an integer corresponds to one pixel of the bitmap, where the low bit corresponds to the rightmost pixel of the bitmap. (Note that this order of bits -is opposite of the order in XBM images; @pxref{XBM Images}.) +is the opposite of the order in XBM images; @pxref{XBM Images}.) The height is normally the length of @var{bits}. However, you can specify a different height with non-@code{nil} @var{height}. The width @@ -6361,8 +6370,8 @@ used for each pixel in the XBM that is 0. The default is the frame's background color. @end table - If you specify an XBM image using data within Emacs instead of an -external file, use the following three properties: + To specify an XBM image using data within Emacs instead of an +external file, use the following properties: @table @code @item :data @var{data} @@ -6993,6 +7002,7 @@ Supports the @code{:index} property. @xref{Multi-Frame Images}. @item WebP Image type @code{webp}. +Supports the @code{:index} property. @xref{Multi-Frame Images}. @end table @node Defining Images @@ -7314,8 +7324,8 @@ about these image-specific key bindings. @cindex image frames Some image files can contain more than one image. We say that there are multiple ``frames'' in the image. At present, Emacs supports -multiple frames for GIF, TIFF, and certain ImageMagick formats such as -DJVM@. +multiple frames for GIF, TIFF, WebP, and certain ImageMagick formats +such as DJVM@. The frames can be used either to represent multiple pages (this is usually the case with multi-frame TIFF files, for example), or to @@ -7405,7 +7415,7 @@ period much shorter than @code{image-cache-eviction-delay} (see below), you can opt to flush unused images yourself, instead of waiting for Emacs to do it automatically. -@defun clear-image-cache &optional filter +@defun clear-image-cache &optional filter animation-filter This function clears an image cache, removing all the images stored in it. If @var{filter} is omitted or @code{nil}, it clears the cache for the selected frame. If @var{filter} is a frame, it clears the cache @@ -7413,6 +7423,16 @@ for that frame. If @var{filter} is @code{t}, all image caches are cleared. Otherwise, @var{filter} is taken to be a file name, and all images associated with that file name are removed from all image caches. + +This function also clears the image animation cache, which is a separate +cache that Emacs maintains for animated multi-frame images +(@pxref{Multi-Frame Images}). If @var{animation-filter} is omitted or +@code{nil}, it clears the animation cache in addition to the image +caches selected by @var{filter}. Otherwise, this function removes the +image with specification @code{eq} to @var{animation-filter} only from +the animation cache, and does not clear any image caches. This can help +reduce memory usage after an animation is stopped but the image is still +displayed. @end defun If an image in the image cache has not been displayed for a specified diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 8b2a493a5e1..bdd79528cac 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -109,6 +109,25 @@ must be a root frame, which means it cannot be a child frame itself descending from it. @end defun +@cindex frame identifier +@defun frame-id &optional frame +This function returns the unique identifier of a frame, an integer, +assigned to @var{frame}. If @var{frame} is @code{nil} or unspecified, +it defaults to the selected frame (@pxref{Input Focus}). This can be +used to unambiguously identify a frame in a context where you do not or +cannot use a frame object. + +A frame undeleted using @command{undelete-frame} will retain its +identifier. A frame cloned using @command{clone-frame} will not retain +its original identifier. @xref{Frame Commands,,,emacs, the Emacs +Manual}. + +Frame identifiers are not persisted using the desktop library +(@pxref{Desktop Save Mode}), @command{frameset-to-register}, or +@code{frameset-save}, and each of their restored frames will bear a new +unique id. +@end defun + @menu * Creating Frames:: Creating additional frames. * Multiple Terminals:: Displaying on several different devices. @@ -198,6 +217,11 @@ A normal hook run by @code{make-frame} before it creates the frame. An abnormal hook run by @code{make-frame} after it created the frame. Each function in @code{after-make-frame-functions} receives one argument, the frame just created. + +You can consult the frame parameters @code{cloned-from} and +@code{undeleted} in your function to determine if a frame was cloned +using @command{clone-frame}, or if it was undeleted using +@command{undelete-frame}. @xref{Frame Parameters}. @end defvar Note that any functions added to these hooks by your initial file are @@ -2206,8 +2230,18 @@ left position ratio is preserved if the @sc{cdr} of the cell is either @code{t} or @code{left-only}. The top position ratio is preserved if the @sc{cdr} of the cell is either @code{t} or @code{top-only}. This parameter has not been yet implemented on text terminals. -@end table +@vindex cloned-from@r{, a frame parameter} +@item cloned-from +The original frame if this frame was made via @code{clone-frame} +(@pxref{Creating Frames,,,emacs, the Emacs Manual}). + +@vindex undeleted@r{, a frame parameter} +@item undeleted +This is non-@code{nil} if this frame was undeleted using the command +@command{undelete-frame} (@pxref{Frame Commands,,,emacs, the Emacs +Manual}). +@end table @node Mouse Dragging Parameters @subsubsection Mouse Dragging Parameters @@ -3154,6 +3188,29 @@ could switch to a different terminal without switching back when you're done. @end deffn +@deffn Command select-frame-by-id id &optional noerror +This function searches open and undeletable frames for a matching frame +identifier @var{id} (@pxref{Frames}). If found, its frame is undeleted, +if necessary, then raised, given focus, and made the selected frame. On +a text terminal, raising a frame causes it to occupy the entire terminal +display. + +This function returns the selected frame or signals an error if @var{id} +is not found, unless @var{noerror} is non-@code{nil}, in which case it +returns @code{nil}. +@end deffn + +@deffn Command undelete-frame-by-id id &optional noerror +This function searches undeletable frames for a matching frame +identifier @var{id} (@pxref{Frames}). If found, its frame is undeleted, +raised, given focus, and made the selected frame. On a text terminal, +raising a frame causes it to occupy the entire terminal display. + +This function returns the undeleted frame or signals an error if +@var{id} is not found, unless @var{noerror} is non-@code{nil}, in which +case it returns @code{nil}. +@end deffn + @cindex text-terminal focus notification Emacs cooperates with the window system by arranging to select frames as the server and window manager request. When a window system diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi index 01ddb92294a..1381d784df5 100644 --- a/doc/lispref/internals.texi +++ b/doc/lispref/internals.texi @@ -286,13 +286,9 @@ program does not use so much space as to force a second garbage collection). @end quotation -@deffn Command garbage-collect -This command runs a garbage collection, and returns information on -the amount of space in use. (Garbage collection can also occur -spontaneously if you use more than @code{gc-cons-threshold} bytes of -Lisp data since the previous garbage collection.) - -@code{garbage-collect} returns a list with information on amount of space in +@defun garbage-collect-heapsize +This function returns information on the current memory usage. +The return value is a list with information on amount of space in use, where each entry has the form @samp{(@var{name} @var{size} @var{used})} or @samp{(@var{name} @var{size} @var{used} @var{free})}. In the entry, @var{name} is a symbol describing the kind of objects this entry represents, @@ -422,6 +418,16 @@ Total heap size, in @var{unit-size} units. @item free-size Heap space which is not currently used, in @var{unit-size} units. @end table +@end defun + +@deffn Command garbage-collect +This command runs a garbage collection, and returns information on +the amount of space in use. (Garbage collection can also occur +spontaneously if you use more than @code{gc-cons-threshold} bytes of +Lisp data since the previous garbage collection.) + +@code{garbage-collect} returns the same list as shown above for +@code{garbage-collect-heapsize}. @end deffn @defopt garbage-collection-messages @@ -1660,6 +1666,7 @@ point to an array of at least @var{count} elements specifying the little-endian magnitude of the return value. @end deftypefn +@cindex GMP, the GNU Multiprecision Library The following example uses the GNU Multiprecision Library (GMP) to calculate the next probable prime after a given integer. @xref{Top,,,gmp}, for a general overview of GMP, and @pxref{Integer @@ -1752,7 +1759,11 @@ next_prime (emacs_env *env, ptrdiff_t nargs, emacs_value *args, mpz_t p; mpz_init (p); extract_big_integer (env, args[0], p); + + /* Assume Emacs is linked to the full GMP library, + not to its mini-gmp subset that lacks mpz_nextprime. */ mpz_nextprime (p, p); + emacs_value result = make_big_integer (env, p); mpz_clear (p); return result; @@ -2844,11 +2855,23 @@ Avoid arbitrary limits. For example, avoid @code{int len = strlen fit in @code{int} range. @item +@cindex overflow in integers +@cindex integer overflow Do not assume that signed integer arithmetic wraps around on overflow. This is no longer true of Emacs porting targets: signed integer overflow has undefined behavior in practice, and can dump core or even cause earlier or later code to behave illogically. Unsigned -overflow does wrap around reliably, modulo a power of two. +overflow does wrap around reliably, modulo a power of two, +if all operand types are unsigned and are @code{unsigned int} or wider. + +@item +Use the macros of @code{} to check for integer overflow +or to implement wraparound arithmetic reliably with integer types +that are signed or are narrower than @code{unsigned int}. +Although @code{} was not standardized until C23, +on non-C23 platforms Emacs internally provides a fallback substitute. +Avoid complex arguments to its macros @code{ckd_add}, @code{ckd_sub} and +@code{ckd_mul}, as the fallback macros might evaluate arguments more than once. @item Prefer signed types to unsigned, as code gets confusing when signed @@ -2907,10 +2930,17 @@ although @code{off_t} is always signed, @code{time_t} need not be. @item Prefer @code{intmax_t} for representing values that might be any -signed integer value. +signed integer value in machine range. A @code{printf}-family function can print such a value via a format like @code{"%"PRIdMAX}. +@item +Prefer Emacs integers, which are either fixnums or bignums, +for representing values that might be outside machine range. +Although low level code uses GMP directly for efficiency, +Emacs integers are typically more convenient at higher levels of +abstraction. + @item Prefer @code{bool}, @code{false} and @code{true} for booleans. Using @code{bool} can make programs easier to read and a bit faster than diff --git a/doc/lispref/positions.texi b/doc/lispref/positions.texi index 89fdca1791e..9fcffee2ee0 100644 --- a/doc/lispref/positions.texi +++ b/doc/lispref/positions.texi @@ -57,14 +57,18 @@ buffer size plus 1. If narrowing is in effect (@pxref{Narrowing}), then point is constrained to fall within the accessible portion of the buffer (possibly at one end of it). +@cindex buffer point Each buffer has its own value of point, which is independent of the value of point in other buffers. Each window also has a value of point, -which is independent of the value of point in other windows on the same -buffer. This is why point can have different values in various windows -that display the same buffer. When a buffer appears in only one window, -the buffer's point and the window's point normally have the same value, -so the distinction is rarely important. @xref{Window Point}, for more -details. +which is independent of the value of point in other windows showing the +same buffer. This is why the cursor may appear at different positions +in various windows that display the same buffer. Wherever necessary, we +use the terms @dfn{buffer point} for the unique position of point of a +specific buffer and the term @dfn{window point} for the position of +point in a specific window showing that buffer. When a buffer appears +in only one window, its buffer's point and that window's point normally +have the same value, so the distinction is rarely important. +@xref{Window Point}, for more details. @defun point @cindex current buffer position diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index ee262a4eda0..555f795dcfd 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -1842,11 +1842,11 @@ text arrives, you could insert a line like the following just before the To force point to the end of the new output, no matter where it was previously, eliminate the variable @code{moving} from the example and call @code{goto-char} unconditionally. Note that this doesn't -necessarily move the window point. The default filter actually uses -@code{insert-before-markers} which moves all markers, including the -window point. This may move unrelated markers, so it's generally -better to move the window point explicitly, or set its insertion type -to @code{t} (@pxref{Window Point}). +necessarily move window point. The default filter actually uses +@code{insert-before-markers} which moves all markers, including window +point. This may move unrelated markers, so it's generally better to +move window point explicitly, or set its insertion type to @code{t} +(@pxref{Window Point}). @ignore In earlier Emacs versions, every filter function that did regular diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index f3cd8db051f..288fa2b0b71 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -713,11 +713,11 @@ would have printed for the same argument. (prin1-to-string (mark-marker)) @result{} "#" @end group +@end example If @var{overrides} is non-@code{nil}, it should either be @code{t} (which tells @code{prin1} to use the defaults for all printer related variables), or a list of settings. @xref{Output Overrides}, for details. -@end example If @var{noescape} is non-@code{nil}, that inhibits use of quoting characters in the output. (This argument is supported in Emacs versions diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index d88fb99a6ed..a313480944b 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -6014,12 +6014,21 @@ must be a Lisp object that can be serialized as JSON (@pxref{Parsing JSON}). The result is forwarded to the server as the JSONRPC @code{result} object. A non-local return, achieved by calling the function @code{jsonrpc-error}, causes an error response to be sent to -the server. The details of the accompanying JSONRPC @code{error} -object are filled out with whatever was passed to -@code{jsonrpc-error}. A non-local return triggered by an unexpected -error of any other type also causes an error response to be sent -(unless you have set @code{debug-on-error}, in which case this calls -the Lisp debugger, @pxref{Error Debugging}). +the server. A non-local return triggered by an unexpected error of any +other type also causes a response to be sent. The debugger is never +called (unless you have set @code{debug-on-error}, in which case the +Lisp debugger may be called, @pxref{Error Debugging}). + +The details of the accompanying JSONRPC @code{error} object are filled +out automatically (in the case of unexpected errors) or with whatever +was passed to @code{jsonrpc-error} (in the case of explicit calls). + +Exceptionally, an explicit call to @code{jsonrpc-error} which sets +@code{:code} to 32000 and @code{:data} to any JSON object has the +meaning of ``no error'' and triggers a normal response to the remote +endpoint with @code{result} being set to @code{:data}. This is useful +if the application wants to treat some non-local exits such as user +quits as benign. @findex jsonrpc-convert-to-endpoint @findex jsonrpc-convert-from-endpoint diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index c659ec8edc8..d804c34250f 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -3549,6 +3549,72 @@ the selected window is not used; thus if the selected frame has a single window, it is not used. @end defun +@defun display-buffer-in-new-tab buffer alist +This function tries to display @var{buffer} in a new tab. + +If @var{alist} contains a non-@code{nil} @code{tab-name} entry (which +may be a string or a function), the buffer is displayed in a new tab +with that name. If the @code{tab-name} entry is a function, it is +called with two arguments (@var{buffer} and @var{alist}), and should +return the tab name. + +If the @code{tab-name} entry is omitted or @code{nil}, a new tab is +created without an explicit name. + +If @var{alist} contains a non-@code{nil} @code{tab-group} entry, this +defines the tab group, overriding user option +@code{tab-bar-new-tab-group}. This entry may again be a string or a +function which is called in the same manner as @code{tab-name}. +@end defun + +@defun display-buffer-in-tab buffer alist +This function tries to display @var{buffer} in a new or existing tab. + +If @var{alist} contains a non-@code{nil} @code{reusable-frames} entry +then the frames indicated by its value are searched for an existing tab +which already displays the buffer. The possible values of +@code{reusable-frames} are: + +@itemize @bullet +@item @code{t} +means consider all existing frames. +@item @code{visible} +means consider all visible frames. +@item 0 +means consider all frames on the current terminal. +@item A frame +means consider that frame only. +@item Any other non-@code{nil} value +means consider the selected frame. +@item @code{nil} +means do not search any frames (equivalent to omitting the entry). Note +that this is different to the typical meaning of the value @code{nil} +for a @code{reusable-frames} entry in a buffer display action alist. +@end itemize + +If @var{alist} contains a non-@code{nil} @code{ignore-current-tab} +entry, then the current tab is skipped when searching for a reusable +tab. Otherwise the current tab is used by preference if it already +displays the buffer. + +If a window displaying the buffer is located in any reusable tab then +that tab and window are selected. + +If no such window is located, the buffer is displayed in a new or +existing tab based on the @var{alist} entry @code{tab-name} (which may +be a string or a function). If a tab with this name already exists then +that tab is selected, otherwise a new tab with that name is created. If +the @code{tab-name} entry is a function, it is called with two arguments +(@var{buffer} and @var{alist}), and should return the tab name. If the +@code{tab-name} entry is omitted or @code{nil}, a new tab is created +without an explicit name. + +If a new tab is created and @var{alist} contains a non-@code{nil} +@code{tab-group} entry, this defines the tab group, overriding user +option @code{tab-bar-new-tab-group}. This entry may again be a string +or a function which is called in the same manner as @code{tab-name}. +@end defun + @defun display-buffer-no-window buffer alist If @var{alist} has a non-@code{nil} @code{allow-no-window} entry, then this function does not display @var{buffer} and returns the symbol @@ -3661,6 +3727,10 @@ well. @code{display-buffer-in-previous-window} consults it when searching for a window that previously displayed the buffer on another frame. +Action function @code{display-buffer-in-tab} searches the tabs of the +frame(s) identified by this entry, and also interprets the value +@code{nil} differently. + @vindex inhibit-switch-frame@r{, a buffer display action alist entry} @item inhibit-switch-frame A non-@code{nil} value prevents another frame from being raised or @@ -3981,6 +4051,19 @@ List, @code{buffer-match-p}}. Thus, if a Lisp program uses a particular @var{symbol} as the category when calling @code{display-buffer}, users can customize how these buffers will be displayed by including such an entry in @code{display-buffer-alist}. + +@vindex tab-name@r{, a buffer display action alist entry} +@item tab-name +The value names the tab in which the buffer should be displayed. This +entry is used by @code{display-buffer-in-new-tab} and (conditionally) by +@code{display-buffer-in-tab}. + +@vindex tab-group@r{, a buffer display action alist entry} +@vindex tab-bar-new-tab-group@r{, override for buffer display actions} +@item tab-group +The value names the tab group to use when creating a new tab, overriding +user option @code{tab-bar-new-tab-group}. This entry is used by +@code{display-buffer-in-new-tab} and @code{display-buffer-in-tab}. @end table By convention, the entries @code{window-height}, @code{window-width} @@ -4039,16 +4122,19 @@ window. If @var{window} cannot be split, it returns @code{nil}. If @var{window} is omitted or @code{nil}, it defaults to the selected window. -This function obeys the usual rules that determine when a window may -be split (@pxref{Splitting Windows}). It first tries to split by -placing the new window below, subject to the restriction imposed by -@code{split-height-threshold} (see below), in addition to any other -restrictions. If that fails, it tries to split by placing the new -window to the right, subject to @code{split-width-threshold} (see -below). If that also fails, and the window is the only window on its -frame, this function again tries to split and place the new window -below, disregarding @code{split-height-threshold}. If this fails as -well, this function gives up and returns @code{nil}. +This function obeys the usual rules that determine when a window may be +split (@pxref{Splitting Windows}). It first tries either a vertical +split by placing the new window below, subject to the restriction +imposed by @code{split-height-threshold} (see below), or a horizontal +split that places the new window to the right, subject to +@code{split-width-threshold}, in addition to any other restrictions. +Whether it tries first to split vertically or horizontally depends on +the value of the user option @code{split-window-preferred-direction}. +If splitting along the first dimension fails, it tries to split along +the other dimension. If that also fails, and the window is the only +window on its frame, this function again tries to split and place the +new window below, disregarding @code{split-height-threshold}. If this +fails as well, this function gives up and returns @code{nil}. @end defun @defopt split-height-threshold @@ -4067,6 +4153,18 @@ window has at least that many columns. If the value is @code{nil}, that means not to split this way. @end defopt +@defopt split-window-preferred-direction +This variable determines the first dimension along which +@code{split-window-sensibly} tries to split the window, if the window +could be split both vertically and horizontally, as determined by the +values of @code{split-height-threshold} and +@code{split-width-threshold}. The default value is @code{longest}, +which means to split vertically if the height of the window's frame is +greater or equal to its width, and horizontally otherwise. The values +@code{vertical} and @code{horizontal} specify the direction in which to +attempt the first split. +@end defopt + @defopt even-window-sizes This variable, if non-@code{nil}, causes @code{display-buffer} to even window sizes whenever it reuses an existing window, and that window is @@ -4826,8 +4924,8 @@ Each list element has the form @code{(@var{buffer} @var{window-start} @var{window-pos})}, where @var{buffer} is a buffer previously shown in the window, @var{window-start} is the window start position (@pxref{Window Start and End}) when that buffer was last shown, and -@var{window-pos} is the point position (@pxref{Window Point}) when -that buffer was last shown in @var{window}. +@var{window-pos} is the window point position (@pxref{Window Point}) +when that buffer was last shown in @var{window}. The list is ordered so that earlier elements correspond to more recently-shown buffers, and the first element usually corresponds to the @@ -5774,8 +5872,8 @@ makes it useful to have multiple windows showing one buffer. @itemize @bullet @item -The window point is established when a window is first created; it is -initialized from the buffer's point, or from the window point of another +Window point is established when a window is first created; it is +initialized from the buffer's point, or from window point of another window opened on the buffer if such a window exists. @item @@ -5789,6 +5887,18 @@ the other windows are stored in those windows. @item As long as the selected window displays the current buffer, the window's point and the buffer's point always move together; they remain equal. + +@item +Many Emacs functions temporarily select a window in order to operate on +its contents. This will move point (@pxref{Point}) of that +window's buffer to the position of window point of that window and +not restore buffer point to its previous position when terminating +the temporary selection. This means that when one and the same buffer +is simultaneously displayed in more than one window, its buffer point +may change in unpredictable ways to the position of window point of any +of these windows as a side-effect of things like redisplay, calling +@code{with-selected-window} (@pxref{Selecting Windows}) or running +@code{window-configuration-change-hook} (@pxref{Window Hooks}). @end itemize @cindex cursor @@ -5844,6 +5954,40 @@ This function returns the cursor type of @var{window}, defaulting to the selected window. @end defun +@defun window-cursor-info &optional window +This function returns information about the cursor of @var{window}, +defaulting to the selected window. + +The value returned by the function is a vector of the form +@w{@code{[@var{type} @var{x} @var{y} @var{width} @var{height} +@var{ascent}]}}. Here's the description of each components of this +vector: + +@table @var +@item type +The type of the cursor, a symbol. This is the same value returned by +@code{window-cursor-type}. + +@item x +@itemx y +The pixel coordinates of the cursor's top-left corner, relative to the +top-left corner of @var{window}'s text area. + +@item width +@itemx height +The pixel dimensions of the cursor. + +@item ascent +The number of pixels the cursor extends above the baseline. +@end table + +If the cursor is not currently displayed for @var{window}, this function +returns @code{nil}. + +Any element except the first one in the returned vector may be +@code{-1}, meaning the actual value is currently unavailable. +@end defun + @node Window Start and End @section The Window Start and End Positions @cindex window start position @@ -7185,8 +7329,8 @@ function may also delete windows which were found live by Each entry in the list that is passed as the second argument to the function is itself a list of six values: the window whose buffer was -found dead, the dead buffer or its name, the positions of window-start -(@pxref{Window Start and End}) and window-point (@pxref{Window Point}) +found dead, the dead buffer or its name, the positions of window start +(@pxref{Window Start and End}) and window point (@pxref{Window Point}) of the buffer in that window, the dedicated state of the window as previously reported by @code{window-dedicated-p} and a flag that is @code{t} if the window has been found to be alive by diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi index 5e80b39c3fd..deddcd7a7ad 100644 --- a/doc/misc/calc.texi +++ b/doc/misc/calc.texi @@ -35694,10 +35694,9 @@ The variable @code{calc-string-maximum-character} is the maximum value of a vector's elements for @code{calc-display-strings}, @code{string}, and @code{bstring} to display the vector as a string. This maximum @emph{must} represent a character, i.e. it's a non-negative integer less -than or equal to @code{(max-char)} or @code{0x3FFFFF}. Any negative -value effectively disables the display of strings, and for values larger -than @code{0x3FFFFF} the display acts as if the maximum were -@code{0x3FFFFF}. Some natural choices (and their resulting ranges) are: +than or equal to @code{(max-char)} or @code{0x3FFFFF}. Any value not +representing a character effectively disables the display of strings. +Some natural choices (and their resulting ranges) are: @itemize @item diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index f3e42f3060c..59685087ae8 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -64,6 +64,7 @@ another. An overview of D-Bus can be found at * Alternative Buses:: Alternative buses and environments. * Errors and Events:: Errors and events. * Monitoring Messages:: Monitoring messages. +* Inhibitor Locks:: Inhibit system shutdowns and sleep states. * Index:: Index including concepts, functions, variables. * GNU Free Documentation License:: The license for this documentation. @@ -124,7 +125,7 @@ name could be @samp{org.gnu.Emacs.TextEditor} or @node Inspection -@chapter Inspection of D-Bus services. +@chapter Inspection of D-Bus services @cindex inspection @menu @@ -139,7 +140,7 @@ name could be @samp{org.gnu.Emacs.TextEditor} or @node Version -@section D-Bus version. +@section D-Bus version D-Bus has evolved over the years. New features have been added with new D-Bus versions. There are two variables, which allow the determination @@ -158,7 +159,7 @@ It is also @code{nil}, if it cannot be determined at runtime. @node Bus names -@section Bus names. +@section Bus names There are several basic functions which inspect the buses for registered names. Internally they use the basic interface @@ -267,7 +268,7 @@ at D-Bus @var{bus}, as a string. @node Introspection -@section Knowing the details of D-Bus services. +@section Knowing the details of D-Bus services D-Bus services publish their interfaces. This can be retrieved and analyzed during runtime, in order to understand the used @@ -483,7 +484,7 @@ If @var{object} has no @var{attribute}, the function returns @node Nodes and Interfaces -@section Detecting object paths and interfaces. +@section Detecting object paths and interfaces The first elements, to be introspected for a D-Bus object, are further object paths and interfaces. @@ -593,7 +594,7 @@ data from a running system: @node Methods and Signal -@section Applying the functionality. +@section Applying the functionality Methods and signals are the communication means to D-Bus. The following functions return their specifications. @@ -673,7 +674,7 @@ Example: @node Properties and Annotations -@section What else to know about interfaces. +@section What else to know about interfaces Interfaces can have properties. These can be exposed via the @samp{org.freedesktop.DBus.Properties} interface@footnote{See @@ -894,7 +895,7 @@ An attribute value can be retrieved by @node Arguments and Signatures -@section The final details. +@section The final details Methods and signals have arguments. They are described in the @code{arg} XML elements. @@ -962,7 +963,7 @@ non-@code{nil}, @var{direction} must be @samp{out}. Example: @node Type Conversion -@chapter Mapping Lisp types and D-Bus types. +@chapter Mapping Lisp types and D-Bus types @cindex type conversion D-Bus method calls and signals accept usually several arguments as @@ -975,7 +976,7 @@ applied Lisp object @expansion{} D-Bus type for input parameters, and D-Bus type @expansion{} Lisp object for output parameters. -@section Input parameters. +@section Input parameters Input parameters for D-Bus methods and signals occur as arguments of a Lisp function call. The following mapping to D-Bus types is @@ -1116,7 +1117,7 @@ lower-case hex digits. As a special case, "" is escaped to @end defun -@section Output parameters. +@section Output parameters Output parameters of D-Bus methods and signals are mapped to Lisp objects. @@ -1199,7 +1200,7 @@ that string: @node Synchronous Methods -@chapter Calling methods in a blocking way. +@chapter Calling methods in a blocking way @cindex method calls, synchronous @cindex synchronous method calls @@ -1240,6 +1241,8 @@ running): "org.freedesktop.systemd1.Manager" "RestartUnit" :authorizable t "bluetooth.service" "replace") + +@result{} "/org/freedesktop/systemd1/job/17508" @end lisp The remaining arguments @var{args} are passed to @var{method} as @@ -1317,7 +1320,7 @@ emulate the @code{lshal} command on GNU/Linux systems: @node Asynchronous Methods -@chapter Calling methods non-blocking. +@chapter Calling methods non-blocking @cindex method calls, asynchronous @cindex asynchronous method calls @@ -1369,7 +1372,7 @@ message arrives, and @var{handler} is called. Example: @node Register Objects -@chapter Offering own services. +@chapter Offering own services @cindex method calls, returning @cindex returning method calls @@ -1720,7 +1723,7 @@ to the service from D-Bus. @node Signals -@chapter Sending and receiving signals. +@chapter Sending and receiving signals @cindex signals Signals are one way messages. They carry input parameters, which are @@ -1752,6 +1755,8 @@ arguments. They are converted into D-Bus types as described in :session nil dbus-path-emacs (concat dbus-interface-emacs ".FileManager") "FileModified" "/home/albinus/.emacs") + +@result{} nil @end lisp @end defun @@ -1779,7 +1784,10 @@ argument. @var{handler} is a Lisp function to be called when the @var{signal} is received. It must accept as arguments the output parameters -@var{signal} is sending. +@var{signal} is sending.@footnote{It is possible to register different +handlers for the same signal. All registered handlers will be called +when the signal arrives. This is useful for example if different Lisp +packages are interested in the same signal.} The remaining arguments @var{args} can be keywords or keyword string pairs.@footnote{For backward compatibility, the arguments @var{args} @@ -1852,7 +1860,7 @@ for a dummy signal, and check the result: @node Alternative Buses -@chapter Alternative buses and environments. +@chapter Alternative buses and environments @cindex bus names @cindex UNIX domain socket @cindex TCP/IP socket @@ -1979,7 +1987,7 @@ running. This could be achieved by @node Errors and Events -@chapter Errors and events. +@chapter Errors and events @cindex debugging @cindex errors @cindex events @@ -2138,7 +2146,7 @@ whether a given D-Bus error is related to them. @node Monitoring Messages -@chapter Monitoring messages. +@chapter Monitoring messages @cindex monitoring @defun dbus-register-monitor bus &optional handler &key type sender destination path interface member @@ -2178,12 +2186,16 @@ The following form shows all D-Bus events on the session bus in buffer @lisp (dbus-register-monitor :session) + +@result{} ((:monitor :session-private) (nil nil dbus-monitor-handler)) @end lisp And this form restricts the monitoring on D-Bus errors: @lisp (dbus-register-monitor :session nil :type "error") + +@result{} ((:monitor :session-private) (nil nil dbus-monitor-handler)) @end lisp @end defun @@ -2193,6 +2205,111 @@ switches to the monitor buffer. @end deffn +@node Inhibitor Locks +@chapter Inhibit system shutdowns and sleep states + +@uref{https://systemd.io/INHIBITOR_LOCKS/, Systemd} includes a logic to +inhibit system shutdowns and sleep states. It can be controlled by a +D-Bus API@footnote{@uref{https://www.freedesktop.org/software/systemd/man/latest/org.freedesktop.login1.html}}. +Because this API includes handling of file descriptors, not all +functions can be implemented by simple D-Bus method calls. Therefore, +the following functions are provided. + +@defun dbus-make-inhibitor-lock what why &optional block +This function creates an inhibitor for system shutdowns and sleep states. + +@var{what} is a colon-separated string of lock types: @samp{shutdown}, +@samp{sleep}, @samp{idle}, @samp{handle-power-key}, +@samp{handle-suspend-key}, @samp{handle-hibernate-key}, +@samp{handle-lid-switch}. Example: @samp{shutdown:idle}. + +@c@var{who} is a descriptive string of who is taking the lock. If it is +@c@code{nil}, it defaults to @samp{Emacs}. + +@var{why} is a descriptive string of why the lock is taken. Example: +@samp{Package Update in Progress}. + +The optional @var{block} is the mode of the inhibitor lock, either +@samp{block} (@var{block} is non-@code{nil}), or @samp{delay}. + +Note, that the @code{who} argument of the inhibitor lock object of the +systemd manager is always set to the string @samp{Emacs}. + +It returns a file descriptor or @code{nil}, if the lock cannot be +acquired. If there is already an inhibitor lock for the triple +@code{(WHAT WHY BLOCK)}, this lock is returned. Example: + +@lisp +(dbus-make-inhibitor-lock "sleep" "Test") + +@result{} 25 +@end lisp +@end defun + +@defun dbus-registered-inhibitor-locks +Return registered inhibitor locks, an alist. +This allows to check, whether other packages of the running Emacs +instance have acquired an inhibitor lock as well. + +An entry in this list is a list @code{(@var{fd} @var{what} @var{why} +@var{block})}. The car of the list is the file descriptor retrieved +from a @code{dbus-make-inhibitor-lock} call. The cdr of the list +represents the three arguments @code{dbus-make-inhibitor-lock} was +called with. Example: + +@lisp +(dbus-registered-inhibitor-locks) + +@result{} ((25 "sleep" "Test" nil)) +@end lisp +@end defun + +@defun dbus-close-inhibitor-lock lock +Close inhibitor lock file descriptor. + +@var{lock}, a file descriptor, must be the result of a +@code{dbus-make-inhibitor-lock} call. It returns @code{t} in case of +success, or @code{nil} if it isn't be possible to close the lock, or if +the lock is closed already. Example: + +@lisp +(dbus-close-inhibitor-lock 25) + +@result{} t + +@end lisp +@end defun + +A typical scenario for these functions is to register for the +D-Bus signal @samp{org.freedesktop.login1.Manager.PrepareForSleep}: + +@lisp +(defvar my-inhibitor-lock + (dbus-make-inhibitor-lock "sleep" "Test")) + +(defun my-dbus-PrepareForSleep-handler (start) + (if start ;; The system goes down for sleep + (progn + @dots{} + ;; Release inhibitor lock. + (when (natnump my-inhibitor-lock) + (dbus-close-inhibitor-lock my-inhibitor-lock) + (setq my-inhibitor-lock nil))) + ;; Reacquire inhibitor lock. + (setq my-inhibitor-lock + (dbus-make-inhibitor-lock "sleep" "Test")))) + +(dbus-register-signal + :system "org.freedesktop.login1" "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" "PrepareForSleep" + #'my-dbus-PrepareForSleep-handler) + +@result{} ((:signal :system "org.freedesktop.login1.Manager" "PrepareForSleep") + ("org.freedesktop.login1" "/org/freedesktop/login1" + my-dbus-PrepareForSleep-handler)) +@end lisp + + @node Index @unnumbered Index diff --git a/doc/misc/eglot.texi b/doc/misc/eglot.texi index 5b5b3f98dc4..8483881c52a 100644 --- a/doc/misc/eglot.texi +++ b/doc/misc/eglot.texi @@ -87,7 +87,9 @@ Eglot itself is completely language-agnostic, but it can support any programming language for which there is a language server and an Emacs major mode. -This manual documents how to configure, use, and customize Eglot. +This manual documents how to configure, use, and customize Eglot. To +read this manual from within Emacs, type @kbd{M-x eglot-manual +@key{RET}}. @insertcopying @@ -97,6 +99,7 @@ This manual documents how to configure, use, and customize Eglot. * Using Eglot:: Important Eglot commands and variables. * Customizing Eglot:: Eglot customization and advanced features. * Advanced server configuration:: Fine-tune a specific language server +* Multi-server support:: Use more than one server in a buffer * Extending Eglot:: Writing Eglot extensions in Elisp * Troubleshooting Eglot:: Troubleshooting and reporting bugs. * GNU Free Documentation License:: The license for this manual. @@ -763,6 +766,22 @@ serve hints about positional parameter names in function calls and a variable's automatically deduced type. Inlay hints help the user not have to remember these things by heart. +@cindex momentary inlay hints +@item eglot-momentary-inlay-hints +When bound to a single key in @code{eglot-mode-map} +(@pxref{Customization Variables}), this will arrange for inlay hints to +be displayed as long as the key is held down, and then hidden shortly +after it is released. The best way to set it up is something like this: + +@lisp +(define-key eglot-mode-map [f7] 'eglot-momentary-inlay-hints) +@end lisp + +@noindent +Note that Emacs doesn't support binding to \"key up\" events, so this +command offers an approximation by estimating your system keyboard delay +and repeat rate. + @cindex semantic tokens @item M-x eglot-semantic-tokens-mode This command toggles LSP @dfn{semantic tokens} fontification on and off @@ -975,6 +994,7 @@ For example: (define-key eglot-mode-map (kbd "C-c o") 'eglot-code-action-organize-imports) (define-key eglot-mode-map (kbd "C-c h") 'eldoc) (define-key eglot-mode-map (kbd "") 'xref-find-definitions) + (define-key eglot-mode-map (kbd "") 'eglot-momentary-inlay-hints) @end lisp @cindex progress @@ -1509,6 +1529,152 @@ is serialized by Eglot to the following JSON text: @} @end example +@node Multi-server support +@chapter Multi-server support +@cindex multiple servers per buffer +@cindex LSP server multiplexer +@cindex per-buffer multiple servers + +One of the most frequently requested features for Eglot in close to a +decade of existence is the ability to use more than one LSP server in a +single buffer. This is distinct from using multiple servers in a +project, where each server manages a disjoint set of files written in +different languages. + +The latter case---multiple servers for different files---is +intrinsically supported by Eglot. For example, in a web project with +JavaScript, CSS, and Python files, Eglot can seamlessly manage separate +language servers for each file type within the same project +(@pxref{Starting Eglot}). Each buffer communicates with its appropriate +server, and this works out-of-the-box. + +However, there are several scenarios where multiple servers per buffer +are useful: + +@itemize @bullet +@item +Combining a spell-checking language server like @command{codebook-lsp} +with language-specific servers for C++, Go, or Python files. The +spell-checker provides diagnostics for comments and strings, while the +language server handles syntax and semantics. + +@item +One might want multiple servers to cover different aspects of the same +language. For Python, you might combine @command{ty} for type checking +with @command{ruff} for linting and formatting. For JavaScript, you +might use @command{typescript-language-server} for language features +together with @command{eslint} for linting. + +@item +When working on multi-language files like Vue @file{.vue} files, which +contain JavaScript, CSS, and HTML embedded in a single file, multiple +servers can manage the different areas of the buffer. +@end itemize + +These use cases are not directly supported by Eglot's architecture, +however, you can use a language-agnostic @dfn{LSP server multiplexer} +that sits between Eglot and the actual language servers. Eglot still +communicates with a single LSP server process in each buffer, but that +process mediates communication to multiple language-specific servers, +meaning that for practical purposes, it's @emph{as if} Eglot was +connected to them directly. + +This approach is more powerful and user-friendly than current +workarounds that combine one LSP server in a buffer with additional +non-LSP mechanisms such as extra Flymake backends (@pxref{Top,,, +Flymake, GNU Flymake manual}) for the same buffer. + +@menu +* Using Rassumfrassum:: Setup the @code{rass} LSP multiplexer +* Design rationale:: Benefits and drawbacks of LSP multiplexers +@end menu + +@node Using Rassumfrassum +@section Using Rassumfrassum + +@uref{https://github.com/joaotavora/rassumfrassum, Rassumfrassum} is an +LSP server multiplexer program that fits the bill. Like most language +servers, it must be installed separately since it is not bundled with +Emacs (at time of writing). The installation is similar to installing +any other language server, and usually amounts to making sure the +program executable is somewhere in @code{PATH} or @code{exec-path}. + +The Rassumfrassum program, invoked via the @command{rass} command, works +by spawning multiple LSP server subprocesses and aggregating their +capabilities, requests, and responses into a single unified LSP +interface. From Eglot's perspective, it appears to be communicating with +a single server. + +To use Rassumfrassum with Eglot, you can start it interactively with a +prefix argument to @code{eglot} and specify the @command{rass} command +followed by the actual servers you want to use, separated by @code{--}: + +@example +C-u M-x eglot RET rass -- clangd -- codebook-lsp serve RET +@end example + +@noindent +This starts @command{clangd} for C++ language support and +@command{codebook-lsp} for spell-checking in the same buffer. + +For Python, you might use: + +@example +C-u M-x eglot RET rass -- ty server -- ruff server RET +@end example + +@noindent +or simply @kbd{C-u M-x eglot RET rass python}, using the ``preset'' +feature. This combines @command{ty} for type checking with +@command{ruff} for linting and formatting. + +These configurations can be integrated into the +@code{eglot-server-programs} variable (@pxref{Setting Up LSP Servers}) +for automatic use: + +@lisp +(with-eval-after-load 'eglot + (add-to-list 'eglot-server-programs + '(c-ts-base-mode . ("rass" "--" "clangd" "--" + "codebook-lsp" "serve"))) + (add-to-list 'eglot-server-programs + '(python-mode . ("rass" "--" "ty" "server" "--" + "ruff" "server")))) +@end lisp + +@node Design rationale +@section Design rationale + +Using an LSP server multiplexer like @command{rass} relieves Eglot from +knowing about the specific characteristics of individual servers and the +complexity of managing multiple simultaneous server connections per +buffer. This helps preserve the essential features that distinguish +Eglot's code base from other LSP offers for Emacs: simple, performant +and mindful of the core tenet of LSP, which is for a client to be +language-agnostic. + +This approach has an additional benefit: because the multiplexer +mediates all communication between Eglot and the servers, it can take +advantage of different optimization opportunities. For instance, at the +system level it may be multi-threaded to process different JSONRPC +streams in with true parallelism, something which is currently +impossible to do in plain Elisp. At the LSP-level it can merge server +responses intelligently, truncate unnecessarily large objects, and cache +significant amounts of information in efficient ways. In many cases, +this can reduce the amount of JSONRPC traffic exchanged with Emacs to +levels well below what would occur if a client connected to multiple +servers separately. Some of these optimizations may apply even when a +program like @command{rass} is mediating communication to a single +server. + +The multiplexer approach is not without drawbacks. Since LSP is a +relatively large protocol with a decade of existence and many backward +compatibility concerns, combining the responses of servers using completely +different mechanisms of the protocol to respond to the same request +sometimes leads to complexity in covering the corner cases. However, +offloading this complexity to a completely separate layer has proven +very effective in practice. + @node Extending Eglot @chapter Extending Eglot @@ -1685,9 +1851,13 @@ slowly, try to customize the variable @code{eglot-events-buffer-config} 0. This will disable recording any events and may speed things up. In other situations, the cause of poor performance lies in the language -server itself. Servers use aggressive caching and other techniques to -improve their performance. Often, this can be tweaked by changing the -server configuration (@pxref{Advanced server configuration}). +server itself. Some servers use aggressive caching and other techniques +to improve their performance. Often, this can be tweaked by changing +the server configuration (@pxref{Advanced server configuration}). + +Another aspect that may cause performance degradation is the amount of +JSONRPC information exchanged with Emacs. Using an LSP program like +@ref{Using Rassumfrassum,Rassumfrassum} may alleviate such problems. @node Getting the latest version @section Getting the latest version @@ -1749,10 +1919,17 @@ may be using. If possible, try to replicate the problem with the C/C@t{++} or Python servers, as these are very easy to install. @item -Describe how to setup a @emph{minimal} project directory where Eglot +If using an LSP multiplexer server like @ref{Using Rassumfrassum, +Rassumfrassum}, first verify if the program replicates by using one of +the multiplexed servers directly. If it doesn't the problem lies in the +LSP multiplexer program and should be reported there. + +@item +Include a description of a @emph{minimal} project directory where Eglot should be started for the problem to happen. Describe each file's name -and its contents. Alternatively, you can supply the address of a public -Git repository. +and its contents, or---sometimes better--- zip that project directory +completely and attach it. Alternatively, you can supply the address of +a public Git repository. @item Include versions of the software used. The Emacs version can be @@ -1765,12 +1942,13 @@ first check if the problem isn't already fixed in the latest version It's also essential to include the version of ELPA packages that are explicitly or implicitly loaded. The optional but popular Company or Markdown packages are distributed as GNU ELPA packages, not to mention -Eglot itself in some situations. Some major modes (Go, Rust, etc.) are -provided by ELPA packages. It's sometimes easy to miss these, since -they are usually implicitly loaded when visiting a file in that -language. +Eglot itself in some situations. Prefer reproducing the problem with +built-in Treesit major modes like @code{go-ts-mode} or +@code{rust-ts-mode} since the non-ts modes for such languages are +usually provided by ELPA packages, and it's often easy to miss them. -ELPA packages usually live in @code{~/.emacs.d/elpa} (or what is in +If you can't reproduce your bug without ELPA packages, you may find the +ones you're using in @code{~/.emacs.d/elpa} (or what is in @code{package-user-dir}). Including a listing of files in that directory is a way to tell the maintainers about ELPA package versions. diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index 1682f6cf5f1..260bf4a9f80 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@ -5,7 +5,7 @@ % \def\texinfoversion{2025-12-23.13} % -% Copyright 1985--1986, 1988, 1990--2026 Free Software Foundation, Inc. +% Copyright 1985, 1986, 1988, 1990-2025 Free Software Foundation, Inc. % % This texinfo.tex file is free software: you can redistribute it and/or % modify it under the terms of the GNU General Public License as diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index e76620bb6f2..c916588a060 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1132,9 +1132,11 @@ an external transfer program. External methods save on the overhead of encoding and decoding of inline methods. +@vindex tramp-copy-size-limit Since external methods have the overhead of opening a new channel, files smaller than @code{tramp-copy-size-limit} still use inline -methods. +methods. If an external method is used inside a multi-hop connection +(@pxref{Multi-hops}), its inherent inline method is used as well. @table @asis @cindex method @option{rcp} @@ -3891,7 +3893,7 @@ proxy @samp{bird@@bastion} to a remote file on @samp{you@@remotehost}: ssh@value{postfixhop}you@@remotehost@value{postfix}/path @key{RET}} @end example -Each involved method must be an inline method (@pxref{Inline methods}). +Each involved method must be handled by @value{tramp}'s @code{tramp-sh} backend. @value{tramp} adds the ad-hoc definitions as an ephemeral record to @code{tramp-default-proxies-alist}, which are available for reuse diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index ed18ab9bf4c..6eddd0e71c5 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -7,7 +7,7 @@ @c In the Tramp GIT, the version number and the bug report address @c are auto-frobbed from configure.ac. -@set trampver 2.8.1 +@set trampver 2.8.2-pre @set trampurl https://www.gnu.org/software/tramp/ @set tramp-bug-report-address tramp-devel@@gnu.org @set emacsver 28.1 diff --git a/doc/misc/transient.texi b/doc/misc/transient.texi index 15f6b3bf025..25d0e11fac7 100644 --- a/doc/misc/transient.texi +++ b/doc/misc/transient.texi @@ -25,13 +25,13 @@ General Public License for more details. @dircategory Emacs misc features @direntry -* Transient: (transient). Transient Commands. +* Transient: (transient). Transient Commands. @end direntry @finalout @titlepage @title Transient User and Developer Manual -@subtitle for version 0.11.0 +@subtitle for version 0.12.0 @author Jonas Bernoulli @page @vskip 0pt plus 1filll @@ -53,7 +53,7 @@ resource to get over that hurdle is Psionic K's interactive tutorial, available at @uref{https://github.com/positron-solutions/transient-showcase}. @noindent -This manual is for Transient version 0.11.0. +This manual is for Transient version 0.12.0. @insertcopying @end ifnottex @@ -385,7 +385,7 @@ than outlined above and even customizable.} If the user does not save the value and just exits using a regular suffix command, then the value is merely saved to the transient's history. That value won't be used when the transient is next invoked, -but it is easily accessible (see @ref{Using History}). +but it is easily accessible (@pxref{Using History}). Option @code{transient-common-command-prefix} controls the prefix key used in the following bindings. For simplicity's sake the default, @kbd{C-x}, @@ -454,8 +454,8 @@ previously used values. Usually the same keys as those mentioned above are bound to those commands. Authors of transients should arrange for different infix commands that -read the same kind of value to also use the same history key (see -@ref{Suffix Slots}). +read the same kind of value to also use the same history key +(@pxref{Suffix Slots}). Both kinds of history are saved to a file when Emacs is exited. @@ -785,7 +785,7 @@ menu buffer. The menu buffer is displayed in a window using The value of this option has the form @code{(@var{FUNCTION} . @var{ALIST})}, where @var{FUNCTION} is a function or a list of functions. Each such function should accept two arguments: a buffer to display and an -alist of the same form as @var{ALIST}. See @ref{Choosing Window,,,elisp,}, +alist of the same form as @var{ALIST}. @xref{Choosing Window,,,elisp,}, for details. The default is: @@ -798,8 +798,8 @@ The default is: @end lisp This displays the window at the bottom of the selected frame. -For alternatives see @ref{Buffer Display Action Functions,,,elisp,}, -and @ref{Buffer Display Action Alists,,,elisp,}. +For alternatives @xref{Buffer Display Action Functions,,,elisp,}, +and @xref{Buffer Display Action Alists,,,elisp,}. When you switch to a different ACTION, you should keep the ALIST entries for @code{dedicated} and @code{inhibit-same-window} in most cases. @@ -861,7 +861,7 @@ used to draw the line. This user option may be overridden if @code{:mode-line-format} is passed when creating a new prefix with @code{transient-define-prefix}. -Otherwise this can be any mode-line format. See @ref{Mode Line Format,,,elisp,}, for details. +Otherwise this can be any mode-line format. @xref{Mode Line Format,,,elisp,}, for details. @end defopt @defopt transient-semantic-coloring @@ -1002,8 +1002,8 @@ That buffer is current and empty when this hook is runs. @cindex modifying existing transients -To an extent, transients can be customized interactively, see -@ref{Enabling and Disabling Suffixes}. This section explains how existing +To an extent, transients can be customized interactively, +@xref{Enabling and Disabling Suffixes}. This section explains how existing transients can be further modified non-interactively. Let's begin with an example: @@ -1029,10 +1029,10 @@ which can be included in multiple prefixes. See TODO@. as expected by @code{transient-define-prefix}. Note that an infix is a special kind of suffix. Depending on context ``suffixes'' means ``suffixes (including infixes)'' or ``non-infix suffixes''. Here it -means the former. See @ref{Suffix Specifications}. +means the former. @xref{Suffix Specifications}. @var{SUFFIX} may also be a group in the same form as expected by -@code{transient-define-prefix}. See @ref{Group Specifications}. +@code{transient-define-prefix}. @xref{Group Specifications}. @item @var{LOC} is a key description (a string as returned by @code{key-description} @@ -1055,9 +1055,9 @@ the function @code{transient--get-layout}. These functions operate on the information stored in the @code{transient--layout} property of the @var{PREFIX} symbol. Elements in that -tree are not objects but have the form @code{(@var{CLASS} @var{PLIST}) for suffixes} and +tree are not objects but have the form @code{(@var{CLASS} @var{PLIST})} for suffixes and @code{[CLASS PLIST CHILDREN]} for groups. At the root of the tree is an -element @code{[N Nil CHILDREN]}, where @code{N} is the version of the layout format, +element @code{[N nil CHILDREN]}, where @code{N} is the version of the layout format, currently and hopefully for a long time 2. While that element looks like a group vector, that element does not count when identifying a group using a coordinate vector, i.e., @code{[0]} is its first child, not the @@ -1072,7 +1072,7 @@ or after @var{LOC}. Conceptually adding a binding to a transient prefix is similar to adding a binding to a keymap, but this is complicated by the fact that multiple suffix commands can be bound to the same key, provided -they are never active at the same time, see @ref{Predicate Slots}. +they are never active at the same time, @xref{Predicate Slots}. Unfortunately both false-positives and false-negatives are possible. To deal with the former, use non-@code{nil} @var{KEEP-OTHER@.} The symbol @code{always} @@ -1205,14 +1205,14 @@ enabled. One benefit of the Transient interface is that it remembers history not only on a global level (``this command was invoked using these arguments, and previously it was invoked using those other arguments''), but also remembers the values of individual arguments -independently. See @ref{Using History}. +independently. @xref{Using History}. After a transient prefix command is invoked, @kbd{C-h @var{KEY}} can be used to show the documentation for the infix or suffix command that @kbd{@var{KEY}} is -bound to (see @ref{Getting Help for Suffix Commands}), and infixes and +bound to (@pxref{Getting Help for Suffix Commands}), and infixes and suffixes can be removed from the transient using @kbd{C-x l @var{KEY}}. Infixes and suffixes that are disabled by default can be enabled the same way. -See @ref{Enabling and Disabling Suffixes}. +@xref{Enabling and Disabling Suffixes}. Transient ships with support for a few different types of specialized infix commands. A command that sets a command line option, for example, @@ -1263,7 +1263,7 @@ explicitly. @var{GROUP}s add key bindings for infix and suffix commands and specify how these bindings are presented in the menu buffer. At least one -@var{GROUP} has to be specified. See @ref{Binding Suffix and Infix Commands}. +@var{GROUP} has to be specified. @xref{Binding Suffix and Infix Commands}. The @var{BODY} is optional. If it is omitted, then @var{ARGLIST} is ignored and the function definition becomes: @@ -1314,11 +1314,13 @@ GROUPs have the same form as for @code{transient-define-prefix}. @section Binding Suffix and Infix Commands The macro @code{transient-define-prefix} is used to define a transient. -This defines the actual transient prefix command (see @ref{Defining Transients}) and adds the transient's infix and suffix bindings, as +This defines the actual transient prefix command (@pxref{Defining +Transients}) and adds the transient's infix and suffix bindings, as described below. Users and third-party packages can add additional bindings using -functions such as @code{transient-insert-suffix} (see @ref{Modifying Existing Transients}). These functions take a ``suffix specification'' as one of +functions such as @code{transient-insert-suffix} (@pxref{Modifying Existing Transients}). +These functions take a ``suffix specification'' as one of their arguments, which has the same form as the specifications used in @code{transient-define-prefix}. @@ -1334,7 +1336,7 @@ for a set of suffixes. Several group classes exist, some of which organize suffixes in subgroups. In most cases the class does not have to be specified -explicitly, but see @ref{Group Classes}. +explicitly, but @xref{Group Classes}. Groups are specified in the call to @code{transient-define-prefix}, using vectors. Because groups are represented using vectors, we cannot use @@ -1344,10 +1346,13 @@ brackets to do the latter. Group specifications then have this form: @lisp -[@{LEVEL@} @{DESCRIPTION@} @{KEYWORD VALUE@}... ELEMENT...] +[@{@var{LEVEL}@} @{@var{DESCRIPTION}@} + @{@var{KEYWORD} @var{VALUE}@}... + @var{ELEMENT}...] @end lisp -The @var{LEVEL} is optional and defaults to 4. See @ref{Enabling and Disabling Suffixes}. +The @var{LEVEL} is optional and defaults to 4. @xref{Enabling and +Disabling Suffixes}. The @var{DESCRIPTION} is optional. If present, it is used as the heading of the group. @@ -1378,7 +1383,7 @@ useful while rebase is already in progress; and another that uses initiate a rebase. These predicates can also be used on individual suffixes and are -only documented once, see @ref{Predicate Slots}. +only documented once, @xref{Predicate Slots}. @item The value of @code{:hide}, if non-@code{nil}, is a predicate that controls @@ -1483,13 +1488,13 @@ The form of suffix specifications is documented in the next node. @cindex suffix specifications A transient's suffix and infix commands are bound when the transient -prefix command is defined using @code{transient-define-prefix}, see -@ref{Defining Transients}. The commands are organized into groups, see -@ref{Group Specifications}. Here we describe the form used to bind an +prefix command is defined using @code{transient-define-prefix}, +@xref{Defining Transients}. The commands are organized into groups, +@xref{Group Specifications}. Here we describe the form used to bind an individual suffix command. The same form is also used when later binding additional commands -using functions such as @code{transient-insert-suffix}, see @ref{Modifying Existing Transients}. +using functions such as @code{transient-insert-suffix}, @xref{Modifying Existing Transients}. Note that an infix is a special kind of suffix. Depending on context ``suffixes'' means ``suffixes (including infixes)'' or ``non-infix @@ -1498,7 +1503,9 @@ suffixes''. Here it means the former. Suffix specifications have this form: @lisp -([LEVEL] [KEY [DESCRIPTION]] COMMAND|ARGUMENT [KEYWORD VALUE]...) +([@var{LEVEL}] + [@var{KEY} [@var{DESCRIPTION}]] + @var{COMMAND}|@var{ARGUMENT} [@var{KEYWORD} @var{VALUE}]...) @end lisp @var{LEVEL}, @var{KEY} and @var{DESCRIPTION} can also be specified using the @var{KEYWORD}s @@ -1509,8 +1516,8 @@ the object's values just for the binding inside this transient. @itemize @item -@var{LEVEL} is the suffix level, an integer between 1 and 7. See -@ref{Enabling and Disabling Suffixes}. +@var{LEVEL} is the suffix level, an integer between 1 and 7. +@xref{Enabling and Disabling Suffixes}. @item KEY is the key binding, a string in the format returned by @@ -1584,7 +1591,7 @@ guessed based on the long argument. If the argument ends with @samp{=} Finally, details can be specified using optional @var{KEYWORD}-@var{VALUE} pairs. Each keyword has to be a keyword symbol, either @code{:class} or a keyword -argument supported by the constructor of that class. See @ref{Suffix Slots}. +argument supported by the constructor of that class. @xref{Suffix Slots}. If a keyword argument accepts a function as value, you an use a @code{lambda} expression. As a special case, the @code{##} macro (which returns a @code{lambda} @@ -1702,7 +1709,7 @@ should be used. @end defun @defun transient-get-value -This function returns the value of the current prefix. +This function returns the value of the extant prefix. This function is intended to be used when setting up a menu and its suffixes. It is not intended to be used when a suffix command is @@ -1934,8 +1941,8 @@ means that all outer prefixes are exited at once. @item The behavior for non-suffixes can be set for a particular prefix, by the prefix's @code{transient-non-suffix} slot to a boolean, a suitable -pre-command function, or a shorthand for such a function. See -@ref{Pre-commands for Non-Suffixes}. +pre-command function, or a shorthand for such a function. +@xref{Pre-commands for Non-Suffixes}. @item The common behavior for the suffixes of a particular prefix can be @@ -2260,7 +2267,7 @@ Transient itself provides a single class for prefix commands, @code{transient-prefix}, but package authors may wish to define specialized classes. Doing so makes it possible to change the behavior of the set of prefix commands that use that class, by implementing specialized -methods for certain generic functions (see @ref{Prefix Methods}). +methods for certain generic functions (@pxref{Prefix Methods}). A transient prefix command's object is stored in the @code{transient--prefix} property of the command symbol. While a transient is active, a clone @@ -2275,7 +2282,7 @@ object should not affect later invocations. @item All suffix and infix classes derive from @code{transient-suffix}, which in turn derives from @code{transient-child}, from which @code{transient-group} also -derives (see @ref{Group Classes}). +derives (@pxref{Group Classes}). @item All infix classes derive from the abstract @code{transient-infix} class, @@ -2283,13 +2290,13 @@ which in turn derives from the @code{transient-suffix} class. Infixes are a special type of suffixes. The primary difference is that infixes always use the @code{transient--do-stay} pre-command, while -non-infix suffixes use a variety of pre-commands (see @ref{Transient State}). Doing that is most easily achieved by using this class, +non-infix suffixes use a variety of pre-commands (@pxref{Transient State}). Doing that is most easily achieved by using this class, though theoretically it would be possible to define an infix class that does not do so. If you do that then you get to implement many methods. Also, infixes and non-infix suffixes are usually defined using -different macros (see @ref{Defining Suffix and Infix Commands}). +different macros (@pxref{Defining Suffix and Infix Commands}). @item Classes used for infix commands that represent arguments should @@ -2699,7 +2706,7 @@ secondary value, called a ``scope''. See @code{transient-define-prefix}. @code{transient-suffix}, @code{transient-non-suffix} and @code{transient-switch-frame} play a part when determining whether the currently active transient prefix command remains active/transient when a suffix or arbitrary -non-suffix command is invoked. See @ref{Transient State}. +non-suffix command is invoked. @xref{Transient State}. @item @code{refresh-suffixes} Normally suffix objects and keymaps are only setup @@ -2781,7 +2788,7 @@ of the same symbol. @item @code{level} The level of the prefix commands. The suffix commands whose -layer is equal or lower are displayed. See @ref{Enabling and Disabling Suffixes}. +layer is equal or lower are displayed. @pxref{Enabling and Disabling Suffixes}. @item @code{value} The likely outdated value of the prefix. Instead of accessing @@ -2805,15 +2812,15 @@ Here we document most of the slots that are only available for suffix objects. Some slots are shared by suffix and group objects, they are documented in @ref{Predicate Slots}. -Also see @ref{Suffix Classes}. +Also @xref{Suffix Classes}. @anchor{Slots of @code{transient-child}} @subheading Slots of @code{transient-child} This is the abstract superclass of @code{transient-suffix} and @code{transient-group}. -This is where the shared @code{if*} and @code{inapt-if*} slots (see @ref{Predicate Slots}), -the @code{level} slot (see @ref{Enabling and Disabling Suffixes}), and the @code{advice} -and @code{advice*} slots (see @ref{Slots of @code{transient-suffix}}) are defined. +This is where the shared @code{if*} and @code{inapt-if*} slots (@pxref{Predicate Slots}), +the @code{level} slot (@pxref{Enabling and Disabling Suffixes}), and the @code{advice} +and @code{advice*} slots (@pxref{Slots of @code{transient-suffix}}) are defined. @itemize @item @@ -2839,7 +2846,7 @@ which is useful for alignment purposes. @code{command} The command, a symbol. @item -@code{transient} Whether to stay transient. See @ref{Transient State}. +@code{transient} Whether to stay transient. @xref{Transient State}. @item @code{format} The format used to display the suffix in the menu buffer. @@ -3063,14 +3070,14 @@ currently cannot be invoked. By default these predicates run when the prefix command is invoked, but this can be changes, using the @code{refresh-suffixes} prefix slot. -See @ref{Prefix Slots}. +@xref{Prefix Slots}. One more slot is shared between group and suffix classes, @code{level}. Like the slots documented above, it is a predicate, but it is used for a different purpose. The value has to be an integer between 1 and 7. @code{level} controls whether a suffix or a group should be available depending on user preference. -See @ref{Enabling and Disabling Suffixes}. +@xref{Enabling and Disabling Suffixes}. @node FAQ @appendix FAQ diff --git a/etc/EGLOT-NEWS b/etc/EGLOT-NEWS index 3d78a835469..20c2208c54c 100644 --- a/etc/EGLOT-NEWS +++ b/etc/EGLOT-NEWS @@ -20,6 +20,71 @@ https://github.com/joaotavora/eglot/issues/1234. * Changes to upcoming Eglot +** File watch limits to prevent resource exhaustion (github#1568) + +The new variable 'eglot-max-file-watches' limits the number of file +watches that can be created. Some language servers request watching +for a very large number of directories (e.g. Python virtualenvs), which +can exhaust system resources and cause slow startup. + +** Support for complex workspace edits (create/rename/delete files) + +Eglot now advertises support for file resource operations in workspace +edits and can handle create, rename, and delete file operations. The +confirmation UI has been reworked to handle mixed operation types. + +The 'eglot-confirm-server-edits' defcustom has been overhauled and now +also accepts file operation kinds as keys in the alist form, providing +more fine-grained control over what confirmation mechanism to use. + +** 'eglot-advertise-cancellation' now defaults to t + +The variable 'eglot-advertise-cancellation' now defaults to t, which +means Eglot will send '$/cancelRequest' notifications to servers when it +thinks responses to inflight requests are no longer useful. The current +2026 LSP landscape (especially gopls and ocamllsp) suggests this is +beneficial and helps servers avoid costly useless work. + +** Imenu setup is more predictable (github#1569) + +Eglot now sets 'imenu-create-index-function' using ':override' advice, +making the integration cleaner and more predictable. + +** Fixed textDocument/prepareRename support (github#1554) + +Eglot now properly checks server capabilities before sending +prepareRename requests. + + +* Changes in Eglot 1.21 (11/1/2026) + +This is a bugfix release with small fixes for semantic tokens and Emacs +26.3 compatibility. + + +* Changes in Eglot 1.20 (11/1/2026) + +** Dramatically faster handling of files with many diagnostics + +Diagnostic conversion between LSP and Flymake versions is now much +faster. Previously, editing, e.g. a Python file with thousands of +diagnostics was next to impossible to to periodic interruptions of +diagnostic reports. Now it's practically unnoticeable. + +** Support for LSP server multiplexers via Rassumfrassum + +Eglot can now leverage LSP server multiplexer programs like Rassumfrassum +(invoked via the 'rass' command) to use multiple language servers in a +single buffer. This enables combining spell-checkers with language +servers, using multiple servers for the same language (e.g., 'ty' for +type checking and 'ruff' for linting in Python), or handling +multi-language files like Vue. + +Some invocations of 'rass' are offered as alternatives in the built-in +'eglot-server-programs' variable. The manual (readable with 'M-x +eglot-manual') contains a comprehensive discussion of how to set up and +use multiplexers in the new "Multi-server support" chapter. + ** Support for pull diagnostics (github#1559, github#1290) For servers supporting the 'diagnosticProvider' capability, Eglot @@ -28,6 +93,15 @@ requests diagnostics explicitly rather than relying on sporadic server is known to support the "pull" variant exclusively, while the 'ty' server is known to support it alongside "push". +** New command 'eglot-momentary-inlay-hints' + +When bound to a single key in 'eglot-mode-map' this will arrange for +inlay hints to be displayed as long as the key is held down, and then +hidden shortly after it is released. Emacs doesn't support binding to +\"key up\" events, but this function offers an approximation. It relies +on measuring your keyboard initial delay and repeat rate, and may not be +100% accurate. + ** Support for watching files outside the project (bug#79809) Eglot now supports and advertises the 'relativePatternSupport' @@ -45,6 +119,11 @@ controlling which token types and modifiers to consider, as well as faces for customizing their appearance. The minor mode is on by default: consult the manual on how to turn it off. +** Reading the Eglot manual in Emacs is easy again + +The command 'M-x eglot-manual' is now easier to reach and directly drops +the user into the manual. + * Changes in Eglot 1.19 (23/10/2025) diff --git a/etc/NEWS b/etc/NEWS index bd60249708c..1838a1ec3e5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -82,6 +82,13 @@ other directory on your system. You can also invoke the * Changes in Emacs 31.1 ++++ +** 'line-spacing' now supports specifying spacing above the line. +Previously, only spacing below the line could be specified. The variable +can now be set to a cons cell to specify spacing both above and below +the line, which allows for vertically centering text. + ++++ ** 'prettify-symbols-mode' attempts to ignore undisplayable characters. Previously, such characters would be rendered as, e.g., white boxes. @@ -199,6 +206,13 @@ different completion categories by customizing be updated as you type, or nil to suppress this always. Note that for large or inefficient completion tables this can slow down typing. ++++ +*** New optional value of 'minibuffer-visible-completions'. +If the value of this option is 'up-down', only the '' and '' +arrow keys move point between candidates shown in the "*Completions*" +buffer display, while '' and '' arrows move point in the +minibuffer window. + --- *** 'RET' chooses the completion selected with 'M-/M-'. If a completion candidate is selected with 'M-' or 'M-', @@ -402,11 +416,20 @@ for which you can use '(category . tex-shell)'. +++ *** New user option 'split-window-preferred-direction'. -Users can now choose in which direction Emacs tries to split first: -vertically or horizontally. The new default is to prefer to split -horizontally if the frame is landscape and vertically if it is portrait. -You can customize this option to 'vertical' to restore Emacs's old -behavior of always preferring vertical splits. +Functions called by 'display-buffer' split the selected window when they +need to create a new window. A window can be split either vertically, +one below the other, or horizontally, side by side. This new option +determines which direction will be tried first, when both directions are +possible according to the values of 'split-width-threshold' and +'split-height-threshold'. The default value is 'longest', which means +to prefer to split horizontally if the window's frame is a "landscape" +frame, and vertically if it is a "portrait" frame. (A frame is +considered to be "portrait" if its vertical dimension in pixels is +greater or equal to its horizontal dimension, otherwise it's considered +to be "landscape".) Previous versions of Emacs always tried to split +vertically first, so to get previous behavior, you can customize this +option to 'vertical'. The value 'horizontal' always prefers the +horizontal split. +++ *** New argument INDIRECT for 'get-buffer-window-list'. @@ -440,6 +463,12 @@ adjacent windows and subsequently operate on that parent. 'uncombine-window' can then be used to restore the window configuration to the state it had before running 'combine-windows'. ++++ +*** New function 'window-cursor-info'. +This function returns a vector of pixel-level information about the +physical cursor in a given window, including its type, coordinates, +dimensions, and ascent. + ** Frames +++ @@ -465,7 +494,7 @@ either resize the frame and change the fullscreen status accordingly or keep the frame size unchanged. The value t means to first reset the fullscreen status and then resize the frame. -*** New commands to set frame size and position in one compound step. +*** New functions to set frame size and position in one compound step. 'set-frame-size-and-position' sets the new size and position of a frame in one compound step. Both, size and position, can be specified as with the corresponding frame parameters 'width', 'height', 'left' and 'top'. @@ -482,6 +511,30 @@ frames into one of these frames and deletes the other one. Unlike with other frame names, an attempt to rename to "F" throws an error when a frame of that name already exists. ++++ +*** New frame parameters 'cloned-from' and 'undeleted'. +The frame parameter 'cloned-from' is set to the frame from which the new +frame is cloned using the command 'clone-frame'. + +The frame parameter 'undeleted' is set to t when a frame is undeleted +using the command 'undelete-frame'. + +These are useful if you need to detect a cloned frame or undeleted frame +in hooks like 'after-make-frame-functions' and +'server-after-make-frame-hook'. + +*** Frames now have unique ids and the new function 'frame-id'. +Each non-tooltip frame is assigned a unique integer id. This allows you +to unambiguously identify frames even if they share the same name or +title. When 'undelete-frame-mode' is enabled, each deleted frame's id +is stored for resurrection. The function 'frame-id' returns a frame's +id (in C, use the frame struct member 'id'). + +*** New commands 'select-frame-by-id', 'undelete-frame-by-id'. +The command 'select-frame-by-id' selects a frame by ID and undeletes it +if deleted. The command 'undelete-frame-by-id' undeletes a frame by its +ID. When called interactively, both functions prompt for an ID. + ** Mode Line +++ @@ -506,9 +559,10 @@ every buffer. ** Tab Bars and Tab Lines --- -*** New command 'merge-tabs'. -'merge-tabs' merges all windows from two tabs into one of these tabs -and closes the other tab. +*** New commands 'split-tab' and 'merge-tabs'. +'split-tab' moves a specified number of windows from an existing tab +to a newly-created tab. 'merge-tabs' merges all windows from two tabs +into one of these tabs and closes the other tab. --- *** New abnormal hook 'tab-bar-auto-width-functions'. @@ -666,6 +720,17 @@ project, during completion. That makes some items shorter. The category defaults are the same as for 'buffer' but any user customizations would need to be re-added. ++++ +*** 'project-mode-line' can now show project name only for local files. +If the value of 'project-mode-line' is 'non-remote', project name and +the Project menu will be shown on the mode line only for projects with +local files. + +** Help + ++++ +*** New keybinding 'C-h u' for 'apropos-user-option'. + ** IDLWAVE has been moved to GNU ELPA. The version bundled with Emacs is out-of-date, and is now marked as obsolete. Use 'M-x list-packages' to install the 'idlwave' package from @@ -749,6 +814,15 @@ Emacs previously discarded arguments to emacsclient of zero length, such as in 'emacsclient --eval "(length (pop server-eval-args-left))" ""'. These are no longer discarded. ++++ +** New user option 'xterm-update-cursor' to update cursor display on TTYs. +When enabled, Emacs sends Xterm escape sequences on Xterm-compatible +terminals to update the cursor's appearacse. Emacs can update the +cursor's shape and color. For example, if you use a purple bar cursor +on graphical displays then when this option is enabled Emacs will use a +purple bar cursor on compatible terminals as well. See the Info node +"(emacs) Cursor Display" for more information. + * Editing Changes in Emacs 31.1 @@ -896,6 +970,11 @@ These commands did not previously accept a prefix argument. Now a numeric prefix argument specifies a repeat count, just like it already did for 'undo'. +** New minor mode 'center-line-mode'. +This mode keeps modified lines centered horizontally according to the +value of 'fill-column', by calling 'center-line' on each non-empty line +of the modified region. + * Changes in Specialized Modes and Packages in Emacs 31.1 @@ -1039,11 +1118,11 @@ The new variable 'forward-comment-function' is set to the new function 'treesit-forward-comment' if a major mode defines the thing 'comment'. +++ -*** New function 'treesit-query-eagerly-compiled-p' +*** New function 'treesit-query-eagerly-compiled-p'. This function returns non-nil if a query was eagerly compiled. +++ -*** New function 'treesit-query-source' +*** New function 'treesit-query-source'. This function returns the string or sexp source query of a compiled query. +++ @@ -1135,8 +1214,9 @@ convention. Also, the ':match?' predicate can now take the regexp as either the first or second argument, so it works with both tree-sitter convention (regexp arg second) and Emacs convention (regexp arg first). +** Track changes + +++ -** Track-changes *** New variable 'track-changes-undo-only' to distinguish undo changes. ** Hideshow @@ -1152,7 +1232,7 @@ blocks. This command hides or shows all the blocks in the current buffer. --- -*** 'hs-hide-level' no longer hide all the blocks in the current buffer. +*** 'hs-hide-level' no longer hides all the blocks in the current buffer. If 'hs-hide-level' was not inside a code block it would hide all the blocks in the buffer like 'hs-hide-all'. Now it should only hide all the second level blocks. @@ -1208,10 +1288,9 @@ buffer-local variables 'hs-block-start-regexp', 'hs-c-start-regexp', 'hs-forward-sexp-function', etc. +++ -*** 'hs-hide-level' and 'hs-cycle' can now hide comments too. +*** 'hs-hide-level' can now hide comments too. This is controlled by 'hs-hide-comments-when-hiding-all'. - ** C-ts mode +++ @@ -1270,6 +1349,12 @@ available. Now method chaining is indented by 8 spaces rather than 4, and this option controls how much is indented for method chaining. +** JSON-ts mode + +*** New command 'json-ts-jq-path-at-point'. +This command copies the path of the JSON element at point to the +kill-ring, formatted for use with the 'jq' utility. + ** PHP-ts mode --- @@ -1321,6 +1406,13 @@ associated to a remote PHP file, show the remote PHP ini files. Rust number literals may have an optional type suffix. When this option is non-nil, this suffix is fontified using 'font-lock-type-face'. +** YAML-ts mode + +--- +*** New user option 'yaml-ts-mode-yamllint-options'. +Additional options for 'yamllint' the command used for Flymake's YAML +support. + ** EIEIO --- @@ -1626,7 +1718,6 @@ is the default. This user option is in sympathy with recentf, and savehist autosave timers. - ** Savehist --- @@ -1996,7 +2087,7 @@ for docstrings where symbols 'nil' and 't' are in quotes. In most cases, having it enabled leads to a large amount of false positives. -*** New file-local variable 'lisp-indent-local-overrides' +*** New file-local variable 'lisp-indent-local-overrides'. This variable can be used to locally override the indent specification of symbols. @@ -2008,6 +2099,14 @@ When you kill the IELM process with 'C-c C-c', the input history is now saved to the file specified by 'ielm-history-file-name', just like when you exit the Emacs session or kill the IELM buffer. +--- +*** New value 'point' for user option 'ielm-dynamic-return'. +When 'ielm-dynamic-return' is set to 'point', typing 'RET' has dynamic +behavior based on whether point is inside an sexp. While point is +inside an sexp typing 'RET' inserts a newline, and otherwise Emacs +proceeds with evaluating the expression. This is useful when +'electric-pair-mode', or a similar automatic pairing mode, is enabled. + ** DocView --- @@ -2038,6 +2137,14 @@ option 'doc-view-djvused-program'. The default value is now 30 seconds, as the old value was too short to allow reading the help text. ++++ +*** Ispell can now save spelling corrections as abbrevs. +In the Ispell command loop, type 'C-u' immediately before selecting a +replacement to toggle whether that correction will be saved as a global +abbrev expansion for its misspelling. The new user option +'ispell-save-corrections-as-abbrevs' determines whether abbrev saving +is enabled by default. + ** Flyspell --- @@ -2065,6 +2172,10 @@ connections after you close remote-file buffers without having to either cherry-pick via 'tramp-cleanup-connection' or clear them all via 'tramp-cleanup-all-connections'. ++++ +*** External methods can now be used in multi-hop connections. +This is implemented for 'tramp-sh' methods, like "/scp:user@host|sudo::". + +++ *** New command 'tramp-dired-find-file-with-sudo'. This command, bound to '@' in Dired, visits the file or directory on the @@ -2445,7 +2556,7 @@ appearance of the list can be customized with the new faces +++ *** Printing root branch logs has moved to 'C-x v b L'. -Previously the command to print the root log for a branch was bound to +Previously, the command to print the root log for a branch was bound to 'C-x v b l'. It has now been renamed from 'vc-print-branch-log' to 'vc-print-root-branch-log', and bound to 'C-x v b L'. This is more consistent with the rest of the 'C-x v' keymap, and makes room for a new @@ -2508,8 +2619,15 @@ cloning, or prompts for that, too. When the argument is non-nil, the function switches to a buffer visiting the directory into which the repository was cloned. ++++ +*** 'vc-revert' is now bound to '@' in VC-Dir. + ++++ +*** 'vc-revert' is now additionally bound to 'C-x v @'. +This is in addition to 'C-x v u'. + --- -*** 'C-x v u' ('vc-revert') now works on directories listed in VC Directory. +*** 'vc-revert' now works on directories listed in VC Directory. Reverting a directory means reverting changes to all files inside it. +++ @@ -2625,8 +2743,8 @@ relevant buffers before generating the contents of a VC Directory buffer *** New commands to report incoming and outgoing diffs. 'vc-root-diff-incoming' and 'vc-root-diff-outgoing' report diffs of all the changes that would be pulled and would be pushed, respectively. -They are the diff analogues of the existing commands 'vc-log-incoming' -and 'vc-log-outgoing'. +They are the diff analogues of the existing commands +'vc-root-log-incoming' and 'vc-root-log-outgoing'. In particular, 'vc-root-diff-outgoing' is useful as a way to preview your push and ensure that all and only the changes you intended to @@ -2636,12 +2754,15 @@ include were committed and will be pushed. current VC fileset. +++ -*** New commands to report diffs of outstanding changes. -'C-x v o =' ('vc-diff-outgoing-base') and 'C-x v o D' +*** New commands to report information about outstanding changes. +'C-x v T =' ('vc-diff-outgoing-base') and 'C-x v T D' ('vc-root-diff-outgoing-base') report diffs of changes since the merge base with the remote branch, including uncommitted changes. -They are useful to view all outstanding (unmerged, unpushed) changes on -the current branch. +'C-x v T l' ('vc-log-outgoing-base') and 'C-x v T L' +('vc-root-log-outgoing-base') show the corresponding revision logs. +These are useful to view all outstanding (unmerged, unpushed) changes on +the current branch. They are also available as 'T =', 'T D', 'T l' and +'T L' in VC-Dir buffers. +++ *** New user option 'vc-use-incoming-outgoing-prefixes'. @@ -2649,16 +2770,16 @@ If this is customized to non-nil, 'C-x v I' and 'C-x v O' become prefix commands, such that the new incoming and outgoing commands have global bindings: -- 'C-x v I L' is bound to 'vc-log-incoming' +- 'C-x v I L' is bound to 'vc-root-log-incoming' - 'C-x v I D' is bound to 'vc-root-diff-incoming' -- 'C-x v O L' is bound to 'vc-log-outgoing' +- 'C-x v O L' is bound to 'vc-root-log-outgoing' - 'C-x v O D' is bound to 'vc-root-diff-outgoing'. +++ *** New display of outgoing revisions count in VC Directory. If there are outgoing revisions, VC Directory now includes a count of how many in its headers, to remind you to push them. -You can disable this by customizing vc-dir-show-outgoing-count to nil. +You can disable this by customizing 'vc-dir-show-outgoing-count' to nil. +++ *** New user option 'vc-async-checkin' to enable async checkin operations. @@ -2748,6 +2869,13 @@ already have, consider replacing the default global bindings, like this: --- *** New command alias 'vc-restore' for 'vc-revert'. +--- +*** The 'diff-restrict-view' command is disabled by default. +This command is Diff mode's specialized 'narrow-to-region'. +'narrow-to-region' has long been disabled by default, so for +consistency, 'diff-restrict-view' is now too. +To enable it again, use 'M-x enable-command'. + ** Package +++ @@ -2783,6 +2911,11 @@ When called from Lisp, it now only accepts a symbol. When invoking the command in a Dired buffer with marked files, the command will only copy those files. +--- +*** 'package-isolate' can now also install packages. +If a package is missing, 'package-isolate' will fetch the missing +tarballs and prepare them to be activated in the sub-process. + +++ *** package-x.el is now obsolete. @@ -2806,6 +2939,14 @@ packages. --- *** Uninstalling a package now removes its directory from 'load-path'. ++++ +*** Packages can be reviewed before installation or upgrade. +The user option 'package-review-policy' can configure which packages +the user should be allowed to review before any processing takes place. +The package review can include reading the downloaded source code, +presenting a diff between the downloaded code and a previous +installation or displaying a ChangeLog. + ** Rcirc +++ @@ -2916,6 +3057,10 @@ Meant to be given a global binding convenient to the user. Example: ** Icomplete +*** New key 'M-j' for 'icomplete-mode' and 'icomplete-vertical-mode'. +Like 'M-j' in 'fido-mode', it can exit the minibuffer with a selected +candidate even when 'icomplete-show-matches-on-no-input' is non-nil. + *** New user options for 'icomplete-vertical-mode'. New user options have been added to enhance 'icomplete-vertical-mode': @@ -3294,7 +3439,7 @@ the source, or to 'antlr-v3' otherwise. *** New command 'antlr-v4-mode' is a derived mode of 'antlr-mode'. It sets 'antlr-tool-version' to value 'antlr-v4', and is automatically -used for files with extension "g4". +used for files with extension ".g4". *** The variable 'antlr-language' is now used more generally. The variable has a symbol as value which determines which of the @@ -3307,8 +3452,8 @@ ObjC, Python and Ruby, additional to Java and Cpp. *** New user option 'antlr-run-tool-on-buffer-file'. Command 'antlr-run-tool' now usually runs on the file for the current -buffer. Customize this user option to have value ' nil' to get the -previous behavior back. +buffer. Customize this user option to nil to get the previous behavior +back. ** Hi Lock @@ -3318,6 +3463,10 @@ If an active region exists, the commands 'hi-lock-line-face-buffer' and 'hi-lock-face-phrase-buffer' now use its contents as their default value. Previously, only 'hi-lock-face-buffer' supported this. +** Shadowfile + +*** 'shadow-info-buffer' and 'shadow-todo-buffer' use ephemeral buffer names now. + * New Modes and Packages in Emacs 31.1 @@ -3479,8 +3628,8 @@ separator, are also supported. --- ** The experimental variable 'binary-as-unsigned' has been removed. -Instead of (let ((binary-as-unsigned t)) (format "%x" N)) you can use -(format "%x" (logand N MASK)) where MASK is for the desired word size, +Instead of '(let ((binary-as-unsigned t)) (format "%x" N))' you can use +'(format "%x" (logand N MASK))' where MASK is for the desired word size, e.g., #x3fffffffffffffff for typical Emacs fixnums. +++ @@ -3530,6 +3679,11 @@ and other similar functions. * Lisp Changes in Emacs 31.1 ++++ +** New function 'garbage-collect-heapsize'. +Same as 'garbage-collect' but just returns the info from the last GC +without performing a collection. + +++ ** Improve 'replace-region-contents' to accept more forms of sources. It has been promoted from 'subr-x' to the C code. @@ -3661,12 +3815,21 @@ without marking it as automatically buffer-local. ** The obsolete face attribute ':reverse-video' has been removed. Use ':inverse-video' instead. +** D-Bus + +++ -** Support interactive D-Bus authorization. +*** Support interactive D-Bus authorization. A new ':authorizable t' parameter has been added to 'dbus-call-method' and 'dbus-call-method-asynchronously' to allow the user to interactively authorize the invoked D-Bus method (for example via polkit). ++++ +*** New D-Bus functions to support systemd inhibitor locks. +The functions 'dbus-make-inhibitor-lock', 'dbus-close-inhibitor-lock' +and 'dbus-registered-inhibitor-locks' implement acquiring and releasing +systemd inhibitor locks. See the Info node "(dbus) Inhibitor Locks" for +details. + ** The customization group 'wp' has been removed. It has been obsolete since Emacs 26.1. Use the group 'text' instead. @@ -3770,6 +3933,13 @@ Binding 'inhibit-message' to a non-nil value will now suppress both the display of messages and the clearing of the echo area, such as caused by calling 'message' with a nil argument. +--- +** 'minibuffer-message' no longer blocks while displaying message. +'minibuffer-message' now uses a timer to clear the message printed to +the minibuffer, instead of waiting with 'sit-for' and then clearing it. +This makes 'minibuffer-message' usable in Lisp programs which want to +print a message and then continue to perform work. + ** Special Events +++ @@ -3837,14 +4007,23 @@ When the theme is set on PGTK, Android, or MS-Windows systems, variable 'toolkit-theme' as either symbol 'dark' or 'light', but may be extended to encompass other toolkit-specific symbols in the future. +** Progress reporter + +++ -** Progress reporter callbacks. +*** Progress reporter callbacks. 'make-progress-reporter' now accepts optional arguments UPDATE-CALLBACK, called on progress steps, and DONE-CALLBACK, called when the progress reporter is done. See the 'make-progress-reporter' docstring for a full specification of these new optional arguments. -** Add binary format specifications '%b' and '%B'. ++++ +*** Progress reporter context. +'make-progress-reporter' now accepts the optional argument CONTEXT, +which if it is the symbol 'async', inhibits updates in the echo area +when it is busy. This is useful, for example, if you want to monitor progress +of an inherently asynchronous command such as 'compile'. + +** Binary format specifications '%b' and '%B' added. These produce the binary representation of a number. '%#b' and '%#B' prefix the bits with '0b' and '0B', respectively. diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 5d8ce5bcf52..340e99c0425 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -1382,6 +1382,19 @@ these problems by disabling XIM in your X resources: Emacs.useXIM: false +** When the compose key is pressed, a small window appears that won't go away + +In some circumstances, pressing the compose key under X pops up a small +character-selection window next to the cursor, which can be moved but +not closed; it disappears when some window manager operation is +performed, like creating or deleting a window. You can prevent this +window from appearing by completely disabling the X input method (XIM). +If this is acceptable to you, you should set the 'XMODIFIERS' +environment variable to the value '@im=none', and export it before +calling Emacs, for example by invoking Emacs like so: + + env XMODIFIERS=@im=none emacs + ** On Haiku, BeCJK doesn't work properly with Emacs Some popular Haiku input methods such BeCJK are known to behave badly diff --git a/etc/tutorials/TUTORIAL.fr b/etc/tutorials/TUTORIAL.fr index 58bc91198c1..1d94f3b9911 100644 --- a/etc/tutorials/TUTORIAL.fr +++ b/etc/tutorials/TUTORIAL.fr @@ -240,7 +240,7 @@ de M-v. Si vous utilisez un environnement graphique, comme X11 ou MS-Windows, il devrait y avoir une zone rectangulaire appelée barre de défilement, -ou « scrollbar » sur le bord gauche de la fenêtre d'Emacs. Vous pouvez +ou « scrollbar » sur le bord droit de la fenêtre d'Emacs. Vous pouvez faire défiler le texte en cliquant avec la souris dans cette barre de défilement. diff --git a/etc/tutorials/TUTORIAL.translators b/etc/tutorials/TUTORIAL.translators index e81e6c665f4..2b1444b13b8 100644 --- a/etc/tutorials/TUTORIAL.translators +++ b/etc/tutorials/TUTORIAL.translators @@ -39,6 +39,7 @@ Maintainer: Mohsen BANAN * TUTORIAL.fr: Author: Éric Jacoboni Maintainer: Éric Jacoboni + Bastien Guerry * TUTORIAL.he Author: Eli Zaretskii diff --git a/lib/alloca.in.h b/lib/alloca.in.h index 06d585d8d9a..bb2cb881619 100644 --- a/lib/alloca.in.h +++ b/lib/alloca.in.h @@ -1,7 +1,7 @@ /* Memory allocation on the stack. - Copyright (C) 1995, 1999, 2001-2004, 2006-2026 Free Software - Foundation, Inc. + Copyright (C) 1995, 1999, 2001-2004, 2006-2026 Free Software Foundation, + Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/binary-io.h b/lib/binary-io.h index 78f38127382..37eb3c4bb18 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -1,6 +1,5 @@ /* Binary mode I/O. - Copyright (C) 2001, 2003, 2005, 2008-2026 Free Software Foundation, - Inc. + Copyright (C) 2001, 2003, 2005, 2008-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/c-ctype.h b/lib/c-ctype.h index 1d9fba13fc5..e3448a4376b 100644 --- a/lib/c-ctype.h +++ b/lib/c-ctype.h @@ -5,8 +5,7 @@ functions' behaviour depends on the current locale set via setlocale. - Copyright (C) 2000-2003, 2006, 2008-2026 Free Software Foundation, - Inc. + Copyright (C) 2000-2003, 2006, 2008-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c index e534f8e87a9..2e7f5405252 100644 --- a/lib/c-strcasecmp.c +++ b/lib/c-strcasecmp.c @@ -1,6 +1,5 @@ /* c-strcasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c index e16d33441fa..0fe570ae476 100644 --- a/lib/c-strncasecmp.c +++ b/lib/c-strncasecmp.c @@ -1,6 +1,5 @@ /* c-strncasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/careadlinkat.c b/lib/careadlinkat.c index 1e2ee8a52e1..fa19e09986c 100644 --- a/lib/careadlinkat.c +++ b/lib/careadlinkat.c @@ -1,7 +1,7 @@ /* Read symbolic links into a buffer without size limitation, relative to fd. - Copyright (C) 2001, 2003-2004, 2007, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 2001, 2003-2004, 2007, 2009-2026 Free Software Foundation, + Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/cloexec.c b/lib/cloexec.c index c546da0e715..3d4f916b0f4 100644 --- a/lib/cloexec.c +++ b/lib/cloexec.c @@ -1,7 +1,6 @@ /* cloexec.c - set or clear the close-on-exec descriptor flag - Copyright (C) 1991, 2004-2006, 2009-2026 Free Software Foundation, - Inc. + Copyright (C) 1991, 2004-2006, 2009-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/close-stream.c b/lib/close-stream.c index 3c19ba63849..0dc79569029 100644 --- a/lib/close-stream.c +++ b/lib/close-stream.c @@ -1,7 +1,6 @@ /* Close a stream, with nicer error checking than fclose's. - Copyright (C) 1998-2002, 2004, 2006-2026 Free Software Foundation, - Inc. + Copyright (C) 1998-2002, 2004, 2006-2026 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/diffseq.h b/lib/diffseq.h index a5ae7a46af0..cf710a316f8 100644 --- a/lib/diffseq.h +++ b/lib/diffseq.h @@ -1,7 +1,7 @@ /* Analyze differences between two vectors. - Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2026 Free - Software Foundation, Inc. + Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2026 Free Software + Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/dup2.c b/lib/dup2.c index 6d46f322b5c..b9a55263be4 100644 --- a/lib/dup2.c +++ b/lib/dup2.c @@ -1,7 +1,6 @@ /* Duplicate an open file descriptor to a specified file descriptor. - Copyright (C) 1999, 2004-2007, 2009-2026 Free Software Foundation, - Inc. + Copyright (C) 1999, 2004-2007, 2009-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/filemode.h b/lib/filemode.h index 36111daf6b0..22fe84b92be 100644 --- a/lib/filemode.h +++ b/lib/filemode.h @@ -1,7 +1,7 @@ /* Make a string describing file modes. - Copyright (C) 1998-1999, 2003, 2006, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 1998-1999, 2003, 2006, 2009-2026 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/fpending.c b/lib/fpending.c index ce16f92841d..58c32d499af 100644 --- a/lib/fpending.c +++ b/lib/fpending.c @@ -1,6 +1,6 @@ /* fpending.c -- return the number of pending output bytes on a stream - Copyright (C) 2000, 2004, 2006-2007, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 2000, 2004, 2006-2007, 2009-2026 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/fpending.h b/lib/fpending.h index 4163d34f66c..aeb1d9310d8 100644 --- a/lib/fpending.h +++ b/lib/fpending.h @@ -1,7 +1,7 @@ /* Declare __fpending. - Copyright (C) 2000, 2003, 2005-2006, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 2000, 2003, 2005-2006, 2009-2026 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/fsusage.c b/lib/fsusage.c index 73916d7e74c..1700a19c996 100644 --- a/lib/fsusage.c +++ b/lib/fsusage.c @@ -1,7 +1,7 @@ /* fsusage.c -- return space usage of mounted file systems - Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2026 Free - Software Foundation, Inc. + Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2026 Free Software + Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/getdelim.c b/lib/getdelim.c index e16acf8c64b..21f3abc294c 100644 --- a/lib/getdelim.c +++ b/lib/getdelim.c @@ -92,54 +92,56 @@ getdelim (char **lineptr, size_t *n, int delimiter, FILE *fp) *lineptr = new_lineptr; } - size_t cur_len = 0; - for (;;) - { - int i; + { + size_t cur_len = 0; + for (;;) + { + int i; - i = getc_maybe_unlocked (fp); - if (i == EOF) - { - result = -1; + i = getc_maybe_unlocked (fp); + if (i == EOF) + { + result = -1; + break; + } + + /* Make enough space for len+1 (for final NUL) bytes. */ + if (cur_len + 1 >= *n) + { + size_t needed_max = + SSIZE_MAX < SIZE_MAX ? (size_t) SSIZE_MAX + 1 : SIZE_MAX; + size_t needed = 2 * *n + 1; /* Be generous. */ + + if (needed_max < needed) + needed = needed_max; + if (cur_len + 1 >= needed) + { + result = -1; + errno = EOVERFLOW; + goto unlock_return; + } + + char *new_lineptr = (char *) realloc (*lineptr, needed); + if (new_lineptr == NULL) + { + alloc_failed (); + result = -1; + goto unlock_return; + } + + *lineptr = new_lineptr; + *n = needed; + } + + (*lineptr)[cur_len] = i; + cur_len++; + + if (i == delimiter) break; - } - - /* Make enough space for len+1 (for final NUL) bytes. */ - if (cur_len + 1 >= *n) - { - size_t needed_max = - SSIZE_MAX < SIZE_MAX ? (size_t) SSIZE_MAX + 1 : SIZE_MAX; - size_t needed = 2 * *n + 1; /* Be generous. */ - - if (needed_max < needed) - needed = needed_max; - if (cur_len + 1 >= needed) - { - result = -1; - errno = EOVERFLOW; - goto unlock_return; - } - - char *new_lineptr = (char *) realloc (*lineptr, needed); - if (new_lineptr == NULL) - { - alloc_failed (); - result = -1; - goto unlock_return; - } - - *lineptr = new_lineptr; - *n = needed; - } - - (*lineptr)[cur_len] = i; - cur_len++; - - if (i == delimiter) - break; - } - (*lineptr)[cur_len] = '\0'; - result = cur_len ? cur_len : result; + } + (*lineptr)[cur_len] = '\0'; + result = cur_len ? cur_len : result; + } unlock_return: funlockfile (fp); /* doesn't set errno */ diff --git a/lib/getgroups.c b/lib/getgroups.c index 77494be91e2..ec20b1a8456 100644 --- a/lib/getgroups.c +++ b/lib/getgroups.c @@ -1,7 +1,6 @@ /* provide consistent interface to getgroups for systems that don't allow N==0 - Copyright (C) 1996, 1999, 2003, 2006-2026 Free Software Foundation, - Inc. + Copyright (C) 1996, 1999, 2003, 2006-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/getloadavg.c b/lib/getloadavg.c index 6ec41dd8cb2..73b2ee28f36 100644 --- a/lib/getloadavg.c +++ b/lib/getloadavg.c @@ -1,7 +1,7 @@ /* Get the system load averages. - Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2026 Free - Software Foundation, Inc. + Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2026 Free Software + Foundation, Inc. NOTE: The canonical source of this file is maintained with gnulib. Bugs can be reported to bug-gnulib@gnu.org. diff --git a/lib/gettime.c b/lib/gettime.c index 14049fce8b9..edd1cdb02b5 100644 --- a/lib/gettime.c +++ b/lib/gettime.c @@ -1,7 +1,6 @@ /* gettime -- get the system clock - Copyright (C) 2002, 2004-2007, 2009-2026 Free Software Foundation, - Inc. + Copyright (C) 2002, 2004-2007, 2009-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c index 43493198df4..f236c427fd1 100644 --- a/lib/gettimeofday.c +++ b/lib/gettimeofday.c @@ -1,7 +1,6 @@ /* Provide gettimeofday for systems that don't have it or for which it's broken. - Copyright (C) 2001-2003, 2005-2007, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index 28158e521f4..33d8d5ad367 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -951,6 +951,7 @@ HAVE_SYS_ENDIAN_H = @HAVE_SYS_ENDIAN_H@ HAVE_SYS_INTTYPES_H = @HAVE_SYS_INTTYPES_H@ HAVE_SYS_LOADAVG_H = @HAVE_SYS_LOADAVG_H@ HAVE_SYS_PARAM_H = @HAVE_SYS_PARAM_H@ +HAVE_SYS_PROCESS_H = @HAVE_SYS_PROCESS_H@ HAVE_SYS_RANDOM_H = @HAVE_SYS_RANDOM_H@ HAVE_SYS_SELECT_H = @HAVE_SYS_SELECT_H@ HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@ @@ -3644,6 +3645,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's|@''HAVE_STRTOULL''@|$(HAVE_STRTOULL)|g' \ -e 's|@''HAVE_STRUCT_RANDOM_DATA''@|$(HAVE_STRUCT_RANDOM_DATA)|g' \ -e 's|@''HAVE_SYS_LOADAVG_H''@|$(HAVE_SYS_LOADAVG_H)|g' \ + -e 's|@''HAVE_SYS_PROCESS_H''@|$(HAVE_SYS_PROCESS_H)|g' \ -e 's|@''HAVE_UNLOCKPT''@|$(HAVE_UNLOCKPT)|g' \ -e 's|@''HAVE_DECL_UNSETENV''@|$(HAVE_DECL_UNSETENV)|g' \ < $@-t1 > $@-t2 diff --git a/lib/group-member.c b/lib/group-member.c index 67dd420b196..b9942c3882a 100644 --- a/lib/group-member.c +++ b/lib/group-member.c @@ -1,7 +1,7 @@ /* group-member.c -- determine whether group id is in calling user's group list - Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2026 Free - Software Foundation, Inc. + Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2026 Free Software + Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/malloc.c b/lib/malloc.c index 0948f5a50f5..f7d11921aeb 100644 --- a/lib/malloc.c +++ b/lib/malloc.c @@ -1,7 +1,6 @@ /* malloc() function that is glibc compatible. - Copyright (C) 1997-1998, 2006-2007, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 1997-1998, 2006-2007, 2009-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/md5-stream.c b/lib/md5-stream.c index c4c1fc2f53d..96b92374c1d 100644 --- a/lib/md5-stream.c +++ b/lib/md5-stream.c @@ -1,7 +1,7 @@ /* Functions to compute MD5 message digest of files or memory blocks. according to the definition of MD5 in RFC 1321 from April 1992. - Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2026 Free - Software Foundation, Inc. + Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2026 Free Software + Foundation, Inc. This file is part of the GNU C Library. This file is free software: you can redistribute it and/or modify diff --git a/lib/md5.c b/lib/md5.c index 4aa3e756b0c..4b0bc59acf7 100644 --- a/lib/md5.c +++ b/lib/md5.c @@ -1,7 +1,7 @@ /* Functions to compute MD5 message digest of files or memory blocks. according to the definition of MD5 in RFC 1321 from April 1992. - Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2026 Free - Software Foundation, Inc. + Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2026 Free Software + Foundation, Inc. This file is part of the GNU C Library. This file is free software: you can redistribute it and/or modify diff --git a/lib/md5.h b/lib/md5.h index 29a4c735d87..16c6684b61b 100644 --- a/lib/md5.h +++ b/lib/md5.h @@ -1,7 +1,7 @@ /* Declaration of functions and data types used for MD5 sum computing library functions. - Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2026 Free - Software Foundation, Inc. + Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2026 Free Software + Foundation, Inc. This file is part of the GNU C Library. This file is free software: you can redistribute it and/or modify diff --git a/lib/memmem.c b/lib/memmem.c index 1ae62a666fa..6c57a5450db 100644 --- a/lib/memmem.c +++ b/lib/memmem.c @@ -1,5 +1,5 @@ -/* Copyright (C) 1991-1994, 1996-1998, 2000, 2004, 2007-2026 Free - Software Foundation, Inc. +/* Copyright (C) 1991-1994, 1996-1998, 2000, 2004, 2007-2026 Free Software + Foundation, Inc. This file is part of the GNU C Library. This file is free software: you can redistribute it and/or modify diff --git a/lib/memrchr.c b/lib/memrchr.c index 4f585b53590..a7683c9aea1 100644 --- a/lib/memrchr.c +++ b/lib/memrchr.c @@ -1,7 +1,7 @@ /* memrchr -- find the last occurrence of a byte in a memory block - Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2026 Free - Software Foundation, Inc. + Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2026 Free Software + Foundation, Inc. Based on strlen implementation by Torbjorn Granlund (tege@sics.se), with help from Dan Sahlin (dan@sics.se) and diff --git a/lib/nanosleep.c b/lib/nanosleep.c index dc22e8ecdc6..a7abb530588 100644 --- a/lib/nanosleep.c +++ b/lib/nanosleep.c @@ -1,7 +1,6 @@ /* Provide a replacement for the POSIX nanosleep function. - Copyright (C) 1999-2000, 2002, 2004-2026 Free Software Foundation, - Inc. + Copyright (C) 1999-2000, 2002, 2004-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/nproc.c b/lib/nproc.c index 58e45e4e385..b0c9514115b 100644 --- a/lib/nproc.c +++ b/lib/nproc.c @@ -405,7 +405,7 @@ get_cgroup2_cpu_quota (void) if (! fp) return cpu_quota; - /* Get our cgroupv2 (unififed) hierarchy. */ + /* Get our cgroupv2 (unified) hierarchy. */ char *cgroup = NULL; char *cgroup_str = NULL; size_t cgroup_size = 0; diff --git a/lib/save-cwd.c b/lib/save-cwd.c index b1e55067327..ca52f72a90c 100644 --- a/lib/save-cwd.c +++ b/lib/save-cwd.c @@ -5,7 +5,7 @@ This program 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 + the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, @@ -45,10 +45,10 @@ the getcwd-lgpl module, but to be truly robust, use the getcwd module. Some systems lack fchdir altogether: e.g., OS/2, pre-2001 Cygwin, - SCO Xenix. Also, SunOS 4 and Irix 5.3 provide the function, yet it - doesn't work for partitions on which auditing is enabled. If - you're still using an obsolete system with these problems, please - send email to the maintainer of this code. */ + SCO Xenix. Also, SunOS 4 provides the function, yet it doesn't work + for partitions on which auditing is enabled. If you're still using + an obsolete system with these problems, please send email to the + maintainer of this code. */ #if !defined HAVE_FCHDIR && !defined fchdir # define fchdir(fd) (-1) @@ -57,10 +57,11 @@ int save_cwd (struct saved_cwd *cwd) { - cwd->desc = open (".", O_SEARCH | O_CLOEXEC); /* The 'name' member is present only to minimize differences from - gnulib. Initialize it to zero, if only to simplify debugging. */ - cwd->name = 0; + gnulib. Initialize it to NULL, if only to simplify debugging. */ + cwd->name = NULL; + + cwd->desc = open (".", O_SEARCH | O_CLOEXEC); return 0; } diff --git a/lib/save-cwd.h b/lib/save-cwd.h index 7ad4f9e8b9f..2084c68328a 100644 --- a/lib/save-cwd.h +++ b/lib/save-cwd.h @@ -1,7 +1,7 @@ /* Save and restore current working directory. - Copyright (C) 1995, 1997-1998, 2003, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 1995, 1997-1998, 2003, 2009-2026 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/sha1.c b/lib/sha1.c index 1057642a178..f41bda875db 100644 --- a/lib/sha1.c +++ b/lib/sha1.c @@ -1,8 +1,7 @@ /* sha1.c - Functions to compute SHA1 message digest of files or memory blocks according to the NIST specification FIPS-180-1. - Copyright (C) 2000-2001, 2003-2006, 2008-2026 Free Software - Foundation, Inc. + Copyright (C) 2000-2001, 2003-2006, 2008-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/sig2str.c b/lib/sig2str.c index 5bc7eae54d2..da54234ac48 100644 --- a/lib/sig2str.c +++ b/lib/sig2str.c @@ -1,7 +1,6 @@ /* sig2str.c -- convert between signal names and numbers - Copyright (C) 2002, 2004, 2006, 2009-2026 Free Software Foundation, - Inc. + Copyright (C) 2002, 2004, 2006, 2009-2026 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/stdckdint.in.h b/lib/stdckdint.in.h index ac12fd6c7ff..1989f7b8319 100644 --- a/lib/stdckdint.in.h +++ b/lib/stdckdint.in.h @@ -47,7 +47,7 @@ These are like the standard macros introduced in C23, except that arguments should not have side effects. The C++26 standard is - expected to add this header and it's macros. */ + expected to add this header and its macros. */ # define ckd_add(r, a, b) ((bool) _GL_INT_ADD_WRAPV (a, b, r)) # define ckd_sub(r, a, b) ((bool) _GL_INT_SUBTRACT_WRAPV (a, b, r)) diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index 4f4de503bec..95237f2a5cb 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -1,7 +1,6 @@ /* A GNU-like . - Copyright (C) 1995, 2001-2004, 2006-2026 Free Software Foundation, - Inc. + Copyright (C) 1995, 2001-2004, 2006-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as @@ -71,6 +70,11 @@ # include #endif +/* QNX declares getprogname() in . */ +#if (@GNULIB_GETPROGNAME@ || defined GNULIB_POSIXCHECK) && @HAVE_SYS_PROCESS_H@ +# include +#endif + /* Native Windows platforms declare _mktemp() in . */ #if defined _WIN32 && !defined __CYGWIN__ # include diff --git a/lib/strftime.c b/lib/strftime.c index a3909a36c89..8d32023729c 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -316,7 +316,7 @@ typedef sbyte_count_t retval_t; else if (to_uppcase) \ for (byte_count_t _i = 0; _i < _n; _i++) \ FPUTC (TOUPPER ((UCHAR_T) _s[_i], loc), p); \ - else if (fwrite (_s, _n, 1, p) == 0) \ + else if (_n && fwrite (_s, _n, 1, p) == 0) \ return FAILURE; \ } \ while (0) \ diff --git a/lib/strtoimax.c b/lib/strtoimax.c index b651d72dfa9..d130e4afa9f 100644 --- a/lib/strtoimax.c +++ b/lib/strtoimax.c @@ -1,7 +1,7 @@ /* Convert string representation of a number into an intmax_t value. - Copyright (C) 1999, 2001-2004, 2006, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 1999, 2001-2004, 2006, 2009-2026 Free Software Foundation, + Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lib/strtol.c b/lib/strtol.c index 244fe9b5e3c..12a64b1c5a7 100644 --- a/lib/strtol.c +++ b/lib/strtol.c @@ -1,7 +1,7 @@ /* Convert string representation of a number into an integer value. - Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2026 Free - Software Foundation, Inc. + Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2026 Free Software + Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@gnu.org. diff --git a/lib/strtoll.c b/lib/strtoll.c index 2b030c9bf66..e8876f98152 100644 --- a/lib/strtoll.c +++ b/lib/strtoll.c @@ -1,6 +1,6 @@ /* Function to parse a 'long long int' from text. - Copyright (C) 1995-1997, 1999, 2001, 2009-2026 Free Software - Foundation, Inc. + Copyright (C) 1995-1997, 1999, 2001, 2009-2026 Free Software Foundation, + Inc. This file is part of the GNU C Library. This file is free software: you can redistribute it and/or modify diff --git a/lib/time_r.c b/lib/time_r.c index b350d70a3cf..dfc427f6679 100644 --- a/lib/time_r.c +++ b/lib/time_r.c @@ -1,7 +1,6 @@ /* Reentrant time functions like localtime_r. - Copyright (C) 2003, 2006-2007, 2010-2026 Free Software Foundation, - Inc. + Copyright (C) 2003, 2006-2007, 2010-2026 Free Software Foundation, Inc. This file is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 2f1a0251183..972448fe545 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -465,7 +465,7 @@ When `outline-minor-mode' is enabled and point is on the outline heading line, this command will unmark all entries in the outline." (interactive "P" Buffer-menu-mode) (cond ((tabulated-list-get-id) - (Buffer-menu--unmark) + (Buffer-menu--unmark ?\r) (forward-line (if backup -1 1))) ((and (bound-and-true-p outline-minor-mode) (outline-on-heading-p)) (let ((old-pos (point)) @@ -488,11 +488,7 @@ When called interactively prompt for MARK; RET remove all marks." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (when-let* ((entry (tabulated-list-get-entry))) - (let ((xmarks (list (aref entry 0) (aref entry 2)))) - (when (or (char-equal mark ?\r) - (member (char-to-string mark) xmarks)) - (Buffer-menu--unmark)))) + (Buffer-menu--unmark mark) (forward-line)))) (defun Buffer-menu-unmark-all () @@ -506,15 +502,22 @@ When called interactively prompt for MARK; RET remove all marks." (forward-line -1) (while (and (not (tabulated-list-get-id)) (not (bobp))) (forward-line -1)) - (if (tabulated-list-get-id) (Buffer-menu--unmark))) + (if (tabulated-list-get-id) (Buffer-menu--unmark ?\r))) -(defun Buffer-menu--unmark () - (tabulated-list-set-col 0 " " t) - (let ((buf (Buffer-menu-buffer))) - (when buf - (if (buffer-modified-p buf) - (tabulated-list-set-col 2 "*" t) - (tabulated-list-set-col 2 " " t))))) +(defun Buffer-menu--unmark (mark) + "Remove MARK in current entry. +If MARK is \\`RET' remove all marks." + (when-let* ((entry (tabulated-list-get-entry))) + ;; A mark could appear in column 0 or 2. + (dolist (col '(0 2)) + (when (or (char-equal mark ?\r) + (char-equal mark (string-to-char (aref entry col)))) + (tabulated-list-set-col col " " t))) + ;; Reset modified mark in column 2. + (let ((buf (Buffer-menu-buffer))) + (when (and buf (buffer-modified-p buf) + (string-equal (aref entry 2) " ")) + (tabulated-list-set-col 2 "*" t))))) (defun Buffer-menu-delete (&optional arg) "Mark the buffer on this Buffer Menu buffer line for deletion. diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index bb8dbe6c52c..86a2c405272 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -911,17 +911,19 @@ Elements of A must either be a character (see `characterp') or a complex number with only a real character part, each with a value less than or -equal to the custom variable `calc-string-maximum-character'." - (while (and (setq a (cdr a)) - (or (and (characterp (car a)) - (<= (car a) - calc-string-maximum-character)) - (and (eq (car-safe (car a)) 'cplx) - (characterp (nth 1 (car a))) - (eq (nth 2 (car a)) 0) - (<= (nth 1 (car a)) - calc-string-maximum-character))))) - (null a)) +equal to the value of `calc-string-maximum-character'. Return nil if +`calc-string-maximum-character' is not a character." + (when (characterp calc-string-maximum-character) + (while (and (setq a (cdr a)) + (or (and (characterp (car a)) + (<= (car a) + calc-string-maximum-character)) + (and (eq (car-safe (car a)) 'cplx) + (characterp (nth 1 (car a))) + (eq (nth 2 (car a)) 0) + (<= (nth 1 (car a)) + calc-string-maximum-character))))) + (null a))) (defconst math-vector-to-string-chars '( ( ?\" . "\\\"" ) ( ?\\ . "\\\\" ) @@ -1556,8 +1558,12 @@ Not all brackets have midpieces.") (setq c (cdr c)) (while (setq c (cdr c)) (if (eq (car-safe (car c)) 'rule) - (math-comp-add-string (make-string maxwid (nth 1 (car c))) - math-comp-hpos math-comp-vpos) + (let* ((sep (nth 1 (car c))) + (rule-width (ceiling + (* maxwid (string-pixel-width "-")) + (string-pixel-width (char-to-string sep))))) + (math-comp-add-string (make-string rule-width sep) + math-comp-hpos math-comp-vpos)) (let ((math-comp-hpos (+ math-comp-hpos (/ (* bias (- maxwid (car widths))) 2)))) @@ -1654,7 +1660,11 @@ Not all brackets have midpieces.") ((memq (car c) '(set break)) t))) (defun math-comp-width (c) - (cond ((not (consp c)) (length c)) + (cond ((not (consp c)) + (or (and (stringp c) + (ceiling (string-pixel-width c) + (string-pixel-width "-"))) + (length c))) ((memq (car c) '(horiz subscr supscr)) (let ((accum 0)) (while (setq c (cdr c)) diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index 1e3f0400d12..ad0379bb731 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -571,232 +571,6 @@ Prefix argument ARG will make the entry nonmarking." "Bahá’í calendar equivalent of date diary entry." (format "Bahá’í date: %s" (calendar-bahai-date-string date))) - -;;; ====================================================================== -;;; Verification and Testing -;;; ====================================================================== - -;; The following code verifies the astronomical calculations against -;; official dates published by the Bahá’í World Centre. -;; -;; BACKGROUND: 2014 Calendar Reform -;; -------------------------------- -;; On 10 July 2014, the Universal House of Justice announced provisions -;; for the uniform implementation of the Badí' calendar, effective from -;; Naw-Rúz 172 BE (March 2015). The key provisions are: -;; -;; 1. NAW-RÚZ DETERMINATION: -;; "The Festival of Naw-Rúz falleth on the day that the sun entereth -;; the sign of Aries, even should this occur no more than one minute -;; before sunset." Tehran is the reference point for determining the -;; moment of the vernal equinox. If the equinox occurs before sunset -;; in Tehran, that day is Naw-Rúz; otherwise, the following day is. -;; -;; 2. TWIN HOLY BIRTHDAYS: -;; "They will now be observed on the first and the second day -;; following the occurrence of the eighth new moon after Naw-Rúz, -;; as determined in advance by astronomical tables using Ṭihrán as -;; the point of reference." -;; -;; VERIFICATION APPROACH -;; --------------------- -;; The functions below compare calculated dates against official data -;; from the Bahá’í World Centre, covering the 50-year period from -;; 172 BE (2015 CE) to 221 BE (2064 CE). This data was extracted from -;; the official ICS calendar file distributed by the Bahá’í World Centre. -;; -;; The verification confirms: -;; - Naw-Rúz dates: Calculated using `solar-equinoxes/solstices' for the -;; vernal equinox and `solar-sunrise-sunset' for Tehran sunset times. -;; - Twin Holy Birthdays: Calculated using `lunar-new-moon-on-or-after' -;; to find the eighth new moon after Naw-Rúz. -;; -;; To run the verification: -;; M-x calendar-bahai-verify-calculations RET - -(defconst calendar-bahai--nawruz-reference-dates - '((2015 3 21) (2016 3 20) (2017 3 20) (2018 3 21) (2019 3 21) - (2020 3 20) (2021 3 20) (2022 3 21) (2023 3 21) (2024 3 20) - (2025 3 20) (2026 3 21) (2027 3 21) (2028 3 20) (2029 3 20) - (2030 3 20) (2031 3 21) (2032 3 20) (2033 3 20) (2034 3 20) - (2035 3 21) (2036 3 20) (2037 3 20) (2038 3 20) (2039 3 21) - (2040 3 20) (2041 3 20) (2042 3 20) (2043 3 21) (2044 3 20) - (2045 3 20) (2046 3 20) (2047 3 21) (2048 3 20) (2049 3 20) - (2050 3 20) (2051 3 21) (2052 3 20) (2053 3 20) (2054 3 20) - (2055 3 21) (2056 3 20) (2057 3 20) (2058 3 20) (2059 3 20) - (2060 3 20) (2061 3 20) (2062 3 20) (2063 3 20) (2064 3 20)) - "Official Naw-Rúz dates from the Bahá’í World Centre (2015-2064). -Each entry is (GREGORIAN-YEAR MONTH DAY). These dates are extracted -from the official ICS calendar file and serve as the authoritative -reference for verifying the astronomical calculations. - -The dates show that Naw-Rúz falls on March 20 or 21, depending on -when the vernal equinox occurs relative to sunset in Tehran.") - -(defconst calendar-bahai--twin-birthdays-reference-dates - '(;; (GREG-YEAR BAB-MONTH BAB-DAY BAHA-MONTH BAHA-DAY) - (2015 11 13 11 14) (2016 11 1 11 2) (2017 10 21 10 22) - (2018 11 9 11 10) (2019 10 29 10 30) (2020 10 18 10 19) - (2021 11 6 11 7) (2022 10 26 10 27) (2023 10 16 10 17) - (2024 11 2 11 3) (2025 10 22 10 23) (2026 11 10 11 11) - (2027 10 30 10 31) (2028 10 19 10 20) (2029 11 7 11 8) - (2030 10 28 10 29) (2031 10 17 10 18) (2032 11 4 11 5) - (2033 10 24 10 25) (2034 11 12 11 13) (2035 11 1 11 2) - (2036 10 20 10 21) (2037 11 8 11 9) (2038 10 29 10 30) - (2039 10 19 10 20) (2040 11 6 11 7) (2041 10 26 10 27) - (2042 10 15 10 16) (2043 11 3 11 4) (2044 10 22 10 23) - (2045 11 10 11 11) (2046 10 30 10 31) (2047 10 20 10 21) - (2048 11 7 11 8) (2049 10 28 10 29) (2050 10 17 10 18) - (2051 11 5 11 6) (2052 10 24 10 25) (2053 11 11 11 12) - (2054 11 1 11 2) (2055 10 21 10 22) (2056 11 8 11 9) - (2057 10 29 10 30) (2058 10 18 10 19) (2059 11 6 11 7) - (2060 10 25 10 26) (2061 10 14 10 15) (2062 11 2 11 3) - (2063 10 23 10 24) (2064 11 10 11 11)) - "Official Twin Holy Birthday dates from the Bahá’í World Centre (2015-2064). -Each entry is (GREGORIAN-YEAR BAB-MONTH BAB-DAY BAHA-MONTH BAHA-DAY). - -The Birth of the Báb and the Birth of Bahá’u’lláh are celebrated on -consecutive days, determined by the eighth new moon after Naw-Rúz. -These dates move through the Gregorian calendar, typically falling -between mid-October and mid-November (Bahá’í months of Mashíyyat, -\\='Ilm, and Qudrat).") - -(defun calendar-bahai--verify-nawruz () - "Verify Naw-Rúz calculations against official reference dates. -Returns a plist with :total, :correct, and :errors keys." - (let ((total 0) - (correct 0) - (errors nil)) - (dolist (entry calendar-bahai--nawruz-reference-dates) - (let* ((greg-year (nth 0 entry)) - (expected-month (nth 1 entry)) - (expected-day (nth 2 entry)) - (expected (list expected-month expected-day greg-year)) - (computed (calendar-bahai-nawruz-for-gregorian-year greg-year))) - (setq total (1+ total)) - (if (equal computed expected) - (setq correct (1+ correct)) - (push (list greg-year expected computed) errors)))) - (list :total total :correct correct :errors (nreverse errors)))) - -(defun calendar-bahai--verify-twin-birthdays () - "Verify Twin Holy Birthday calculations against official reference dates. -Returns a plist with :total, :bab-correct, :baha-correct, and :errors keys." - (let ((total 0) - (bab-correct 0) - (baha-correct 0) - (errors nil)) - (dolist (entry calendar-bahai--twin-birthdays-reference-dates) - (let* ((greg-year (nth 0 entry)) - (bahai-year (- greg-year (1- 1844))) - (expected-bab (list (nth 1 entry) (nth 2 entry) greg-year)) - (expected-baha (list (nth 3 entry) (nth 4 entry) greg-year))) - ;; Only verify from reform year onwards - (when (>= bahai-year calendar-bahai-reform-year) - (setq total (1+ total)) - (let* ((computed (calendar-bahai-twin-holy-birthdays-for-year bahai-year)) - (computed-bab (car computed)) - (computed-baha (cadr computed))) - (if (equal computed-bab expected-bab) - (setq bab-correct (1+ bab-correct)) - (push (list greg-year "Báb" expected-bab computed-bab) errors)) - (if (equal computed-baha expected-baha) - (setq baha-correct (1+ baha-correct)) - (push (list greg-year "Bahá’u’lláh" expected-baha computed-baha) - errors)))))) - (list :total total - :bab-correct bab-correct - :baha-correct baha-correct - :errors (nreverse errors)))) - -(defun calendar-bahai-verify-calculations () - "Verify Bahá’í calendar calculations against official reference dates. -This function compares the astronomical calculations for Naw-Rúz and -the Twin Holy Birthdays against official dates from the Bahá’í World -Centre for the period 172-221 BE (2015-2064 CE). - -The verification tests: -1. Naw-Rúz dates - calculated from the vernal equinox relative to - sunset in Tehran. -2. Birth of the Báb dates - the first day following the eighth new - moon after Naw-Rúz. -3. Birth of Bahá’u’lláh dates - the second day following the eighth - new moon after Naw-Rúz. - -Results are displayed in the *Bahá’í Calendar Verification* buffer." - (interactive) - (let* ((nawruz-results (calendar-bahai--verify-nawruz)) - (twin-results (calendar-bahai--verify-twin-birthdays)) - (buf (get-buffer-create "*Bahá’í Calendar Verification*"))) - (with-current-buffer buf - (erase-buffer) - - (insert "This report verifies the astronomical calculations against\n") - (insert "official dates from the Bahá’í World Centre (172-221 BE).\n\n") - - ;; Naw-Rúz results - (insert "───────────────────────────────────────────────────────────────\n") - (insert "NAW-RÚZ VERIFICATION\n") - (insert "───────────────────────────────────────────────────────────────\n") - (insert (format " Total years tested: %d\n" (plist-get nawruz-results :total))) - (insert (format " Correct: %d\n" (plist-get nawruz-results :correct))) - (insert (format " Errors: %d\n" - (length (plist-get nawruz-results :errors)))) - (when (plist-get nawruz-results :errors) - (insert "\n Discrepancies:\n") - (dolist (err (plist-get nawruz-results :errors)) - (insert (format " %d: expected %S, calculated %S\n" - (nth 0 err) (nth 1 err) (nth 2 err))))) - (insert "\n") - - ;; Twin Holy Birthdays results - (insert "───────────────────────────────────────────────────────────────\n") - (insert "TWIN HOLY BIRTHDAYS VERIFICATION\n") - (insert "───────────────────────────────────────────────────────────────\n") - (insert (format " Total years tested: %d\n" - (plist-get twin-results :total))) - (insert (format " Birth of Báb correct: %d\n" - (plist-get twin-results :bab-correct))) - (insert (format " Birth of Bahá’u’lláh correct: %d\n" - (plist-get twin-results :baha-correct))) - (insert (format " Errors: %d\n" - (length (plist-get twin-results :errors)))) - (when (plist-get twin-results :errors) - (insert "\n Discrepancies:\n") - (dolist (err (plist-get twin-results :errors)) - (insert (format " %d %s: expected %S, calculated %S\n" - (nth 0 err) (nth 1 err) (nth 2 err) (nth 3 err))))) - (insert "\n") - - ;; Summary - (insert "───────────────────────────────────────────────────────────────\n") - (insert "SUMMARY\n") - (insert "───────────────────────────────────────────────────────────────\n") - (let ((total-errors (+ (length (plist-get nawruz-results :errors)) - (length (plist-get twin-results :errors))))) - (if (zerop total-errors) - (progn - (insert " All calculations match official dates!\n\n") - (insert " The astronomical algorithms correctly compute:\n") - (insert " • Naw-Rúz from the vernal equinox/sunset in Tehran\n") - (insert " • Twin Holy Birthdays from the 8th new moon after Naw-Rúz\n")) - (insert (format " ✗ Total discrepancies: %d\n" total-errors)) - (insert " Review the errors above for details.\n")))) - - (display-buffer buf) - ;; Return results for programmatic use - (list :nawruz nawruz-results :twin-birthdays twin-results))) - -(defun calendar-bahai-run-tests () - "Run verification tests and return t if all pass, nil otherwise. -This function is suitable for use in automated testing." - (let* ((nawruz-results (calendar-bahai--verify-nawruz)) - (twin-results (calendar-bahai--verify-twin-birthdays)) - (nawruz-ok (zerop (length (plist-get nawruz-results :errors)))) - (twin-ok (zerop (length (plist-get twin-results :errors))))) - (and nawruz-ok twin-ok))) - - (provide 'cal-bahai) ;;; cal-bahai.el ends here diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 0d49a6571d5..42fc210c1e1 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1098,7 +1098,7 @@ Otherwise, use symbolic time zones like \"CET\"." (defconst calendar-first-date-row 3 "First row in the calendar with actual dates.") -(defconst calendar-buffer "*Calendar*" +(defvar calendar-buffer "*Calendar*" "Name of the buffer used for the calendar.") (defun calendar-get-buffer () @@ -1450,9 +1450,12 @@ Optional integers MON and YR are used instead of today's date." (calendar-mark-holidays)) (unwind-protect (if calendar-mark-diary-entries (diary-mark-entries)) - (run-hooks (if (calendar-date-is-visible-p today) - 'calendar-today-visible-hook - 'calendar-today-invisible-hook))))) + (if (not (calendar-date-is-visible-p today)) + (run-hooks 'calendar-today-invisible-hook) + ;; Functions in calendar-today-visible-hook may rely on the cursor + ;; being on today's date. + (calendar-cursor-to-visible-date today) + (run-hooks 'calendar-today-visible-hook))))) (defun calendar-generate (month year) "Generate a three-month Gregorian calendar centered around MONTH, YEAR." diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index baa361bd707..36f9b0ef13b 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -1402,7 +1402,7 @@ marks. This is intended to deal with deleted diary entries." (diary-buffer (find-buffer-visiting diary-file)) ;; Record current calendar buffer in case this function is ;; called in a calendar-mode buffer not named `calendar-buffer'. - (calendar-buffer (calendar-get-buffer)) + (calendar-buffer (buffer-name (calendar-get-buffer))) ;; Dynamically bound in diary-include-files. (d-incp (and (boundp 'diary-including) diary-including)) file-glob-attrs temp-buff) diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 3acaf9b91e2..696a5b50aa1 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -654,10 +654,17 @@ STRING)). Returns nil if it is not visible in the current calendar window." (defun holiday-float (month dayname n string &optional day) "Holiday called STRING on the Nth DAYNAME after/before MONTH DAY. -DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on. -If N>0, use the Nth DAYNAME after MONTH DAY. -If N<0, use the Nth DAYNAME before MONTH DAY. -DAY defaults to 1 if N>0, and MONTH's last day otherwise. +DAYNAME = 0 means Sunday, DAYNAME = 1 means Monday, and so on. DAY +defaults to 1 if N > 0, and MONTH's last day otherwise. + +If N > 0, use the Nth DAYNAME after MONTH DAY. +If N < 0, use the Nth DAYNAME before MONTH DAY. + +When MONTH DAY falls on DAYNAME, the holiday will be |N|-1 weeks before +or after MONTH DAY. For example, with N = +1 (-1) the holiday falls on +MONTH DAY, and with N = +2 (-2) the holiday falls 1 week after (before) +MONTH DAY. + If the holiday is visible in the calendar window, returns a list (((month day year) STRING)). Otherwise returns nil." ;; This is messy because the holiday may be visible, while the date diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 73f60f1972a..808840f895d 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -723,19 +723,23 @@ SYMBOL is a function that can be overridden." override (symbol-function override))))) (when (and override override-file) - (let ((meta-name (cons override major-mode)) - ;; For the declaration: - ;; - ;;(define-mode-local-override xref-elisp-foo c-mode - ;; - ;; The override symbol name is - ;; "xref-elisp-foo-c-mode". The summary should match - ;; the declaration, so strip the mode from the - ;; symbol name. - (summary (format elisp--xref-format-extra - 'define-mode-local-override - (substring (symbol-name override) 0 (- (1+ (length (symbol-name major-mode))))) - major-mode))) + (let* ((meta-name (cons override major-mode)) + ;; For the declaration: + ;; + ;;(define-mode-local-override xref-elisp-foo c-mode + ;; + ;; The override symbol name is + ;; "xref-elisp-foo-c-mode". The summary should match + ;; the declaration, so strip the mode from the + ;; symbol name. + (overridesymbol + (intern + (substring (symbol-name override) + 0 (- (1+ (length (symbol-name major-mode))))))) + (summary (format elisp--xref-format-extra + 'define-mode-local-override + overridesymbol + major-mode))) (unless (xref-mode-local--override-present override xrefs) (push (elisp--xref-make-xref diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 3720e267f4e..6761bc8bd3f 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -150,7 +150,11 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (scroll-down-aggressively windows (choice (const :tag "off" nil) float) "21.1") - (line-spacing display (choice (const :tag "none" nil) number) + (line-spacing display + (choice (const :tag "No spacing" nil) + (number :tag "Spacing below") + (cons :tag "Spacing above and below" + number number)) "22.1") (cursor-in-non-selected-windows cursor ,cursor-type-types nil diff --git a/lisp/dired.el b/lisp/dired.el index b987b85c3c7..7f598433a9d 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -5038,12 +5038,16 @@ format, use `\\[universal-argument] \\[dired]'.") ;; `dired-ls-sorting-switches' after -t overrides -t. "[^ " dired-ls-sorting-switches "]*" "\\(\\(\\`\\| +\\)\\(--[^ ]+\\|-[^- t" - dired-ls-sorting-switches "]+\\)\\)* *$") + dired-ls-sorting-switches "]+\\|" + ;; Allow quoted strings + "\"[^\"]*\"\\)\\)* *$") "Regexp recognized by Dired to set `by date' mode.") (defvar dired-sort-by-name-regexp (concat "\\`\\(\\(\\`\\| +\\)\\(--[^ ]+\\|" - "-[^- t" dired-ls-sorting-switches "]+\\)\\)* *$") + "-[^- t" dired-ls-sorting-switches "]+[^- tSXU]+\\|" + ;; Allow quoted strings + "\"[^\"]*\"\\)\\)* *$") "Regexp recognized by Dired to set `by name' mode.") (defvar dired-sort-inhibit nil diff --git a/lisp/editorconfig-tools.el b/lisp/editorconfig-tools.el index 4c687fbb570..ae793bff87a 100644 --- a/lisp/editorconfig-tools.el +++ b/lisp/editorconfig-tools.el @@ -31,12 +31,9 @@ ;;; Code: -(require 'cl-lib) - (eval-when-compile (require 'subr-x)) - (require 'editorconfig) ;;;###autoload diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 405500c0987..320bc4c3d8e 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -154,17 +154,22 @@ also passed as second argument to SPECIALIZERS-FUNCTION." (:constructor cl--generic-make-method (specializers qualifiers call-con function)) (:predicate nil)) + "Type of `cl-generic' method objects. +FUNCTION holds a function containing the actual code of the method. +SPECIALIZERS holds the list of specializers (as long as the number of +mandatory arguments of the method). +QUALIFIERS holds the list of qualifiers. +CALL-CON indicates the calling convention expected by FUNCTION: +- nil: FUNCTION is just a normal function with no extra arguments for + `call-next-method' or `next-method-p' (which it hence can't use). +- `curried': FUNCTION is a curried function that first takes the + \"next combined method\" and returns the resulting combined method. + It can distinguish `next-method-p' by checking if that next method + is `cl--generic-isnot-nnm-p'. +- t: FUNCTION takes the `call-next-method' function as an extra first + argument." (specializers nil :read-only t :type list) (qualifiers nil :read-only t :type (list-of atom)) - ;; CALL-CON indicates the calling convention expected by FUNCTION: - ;; - nil: FUNCTION is just a normal function with no extra arguments for - ;; `call-next-method' or `next-method-p' (which it hence can't use). - ;; - `curried': FUNCTION is a curried function that first takes the - ;; "next combined method" and return the resulting combined method. - ;; It can distinguish `next-method-p' by checking if that next method - ;; is `cl--generic-isnot-nnm-p'. - ;; - t: FUNCTION takes the `call-next-method' function as its first (extra) - ;; argument. (call-con nil :read-only t :type symbol) (function nil :read-only t :type function)) @@ -181,7 +186,10 @@ also passed as second argument to SPECIALIZERS-FUNCTION." ;; The most important dispatch is last in the list (and the least is first). (dispatches nil :type (list-of (cons natnum (list-of generalizers)))) (method-table nil :type (list-of cl--generic-method)) - (options nil :type list)) + (options nil :type list) + ;; This slot holds the function we put into `symbol-function' before + ;; the actual dispatch function has been computed. + (lazy-function nil)) (defun cl-generic-function-options (generic) "Return the options of the generic function GENERIC." @@ -316,6 +324,9 @@ DEFAULT-BODY, if present, is used as the body of a default method. ,@warnings (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) + ;; FIXME: This docstring argument is used as circumstantial + ;; evidence that this generic function was defined via + ;; `cl-defgeneric' rather than only `cl-defmethod's. ,(if (consp doc) ;An expression rather than a constant. `(help-add-fundoc-usage ,doc ',args) (help-add-fundoc-usage doc args))) @@ -658,8 +669,6 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; Keep the ordering; important for methods with :extra qualifiers. (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) (let ((sym (cl--generic-name generic)) ; Actual name (for aliases). - ;; FIXME: Try to avoid re-constructing a new function if the old one - ;; is still valid (e.g. still empty method cache)? (gfun (cl--generic-make-function generic))) (cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format (cl--generic-name generic) @@ -827,9 +836,30 @@ You might need to add: %S" ,@fixedargs args))))))))) (defun cl--generic-make-function (generic) - (cl--generic-make-next-function generic - (cl--generic-dispatches generic) - (cl--generic-method-table generic))) + "Return the function to put into the `symbol-function' of GENERIC." + ;; The function we want is the one that performs the dispatch, + ;; but that function depends on the set of methods and needs to be + ;; flushed/recomputed when the set of methods changes. + ;; To avoid reconstructing such a method N times for N `cl-defmethod', + ;; we construct the dispatch function lazily: + ;; we first return a "lazy" function, which waits until the + ;; first call to the method to really compute the dispatch function, + ;; at which point we replace the dummy with the real one. + (with-memoization (cl--generic-lazy-function generic) + (lambda (&rest args) + (let* ((real + (cl--generic-make-next-function generic + (cl--generic-dispatches generic) + (cl--generic-method-table generic))) + (sym (cl--generic-name generic)) + (old-adv-cc (get-advertised-calling-convention + (symbol-function sym)))) + (when (listp old-adv-cc) + (set-advertised-calling-convention real old-adv-cc nil)) + (when (symbol-function sym) + (let ((current-load-list nil)) + (defalias sym real))) + (apply real args))))) (defun cl--generic-make-next-function (generic dispatches methods) (let* ((dispatch @@ -855,33 +885,32 @@ This is particularly useful when many different tags select the same set of methods, since this table then allows us to share a single combined-method for all those different tags in the method-cache.") -(define-error 'cl--generic-cyclic-definition "Cyclic definition") - (defun cl--generic-build-combined-method (generic methods) - (if (null methods) - ;; Special case needed to fix a circularity during bootstrap. - (cl--generic-standard-method-combination generic methods) - (let ((f - (with-memoization - ;; FIXME: Since the fields of `generic' are modified, this - ;; hash-table won't work right, because the hashes will change! - ;; It's not terribly serious, but reduces the effectiveness of - ;; the table. - (gethash (cons generic methods) - cl--generic-combined-method-memoization) - (puthash (cons generic methods) :cl--generic--under-construction - cl--generic-combined-method-memoization) - (condition-case nil - (cl-generic-combine-methods generic methods) - ;; Special case needed to fix a circularity during bootstrap. - (cl--generic-cyclic-definition - (cl--generic-standard-method-combination generic methods)))))) - (if (eq f :cl--generic--under-construction) - (signal 'cl--generic-cyclic-definition - (list (cl--generic-name generic))) - f)))) + ;; Since `cl-generic-combine-methods' is itself a generic function, + ;; there is a chicken and egg problem when computing a combined + ;; method for `cl-generic-combine-methods'. + ;; We break such infinite recursion by detecting it and falling + ;; back to `cl--generic-standard-method-combination' when it happens. + ;; FIXME: Since the fields of `generic' are modified, the + ;; `cl--generic-combined-method-memoization' hash-table won't work + ;; right, because the hashes will change! It's not terribly serious, + ;; but reduces the effectiveness of the table. + (let ((key (cons generic methods))) + (pcase (gethash key cl--generic-combined-method-memoization) + (:cl--generic--under-construction + ;; Fallback to the standard method combination. + (setf (gethash key cl--generic-combined-method-memoization) + (cl--generic-standard-method-combination generic methods))) + ('nil + (setf (gethash key cl--generic-combined-method-memoization) + :cl--generic--under-construction) + (let ((f nil)) + (unwind-protect + (setq f (cl-generic-combine-methods generic methods)) + (setf (gethash key cl--generic-combined-method-memoization) f)))) + (f f)))) -(oclosure-define (cl--generic-nnm) +(oclosure-define cl--generic-nnm "Special type for `call-next-method's that just call `no-next-method'.") (defun cl-generic-call-method (generic method &optional fun) @@ -1002,11 +1031,11 @@ The code which extracts the tag should be as fast as possible. The tags should be chosen according to the following rules: - The tags should not be too specific: similar objects which match the same list of specializers should ideally use the same (`eql') tag. - This insures that the cached computation of the applicable + This ensures that the cached computation of the applicable methods for one object can be reused for other objects. - Corollary: objects which don't match any of the relevant specializers should ideally all use the same tag (typically nil). - This insures that this cache does not grow unnecessarily large. + This ensures that this cache does not grow unnecessarily large. - Two different generalizers G1 and G2 should not use the same tag unless they use it for the same set of objects. IOW, if G1.tag(X1) = G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2). @@ -1028,8 +1057,7 @@ those methods.") (unless (ignore-errors (cl-generic-generalizers t)) ;; Temporary definition to let the next defmethod succeed. (fset 'cl-generic-generalizers - (lambda (specializer) - (if (eq t specializer) (list cl--generic-t-generalizer)))) + (lambda (_specializer) (list cl--generic-t-generalizer))) (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)) (cl-defmethod cl-generic-generalizers (specializer) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 989f8f5ce20..caa02fb24b2 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -327,15 +327,16 @@ FORM is of the form (ARGS . BODY)." ;; "manual" parsing. (let ((slen (length simple-args)) (usage-str - ;; Macro expansion can take place in the middle of - ;; apparently harmless computation, so it should not - ;; touch the match-data. - (save-match-data - (help--docstring-quote - (let ((print-gensym nil) (print-quoted t) - (print-escape-newlines t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args)))))))) + ;; Macro expansion can take place in the middle of + ;; apparently harmless computation, so it should not + ;; touch the match-data. + (save-match-data + (require 'help) + (help--docstring-quote + (let ((print-gensym nil) (print-quoted t) + (print-escape-newlines t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args)))))))) (when (memq '&optional simple-args) (decf slen)) (setq header diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index d75a32a8d4e..f6376fbd192 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -296,10 +296,11 @@ (cl-defstruct (built-in-class (:include cl--class) + (:conc-name built-in-class--) (:noinline t) (:constructor nil) (:constructor built-in-class--make - (name docstring parent-types + (name docstring parent-types &optional non-abstract-supertype &aux (parents (mapcar (lambda (type) (or (get type 'cl--class) @@ -308,7 +309,9 @@ (:copier nil)) "Type descriptors for built-in types. The `slots' (and hence `index-table') are currently unused." - ) + ;; As a general rule, built-in types are abstract if-and-only-if they have + ;; other built-in types as subtypes. But there are a few exceptions. + (non-abstract-supertype nil :read-only t)) (defmacro cl--define-built-in-type (name parents &optional docstring &rest slots) ;; `slots' is currently unused, but we could make it take @@ -322,19 +325,22 @@ The `slots' (and hence `index-table') are currently unused." (let ((predicate (intern-soft (format (if (string-match "-" (symbol-name name)) "%s-p" "%sp") - name)))) + name))) + (nas nil)) (unless (fboundp predicate) (setq predicate nil)) (while (keywordp (car slots)) (let ((kw (pop slots)) (val (pop slots))) (pcase kw (:predicate (setq predicate val)) + (:non-abstract-supertype (setq nas val)) (_ (error "Unknown keyword arg: %S" kw))))) `(progn ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate) ;; (message "Missing predicate for: %S" name) nil) (put ',name 'cl--class - (built-in-class--make ',name ,docstring ',parents))))) + (built-in-class--make ',name ,docstring ',parents + ,@(if nas '(t))))))) ;; FIXME: Our type DAG has various quirks: ;; - Some `keyword's are also `symbol-with-pos' but that's not reflected @@ -381,6 +387,7 @@ regardless if `funcall' would accept to call them." "Abstract supertype of both `number's and `marker's.") (cl--define-built-in-type symbol atom "Type of symbols." + :non-abstract-supertype t ;; Example of slots we could document. It would be desirable to ;; have some way to extract this from the C code, or somehow keep it ;; in sync (probably not for `cons' and `symbol' but for things like @@ -411,7 +418,8 @@ The size depends on the Emacs version and compilation options. For this build of Emacs it's %dbit." (1+ (logb (1+ most-positive-fixnum))))) (cl--define-built-in-type boolean (symbol) - "Type of the canonical boolean values, i.e. either nil or t.") + "Type of the canonical boolean values, i.e. either nil or t." + :non-abstract-supertype t) (cl--define-built-in-type symbol-with-pos (symbol) "Type of symbols augmented with source-position information.") (cl--define-built-in-type vector (array)) @@ -450,9 +458,9 @@ The fields are used as follows: 5 [iform] The interactive form (if present)") (cl--define-built-in-type byte-code-function (compiled-function closure) "Type of functions that have been byte-compiled.") -(cl--define-built-in-type subr (atom) - "Abstract type of functions compiled to machine code.") -(cl--define-built-in-type module-function (function) +(cl--define-built-in-type subr (atom) ;Beware: not always a function. + "Abstract type of functions and special forms compiled to machine code.") +(cl--define-built-in-type module-function (compiled-function) "Type of functions provided via the module API.") (cl--define-built-in-type interpreted-function (closure) "Type of functions that have not been compiled.") diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index bf86fc2e3cd..d81e800cc36 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -272,7 +272,7 @@ Used to modify the compiler environment." (member (function (t list) list)) (memq (function (t list) list)) (memql (function (t list) list)) - (message (function (string &rest t) string)) + (message (function ((or string null) &rest t) (or string null))) (min (function ((or number marker) &rest (or number marker)) number)) (minibuffer-selected-window (function () (or window null))) (minibuffer-window (function (&optional frame) window)) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index b91fa165986..6bd763d2ea2 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -254,11 +254,7 @@ with empty strings removed." (let* ((map (if require-match crm-local-must-match-map crm-local-completion-map)) - (map (if minibuffer-visible-completions - (make-composed-keymap - (list minibuffer-visible-completions-map - map)) - map)) + (map (minibuffer-visible-completions--maybe-compose-map map)) (buffer (current-buffer)) input) (minibuffer-with-setup-hook diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el index 9a1faaca126..25be0dd9c40 100644 --- a/lisp/emacs-lisp/inline.el +++ b/lisp/emacs-lisp/inline.el @@ -134,7 +134,7 @@ After VARS is handled, BODY is evaluated in the new environment." This is halfway between `defmacro' and `defun'. BODY is used as a blueprint both for the body of the function and for the body of the compiler-macro used to generate the code inlined at each call site. -See Info node `(elisp)Inline Functions for more details. +See Info node `(elisp)Inline Functions' for more details. A (noinline t) in the `declare' form prevents the definition of the compiler macro. This is for the rare case in which you want to use this diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 1f1115b2f18..5cbd4213028 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -50,7 +50,7 @@ This affects `insert-parentheses' and `insert-pair'." (goto-char (or (scan-sexps (point) arg) (buffer-end arg))) (if (< arg 0) (backward-prefix-chars))) -(defvar forward-sexp-function nil +(defvar forward-sexp-function #'forward-sexp-default-function ;; FIXME: ;; - for some uses, we may want a "sexp-only" version, which only ;; jumps over a well-formed sexp, rather than some dwimish thing @@ -79,9 +79,9 @@ report errors as appropriate for this kind of usage." "No next sexp" "No previous sexp")))) (or arg (setq arg 1)) - (if forward-sexp-function - (funcall forward-sexp-function arg) - (forward-sexp-default-function arg)))) + (funcall (or forward-sexp-function + #'forward-sexp-default-function) + arg))) (defun backward-sexp (&optional arg interactive) "Move backward across one balanced expression (sexp). @@ -147,7 +147,7 @@ This command assumes point is not in a string or comment." "Default function for `forward-list-function'." (goto-char (or (scan-lists (point) arg 0) (buffer-end arg)))) -(defvar forward-list-function nil +(defvar forward-list-function #'forward-list-default-function "If non-nil, `forward-list' delegates to this function. Should take the same arguments and behave similarly to `forward-list'.") @@ -169,9 +169,9 @@ report errors as appropriate for this kind of usage." "No next group" "No previous group")))) (or arg (setq arg 1)) - (if forward-list-function - (funcall forward-list-function arg) - (forward-list-default-function arg)))) + (funcall (or forward-list-function + #'forward-list-default-function) + arg))) (defun backward-list (&optional arg interactive) "Move backward across one balanced group of parentheses. @@ -250,6 +250,8 @@ defined by the current language mode. With ARG, do this that many times. A negative argument means move backward but still to a less deep spot. +Calls `up-list-function' to do the work, if that is non-nil. + If ESCAPE-STRINGS is non-nil (as it is interactively), move out of enclosing strings as well. @@ -289,7 +291,9 @@ On error, location of point is unspecified." (scan-error (point-max))) (forward-comment 1) (point))))))) - (if (null forward-sexp-function) + ;; FIXME: Comparing functions is a code smell. + (if (memq forward-sexp-function + '(nil forward-sexp-default-function)) (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))) (condition-case err diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 550c6d8e0c2..60d250b564f 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -155,7 +155,10 @@ scanning for autoloads and will be in the `load-path'." ;; employing :autoload-end to omit unneeded forms). (defconst loaddefs--defining-macros '( transient-define-prefix transient-define-suffix transient-define-infix - transient-define-argument transient-define-group)) + transient-define-argument + ;; FIXME: How can this one make sense? It doesn't put anything + ;; into `symbol-function'! + transient-define-group)) (defvar loaddefs--load-error-files nil) (defun loaddefs-generate--make-autoload (form file &optional expansion) @@ -228,12 +231,16 @@ expand)' among their `declare' forms." (member file loaddefs--load-error-files)) (let ((load-path (cons (file-name-directory file) load-path))) (message "loaddefs-gen: loading file %s (for %s)" file car) - (condition-case e (load file) + (condition-case e + ;; Don't load the `.elc' file, in case the file wraps + ;; the macro-definition in `eval-when-compile' (bug#80180). + (let ((load-suffixes '(".el"))) + (load file)) (error (push file loaddefs--load-error-files) ; do not attempt again (warn "loaddefs-gen: load error\n\t%s" e))))) (and (macrop car) - (eq 'expand (function-get car 'autoload-macro)) + (eq 'expand (function-get car 'autoload-macro 'macro)) (setq expand (let ((load-true-file-name file) (load-file-name file)) (macroexpand-1 form))) @@ -245,12 +252,7 @@ expand)' among their `declare' forms." ;; directly. ((memq car loaddefs--defining-macros) (let* ((name (nth 1 form)) - (args (pcase car - ((or 'transient-define-prefix 'transient-define-suffix - 'transient-define-infix 'transient-define-argument - 'transient-define-group) - (nth 2 form)) - (_ t))) + (args (nth 2 form)) (body (nthcdr (or (function-get car 'doc-string-elt) 3) form)) (doc (if (stringp (car body)) (pop body)))) ;; Add the usage form at the end where describe-function-1 @@ -259,18 +261,7 @@ expand)' among their `declare' forms." ;; `define-generic-mode' quotes the name, so take care of that (loaddefs-generate--shorten-autoload `(autoload ,(if (listp name) name (list 'quote name)) - ,file ,doc - ,(or (and (memq car '( transient-define-prefix - transient-define-suffix - transient-define-infix - transient-define-argument - transient-define-group)) - t) - (and (eq (car-safe (car body)) 'interactive) - ;; List of modes or just t. - (or (if (nthcdr 2 (car body)) - (list 'quote (nthcdr 2 (car body))) - t)))))))) + ,file ,doc t)))) ;; For defclass forms, use `eieio-defclass-autoload'. ((eq car 'defclass) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index dcb519b33b5..d9ca6f0b19a 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -469,16 +469,23 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp-warn-and-return (format-message "`condition-case' without handlers") exp-body (list 'suspicious 'condition-case) t form)))) - (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) - (push name macroexp--dynvars) - (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons fn - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form))) + (`(,(or 'defvar 'defconst) . ,args) + (if (and (car-safe args) (symbolp (car-safe args))) + (progn + (push (car args) macroexp--dynvars) + (macroexp--all-forms form 2)) + form)) + (`(function . ,rest) + (if (and (eq (car-safe (car-safe rest)) 'lambda) + (null (cdr rest))) + (let ((f (car rest))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons fn + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + form)) (`(,(or 'function 'quote) . ,_) form) (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) pcase--dontcare)) @@ -495,82 +502,88 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--all-forms body)) (cdr form)) form))) - (`(while) - (macroexp-warn-and-return - (format-message "missing `while' condition") - `(signal 'wrong-number-of-arguments '(while 0)) - nil 'compile-only form)) - (`(unwind-protect ,expr) - (macroexp-warn-and-return - (format-message "`unwind-protect' without unwind forms") - (macroexp--expand-all expr) - (list 'suspicious 'unwind-protect) t form)) - (`(setq ,(and var (pred symbolp) - (pred (not booleanp)) (pred (not keywordp))) - ,expr) - ;; Fast path for the setq common case. - (let ((new-expr (macroexp--expand-all expr))) - (if (eq new-expr expr) - form - `(,fn ,var ,new-expr)))) + (`(while . ,args) + (if args + (macroexp--all-forms form 1) + (macroexp-warn-and-return + (format-message "missing `while' condition") + `(signal 'wrong-number-of-arguments '(while 0)) + nil 'compile-only form))) + (`(unwind-protect . ,args) + (if (cdr-safe args) + (macroexp--all-forms form 1) + (macroexp-warn-and-return + (format-message "`unwind-protect' without unwind forms") + (macroexp--expand-all (car-safe args)) + (list 'suspicious 'unwind-protect) t form))) (`(setq . ,args) - ;; Normalize to a sequence of (setq SYM EXPR). - ;; Malformed code is translated to code that signals an error - ;; at run time. - (let ((nargs (length args))) - (if (oddp nargs) - (macroexp-warn-and-return - (format-message "odd number of arguments in `setq' form") - `(signal 'wrong-number-of-arguments '(setq ,nargs)) - nil 'compile-only fn) - (let ((assignments nil)) - (while (consp (cdr-safe args)) - (let* ((var (car args)) - (expr (cadr args)) - (new-expr (macroexp--expand-all expr)) - (assignment - (if (and (symbolp var) - (not (booleanp var)) (not (keywordp var))) - `(,fn ,var ,new-expr) - (macroexp-warn-and-return - (format-message "attempt to set %s `%s'" - (if (symbolp var) - "constant" - "non-variable") - var) - (cond - ((keywordp var) - ;; Accept `(setq :a :a)' for compatibility. - `(if (eq ,var ,new-expr) - ,var - (signal 'setting-constant (list ',var)))) - ((symbolp var) - `(signal 'setting-constant (list ',var))) - (t - `(signal 'wrong-type-argument - (list 'symbolp ',var)))) - nil 'compile-only var)))) - (push assignment assignments)) - (setq args (cddr args))) - (cons 'progn (nreverse assignments)))))) - (`(,(and fun `(lambda . ,_)) . ,args) - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) + (let ((nargs (length args)) + (var (car-safe args))) + (if (and (= nargs 2) + (symbolp var) + (not (booleanp var)) (not (keywordp var))) + ;; Fast path for the common case. + (let* ((expr (nth 1 args)) + (new-expr (macroexp--expand-all expr))) + (if (eq new-expr expr) + form + `(,fn ,var ,new-expr))) + ;; Normalize to a sequence of (setq SYM EXPR). + ;; Malformed code is translated to code that signals an error + ;; at run time. + (if (oddp nargs) + (macroexp-warn-and-return + (format-message "odd number of arguments in `setq' form") + `(signal 'wrong-number-of-arguments '(setq ,nargs)) + nil 'compile-only fn) + (let ((assignments nil)) + (while (consp (cdr-safe args)) + (let* ((var (car args)) + (expr (cadr args)) + (new-expr (macroexp--expand-all expr)) + (assignment + (if (and (symbolp var) + (not (booleanp var)) + (not (keywordp var))) + `(,fn ,var ,new-expr) + (macroexp-warn-and-return + (format-message "attempt to set %s `%s'" + (if (symbolp var) + "constant" + "non-variable") + var) + (cond + ((keywordp var) + ;; Accept `(setq :a :a)' for compatibility. + ;; FIXME: Why, exactly? It's useless. + `(if (eq ,var ,new-expr) + ,var + (signal 'setting-constant (list ',var)))) + ((symbolp var) + `(signal 'setting-constant (list ',var))) + (t + `(signal 'wrong-type-argument + (list 'symbolp ',var)))) + nil 'compile-only var)))) + (push assignment assignments)) + (setq args (cddr args))) + (cons 'progn (nreverse assignments))))))) (`(funcall ,exp . ,args) (let ((eexp (macroexp--expand-all exp)) (eargs (macroexp--all-forms args))) - (pcase eexp - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - ((and `#',f - (guard (and (symbolp f) - ;; bug#46636 - (not (or (special-form-p f) (macrop f)))))) - (macroexp--expand-all `(,f . ,eargs))) - (`#'(lambda . ,_) - (macroexp--unfold-lambda `(,fn ,eexp . ,eargs))) - (_ `(,fn ,eexp . ,eargs))))) + (if (eq (car-safe eexp) 'function) + (let ((f (cadr eexp))) + (cond + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + ((and (symbolp f) + ;; bug#46636 + (not (or (special-form-p f) (macrop f)))) + (macroexp--expand-all `(,f . ,eargs))) + ((eq (car-safe f) 'lambda) + (macroexp--unfold-lambda `(,fn ,eexp . ,eargs))) + (t `(,fn ,eexp . ,eargs)))) + `(,fn ,eexp . ,eargs)))) (`(funcall . ,_) form) ;bug#53227 (`(,(and func (pred symbolp)) . ,_) (let ((handler (function-get func 'compiler-macro))) @@ -597,6 +610,10 @@ Assumes the caller has bound `macroexpand-all-environment'." newform (macroexp--expand-all form))) (macroexp--expand-all newform)))))) + (`(,(and fun `(lambda . ,_)) . ,args) + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form)) (_ form)))))) ;;;###autoload diff --git a/lisp/emacs-lisp/package-activate.el b/lisp/emacs-lisp/package-activate.el new file mode 100644 index 00000000000..e130304be5c --- /dev/null +++ b/lisp/emacs-lisp/package-activate.el @@ -0,0 +1,538 @@ +;;; package-activate.el --- Core of the Emacs Package Manager -*- lexical-binding:t -*- + +;; Copyright (C) 2007-2026 Free Software Foundation, Inc. + +;; Author: Tom Tromey +;; Daniel Hackney +;; Created: 10 Mar 2007 +;; Version: 1.1.0 +;; Keywords: tools +;; Package-Requires: ((tabulated-list "1.0")) + +;; 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 . + +;;; Commentary: + +;; This file contains the core definitions of package.el used to +;; activate packages at startup, as well as other functions that are +;; useful without having to load the entirety of package.el. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(defcustom package-load-list '(all) + "List of packages for `package-activate-all' to make available. +Each element in this list should be a list (NAME VERSION), or the +symbol `all'. The symbol `all' says to make available the latest +installed versions of all packages not specified by other +elements. + +For an element (NAME VERSION), NAME is a package name (a symbol). +VERSION should be t, a string, or nil. +If VERSION is t, the most recent version is made available. +If VERSION is a string, only that version is ever made available. + Any other version, even if newer, is silently ignored. + Hence, the package is \"held\" at that version. +If VERSION is nil, the package is not made available (it is \"disabled\")." + :type '(repeat (choice (const all) + (list :tag "Specific package" + (symbol :tag "Package name") + (choice :tag "Version" + (const :tag "disable" nil) + (const :tag "most recent" t) + (string :tag "specific version"))))) + :risky t + :version "24.1" + :group 'package) + +(defvar package--default-summary "No description available.") + +(define-inline package-vc-p (pkg-desc) + "Return non-nil if PKG-DESC is a VC package." + (inline-letevals (pkg-desc) + (inline-quote (eq (package-desc-kind ,pkg-desc) 'vc)))) + +(cl-defstruct (package-desc + ;; Rename the default constructor from `make-package-desc'. + (:constructor package-desc-create) + ;; Has the same interface as the old `define-package', + ;; which is still used in the "foo-pkg.el" files. Extra + ;; options can be supported by adding additional keys. + (:constructor + package-desc-from-define + (name-string version-string &optional summary requirements + &rest rest-plist + &aux + (name (intern name-string)) + (version (if (eq (car-safe version-string) 'vc) + (version-to-list (cdr version-string)) + (version-to-list version-string))) + (reqs (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + (if (eq 'quote (car requirements)) + (nth 1 requirements) + requirements))) + (kind (plist-get rest-plist :kind)) + (archive (plist-get rest-plist :archive)) + (extras (let (alist) + (while rest-plist + (unless (memq (car rest-plist) '(:kind :archive)) + (let ((value (cadr rest-plist))) + (when value + (push (cons (car rest-plist) + (if (eq (car-safe value) 'quote) + (cadr value) + value)) + alist)))) + (setq rest-plist (cddr rest-plist))) + alist))))) + "Structure containing information about an individual package. +Slots: + +`name' Name of the package, as a symbol. + +`version' Version of the package, as a version list. + +`summary' Short description of the package, typically taken from + the first line of the file. + +`reqs' Requirements of the package. A list of (PACKAGE + VERSION-LIST) naming the dependent package and the minimum + required version. + +`kind' The distribution format of the package. Currently, it is + either `single', `tar', or (temporarily only) `dir'. In + addition, there is distribution format `vc', which is handled + by package-vc.el. + +`archive' The name of the archive (as a string) whence this + package came. + +`dir' The directory where the package is installed (if installed), + `builtin' if it is built-in, or nil otherwise. + +`extras' Optional alist of additional keyword-value pairs. + +`signed' Flag to indicate that the package is signed by provider." + name + version + (summary package--default-summary) + reqs + kind + archive + dir + extras + signed) + +;; Pseudo fields. +(defun package-version-join (vlist) + "Return the version string corresponding to the list VLIST. +This is, approximately, the inverse of `version-to-list'. +\(Actually, it returns only one of the possible inverses, since +`version-to-list' is a many-to-one operation.)" + (if (null vlist) + "" + (let ((str-list (list "." (int-to-string (car vlist))))) + (dolist (num (cdr vlist)) + (cond + ((>= num 0) + (push (int-to-string num) str-list) + (push "." str-list)) + ((< num -4) + (error "Invalid version list `%s'" vlist)) + (t + ;; pre, or beta, or alpha + (cond ((equal "." (car str-list)) + (pop str-list)) + ((not (string-match "[0-9]+" (car str-list))) + (error "Invalid version list `%s'" vlist))) + (push (cond ((= num -1) "pre") + ((= num -2) "beta") + ((= num -3) "alpha") + ((= num -4) "snapshot")) + str-list)))) + (if (equal "." (car str-list)) + (pop str-list)) + (apply #'concat (nreverse str-list))))) + +(defun package-desc-full-name (pkg-desc) + "Return full name of package-desc object PKG-DESC. +This is the name of the package with its version appended." + (if (package-vc-p pkg-desc) + (symbol-name (package-desc-name pkg-desc)) + (format "%s-%s" + (package-desc-name pkg-desc) + (package-version-join (package-desc-version pkg-desc))))) + + +;;; Installed packages +;; The following variables store information about packages present in +;; the system. The most important of these is `package-alist'. The +;; command `package-activate-all' is also closely related to this +;; section. + +(defvar package--builtins nil + "Alist of built-in packages. +The actual value is initialized by loading the library +`finder-inf'; this is not done until it is needed, e.g. by the +function `package-built-in-p'. + +Each element has the form (PKG . PACKAGE-BI-DESC), where PKG is a package +name (a symbol) and DESC is a `package--bi-desc' structure.") +(put 'package--builtins 'risky-local-variable t) + +(defvar package-alist nil + "Alist of all packages available for activation. +Each element has the form (PKG . DESCS), where PKG is a package +name (a symbol) and DESCS is a non-empty list of `package-desc' +structures, sorted by decreasing versions. + +This variable is set automatically by `package-load-descriptor', +called via `package-activate-all'. To change which packages are +loaded and/or activated, customize `package-load-list'.") +(put 'package-alist 'risky-local-variable t) + +;;;; Public interfaces for accessing built-in package info + +;;;###autoload +(defvar package-activated-list nil + ;; FIXME: This should implicitly include all builtin packages. + "List of the names of currently activated packages.") +(put 'package-activated-list 'risky-local-variable t) + +;;;; Populating `package-alist'. + +;; The following functions are called on each installed package by +;; `package-load-all-descriptors', which ultimately populates the +;; `package-alist' variable. + +(defun package-process-define-package (exp) + "Process define-package expression EXP and push it to `package-alist'. +EXP should be a form read from a foo-pkg.el file. +Convert EXP into a `package-desc' object using the +`package-desc-from-define' constructor before pushing it to +`package-alist'. + +If there already exists a package by the same name in +`package-alist', insert this object there such that the packages +are sorted with the highest version first." + (when (eq (car-safe exp) 'define-package) + (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) + (name (package-desc-name new-pkg-desc)) + (version (package-desc-version new-pkg-desc)) + (old-pkgs (assq name package-alist))) + (if (null old-pkgs) + ;; If there's no old package, just add this to `package-alist'. + (push (list name new-pkg-desc) package-alist) + ;; If there is, insert the new package at the right place in the list. + (while + (if (and (cdr old-pkgs) + (version-list-< version + (package-desc-version (cadr old-pkgs)))) + (setq old-pkgs (cdr old-pkgs)) + (push new-pkg-desc (cdr old-pkgs)) + nil))) + new-pkg-desc))) + +(defun package-load-descriptor (pkg-dir) + "Load the package description file in directory PKG-DIR. +Create a new `package-desc' object, add it to `package-alist' and +return it." + (let ((pkg-file (expand-file-name (package--description-file pkg-dir) + pkg-dir)) + (signed-file (concat pkg-dir ".signed"))) + (when (file-exists-p pkg-file) + (with-temp-buffer + (insert-file-contents pkg-file) + (goto-char (point-min)) + (let ((pkg-desc (or (package-process-define-package + (read (current-buffer))) + (error "Can't find define-package in %s" pkg-file)))) + (setf (package-desc-dir pkg-desc) pkg-dir) + (if (file-exists-p signed-file) + (setf (package-desc-signed pkg-desc) t)) + pkg-desc))))) + +(defun package-load-all-descriptors () + "Load descriptors for installed Emacs Lisp packages. +This looks for package subdirectories in `package-user-dir' and +`package-directory-list'. The variable `package-load-list' +controls which package subdirectories may be loaded. + +In each valid package subdirectory, this function loads the +description file containing a call to `define-package', which +updates `package-alist'." + (dolist (dir (cons package-user-dir package-directory-list)) + (when (file-directory-p dir) + (dolist (pkg-dir (directory-files dir t "\\`[^.]")) + (when (file-directory-p pkg-dir) + (package-load-descriptor pkg-dir)))))) + +(defun package--alist () + "Return `package-alist', after computing it if needed." + (or package-alist + (progn (package-load-all-descriptors) + package-alist))) + + +;;; Package activation +;; Section for functions used by `package-activate', which see. + +(defun package-disabled-p (pkg-name version) + "Return whether PKG-NAME at VERSION can be activated. +The decision is made according to `package-load-list'. +Return nil if the package can be activated. +Return t if the package is completely disabled. +Return the max version (as a string) if the package is held at a lower version." + (let ((force (assq pkg-name package-load-list))) + (cond ((null force) (not (memq 'all package-load-list))) + ((null (setq force (cadr force))) t) ; disabled + ((eq force t) nil) + ((stringp force) ; held + (unless (version-list-= version (version-to-list force)) + force)) + (t (error "Invalid element in `package-load-list'"))))) + +(defun package-built-in-p (package &optional min-version) + "Return non-nil if PACKAGE is built-in to Emacs. +Optional arg MIN-VERSION, if non-nil, should be a version list +specifying the minimum acceptable version." + (if (package-desc-p package) ;; was built-in and then was converted + (eq 'builtin (package-desc-dir package)) + (let ((bi (assq package package--builtin-versions))) + (cond + (bi (version-list-<= min-version (cdr bi))) + ((remove 0 min-version) nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins)))))) + +(defun package--autoloads-file-name (pkg-desc) + "Return the absolute name of the autoloads file, sans extension. +PKG-DESC is a `package-desc' object." + (expand-file-name + (format "%s-autoloads" (package-desc-name pkg-desc)) + (package-desc-dir pkg-desc))) + +(declare-function info-initialize "info" ()) + +(defvar package--quickstart-pkgs t + "If set to a list, we're computing the set of pkgs to activate.") + +(defun package--add-info-node (pkg-dir) + "Add info node located in PKG-DIR." + (when (file-exists-p (expand-file-name "dir" pkg-dir)) + ;; FIXME: not the friendliest, but simple. + (require 'info) + (defvar Info-directory-list) + (info-initialize) + (add-to-list 'Info-directory-list pkg-dir))) + +(defun package-activate-1 (pkg-desc &optional reload deps) + "Activate package given by PKG-DESC, even if it was already active. +If DEPS is non-nil, also activate its dependencies (unless they +are already activated). +If RELOAD is non-nil, also `load' any files inside the package which +correspond to previously loaded files." + (let* ((name (package-desc-name pkg-desc)) + (pkg-dir (package-desc-dir pkg-desc))) + (unless pkg-dir + (error "Internal error: unable to find directory for `%s'" + (package-desc-full-name pkg-desc))) + (catch 'exit + ;; Activate its dependencies recursively. + ;; FIXME: This doesn't check whether the activated version is the + ;; required version. + (when deps + (dolist (req (package-desc-reqs pkg-desc)) + (unless (package-activate (car req)) + (message "Unable to activate package `%s'.\nRequired package `%s-%s' is unavailable" + name (car req) (package-version-join (cadr req))) + (throw 'exit nil)))) + (if (listp package--quickstart-pkgs) + ;; We're only collecting the set of packages to activate! + (push pkg-desc package--quickstart-pkgs) + (when (or reload (assq name package--builtin-versions)) + (require 'package) + (declare-function package--reload-previously-loaded + "package" (pkg-desc &optional warn)) + + (package--reload-previously-loaded + pkg-desc (unless reload + "Package %S is activated too late. +The following files have already been loaded: %S"))) + (with-demoted-errors "Error loading autoloads: %s" + (load (package--autoloads-file-name pkg-desc) nil t))) + (package--add-info-node pkg-dir) + (push name package-activated-list) + ;; Don't return nil. + t))) + +;;;; `package-activate' + +(defun package--get-activatable-pkg (pkg-name) + ;; Is "activatable" a word? + (let ((pkg-descs (cdr (assq pkg-name package-alist)))) + ;; Check if PACKAGE is available in `package-alist'. + (while + (when pkg-descs + (let ((available-version (package-desc-version (car pkg-descs)))) + (or (package-disabled-p pkg-name available-version) + ;; Prefer a builtin package. + (package-built-in-p pkg-name available-version)))) + (setq pkg-descs (cdr pkg-descs))) + (car pkg-descs))) + +;; This function activates a newer version of a package if an older +;; one was already activated. It also loads a features of this +;; package which were already loaded. +(defun package-activate (package &optional force) + "Activate the package named PACKAGE. +If FORCE is true, (re-)activate it if it's already activated. +Newer versions are always activated, regardless of FORCE." + (let ((pkg-desc (package--get-activatable-pkg package))) + (cond + ;; If no such package is found, maybe it's built-in. + ((null pkg-desc) + (package-built-in-p package)) + ;; If the package is already activated, just return t. + ((and (memq package package-activated-list) (not force)) + t) + ;; Otherwise, proceed with activation. + (t (package-activate-1 pkg-desc nil 'deps))))) + + +;;; Installation -- Local operations +;; This section contains a variety of features regarding installing a +;; package to/from disk. This includes autoload generation, +;; unpacking, compiling, as well as defining a package from the +;; current buffer. + +;;;; Unpacking + +;;;###autoload +(defvar package--activated nil + "Non-nil if `package-activate-all' has been run.") + +;;;###autoload +(progn ;; Make the function usable without loading `package.el'. +(defun package-activate-all () + "Activate all installed packages. +The variable `package-load-list' controls which packages to load." + (setq package--activated t) + (let* ((elc (concat package-quickstart-file "c")) + (qs (if (file-readable-p elc) elc + (if (file-readable-p package-quickstart-file) + package-quickstart-file)))) + ;; The quickstart file presumes that it has a blank slate, + ;; so don't use it if we already activated some packages. + (or (and qs (not (bound-and-true-p package-activated-list)) + ;; Skip `load-source-file-function' which would slow us down by + ;; a factor 2 when loading the .el file (this assumes we were + ;; careful to save this file so it doesn't need any decoding). + (with-demoted-errors "Error during quickstart: %S" + (let ((load-source-file-function nil)) + (unless (boundp 'package-activated-list) + (setq package-activated-list nil)) + (load qs nil 'nomessage) + t))) + (progn + (require 'package) + ;; Silence the "unknown function" warning when this is compiled + ;; inside `loaddefs.el'. + ;; FIXME: We use `with-no-warnings' because the effect of + ;; `declare-function' is currently not scoped, so if we use + ;; it here, we end up with a redefinition warning instead :-) + (with-no-warnings + (package--activate-all))))))) + +(defun package--activate-all () + (dolist (elt (package--alist)) + (condition-case err + (package-activate (car elt)) + ;; Don't let failure of activation of a package arbitrarily stop + ;; activation of further packages. + (error (message "%s" (error-message-string err)))))) + +;;;; Inferring package from current buffer + +(declare-function lm-package-version "lisp-mnt" (&optional file)) + +;;;###autoload +(defun package-installed-p (package &optional min-version) + "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a `package-desc' object, MIN-VERSION is ignored." + (cond + ((package-desc-p package) + (let ((dir (package-desc-dir package))) + (and (stringp dir) + (file-exists-p dir)))) + ((and (not (bound-and-true-p package--initialized)) + (null min-version) + package-activated-list) + ;; We used the quickstart: make it possible to use package-installed-p + ;; even before package is fully initialized. + (or + (memq package package-activated-list) + ;; Also check built-in packages. + (package-built-in-p package min-version))) + (t + (or + (let ((pkg-descs (cdr (assq package (package--alist))))) + (and pkg-descs + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) + ;; Also check built-in packages. + (package-built-in-p package min-version))))) + +;;;###autoload +(defun package-get-version () + "Return the version number of the package in which this is used. +Assumes it is used from an Elisp file placed inside the top-level directory +of an installed ELPA package. +The return value is a string (or nil in case we can't find it). +It works in more cases if the call is in the file which contains +the `Version:' header." + ;; In a sense, this is a lie, but it does just what we want: precomputes + ;; the version at compile time and hardcodes it into the .elc file! + (declare (pure t)) + ;; Hack alert! + (let ((file (or (macroexp-file-name) buffer-file-name))) + (cond + ((null file) nil) + ;; Packages are normally installed into directories named "-", + ;; so get the version number from there. + ((string-match "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" file) + (match-string 1 file)) + ;; For packages run straight from the an elpa.git clone, there's no + ;; "-" in the directory name, so we have to fetch the version + ;; the hard way. + (t + (let* ((pkgdir (file-name-directory file)) + (pkgname (file-name-nondirectory (directory-file-name pkgdir))) + (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) + (unless (file-readable-p mainfile) (setq mainfile file)) + (when (file-readable-p mainfile) + (require 'lisp-mnt) + (lm-package-version mainfile))))))) + +(provide 'package-activate) +;;; package-activate.el ends here diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index c5e94c90e9b..11ea9d2850f 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -1086,13 +1086,17 @@ See also `vc-prepare-patch'." (vc-prepare-patch (package-maintainers pkg-desc t) subject revisions))) -(defun package-vc-log-incoming (pkg-desc) - "Call `vc-log-incoming' for the package PKG-DESC." +(defun package-vc-root-log-incoming (pkg-desc) + "Call `vc-root-log-incoming' for the package PKG-DESC." (interactive (list (package-vc--read-package-desc "Incoming log for package: " t))) (let ((default-directory (package-vc--checkout-dir pkg-desc)) (vc-deduce-backend-nonvc-modes t)) - (call-interactively #'vc-log-incoming))) + (call-interactively #'vc-root-log-incoming))) +(define-obsolete-function-alias + 'package-vc-log-incoming + #'package-vc-root-log-incoming + "31.1") (provide 'package-vc) ;;; package-vc.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 54e905109b3..407c4496d81 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -143,6 +143,8 @@ ;;; Code: +(require 'package-activate) + (require 'cl-lib) (eval-when-compile (require 'subr-x)) (eval-when-compile (require 'epg)) ;For setf accessors. @@ -184,30 +186,6 @@ your `early-init-file'." :type 'boolean :version "24.1") -(defcustom package-load-list '(all) - "List of packages for `package-activate-all' to make available. -Each element in this list should be a list (NAME VERSION), or the -symbol `all'. The symbol `all' says to make available the latest -installed versions of all packages not specified by other -elements. - -For an element (NAME VERSION), NAME is a package name (a symbol). -VERSION should be t, a string, or nil. -If VERSION is t, the most recent version is made available. -If VERSION is a string, only that version is ever made available. - Any other version, even if newer, is silently ignored. - Hence, the package is \"held\" at that version. -If VERSION is nil, the package is not made available (it is \"disabled\")." - :type '(repeat (choice (const all) - (list :tag "Specific package" - (symbol :tag "Package name") - (choice :tag "Version" - (const :tag "disable" nil) - (const :tag "most recent" t) - (string :tag "specific version"))))) - :risky t - :version "24.1") - (defcustom package-archives `(("gnu" . ,(format "http%s://elpa.gnu.org/packages/" (if (gnutls-available-p) "s" ""))) @@ -459,86 +437,6 @@ synchronously." ;; but keep in mind there could be multiple `package-desc's with the ;; same name. -(defvar package--default-summary "No description available.") - -(define-inline package-vc-p (pkg-desc) - "Return non-nil if PKG-DESC is a VC package." - (inline-letevals (pkg-desc) - (inline-quote (eq (package-desc-kind ,pkg-desc) 'vc)))) - -(cl-defstruct (package-desc - ;; Rename the default constructor from `make-package-desc'. - (:constructor package-desc-create) - ;; Has the same interface as the old `define-package', - ;; which is still used in the "foo-pkg.el" files. Extra - ;; options can be supported by adding additional keys. - (:constructor - package-desc-from-define - (name-string version-string &optional summary requirements - &rest rest-plist - &aux - (name (intern name-string)) - (version (if (eq (car-safe version-string) 'vc) - (version-to-list (cdr version-string)) - (version-to-list version-string))) - (reqs (mapcar (lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) - (if (eq 'quote (car requirements)) - (nth 1 requirements) - requirements))) - (kind (plist-get rest-plist :kind)) - (archive (plist-get rest-plist :archive)) - (extras (let (alist) - (while rest-plist - (unless (memq (car rest-plist) '(:kind :archive)) - (let ((value (cadr rest-plist))) - (when value - (push (cons (car rest-plist) - (if (eq (car-safe value) 'quote) - (cadr value) - value)) - alist)))) - (setq rest-plist (cddr rest-plist))) - alist))))) - "Structure containing information about an individual package. -Slots: - -`name' Name of the package, as a symbol. - -`version' Version of the package, as a version list. - -`summary' Short description of the package, typically taken from - the first line of the file. - -`reqs' Requirements of the package. A list of (PACKAGE - VERSION-LIST) naming the dependent package and the minimum - required version. - -`kind' The distribution format of the package. Currently, it is - either `single', `tar', or (temporarily only) `dir'. In - addition, there is distribution format `vc', which is handled - by package-vc.el. - -`archive' The name of the archive (as a string) whence this - package came. - -`dir' The directory where the package is installed (if installed), - `builtin' if it is built-in, or nil otherwise. - -`extras' Optional alist of additional keyword-value pairs. - -`signed' Flag to indicate that the package is signed by provider." - name - version - (summary package--default-summary) - reqs - kind - archive - dir - extras - signed) - (defun package--from-builtin (bi-desc) "Create a `package-desc' object from BI-DESC. BI-DESC should be a `package--bi-desc' object." @@ -547,46 +445,6 @@ BI-DESC should be a `package--bi-desc' object." :summary (package--bi-desc-summary bi-desc) :dir 'builtin)) -;; Pseudo fields. -(defun package-version-join (vlist) - "Return the version string corresponding to the list VLIST. -This is, approximately, the inverse of `version-to-list'. -\(Actually, it returns only one of the possible inverses, since -`version-to-list' is a many-to-one operation.)" - (if (null vlist) - "" - (let ((str-list (list "." (int-to-string (car vlist))))) - (dolist (num (cdr vlist)) - (cond - ((>= num 0) - (push (int-to-string num) str-list) - (push "." str-list)) - ((< num -4) - (error "Invalid version list `%s'" vlist)) - (t - ;; pre, or beta, or alpha - (cond ((equal "." (car str-list)) - (pop str-list)) - ((not (string-match "[0-9]+" (car str-list))) - (error "Invalid version list `%s'" vlist))) - (push (cond ((= num -1) "pre") - ((= num -2) "beta") - ((= num -3) "alpha") - ((= num -4) "snapshot")) - str-list)))) - (if (equal "." (car str-list)) - (pop str-list)) - (apply #'concat (nreverse str-list))))) - -(defun package-desc-full-name (pkg-desc) - "Return full name of package-desc object PKG-DESC. -This is the name of the package with its version appended." - (if (package-vc-p pkg-desc) - (symbol-name (package-desc-name pkg-desc)) - (format "%s-%s" - (package-desc-name pkg-desc) - (package-version-join (package-desc-version pkg-desc))))) - (defun package-desc-suffix (pkg-desc) "Return file-name extension of package-desc object PKG-DESC. Depending on the `package-desc-kind' of PKG-DESC, this is one of: @@ -645,54 +503,6 @@ package." ;;; Installed packages -;; The following variables store information about packages present in -;; the system. The most important of these is `package-alist'. The -;; command `package-activate-all' is also closely related to this -;; section. - -(defvar package--builtins nil - "Alist of built-in packages. -The actual value is initialized by loading the library -`finder-inf'; this is not done until it is needed, e.g. by the -function `package-built-in-p'. - -Each element has the form (PKG . PACKAGE-BI-DESC), where PKG is a package -name (a symbol) and DESC is a `package--bi-desc' structure.") -(put 'package--builtins 'risky-local-variable t) - -(defvar package-alist nil - "Alist of all packages available for activation. -Each element has the form (PKG . DESCS), where PKG is a package -name (a symbol) and DESCS is a non-empty list of `package-desc' -structures, sorted by decreasing versions. - -This variable is set automatically by `package-load-descriptor', -called via `package-activate-all'. To change which packages are -loaded and/or activated, customize `package-load-list'.") -(put 'package-alist 'risky-local-variable t) - -;;;; Public interfaces for accessing built-in package info - -(defun package-versioned-builtin-packages () - "Return a list of all the versioned built-in packages. -The return value is a list of names of built-in packages represented as -symbols." - (mapcar #'car package--builtin-versions)) - -(defun package-builtin-package-version (package) - "Return the version of a built-in PACKAGE given by its symbol. -The return value is a list of integers representing the version of -PACKAGE, in the format returned by `version-to-list', or nil if the -package is built-in but has no version or is not a built-in package." - (alist-get package package--builtin-versions)) - -;;;###autoload -(defvar package-activated-list nil - ;; FIXME: This should implicitly include all builtin packages. - "List of the names of currently activated packages.") -(put 'package-activated-list 'risky-local-variable t) - -;;;; Populating `package-alist'. ;; The following functions are called on each installed package by ;; `package-load-all-descriptors', which ultimately populates the @@ -730,46 +540,6 @@ are sorted with the highest version first." (declare-function package-vc-commit "package-vc" (pkg)) -(defun package-load-descriptor (pkg-dir) - "Load the package description file in directory PKG-DIR. -Create a new `package-desc' object, add it to `package-alist' and -return it." - (let ((pkg-file (expand-file-name (package--description-file pkg-dir) - pkg-dir)) - (signed-file (concat pkg-dir ".signed"))) - (when (file-exists-p pkg-file) - (with-temp-buffer - (insert-file-contents pkg-file) - (goto-char (point-min)) - (let ((pkg-desc (or (package-process-define-package - (read (current-buffer))) - (error "Can't find define-package in %s" pkg-file)))) - (setf (package-desc-dir pkg-desc) pkg-dir) - (if (file-exists-p signed-file) - (setf (package-desc-signed pkg-desc) t)) - pkg-desc))))) - -(defun package-load-all-descriptors () - "Load descriptors for installed Emacs Lisp packages. -This looks for package subdirectories in `package-user-dir' and -`package-directory-list'. The variable `package-load-list' -controls which package subdirectories may be loaded. - -In each valid package subdirectory, this function loads the -description file containing a call to `define-package', which -updates `package-alist'." - (dolist (dir (cons package-user-dir package-directory-list)) - (when (file-directory-p dir) - (dolist (pkg-dir (directory-files dir t "\\`[^.]")) - (when (file-directory-p pkg-dir) - (package-load-descriptor pkg-dir)))))) - -(defun package--alist () - "Return `package-alist', after computing it if needed." - (or package-alist - (progn (package-load-all-descriptors) - package-alist))) - (defun define-package ( _name-string _version-string &optional _docstring _requirements &rest _extra-properties) @@ -785,39 +555,6 @@ EXTRA-PROPERTIES is currently unused." (declare (obsolete nil "29.1") (indent defun)) (error "Don't call me!")) - -;;; Package activation -;; Section for functions used by `package-activate', which see. - -(defun package-disabled-p (pkg-name version) - "Return whether PKG-NAME at VERSION can be activated. -The decision is made according to `package-load-list'. -Return nil if the package can be activated. -Return t if the package is completely disabled. -Return the max version (as a string) if the package is held at a lower version." - (let ((force (assq pkg-name package-load-list))) - (cond ((null force) (not (memq 'all package-load-list))) - ((null (setq force (cadr force))) t) ; disabled - ((eq force t) nil) - ((stringp force) ; held - (unless (version-list-= version (version-to-list force)) - force)) - (t (error "Invalid element in `package-load-list'"))))) - -(defun package-built-in-p (package &optional min-version) - "Return non-nil if PACKAGE is built-in to Emacs. -Optional arg MIN-VERSION, if non-nil, should be a version list -specifying the minimum acceptable version." - (if (package-desc-p package) ;; was built-in and then was converted - (eq 'builtin (package-desc-dir package)) - (let ((bi (assq package package--builtin-versions))) - (cond - (bi (version-list-<= min-version (cdr bi))) - ((remove 0 min-version) nil) - (t - (require 'finder-inf nil t) ; For `package--builtins'. - (assq package package--builtins)))))) - (defun package--active-built-in-p (package) "Return non-nil if the built-in version of PACKAGE is used. If the built-in version of PACKAGE is used and PACKAGE is @@ -833,19 +570,6 @@ version from the archive." (package--alist))) (package-built-in-p package))) -(defun package--autoloads-file-name (pkg-desc) - "Return the absolute name of the autoloads file, sans extension. -PKG-DESC is a `package-desc' object." - (expand-file-name - (format "%s-autoloads" (package-desc-name pkg-desc)) - (package-desc-dir pkg-desc))) - -(defvar Info-directory-list) -(declare-function info-initialize "info" ()) - -(defvar package--quickstart-pkgs t - "If set to a list, we're computing the set of pkgs to activate.") - (defsubst package--library-stem (file) (catch 'done (let (result) @@ -905,83 +629,6 @@ sexps)." (mapc (lambda (c) (load (car c) nil t)) (sort result (lambda (x y) (< (cdr x) (cdr y)))))))) -(defun package--add-info-node (pkg-dir) - "Add info node located in PKG-DIR." - (when (file-exists-p (expand-file-name "dir" pkg-dir)) - ;; FIXME: not the friendliest, but simple. - (require 'info) - (info-initialize) - (add-to-list 'Info-directory-list pkg-dir))) - -(defun package-activate-1 (pkg-desc &optional reload deps) - "Activate package given by PKG-DESC, even if it was already active. -If DEPS is non-nil, also activate its dependencies (unless they -are already activated). -If RELOAD is non-nil, also `load' any files inside the package which -correspond to previously loaded files." - (let* ((name (package-desc-name pkg-desc)) - (pkg-dir (package-desc-dir pkg-desc))) - (unless pkg-dir - (error "Internal error: unable to find directory for `%s'" - (package-desc-full-name pkg-desc))) - (catch 'exit - ;; Activate its dependencies recursively. - ;; FIXME: This doesn't check whether the activated version is the - ;; required version. - (when deps - (dolist (req (package-desc-reqs pkg-desc)) - (unless (package-activate (car req)) - (message "Unable to activate package `%s'.\nRequired package `%s-%s' is unavailable" - name (car req) (package-version-join (cadr req))) - (throw 'exit nil)))) - (if (listp package--quickstart-pkgs) - ;; We're only collecting the set of packages to activate! - (push pkg-desc package--quickstart-pkgs) - (when (or reload (assq name package--builtin-versions)) - (package--reload-previously-loaded - pkg-desc (unless reload - "Package %S is activated too late. -The following files have already been loaded: %S"))) - (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t))) - (package--add-info-node pkg-dir) - (push name package-activated-list) - ;; Don't return nil. - t))) - -;;;; `package-activate' - -(defun package--get-activatable-pkg (pkg-name) - ;; Is "activatable" a word? - (let ((pkg-descs (cdr (assq pkg-name package-alist)))) - ;; Check if PACKAGE is available in `package-alist'. - (while - (when pkg-descs - (let ((available-version (package-desc-version (car pkg-descs)))) - (or (package-disabled-p pkg-name available-version) - ;; Prefer a builtin package. - (package-built-in-p pkg-name available-version)))) - (setq pkg-descs (cdr pkg-descs))) - (car pkg-descs))) - -;; This function activates a newer version of a package if an older -;; one was already activated. It also loads a features of this -;; package which were already loaded. -(defun package-activate (package &optional force) - "Activate the package named PACKAGE. -If FORCE is true, (re-)activate it if it's already activated. -Newer versions are always activated, regardless of FORCE." - (let ((pkg-desc (package--get-activatable-pkg package))) - (cond - ;; If no such package is found, maybe it's built-in. - ((null pkg-desc) - (package-built-in-p package)) - ;; If the package is already activated, just return t. - ((and (memq package package-activated-list) (not force)) - t) - ;; Otherwise, proceed with activation. - (t (package-activate-1 pkg-desc nil 'deps))))) - ;;; Installation -- Local operations ;; This section contains a variety of features regarding installing a @@ -1022,40 +669,208 @@ untar into a directory named DIR; otherwise, signal an error." (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))) +(defcustom package-review-policy nil + "Policy to review incoming packages before installing them. +Reviewing a package allows you to read the source code without +installing anything, compare it to previous installations of the package +and read the change log. The default value of nil will install packages +without any additional prompts, while t reviews all packages. By +setting this user option to a list you can also selectively list what +packages and archives to review. For the former, an entry of the +form (archive STRING) will review all packages from the archive +STRING (see `package-archives'), and an entry of the form (package +SYMBOL) will review packages whose names match SYMBOL. If you prefix +the list with a symbol `not', the rules are inverted." + :type + (let ((choice '(choice :tag "Review specific packages or archives" + (cons :tag "Archive name" (const archive) string) + (cons :tag "Package name" (const package) symbol)))) + `(choice + (const :tag "Review all packages" t) + (repeat :tag "Review these specific packages and archives" ,choice) + (cons :tag "Review packages and archives except these" + (const not) (repeat ,choice)))) + :risky t + :version "31.1") + +(defcustom package-review-directory temporary-file-directory + "Directory to unpack packages for review. +The value of this user option is used to rebind the variable +`temporary-file-directory'. The directory doesn't have to exist; if +it doesn't, Emacs will create the directory for you. You can +therefore set the option to + + (setopt package-review-directory + (expand-file-name \"emacs\" (xdg-cache-home))) + +if you wish to have Emacs unpack the packages in your home directory, in +case you are concerned about moving files between file systems." + :type 'directory + :version "31.1") + +(defcustom package-review-diff-command + (cons diff-command + (mapcar #'shell-quote-argument + '("-u" ;unified patch formatting + "-N" ;treat absent files as empty + "-x" "*.elc" ;ignore byte compiled files + "-x" "*-autoloads.el" ;ignore the autoloads file + "-x" "*-pkg.el" ;ignore the package description + "-x" "*.info" ;ignore compiled Info files + ))) + "Configuration of how `package-review' should generate a Diff. +The structure of the value must be (COMMAND . OPTIONS), where +`diff-command' is rebound to be COMMAND and OPTIONS are command-line +switches and arguments passed to `diff-no-select' as the SWITCHES argument +if the user selects a diff-related option during review." + :type '(cons (string :tag "Diff command name") + (repeat :tag "Diff command-line arguments" string)) + :version "31.1") + +(defun package--review-p (pkg-desc) + "Return non-nil if upgrading PKG-DESC requires a review. +This function consults `package-review-policy' to determine if the user +wants to review the package prior to installation. See `package-review'." + (let ((archive (package-desc-archive pkg-desc)) + (name (package-desc-name pkg-desc))) + (pcase-exhaustive package-review-policy + ((and (pred listp) list) + (xor (any (lambda (ent) + (pcase ent + ((or `(archive . ,(pred (equal archive))) + `(package . ,(pred (eq name)))) + t) + (_ nil))) + (if (eq (car list) 'not) (cdr list) list)) + (eq (car list) 'not))) + ('t t)))) + + +(declare-function mail-text "sendmail" ()) +(declare-function message-goto-body "message" (&optional interactive)) +(declare-function diff-no-select "diff" (old new &optional switches no-async buf)) + +(defun package-review (pkg-desc pkg-dir old-desc) + "Review the package specified PKG-DESC which is about to be installed. +PKG-DIR is the directory where the downloaded source of PKG-DESC have +been downloaded. OLD-DESC is either a `package-desc' object of the +previous installation or nil, if there was no prior installation. If the +review fails, the function throws a symbol `review-failed' with PKG-DESC +attached." + (let ((news (package-find-news-file pkg-desc)) + (enable-recursive-minibuffers t) + (diff-command (car package-review-diff-command))) + (while (pcase-exhaustive + (car (read-multiple-choice + (format "Install \"%s\"?" (package-desc-name pkg-desc)) + `((?y "yes" "Proceed with installation") + (?n "no" "Abort installation") + ,@(and old-desc '((?d "diff" "Show the installation diff") + (?m "mail" "Send an email to the maintainers"))) + ,@(and news '((?c "changelog" "Show the changelog"))) + (?b "browse" "Browse the source")))) + (?y nil) + (?n + (delete-directory pkg-dir t) + (throw 'review-failed pkg-desc)) + (?d + (display-buffer + (diff-no-select + (package-desc-dir old-desc) pkg-dir (cdr package-review-diff-command) t + (get-buffer-create (format "*Package Review Diff: %s*" + (package-desc-full-name pkg-desc))))) + t) + (?m + (require 'diff) ;for `diff-no-select' + (with-temp-buffer + (diff-no-select + (package-desc-dir old-desc) pkg-dir + (cdr package-review-diff-command) + t (current-buffer)) + ;; delete sentinel message + (goto-char (point-max)) + (forward-line -2) + (narrow-to-region (point-min) (point)) + ;; prepare mail buffer + (let ((tmp-buf (current-buffer))) + (compose-mail (with-demoted-errors "Failed to find maintainers: %S" + (package-maintainers pkg-desc)) + (concat "Emacs Package Review: " + (package-desc-full-name pkg-desc))) + (pcase mail-user-agent + ('sendmail-user-agent (mail-text)) + (_ (message-goto-body))) + (let ((start (point))) + (save-excursion + (insert-buffer-substring tmp-buf) + (comment-region start (point)))))) + t) + (?c + (view-file news) + t) + (?b + (dired pkg-dir "-R") ;FIXME: Is recursive dired portable? + t))))) + (declare-function dired-get-marked-files "dired") (defun package-unpack (pkg-desc) - "Install the contents of the current buffer as a package." + "Install the contents of the current buffer as a package. +The argument PKG-DESC contains metadata of the yet to be installed +package. The function returns a `package-desc' object of the actually +installed package." (let* ((name (package-desc-name pkg-desc)) - (dirname (package-desc-full-name pkg-desc)) - (pkg-dir (expand-file-name dirname package-user-dir))) - (pcase (package-desc-kind pkg-desc) - ('dir - (make-directory pkg-dir t) - (let ((file-list - (or (and (derived-mode-p 'dired-mode) - (dired-get-marked-files nil 'marked)) - (directory-files-recursively default-directory "" nil)))) - (dolist (source-file file-list) - (let ((target (expand-file-name - (file-relative-name source-file default-directory) - pkg-dir))) - (make-directory (file-name-directory target) t) - (copy-file source-file target t))) - ;; Now that the files have been installed, this package is - ;; indistinguishable from a `tar' or a `single'. Let's make - ;; things simple by ensuring we're one of them. - (setf (package-desc-kind pkg-desc) - (if (length> file-list 1) 'tar 'single)))) - ('tar - (make-directory package-user-dir t) - (let* ((default-directory (file-name-as-directory package-user-dir))) - (package-untar-buffer dirname))) - ('single - (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir))) - (make-directory pkg-dir t) - (package--write-file-no-coding el-file))) - (kind (error "Unknown package kind: %S" kind))) + (full-name (package-desc-full-name pkg-desc)) + (pkg-dir (expand-file-name full-name package-user-dir)) + (review-p (package--review-p pkg-desc)) + (unpack-dir (if review-p + (let ((temporary-file-directory package-review-directory)) + (make-directory temporary-file-directory t) ;ensure existence + (expand-file-name + full-name + (make-temp-file "emacs-package-review-" t))) + pkg-dir)) + (old-desc (package--get-activatable-pkg name))) + (make-directory unpack-dir t) + (save-window-excursion + (pcase (package-desc-kind pkg-desc) + ('dir + (let ((file-list + (or (and (derived-mode-p 'dired-mode) + (dired-get-marked-files nil 'marked)) + (directory-files-recursively default-directory "" nil)))) + (dolist (source-file file-list) + (let ((target (expand-file-name + (file-relative-name source-file default-directory) + unpack-dir))) + (make-directory (file-name-directory target) t) + (copy-file source-file target t))) + ;; Now that the files have been installed, this package is + ;; indistinguishable from a `tar' or a `single'. Let's make + ;; things simple by ensuring we're one of them. + (setf (package-desc-kind pkg-desc) + (if (length> file-list 1) 'tar 'single)))) + ('tar + (let ((default-directory (file-name-directory unpack-dir))) + (package-untar-buffer (file-name-nondirectory unpack-dir)))) + ('single + (let ((el-file (expand-file-name (format "%s.el" name) unpack-dir))) + (package--write-file-no-coding el-file))) + (kind (error "Unknown package kind: %S" kind)))) + + ;; check if the user wants to review this package + (when review-p + (unwind-protect + (progn + (save-window-excursion + (package-review pkg-desc unpack-dir old-desc)) + (make-directory package-user-dir t) + (rename-file unpack-dir pkg-dir)) + (let ((temp-dir (file-name-directory unpack-dir))) + (when (file-directory-p temp-dir) + (delete-directory temp-dir t))))) + (cl-assert (file-directory-p pkg-dir)) + (package--make-autoloads-and-stuff pkg-desc pkg-dir) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) @@ -1075,8 +890,9 @@ untar into a directory named DIR; otherwise, signal an error." (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. - (package--reload-previously-loaded new-desc))) - pkg-dir)) + (package--reload-previously-loaded new-desc)) + + new-desc))) (defun package-generate-description-file (pkg-desc pkg-file) "Create the foo-pkg.el file PKG-FILE for single-file package PKG-DESC." @@ -1684,10 +1500,6 @@ If successful, set or update `package-archive-contents'." (defvar package--initialized nil "Non-nil if `package-initialize' has been run.") -;;;###autoload -(defvar package--activated nil - "Non-nil if `package-activate-all' has been run.") - ;;;###autoload (defun package-initialize (&optional no-activate) "Load Emacs Lisp packages, and activate them. @@ -1718,45 +1530,6 @@ that code in the early init-file." ;; `package--initialized' is t. (package--build-compatibility-table)) -;;;###autoload -(progn ;; Make the function usable without loading `package.el'. -(defun package-activate-all () - "Activate all installed packages. -The variable `package-load-list' controls which packages to load." - (setq package--activated t) - (let* ((elc (concat package-quickstart-file "c")) - (qs (if (file-readable-p elc) elc - (if (file-readable-p package-quickstart-file) - package-quickstart-file)))) - ;; The quickstart file presumes that it has a blank slate, - ;; so don't use it if we already activated some packages. - (or (and qs (not (bound-and-true-p package-activated-list)) - ;; Skip `load-source-file-function' which would slow us down by - ;; a factor 2 when loading the .el file (this assumes we were - ;; careful to save this file so it doesn't need any decoding). - (with-demoted-errors "Error during quickstart: %S" - (let ((load-source-file-function nil)) - (unless (boundp 'package-activated-list) - (setq package-activated-list nil)) - (load qs nil 'nomessage) - t))) - (progn - (require 'package) - ;; Silence the "unknown function" warning when this is compiled - ;; inside `loaddefs.el'. - ;; FIXME: We use `with-no-warnings' because the effect of - ;; `declare-function' is currently not scoped, so if we use - ;; it here, we end up with a redefinition warning instead :-) - (with-no-warnings - (package--activate-all))))))) - -(defun package--activate-all () - (dolist (elt (package--alist)) - (condition-case err - (package-activate (car elt)) - ;; Don't let failure of activation of a package arbitrarily stop - ;; activation of further packages. - (error (message "%s" (error-message-string err)))))) ;;;; Populating `package-archive-contents' from archives ;; This subsection populates the variables listed above from the @@ -2136,13 +1909,16 @@ if all the in-between dependencies are also in PACKAGE-LIST." (cdr (assoc (package-desc-archive desc) package-archives))) (defun package-install-from-archive (pkg-desc) - "Download and install a package defined by PKG-DESC." + "Download and install a package defined by PKG-DESC. +The function returns the new `package-desc' object of the installed +package." ;; This won't happen, unless the archive is doing something wrong. (when (eq (package-desc-kind pkg-desc) 'dir) (error "Can't install directory package from archive")) (let* ((location (package-archive-base pkg-desc)) (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc)))) + (package-desc-suffix pkg-desc))) + new-desc) (package--with-response-buffer location :file file (if (or (not (package-check-signature)) (member (package-desc-archive pkg-desc) @@ -2150,7 +1926,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." ;; If we don't care about the signature, unpack and we're ;; done. (let ((save-silently t)) - (package-unpack pkg-desc)) + (setq new-desc (package-unpack pkg-desc))) ;; If we care, check it and *then* write the file. (let ((content (buffer-string))) (package--check-signature @@ -2163,7 +1939,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." (cl-assert (not (multibyte-string-p content))) (insert content) (let ((save-silently t)) - (package-unpack pkg-desc))) + (setq new-desc (package-unpack pkg-desc)))) ;; Here the package has been installed successfully, mark it as ;; signed if appropriate. (when good-sigs @@ -2194,45 +1970,27 @@ if all the in-between dependencies are also in PACKAGE-LIST." (unless (save-excursion (goto-char (point-min)) (looking-at-p "[[:space:]]*\\'")) - (write-region nil nil readme))))))) - -;;;###autoload -(defun package-installed-p (package &optional min-version) - "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. -If PACKAGE is a symbol, it is the package name and MIN-VERSION -should be a version list. - -If PACKAGE is a `package-desc' object, MIN-VERSION is ignored." - (cond - ((package-desc-p package) - (let ((dir (package-desc-dir package))) - (and (stringp dir) - (file-exists-p dir)))) - ((and (not package--initialized) - (null min-version) - package-activated-list) - ;; We used the quickstart: make it possible to use package-installed-p - ;; even before package is fully initialized. - (or - (memq package package-activated-list) - ;; Also check built-in packages. - (package-built-in-p package min-version))) - (t - (or - (let ((pkg-descs (cdr (assq package (package--alist))))) - (and pkg-descs - (version-list-<= min-version - (package-desc-version (car pkg-descs))))) - ;; Also check built-in packages. - (package-built-in-p package min-version))))) + (write-region nil nil readme))))) + new-desc)) (defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. -PACKAGES should be a list of `package-desc'. -This function assumes that all package requirements in -PACKAGES are satisfied, i.e. that PACKAGES is computed -using `package-compute-transaction'." - (mapc #'package-install-from-archive packages)) +PACKAGES should be a list of `package-desc'. This function assumes that +all package requirements in PACKAGES are satisfied, i.e. that PACKAGES +is computed using `package-compute-transaction'. The function returns a +list of `package-desc' objects that have been installed, or nil if the +transaction had no effect." + (let* ((installed '()) + (pkg-desc (catch 'review-failed + (dolist (pkg-desc packages nil) + (push (package-install-from-archive pkg-desc) + installed))))) + (if pkg-desc + (progn + (message "Rejected `%s', reverting transaction." (package-desc-name pkg-desc)) + (mapc #'package-delete installed) + nil) + installed))) (defun package--archives-initialize () "Make sure the list of installed and remote packages are initialized." @@ -2250,7 +2008,7 @@ package archive." :version "29.1") ;;;###autoload -(defun package-install (pkg &optional dont-select) +(defun package-install (pkg &optional dont-select interactive) "Install the package PKG. PKG can be a `package-desc', or a symbol naming one of the available @@ -2278,34 +2036,36 @@ had been enabled." "Install package: " package-archive-contents nil t)) - nil))) + nil + 'interactive))) (cl-check-type pkg (or symbol package-desc)) (package--archives-initialize) (add-hook 'post-command-hook #'package-menu--post-refresh) (let ((name (if (package-desc-p pkg) (package-desc-name pkg) pkg))) - (when (or (and package-install-upgrade-built-in - (package--active-built-in-p pkg)) - (package-installed-p pkg)) - (user-error "`%s' is already installed" name)) - (unless (or dont-select (package--user-selected-p name)) - (package--save-selected-packages - (cons name package-selected-packages))) - (when (and (or current-prefix-arg package-install-upgrade-built-in) - (package--active-built-in-p pkg)) - (setq pkg (or (cadr (assq name package-archive-contents)) pkg))) - (if-let* ((transaction - (if (package-desc-p pkg) - (unless (package-installed-p pkg) - (package-compute-transaction (list pkg) - (package-desc-reqs pkg))) - (package-compute-transaction () (list (list pkg)))))) - (progn - (package-download-transaction transaction) - (package--quickstart-maybe-refresh) - (message "Package `%s' installed." name))))) - + (if (or (and package-install-upgrade-built-in + (package--active-built-in-p pkg)) + (package-installed-p pkg)) + (funcall (if interactive #'user-error #'message) + "`%s' is already installed" name) + (unless (or dont-select (package--user-selected-p name)) + (package--save-selected-packages + (cons name package-selected-packages))) + (when (and (or current-prefix-arg package-install-upgrade-built-in) + (package--active-built-in-p pkg)) + (setq pkg (or (cadr (assq name package-archive-contents)) pkg))) + (if-let* ((transaction + (if (package-desc-p pkg) + (unless (package-installed-p pkg) + (package-compute-transaction (list pkg) + (package-desc-reqs pkg))) + (package-compute-transaction () (list (list pkg)))))) + (if (package-download-transaction transaction) + (progn + (package--quickstart-maybe-refresh) + (message "Package `%s' installed" name)) + (error "Package `%s' not installed" name)))))) (declare-function package-vc-upgrade "package-vc" (pkg)) @@ -2324,12 +2084,17 @@ NAME should be a symbol." ;; `pkg-desc' will be nil when the package is an "active built-in". (if (and pkg-desc (package-vc-p pkg-desc)) (package-vc-upgrade pkg-desc) - (when pkg-desc - (package-delete pkg-desc 'force 'dont-unselect)) - (package-install name - ;; An active built-in has never been "selected" - ;; before. Mark it as installed explicitly. - (and pkg-desc 'dont-select))))) + (let ((new-desc (cadr (assq name package-archive-contents)))) + (when (or (null new-desc) + (version-list-= (package-desc-version pkg-desc) + (package-desc-version new-desc))) + (user-error "Cannot upgrade `%s'" name)) + (package-install new-desc + ;; An active built-in has never been "selected" + ;; before. Mark it as installed explicitly. + (and pkg-desc 'dont-select)) + (when pkg-desc + (package-delete pkg-desc 'force 'dont-unselect)))))) (defun package--upgradeable-packages (&optional include-builtins) ;; Initialize the package system to get the list of package @@ -2464,10 +2229,20 @@ Downloads and installs required packages as needed." (name (package-desc-name pkg-desc))) ;; Download and install the dependencies. (let* ((requires (package-desc-reqs pkg-desc)) - (transaction (package-compute-transaction nil requires))) - (package-download-transaction transaction)) - ;; Install the package itself. - (package-unpack pkg-desc) + (transaction (package-compute-transaction nil requires)) + (installed (package-download-transaction transaction))) + (when (and (catch 'review-failed + ;; Install the package itself. + (package-unpack pkg-desc) + nil) + (or (null transaction) installed)) + (mapc #'package-delete installed) + (when installed + (message "Review uninstalled dependencies: %s" + (mapconcat #'package-desc-full-name + installed + ", "))) + (user-error "Installation aborted"))) (unless (package--user-selected-p name) (package--save-selected-packages (cons name package-selected-packages))) @@ -2552,7 +2327,7 @@ compiled, and remove the DIR from `load-path'." (delete-file (directory-file-name dir)) (delete-directory dir t))) - +;;;###autoload (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. @@ -2712,14 +2487,16 @@ argument, don't ask for confirmation to install packages." (defun package-isolate (packages &optional temp-init) "Start an uncustomized Emacs and only load a set of PACKAGES. Interactively, prompt for PACKAGES to load, which should be specified -separated by commas. -If called from Lisp, PACKAGES should be a list of packages to load. -If TEMP-INIT is non-nil, or when invoked with a prefix argument, -the Emacs user directory is set to a temporary directory. -This command is intended for testing Emacs and/or the packages -in a clean environment." +separated by commas. If called from Lisp, PACKAGES should be a list of +`package-desc' objects to load. If an element of PACKAGES is not +installed, it will be fetched, but not activated in the current session. +If TEMP-INIT is non-nil, or when invoked with a prefix argument, the +Emacs user directory is set to a temporary directory. This command is +intended for testing Emacs and/or the packages in a clean environment." (interactive - (cl-loop for p in (cl-loop for p in (package--alist) append (cdr p)) + (cl-loop for p in (append + (cl-loop for p in (package--alist) append (cdr p)) + (cl-loop for p in package-archive-contents append (cdr p))) unless (package-built-in-p p) collect (cons (package-desc-full-name p) p) into table finally return @@ -2728,21 +2505,27 @@ in a clean environment." (completing-read-multiple "Packages to isolate: " table nil t) - collect (alist-get c table nil nil #'string=)) - current-prefix-arg))) + collect (alist-get c table nil nil #'string=)) + current-prefix-arg))) (let* ((name (concat "package-isolate-" (mapconcat #'package-desc-full-name packages ","))) - (all-packages (delete-consecutive-dups - (sort (append packages (mapcan #'package--dependencies packages)) - (lambda (p0 p1) - (string< (package-desc-name p0) (package-desc-name p1)))))) - initial-scratch-message package-load-list) + (all-packages (package-compute-transaction + packages (mapcan #'package-desc-reqs packages))) + (package-alist (copy-tree package-alist t)) + (temp-install-dir nil) initial-scratch-message load-list) + (when-let* ((missing (seq-remove #'package-installed-p all-packages)) + (package-user-dir (make-temp-file "package-isolate" t))) + (setq temp-install-dir (list package-user-dir)) + ;; We bind `package-activate-1' to prevent activating the package + ;; in `package-unpack' for this session. + (cl-letf (((symbol-function #'package-activate-1) #'ignore)) + (package-download-transaction missing))) (with-temp-buffer (insert ";; This is an isolated testing environment, with these packages enabled:\n\n") (dolist (package all-packages) (push (list (package-desc-name package) (package-version-join (package-desc-version package))) - package-load-list) + load-list) (insert ";; - " (package-desc-full-name package)) (unless (memq package packages) (insert " (dependency)")) @@ -2763,7 +2546,9 @@ in a clean environment." ,@(mapcar (lambda (dir) `(add-to-list 'package-directory-list ,dir)) - (cons package-user-dir package-directory-list)) + (append (list package-user-dir) + temp-install-dir + package-directory-list)) (setq package-load-list ',package-load-list) (package-activate-all))))))) @@ -2856,6 +2641,17 @@ The description is read from the installed package files." 'help-echo "Read this file's commentary" :type 'package--finder-xref)))) +(defun package-find-news-file (pkg-desc) + "Return the file name of a news file of PKG-DESC. +If no such file exists, the function returns nil." + (and-let* ((pkg-dir (package-desc-dir pkg-desc)) + (_ (not (eq pkg-dir 'builtin))) + (default-directory pkg-dir)) + (catch 'success + (dolist (file '("NEWS-elpa" "news") nil) ;TODO: add user option? + (when (and (file-readable-p file) (file-regular-p file)) + (throw 'success (expand-file-name file))))))) + (defun describe-package-1 (pkg) "Insert the package description for PKG. Helper function for `describe-package'." @@ -2885,12 +2681,7 @@ Helper function for `describe-package'." (maintainers (or (cdr (assoc :maintainer extras)) (cdr (assoc :maintainers extras)))) (authors (cdr (assoc :authors extras))) - (news (and-let* (pkg-dir - ((not built-in)) - (file (expand-file-name "news" pkg-dir)) - ((file-regular-p file)) - ((file-readable-p file))) - file))) + (news (and desc (package-find-news-file desc)))) (when (string= status "avail-obso") (setq status "available obsolete")) (when incompatible-reason @@ -4738,40 +4529,11 @@ The list is displayed in a buffer named `*Packages*'." (interactive) (list-packages t)) -;;;###autoload -(defun package-get-version () - "Return the version number of the package in which this is used. -Assumes it is used from an Elisp file placed inside the top-level directory -of an installed ELPA package. -The return value is a string (or nil in case we can't find it). -It works in more cases if the call is in the file which contains -the `Version:' header." - ;; In a sense, this is a lie, but it does just what we want: precomputes - ;; the version at compile time and hardcodes it into the .elc file! - (declare (pure t)) - ;; Hack alert! - (let ((file (or (macroexp-file-name) buffer-file-name))) - (cond - ((null file) nil) - ;; Packages are normally installed into directories named "-", - ;; so get the version number from there. - ((string-match "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" file) - (match-string 1 file)) - ;; For packages run straight from the an elpa.git clone, there's no - ;; "-" in the directory name, so we have to fetch the version - ;; the hard way. - (t - (let* ((pkgdir (file-name-directory file)) - (pkgname (file-name-nondirectory (directory-file-name pkgdir))) - (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) - (unless (file-readable-p mainfile) (setq mainfile file)) - (when (file-readable-p mainfile) - (require 'lisp-mnt) - (lm-package-version mainfile))))))) - ;;;; Quickstart: precompute activation actions for faster start up. +(defvar Info-directory-list) + ;; Activating packages via `package-initialize' is costly: for N installed ;; packages, it needs to read all N -pkg.el files first to decide ;; which packages to activate, and then again N -autoloads.el files. @@ -4923,21 +4685,23 @@ form (PKG-NAME PKG-DESC). If not specified, it will default to (cadr (assoc (completing-read "Package: " alist nil t) alist #'string=))))) +;;;###autoload (defun package-browse-url (desc &optional secondary) "Open the website of the package under point in a browser. `browse-url' is used to determine the browser to be used. If SECONDARY (interactively, the prefix), use the secondary browser. DESC must be a `package-desc' object." (interactive (list (package--query-desc) - current-prefix-arg) - package-menu-mode) + current-prefix-arg)) (unless desc (user-error "No package here")) (let ((url (cdr (assoc :url (package-desc-extras desc))))) (unless url (user-error "No website for %s" (package-desc-name desc))) - (if secondary - (funcall browse-url-secondary-browser-function url) + (let ((browse-url-browser-function + (if secondary + browse-url-secondary-browser-function + browse-url-browser-function))) (browse-url url)))) (declare-function ietf-drums-parse-address "ietf-drums" @@ -4976,8 +4740,7 @@ will be signaled in that case." (defun package-report-bug (desc) "Prepare a message to send to the maintainers of a package. DESC must be a `package-desc' object." - (interactive (list (package--query-desc package-alist)) - package-menu-mode) + (interactive (list (package--query-desc package-alist))) (let ((maint (package-maintainers desc)) (name (symbol-name (package-desc-name desc))) (pkgdir (package-desc-dir desc)) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 33d39ecd423..6126679e870 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -523,7 +523,15 @@ how many time this CODEGEN is called." (cond ((null head) (if (pcase--self-quoting-p pat) `',pat pat)) - ((memq head '(pred guard quote)) pat) + ((memq head '(guard quote)) pat) + ((eq head 'pred) + ;; Ad-hoc expansion of some predicates that are complements or aliases. + ;; Not required for correctness but results in better code. + (let ((equiv (assq (cadr pat) '((atom . (not consp)) + (nlistp . (not listp)) + (identity . (not null)) + (not . null))))) + (if equiv `(,head ,(cdr equiv)) pat))) ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat)))) ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) (t @@ -654,13 +662,22 @@ recording whether the var has been referenced by earlier parts of the match." (lambda (x y) (> (length (nth 2 x)) (length (nth 2 y)))))) + ;; We presume that the "fundamental types" (i.e. the built-in types + ;; that have no subtypes) are all mutually exclusive and give them + ;; one bit each in bitsets. + ;; The "non-abstract-supertypes" also get their own bit. + ;; All other built-in types are abstract, so they don't need their + ;; own bits (they are faithfully modeled by the set of bits + ;; corresponding to their subtypes). (let ((bitsets (make-hash-table)) (i 1)) (dolist (x built-in-types) ;; Don't dedicate any bit to those predicates which already ;; have a bitset, since it means they're already represented ;; by their subtypes. - (unless (and (nth 1 x) (gethash (nth 1 x) bitsets)) + (unless (and (nth 1 x) (gethash (nth 1 x) bitsets) + (not (built-in-class--non-abstract-supertype + (get (nth 0 x) 'cl--class)))) (dolist (parent (nth 2 x)) (let ((pred (nth 1 (assq parent built-in-types)))) (unless (or (eq parent t) (null pred)) @@ -668,24 +685,35 @@ recording whether the var has been referenced by earlier parts of the match." bitsets)))) (setq i (+ i i)))) + ;; (cl-assert (= (1- i) (apply #'logior (map-values bitsets)))) + ;; Extra predicates that don't have matching types. - (dolist (pred-types '((functionp cl-functionp consp symbolp) - (keywordp symbolp) - (characterp fixnump) - (natnump integerp) - (facep symbolp stringp) - (plistp listp) - (cl-struct-p recordp) - ;; ;; FIXME: These aren't quite in the same - ;; ;; category since they'll signal errors. - (fboundp symbolp) - )) - (puthash (car pred-types) - (apply #'logior - (mapcar (lambda (pred) - (gethash pred bitsets)) - (cdr pred-types))) - bitsets)) + ;; Beware: For these predicates, the bitsets are conservative + ;; approximations (so, e.g., it wouldn't be correct to use one of + ;; them after a `!' since the negation would be an unsound + ;; under-approximation). + (let ((all (1- i))) + (dolist (pred-types '((functionp cl-functionp consp symbolp) + (keywordp symbolp) + (nlistp ! listp) + (characterp fixnump) + (natnump integerp) + (facep symbolp stringp) + (plistp listp) + (cl-struct-p recordp) + ;; ;; FIXME: These aren't quite in the same + ;; ;; category since they'll signal errors. + (fboundp symbolp) + )) + (let* ((types (cdr pred-types)) + (neg (when (eq '! (car types)) (setq types (cdr types)))) + (bitset (apply #'logior + (mapcar (lambda (pred) + (gethash pred bitsets)) + types)))) + (puthash (car pred-types) + (if neg (- all bitset) bitset) + bitsets)))) bitsets))) (defconst pcase--subtype-bitsets diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index 68bd93422ae..27c558ae349 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -209,10 +209,7 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher." ;; ;; If there are several one-char strings, use charsets ((and (= (length (car strings)) 1) - (let ((strs (cdr strings))) - (while (and strs (/= (length (car strs)) 1)) - (pop strs)) - strs)) + (any (lambda (s) (= (length s) 1)) (cdr strings))) (let (letters rest) ;; Collect one-char strings (dolist (s strings) diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el index 11f9175e468..9c668bb3720 100644 --- a/lisp/emacs-lisp/shorthands.el +++ b/lisp/emacs-lisp/shorthands.el @@ -28,7 +28,6 @@ ;;; Code: (require 'files) (require 'mule) -(eval-when-compile (require 'cl-lib)) (defun hack-read-symbol-shorthands () "Compute `read-symbol-shorthands' from Local Variables section." diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index 59162e213c6..1cb755577d7 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -163,36 +163,38 @@ You can call this function to add internal values in the trace buffer." "Generate a string that describes that FUNCTION has been entered. LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION." (unless inhibit-trace - (trace--insert - (let ((ctx (funcall context)) - (print-circle t) - (print-escape-newlines t)) - (format "%s%s%d -> %s%s\n" - (mapconcat #'char-to-string - (make-string (max 0 (1- level)) ?|) " ") - (if (> level 1) " " "") - level - ;; FIXME: Make it so we can click the function name to - ;; jump to its definition and/or untrace it. - (cl-prin1-to-string (cons function args)) - ctx))))) + (let ((inhibit-trace t)) + (trace--insert + (let ((ctx (funcall context)) + (print-circle t) + (print-escape-newlines t)) + (format "%s%s%d -> %s%s\n" + (mapconcat #'char-to-string + (make-string (max 0 (1- level)) ?|) " ") + (if (> level 1) " " "") + level + ;; FIXME: Make it so we can click the function name to + ;; jump to its definition and/or untrace it. + (cl-prin1-to-string (cons function args)) + ctx)))))) (defun trace--exit-message (function level value context) "Generate a string that describes that FUNCTION has exited. LEVEL is the trace level, VALUE value returned by FUNCTION." (unless inhibit-trace - (trace--insert - (let ((ctx (funcall context)) - (print-circle t) - (print-escape-newlines t)) - (format "%s%s%d <- %s: %s%s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - ;; Do this so we'll see strings: - (cl-prin1-to-string value) - ctx))))) + (let ((inhibit-trace t)) + (trace--insert + (let ((ctx (funcall context)) + (print-circle t) + (print-escape-newlines t)) + (format "%s%s%d <- %s: %s%s\n" + (mapconcat #'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + function + ;; Do this so we'll see strings: + (cl-prin1-to-string value) + ctx)))))) (defvar trace--timer nil) @@ -261,7 +263,7 @@ If `current-prefix-arg' is non-nil, also read a buffer and a \"context\" (cons (let ((default (function-called-at-point))) (intern (completing-read (format-prompt prompt default) - obarray 'fboundp t nil nil + obarray #'fboundp t nil nil (if default (symbol-name default))))) (when current-prefix-arg (list @@ -307,7 +309,7 @@ the output buffer or changing the window configuration." (trace-function-internal function buffer t context)) ;;;###autoload -(defalias 'trace-function 'trace-function-foreground) +(defalias 'trace-function #'trace-function-foreground) (defun untrace-function (function) "Untraces FUNCTION and possibly activates all remaining advice. diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 116f702ab3e..1a0b9c323d1 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -641,25 +641,6 @@ Otherwise, return LIST-OR-ATOM." (car ,list-or-atom) ,list-or-atom)))) -(defmacro erc--doarray (spec &rest body) - "Map over ARRAY, running BODY with VAR bound to iteration element. -Behave more or less like `seq-doseq', but tailor operations for -arrays. - -\(fn (VAR ARRAY [RESULT]) BODY...)" - (declare (indent 1) (debug ((symbolp form &optional form) body))) - (let ((array (make-symbol "array")) - (len (make-symbol "len")) - (i (make-symbol "i"))) - `(let* ((,array ,(nth 1 spec)) - (,len (length ,array)) - (,i 0)) - (while-let (((< ,i ,len)) - (,(car spec) (aref ,array ,i))) - ,@body - (cl-incf ,i)) - ,(nth 2 spec)))) - (provide 'erc-common) ;;; erc-common.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index cec261feb43..572b73188e3 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -7607,7 +7607,7 @@ Use the getter of the same name to retrieve the current value.") (ct (make-char-table 'erc--channel-mode-types)) (type ?a)) (dolist (cs types) - (erc--doarray (c cs) + (seq-doseq (c cs) (aset ct c type)) (cl-incf type)) (make-erc--channel-mode-types :key key @@ -7626,7 +7626,7 @@ complement relevant letters in STRING." (table (erc--channel-mode-types-table obj)) (fallbackp (erc--channel-mode-types-fallbackp obj)) (+p t)) - (erc--doarray (c string) + (seq-doseq (c string) (cond ((= ?+ c) (setq +p t)) ((= ?- c) (setq +p nil)) ((and status-letters (string-search (string c) status-letters)) @@ -7719,7 +7719,7 @@ dropped were they not already absent." (let ((addp t) ;; redundant-add redundant-drop adding dropping) - (erc--doarray (c string) + (seq-doseq (c string) (pcase c (?+ (setq addp t)) (?- (setq addp nil)) diff --git a/lisp/faces.el b/lisp/faces.el index 4555c92f201..eea1773a3a2 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2963,30 +2963,39 @@ Note: Other faces cannot inherit from the cursor face." :group 'basic-faces) (defface tab-bar - '((((class color) (min-colors 88)) + '((((class color) (min-colors 88) (background light)) :inherit variable-pitch :background "grey85" :foreground "black") + (((class color) (min-colors 88) (background dark)) + :inherit variable-pitch + :background "grey20" + :foreground "white") (((class mono)) :background "grey") (t :inverse-video t)) "Tab bar face." - :version "27.1" + :version "31.1" :group 'basic-faces) (defface tab-line - '((((class color) (min-colors 88)) + '((((class color) (min-colors 88) (background light)) :inherit variable-pitch :height 0.9 :background "grey85" :foreground "black") + (((class color) (min-colors 88) (background dark)) + :inherit variable-pitch + :height 0.9 + :background "grey20" + :foreground "white") (((class mono)) :background "grey") (t :inverse-video t)) "Tab line face." - :version "27.1" + :version "31.1" :group 'basic-faces) (defface menu diff --git a/lisp/files.el b/lisp/files.el index ec5896e8731..d4b3dd490c5 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -5478,7 +5478,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." (defvar file-name-version-regexp "\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)" - ;; The last ~[[:digit]]+ matches relative versions in git, + ;; The last ~[[:digit:]]+ matches relative versions in git, ;; e.g. `foo.js.~HEAD~1~'. "Regular expression matching the backup/version part of a file name. Used by `file-name-sans-versions'.") diff --git a/lisp/format-spec.el b/lisp/format-spec.el index 5c1acf20c9f..b08c7a1cdee 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -59,7 +59,7 @@ value associated with ?b in SPECIFICATION, either padding it with leading zeros or truncating leading characters until it's ten characters wide\". -the substitution for a specification character can also be a +The substitution for a specification character can also be a function, taking no arguments and returning a string to be used for the replacement. It will only be called if FORMAT uses that character. For example: @@ -73,6 +73,9 @@ like above, so that it is compiled by the byte-compiler. Any text properties of FORMAT are copied to the result, with any text properties of a %-spec itself copied to its substitution. +However, note that face properties from the two sources are not +merged; the face properties of %-spec override the face properties +of substitutions, if any, in the result. IGNORE-MISSING indicates how to handle %-spec characters not present in SPECIFICATION. If it is nil or omitted, emit an diff --git a/lisp/frame.el b/lisp/frame.el index 071e121246b..54502837bf6 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -951,23 +951,24 @@ and lines for the clone. FRAME defaults to the selected frame. The frame is created on the same terminal as FRAME. If the terminal is a text-only terminal then -also select the new frame." +also select the new frame. + +A cloned frame is assigned a new frame ID. See `frame-id'." (interactive (list (selected-frame) current-prefix-arg)) (let* ((frame (or frame (selected-frame))) (windows (unless no-windows (window-state-get (frame-root-window frame)))) - (default-frame-alist - (seq-remove (lambda (elem) - (memq (car elem) frame-internal-parameters)) - (frame-parameters frame))) + (parameters + (append `((cloned-from . ,frame)) + (frame--purify-parameters (frame-parameters frame)))) new-frame) (when (and frame-resize-pixelwise (display-graphic-p frame)) (push (cons 'width (cons 'text-pixels (frame-text-width frame))) - default-frame-alist) + parameters) (push (cons 'height (cons 'text-pixels (frame-text-height frame))) - default-frame-alist)) - (setq new-frame (make-frame)) + parameters)) + (setq new-frame (make-frame parameters)) (when windows (window-state-put windows (frame-root-window new-frame) 'safe)) (unless (display-graphic-p frame) @@ -994,6 +995,24 @@ frame, unless you add them to the hook in your early-init file.") (defvar x-display-name) +(defun frame--purify-parameters (parameters) + "Return PARAMETERS without internals and ignoring unset parameters. +Use this helper function so that `make-frame' does not override any +parameters. + +In the return value, assign nil to each parameter in +`default-frame-alist', `window-system-default-frame-alist', +`frame-inherited-parameters', which is not in PARAMETERS, and remove all +parameters in `frame-internal-parameters' from PARAMETERS." + (dolist (p (append default-frame-alist + window-system-default-frame-alist + frame-inherited-parameters)) + (unless (assq (car p) parameters) + (push (cons (car p) nil) parameters))) + (seq-remove (lambda (elem) + (memq (car elem) frame-internal-parameters)) + parameters)) + (defun make-frame (&optional parameters) "Return a newly created frame displaying the current buffer. Optional argument PARAMETERS is an alist of frame parameters for @@ -1093,6 +1112,12 @@ current buffer even if it is hidden." (setq params (cons '(minibuffer) (delq (assq 'minibuffer params) params)))) + ;; Let the `frame-creation-function' apparatus assign a new frame id + ;; for a new or cloned frame. For an undeleted frame, send the old + ;; id via a frame parameter. + (when-let* ((id (cdr (assq 'undeleted params)))) + (push (cons 'frame-id id) params)) + ;; Now make the frame. (run-hooks 'before-make-frame-hook) @@ -1124,7 +1149,7 @@ current buffer even if it is hidden." ;; buffers for these windows were set (Bug#79606). (let* ((root (frame-root-window frame)) (buffer (window-buffer root))) - (with-current-buffer buffer + (with-current-buffer buffer (set-window-fringes root left-fringe-width right-fringe-width fringes-outside-margins) (set-window-scroll-bars @@ -1134,7 +1159,7 @@ current buffer even if it is hidden." root left-margin-width right-margin-width))) (let* ((mini (minibuffer-window frame)) (buffer (window-buffer mini))) - (when (eq (window-frame mini) frame) + (when (eq (window-frame mini) frame) (with-current-buffer buffer (set-window-fringes mini left-fringe-width right-fringe-width fringes-outside-margins) @@ -1360,10 +1385,30 @@ defaults to the selected frame." (push (cons (frame-parameter frame 'name) frame) alist))) (nreverse alist))) +(defun frame--make-frame-ids-alist (&optional frame) + "Return alist of frame identifiers and frames starting with FRAME. +Visible or iconified frames on the same terminal as FRAME are listed +along with frames that are undeletable. Frames with a non-nil +`no-other-frame' parameter are not listed. The optional argument FRAME +must specify a live frame and defaults to the selected frame." + (let ((frames (frame-list-1 frame)) + (terminal (frame-parameter frame 'terminal)) + alist) + (dolist (frame frames) + (when (and (frame-visible-p frame) + (eq (frame-parameter frame 'terminal) terminal) + (not (frame-parameter frame 'no-other-frame))) + (push (cons (number-to-string (frame-id frame)) frame) alist))) + (dolist (elt undelete-frame--deleted-frames) + (push (cons (number-to-string (nth 3 elt)) nil) alist)) + (nreverse alist))) + (defvar frame-name-history nil) (defun select-frame-by-name (name) "Select the frame whose name is NAME and raise it. Frames on the current terminal are checked first. +Raise the frame and give it input focus. On a text terminal, the frame +will occupy the entire terminal screen after the next redisplay. If there is no frame by that name, signal an error." (interactive (let* ((frame-names-alist (make-frame-names-alist)) @@ -1371,9 +1416,7 @@ If there is no frame by that name, signal an error." (input (completing-read (format-prompt "Select Frame" default) frame-names-alist nil t nil 'frame-name-history))) - (if (= (length input) 0) - (list default) - (list input)))) + (list (if (zerop (length input)) default input)))) (select-frame-set-input-focus ;; Prefer frames on the current display. (or (cdr (assoc name (make-frame-names-alist))) @@ -1383,6 +1426,50 @@ If there is no frame by that name, signal an error." (throw 'done frame)))) (error "There is no frame named `%s'" name)))) +(defun frame-by-id (id) + "Return the live frame object associated with ID. +Return nil if ID is not found." + (seq-find + (lambda (frame) + (eq id (frame-id frame))) + (frame-list))) + +(defun frame-id-live-p (id) + "Return non-nil if ID is associated with a live frame object. +This is useful when you have a frame ID and a potentially dead frame +reference that may have been resurrected. Also see `frame-live-p'." + (frame-live-p (frame-by-id id))) + +(defun select-frame-by-id (id &optional noerror) + "Select the frame whose identifier is ID and raise it. +If the frame is undeletable, undelete it. +Frames on the current terminal are checked first. +Raise the frame and give it input focus. On a text terminal, the frame +will occupy the entire terminal screen after the next redisplay. +Return the selected frame or signal an error if no frame matching ID +was found. If NOERROR is non-nil, return nil instead." + (interactive + (let* ((frame-ids-alist (frame--make-frame-ids-alist)) + (default (car (car frame-ids-alist))) + (input (completing-read + (format-prompt "Select Frame by ID" default) + frame-ids-alist nil t))) + (list (string-to-number + (if (zerop (length input)) default input))))) + ;; `undelete-frame-by-id' returns the undeleted frame, or nil. + (unless (undelete-frame-by-id id 'noerror) + ;; Prefer frames on the current display. + (if-let* ((found (or (cdr (assq id (frame--make-frame-ids-alist))) + (catch 'done + (dolist (frame (frame-list)) + (when (eq (frame-id frame) id) + (throw 'done frame))))))) + (progn + (select-frame-set-input-focus found) + found) + (unless noerror + (error "There is no frame with identifier `%S'" id))))) + ;;;; Background mode. @@ -1666,7 +1753,7 @@ resize and move FRAME." (setq text-height (- (round (* height parent-or-workarea-height)) outer-minus-text-height))) - (width + (height (user-error "Invalid height specification"))) (cond @@ -3125,7 +3212,8 @@ Only the 16 most recently deleted frames are saved." ;; to restore a graphical frame. (and (eq (car elem) 'display) (not (display-graphic-p))))) (frame-parameters frame)) - (window-state-get (frame-root-window frame))) + (window-state-get (frame-root-window frame)) + (frame-id frame)) undelete-frame--deleted-frames)) (if (> (length undelete-frame--deleted-frames) 16) (setq undelete-frame--deleted-frames @@ -3148,7 +3236,9 @@ Without a prefix argument, undelete the most recently deleted frame. With a numerical prefix argument ARG between 1 and 16, where 1 is most recently deleted frame, undelete the ARGth deleted frame. -When called from Lisp, returns the new frame." +When called from Lisp, returns the new frame. +Return the undeleted frame, or nil if a frame was not undeleted. +An undeleted frame retains its original frame ID. See `frame-id'." (interactive "P") (if (not undelete-frame-mode) (user-error "Undelete-Frame mode is disabled") @@ -3169,11 +3259,46 @@ When called from Lisp, returns the new frame." (if graphic "graphic" "non-graphic")) (setq undelete-frame--deleted-frames (delq frame-data undelete-frame--deleted-frames)) - (let* ((default-frame-alist (nth 1 frame-data)) - (frame (make-frame))) + (let* ((parameters + ;; `undeleted' signals to `make-frame' to reuse its id. + (append `((undeleted . ,(nth 3 frame-data))) + (frame--purify-parameters (nth 1 frame-data)))) + (frame (make-frame parameters))) (window-state-put (nth 2 frame-data) (frame-root-window frame) 'safe) (select-frame-set-input-focus frame) frame)))))))) + +(defun undelete-frame-id-index (id) + "Return an `undelete-frame' index, if ID is that of an undeletable frame. +Return nil if ID is not associated with an undeletable frame." + (catch :found + (seq-do-indexed + (lambda (frame-data index) + (when (eq id (nth 3 frame-data)) + (throw :found (1+ index)))) + undelete-frame--deleted-frames))) + +(defun undelete-frame-by-id (id &optional noerror) + "Undelete the frame with the matching ID. +Return the undeleted frame if the ID is that of an undeletable frame, +otherwise, signal an error. +If NOERROR is non-nil, do not signal an error, and return nil. +Also see `undelete-frame'." + (interactive + (let* ((candidates + (mapcar (lambda (elt) + (number-to-string (nth 3 elt))) + undelete-frame--deleted-frames)) + (default (car candidates)) + (input (completing-read + (format-prompt "Undelete Frame by ID" default) + candidates nil t))) + (list (string-to-number + (if (zerop (length input)) default input))))) + (if-let* ((index (undelete-frame-id-index id))) + (undelete-frame index) + (unless noerror + (error "There is no frame with identifier `%S'" id)))) ;;; Window dividers. (defgroup window-divider nil diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index a7488ec02b7..ddb9a4dce1b 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-sum) (require 'nntp) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 3bdf4712c01..ba652343a40 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-sum) diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el index 4345c5d27bf..7b95a4aaa49 100644 --- a/lisp/gnus/gnus-logic.el +++ b/lisp/gnus/gnus-logic.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-score) (require 'gnus-util) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index e35f87288e9..99f1735dfec 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -467,11 +467,17 @@ Gcc: header for archiving purposes. If Gnus isn't running, a plain `message-mail' setup is used instead." (interactive) - (if (not (gnus-alive-p)) - (progn - (message "Gnus not running; using plain Message mode") - (message-mail to subject other-headers continue - switch-action yank-action send-actions return-action)) + (if (and (not (gnus-alive-p)) + (condition-case err + (progn + (message "Gnus not running. Starting Gnus...") + (save-window-excursion (gnus)) + nil) + (error + (message "Gnus failed with %s. Using plain Message mode" + (error-message-string err))))) + (message-mail to subject other-headers continue + switch-action yank-action send-actions return-action) (let ((buf (current-buffer)) ;; Don't use posting styles corresponding to any existing group. ;; (group-name gnus-newsgroup-name) diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index e5c4c9e122e..d70f7f8fe5c 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-sum) (require 'gnus-win) diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index 6fd7b298d7e..6b920ed5e53 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (defvar gnus-newsrc-file-version) (require 'gnus) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 849fe9d2129..312862df165 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-start) (require 'gnus-spec) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 677b028bcaf..e09bb3a4b39 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -9410,7 +9410,7 @@ See `gnus-collect-urls'." (concat "#" target))))) (concat host (string-truncate-left rest (- max (length host))))))) -(defun gnus-summary-browse-url (&optional external) +(defun gnus-summary-browse-url (&optional secondary) "Scan the current article body for links, and offer to browse them. Links are opened using `browse-url' unless a prefix argument is @@ -9431,9 +9431,11 @@ default." (gnus-shorten-url (car urls) 40)) urls nil t nil nil (car urls)))))) (if target - (if external - (funcall browse-url-secondary-browser-function target) - (browse-url target)) + (let ((browse-url-browser-function + (if secondary + browse-url-secondary-browser-function + browse-url-browser-function))) + (browse-url target)) (message "No URLs found.")))) (defun gnus-summary-isearch-article (&optional regexp-p) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 7c05895e4d5..315f1a018c9 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -25,8 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-group) (require 'gnus-start) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 7332fc57320..b32533e105e 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -26,8 +26,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-art) (require 'message) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 7897589a902..d0505506ea6 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-util) (require 'seq) diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el index 253d31ccfb4..289192acdac 100644 --- a/lisp/gnus/mm-encode.el +++ b/lisp/gnus/mm-encode.el @@ -23,7 +23,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (require 'mail-parse) (autoload 'mailcap-extension-to-mime "mailcap") (autoload 'mm-body-7-or-8 "mm-bodies") diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index f48e7968097..15ff49ab770 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -28,8 +28,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'mm-util) (require 'gnus) diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el index afc19e5b624..45010ca765c 100644 --- a/lisp/gnus/nnatom.el +++ b/lisp/gnus/nnatom.el @@ -26,7 +26,6 @@ ;;; Code: (eval-when-compile - (require 'cl-lib) (require 'subr-x)) (require 'nnfeed) diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 767b3f16933..38f2ac31767 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -32,7 +32,6 @@ (require 'rmail) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl-lib)) (nnoo-declare nnbabyl) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index 9e0659b06b6..f2769eb1012 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -33,7 +33,6 @@ (require 'nnoo) (require 'gnus-util) (require 'mm-util) -(eval-when-compile (require 'cl-lib)) (nnoo-declare nndoc) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index ae06faff57d..498c2b4888a 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -25,8 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'mailcap) (require 'nnheader) (require 'nnmail) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index e6fca7254ed..1577fb11f7f 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) ; for macro gnus-kill-buffer, at least (require 'nnheader) (require 'message) diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el index 62ddb73ce3d..5088afcd1af 100644 --- a/lisp/gnus/nnoo.el +++ b/lisp/gnus/nnoo.el @@ -25,7 +25,6 @@ ;;; Code: (require 'nnheader) -(eval-when-compile (require 'cl-lib)) (defvar nnoo-definition-alist nil) (defvar nnoo-state-alist nil) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index c0923c1e4da..59805040e97 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -29,7 +29,6 @@ (require 'nnheader) (require 'nntp) (require 'nnoo) -(eval-when-compile (require 'cl-lib)) ;; Probably this entire thing should be obsolete. ;; It's only used to init nnspool-spool-directory, so why not just diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 75f44619e84..12657a698c6 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -38,7 +38,6 @@ (require 'gnus-start) (require 'gnus-sum) (require 'gnus-msg) -(eval-when-compile (require 'cl-lib)) (nnoo-declare nnvirtual) diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index ade8d4b1b87..b906f4610d6 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'nnoo) (require 'message) (require 'gnus-util) diff --git a/lisp/help.el b/lisp/help.el index 0bb1053fa6a..76c3770fbba 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -99,6 +99,7 @@ buffer.") "f" #'describe-function "g" #'describe-gnu-project "h" #'view-hello-file + "u" #'apropos-user-option "i" #'info "4 i" #'info-other-window diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index 835a8b9aa15..d9cb1e7f88f 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -72,7 +72,8 @@ During evaluation of body, bind `it' to the value returned by TEST." ;;;###autoload (cl-defmacro define-ibuffer-column (symbol (&key name inline props summarizer - header-mouse-map) &rest body) + header-mouse-map) + &rest body) "Define a column SYMBOL for use with `ibuffer-formats'. BODY will be called with `buffer' bound to the buffer object, and @@ -112,19 +113,18 @@ change its definition, you should explicitly call `(defun ,sym (buffer mark) (ignore mark) ;Silence byte-compiler if mark is unused. ,bod)) - (put (quote ,sym) 'ibuffer-column-name + (put ',sym 'ibuffer-column-name ,(if (stringp name) name (capitalize (symbol-name symbol)))) - ,(if header-mouse-map `(put (quote ,sym) 'header-mouse-map ,header-mouse-map)) + ,(if header-mouse-map `(put ',sym 'header-mouse-map ,header-mouse-map)) ,(if summarizer ;; Store the name of the summarizing function. - `(put (quote ,sym) 'ibuffer-column-summarizer - (quote ,summarizer))) + `(put ',sym 'ibuffer-column-summarizer #',summarizer)) ,(if summarizer ;; This will store the actual values of the column ;; summary. - `(put (quote ,sym) 'ibuffer-column-summary nil)) + `(put ',sym 'ibuffer-column-summary nil)) :autoload-end))) ;;;###autoload diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index d8692595ee0..99fe5cd2f5a 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -166,9 +166,7 @@ elisp byte-compiler." buffer-file-name)) font-lock-doc-face) (20 (string-match "^\\*" (buffer-name)) font-lock-keyword-face) - (25 (and (string-match "^ " (buffer-name)) - (null buffer-file-name)) - italic) + (25 (ibuffer-hidden-buffer-p) italic) (30 (memq major-mode ibuffer-help-buffer-modes) font-lock-comment-face) (35 (derived-mode-p 'dired-mode) font-lock-function-name-face) (40 (and (boundp 'emacs-lock-mode) emacs-lock-mode) ibuffer-locked-buffer)) @@ -236,9 +234,7 @@ view of the buffers." "The string to use for eliding long columns." :type 'string) -(defcustom ibuffer-maybe-show-predicates `(,(lambda (buf) - (and (string-match "^ " (buffer-name buf)) - (null buffer-file-name)))) +(defcustom ibuffer-maybe-show-predicates '(ibuffer-hidden-buffer-p) "A list of predicates for buffers to display conditionally. A predicate can be a regexp or a function. @@ -2035,6 +2031,13 @@ the value of point at the beginning of the line for that buffer." e))) bmarklist)))) +(defun ibuffer-hidden-buffer-p (&optional buf) + "The default member of `ibuffer-maybe-show-predicates'. +Non-nil if BUF is not visiting a file and its name begins with a space. +BUF defaults to the current buffer." + (and (string-match "^ " (buffer-name buf)) + (null (buffer-file-name buf)))) + (defun ibuffer-visible-p (buf all &optional ibuffer-buf) (and (or all (not diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 975b9d5404e..c1d9556e24d 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -242,6 +242,7 @@ Used to implement the option `icomplete-show-matches-on-no-input'.") :doc "Keymap used by `icomplete-mode' in the minibuffer." "C-M-i" #'icomplete-force-complete "C-j" #'icomplete-force-complete-and-exit + "M-j" #'icomplete-exit "C-." #'icomplete-forward-completions "C-," #'icomplete-backward-completions " " #'icomplete-ret) @@ -455,6 +456,8 @@ if that doesn't produce a completion match." (minibuffer-complete-and-exit) (exit-minibuffer))) +(defalias 'icomplete-exit #'icomplete-fido-exit) + (defun icomplete-fido-backward-updir () "Delete char before or go up directory, like `ido-mode'." (interactive) @@ -1025,7 +1028,9 @@ away from the bottom. Counts wrapped lines as real lines." collect (concat prefix (make-string (max 0 (- max-prefix-len (length prefix))) ? ) (completion-lazy-hilit comp) - (make-string (max 0 (- max-comp-len (length comp))) ? ) + (and suffix + (make-string (max 0 (- max-comp-len (length comp))) + ? )) suffix) into lines-aux finally (setq lines lines-aux diff --git a/lisp/ielm.el b/lisp/ielm.el index 78c5ad31d3d..0f6ba30ec00 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -97,9 +97,27 @@ customizes `ielm-prompt'.") (defcustom ielm-dynamic-return t "Controls whether \\\\[ielm-return] has intelligent behavior in IELM. -If non-nil, \\[ielm-return] evaluates input for complete sexps, or inserts a newline -and indents for incomplete sexps. If nil, always inserts newlines." - :type 'boolean) + +If nil, always insert newlines. + +If `point', insert newline if the point is in the middle of an sexp, +otherwise evaluate input. This is useful if you have +`electric-pair-mode', or a similar mode, enabled. + +If any other non-nil value, insert newline for incomplete sexp input and +evaluate input for complete sexps. This is similar to the behavior in +text shells." + :type + '(radio + (const :tag "Always insert newline" nil) + (const + :tag + "Insert newline if point is in middle of sexp, otherwise evaluate input" + point) + (const + :tag + "Insert newline for incomplete sexp, otherwise evaluate input" + t))) (defcustom ielm-dynamic-multiline-inputs t "Force multiline inputs to start from column zero? @@ -248,14 +266,16 @@ simply inserts a newline." (if ielm-dynamic-return (let ((state (save-excursion - (end-of-line) + (unless (eq ielm-dynamic-return 'point) + (end-of-line)) (parse-partial-sexp (ielm-pm) (point))))) (if (and (< (car state) 1) (not (nth 3 state))) (ielm-send-input for-effect) (when (and ielm-dynamic-multiline-inputs (save-excursion - (beginning-of-line) + (let ((inhibit-field-text-motion t)) + (beginning-of-line)) (looking-at-p comint-prompt-regexp))) (save-excursion (goto-char (ielm-pm)) diff --git a/lisp/image.el b/lisp/image.el index 6048caea0be..dbfbc266445 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -33,7 +33,7 @@ (declare-function image-flush "image.c" (spec &optional frame)) (declare-function clear-image-cache "image.c" - (&optional filter animation-cache)) + (&optional filter animation-filter)) (defconst image-type-header-regexps `(("\\`/[\t\n\r ]*\\*.*XPM.\\*/" . xpm) @@ -953,9 +953,6 @@ displayed." (when position (plist-put (cdr image) :animate-position (set-marker (make-marker) position (current-buffer)))) - ;; Stash the data about the animation here so that we don't - ;; trigger image recomputation unnecessarily later. - (plist-put (cdr image) :animate-multi-frame-data animation) (run-with-timer 0.2 nil #'image-animate-timeout image (or index 0) (car animation) 0 limit (+ (float-time) 0.2))))) @@ -986,9 +983,7 @@ Frames are indexed from 0. Optional argument NOCHECK non-nil means do not check N is within the range of frames present in the image." (unless nocheck (if (< n 0) (setq n 0) - (setq n (min n (1- (car (or (plist-get (cdr image) - :animate-multi-frame-data) - (image-multi-frame-p image)))))))) + (setq n (min n (1- (car (image-multi-frame-p image))))))) (plist-put (cdr image) :index n) (force-window-update (plist-get (cdr image) :animate-buffer))) @@ -1005,10 +1000,8 @@ multiplication factor for the current value." (* value (image-animate-get-speed image)) value))) -;; FIXME? The delay may not be the same for different sub-images, -;; hence we need to call image-multi-frame-p to return it. -;; But it also returns count, so why do we bother passing that as an -;; argument? +;; FIXME: The count argument is redundant; the value is also given by +;; the call to `image-multi-frame-p'. (defun image-animate-timeout (image n count time-elapsed limit target-time) "Display animation frame N of IMAGE. N=0 refers to the initial animation frame. @@ -1053,15 +1046,20 @@ for the animation speed. A negative value means to animate in reverse." ;; keep updating it. This helps stop unbounded RAM usage when ;; doing, for instance, `g' in an eww buffer with animated ;; images. + ;; FIXME: This doesn't currently support ImageMagick. (clear-image-cache nil image) - (let* ((time (prog1 (current-time) - (image-show-frame image n t))) + (let* ((time (current-time)) + ;; Each animation frame can have its own duration, so + ;; (re)fetch its `image-metadata'. Do so before + ;; `image-show-frame' to avoid an image cache miss per + ;; animation frame (bug#47895, bug#66221). + (multi (prog1 (image-multi-frame-p image) + (image-show-frame image n t))) (speed (image-animate-get-speed image)) - (time-to-load-image (time-since time)) (stated-delay-time - (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data)) - image-default-frame-delay) + (/ (or (cdr multi) image-default-frame-delay) (float (abs speed)))) + (time-to-load-image (time-since time)) ;; Subtract off the time we took to load the image from the ;; stated delay time. (delay (max (float-time (time-subtract stated-delay-time diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index e632fa7fbfe..cba090e7c85 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -1283,18 +1283,18 @@ which is based on `image-mode'." (setq file (expand-file-name file)) (when (not (file-exists-p file)) (error "No such file: %s" file)) - (let ((buf (get-buffer image-dired-display-image-buffer)) + (let ((buf (get-buffer-create image-dired-display-image-buffer)) (cur-win (selected-window))) - (when buf - (kill-buffer buf)) - (when-let* ((buf (find-file-noselect file nil t))) - (pop-to-buffer buf) - (rename-buffer image-dired-display-image-buffer) - (if (string-match (image-file-name-regexp) file) - (image-dired-image-mode) - ;; Support visiting PDF files. - (normal-mode)) - (select-window cur-win)))) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (erase-buffer) + (insert-file-contents file) + (if (string-match (image-file-name-regexp) file) + (image-dired-image-mode) + ;; Support visiting PDF files. + (normal-mode)))) + (when buf (pop-to-buffer buf)) + (select-window cur-win))) (defun image-dired-display-this (&optional arg) "Display current thumbnail's original image in display buffer. diff --git a/lisp/info-xref.el b/lisp/info-xref.el index e09c86ef811..df92c77c843 100644 --- a/lisp/info-xref.el +++ b/lisp/info-xref.el @@ -45,7 +45,6 @@ ;;; Code: (require 'info) -(eval-when-compile (require 'cl-lib)) ; for `cl-incf' (defgroup info-xref nil "Check external cross-references in Info documents." diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 7de35a3f5e4..eeea4574b42 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -53,7 +53,6 @@ ;;; Code: (require 'help-mode) -(eval-when-compile (require 'cl-lib)) (defgroup quail nil "Quail: multilingual input method." diff --git a/lisp/international/rfc1843.el b/lisp/international/rfc1843.el index c938b6cc31c..261e5e02f9e 100644 --- a/lisp/international/rfc1843.el +++ b/lisp/international/rfc1843.el @@ -30,8 +30,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (defvar rfc1843-word-regexp "~\\({\\([\041-\167][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index d7bba4e389c..fca00dd2fc7 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -208,6 +208,34 @@ JSONRPC message." "jsonrpc-lambda-elem"))) `(lambda (,e) (apply (cl-function (lambda ,cl-lambda-list ,@body)) ,e)))) +(defun jsonrpc-events-jq-at-point () + "Find first { in line, use forward-sexp to grab JSON, pipe through jq." + (interactive) + (save-excursion + (beginning-of-line) + (when (search-forward "{" (line-end-position) t) + (backward-char) + (let ((start (point))) + (forward-sexp) + (shell-command-on-region start (point) "jq" "*jq output*"))))) + +(defun jsonrpc-events-occur-at-point () + "Run occur on thing at point." + (interactive) + (occur (thing-at-point 'symbol))) + +(defvar jsonrpc-events-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'jsonrpc-events-jq-at-point) + (define-key map (kbd "C-c C-o") 'jsonrpc-events-occur-at-point) + map) + "Keymap for `jsonrpc-events-mode'.") + +(define-derived-mode jsonrpc-events-mode special-mode "JSONRPC-Events" + "Major mode for JSONRPC events buffers." + (buffer-disable-undo) + (setq buffer-read-only t)) + (defun jsonrpc-events-buffer (connection) "Get or create JSONRPC events buffer for CONNECTION." (let ((probe (jsonrpc--events-buffer connection))) @@ -215,8 +243,7 @@ JSONRPC message." probe (with-current-buffer (get-buffer-create (format "*%s events*" (jsonrpc-name connection))) - (buffer-disable-undo) - (setq buffer-read-only t) + (jsonrpc-events-mode) (setf (jsonrpc--events-buffer connection) (current-buffer)))))) @@ -300,22 +327,29 @@ dispatcher in CONN." (and method id) (let* ((debug-on-error (and debug-on-error (not jsonrpc-inhibit-debug-on-error))) - (reply - (condition-case-unless-debug _ignore - (condition-case oops - `(:result ,(funcall rdispatcher conn (intern method) - params)) - (jsonrpc-error - `(:error - (:code - ,(or (alist-get 'jsonrpc-error-code (cdr oops)) - -32603) - :message ,(or (alist-get 'jsonrpc-error-message - (cdr oops)) - "Internal error"))))) - (error - '(:error (:code -32603 :message "Internal error")))))) - (apply #'jsonrpc--reply conn id method reply))) + reply) + (unwind-protect + (setq + reply + (condition-case oops + `(:result + ,(funcall rdispatcher conn (intern method) params)) + (jsonrpc-error + (let* ((data (cdr oops)) + (code (alist-get 'jsonrpc-error-code data)) + (msg (alist-get 'jsonrpc-error-message + (cdr oops)))) + (if (eq code 32000) ;; This means 'no error' + (when-let* ((d (alist-get 'jsonrpc-error-data + data))) + `(:result ,d)) + `(:error + (:code ,(or code -32603) + :message ,(or msg "Internal error")))))))) + (unless reply + (setq reply + `(:error (:code -32603 :message "Internal error")))) + (apply #'jsonrpc--reply conn id method reply)))) (;; A remote notification method (funcall ndispatcher conn (intern method) params)) @@ -386,86 +420,105 @@ as specified in the JSONRPC 2.0 spec." (apply #'jsonrpc--async-request-1 connection method params args)) (cl-defun jsonrpc-request (connection - method params &key + method params + &rest args + &key deferred timeout + cancel-on-quit cancel-on-input cancel-on-input-retval) "Make a request to CONNECTION, synchronously wait for a reply. -CONNECTION, METHOD and PARAMS as in `jsonrpc-async-request' (which see). +CONNECTION, METHOD, PARAMS, DEFERRED and TIMEOUT are interpreted as in +`jsonrpc-async-request', which see. -Except in the case of a non-nil CANCEL-ON-INPUT (explained -below), this function doesn't exit until anything interesting -happens (success reply, error reply, or timeout). Furthermore, -it only exits locally (returning the JSONRPC result object) if -the request is successful, otherwise it exits non-locally with an -error of type `jsonrpc-error'. +This function has two exit modes: local and non-local. Except for +CANCEL-ON-INPUT, explained below, the only normal local exit occurs when +the remote endpoint succeeds, in which case a JSONRPC result object is +returned. A remote endpoint error or a local timeout cause a non-local +exit with a `jsonrpc-error' condition. -DEFERRED and TIMEOUT as in `jsonrpc-async-request', which see. +A user quit (`'C-g'/`keyboard-quit') causes a non-local exit with a +`quit' condition. A non-nil CANCEL-ON-QUIT must be a function of a +single argument, ID, which identifies the request as specified in the +JSONRPC 2.0 spec. Callers may use this function to issue a cancel +notification to the endpoint, thus preventing it from continuing to work +on the request. -If CANCEL-ON-INPUT is non-nil and the user inputs something while the -function is waiting, the function locally exits immediately returning -CANCEL-ON-INPUT-RETVAL. Any future replies to the request coming from -the remote endpoint (normal or error) are ignored. If CANCEL-ON-INPUT -is a function, it is invoked with one argument, an integer identifying -the canceled request as specified in the JSONRPC 2.0 spec. Callers may -use this function to issue a cancel notification to the endpoint, thus -preventing it from continuing to work on the now-cancelled request." +If CANCEL-ON-INPUT is non-nil and any type of user input is detected +while waiting for a response `jsonrpc-request' locally exits +immediately, returning CANCEL-ON-INPUT-RETVAL. CANCEL-ON-INPUT can also +be a function with the same semantics as CANCEL-ON-QUIT. Since the a +`C-g'/`keyboard-quit' also counts as user input, CANCEL-ON-INPUT +nullifies the effect of CANCEL-ON-QUIT. + +On either cancellation scenario, any future remote endpoint replies +to the original request (normal or error) are ignored." (let* ((tag (funcall (if (fboundp 'gensym) 'gensym 'cl-gensym) "jsonrpc-request-catch-tag")) id-and-timer canceled (throw-on-input nil) - (retval - (unwind-protect - (catch tag - (setq - id-and-timer - (apply - #'jsonrpc--async-request-1 - connection method params - :sync-request t - :success-fn (lambda (result) - (unless canceled - (throw tag `(done ,result)))) - :error-fn - (jsonrpc-lambda - (&key code message data) - (unless canceled - (throw tag `(error (jsonrpc-error-code . ,code) - (jsonrpc-error-message . ,message) - (jsonrpc-error-data . ,data))))) - :timeout-fn - (lambda () - (unless canceled - (throw tag '(error (jsonrpc-error-message . "Timed out"))))) - `(,@(when deferred `(:deferred ,deferred)) - ,@(when timeout `(:timeout ,timeout))))) - (cond (cancel-on-input - (unwind-protect - (let ((inhibit-quit t)) (while (sit-for 30))) - (setq canceled t)) - (when (functionp cancel-on-input) - (funcall cancel-on-input (car id-and-timer))) - `(canceled ,cancel-on-input-retval)) - (t (while t (accept-process-output nil 30))))) - ;; In normal operation, continuations for error/success is - ;; handled by `jsonrpc--continue'. Timeouts also remove - ;; the continuation... - (pcase-let* ((`(,id ,_) id-and-timer)) - ;; ...but we still have to guard against exist explicit - ;; user-quit (C-g) or the `cancel-on-input' case, so - ;; discard the continuation. - (jsonrpc--remove connection id (list deferred (current-buffer))) - ;; ...finally, whatever may have happened to this sync - ;; request, it might have been holding up any outer - ;; "anxious" continuations. The following ensures we - ;; call them. - (jsonrpc--continue connection id))))) - (when (eq 'error (car retval)) - (signal 'jsonrpc-error - (cons - (format "request id=%s failed:" (car id-and-timer)) - (cdr retval)))) + retval) + (unwind-protect + (catch tag + (setq + id-and-timer + (apply + #'jsonrpc--async-request-1 + connection method params + :sync-request t + :success-fn (lambda (result) + (unless canceled + (setq retval `(done ,result)) + (throw tag nil))) + :error-fn + (jsonrpc-lambda + (&key code message data) + (unless canceled + (setq retval `(error (jsonrpc-error-code . ,code) + (jsonrpc-error-message . ,message) + (jsonrpc-error-data . ,data))) + (throw tag nil))) + :timeout-fn + (lambda () + (unless canceled + (setq retval '(error (jsonrpc-error-message . "Timed out"))) + (throw tag nil))) + `(,@(when (plist-member args :deferred) `(:deferred ,deferred)) + ,@(when (plist-member args :timeout) `(:timeout ,timeout))))) + (cond (cancel-on-input + (unwind-protect + (let ((inhibit-quit t) (inhibit-redisplay t)) + (while (sit-for 30 t))) + (setq canceled t)) + (when (functionp cancel-on-input) + (funcall cancel-on-input (car id-and-timer))) + (setq retval `(canceled ,cancel-on-input-retval))) + (t (let ((inhibit-quit nil)) + (while t (accept-process-output nil 30)))))) + ;; In normal operation, continuations for error/success is + ;; handled by `jsonrpc--continue'. Timeouts also remove + ;; the continuation... + (pcase-let* ((`(,id ,_) id-and-timer)) + ;; ...but we still have to guard against exist explicit + ;; user-quit (C-g) or the `cancel-on-input' case, so + ;; discard the continuation. + (jsonrpc--remove connection id (list deferred (current-buffer))) + ;; Furthermore, assume a nil `retval' is a quit from + ;; `accept-process-output' (either "soft" or "hard," like a + ;; double C-g C-g on TTY terminals) + (unless retval + (when cancel-on-quit (funcall cancel-on-quit id))) + ;; ...finally, whatever may have happened to this sync + ;; request, it might have been holding up any outer + ;; "anxious" continuations. The following ensures we + ;; call them. + (jsonrpc--continue connection id))) + (cond ((eq 'error (car retval)) + (signal 'jsonrpc-error + (cons + (format "request id=%s failed:" (car id-and-timer)) + (cdr retval))))) (cadr retval))) (cl-defun jsonrpc-notify (connection method params) diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 793b54f82d1..c5fbb5a3e22 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -2699,10 +2699,10 @@ from `browse-url-elinks-wrapper'. (fn URL &optional NEW-WINDOW)" t) (autoload 'browse-url-button-open "browse-url" "\ Follow the link under point using `browse-url'. -If EXTERNAL (the prefix if used interactively), open with the -external browser instead of the default one. +If SECONDARY (the prefix if used interactively), open with the +secondary browser instead of the default one. -(fn &optional EXTERNAL MOUSE-EVENT)" t) +(fn &optional SECONDARY MOUSE-EVENT)" t) (autoload 'browse-url-button-open-url "browse-url" "\ Open URL using `browse-url'. If `current-prefix-arg' is non-nil, use @@ -5133,7 +5133,7 @@ List of directories to search for source files named in error messages. Elements should be directory names, not file names of directories. The value nil as an element means to try the default directory.") (custom-autoload 'compilation-search-path "compile" t) -(defvar compile-command "make -k " "\ +(defvar compile-command (format "make -k -j%d " (ceiling (num-processors) 1.5)) "\ Last shell command used to do a compilation; default for next compilation. Sometimes it is useful for files to supply local values for this variable. @@ -5259,6 +5259,8 @@ evaluate the variable `compilation-shell-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. +\\{compilation-shell-minor-mode-map} + (fn &optional ARG)" t) (autoload 'compilation-minor-mode "compile" "\ Toggle Compilation minor mode. @@ -5281,6 +5283,8 @@ evaluate the variable `compilation-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. +\\{compilation-minor-mode-map} + (fn &optional ARG)" t) (autoload 'compilation-next-error-function "compile" "\ Advance to the next error message and visit the file where the error was. @@ -9805,7 +9809,7 @@ Turn on EDT Emulation." t) ;;; Generated autoloads from progmodes/eglot.el -(push '(eglot 1 19) package--builtin-versions) +(push '(eglot 1 21) package--builtin-versions) (define-obsolete-function-alias 'eglot-update #'eglot-upgrade-eglot "29.1") (autoload 'eglot "eglot" "\ Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES. @@ -9861,6 +9865,8 @@ command only needs to be invoked once per project, as all other files of a given major mode visited within the same project will automatically become managed with no further user intervention needed.") +(autoload 'eglot-manual "eglot" "\ +Read Eglot's manual." t) (autoload 'eglot-upgrade-eglot "eglot" "\ Update Eglot to latest version. @@ -13982,7 +13988,7 @@ value associated with ?b in SPECIFICATION, either padding it with leading zeros or truncating leading characters until it's ten characters wide\". -the substitution for a specification character can also be a +The substitution for a specification character can also be a function, taking no arguments and returning a string to be used for the replacement. It will only be called if FORMAT uses that character. For example: @@ -13996,6 +14002,9 @@ like above, so that it is compiled by the byte-compiler. Any text properties of FORMAT are copied to the result, with any text properties of a %-spec itself copied to its substitution. +However, note that face properties from the two sources are not +merged; the face properties of %-spec override the face properties +of substitutions, if any, in the result. IGNORE-MISSING indicates how to handle %-spec characters not present in SPECIFICATION. If it is nil or omitted, emit an @@ -19216,7 +19225,7 @@ Define an inline function NAME with arguments ARGS and body in BODY. This is halfway between `defmacro' and `defun'. BODY is used as a blueprint both for the body of the function and for the body of the compiler-macro used to generate the code inlined at each call site. -See Info node `(elisp)Inline Functions for more details. +See Info node `(elisp)Inline Functions' for more details. A (noinline t) in the `declare' form prevents the definition of the compiler macro. This is for the rare case in which you want to use this @@ -19453,6 +19462,7 @@ Selections are: \\`m' Place typed-in value in personal dictionary, then recheck current word. \\`C-l' Redraw screen. \\`C-r' Recursive edit. +\\`C-u' Toggle abbrev saving for an immediately subsequent replacement command. \\`C-z' Suspend Emacs or iconify frame.") (autoload 'ispell-kill-ispell "ispell" "\ Kill current Ispell process (so that you may start a fresh one). @@ -24627,10 +24637,6 @@ Each directory name should be absolute. These directories contain packages intended for system-wide; in contrast, `package-user-dir' contains packages for personal use." :type '(repeat directory) :initialize #'custom-initialize-delay :group 'applications :risky t :version "24.1") (custom-autoload 'package-directory-list "package" t) -(defvar package-activated-list nil "\ -List of the names of currently activated packages.") -(defvar package--activated nil "\ -Non-nil if `package-activate-all' has been run.") (autoload 'package-initialize "package" "\ Load Emacs Lisp packages, and activate them. The variable `package-load-list' controls which packages to load. @@ -24648,9 +24654,6 @@ you have code which must run before `package-initialize', put that code in the early init-file. (fn &optional NO-ACTIVATE)" t) -(defun package-activate-all nil "\ -Activate all installed packages. -The variable `package-load-list' controls which packages to load." (setq package--activated t) (let* ((elc (concat package-quickstart-file "c")) (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) (or (and qs (not (bound-and-true-p package-activated-list)) (with-demoted-errors "Error during quickstart: %S" (let ((load-source-file-function nil)) (unless (boundp 'package-activated-list) (setq package-activated-list nil)) (load qs nil 'nomessage) t))) (progn (require 'package) (with-no-warnings (package--activate-all)))))) (autoload 'package-import-keyring "package" "\ Import keys from FILE. @@ -24665,14 +24668,6 @@ downloads in the background. This is always the case when the command is invoked interactively. (fn &optional ASYNC)" t) -(autoload 'package-installed-p "package" "\ -Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. -If PACKAGE is a symbol, it is the package name and MIN-VERSION -should be a version list. - -If PACKAGE is a `package-desc' object, MIN-VERSION is ignored. - -(fn PACKAGE &optional MIN-VERSION)") (autoload 'package-install "package" "\ Install the package PKG. @@ -24693,7 +24688,7 @@ If the command is invoked with a prefix argument, it will allow upgrading of built-in packages, as if `package-install-upgrade-built-in' had been enabled. -(fn PKG &optional DONT-SELECT)" t) +(fn PKG &optional DONT-SELECT INTERACTIVE)" t) (autoload 'package-upgrade "package" "\ Upgrade package NAME if a newer version exists. @@ -24738,6 +24733,21 @@ If optional argument NOCONFIRM is non-nil, or when invoked with a prefix argument, don't ask for confirmation to install packages. (fn &optional NOCONFIRM)" t) +(autoload 'package-delete "package" "\ +Delete package PKG-DESC. + +Argument PKG-DESC is the full description of the package, for example as +obtained by `package-get-descriptor'. Interactively, prompt the user +for the package name and version. + +When package is used elsewhere as dependency of another package, +refuse deleting it and return an error. +If prefix argument FORCE is non-nil, package will be deleted even +if it is used elsewhere. +If NOSAVE is non-nil, the package is not removed from +`package-selected-packages'. + +(fn PKG-DESC &optional FORCE NOSAVE)" t) (autoload 'package-reinstall "package" "\ Reinstall package PKG. PKG should be either a symbol, the package name, or a `package-desc' @@ -24779,7 +24789,43 @@ short description. (fn &optional NO-FETCH)" t) (defalias 'package-list-packages 'list-packages) -(autoload 'package-get-version "package" "\ +(defcustom package-quickstart-file (locate-user-emacs-file "package-quickstart.el") "\ +Location of the file used to speed up activation of packages at startup." :type 'file :group 'applications :initialize #'custom-initialize-delay :version "27.1") +(custom-autoload 'package-quickstart-file "package" t) +(autoload 'package-browse-url "package" "\ +Open the website of the package under point in a browser. +`browse-url' is used to determine the browser to be used. If +SECONDARY (interactively, the prefix), use the secondary browser. +DESC must be a `package-desc' object. + +(fn DESC &optional SECONDARY)" t) +(autoload 'package-report-bug "package" "\ +Prepare a message to send to the maintainers of a package. +DESC must be a `package-desc' object. + +(fn DESC)" t) +(register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-")) + + +;;; Generated autoloads from emacs-lisp/package-activate.el + +(push '(package-activate 1 1 0) package--builtin-versions) +(defvar package-activated-list nil "\ +List of the names of currently activated packages.") +(defvar package--activated nil "\ +Non-nil if `package-activate-all' has been run.") +(defun package-activate-all nil "\ +Activate all installed packages. +The variable `package-load-list' controls which packages to load." (setq package--activated t) (let* ((elc (concat package-quickstart-file "c")) (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) (or (and qs (not (bound-and-true-p package-activated-list)) (with-demoted-errors "Error during quickstart: %S" (let ((load-source-file-function nil)) (unless (boundp 'package-activated-list) (setq package-activated-list nil)) (load qs nil 'nomessage) t))) (progn (require 'package) (with-no-warnings (package--activate-all)))))) +(autoload 'package-installed-p "package-activate" "\ +Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a `package-desc' object, MIN-VERSION is ignored. + +(fn PACKAGE &optional MIN-VERSION)") +(autoload 'package-get-version "package-activate" "\ Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory of an installed ELPA package. @@ -24787,15 +24833,7 @@ The return value is a string (or nil in case we can't find it). It works in more cases if the call is in the file which contains the `Version:' header.") (function-put 'package-get-version 'pure 't) -(defcustom package-quickstart-file (locate-user-emacs-file "package-quickstart.el") "\ -Location of the file used to speed up activation of packages at startup." :type 'file :group 'applications :initialize #'custom-initialize-delay :version "27.1") -(custom-autoload 'package-quickstart-file "package" t) -(autoload 'package-report-bug "package" "\ -Prepare a message to send to the maintainers of a package. -DESC must be a `package-desc' object. - -(fn DESC)" '(package-menu-mode)) -(register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-")) +(register-definition-prefixes "package-activate" '("package-")) ;;; Generated autoloads from emacs-lisp/package-vc.el @@ -25797,6 +25835,10 @@ Note that this function doesn't work if DELTA is larger than the height of the current window. (fn DELTA)") +(autoload 'pixel-scroll-interpolate-down "pixel-scroll" "\ +Interpolate a scroll downwards by one page." t) +(autoload 'pixel-scroll-interpolate-up "pixel-scroll" "\ +Interpolate a scroll upwards by one page." t) (defvar pixel-scroll-precision-mode nil "\ Non-nil if Pixel-Scroll-Precision mode is enabled. See the `pixel-scroll-precision-mode' command @@ -26527,7 +26569,7 @@ Open profile FILENAME. ;;; Generated autoloads from progmodes/project.el -(push '(project 0 11 1) package--builtin-versions) +(push '(project 0 11 2) package--builtin-versions) (autoload 'project-current "project" "\ Return the project instance in DIRECTORY, defaulting to `default-directory'. @@ -26820,7 +26862,8 @@ would otherwise have the same name. Whether to show current project name and Project menu on the mode line. This feature requires the presence of the following item in `mode-line-format': `(project-mode-line project-mode-line-format)'; it -is part of the default mode line beginning with Emacs 30.") +is part of the default mode line beginning with Emacs 30. When the +value is `non-remote', show the project name only for local files.") (custom-autoload 'project-mode-line "project" t) (register-definition-prefixes "project" '("project-" "vc-")) @@ -33990,9 +34033,9 @@ of the file before running this function, by default can look like one of the following (your choice): Time-stamp: <> Time-stamp: \" \" -This function writes the current time between the brackets or quotes, -by default formatted like this: - Time-stamp: <2024-08-07 17:10:21 gildea> +This function writes the current time between the angle brackets +or quotes, by default formatted like this: + Time-stamp: <2025-08-07 17:10:21 gildea> Although you can run this function manually to update a time stamp once, usually you want automatic time stamp updating. @@ -34010,7 +34053,8 @@ If the file has no time stamp template or if `time-stamp-active' is nil, this function does nothing. You can set `time-stamp-pattern' in a file's local variables list -to customize the information in the time stamp and where it is written." t) +to customize the information in the time stamp, the surrounding +template, and where in the file it can occur." t) (autoload 'time-stamp-toggle-active "time-stamp" "\ Set `time-stamp-active' (whether \\[time-stamp] updates a buffer). If ARG is unset, toggle `time-stamp-active'. With an arg, set @@ -34559,13 +34603,13 @@ This is like `trace-function-foreground', but without popping up the output buffer or changing the window configuration. (fn FUNCTION &optional BUFFER CONTEXT)" t) -(defalias 'trace-function 'trace-function-foreground) +(defalias 'trace-function #'trace-function-foreground) (register-definition-prefixes "trace" '("inhibit-trace" "trace-" "untrace-")) ;;; Generated autoloads from emacs-lisp/track-changes.el -(push '(track-changes 1 4) package--builtin-versions) +(push '(track-changes 1 5) package--builtin-versions) (register-definition-prefixes "track-changes" '("track-changes-" "with--track-changes")) @@ -34751,13 +34795,13 @@ Interactively, with a prefix argument, prompt for a different method." t) ;;; Generated autoloads from net/trampver.el -(push '(tramp 2 8 1 -1) package--builtin-versions) +(push '(tramp 2 8 2 -1) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) ;;; Generated autoloads from transient.el -(push '(transient 0 11 0) package--builtin-versions) +(push '(transient 0 12 0) package--builtin-versions) (autoload 'transient-insert-suffix "transient" "\ Insert a SUFFIX into PREFIX before LOC. PREFIX is a prefix command, a symbol. @@ -36515,22 +36559,31 @@ See `vc-use-incoming-outgoing-prefixes' regarding giving this command a global binding. (fn &optional UPSTREAM-LOCATION FILESET)" t) + (put 'vc-trunk-branch-regexps 'safe-local-variable + #'vc--safe-branch-regexps-p) + (put 'vc-topic-branch-regexps 'safe-local-variable + #'vc--safe-branch-regexps-p) (autoload 'vc-root-diff-outgoing-base "vc" "\ Report diff of all changes since the merge base with UPSTREAM-LOCATION. The merge base with UPSTREAM-LOCATION means the common ancestor of the working revision and UPSTREAM-LOCATION. Uncommitted changes are included in the diff. -When unspecified UPSTREAM-LOCATION is the place \\[vc-push] would push -to. This default meaning for UPSTREAM-LOCATION may change in a future -release of Emacs. +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. When called interactively with a prefix argument, prompt for UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION can be a remote branch name. -This command is like `vc-root-diff-outgoing' except that it includes -uncommitted changes. +When called interactively with a \\[universal-argument] \\[universal-argument] prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch. (With a double prefix argument, this command is like +`vc-diff-outgoing' except that it includes uncommitted changes.) (fn &optional UPSTREAM-LOCATION)" t) (autoload 'vc-diff-outgoing-base "vc" "\ @@ -36540,18 +36593,69 @@ The merge base with UPSTREAM-LOCATION means the common ancestor of the working revision and UPSTREAM-LOCATION. Uncommitted changes are included in the diff. -When unspecified UPSTREAM-LOCATION is the place \\[vc-push] would push -to. This default meaning for UPSTREAM-LOCATION may change in a future -release of Emacs. +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. When called interactively with a prefix argument, prompt for UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION can be a remote branch name. -This command is like to `vc-diff-outgoing' except that it includes -uncommitted changes. +When called interactively with a \\[universal-argument] \\[universal-argument] prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch. (With a double prefix argument, this command is like +`vc-diff-outgoing' except that it includes uncommitted changes.) + +When called from Lisp, optional argument FILESET overrides the fileset. (fn &optional UPSTREAM-LOCATION FILESET)" t) +(autoload 'vc-log-outgoing-base "vc" "\ +Show log for the VC fileset since the merge base with UPSTREAM-LOCATION. +The merge base with UPSTREAM-LOCATION means the common ancestor of the +working revision and UPSTREAM-LOCATION. + +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. + +When called interactively with a prefix argument, prompt for +UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION +can be a remote branch name. + +When called interactively with a \\[universal-argument] \\[universal-argument] prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch. + +When called from Lisp, optional argument FILESET overrides the fileset. + +(fn &optional UPSTREAM-LOCATION FILESET)" t) +(autoload 'vc-root-log-outgoing-base "vc" "\ +Show log of revisions since the merge base with UPSTREAM-LOCATION. +The merge base with UPSTREAM-LOCATION means the common ancestor of the +working revision and UPSTREAM-LOCATION. + +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. + +When called interactively with a prefix argument, prompt for +UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION +can be a remote branch name. + +When called interactively with a \\[universal-argument] \\[universal-argument] prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch. + +(fn &optional UPSTREAM-LOCATION)" t) (autoload 'vc-version-ediff "vc" "\ Show differences between REV1 and REV2 of FILES using ediff. This compares two revisions of the files in FILES. Currently, @@ -36700,6 +36804,16 @@ the full log message and the author. Additional control of the shown log style is available via `vc-log-short-style'. (fn &optional WORKING-REVISION LIMIT)" t) +(autoload 'vc-print-change-log "vc" "\ +Show in another window the VC change history of the current fileset. +With a \\[universal-argument] prefix argument, prompt for a branch or revision to log +instead of the working revision, and a number specifying the maximum +number of revisions to show; the default is `vc-log-show-limit'. +You can also use a numeric prefix argument to specify this. + +This is like `vc-print-log' but with an alternative prefix argument that +some users might prefer for interactive usage." t) +(function-put 'vc-print-change-log 'interactive-only 'vc-print-log) (autoload 'vc-print-root-log "vc" "\ Show in another window VC change history of the current VC controlled tree. If LIMIT is non-nil, it should be a number specifying the maximum @@ -36711,6 +36825,16 @@ the command prompts for the id of a REVISION, and shows that revision with its diffs (if the underlying VCS backend supports that). (fn &optional LIMIT REVISION)" t) +(autoload 'vc-print-root-change-log "vc" "\ +Show in another window the VC change history of the whole tree. +With a \\[universal-argument] prefix argument, prompt for a branch or revision to log +instead of the working revision, and a number specifying the maximum +number of revisions to show; the default is `vc-log-show-limit'. +You can also use a numeric prefix argument to specify this. + +This is like `vc-root-print-log' but with an alternative prefix argument +that some users might prefer for interactive usage." t) +(function-put 'vc-print-root-change-log 'interactive-only 'vc-print-root-log) (autoload 'vc-print-fileset-branch-log "vc" "\ Show log of VC changes on BRANCH, limited to the current fileset. When called interactively, prompts for BRANCH. @@ -36727,7 +36851,7 @@ can specify a revision ID instead of a branch name to produce a log starting at that revision. Tags and remote references also work. (fn BRANCH)" t) -(autoload 'vc-log-incoming "vc" "\ +(autoload 'vc-root-log-incoming "vc" "\ Show log of changes that will be received with pull from UPSTREAM-LOCATION. When unspecified UPSTREAM-LOCATION is the place \\[vc-update] would pull from. When called interactively with a prefix argument, prompt for @@ -36735,7 +36859,7 @@ UPSTREAM-LOCATION. In some version control systems UPSTREAM-LOCATION can be a remote branch name. (fn &optional UPSTREAM-LOCATION)" t) -(autoload 'vc-log-outgoing "vc" "\ +(autoload 'vc-root-log-outgoing "vc" "\ Show log of changes that will be sent with a push to UPSTREAM-LOCATION. When unspecified UPSTREAM-LOCATION is the place \\[vc-push] would push to. When called interactively with a prefix argument, prompt for @@ -37262,7 +37386,7 @@ step during initialization." t) ;;; Generated autoloads from progmodes/verilog-mode.el -(push '(verilog-mode 2025 11 8 248496848) package--builtin-versions) +(push '(verilog-mode 2026 1 18 88738971) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. \\ @@ -39583,6 +39707,14 @@ list. Delete FRAME2 if the merge completed successfully and return FRAME1. (fn &optional FRAME1 FRAME2 VERTICAL)" t) +(autoload 'window-get-split-combination "window-x" "\ +Return window combination suitable for `split-frame'. + +WINDOW is the main window in which the combination should be derived. +ARG is the argument passed to `split-frame'. Return a +combination of windows `split-frame' is considered to split off. + +(fn WINDOW ARG)") (autoload 'split-frame "window-x" "\ Split windows of specified FRAME into two separate frames. FRAME must be a live frame and defaults to the selected frame. ARG @@ -39917,12 +40049,9 @@ output of this command when the backend is etags. (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame) (autoload 'xref-references-in-directory "xref" "\ Find all references to SYMBOL in directory DIR. +See `xref-references-in-directory-function' for the implementation. Return a list of xref values. -This function uses the Semantic Symbol Reference API, see -`semantic-symref-tool-alist' for details on which tools are used, -and when. - (fn SYMBOL DIR)") (autoload 'xref-matches-in-directory "xref" "\ Find all matches for REGEXP in directory DIR. @@ -39930,8 +40059,9 @@ Return a list of xref values. Only files matching some of FILES and none of IGNORES are searched. FILES is a string with glob patterns separated by spaces. IGNORES is a list of glob patterns for files to ignore. +If DELIMITED is `symbol', only select matches that span full symbols. -(fn REGEXP FILES DIR IGNORES)") +(fn REGEXP FILES DIR IGNORES &optional DELIMITED)") (autoload 'xref-matches-in-files "xref" "\ Find all matches for REGEXP in FILES. Return a list of xref values. @@ -40029,7 +40159,7 @@ Enable `yaml-ts-mode' when its grammar is available. Also propose to install the grammar when `treesit-enabled-modes' is t or contains the mode name.") (when (boundp 'treesit-major-mode-remap-alist) (add-to-list 'auto-mode-alist '("\\.ya?ml\\'" . yaml-ts-mode-maybe)) (add-to-list 'treesit-major-mode-remap-alist '(yaml-mode . yaml-ts-mode))) -(register-definition-prefixes "yaml-ts-mode" '("yaml-ts-mode--")) +(register-definition-prefixes "yaml-ts-mode" '("yaml-ts-mode-")) ;;; Generated autoloads from yank-media.el diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el index bbcadb9c611..8b2e0999f77 100644 --- a/lisp/leim/quail/latin-ltx.el +++ b/lisp/leim/quail/latin-ltx.el @@ -66,6 +66,22 @@ system, including many technical ones. Examples: (defun latin-ltx--ascii-p (char) (and (characterp char) (< char 128))) + ;; For mathematical alphabets + (defconst latin-ltx--math-variant-prefix-map + '(("BOLD" . "bf") + ("ITALIC" . "it") + ("BOLD ITALIC" . "bfit") + ("DOUBLE-STRUCK" . "bb") + ("SCRIPT" . "scr") + ("BOLD SCRIPT" . "bfscr") + ("FRAKTUR" . "frak") + ("BOLD FRAKTUR" . "bffrak") + ("SANS-SERIF" . "sf") + ("SANS-SERIF BOLD" . "bfsf") + ("SANS-SERIF ITALIC" . "sfit") + ("SANS-SERIF BOLD ITALIC" . "bfsfit") + ("MONOSPACE" . "tt"))) + (defmacro latin-ltx--define-rules (&rest rules) (load "uni-name" nil t) (let ((newrules ())) @@ -281,6 +297,7 @@ system, including many technical ones. Examples: ("\\Vert" ?‖) ("\\Vvdash" ?⊪) ("\\above" ?┴) + ("\\acute" ?́) ;; synonymous with \'‌ ("\\aleph" ?ℵ) ("\\amalg" ?∐) ("\\angle" ?∠) @@ -297,6 +314,7 @@ system, including many technical ones. Examples: ("\\backsim" ?∽) ("\\backsimeq" ?⋍) ("\\backslash" ?\\) + ("\\bar" ?̄) ;; synonymous with \= ("\\barwedge" ?⊼) ("\\because" ?∵) ("\\begin" ?\〖) @@ -328,11 +346,14 @@ system, including many technical ones. Examples: ("\\boxplus" ?⊞) ("\\boxtimes" ?⊠) ("\\bra" ?\⟨) + ("\\breve" ?̆) ;; synonymous with \u ("\\bullet" ?•) ("\\bumpeq" ?≏) ("\\cap" ?∩) + ("\\cbrt" ?∛) ("\\cdots" ?⋯) ("\\centerdot" ?·) + ("\\check" ?̌) ;; synonymous with \v ("\\checkmark" ?✓) ("\\chi" ?χ) ("\\circ" ?∘) @@ -370,10 +391,14 @@ system, including many technical ones. Examples: ("\\ddagger" ?‡) ("\\ddddot" ?⃜) ("\\dddot" ?⃛) + ("\\ddot" ?̈) ;; synonymous with \" ("\\ddots" ?⋱) + ("\\diagdown" ?⟍) + ("\\diagup" ?⟋) ("\\diamond" ?⋄) ("\\diamondsuit" ?♢) ("\\divideontimes" ?⋇) + ("\\dot" ?̇) ("\\doteq" ?≐) ("\\doteqdot" ?≑) ("\\dotplus" ?∔) @@ -397,13 +422,17 @@ system, including many technical ones. Examples: ("\\fallingdotseq" ?≒) ("\\flat" ?♭) ("\\forall" ?∀) + ("\\frac03" ?↉) ("\\frac1" ?⅟) + ("\\frac110" ?⅒) ("\\frac12" ?½) ("\\frac13" ?⅓) ("\\frac14" ?¼) ("\\frac15" ?⅕) ("\\frac16" ?⅙) + ("\\frac17" ?⅐) ("\\frac18" ?⅛) + ("\\frac19" ?⅑) ("\\frac23" ?⅔) ("\\frac25" ?⅖) ("\\frac34" ?¾) @@ -426,6 +455,7 @@ system, including many technical ones. Examples: ("\\gneq" ?≩) ("\\gneqq" ?≩) ("\\gnsim" ?⋧) + ("\\grave" ?̀) ;; synonymous with \` ("\\gtrapprox" ?≳) ("\\gtrdot" ?⋗) ("\\gtreqless" ?⋛) @@ -433,6 +463,7 @@ system, including many technical ones. Examples: ("\\gtrless" ?≷) ("\\gtrsim" ?≳) ("\\gvertneqq" ?≩) + ("\\hat" ?̂) ;; synonymous with \^ ("\\hbar" ?ℏ) ("\\heartsuit" ?♥) ("\\hookleftarrow" ?↩) @@ -451,10 +482,17 @@ system, including many technical ones. Examples: ("\\intercal" ?⊺) ("\\jj" ?ⅉ) ("\\jmath" ?ȷ) - ("\\langle" ?⟨) ;; Was ?〈, see bug#12948. - ("\\lbrace" ?{) + ("\\ket" ?\⟩) + ("\\land" ?∧) ;; logical and, same symbol as \wedge + ("\\langle" ?\⟨) ;; Was ?〈, see bug#12948. + ("\\lAngle" ?\⟪) + ("\\lbrace" ?\{) ("\\lbrack" ?\[) - ("\\lceil" ?⌈) + ("\\lBrack" ?\⟦) + ("\\lblkbrbrak" ?\⦗) + ("\\lbrbrak" ?\❲) + ("\\Lbrbrak" ?\⟬) + ("\\lceil" ?\⌈) ("\\ldiv" ?∕) ("\\ldots" ?…) ("\\le" ?≤) @@ -479,12 +517,14 @@ system, including many technical ones. Examples: ("\\lesseqqgtr" ?⋚) ("\\lessgtr" ?≶) ("\\lesssim" ?≲) - ("\\lfloor" ?⌊) + ("\\lfloor" ?\⌊) + ("\\lgroup" ?\⟮) ("\\lhd" ?◁) ("\\rhd" ?▷) ("\\ll" ?≪) ("\\llcorner" ?⌞) ("\\lll" ?⋘) + ("\\lmoustache" ?⎰) ("\\lnapprox" ?⋦) ("\\lneq" ?≨) ("\\lneqq" ?≨) @@ -495,6 +535,7 @@ system, including many technical ones. Examples: ("\\longrightarrow" ?⟶) ("\\looparrowleft" ?↫) ("\\looparrowright" ?↬) + ("\\lor" ?∨) ;; logical or, same symbol as \vee ("\\lozenge" ?✧) ("\\lq" ?‘) ("\\lrcorner" ?⌟) @@ -502,6 +543,7 @@ system, including many technical ones. Examples: ("\\lvertneqq" ?≨) ("\\maltese" ?✠) ("\\mapsto" ?↦) + ("\\mathring" ?̊) ("\\measuredangle" ?∡) ("\\mho" ?℧) ("\\mid" ?∣) @@ -569,8 +611,12 @@ system, including many technical ones. Examples: ("\\oplus" ?⊕) ("\\oslash" ?⊘) ("\\otimes" ?⊗) + ("\\overbar" ?̅) ("\\overbrace" ?⏞) + ("\\overleftarrow" ?⃖) ("\\overparen" ?⏜) + ("\\overrightarrow" ?⃗) ;; synonymous with \vec + ("\\owns" ?∋) ;; synonymous with \ni ("\\par" ?
) ("\\parallel" ?∥) ("\\partial" ?∂) @@ -594,13 +640,18 @@ system, including many technical ones. Examples: ("\\qed" ?∎) ("\\quad" ? ) ("\\rangle" ?\⟩) ;; Was ?〉, see bug#12948. + ("\\rAngle" ?\⟫) ("\\ratio" ?∶) - ("\\rbrace" ?}) + ("\\rbrace" ?\}) ("\\rbrack" ?\]) - ("\\rceil" ?⌉) + ("\\rBrack" ?\⟧) + ("\\rblkbrbrak" ?\⦘) + ("\\rbrbrak" ?\❳) + ("\\Rbrbrak" ?\⟭) + ("\\rceil" ?\⌉) ("\\rddots" ?⋰) ("\\rect" ?▭) - ("\\rfloor" ?⌋) + ("\\rfloor" ?\⌋) ("\\rightarrow" ?→) ("\\rightarrowtail" ?↣) ("\\rightharpoondown" ?⇁) @@ -611,6 +662,8 @@ system, including many technical ones. Examples: ("\\rightrightarrows" ?⇉) ("\\rightthreetimes" ?⋌) ("\\risingdotseq" ?≓) + ("\\rgroup" ?\⟯) + ("\\rmoustache" ?⎱) ("\\rrect" ?▢) ("\\sdiv" ?⁄) ("\\rtimes" ?⋊) @@ -662,6 +715,7 @@ system, including many technical ones. Examples: ("\\therefore" ?∴) ("\\thickapprox" ?≈) ("\\thicksim" ?∼) + ("\\tilde" ?̃) ;; synonymous with \~ ("\\to" ?→) ("\\top" ?⊤) ("\\triangle" ?▵) @@ -678,6 +732,8 @@ system, including many technical ones. Examples: ("\\updownarrow" ?↕) ("\\underbar" ?▁) ("\\underbrace" ?⏟) + ("\\underleftarrow" ?⃮) + ("\\underrightarrow" ?⃯) ("\\underparen" ?⏝) ("\\upleftharpoon" ?↿) ("\\uplus" ?⊎) @@ -686,6 +742,7 @@ system, including many technical ones. Examples: ("\\urcorner" ?⌝) ("\\u{i}" ?ĭ) ("\\vbar" ?│) + ("\\vec" ?⃗) ("\\vDash" ?⊨) ((lambda (name char) @@ -713,6 +770,77 @@ system, including many technical ones. Examples: ("\\wp" ?℘) ("\\wr" ?≀) + ;;;; Mathematical alphabets + ;; Latin letters + ((lambda (name _char) + (let* ((variant (match-string 1 name)) + (prefix (cdr (assoc variant latin-ltx--math-variant-prefix-map))) + (basename (match-string 3 name)) + (name (if (match-end 2) (capitalize basename) (downcase basename)))) + (concat "\\" prefix name))) + "\\`MATHEMATICAL \\(.+\\) \\(?:SMALL\\|CAPITA\\(L\\)\\) \\([[:ascii:]]+\\)\\'") + + ;; Digits + ((lambda (name _char) + (let* ((variant (match-string 1 name)) + (prefix (cdr (assoc variant latin-ltx--math-variant-prefix-map))) + (basename (match-string 2 name))) + (concat "\\" prefix (char-to-string (char-from-name basename))))) + "\\`MATHEMATICAL \\(.+\\) \\(DIGIT [[:ascii:]]+\\)\\'") + + ;; Some Greek variants + ;; NOTE: Check if any of these are reversed from their counterparts, like + ;; the claim above of \phi and \varphi being swapped + ((lambda (name _char) + (let* ((variant (match-string 1 name)) + (prefix (cdr (assoc variant latin-ltx--math-variant-prefix-map))) + (basename (downcase (match-string 2 name)))) + (if prefix ;; This avoids e.g. MATHEMATICAL BOLD CAPITAL SYMBOL + (concat "\\" prefix "var" basename)))) + "\\`MATHEMATICAL \\(.+\\) \\([A-Z]+\\) SYMBOL\\'") + + ((lambda (name _char) + (let* ((variant (match-string 1 name)) + (prefix (cdr (assoc variant latin-ltx--math-variant-prefix-map))) + (basename (if (match-end 2) "partial" "nabla"))) + (concat "\\" prefix basename))) + "\\`MATHEMATICAL \\(.*\\) \\(?:NABLA\\|PARTIAL DIFFERENTIA\\(L\\)\\)\\'") + + ;; Some of the math alphabet characters have other canonical names and must be + ;; added manually + ("\\scrB" ?ℬ) + ("\\scrE" ?ℰ) + ("\\scrF" ?ℱ) + ("\\scrH" ?ℋ) + ("\\scrI" ?ℐ) + ("\\scrL" ?ℒ) + ("\\scrM" ?ℳ) + ("\\scrR" ?ℛ) + ("\\frakC" ?ℭ) + ("\\frakH" ?ℌ) + ("\\frakI" ?ℑ) + ("\\frakR" ?ℜ) + ("\\frakZ" ?ℨ) + ("\\bbC" ?ℂ) + ("\\bbH" ?ℍ) + ("\\bbN" ?ℕ) + ("\\bbP" ?ℙ) + ("\\bbQ" ?ℚ) + ("\\bbR" ?ℝ) + ("\\bbZ" ?ℤ) + ("\\ith" ?ℎ) + ("\\scre" ?ℯ) + ("\\scrg" ?ℊ) + ("\\scro" ?ℴ) + + ("\\bbsum" ?⅀) + ("\\bbSigma" ?⅀) + ("\\bbgamma" ?ℽ) + ("\\bbGamma" ?ℾ) + ("\\bbprod" ?ℿ) + ("\\bbPi" ?ℿ) + ("\\bbpi" ?ℼ) + ("\\Bbb{A}" ?𝔸) ; AMS commands for blackboard bold ("\\Bbb{B}" ?𝔹) ; Also sometimes \mathbb. ("\\Bbb{C}" ?ℂ) @@ -772,6 +900,7 @@ system, including many technical ones. Examples: ;; ("\\Yinyang" ?☯) ;; ("\\Heart" ?♡) ("\\dh" ?ð) + ("\\eth" ?ð) ("\\DH" ?Ð) ("\\th" ?þ) ("\\TH" ?Þ) @@ -787,16 +916,16 @@ system, including many technical ones. Examples: ("\\sqrt" ?√) ("\\sqrt[3]" ?∛) ("\\sqrt[4]" ?∜) - ("\\llbracket" ?\〚) ; stmaryrd - ("\\rrbracket" ?\〛) + ("\\llbracket" ?\⟦) ; stmaryrd + ("\\rrbracket" ?\⟧) ;; ("\\lbag" ?\〚) ; fuzz ;; ("\\rbag" ?\〛) - ("\\ldata" ?\《) ; fuzz/zed - ("\\rdata" ?\》) + ("\\ldata" ?\⟪) ; fuzz/zed + ("\\rdata" ?\⟫) ;; From Karl Eichwalder. - ("\\glq" ?‚) + ("\\glq" ?\‚) ("\\grq" ?‘) - ("\\glqq" ?„) ("\\\"`" ?„) + ("\\glqq" ?\„) ("\\\"`" ?\„) ("\\grqq" ?“) ("\\\"'" ?“) ("\\flq" ?‹) ("\\frq" ?›) diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index 80949dff198..5ee822e2dec 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -27,8 +27,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" "US-ASCII control characters excluding CR, LF and white space.") (defvar ietf-drums-text-token "\001-\011\013\014\016-\177" diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el index 089875209e9..a48b876443b 100644 --- a/lisp/mail/rfc2047.el +++ b/lisp/mail/rfc2047.el @@ -26,7 +26,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (defvar message-posting-charset) (require 'mm-util) diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 8dd04f97c21..79c2d04ac4f 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -1201,6 +1201,7 @@ a negative argument means to delete and move forward." (or (eobp) (not (overlay-get rmail-summary-overlay 'face)) (let ((buffer-read-only nil)) + (beginning-of-line) (skip-chars-forward " ") (skip-chars-forward "0-9") (if undel diff --git a/lisp/mail/yenc.el b/lisp/mail/yenc.el index fe3315a226f..88e56c7dc67 100644 --- a/lisp/mail/yenc.el +++ b/lisp/mail/yenc.el @@ -32,8 +32,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (defconst yenc-begin-line "^=ybegin.*$") diff --git a/lisp/man.el b/lisp/man.el index 549dfd6d955..3b59efa0a44 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -559,9 +559,12 @@ Otherwise, the value is whatever the function (defun Man-shell-file-name () "Return a proper shell file name, respecting remote directories." + ;; It must be a Bourne-shell. (Bug#75308, Bug#80212) (if (connection-local-p shell-file-name) (connection-local-value shell-file-name) - "/bin/sh")) + (if (memq system-type '(windows-nt ms-dos)) + shell-file-name + "/bin/sh"))) (defun Man-header-file-path () "Return the C header file search path that Man should use. @@ -1221,7 +1224,11 @@ Return the buffer in which the manpage will appear." (buffer (get-buffer bufname))) (if buffer (Man-notify-when-ready buffer) - (message "Invoking %s %s in the background" manual-program man-args) + (message "Invoking %s %s %s" + manual-program man-args + (if Man-prefer-synchronous-call + "and formatting..." + "in the background")) (setq buffer (generate-new-buffer bufname)) (Man-notify-when-ready buffer) (with-current-buffer buffer diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 1c888e4012a..fc193fe54f0 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -797,6 +797,19 @@ for use at QPOS." (defvar minibuffer-message-properties nil "Text properties added to the text shown by `minibuffer-message'.") +(defvar minibuffer--message-overlay nil) + +(defvar minibuffer--message-timer nil) + +(defun minibuffer--delete-message-overlay () + (when (overlayp minibuffer--message-overlay) + (delete-overlay minibuffer--message-overlay) + (setq minibuffer--message-overlay nil)) + (when (timerp minibuffer--message-timer) + (cancel-timer minibuffer--message-timer) + (setq minibuffer--message-timer nil)) + (remove-hook 'pre-command-hook #'minibuffer--delete-message-overlay)) + (defun minibuffer-message (message &rest args) "Temporarily display MESSAGE at the end of minibuffer text. This function is designed to be called from the minibuffer, i.e., @@ -814,13 +827,9 @@ through `format-message'. If some of the minibuffer text has the `minibuffer-message' text property, MESSAGE is shown at that position instead of EOB." (if (not (minibufferp (current-buffer) t)) - (progn - (if args - (apply #'message message args) - (message "%s" message)) - (prog1 (sit-for (or minibuffer-message-timeout 1000000)) - (message nil))) + (apply #'message message args) ;; Clear out any old echo-area message to make way for our new thing. + (minibuffer--delete-message-overlay) (message nil) (setq message (if (and (null args) (string-match-p "\\` *\\[.+\\]\\'" message)) @@ -834,30 +843,24 @@ property, MESSAGE is shown at that position instead of EOB." (setq message (apply #'propertize message minibuffer-message-properties))) ;; Put overlay either on `minibuffer-message' property, or at EOB. (let* ((ovpos (minibuffer--message-overlay-pos)) - (ol (make-overlay ovpos ovpos nil t t)) - ;; A quit during sit-for normally only interrupts the sit-for, - ;; but since minibuffer-message is used at the end of a command, - ;; at a time when the command has virtually finished already, a C-g - ;; should really cause an abort-recursive-edit instead (i.e. as if - ;; the C-g had been typed at top-level). Binding inhibit-quit here - ;; is an attempt to get that behavior. - (inhibit-quit t)) - (unwind-protect - (progn - (unless (zerop (length message)) - ;; The current C cursor code doesn't know to use the overlay's - ;; marker's stickiness to figure out whether to place the cursor - ;; before or after the string, so let's spoon-feed it the pos. - (put-text-property 0 1 'cursor t message)) - (overlay-put ol 'after-string message) - ;; Make sure the overlay with the message is displayed before - ;; any other overlays in that position, in case they have - ;; resize-mini-windows set to nil and the other overlay strings - ;; are too long for the mini-window width. This makes sure the - ;; temporary message will always be visible. - (overlay-put ol 'priority 1100) - (sit-for (or minibuffer-message-timeout 1000000))) - (delete-overlay ol))))) + (ol (make-overlay ovpos ovpos nil t t))) + (unless (zerop (length message)) + ;; The current C cursor code doesn't know to use the overlay's + ;; marker's stickiness to figure out whether to place the cursor + ;; before or after the string, so let's spoon-feed it the pos. + (put-text-property 0 1 'cursor t message)) + (overlay-put ol 'after-string message) + ;; Make sure the overlay with the message is displayed before + ;; any other overlays in that position, in case they have + ;; resize-mini-windows set to nil and the other overlay strings + ;; are too long for the mini-window width. This makes sure the + ;; temporary message will always be visible. + (overlay-put ol 'priority 1100) + (setq minibuffer--message-overlay ol + minibuffer--message-timer + (run-at-time (or minibuffer-message-timeout 1000000) nil + #'minibuffer--delete-message-overlay)) + (add-hook 'pre-command-hook #'minibuffer--delete-message-overlay)))) (defcustom minibuffer-message-clear-timeout nil "How long to display an echo-area message when the minibuffer is active. @@ -2774,18 +2777,27 @@ so that the update is less likely to interfere with user typing." ;; If we got interrupted, try again the next time the user is idle. (completions--start-eager-display)))) -(defun completions--start-eager-display () +(defun completions--start-eager-display (&optional require-eager-update) "Maybe display the *Completions* buffer when the user is next idle. Only displays if `completion-eager-display' is t, or if eager display -has been requested by the completion table." - (when completion-eager-display - (when (or (eq completion-eager-display t) - (completion-metadata-get - (completion-metadata - (buffer-substring-no-properties (minibuffer-prompt-end) (point)) - minibuffer-completion-table minibuffer-completion-predicate) - 'eager-display)) +has been requested by the completion table. + +When REQUIRE-EAGER-UPDATE is non-nil, also require eager-display to be +requested by the completion table." + (when (and completion-eager-display + ;; If it's already displayed, don't display it again. + (not (get-buffer-window "*Completions*" 0))) + (when (let ((metadata + (completion-metadata + (buffer-substring-no-properties (minibuffer-prompt-end) (point)) + minibuffer-completion-table minibuffer-completion-predicate))) + (and + (or (eq completion-eager-display t) + (completion-metadata-get metadata 'eager-display)) + (or (not require-eager-update) + (eq completion-eager-update t) + (completion-metadata-get metadata 'eager-update)))) (setq completion-eager-display--timer (run-with-idle-timer 0 nil #'completions--eager-display))))) @@ -2797,13 +2809,16 @@ has been requested by the completion table." (defun completions--after-change (_start _end _old-len) "Update displayed *Completions* buffer after change in buffer contents." - (when (or completion-auto-deselect completion-eager-update) - (when-let* ((window (minibuffer--completions-visible))) + (if (not (or (minibufferp nil t) completion-in-region-mode)) + (remove-hook 'after-change-functions #'completions--after-change t) + (when-let* ((window (get-buffer-window "*Completions*" 0))) (when completion-auto-deselect (with-selected-window window (completions--deselect))) (when completion-eager-update - (add-hook 'post-command-hook #'completions--post-command-update))))) + (add-hook 'post-command-hook #'completions--post-command-update))) + (when (minibufferp nil t) + (completions--start-eager-display t)))) (defun minibuffer-completion-help (&optional start end) "Display a list of possible completions of the current minibuffer contents." @@ -2821,6 +2836,8 @@ has been requested by the completion table." (- (point) start) md))) (message nil) + (when (or completion-auto-deselect completion-eager-update) + (add-hook 'after-change-functions #'completions--after-change nil t)) (if (or (null completions) (and (not (consp (cdr completions))) (equal (car completions) string))) @@ -2828,7 +2845,6 @@ has been requested by the completion table." ;; If there are no completions, or if the current input is already ;; the sole completion, then hide (previous&stale) completions. (minibuffer-hide-completions) - (remove-hook 'after-change-functions #'completions--after-change t) (if completions (completion--message "Sole completion") (unless completion-fail-discreetly @@ -2894,8 +2910,6 @@ has been requested by the completion table." (body-function . ,#'(lambda (window) (with-current-buffer mainbuf - (when (or completion-auto-deselect completion-eager-update) - (add-hook 'after-change-functions #'completions--after-change nil t)) ;; Remove the base-size tail because `sort' requires a properly ;; nil-terminated list. (when last (setcdr last nil)) @@ -3181,11 +3195,7 @@ Also respects the obsolete wrapper hook `completion-in-region-functions'. (setq-local minibuffer-completion-auto-choose nil) (add-hook 'post-command-hook #'completion-in-region--postch) (let* ((keymap completion-in-region-mode-map) - (keymap (if minibuffer-visible-completions - (make-composed-keymap - (list minibuffer-visible-completions-map - keymap)) - keymap))) + (keymap (minibuffer-visible-completions--maybe-compose-map keymap))) (push `(completion-in-region-mode . ,keymap) minor-mode-overriding-map-alist)))) @@ -3450,15 +3460,25 @@ the mode hook of this mode." (setq-local minibuffer-completion-auto-choose nil))) (defcustom minibuffer-visible-completions nil - "Whether candidates shown in *Completions* can be navigated from minibuffer. + "Whether to enable navigation of candidates in *Completions* from minibuffer. When non-nil, if the *Completions* buffer is displayed in a window, -you can use the arrow keys in the minibuffer to move the cursor in +you can use the arrow keys in the minibuffer to move point in the window showing the *Completions* buffer. Typing `RET' selects the highlighted completion candidate. If the *Completions* buffer is not displayed on the screen, or this variable is nil, the arrow keys move point in the minibuffer as usual, -and `RET' accepts the input typed into the minibuffer." - :type 'boolean +and `RET' accepts the input typed into the minibuffer. +If the value is t, both up/down and right/left arrow keys move point +in *Completions*; if the value is \\+`up-down', only up/down arrow +keys move point in *Completions*, while left/right arrows move point +in the minibuffer window." + :type '(choice (const :tag + "Disable completions navigation with arrow keys" nil) + (const :tag + "Enable completions navigation with arrow keys" t) + (const :tag + "Enable completions navigation with up/down arrows" + up-down)) :version "30.1") (defvar minibuffer-visible-completions--always-bind nil @@ -3467,13 +3487,16 @@ and `RET' accepts the input typed into the minibuffer." (defun minibuffer--completions-visible () "Return the window where the current *Completions* buffer is visible, if any." (when-let* ((window (get-buffer-window "*Completions*" 0))) - (when (eq (buffer-local-value 'completion-reference-buffer - (window-buffer window)) - ;; If there's no active minibuffer, we call - ;; `window-buffer' on nil, assuming that completion is - ;; happening in the selected window. - (window-buffer (active-minibuffer-window))) - window))) + (let ((reference-buffer + (buffer-local-value 'completion-reference-buffer + (window-buffer window)))) + (when (or (null reference-buffer) + (eq reference-buffer + ;; If there's no active minibuffer, we call + ;; `window-buffer' on nil, assuming that completion is + ;; happening in the selected window. + (window-buffer (active-minibuffer-window)))) + window)))) (defun completion--selected-candidate () "Return the selected completion candidate if any." @@ -3503,6 +3526,20 @@ displaying the *Completions* buffer exists." "" (minibuffer-visible-completions--bind #'minibuffer-previous-line-completion) "" (minibuffer-visible-completions--bind #'minibuffer-next-line-completion) "C-g" (minibuffer-visible-completions--bind #'minibuffer-hide-completions)) + +(defvar-keymap minibuffer-visible-completions-up-down-map + :doc "Local keymap for minibuffer input with visible completions, only for up/down." + "" (minibuffer-visible-completions--bind #'minibuffer-previous-completion) + "" (minibuffer-visible-completions--bind #'minibuffer-next-completion)) + +(defun minibuffer-visible-completions--maybe-compose-map (map) + (cond + ((eq minibuffer-visible-completions 'up-down) + (make-composed-keymap (list minibuffer-visible-completions-up-down-map map))) + ((eq minibuffer-visible-completions t) + (make-composed-keymap (list minibuffer-visible-completions-map map))) + (t map))) + ;;; Completion tables. @@ -5158,11 +5195,7 @@ See `completing-read' for the meaning of the arguments." ;; in minibuffer-local-filename-completion-map can ;; override bindings in base-keymap. base-keymap))) - (keymap (if minibuffer-visible-completions - (make-composed-keymap - (list minibuffer-visible-completions-map - keymap)) - keymap)) + (keymap (minibuffer-visible-completions--maybe-compose-map keymap)) (buffer (current-buffer)) (c-i-c completion-ignore-case) (result diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 8806e6ab369..83ec67f976c 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1000,7 +1000,10 @@ opposite of the browser kind of `browse-url-browser-function'." browse-url-secondary-browser-function #'browse-url-default-browser #'eww)))) - (funcall function url arg))) + (let ((browse-url-browser-function function) + (browse-url-handlers nil) + (browse-url-default-handlers nil)) + (browse-url url arg)))) ;;;###autoload (defun browse-url-at-mouse (event) @@ -1788,17 +1791,19 @@ clickable and will use `browse-url' to open the URLs in question." browse-url-data ,(match-string 0))))))) ;;;###autoload -(defun browse-url-button-open (&optional external mouse-event) +(defun browse-url-button-open (&optional secondary mouse-event) "Follow the link under point using `browse-url'. -If EXTERNAL (the prefix if used interactively), open with the -external browser instead of the default one." +If SECONDARY (the prefix if used interactively), open with the +secondary browser instead of the default one." (interactive (list current-prefix-arg last-nonmenu-event)) (mouse-set-point mouse-event) (let ((url (get-text-property (point) 'browse-url-data))) (unless url (error "No URL under point")) - (if external - (funcall browse-url-secondary-browser-function url) + (let ((browse-url-browser-function + (if secondary + browse-url-secondary-browser-function + browse-url-browser-function))) (browse-url url)))) ;;;###autoload @@ -1806,8 +1811,10 @@ external browser instead of the default one." "Open URL using `browse-url'. If `current-prefix-arg' is non-nil, use `browse-url-secondary-browser-function' instead." - (if current-prefix-arg - (funcall browse-url-secondary-browser-function url) + (let ((browse-url-browser-function + (if current-prefix-arg + browse-url-secondary-browser-function + browse-url-browser-function))) (browse-url url))) (defun browse-url-button-copy () diff --git a/lisp/net/eww.el b/lisp/net/eww.el index fc7cf2a1710..fb53d067e4f 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -2257,7 +2257,8 @@ external browser." (setq url (or url (plist-get eww-data :url))) (if (eq 'external (browse-url--browser-kind browse-url-secondary-browser-function url)) - (funcall browse-url-secondary-browser-function url) + (let ((browse-url-browser-function browse-url-secondary-browser-function)) + (browse-url url)) (browse-url-with-browser-kind 'external url))) (defun eww-remove-tracking (url) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index 7d8442c64d2..246528a7176 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -34,8 +34,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'mail-utils) (defgroup pop3 nil diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index c669d45a0bd..c067c2472bb 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -1338,21 +1338,11 @@ The list is updated automatically by `defun-rcirc-command'.") (interactive "zCoding system for incoming messages: ") (setq-local rcirc-decode-coding-system coding-system)) -(define-obsolete-function-alias - 'rcirc-set-decode-coding-system - 'set-rcirc-decode-coding-system - "28.1") - (defun rcirc-set-encode-coding-system (coding-system) "Set the encode CODING-SYSTEM used in this channel." (interactive "zCoding system for outgoing messages: ") (setq-local rcirc-encode-coding-system coding-system)) -(define-obsolete-function-alias - 'rcirc-set-encode-coding-system - 'set-rcirc-encode-coding-system - "28.1") - (defun rcirc-format (pre &optional replace) "Insert markup formatting PRE. PRE and \"^O\" (ASCII #x0f) will either be inserted around the @@ -1577,7 +1567,8 @@ If ALL is non-nil, update prompts in all IRC buffers." (with-rcirc-process-buffer process (mapcar 'cdr rcirc-buffer-alist)))) (rcirc-process-list)) - (let ((inhibit-read-only t) + (let ((buffer-undo-list t) + (inhibit-read-only t) (prompt (or rcirc-prompt ""))) (mapc (lambda (rep) (setq prompt @@ -1729,6 +1720,8 @@ Create the buffer if it doesn't exist." rcirc-prompt-end-marker (point)))) (dolist (line (split-string input "\n")) (rcirc-process-input-line line)) + ;; reset undo data after input is sent + (setq buffer-undo-list nil) ;; add to input-ring (save-excursion (ring-insert rcirc-input-ring input) @@ -2014,6 +2007,30 @@ PROCESS is the process object for the current connection." (> last-activity-line 0)) (- rcirc-current-line last-activity-line)))) +;; Copied from lisp/erc/erc.el (erc-update-undo-list) +(defun rcirc-update-undo-list (shift) + "Translate buffer positions in buffer-undo-list by SHIFT." + (unless (or (zerop shift) (atom buffer-undo-list)) + (let ((list buffer-undo-list) elt) + (while list + (setq elt (car list)) + (cond ((integerp elt) ; POSITION + (incf (car list) shift)) + ((or (atom elt) ; nil, EXTENT + ;; (eq t (car elt)) ; (t . TIME) + (markerp (car elt))) ; (MARKER . DISTANCE) + nil) + ((integerp (car elt)) ; (BEGIN . END) + (incf (car elt) shift) + (incf (cdr elt) shift)) + ((stringp (car elt)) ; (TEXT . POSITION) + (incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) + ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) + (let ((cons (nthcdr 3 elt))) + (incf (car cons) shift) + (incf (cdr cons) shift)))) + (setq list (cdr list)))))) + (defvar rcirc-markup-text-functions '(rcirc-markup-attributes rcirc-color-attributes @@ -2042,13 +2059,16 @@ connection." rcirc-ignore-list)) ;; do not ignore if we sent the message (not (string= sender (rcirc-nick process)))) - (let* ((buffer (rcirc-target-buffer process sender response target text)) + (let* (preinsert-prompt-end-position + (buffer (rcirc-target-buffer process sender response target text)) (time (if-let* ((time (rcirc-get-tag "time"))) (parse-iso8601-time-string time t) (current-time))) (inhibit-read-only t)) (with-current-buffer buffer - (let ((moving (= (point) rcirc-prompt-end-marker)) + (setq preinsert-prompt-end-position (marker-position rcirc-prompt-end-marker)) + (let ((buffer-undo-list t) + (moving (= (point) rcirc-prompt-end-marker)) (old-point (point-marker))) (setq text (decode-coding-string text rcirc-decode-coding-system)) @@ -2154,9 +2174,16 @@ connection." 0) (recenter -1))))))) - ;; flush undo (can we do something smarter here?) - (buffer-disable-undo) - (buffer-enable-undo) + ;; as text is inserted before the prompt - moving it further + ;; away - the undo data for user input beyond the prompt is + ;; invalidated + ;; + ;; attempt to fix the undo data by shifting the undo positions + ;; in the undo list by the prompt's "drift", i.e. the delta + ;; between the current and previous (pre-insertion) prompt + ;; position + (rcirc-update-undo-list (- rcirc-prompt-end-marker + preinsert-prompt-end-position)) ;; record mode line activity (when (and activity diff --git a/lisp/net/sasl-scram-sha256.el b/lisp/net/sasl-scram-sha256.el index 4df500092b6..844425bdb43 100644 --- a/lisp/net/sasl-scram-sha256.el +++ b/lisp/net/sasl-scram-sha256.el @@ -26,7 +26,6 @@ ;;; Code: -(require 'cl-lib) (require 'sasl) (require 'hex-util) (require 'rfc2104) diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index 45f600a480d..68bf2c418ec 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -27,7 +27,6 @@ ;;; Code: (require 'color) -(eval-when-compile (require 'cl-lib)) (defgroup shr-color nil "Simple HTML Renderer colors." diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 9a620af4515..bf78cce13bf 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1097,9 +1097,9 @@ When `shr-fill-text' is nil, only indent." (mouse-set-point ev) (shr-browse-url nil nil t)) -(defun shr-browse-url (&optional external mouse-event new-window) +(defun shr-browse-url (&optional secondary mouse-event new-window) "Browse the URL at point using `browse-url'. -If EXTERNAL is non-nil (interactively, the prefix argument), browse +If SECONDARY is non-nil (interactively, the prefix argument), browse the URL using `browse-url-secondary-browser-function'. If this function is invoked by a mouse click, it will browse the URL at the position of the click. Optional argument MOUSE-EVENT describes @@ -1110,8 +1110,9 @@ the mouse click event." (cond ((not url) (message "No link under point")) - (external - (funcall browse-url-secondary-browser-function url) + (secondary + (let ((browse-url-browser-function browse-url-secondary-browser-function)) + (browse-url url)) (shr--blink-link)) (t (browse-url url (xor new-window browse-url-new-window-flag)))))) diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 1f2ac56d418..54bccc179aa 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -48,6 +48,13 @@ "Sieve." :group 'languages) +(defcustom sieve-indent-offset 2 + "Indentation offset for Sieve mode." + :type 'integer + :group 'sieve + :safe #'integerp + :version "31.1") + (defcustom sieve-mode-hook nil "Hook run in sieve mode buffers." :type 'hook) @@ -180,7 +187,7 @@ Turning on Sieve mode runs `sieve-mode-hook'." (let ((depth (car (syntax-ppss)))) (when (looking-at "[ \t]*}") (setq depth (1- depth))) - (indent-line-to (* 2 depth)))) + (indent-line-to (* sieve-indent-offset depth)))) ;; Skip to the end of the indentation if at the beginning of the ;; line. (when (save-excursion diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index a745633c24b..5bcb92536fd 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -882,8 +882,8 @@ will be used." ;; is deleted. The temporary file will exist ;; until the process is deleted. (when (bufferp stderr) + (tramp-taint-remote-process-buffer stderr) (ignore-errors - (tramp-taint-remote-process-buffer stderr) (with-current-buffer stderr (insert-file-contents-literally remote-tmpstderr 'visit))) @@ -1227,11 +1227,10 @@ connection if a previous connection has died for some reason." 'tramp-adb-connection-local-default-ps-profile tramp-adb-connection-local-default-ps-variables) -(with-eval-after-load 'shell - (connection-local-set-profiles - `(:application tramp :protocol ,tramp-adb-method) - 'tramp-adb-connection-local-default-shell-profile - 'tramp-adb-connection-local-default-ps-profile)) +(connection-local-set-profiles + `(:application tramp :protocol ,tramp-adb-method) + 'tramp-adb-connection-local-default-shell-profile + 'tramp-adb-connection-local-default-ps-profile) ;; `shell-mode' tries to open remote files like "/adb::~/.history". ;; This fails, because the tilde cannot be expanded. Tell diff --git a/lisp/net/tramp-androidsu.el b/lisp/net/tramp-androidsu.el index d3e528e8ce7..f15c5587651 100644 --- a/lisp/net/tramp-androidsu.el +++ b/lisp/net/tramp-androidsu.el @@ -529,13 +529,9 @@ arguments to pass to the OPERATION." (connection-local-set-profiles `(:application tramp :protocol ,tramp-androidsu-method) - 'tramp-androidsu-connection-local-default-profile) - -(with-eval-after-load 'shell - (connection-local-set-profiles - `(:application tramp :protocol ,tramp-androidsu-method) - 'tramp-adb-connection-local-default-shell-profile - 'tramp-adb-connection-local-default-ps-profile)) + 'tramp-androidsu-connection-local-default-profile + 'tramp-adb-connection-local-default-shell-profile + 'tramp-adb-connection-local-default-ps-profile) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index bb9179630cb..1fc3fb3aeae 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -202,11 +202,6 @@ Return DEFAULT if not set." (set var (1+ val)))) value))) -(add-hook 'tramp-cache-unload-hook - (lambda () - (dolist (var (all-completions "tramp-cache-get-count-" obarray)) - (unintern var obarray)))) - ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. @@ -229,8 +224,9 @@ Return VALUE." (add-hook 'tramp-cache-unload-hook (lambda () - (dolist (var (all-completions "tramp-cache-set-count-" obarray)) - (unintern var obarray)))) + (dolist (var (apropos-internal + (rx bos "tramp-cache-" (| "get" "set") "-count-"))) + (unintern var nil)))) ;;;###tramp-autoload (defun tramp-file-property-p (key file property) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 84c1c7ea7f4..95e1c5ecad8 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -78,8 +78,7 @@ SYNTAX can be one of the symbols `default' (default), ((not (assoc method tramp-methods)))) method)) ;; All method enabling functions. - (mapcar - #'intern (all-completions "tramp-enable-" obarray #'functionp)))))) + (apropos-internal (rx bos "tramp-enable-") #'functionp))))) (when-let* (((not (assoc method tramp-methods))) (fn (intern (format "tramp-enable-%s-method" method))) @@ -839,7 +838,7 @@ This is needed if there are compatibility problems." (and x (boundp x) (not (get x 'tramp-suppress-trace)) (cons x 'tramp-reporter-dump-variable))) (append - (mapcar #'intern (all-completions "tramp-" obarray #'boundp)) + (apropos-internal (rx bos "tramp-") #'boundp) ;; Non-Tramp variables of interest. '(shell-prompt-pattern backup-by-copying diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index c9a728e2be1..f975457d4df 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -229,8 +229,8 @@ value is the default binding of the variable." (cdr result) ,variable))))) -(dolist (elt (all-completions "tramp-compat-" obarray #'functionp)) - (function-put (intern elt) 'tramp-suppress-trace t)) +(dolist (elt (apropos-internal (rx bos "tramp-compat-") #'functionp)) + (function-put elt 'tramp-suppress-trace t)) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 0183960d7f4..83351952c6c 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -367,10 +367,6 @@ It's value must be a Tramp user option, indexed in the Tramp manual via 'tramp-connection-local-default-system-profile tramp-connection-local-default-system-variables) -(connection-local-set-profiles - '(:application tramp) - 'tramp-connection-local-default-system-profile) - (defconst tramp-connection-local-default-shell-variables '((shell-file-name . "/bin/sh") (shell-command-switch . "-c")) @@ -380,10 +376,10 @@ It's value must be a Tramp user option, indexed in the Tramp manual via 'tramp-connection-local-default-shell-profile tramp-connection-local-default-shell-variables) -(with-eval-after-load 'shell - (connection-local-set-profiles - '(:application tramp) - 'tramp-connection-local-default-shell-profile)) +(connection-local-set-profiles + '(:application tramp) + 'tramp-connection-local-default-system-profile + 'tramp-connection-local-default-shell-profile) ;; Tested with FreeBSD 12.2. (defconst tramp-bsd-process-attributes-ps-args @@ -586,12 +582,10 @@ See `tramp-process-attributes-ps-format'.") 'tramp-connection-local-darwin-ps-profile) ;; ... Add other system types here. ))) - (connection-local-set-profiles - `(:application tramp :machine ,(system-name)) - local-profile) - (connection-local-set-profiles - '(:application tramp :machine "localhost") - local-profile)) + (dolist (local-host tramp-local-host-names) + (connection-local-set-profiles + `(:application tramp :machine ,local-host) + local-profile))) ;; Set connection-local variables for buffers visiting a file. diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el index fe7758bdb08..7b405061ba8 100644 --- a/lisp/net/tramp-message.el +++ b/lisp/net/tramp-message.el @@ -240,8 +240,10 @@ ARGUMENTS to actually emit the message (if applicable)." (dolist (elt (append - (mapcar - #'intern (all-completions "tramp-" obarray #'functionp)) + (apropos-internal (rx bos "tramp-") #'functionp) + (apropos-internal (rx bos "tramp-") #'macrop) + (apropos-internal + (rx bos "with-" (? "parsed-") "tramp-") #'macrop) tramp-trace-functions)) (unless (get elt 'tramp-suppress-trace) (trace-function-background elt (tramp-trace-buffer-name vec))))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index a40803a53f1..97b72ba00ad 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2098,66 +2098,67 @@ ID-FORMAT valid values are `string' and `integer'." "Like `copy-directory' for Tramp files." (tramp-skeleton-copy-directory dirname newname keep-date parents copy-contents - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname)) - target) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (cond - ((and copy-directory-create-symlink - (setq target (file-symlink-p dirname)) - (tramp-equal-remote dirname newname)) - (make-symbolic-link - target - (if (directory-name-p newname) - (concat newname (file-name-nondirectory dirname)) newname) - t)) + (let* ((v1 (and (tramp-tramp-file-p dirname) + (tramp-dissect-file-name dirname))) + (v2 (and (tramp-tramp-file-p newname) + (tramp-dissect-file-name newname))) + (v (or v1 v2)) + target) + (cond + ((and copy-directory-create-symlink + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t)) - ;; Shortcut: if method, host, user are the same for both - ;; files, we invoke `cp' on the remote host directly. - ((and (not copy-contents) - (tramp-equal-remote dirname newname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (tramp-do-copy-or-rename-file-directly - 'copy dirname newname - 'ok-if-already-exists keep-date 'preserve-uid-gid)) + ;; Shortcut: if method, host, user are the same for both files, + ;; we invoke `cp' on the remote host directly. + ((and (not copy-contents) + (tramp-equal-remote dirname newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (tramp-do-copy-or-rename-file-directly + 'copy dirname newname + 'ok-if-already-exists keep-date 'preserve-uid-gid)) - ;; scp or rsync DTRT. - ((and (not copy-contents) - (tramp-get-method-parameter v 'tramp-copy-recursive) - ;; When DIRNAME and NEWNAME are remote, they must have - ;; the same method. - (or (null t1) (null t2) - (string-equal - (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method (tramp-dissect-file-name newname))))) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name (file-name-nondirectory dirname) newname))) - (unless (file-directory-p (file-name-directory newname)) - (make-directory (file-name-directory newname) parents)) - (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname 'ok-if-already-exists keep-date)) + ;; scp or rsync DTRT. + ((and (not copy-contents) + (tramp-get-method-parameter v 'tramp-copy-recursive) + ;; When DIRNAME and NEWNAME are remote, they must have + ;; the same method. None of them must be multi-hop. + (or (and (null v1) (tramp-method-out-of-band-p v2 0)) + (and (null v2) (tramp-method-out-of-band-p v1 0)) + (and v1 v2 + (tramp-method-out-of-band-p v1 0) + (tramp-method-out-of-band-p v2 0) + (string-equal + (tramp-file-name-method v1) + (tramp-file-name-method v2))))) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name (file-name-nondirectory dirname) newname))) + (unless (file-directory-p (file-name-directory newname)) + (make-directory (file-name-directory newname) parents)) + (tramp-do-copy-or-rename-file-out-of-band + 'copy dirname newname 'ok-if-already-exists keep-date)) - ;; We must do it file-wise. - (t (tramp-run-real-handler - #'copy-directory - (list dirname newname keep-date parents copy-contents)))) - - ;; NEWNAME has wrong cached values. - (when t2 - (with-parsed-tramp-file-name (expand-file-name newname) nil - (tramp-flush-file-properties v localname))))))) + ;; We must do it file-wise. + (t (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents))))))) (defun tramp-sh-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -5679,7 +5680,11 @@ raises an error." (and ;; It shall be an out-of-band method. (tramp-get-method-parameter vec 'tramp-copy-program) - ;; There must be a size, otherwise the file doesn't exist. + ;; There shouldn't be a multi-hop. + (or (not (tramp-multi-hop-p vec)) + (null (cdr (tramp-compute-multi-hops vec)))) + ;; There must be a SIZE, otherwise the file doesn't exist. A zero + ;; SIZE is used for directories. (numberp size) ;; Either the file size is large enough, or (in rare cases) there ;; does not exist a remote encoding. @@ -5823,9 +5828,10 @@ Nonexistent directories are removed from spec." (or (catch 'ls-found (dolist (cmd - ;; Prefer GNU ls on *BSD and macOS. + ;; Prefer GNU ls on *BSD and macOS. See also + ;; Bug#80075 for Linux. (if (tramp-check-remote-uname vec tramp-bsd-unames) - '("gls" "ls" "gnuls") '("ls" "gnuls" "gls"))) + '("gls" "ls" "gnuls") '("gnuls" "ls" "gls"))) (let ((dl (tramp-get-remote-path vec)) result) (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) @@ -5966,11 +5972,14 @@ Nonexistent directories are removed from spec." "Determine remote `readlink' command." (with-tramp-connection-property vec "readlink" (tramp-message vec 5 "Finding a suitable `readlink' command") - (when-let* ((result (tramp-find-executable - vec "readlink" (tramp-get-remote-path vec))) - ((tramp-send-command-and-check - vec (format "%s --canonicalize-missing /" result)))) - result))) + ;; See Bug#80075. + (catch 'readlink-found + (dolist (cmd '("gnureadlink" "readlink")) + (when-let* ((result (tramp-find-executable + vec cmd (tramp-get-remote-path vec))) + ((tramp-send-command-and-check + vec (format "%s --canonicalize-missing /" result)))) + (throw 'readlink-found result)))))) (defun tramp-get-remote-touch (vec) "Determine remote `touch' command." diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 076f18bb391..b87eee0fcce 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -577,12 +577,7 @@ arguments to pass to the OPERATION." ;; Set the mode. (unless keep-date - (set-file-modes newname (tramp-default-file-modes dirname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname)))) + (set-file-modes newname (tramp-default-file-modes dirname)))) ;; We must do it file-wise. (t @@ -2235,10 +2230,6 @@ SHARE will be passed to the call of `tramp-smb-get-localname'." 'tramp-smb-connection-local-default-system-profile tramp-smb-connection-local-default-system-variables) -(connection-local-set-profiles - `(:application tramp :protocol ,tramp-smb-method) - 'tramp-smb-connection-local-default-system-profile) - ;; (defconst tramp-smb-connection-local-bash-variables ;; '((explicit-shell-file-name . "bash") ;; (explicit-bash-args . ("--norc" "--noediting" "-i")) @@ -2262,12 +2253,6 @@ SHARE will be passed to the call of `tramp-smb-get-localname'." 'tramp-smb-connection-local-powershell-profile tramp-smb-connection-local-powershell-variables) -(defun tramp-smb-shell-prompt () - "Set `comint-prompt-regexp' to a proper value." - ;; Used for remote `shell-mode' buffers. - (when (tramp-smb-file-name-p default-directory) - (setq-local comint-prompt-regexp tramp-smb-prompt))) - ;; (defconst tramp-smb-connection-local-cmd-variables ;; '((explicit-shell-file-name . "cmd") ;; (explicit-cmd-args . ("/Q")) @@ -2279,10 +2264,18 @@ SHARE will be passed to the call of `tramp-smb-get-localname'." ;; 'tramp-smb-connection-local-cmd-profile ;; tramp-smb-connection-local-cmd-variables) +(connection-local-set-profiles + `(:application tramp :protocol ,tramp-smb-method) + 'tramp-smb-connection-local-default-system-profile + 'tramp-smb-connection-local-powershell-profile) + +(defun tramp-smb-shell-prompt () + "Set `comint-prompt-regexp' to a proper value." + ;; Used for remote `shell-mode' buffers. + (when (tramp-smb-file-name-p default-directory) + (setq-local comint-prompt-regexp tramp-smb-prompt))) + (with-eval-after-load 'shell - (connection-local-set-profiles - `(:application tramp :protocol ,tramp-smb-method) - 'tramp-smb-connection-local-powershell-profile) (add-hook 'shell-mode-hook #'tramp-smb-shell-prompt) (add-hook 'tramp-smb-unload-hook diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index ebbe6df06a8..f57b572532a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -296,9 +296,8 @@ pair of the form (KEY VALUE). The following KEYs are defined: - \"%a\" adds the pseudo-terminal allocation argument \"-t\" in asynchronous processes, if the connection type is not `pipe'. - The existence of `tramp-login-args', combined with the - absence of `tramp-copy-args', is an indication that the - method is capable of multi-hops. + The existence of `tramp-login-args' is an indication that the method + is capable of multi-hops. * `tramp-async-args' When an asynchronous process is started, we know already that @@ -584,19 +583,21 @@ host runs a restricted shell, it shall be added to this list, too." :type '(repeat (regexp :tag "Host regexp")) :link '(info-link :tag "Tramp manual" "(tramp) Multi-hops")) +;;;###tramp-autoload +(defvar tramp-local-host-names + (list tramp-system-name "localhost" "127.0.0.1" "::1" + ;; Fedora. + "localhost4" "localhost6" + ;; Ubuntu. + "ip6-localhost" "ip6-loopback" + ;; OpenSUSE. + "ipv6-localhost" "ipv6-loopback") + "List of host names which are regarded as local host.") + ;;;###tramp-autoload (defcustom tramp-local-host-regexp - (rx bos - (| (literal tramp-system-name) - (| "localhost" "127.0.0.1" "::1" - ;; Fedora. - "localhost4" "localhost6" - ;; Ubuntu. - "ip6-localhost" "ip6-loopback" - ;; OpenSUSE. - "ipv6-localhost" "ipv6-loopback")) - eos) - "Host names which are regarded as local host. + (rx-to-string `(: bos (| . ,tramp-local-host-names) eos)) + "Regexp of host names which are regarded as local host. If the local host runs a chrooted environment, set this to nil." :version "30.1" :type '(choice (const :tag "Chrooted environment" nil) @@ -2137,7 +2138,7 @@ of `current-buffer'." "Execute BODY and return the result. In case of an error, raise a `file-missing' error if FILENAME does not exist, otherwise propagate the error." - (declare (indent 2) (debug (tramp-file-name-p form &rest body))) + (declare (indent 2) (debug t)) (let ((err (make-symbol "err"))) `(condition-case ,err (let (signal-hook-function) ,@body) @@ -2176,7 +2177,7 @@ Remaining args are Lisp expressions to be evaluated (inside an implicit If VAR is nil, then we bind `v' to the structure and `method', `user', `domain', `host', `port', `localname', `hop' to the components." - (declare (indent 2) (debug (form symbolp &rest body))) + (declare (indent 2) (debug t)) (let ((bindings (mapcar (lambda (elem) @@ -3585,7 +3586,7 @@ User is always nil." ;;; Skeleton macros for file name handler functions. (defmacro tramp-skeleton-copy-directory - (directory _newname &optional _keep-date _parents _copy-contents &rest body) + (directory newname &optional _keep-date _parents _copy-contents &rest body) "Skeleton for `tramp-*-handle-copy-directory'. BODY is the backend specific code." (declare (indent 5) (debug t)) @@ -3596,7 +3597,12 @@ BODY is the backend specific code." (unless (file-exists-p ,directory) (tramp-error (tramp-dissect-file-name ,directory) 'file-missing ,directory)) - ,@body)) + ,@body + + ;; NEWNAME has wrong cached values. + (when (tramp-tramp-file-p ,newname) + (with-parsed-tramp-file-name (expand-file-name ,newname) nil + (tramp-flush-file-properties v localname))))) (defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body) "Skeleton for `tramp-*-handle-delete-directory'. @@ -5148,7 +5154,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") "Whether the method of VEC is capable of multi-hops." (let ((tramp-verbose 0)) (and (tramp-sh-file-name-handler-p vec) - (not (tramp-get-method-parameter vec 'tramp-copy-program))))) + (tramp-get-method-parameter vec 'tramp-login-args)))) (defun tramp-add-hops (vec) "Add ad-hoc proxy definitions to `tramp-default-proxies-alist'." diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index f813fe869d4..b900ab377aa 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.8.1 +;; Version: 2.8.2-pre ;; Package-Requires: ((emacs "28.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.8.1" +(defconst tramp-version "2.8.2-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -76,7 +76,7 @@ ;; Check for Emacs version. (let ((x (if (not (string-version-lessp emacs-version "28.1")) "ok" - (format "Tramp 2.8.1 is not fit for %s" + (format "Tramp 2.8.2-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index b20af40091a..dbb532f691b 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -820,6 +820,7 @@ It is a vector of the form [ VELOCITY TIME SIGN ]." (end-of-buffer (message (error-message-string '(end-of-buffer))))))))) +;;;###autoload (defun pixel-scroll-interpolate-down () "Interpolate a scroll downwards by one page." (interactive) @@ -832,6 +833,7 @@ It is a vector of the form [ VELOCITY TIME SIGN ]." nil 1) (cua-scroll-up))) +;;;###autoload (defun pixel-scroll-interpolate-up () "Interpolate a scroll upwards by one page." (interactive) @@ -850,6 +852,8 @@ precisely, according to the turning of the mouse wheel." :keymap pixel-scroll-precision-mode-map (setq mwheel-coalesce-scroll-events (not pixel-scroll-precision-mode)) + ;; This works around some issues described in bug#65214. + ;; Ideally this would not be needed because it breaks some other things. (setq-default make-cursor-line-fully-visible (not pixel-scroll-precision-mode))) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index d90f65e1be1..d2e92d7da8b 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -954,7 +954,11 @@ The value nil as an element means to try the default directory." (string :tag "Directory")))) ;;;###autoload -(defcustom compile-command "make -k " +(defcustom compile-command + ;; Divide by less than 2 and round up to avoid using all processors on + ;; multi-core systems, but use at least one processor on a single-core + ;; system. + (format "make -k -j%d " (ceiling (num-processors) 1.5)) "Last shell command used to do a compilation; default for next compilation. Sometimes it is useful for files to supply local values for this variable. diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index aa165ae9ad3..6faf5a49da8 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -717,7 +717,11 @@ compilation and evaluation time conflicts." ((parent-is "arrow_function") parent-bol csharp-ts-mode-indent-offset) ((parent-is "parenthesized_expression") parent-bol csharp-ts-mode-indent-offset) ((parent-is "using_statement") parent-bol 0) - ((parent-is "lambda_expression") parent-bol 0)))) + ((parent-is "lambda_expression") parent-bol 0) + ((parent-is "try_statement") parent-bol 0) + ((parent-is "catch_filter_clause") parent-bol 0) + ((parent-is "preproc_if") parent-bol 0) + ((parent-is "preproc_region") parent-bol 0)))) (defvar csharp-ts-mode--keywords '("using" "namespace" "class" "if" "else" "throw" "new" "for" diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index b2dd76f0ea8..80099a26ee8 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -2,12 +2,12 @@ ;; Copyright (C) 2018-2026 Free Software Foundation, Inc. -;; Version: 1.19 +;; Version: 1.21 ;; Author: João Távora ;; Maintainer: João Távora ;; URL: https://github.com/joaotavora/eglot ;; Keywords: convenience, languages -;; Package-Requires: ((emacs "26.3") (eldoc "1.14.0") (external-completion "0.1") (flymake "1.4.2") (jsonrpc "1.0.26") (project "0.9.8") (seq "2.23") (xref "1.6.2")) +;; Package-Requires: ((emacs "26.3") (eldoc "1.14.0") (external-completion "0.1") (flymake "1.4.2") (jsonrpc "1.0.26") (project "0.11.2") (seq "2.23") (xref "1.6.2")) ;; This is a GNU ELPA :core package. Avoid adding functionality ;; that is not available in the version of Emacs recorded above or any @@ -238,7 +238,7 @@ automatically)." (defvar eglot-server-programs ;; FIXME: Maybe this info should be distributed into the major modes ;; themselves where they could set a buffer-local `eglot-server-program' - ;; instead of keeping this database centralized. + ;; which would allow deprecating this database. ;; FIXME: With `derived-mode-add-parents' in Emacs≥30, some of ;; those entries can be simplified, but we keep them for when ;; `eglot.el' is installed via GNU ELPA in an older Emacs. @@ -248,7 +248,8 @@ automatically)." (vimrc-mode . ("vim-language-server" "--stdio")) ((python-mode python-ts-mode) . ,(eglot-alternatives - '("pylsp" "pyls" ("basedpyright-langserver" "--stdio") + '(("rass" "python") + "pylsp" "pyls" ("basedpyright-langserver" "--stdio") ("pyright-langserver" "--stdio") ("pyrefly" "lsp") ("ty" "server") @@ -262,7 +263,9 @@ automatically)." (tsx-ts-mode :language-id "typescriptreact") (typescript-ts-mode :language-id "typescript") (typescript-mode :language-id "typescript")) - . ("typescript-language-server" "--stdio")) + . ,(eglot-alternatives + '(("rass ts") + ("typescript-language-server" "--stdio")))) ((bash-ts-mode sh-mode) . ("bash-language-server" "start")) ((php-mode phps-mode php-ts-mode) . ,(eglot-alternatives @@ -306,6 +309,7 @@ automatically)." ((latex-mode plain-tex-mode context-mode texinfo-mode bibtex-mode tex-mode) . ,(eglot-alternatives '("digestif" "texlab"))) (erlang-mode . ("erlang_ls" "--transport" "stdio")) + (wat-mode . ("wat_server")) ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio")) ((toml-ts-mode conf-toml-mode) . ("tombi" "lsp")) (nix-mode . ,(eglot-alternatives '("nil" "rnix-lsp" "nixd"))) @@ -492,25 +496,26 @@ the LSP connection. That can be done by `eglot-reconnect'." (const :tag "Pretty-printed lisp" lisp))))) :package-version '(Eglot . "1.17.30")) -(defcustom eglot-confirm-server-edits '((eglot-rename . nil) - (t . maybe-summary)) +(defcustom eglot-confirm-server-edits '((t . maybe-summary)) "Control if changes proposed by LSP should be confirmed with user. -If this variable's value is the symbol `diff', a diff buffer is -pops up, allowing the user to apply each change individually. If -the symbol `summary' or any other non-nil value, the user is -prompted in the minibuffer with aa short summary of changes. The -symbols `maybe-diff' and `maybe-summary' mean that the -confirmation is offered to the user only if the changes target -files visited in buffers. Finally, a nil value means all changes -are applied directly without any confirmation. +If this variable's value is the symbol `diff', a diff buffer pops +up, allowing the user to apply each change individually. If the +symbol `summary' or any other non-nil value, the user is prompted +in the minibuffer with a short summary of changes. The symbols +`maybe-diff' and `maybe-summary' mean that the confirmation is +offered to the user only if the changes target files not visited +in buffers. Finally, a nil value means all changes are applied +directly without any confirmation. -If this variable's value can also be an alist ((COMMAND . ACTION) -...) where COMMAND is a symbol designating a command, such as -`eglot-rename', `eglot-code-actions', -`eglot-code-action-quickfix', etc. ACTION is one of the symbols -described above. The value t for COMMAND is accepted and its -ACTION is the default value for commands not in the alist." +This variable's value can also be an alist ((KEY . ACTION) ...) +where KEY is either a symbol designating the invoked Emacs command +(such as `eglot-rename', `eglot-code-actions', +`eglot-code-action-quickfix', etc.), or a list of file operation +kinds (`create', `rename', `delete') contained in the edit. +ACTION is one of the symbols described above. The value t for +KEY is accepted and its ACTION is the default value for commands +or file operation kinds not in the alist." :type (let ((basic-choices '((const :tag "Use diff" diff) (const :tag "Summarize and prompt" summary) @@ -518,8 +523,9 @@ ACTION is the default value for commands not in the alist." (const :tag "Maybe summarize and prompt" maybe-summary) (const :tag "Don't confirm" nil)))) `(choice ,@basic-choices - (alist :tag "Per-command alist" + (alist :tag "Per-command or per-kind alist" :key-type (choice (function :tag "Command") + (repeat :tag "File operation kinds" symbol) (const :tag "Default" t)) :value-type (choice . ,basic-choices)))) :package-version '(Eglot . "1.17.30")) @@ -579,7 +585,7 @@ under cursor." (const :tag "Call hierarchies" :callHierarchyProvider) (const :tag "On-demand \"pull\" diagnostics" :diagnosticProvider))) -(defcustom eglot-advertise-cancellation nil +(defcustom eglot-advertise-cancellation t "If non-nil, Eglot attempts to inform server of canceled requests. This is done by sending an additional '$/cancelRequest' notification every time Eglot decides to forget a request. The effect of this @@ -778,7 +784,10 @@ This can be useful when using docker to run a language server.") (HierarchyItem (:name :kind) (:tags :detail :uri :range :selectionRange :data)) (CallHierarchyIncomingCall (:from :fromRanges) ()) - (CallHierarchyOutgoingCall (:to :fromRanges) ())) + (CallHierarchyOutgoingCall (:to :fromRanges) ()) + (CreateFile (:kind :uri) (:options)) + (RenameFile (:kind :oldUri :newUri) (:options)) + (DeleteFile (:kind :uri) (:options))) "Alist (INTERFACE-NAME . INTERFACE) of known external LSP interfaces. INTERFACE-NAME is a symbol designated by the spec as @@ -1006,7 +1015,8 @@ treated as in `eglot--dbind'." (:method (server command arguments) (eglot--request server :workspace/executeCommand - `(:command ,(format "%s" command) :arguments ,arguments)))) + `(:command ,(format "%s" command) :arguments ,arguments) + :timeout nil))) (cl-defgeneric eglot-execute (server action) "Ask SERVER to execute ACTION. @@ -1020,7 +1030,7 @@ object." (cl-remf action :title) (eglot-execute server action)) (((ExecuteCommandParams)) - (eglot--request server :workspace/executeCommand action)) + (eglot--request server :workspace/executeCommand action :timeout nil)) (((CodeAction) edit command data) (if (and (null edit) (null command) data (eglot-server-capable :codeActionProvider :resolveProvider)) @@ -1059,7 +1069,9 @@ object." :workspace (list :applyEdit t :executeCommand `(:dynamicRegistration :json-false) - :workspaceEdit `(:documentChanges t) + :workspaceEdit `(:documentChanges t + :resourceOperations ["create" "delete" "rename"] + :failureHandling "abort") :didChangeWatchedFiles `(:dynamicRegistration ,(if (eglot--trampish-p s) :json-false t) @@ -1127,9 +1139,10 @@ object." :isPreferredSupport t) :formatting `(:dynamicRegistration :json-false) :rangeFormatting `(:dynamicRegistration :json-false) - :rename `(:dynamicRegistration :json-false) + :rename `(:dynamicRegistration :json-false + :prepareSupport t) :semanticTokens `(:dynamicRegistration :json-false - :requests '(:full (:delta t)) + :requests (:full (:delta t)) :overlappingTokenSupport t :multilineTokenSupport t :tokenTypes [,@eglot-semantic-token-types] @@ -1148,7 +1161,8 @@ object." :tagSupport `(:valueSet [,@(mapcar - #'car eglot--tag-faces)]))) + #'car eglot--tag-faces)])) + :$streamingDiagnostics `(:dynamicRegistration :json-false)) :window `(:showDocument (:support t) :showMessage (:messageActionItem (:additionalPropertiesSupport t)) @@ -1276,6 +1290,61 @@ If optional MARKERS, make markers instead." (list :start (eglot--pos-to-lsp-position from) :end (eglot--pos-to-lsp-position to))) +(defvar eglot-move-to-linepos-function) +(cl-defun eglot--call-with-ranged (objs key fn &aux (curline 0)) + (unless key + (setq key (lambda (o) (plist-get o :range)))) + (cl-flet ((moveit (line col) + (forward-line (- line curline)) + (setq curline line) + (unless (eobp) + (unless (wholenump col) (setq col 0)) + (funcall eglot-move-to-linepos-function col)) + (point))) + (eglot--widening + (goto-char (point-min)) + (cl-loop + with pairs = (if key + (mapcar (lambda (obj) (cons obj (funcall key obj))) + objs) + (mapcar (lambda (range) (cons range range)) + objs)) + with sorted = + (sort pairs + (lambda (p1 p2) + (< (plist-get (plist-get (cdr p1) :start) :line) + (plist-get (plist-get (cdr p2) :start) :line)))) + for (object . range) in sorted + for spos = (plist-get range :start) + for epos = (plist-get range :end) + for sline = (plist-get spos :line) + for scol = (plist-get spos :character) + for eline = (plist-get epos :line) + for ecol = (plist-get epos :character) + collect (funcall fn object (cons (moveit sline scol) + (moveit eline ecol))))))) + +(cl-defmacro eglot--collecting-ranged ((object-sym region-sym + objects + &optional key) + &rest body) + "Iterate over OBJECTS, binding each element and its region. +For each element in OBJECTS, bind OBJECT-SYM to the element and +REGION-SYM to its computed Emacs region (a cons of buffer positions). +Evaluate BODY and collect the result into a list. Return that list. + +KEY, if non-nil, should be a function to extract the LSP range from each +element. If nil, elements are assumed to be plists with `:range' keys. + +This macro uses optimized incremental navigation instead of repeatedly +calling `eglot-range-region', providing significant performance benefits +when processing many ranges." + (declare (indent 1) (debug t)) + `(eglot--call-with-ranged + ,objects + ,key + (lambda (,object-sym ,region-sym) ,@body))) + (defun eglot-server-capable (&rest feats) "Determine if current server is capable of FEATS." (unless (cl-some (lambda (feat) @@ -1309,7 +1378,7 @@ If optional MARKERS, make markers instead." (cl-defmethod initialize-instance :before ((_server eglot-lsp-server) &optional args) (cl-remf args :initializationOptions)) -(defvar-local eglot--docver 0 +(defvar-local eglot--docver -1 "LSP document version. Bumped on `eglot--after-change'.") (defvar eglot--servers-by-project (make-hash-table :test #'equal) @@ -1871,6 +1940,14 @@ in project `%s'." "Message out with FORMAT with ARGS." (message "[eglot] %s" (apply #'eglot--format format args))) +(defun eglot--format-server-message (_server type format &rest args) + "Format SERVER-originated message with FORMAT with ARGS. +TYPE is a number indicating the message severity." + (concat + (propertize "[eglot] " + 'face (if (or (not type) (<= type 1)) 'error)) + (apply #'eglot--format format args))) + (defun eglot--warn (format &rest args) "Warning message with FORMAT and ARGS." (apply #'eglot--message (concat "(warning) " format) args) @@ -1899,15 +1976,22 @@ in project `%s'." "Like `jsonrpc-request', but for Eglot LSP requests. Unless IMMEDIATE, send pending changes before making request." (unless immediate (eglot--signal-textDocument/didChange)) - (jsonrpc-request server method params - :timeout timeout - :cancel-on-input - (cond ((and cancel-on-input - eglot-advertise-cancellation) - (lambda (id) - (jsonrpc-notify server '$/cancelRequest `(:id ,id)))) - (cancel-on-input)) - :cancel-on-input-retval cancel-on-input-retval)) + (cl-flet ((cancel (id) + (jsonrpc-notify server '$/cancelRequest `(:id ,id)))) + (condition-case oops + (jsonrpc-request server method params + :timeout timeout + :cancel-on-input + (if (and cancel-on-input eglot-advertise-cancellation) + #'cancel + cancel-on-input) + :cancel-on-quit + (and eglot-advertise-cancellation #'cancel) + :cancel-on-input-retval cancel-on-input-retval) + (jsonrpc-error + (let* ((data (cddr oops)) (ec (alist-get 'jsonrpc-error-code data))) + (if (zerop ec) (eglot--message (alist-get 'jsonrpc-error-message data)) + (signal 'jsonrpc-error (cdr oops)))))))) (defvar-local eglot--inflight-async-requests nil "An plist of symbols to lists of JSONRPC ids. @@ -1940,31 +2024,37 @@ according to `eglot-advertise-cancellation'.") (timeout-fn nil timeout-fn-supplied-p) (timeout nil timeout-supplied-p) hint - &aux moreargs) + &aux moreargs + id (buf (current-buffer))) "Like `jsonrpc-async-request', but for Eglot LSP requests. +SUCCESS-FN, ERROR-FN and TIMEOUT-FN run in buffer of call site. HINT argument is a symbol passed as DEFERRED to `jsonrpc-async-request' and also used as a hint of the request cancellation mechanism (see `eglot-advertise-cancellation')." - (cl-labels ((clearing-fn (fn) - (lambda (&rest args) - (when fn (apply fn args)) - (cl-remf eglot--inflight-async-requests hint)))) + (cl-labels + ((clearing-fn (fn) + (lambda (&rest args) + (eglot--when-live-buffer buf + (when (and + fn (memq id (cl-getf eglot--inflight-async-requests hint))) + (apply fn args)) + (cl-remf eglot--inflight-async-requests hint))))) (eglot--cancel-inflight-async-requests (list hint)) (when timeout-supplied-p (setq moreargs (nconc `(:timeout ,timeout) moreargs))) (when hint (setq moreargs (nconc `(:deferred ,hint) moreargs))) - (let ((id - (car (apply #'jsonrpc-async-request - server method params - :success-fn (clearing-fn success-fn) - :error-fn (clearing-fn error-fn) - :timeout-fn (clearing-fn timeout-fn) - moreargs)))) - (when (and hint eglot-advertise-cancellation) - (push id - (plist-get eglot--inflight-async-requests hint))) - id))) + (setq id + (car (apply #'jsonrpc-async-request + server method params + :success-fn (clearing-fn success-fn) + :error-fn (clearing-fn error-fn) + :timeout-fn (clearing-fn timeout-fn) + moreargs))) + (when (and hint eglot-advertise-cancellation) + (push id + (plist-get eglot--inflight-async-requests hint))) + id)) (cl-defun eglot--delete-overlays (&optional (prop 'eglot--overlays)) (eglot--widening @@ -2113,21 +2203,22 @@ MARKUP is either an LSP MarkedString or MarkupContent object." (setq-local markdown-fontify-code-blocks-natively t) (insert string) (let ((inhibit-message t) - (message-log-max nil) - match) + (message-log-max nil)) (ignore-errors (delay-mode-hooks (funcall render-mode))) (font-lock-ensure) (goto-char (point-min)) (let ((inhibit-read-only t)) - (when (fboundp 'text-property-search-forward) - ;; If `render-mode' is `gfm-view-mode', the `invisible' - ;; regions are set to `markdown-markup'. Set them to 't' - ;; instead, since this has actual meaning in the "*eldoc*" - ;; buffer where we're taking this string (#bug79552). - (while (setq match (text-property-search-forward 'invisible)) - (put-text-property (prop-match-beginning match) - (prop-match-end match) - 'invisible t)))) + ;; If `render-mode' is `gfm-view-mode', the `invisible' + ;; regions are set to `markdown-markup'. Set them to 't' + ;; instead, since this has actual meaning in the "*eldoc*" + ;; buffer where we're taking this string (#bug79552). + (cl-loop for from = (point) then to + while (< from (point-max)) + for inv = (get-text-property from 'invisible) + for to = (or (next-single-property-change from 'invisible) + (point-max)) + when inv + do (put-text-property from to 'invisible t))) (string-trim (buffer-string)))))) (defun eglot--read-server (prompt &optional dont-if-just-the-one) @@ -2224,15 +2315,24 @@ Use `eglot-managed-p' to determine if current buffer is managed.") (defvar eglot--highlights nil "Overlays for `eglot-highlight-eldoc-function'.") (defvar-local eglot--pulled-diagnostics nil - "A list (DIAGNOSTICS RESULT-ID) \"pulled\" for current buffer. -DIAGNOSTICS is a list of Flymake diagnostics objects. RESULT-ID -identifies this diagnostic result as is used for incremental updates.") + "A list (DIAGNOSTICS VERSION RESULT-ID) \"pulled\" for current buffer. +DIAGNOSTICS is a sequence of LSP or Flymake diagnostics objects. +RESULT-ID identifies this diagnostic result as is used for incremental +updates.") (defvar-local eglot--pushed-diagnostics nil "A list (DIAGNOSTICS VERSION) \"pushed\" for current buffer. -DIAGNOSTICS is a list of Flymake diagnostics objects. VERSION is the -LSP Document version reported for DIAGNOSTICS (comparable to -`eglot--docver') or nil if server didn't bother.") +DIAGNOSTICS is a sequence of LSP or Flymake diagnostics objects. +VERSION is the LSP Document version reported for DIAGNOSTICS (comparable +to `eglot--docver') or nil if server didn't bother.") + +(defvar-local eglot--streamed-diagnostics nil + "A (VERSION MAP PREV-MAP) description of \"streamed\" diagnostics. +MAP and PREV-MAP are alists of (TOKEN . DIAGS) entries. DIAGS is a +sequence of LSP/Flymake diagnostics objects. TOKEN identifies the +source of a partial report. VERSION is the LSP Document version +reported for diagnostics in MAP. PREV-MAP contains the diagnostics of +the previous reports for TOKEN.") (defvar-local eglot--suggestion-overlay (make-overlay 0 0) "Overlay for `eglot-code-action-suggestion'.") @@ -2273,8 +2373,9 @@ LSP Document version reported for DIAGNOSTICS (comparable to (eglot--setq-saving company-tooltip-align-annotations t) (eglot--setq-saving eldoc-documentation-strategy #'eldoc-documentation-compose) - (unless (eglot--stay-out-of-p 'imenu) - (add-function :before-until (local 'imenu-create-index-function) + (unless (or (eglot--stay-out-of-p 'imenu) + (not (eglot-server-capable :documentSymbolProvider))) + (add-function :override (local 'imenu-create-index-function) #'eglot-imenu)) (unless (eglot--stay-out-of-p 'flymake) (flymake-mode 1)) (unless (eglot--stay-out-of-p 'eldoc) @@ -2286,6 +2387,7 @@ LSP Document version reported for DIAGNOSTICS (comparable to (eldoc-mode 1)) (cl-pushnew (current-buffer) (eglot--managed-buffers (eglot-current-server)))) (t + (setq eglot--docver -1) (eglot-inlay-hints-mode -1) (eglot-semantic-tokens-mode -1) (eglot--delete-overlays 'eglot--overlay) @@ -2312,11 +2414,8 @@ LSP Document version reported for DIAGNOSTICS (comparable to (cl-loop for (var . saved-binding) in eglot--saved-bindings do (set (make-local-variable var) saved-binding)) (remove-function (local 'imenu-create-index-function) #'eglot-imenu) - (when eglot--flymake-report-fn - (setq eglot--pulled-diagnostics nil - eglot--pushed-diagnostics nil) - (eglot--flymake-report) - (setq eglot--flymake-report-fn nil)) + (eglot--flymake-reset) + (setq eglot--flymake-report-fn nil) (run-hooks 'eglot-managed-mode-hook) (let ((server eglot--cached-server)) (setq eglot--cached-server nil) @@ -2326,7 +2425,7 @@ LSP Document version reported for DIAGNOSTICS (comparable to (when (and eglot-autoshutdown (null (eglot--managed-buffers server)) ;; Don't shutdown if up again soon. - (with-no-warnings (not revert-buffer-in-progress-p))) + (not (eglot--revert-in-progress-p))) (eglot-shutdown server))))))) (defun eglot--managed-mode-off () @@ -2361,6 +2460,9 @@ LSP Document version reported for DIAGNOSTICS (comparable to (when eglot-semantic-tokens-mode (eglot-semantic-tokens-mode)))) +(defun eglot--revert-in-progress-p () + (with-no-warnings revert-buffer-in-progress-p)) + (defun eglot--maybe-activate-editing-mode () "Maybe activate `eglot--managed-mode'. @@ -2369,8 +2471,6 @@ If it is activated, also signal textDocument/didOpen." ;; Called when `revert-buffer-in-progress-p' is t but ;; `revert-buffer-preserve-modes' is nil. (when (and buffer-file-name (eglot-current-server)) - (setq eglot--pulled-diagnostics nil - eglot--pushed-diagnostics nil) (eglot--managed-mode) (eglot--signal-textDocument/didOpen) ;; Run user hook after 'textDocument/didOpen' so server knows @@ -2401,9 +2501,8 @@ If it is activated, also signal textDocument/didOpen." (when update-mode-line (force-mode-line-update t))))))) -(defun eglot-manual () "Read Eglot's manual." - (declare (obsolete info "1.10")) - (interactive) (info "(eglot)")) +;;;###autoload +(defun eglot-manual () "Read Eglot's manual." (interactive) (info "(eglot)")) ;;;###autoload (defun eglot-upgrade-eglot (&rest _) "Update Eglot to latest version." @@ -2575,12 +2674,14 @@ Uses THING, FACE, DEFS and PREPEND." (defconst eglot-mode-line-error '(:eval (when-let* ((server (eglot-current-server)) - (last-error (and server (jsonrpc-last-error server)))) - (eglot--mode-line-props - "error" 'compilation-mode-line-fail - '((mouse-3 eglot-clear-status "Clear this status")) - (format "An error occurred: %s\n" (plist-get last-error - :message))))) + (last-error (and server (jsonrpc-last-error server))) + (code (plist-get last-error :code))) + (unless (zerop code) + (eglot--mode-line-props + "error" 'compilation-mode-line-fail + '((mouse-3 eglot-clear-status "Clear this status")) + (format "An error occurred: %s\n" (plist-get last-error + :message)))))) "Eglot mode line construct for LSP errors.") (defconst eglot-mode-line-pending-requests @@ -2601,14 +2702,16 @@ still unanswered LSP requests to the server\n")))) (cl-loop for pr hash-values of (eglot--progress-reporters server) when (eq (car pr) 'eglot--mode-line-reporter) - collect (eglot--mode-line-props - (format "%s%%%%" (or (nth 4 pr) "?")) - 'eglot-mode-line - nil - (format "(%s) %s %s" (nth 1 pr) - (nth 2 pr) (nth 3 pr))) - into reports - finally (return (mapconcat #'identity reports " /"))))) + for v = (nth 4 pr) + when v sum 1 into n and sum v into acc + collect (format "(%s) %s %s" (nth 1 pr) (nth 2 pr) (nth 3 pr)) + into blurbs finally return + (unless (zerop n) + (eglot--mode-line-props + (format "%d%%%%" (/ acc n 1.0)) + 'eglot-mode-line + nil + (mapconcat #'identity blurbs "\n")))))) "Eglot mode line construct for LSP progress reports.") (defconst eglot-mode-line-action-suggestion @@ -2640,40 +2743,6 @@ still unanswered LSP requests to the server\n")))) when rest concat (if titlep ":" "/"))))) "] "))) - -;;; Flymake customization -;;; -(put 'eglot-note 'flymake-category 'flymake-note) -(put 'eglot-warning 'flymake-category 'flymake-warning) -(put 'eglot-error 'flymake-category 'flymake-error) - -(defun eglot--flymake-diagnostics (beg &optional end) - "Like `flymake-diagnostics', but for Eglot-specific diagnostics." - (cl-loop for diag in (flymake-diagnostics beg end) - for data = (flymake-diagnostic-data diag) - for lsp-diag = (alist-get 'eglot-lsp-diag data) - for version = (alist-get 'eglot--doc-version data) - when (and lsp-diag (or (null version) - (= version eglot--docver))) - collect diag)) - -(defun eglot--diag-to-lsp-diag (diag) - (alist-get 'eglot-lsp-diag (flymake-diagnostic-data diag))) - -(defvar eglot-diagnostics-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] #'eglot-code-actions-at-mouse) - (define-key map [left-margin mouse-1] #'eglot-code-actions-at-mouse) - map) - "Keymap active in Eglot-backed Flymake diagnostic overlays.") - -(cl-loop for i from 1 - for type in '(eglot-note eglot-warning eglot-error) - do (put type 'flymake-overlay-control - `((mouse-face . highlight) - (priority . ,(+ 50 i)) - (keymap . ,eglot-diagnostics-map)))) - ;;; Protocol implementation (Requests, notifications, etc) ;;; @@ -2691,27 +2760,21 @@ still unanswered LSP requests to the server\n")))) (jsonrpc-error "Unknown request method `%s'" method))) (cl-defmethod eglot-handle-notification - (_server (_method (eql window/showMessage)) &key type message) + (server (_method (eql window/showMessage)) &key type message) "Handle notification window/showMessage." - (eglot--message (propertize "Server reports (type=%s): %s" - 'face (if (<= type 1) 'error)) - type message)) + (message (eglot--format-server-message server type message))) (cl-defmethod eglot-handle-request - (_server (_method (eql window/showMessageRequest)) + (server (_method (eql window/showMessageRequest)) &key type message actions &allow-other-keys) "Handle server request window/showMessageRequest. ACTIONS is a list of MessageActionItem, this has the user choose one and return it back to the server. :null is returned if the list was empty." (let* ((actions (mapcar (lambda (a) (cons (plist-get a :title) a)) actions)) (label (completing-read - (concat - (format (propertize "[eglot] Server reports (type=%s): %s" - 'face (if (or (not type) (<= type 1)) 'error)) - type message) - "\nChoose an option: ") - (or actions '("OK")) - nil t (caar actions)))) + (eglot--format-server-message server type message) + (or (mapcar #'car actions) '("OK")) + nil t))) (if (and actions label) (cdr (assoc label actions)) :null))) (cl-defmethod eglot-handle-notification @@ -2762,56 +2825,6 @@ Value is (TRUENAME . (:uri STR)), where STR is what is sent to the server on textDocument/didOpen and similar calls. TRUENAME is the expensive cached value of `file-truename'.") -(cl-defmethod eglot-handle-notification - (server (_method (eql textDocument/publishDiagnostics)) - &key uri diagnostics version - &allow-other-keys) ; FIXME: doesn't respect `eglot-strict-mode' - "Handle notification publishDiagnostics." - (cl-flet ((find-it (abspath) - ;; `find-buffer-visiting' would be natural, but calls the - ;; potentially slow `file-truename' (bug#70036). - (cl-loop for b in (eglot--managed-buffers server) - when (with-current-buffer b - (equal (car eglot--TextDocumentIdentifier-cache) - abspath)) - return b))) - (if-let* ((path (expand-file-name (eglot-uri-to-path uri))) - (buffer (find-it path))) - (with-current-buffer buffer - (cl-loop - initially - (if (and version (/= version eglot--docver)) - (cl-return)) - (setq - ;; if no explicit version received, assume it's current. - version eglot--docver - flymake-list-only-diagnostics - (assoc-delete-all path flymake-list-only-diagnostics)) - for diag-spec across diagnostics - collect (eglot--flymake-make-diag diag-spec version) - into diags - finally - (setq eglot--pushed-diagnostics (list diags version)) - (when (not (null flymake-no-changes-timeout )) - ;; only add to current report if Flymake - ;; starts on idle-timer (github#957) - (eglot--flymake-report)))) - (cl-loop - for diag-spec across diagnostics - collect (eglot--dbind ((Diagnostic) code range message severity source) diag-spec - (let* ((start (plist-get range :start)) - (line (1+ (plist-get start :line))) - (char (1+ (plist-get start :character)))) - (flymake-make-diagnostic - path (cons line char) nil - (eglot--flymake-diag-type severity) - (list source code message)))) - into diags - finally - (setq flymake-list-only-diagnostics - (assoc-delete-all path flymake-list-only-diagnostics)) - (push (cons path diags) flymake-list-only-diagnostics))))) - (cl-defun eglot--register-unregister (server things how) "Helper for `registerCapability'. THINGS are either registrations or unregisterations (sic)." @@ -2837,8 +2850,19 @@ THINGS are either registrations or unregisterations (sic)." (cl-defmethod eglot-handle-request (_server (_method (eql workspace/applyEdit)) &key _label edit) "Handle server request workspace/applyEdit." - (eglot--apply-workspace-edit edit last-command) - `(:applied t)) + (condition-case-unless-debug oops + (pcase-let ((`(,retval ,reason) (eglot--apply-workspace-edit edit last-command))) + `(:applied ,retval ,@(and reason `(:failureReason ,reason)))) + (quit + (jsonrpc-error + :code 32000 :data + (list :applied :json-false + :failureReason + (format "'%s'%s." (car oops) + (if (cdr oops) (format " (%s)" (cdr oops)) ""))))) + (t + ;; resignal (unfortunately like this) + (signal (car oops) (cdr oops))))) (cl-defmethod eglot-handle-request (server (_method (eql workspace/workspaceFolders))) @@ -2952,7 +2976,7 @@ buffer." (cl-defmethod jsonrpc-connection-ready-p ((_server eglot-lsp-server) _what) "Tell if SERVER is ready for WHAT in current buffer." - (and (cl-call-next-method) (not eglot--recent-changes))) + (and (cl-call-next-method) (not (cl-minusp eglot--docver)) (not eglot--recent-changes))) (defvar-local eglot--change-idle-timer nil "Idle timer for didChange signals.") @@ -3152,12 +3176,14 @@ When called interactively, use the currently active server" (setq eglot--recent-changes nil eglot--docver 0 eglot--TextDocumentIdentifier-cache nil) + (eglot--flymake-reset) (jsonrpc-notify (eglot--current-server-or-lose) :textDocument/didOpen `(:textDocument ,(eglot--TextDocumentItem)))) (defun eglot--signal-textDocument/didClose () "Send textDocument/didClose to server." + (setq eglot--docver -1) (with-demoted-errors "[eglot] error sending textDocument/didClose: %s" (jsonrpc-notify @@ -3188,6 +3214,130 @@ When called interactively, use the currently active server" :text (buffer-substring-no-properties (point-min) (point-max)) :textDocument (eglot--TextDocumentIdentifier))))) +(defun eglot--find-buffer-visiting (server abspath) + ;; `find-buffer-visiting' would be natural, but calls the + ;; potentially slow `file-truename' (bug#70036). + (cl-loop for b in (eglot--managed-buffers server) + when (with-current-buffer b + (equal (car eglot--TextDocumentIdentifier-cache) + abspath)) + return b)) + + +;;; Flymake integration + +(put 'eglot-note 'flymake-category 'flymake-note) +(put 'eglot-warning 'flymake-category 'flymake-warning) +(put 'eglot-error 'flymake-category 'flymake-error) + +(defvar eglot-diagnostics-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-2] #'eglot-code-actions-at-mouse) + (define-key map [left-margin mouse-1] #'eglot-code-actions-at-mouse) + map) + "Keymap active in Eglot-backed Flymake diagnostic overlays.") + +(cl-loop for i from 1 + for type in '(eglot-note eglot-warning eglot-error) + do (put type 'flymake-overlay-control + `((mouse-face . highlight) + (priority . ,(+ 50 i)) + (keymap . ,eglot-diagnostics-map)))) + +(defun eglot--flymake-sniff-diagnostics (beg &optional end) + "Like `flymake-diagnostics', but for Eglot-specific diagnostics." + (cl-loop for diag in (flymake-diagnostics beg end) + for data = (flymake-diagnostic-data diag) + for lsp-diag = (alist-get 'eglot-lsp-diag data) + for version = (alist-get 'eglot--doc-version data) + when (and lsp-diag (or (null version) + (= version eglot--docver))) + collect diag)) + +(cl-defmacro eglot--flymake-report-1 (diags mode &key (version 'eglot--docver) force) + "Maybe convert, report and store the diagnostics objects DIAGS. +DIAGS is either a vector of LSP diagnostics or a list of Flymake +diagnostics. MODE can be `:stay' or `:clear' depending on whether we +want to accumulate or reset diagnostics in the buffer. VERSION is the +version the diagnostics pertain to." + ;; JT@2026-01-10: criteria for "incremental" reports could be + ;; tightened to e.g. check eglot--capf-session nillness, but we'd have + ;; to schedule an after-session re-report, and that's way too complex + `(when (and (or ,force flymake-no-changes-timeout) + eglot--flymake-report-fn) + (when (and ,diags (vectorp ,diags)) + (setf ,diags + (eglot--collecting-ranged (o r ,diags) + (eglot--flymake-make-diag o ,version r)))) + (eglot--flymake-report-2 ,diags ,mode))) + +(cl-defmethod eglot-handle-notification + (server (_method (eql textDocument/publishDiagnostics)) + &key uri diagnostics version + &allow-other-keys) + "Handle notification publishDiagnostics." + (eglot--flymake-handle-push + server uri diagnostics version + (lambda (diags) + (setq eglot--pushed-diagnostics (list diags eglot--docver)) + (when (not (null flymake-no-changes-timeout )) + ;; only add to current report if Flymake + ;; starts on idle-timer (github#957) + (eglot--flymake-report-push+pulled))))) + +(cl-defmethod eglot-handle-notification + (server (_method (eql $/streamDiagnostics)) + &key uri diagnostics version token kind + &allow-other-keys) + "Handle notification $/streamDiagnostics." + (cl-macrolet ((report (what mode) + `(eglot--flymake-report-1 ,what ,mode))) + (eglot--flymake-handle-push + server uri diagnostics version + (lambda (lsp-diags) + (cl-symbol-macrolet ((map (cadr eglot--streamed-diagnostics))) + (let* ((doc-v eglot--docver) + (known-v (car eglot--streamed-diagnostics)) + (prev-map (caddr eglot--streamed-diagnostics)) + (diags (if (equal kind "unchanged") + (cdr (assoc token (if (eq known-v doc-v) + map prev-map))) + lsp-diags)) + probe) + ;; (trace-values (buffer-name) "lsp-diags" (length lsp-diags) + ;; "diags" (length diags) "kind" kind + ;; "known-v" known-v "doc-v" doc-v) + (cond ((and known-v (< doc-v known-v)) + ;; Ignore out of date (shouldn't happen) + (report nil :stay)) + ((or (null known-v) (> doc-v known-v)) + ;; `doc-v' is greater than (potentially nil) + ;; recorded `known-v'. Save old known-v and map, + ;; "inaugurate" new doc-v, report this initial subset, + ;; clearing all existing diagnostics. + (cl-loop for (tk . diags) in map + do (setf (alist-get tk prev-map nil nil #'equal) diags)) + (let ((entry (cons token diags))) + (setq eglot--streamed-diagnostics + `(,doc-v (,entry) ,prev-map)) + (report (cdr entry) :clear))) + ((setq probe (assoc token map)) + ;; `diags' are an update to an existing report for + ;; this token, for this `doc-v' Record and report + ;; all to Flymake, clearing all existing diagnostics. + (setcdr probe diags) + (cl-loop for e in map + for m = :clear then :stay + do (report (cdr e) m))) + (t + ;; It's the first time we hear about `token' for this + ;; already inaugurated `doc-v' add its diagnostics to + ;; the map, and report only this subset, not clearing + ;; any old diagnostics. + (let ((entry (cons token diags))) + (push entry map) + (report (cdr entry) :stay)))))))))) + (defun eglot--flymake-diag-type (severity) "Convert LSP diagnostic SEVERITY to Eglot/Flymake diagnostic type." (cond ((null severity) 'eglot-error) @@ -3195,13 +3345,14 @@ When called interactively, use the currently active server" ((= severity 2) 'eglot-warning) (t 'eglot-note))) -(defun eglot--flymake-make-diag (diag-spec version) +(defun eglot--flymake-make-diag (diag-spec version region) "Convert LSP diagnostic DIAG-SPEC to Flymake diagnostic. -VERSION is the document version number." +VERSION is the document version number. REGION is the (BEG . END) +pertaining to DIAG-SPEC." (eglot--dbind ((Diagnostic) range code message severity source tags) diag-spec (pcase-let - ((`(,beg . ,end) (eglot-range-region range))) + ((`(,beg . ,end) region)) ;; Fallback to `flymake-diag-region' if server botched the range (when (= beg end) (if-let* ((st (plist-get range :start)) @@ -3242,12 +3393,57 @@ may be called multiple times (respecting the protocol of ;; Use pull diagnostics if server supports it ((eglot-server-capable :diagnosticProvider) (eglot--flymake-pull)) + ((eglot-server-capable :$streamingDiagnosticsProvider) + (let ((v (car eglot--streamed-diagnostics)) + (map (cadr eglot--streamed-diagnostics))) + (if (and v (< v eglot--docver)) + (eglot--flymake-report-2 nil :stay) + (cl-loop for e in map + for m = :clear then :stay + do (eglot--flymake-report-1 (cdr e) m))))) ;; Otherwise push whatever we might have, and wait for - ;; `textDocument/publishDiagnostics'. - (t (eglot--flymake-report)))) + ;; further `textDocument/publishDiagnostics'. + (t (eglot--flymake-report-push+pulled :force t)))) (t (funcall report-fn nil)))) +(cl-defun eglot--flymake-handle-push (server uri diagnostics version then) + "Handle a diagnostics \"push\" from SERVER for document URI. +DIAGNOSTICS is a list of LSP diagnostic objects. VERSION is the +LSP-reported version comparable to `eglot--docver' for which these +objects presumably pertain. If diagnostics are thought to belong to +`eglot--docver' THEN is a unary function taking DIAGNOSTICS and tasked +to eventually report the corresponding Flymake conversions of each +object. The originator of this \"push\" is usually either regular +`textDocument/publishDiagnostics' or an experimental +`$/streamDiagnostics' notification." + (if-let* ((path (expand-file-name (eglot-uri-to-path uri))) + (buffer (eglot--find-buffer-visiting server path))) + (with-current-buffer buffer + (if (and version (/= version eglot--docver)) + (cl-return-from eglot--flymake-handle-push)) + (setq + ;; if no explicit version received, assume it's current. + version eglot--docver + flymake-list-only-diagnostics + (assoc-delete-all path flymake-list-only-diagnostics)) + (funcall then diagnostics)) + (cl-loop + for diag-spec across diagnostics + collect (eglot--dbind ((Diagnostic) code range message severity source) diag-spec + (let* ((start (plist-get range :start)) + (line (1+ (plist-get start :line))) + (char (1+ (plist-get start :character)))) + (flymake-make-diagnostic + path (cons line char) nil + (eglot--flymake-diag-type severity) + (list source code message)))) + into diags + finally + (setq flymake-list-only-diagnostics + (assoc-delete-all path flymake-list-only-diagnostics)) + (push (cons path diags) flymake-list-only-diagnostics)))) + (cl-defun eglot--flymake-pull (&aux (server (eglot--current-server-or-lose)) (origin (current-buffer))) "Pull diagnostics from server, for all managed buffers. @@ -3256,7 +3452,7 @@ When response arrives call registered `eglot--flymake-report-fn'." ((pull-for (buf &optional then) (with-current-buffer buf (let ((version eglot--docver) - (prev-result-id (cadr eglot--pulled-diagnostics))) + (prev-result-id (caddr eglot--pulled-diagnostics))) (eglot--async-request server :textDocument/diagnostic @@ -3266,18 +3462,14 @@ When response arrives call registered `eglot--flymake-report-fn'." `(:previousResultId ,prev-result-id)))) :success-fn (eglot--lambda ((DocumentDiagnosticReport) kind items resultId) - (eglot--when-live-buffer buf - (pcase kind - ("full" - (setq eglot--pulled-diagnostics - (list - (cl-loop - for spec across items - collect (eglot--flymake-make-diag spec version)) - resultId)) - (eglot--flymake-report)) - ("unchanged" - (when (eq buf origin) (eglot--flymake-report 'void))))) + (pcase kind + ("full" + (setq eglot--pulled-diagnostics + (list items version resultId)) + (eglot--flymake-report-push+pulled :force t)) + ("unchanged" + (when (eq buf origin) + (eglot--flymake-report-1 nil :stay :force t)))) (when then (funcall then))) :hint :textDocument/diagnostic))))) ;; JT@2025-12-15: No known server yet supports "relatedDocuments" so @@ -3290,36 +3482,48 @@ When response arrives call registered `eglot--flymake-report-fn'." (mapc #'pull-for (remove origin (eglot--managed-buffers server)))))))) -(cl-defun eglot--flymake-report - (&optional void - &aux - (diags (append (car eglot--pulled-diagnostics) - (car eglot--pushed-diagnostics))) - (version (cadr eglot--pushed-diagnostics))) - "Push previously collected diagnostics to `eglot--flymake-report-fn'. -If VOID, knowingly push a dummy do-nothing update." - (unless eglot--flymake-report-fn - ;; Occasionally called from contexts where report-fn not setup, such - ;; as a `didOpen''ed but yet undisplayed buffer. - (cl-return-from eglot--flymake-report)) - (eglot--widening - (if (or void (and version (< version eglot--docver))) - ;; Here, we don't have anything interesting to give to Flymake: we - ;; just want to keep whatever diagnostics it has annotated in the - ;; buffer. However, as a nice-to-have, we still want to signal - ;; we're alive and clear a possible "Wait" state. We hackingly - ;; achieve this by reporting an empty list and making sure it - ;; pertains to a 0-length region. - (funcall eglot--flymake-report-fn nil - :region (cons (point-min) (point-min))) - (funcall eglot--flymake-report-fn diags - ;; If the buffer hasn't changed since last - ;; call to the report function, flymake won't - ;; delete old diagnostics. Using :region - ;; keyword forces flymake to delete - ;; them (github#159). - :region (cons (point-min) (point-max)))))) +(defun eglot--flymake-reset () + (setq eglot--pulled-diagnostics nil + eglot--pushed-diagnostics nil + eglot--streamed-diagnostics nil) + (when eglot--flymake-report-fn + (eglot--flymake-report-1 nil :clear :force t))) +(cl-defun eglot--flymake-report-2 (diags mode) + "Really report the Flymake diagnostics objects DIAGS. +MODE is like `eglot--flymake-report-1'." + (apply eglot--flymake-report-fn + diags + (cond ((eq mode :clear) + `(:region ,(cons (point-min) (point-max)))) + ((eq mode :stay) + `(:region ,(cons (point-min) (point-min))))))) + +(cl-defun eglot--flymake-report-push+pulled + (&key force + &aux + (pushed-docver (cadr eglot--pushed-diagnostics)) + (pushed-outdated-p (and pushed-docver (< pushed-docver eglot--docver)))) + "Push previously collected diagnostics to `eglot--flymake-report-fn'. +If KEEP, knowingly push a dummy do-nothing update." + (eglot--widening + (if (and (null eglot--pulled-diagnostics) pushed-outdated-p) + ;; Here, we don't have anything interesting to give to Flymake. + ;; Either a textDocument/diagnostics response specifically told + ;; use that nothing changed, or `flymake-start' kicked in before + ;; server had a chance to push something. We just want to keep + ;; whatever diagnostics it has annotated in the buffer and and + ;; clear a possible "Wait" state. + (eglot--flymake-report-2 nil :stay) + (cl-macrolet ((report (x m) + `(eglot--flymake-report-1 + (car ,x) ,m :force force))) + (report eglot--pulled-diagnostics :clear) + (unless pushed-outdated-p + (report eglot--pushed-diagnostics :stay)))))) + + +;;; Xref integration (defun eglot-xref-backend () "Eglot xref backend." 'eglot) (defvar eglot--temp-location-buffers (make-hash-table :test #'equal) @@ -3517,6 +3721,8 @@ If BUFFER, switch to it before." :workspace/symbol `(:query ,pattern)))))) + +;;; Eglot interactive commands and helpers (defun eglot-format-buffer () "Format contents of current buffer." (interactive) @@ -3559,12 +3765,15 @@ for which LSP on-type-formatting should be requested." nil on-type-format))) + + +;;; Completion (defvar eglot-cache-session-completions t "If non-nil Eglot caches data during completion sessions.") (defvar eglot--capf-session :none "A cache used by `eglot-completion-at-point'.") -(defun eglot--capf-session-flush (&optional _) (setq eglot--capf-session :none)) +(defun eglot--capf-session-flush (&optional _) (setq eglot--capf-session nil)) (defun eglot--dumb-flex (pat comp ignorecase) "Return destructively fontified COMP iff PAT matches it." @@ -3820,6 +4029,8 @@ for which LSP on-type-formatting should be requested." (eglot--apply-text-edits additionalTextEdits))) (eglot--signal-textDocument/didChange))))))))) + +;;; Eldoc integration (defun eglot--hover-info (contents &optional _range) (mapconcat #'eglot--format-markup (if (vectorp contents) contents (list contents)) "\n")) @@ -3965,6 +4176,8 @@ for which LSP on-type-formatting should be requested." :hint :textDocument/documentHighlight) nil))) + +;;; Imenu integration (defun eglot--imenu-SymbolInformation (res) "Compute `imenu--index-alist' for RES vector of SymbolInformation." (mapcar @@ -3973,20 +4186,20 @@ for which LSP on-type-formatting should be requested." (alist-get kind eglot--symbol-kind-names "Unknown") (mapcan (pcase-lambda (`(,container . ,objs)) - (let ((elems (mapcar - (eglot--lambda ((SymbolInformation) kind name location) - (let ((reg (eglot-range-region - (plist-get location :range))) - (kind (alist-get kind eglot--symbol-kind-names))) - (cons (propertize name - 'imenu-region reg - 'imenu-kind kind - ;; Backward-compatible props - ;; to be removed later: - 'breadcrumb-region reg - 'breadcrumb-kind kind) - (car reg)))) - objs))) + (let ((elems + (eglot--collecting-ranged + (s reg objs (lambda (o) + (plist-get :range (plist-get o :location)))) + (eglot--dbind ((SymbolInformation) kind name) s + (let ((kind (alist-get kind eglot--symbol-kind-names))) + (cons (propertize name + 'imenu-region reg + 'imenu-kind kind + ;; Backward-compatible props + ;; to be removed later: + 'breadcrumb-region reg + 'breadcrumb-kind kind) + (car reg))))))) (if container (list (cons container elems)) elems))) (seq-group-by (eglot--lambda ((SymbolInformation) containerName) containerName) objs)))) @@ -4006,6 +4219,7 @@ for which LSP on-type-formatting should be requested." 'breadcrumb-kind kind))) (if (seq-empty-p children) (cons name (car reg)) + ;; FIXME: leverage eglot--collecting-ranged (cons name (mapcar (lambda (c) (apply #'dfs c)) children)))))) (mapcar (lambda (s) (apply #'dfs s)) res))) @@ -4013,8 +4227,6 @@ for which LSP on-type-formatting should be requested." (cl-defun eglot-imenu () "Eglot's `imenu-create-index-function'. Returns a list as described in docstring of `imenu--index-alist'." - (unless (eglot-server-capable :documentSymbolProvider) - (cl-return-from eglot-imenu)) (let* ((res (eglot--request (eglot--current-server-or-lose) :textDocument/documentSymbol `(:textDocument @@ -4026,12 +4238,14 @@ Returns a list as described in docstring of `imenu--index-alist'." (((SymbolInformation)) (eglot--imenu-SymbolInformation res)) (((DocumentSymbol)) (eglot--imenu-DocumentSymbol res)))))) + +;;; Code actions and rename (cl-defun eglot--apply-text-edits (edits &optional version silent) "Apply EDITS for current buffer if at VERSION, or if it's nil. If SILENT, don't echo progress in mode-line." (unless edits (cl-return-from eglot--apply-text-edits)) (unless (or (not version) (equal version eglot--docver)) - (jsonrpc-error "Edits on `%s' require version %d, you have %d" + (jsonrpc-error "Edits on `%s' require version %d, have %d" (current-buffer) version eglot--docver)) (atomic-change-group (let* ((change-group (prepare-change-group)) @@ -4068,14 +4282,25 @@ If SILENT, don't echo progress in mode-line." (when reporter (progress-reporter-done reporter))))) -(defun eglot--confirm-server-edits (origin _prepared) +(defun eglot--confirm-server-edits (origin prepared) "Helper for `eglot--apply-workspace-edit. -ORIGIN is a symbol designating a command. Reads the -`eglot-confirm-server-edits' user option and returns a symbol -like `diff', `summary' or nil." - (let (v) +ORIGIN is a symbol designating a command. PREPARED is a list of +operations to apply. Reads the `eglot-confirm-server-edits' user +option and returns a symbol like `diff', `summary' or nil." + (let (v op-kinds) (cond ((symbolp eglot-confirm-server-edits) eglot-confirm-server-edits) + ;; Check for command-based entry ((setq v (assoc origin eglot-confirm-server-edits)) (cdr v)) + ;; Check for operation-kind-based entry + ((and (setq op-kinds (mapcar #'car prepared)) + (setq v (cl-find-if (lambda (entry) + (and (listp (car entry)) + (cl-some (lambda (kind) + (memq kind (car entry))) + op-kinds))) + eglot-confirm-server-edits))) + (cdr v)) + ;; Default entry ((setq v (assoc t eglot-confirm-server-edits)) (cdr v))))) (defun eglot--propose-changes-as-diff (prepared) @@ -4089,7 +4314,7 @@ list ((FILENAME EDITS VERSION)...)." (target (current-buffer))) (diff-mode) (erase-buffer) - (pcase-dolist (`(,path ,edits ,_) prepared) + (pcase-dolist (`(_ _ _ ,path ,edits ,_) prepared) (with-temp-buffer (let* ((diff (current-buffer)) (existing-buf (find-buffer-visiting path)) @@ -4115,62 +4340,185 @@ list ((FILENAME EDITS VERSION)...)." (buffer-enable-undo (current-buffer)) (goto-char (point-min)) (pop-to-buffer (current-buffer)) - (font-lock-ensure))) + (font-lock-ensure) + (current-buffer))) -(defun eglot--apply-workspace-edit (wedit origin) +(cl-defun eglot--apply-workspace-edit (wedit origin &aux prepared) "Apply (or offer to apply) the workspace edit WEDIT. -ORIGIN is a symbol designating the command that originated this -edit proposed by the server." - (eglot--dbind ((WorkspaceEdit) changes documentChanges) wedit - (let ((prepared - (mapcar (eglot--lambda ((TextDocumentEdit) textDocument edits) - (eglot--dbind ((VersionedTextDocumentIdentifier) uri version) - textDocument - (list (eglot-uri-to-path uri) edits version))) - documentChanges))) +ORIGIN is a symbol designating the command that originated this edit +proposed by the server. Returns a list (APPLIED REASON) indicating if +the edit was attempted and optionally why not." + ;; JT@2026-01-11: Note to future (self?). Most if this big function + ;; is preparing with the `prepared' (OP ...) list , where each OP is + ;; (KIND DESC APPLY-FN . MORE). KIND is a symbol, DESC is a string. + ;; APPLY-FN is a unary function of OP that applies the change. + ;; Sometimes there is MORE data, such as when KIND is eg. 'text-edit' + ;; and needs extra info for the diff rendering. + (cl-labels + ((pathify (x) (eglot-uri-to-path x)) + (do-create (path &key overwrite ignoreIfExists + &allow-other-keys) + (let ((exists (file-exists-p path))) + (when (and exists (not ignoreIfExists) (not overwrite)) + (eglot--error "File %s already exists" path)) + (when (or (not exists) overwrite) + (let ((dir (file-name-directory path))) + (unless (file-directory-p dir) + (make-directory dir t))) + (write-region "" nil path nil 'nomessage)))) + (do-rename (old-path new-path &key overwrite ignoreIfExists + &allow-other-keys) + (let ((new-exists (file-exists-p new-path))) + (when (and new-exists (not ignoreIfExists) (not overwrite)) + (eglot--error "File %s already exists" new-path)) + (let ((dir (file-name-directory new-path))) + (unless (file-directory-p dir) + (make-directory dir t))) + ;; If the old file is visited, rename the buffer too + (let ((buf (find-buffer-visiting old-path))) + (when buf + (with-current-buffer buf + (set-visited-file-name new-path t t)))) + (rename-file old-path new-path overwrite))) + (do-delete (path &key recursive ignoreIfNotExists &allow-other-keys) + (let ((exists (file-exists-p path))) + (when (and (not exists) (not ignoreIfNotExists)) + (eglot--error "File %s does not exist" path)) + (when exists + ;; Kill buffer if the file is visited + (let ((buf (find-buffer-visiting path))) + (when buf (kill-buffer buf))) + (delete-file path recursive)))) + (text-edit-op (path edits version) + `(text-edit + ,(format "Change %s (%d change%s)" path (length edits) + (if (> (length edits) 1) "s" "")) + ,(lambda (_op) + (with-current-buffer (find-file-noselect path) + (eglot--apply-text-edits edits version))) + ,path ,edits ,version)) + (mkfn (doit-fn &rest things) + (lambda (op) + (apply doit-fn things) + (eglot--message + "%s" (replace-regexp-in-string "^\\([^ ]+\\) " "\\1d " (cadr op))))) + (prepare (ch) + (pcase (plist-get ch :kind) + ("create" + (eglot--dbind ((CreateFile) uri ((:options o))) ch + (let ((p (pathify uri))) + `(create ,(format "Create `%s'" p) ,(mkfn #'do-create p o))))) + ("rename" + (eglot--dbind ((RenameFile) oldUri newUri ((:options o))) ch + (let ((ol (pathify oldUri)) (nw (pathify newUri))) + `(rename ,(format "Rename `%s' to `%s'" ol nw) + ,(mkfn #'do-rename ol nw o))))) + ("delete" + (eglot--dbind ((DeleteFile) uri ((:options o))) ch + (let ((p (pathify uri))) + `(delete ,(format "Delete `%s'" p) ,(mkfn #'do-delete p o))))) + (_ + ;; It's a TextDocumentEdit (no kind field) + (eglot--dbind ((TextDocumentEdit) textDocument edits) ch + (eglot--dbind ((VersionedTextDocumentIdentifier) uri version) + textDocument (text-edit-op (pathify uri) edits version)))))) + (user-accepts-p () + (y-or-n-p + (format "[eglot] Server wants to:\n%s\nProceed? " + (mapconcat (lambda (op) (concat " " (cadr op))) + prepared "\n")))) + (apply-all () + (cl-loop + for op in prepared + for (_kind _desc fn) = op + do (funcall fn op) + finally (eldoc) (eglot--message "Workspace edit successful")) + `(t nil))) + (eglot--dbind ((WorkspaceEdit) changes documentChanges) wedit + (setq prepared (mapcar #'prepare documentChanges)) (unless (and changes documentChanges) - ;; We don't want double edits, and some servers send both - ;; changes and documentChanges. This unless ensures that we - ;; prefer documentChanges over changes. + ;; Prefer `documentChanges' over sort-of-deprecated `changes'. (cl-loop for (uri edits) on changes by #'cddr - do (push (list (eglot-uri-to-path uri) edits) prepared))) - (cl-flet ((notevery-visited-p () - (cl-notevery #'find-buffer-visiting - (mapcar #'car prepared))) - (accept-p () - (y-or-n-p - (format "[eglot] Server wants to edit:\n%sProceed? " - (cl-loop - for (f eds _) in prepared - concat (format - " %s (%d change%s)\n" - f (length eds) - (if (> (length eds) 1) "s" "")))))) - (apply () - (cl-loop for edit in prepared - for (path edits version) = edit - do (with-current-buffer (find-file-noselect path) - (eglot--apply-text-edits edits version)) - finally (eldoc) (eglot--message "Edit successful!")))) - (let ((decision (eglot--confirm-server-edits origin prepared))) - (cond - ((or (eq decision 'diff) - (and (eq decision 'maybe-diff) (notevery-visited-p))) - (eglot--propose-changes-as-diff prepared)) - ((or (memq decision '(t summary)) - (and (eq decision 'maybe-summary) (notevery-visited-p))) - (when (accept-p) (apply))) - (t - (apply)))))))) + do (push (text-edit-op (pathify uri) edits nil) prepared))) + (let* ((decision (eglot--confirm-server-edits origin prepared)) + (all-text-edits (cl-loop for (kind . _) in prepared + always (eq kind 'text-edit))) + (peaceful + (and + all-text-edits + (cl-loop for op in prepared + always (find-buffer-visiting (cadddr op)))))) + (cond + ((and (and (memq decision '(maybe-diff maybe-summary)) peaceful)) + (apply-all)) + ((memq decision '(diff maybe-diff)) + (cond (all-text-edits + (pop-to-buffer + (eglot--propose-changes-as-diff prepared)) + `(nil "decision to apply manually")) + (t + ;; `map-y-or-n-p' heroics. Iterate over prepared + ;; operations with individual prompts, showing diffs + ;; for text-edit operations. + (let* ((wconf (current-window-configuration)) + (applied 0) + (total (length prepared))) + (unwind-protect + (progn + (map-y-or-n-p + (lambda (op) + (when (eq (car op) 'text-edit) + (display-buffer + (eglot--propose-changes-as-diff (list op)))) + (format "[eglot] %s? " (cadr op))) + (lambda (op) + (set-window-configuration wconf) + (funcall (caddr op) op) + (cl-incf applied)) + (lambda () + ;; Skip text-edits for files that don't exist + ;; (e.g. user skipped the create operation). + (cl-loop for op = (pop prepared) while op + when (or (not (eq (car op) 'text-edit)) + (file-exists-p (cadddr op))) + return op)) + '("change" "changes" "apply")) + (if (= applied total) + (progn + (eldoc) + (eglot--message "Workspace edit successful") + `(t nil)) + `(nil "decision to abort"))) + (set-window-configuration wconf)))))) + ((memq decision '(t summary maybe-summary)) + (if (user-accepts-p) (apply-all) `(nil "decision to decline"))) + ((apply-all))))))) + +(cl-defun eglot--rename-interactive + (&aux + def region + (rename-support (eglot-server-capable-or-lose :renameProvider)) + (prepare-support (and (listp rename-support) + (plist-get rename-support :prepareProvider)))) + (setq + def + (cond (prepare-support + (let ((x (eglot--request (eglot--current-server-or-lose) + :textDocument/prepareRename + (eglot--TextDocumentPositionParams)))) + (cond ((null x) (user-error "[eglot] Can't rename here")) + ((plist-get x :placeholder)) + ((plist-get x :defaultBehavior) (thing-at-point 'symbol t)) + ((setq region (eglot-range-region x)) + (buffer-substring-no-properties (car region) (cdr region)))))) + (t (thing-at-point 'symbol t)))) + (list (read-from-minibuffer + (format "Rename `%s' to: " (or def "unknown symbol")) + nil nil nil nil def))) (defun eglot-rename (newname) "Rename the current symbol to NEWNAME." - (interactive - (let ((tap (thing-at-point 'symbol t))) - (list (read-from-minibuffer - (format "Rename `%s' to: " (or tap "unknown symbol")) - nil nil nil nil tap)))) - (eglot-server-capable-or-lose :renameProvider) + (interactive (eglot--rename-interactive)) (eglot--apply-workspace-edit (eglot--request (eglot--current-server-or-lose) :textDocument/rename `(,@(eglot--TextDocumentPositionParams) @@ -4181,7 +4529,7 @@ edit proposed by the server." "Calculate appropriate bounds depending on region and point." (let (diags boftap) (cond ((use-region-p) `(,(region-beginning) ,(region-end))) - ((setq diags (eglot--flymake-diagnostics (point))) + ((setq diags (eglot--flymake-sniff-diagnostics (point))) (cl-loop for d in diags minimizing (flymake-diagnostic-beg d) into beg maximizing (flymake-diagnostic-end d) into end @@ -4197,8 +4545,9 @@ edit proposed by the server." :range (eglot-region-range beg end) :context `(:diagnostics - [,@(mapcar #'eglot--diag-to-lsp-diag - (eglot--flymake-diagnostics beg end))] + [,@(mapcar (lambda (x) + (alist-get 'eglot-lsp-diag (flymake-diagnostic-data x))) + (eglot--flymake-sniff-diagnostics beg end))] ,@(when only `(:only [,only])) ,@(when triggerKind `(:triggerKind ,triggerKind))))) @@ -4341,11 +4690,28 @@ at point. With prefix argument, prompt for ACTION-KIND." ;;; File watchers (aka didChangeWatchedFiles) ;;; (defvar eglot-watch-files-outside-project-root t - "If non-nil, allow watching files outside project root") + "If non-nil, allow watching files outside project root.") + +(defvar eglot-max-file-watches 10000 + "Maximum number of file watches across all Eglot servers. +If this limit is reached, a warning is issued and further watches +are not added. Set to nil for unlimited watches.") + +(defun eglot--count-file-watches () + "Count total file watches across all Eglot servers." + (let ((count 0)) + (maphash (lambda (_proj servers) + (dolist (server servers) + (maphash (lambda (_id descs) + (cl-incf count (length descs))) + (eglot--file-watches server)))) + eglot--servers-by-project) + count)) (cl-defun eglot--watch-globs (server id globs dir in-root &aux (project (eglot--project server)) - success) + success + (watch-count (eglot--count-file-watches))) "Set up file watching for relative file names matching GLOBS under DIR. GLOBS is a list of (COMPILED-GLOB . KIND) pairs, where COMPILED-GLOB is a compiled glob predicate and KIND is a bitmask of change types. DIR is @@ -4373,6 +4739,7 @@ happens to be inside or matching the project root." (candidate (if dir (file-relative-name file dir) file))) (cond ((and (memq action '(created changed deleted)) + (not (eglot--find-buffer-visiting server file)) (cl-loop for (compiled . kind) in globs thereis (and (> (logand kind action-bit) 0) (funcall compiled candidate)))) @@ -4387,9 +4754,18 @@ happens to be inside or matching the project root." (handle-event `(,desc deleted ,file)) (handle-event `(,desc created ,file1)))))) (add-watch (subdir) - (when (file-readable-p subdir) - (push (file-notify-add-watch subdir '(change) #'handle-event) - (gethash id (eglot--file-watches server)))))) + (cond ((not (file-readable-p subdir))) + ((and eglot-max-file-watches + (>= watch-count eglot-max-file-watches)) + (eglot--warn "Reached `eglot-max-file-watches' limit of %d, \ +not watching some directories" eglot-max-file-watches) + ;; Could `(setq success t)' here to keep partial watches. + (jsonrpc-error "Reached `eglot-max-file-watches' limit of %d" + eglot-max-file-watches)) + (t + (push (file-notify-add-watch subdir '(change) #'handle-event) + (gethash id (eglot--file-watches server))) + (cl-incf watch-count))))) (let ((subdirs (if (or (null dir) in-root) (subdirs-using-project) (condition-case _ (subdirs-using-find) @@ -4531,7 +4907,8 @@ If NOERROR, return predicate, else erroring function." \\{eglot-list-connections-mode-map}" :interactive nil (setq-local tabulated-list-format - `[("Language server" 16) ("Project name" 16) ("Modes handled" 16)]) + `[("Language server" 16) ("Project name" 20) ("Buffers" 7) + ("Modes" 20) ("Invocation" 32)]) (tabulated-list-init-header)) (defun eglot-list-connections () @@ -4549,9 +4926,14 @@ If NOERROR, return predicate, else erroring function." `[,(or (plist-get (eglot--server-info server) :name) (jsonrpc-name server)) ,(eglot-project-nickname server) + ,(format "%s" (length (eglot--managed-buffers server))) ,(mapconcat #'symbol-name (eglot--major-modes server) - ", ")])) + ", ") + ,(let ((c (process-command + (jsonrpc--process server)))) + (if (consp c) (mapconcat #'identity c " ") + "network"))])) (cl-reduce #'append (hash-table-values eglot--servers-by-project)))) (revert-buffer) @@ -4697,6 +5079,45 @@ If NOERROR, return predicate, else erroring function." (jit-lock-unregister #'eglot--update-hints) (eglot--delete-overlays 'eglot--inlay-hint)))) +(defvar eglot--momentary-hints-data (list nil nil nil 0 nil)) + +(defun eglot-momentary-inlay-hints () + "Display inlay hints while holding down a key. +Emacs doesn't support binding to \"key up\" events, but this function +offers an approximation. When bound to a key it will arrange for inlay +hints to be displayed as long as the key is held down, and then hidden +shortly after it is released. This relies on measuring your keyboard +initial delay and repeat rate, and may not be 100% accurate." + (interactive) + (when eglot-inlay-hints-mode + (eglot-inlay-hints-mode -1)) + (cl-symbol-macrolet + ((timer (nth 0 eglot--momentary-hints-data)) + (initial-delay (nth 1 eglot--momentary-hints-data)) + (repeat-delay (nth 2 eglot--momentary-hints-data)) + (calls (nth 3 eglot--momentary-hints-data)) + (last-call-time (nth 4 eglot--momentary-hints-data))) + (cl-incf calls) + (cl-flet ((runit (delay) + (setf timer + (run-at-time (+ 0.1 delay) + nil (lambda () + (dolist (o (overlays-in (point-min) (point-max))) + (when (overlay-get o 'eglot--inlay-hint) + (delete-overlay o))) + (setf timer nil calls 0))) + last-call-time (float-time)))) + (cond ((timerp timer) + (when (and (not initial-delay) (= calls 2)) + (setf initial-delay (- (float-time) last-call-time))) + (when (and (not repeat-delay) (= calls 3)) + (setf repeat-delay (- (float-time) last-call-time))) + (cancel-timer timer) + (runit (or repeat-delay 0.5))) + (t + (eglot--update-hints-1 (window-start) (window-end)) + (runit (or initial-delay 1.0))))))) + ;;; Semantic tokens (defmacro eglot--semtok-define-things () @@ -4793,14 +5214,13 @@ See `eglot--semtok-request' implementation for details.") (defun eglot--semtok-after-send-changes () ;; (trace-values "Dispatching") - (setf (plist-get eglot--semtok-state :dispatched) t)) + (setf (cl-getf eglot--semtok-state :dispatched) t)) (cl-defun eglot--semtok-request (beg end &aux (docver eglot--docver)) "Ask for tokens. Arrange for BEG..END to be font-lock flushed." - (cl-macrolet ((c (tag) `(plist-get eglot--semtok-state ,tag))) + (cl-macrolet ((c (tag) `(cl-getf eglot--semtok-state ,tag))) (cl-labels - ((req (method &optional params cont - &aux (buf (current-buffer))) + ((req (method &optional params cont) (setf (c :req-docver) docver (c :orig-docver) docver (c :dispatched) (not eglot--recent-changes) @@ -4811,22 +5231,21 @@ See `eglot--semtok-request' implementation for details.") (append (nconc params `(:textDocument ,(eglot--TextDocumentIdentifier)))) :success-fn (lambda (response) - (eglot--when-live-buffer buf - ;; (trace-values "Response" - ;; eglot--docver docver (c :orig-docver) (c :req-docver)) - ;; This skip is different from the one below. Comparing - ;; the lexical `docver' to the original request's - ;; `:orig-docver' allows skipping the outdated response - ;; of a dispatched request that has been overridden by - ;; another (perhaps not dispatched yet) request. - (when (eq docver (c :orig-docver)) - (setf (c :docver) (c :req-docver) - (c :data) (if cont (funcall cont response) - (plist-get response :data)) - (c :resultId) (plist-get response :resultId)) - ;; (trace-values "Flushing" (length (c :regions)) "regions") - (cl-loop for (a . b) in (c :regions) do (font-lock-flush a b)) - (setf (c :regions) nil)))) + ;; (trace-values "Response" + ;; eglot--docver docver (c :orig-docver) (c :req-docver)) + ;; This skip is different from the one below. Comparing + ;; the lexical `docver' to the original request's + ;; `:orig-docver' allows skipping the outdated response + ;; of a dispatched request that has been overridden by + ;; another (perhaps not dispatched yet) request. + (when (eq docver (c :orig-docver)) + (setf (c :docver) (c :req-docver) + (c :data) (if cont (funcall cont response) + (plist-get response :data)) + (c :resultId) (plist-get response :resultId)) + ;; (trace-values "Flushing" (length (c :regions)) "regions") + (cl-loop for (a . b) in (c :regions) do (font-lock-flush a b)) + (setf (c :regions) nil))) :hint 'semtok))) ;; Skip actually making the request if there's an undispatched ;; waiting for a eglot--send-changes-hook flush. Just update the @@ -4901,12 +5320,12 @@ lock machinery calls us again." (with-silent-modifications (save-excursion (cl-loop - initially (goto-char beg) - for match = (text-property-search-forward 'eglot--semtok-faces) - while (and match (< (point) end)) - do (dolist (f (prop-match-value match)) - (add-face-text-property - (prop-match-beginning match) (prop-match-end match) f))))))) + for from = beg then to + while (< from end) + for faces = (get-text-property from 'eglot--semtok-faces) + for to = (or (next-single-property-change from 'eglot--semtok-faces nil end) end) + when faces + do (dolist (f faces) (add-face-text-property from to f))))))) ;;; Call and type hierarchies diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 13106ee6885..c4fb6946aeb 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -1249,17 +1249,13 @@ functions are annotated with \"\" via the (defun elisp--xref-backend () 'elisp) -;; WORKAROUND: This is nominally a constant, but the text properties -;; are not preserved thru dump if use defconst. See bug#21237. -(defvar elisp--xref-format - #("(%s %s)" +(defconst elisp--xref-format + #("(%S %S)" 1 3 (face font-lock-keyword-face) 4 6 (face font-lock-function-name-face))) -;; WORKAROUND: This is nominally a constant, but the text properties -;; are not preserved thru dump if use defconst. See bug#21237. -(defvar elisp--xref-format-extra - #("(%s %s %s)" +(defconst elisp--xref-format-extra + #("(%S %S %S)" 1 3 (face font-lock-keyword-face) 4 6 (face font-lock-function-name-face))) @@ -1539,22 +1535,28 @@ namespace but with lower confidence." ;; defined in C; the doc strings from the C source have ;; not been loaded yet. Second call will return "src/*.c" ;; in file; handled by t case below. - (push (elisp--xref-make-xref nil symbol (help-C-file-name (symbol-function symbol) 'subr)) xrefs)) + (push (elisp--xref-make-xref + nil symbol (help-C-file-name (symbol-function symbol) + 'subr)) + xrefs)) ((and (setq doc (documentation symbol t)) ;; This doc string is defined in cl-macs.el cl-defstruct - (string-match "Constructor for objects of type `\\(.*\\)'" doc)) + ;; FIXME: This is hideously brittle! + (string-match "Constructor for objects of type `\\(.*\\)'" + doc)) ;; `symbol' is a name for the default constructor created by ;; cl-defstruct, so return the location of the cl-defstruct. (let* ((type-name (match-string 1 doc)) (type-symbol (intern type-name)) - (file (find-lisp-object-file-name type-symbol 'define-type)) + (file (find-lisp-object-file-name + type-symbol 'define-type)) (summary (format elisp--xref-format-extra - 'cl-defstruct - (concat "(" type-name) - (concat "(:constructor " (symbol-name symbol) "))")))) - (push (elisp--xref-make-xref 'define-type type-symbol file summary) xrefs) - )) + 'cl-defstruct type-symbol + `(:constructor ,symbol)))) + (push (elisp--xref-make-xref 'define-type type-symbol + file summary) + xrefs))) ((setq generic (cl--generic symbol)) ;; FIXME: move this to elisp-xref-find-def-functions, in cl-generic.el @@ -1585,22 +1587,28 @@ namespace but with lower confidence." ;; Default method has all t in specializers. (setq non-default (or non-default (not (equal t item))))) - (when (and file - (or non-default - (nth 2 info))) ;; assuming only co-located default has null doc string + ;; Assuming only co-located default has null doc string + (when (and file (or non-default (nth 2 info))) (if specializers - (let ((summary (format elisp--xref-format-extra 'cl-defmethod symbol (nth 1 info)))) - (push (elisp--xref-make-xref 'cl-defmethod met-name file summary) xrefs)) + (let ((summary (format elisp--xref-format-extra + 'cl-defmethod symbol + (nth 1 info)))) + (push (elisp--xref-make-xref 'cl-defmethod met-name + file summary) + xrefs)) - (let ((summary (format elisp--xref-format-extra 'cl-defmethod symbol "()"))) - (push (elisp--xref-make-xref 'cl-defmethod met-name file summary) xrefs)))) + (let ((summary (format elisp--xref-format-extra + 'cl-defmethod symbol ()))) + (push (elisp--xref-make-xref 'cl-defmethod met-name + file summary) + xrefs)))) )) - (if (and (setq doc (documentation symbol t)) - ;; This doc string is created somewhere in - ;; cl--generic-make-function for an implicit - ;; defgeneric. - (string-match "\n\n(fn ARG &rest ARGS)" doc)) + ;; FIXME: We rely on the fact that `cl-defgeneric' sets + ;; a `function-documentation' property (via the third arg of + ;; `defalias'), whereas implicit declaration of a generic via + ;; `cl-defmethod' doesn't. + (if (null (get symbol 'function-documentation)) ;; This symbol is an implicitly defined defgeneric, so ;; don't return it. nil @@ -2238,7 +2246,6 @@ Intended for `eldoc-documentation-functions' (which see)." (defcustom elisp-eldoc-docstring-length-limit 1000 "Maximum length of doc strings displayed by elisp ElDoc functions." :type 'natnum - :group 'elisp :version "31.1") (defcustom elisp-eldoc-funcall-with-docstring-length 'short @@ -2248,7 +2255,6 @@ Otherwise if set to `full', display full doc string." :type '(choice (const :tag "Short" short) (const :tag "Full" full)) - :group 'elisp :version "31.1") (defun elisp-eldoc-funcall-with-docstring (callback &rest _ignored) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index ec71f353ee3..f73bdadef72 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -695,12 +695,12 @@ region is invalid. This function saves match data." (defvar flymake-diagnostic-functions nil "Special hook of Flymake backends that check a buffer. -The functions in this hook diagnose problems in a buffer's -contents and provide information to the Flymake user interface -about where and how to annotate problems diagnosed in a buffer. +The functions in this hook diagnose problems in a buffer's contents and +provide information to the Flymake user interface about where and how to +annotate problems diagnosed in a buffer. -Each backend function must be prepared to accept an arbitrary -number of arguments: +Each backend function must be prepared to accept an arbitrary number of +arguments: * the first argument is always REPORT-FN, a callback function detailed below; @@ -710,74 +710,72 @@ number of arguments: Currently, Flymake may provide these keyword-value pairs: -* `:recent-changes', a list of recent changes since the last time - the backend function was called for the buffer. An empty list - indicates that no changes have been recorded. If it is the - first time that this backend function is called for this - activation of `flymake-mode', then this argument isn't provided - at all (i.e. it's not merely nil). +* `:recent-changes', a list of recent changes since the last time the + backend function was called for the buffer. An empty list indicates + that no changes have been recorded. If it is the first time that this + backend function is called for this activation of `flymake-mode', then + this argument isn't provided at all (i.e. it's not merely nil). - Each element is in the form (BEG END TEXT) where BEG and END - are buffer positions, and TEXT is a string containing the text - contained between those positions (if any) after the change was - performed. + Each element is in the form (BEG END TEXT) where BEG and END are + buffer positions, and TEXT is a string containing the text contained + between those positions (if any) after the change was performed. -* `:changes-start' and `:changes-end', the minimum and maximum - buffer positions touched by the recent changes. These are only - provided if `:recent-changes' is also provided. +* `:changes-start' and `:changes-end', the minimum and maximum buffer + positions touched by the recent changes. These are only provided if + `:recent-changes' is also provided. -Whenever Flymake or the user decides to re-check the buffer, -backend functions are called as detailed above and are expected -to initiate this check, but aren't required to complete it before -exiting: if the computation involved is expensive, especially for -large buffers, that task can be scheduled for the future using -asynchronous processes or other asynchronous mechanisms. +Whenever Flymake or the user decides to re-check the buffer, backend +functions are called as detailed above and are expected to initiate this +check, but aren't required to complete it before exiting: if the +computation involved is expensive, especially for large buffers, that +task can be scheduled for the future using asynchronous processes or +other asynchronous mechanisms. -In any case, backend functions are expected to return quickly or -signal an error, in which case the backend is disabled. Flymake -will not try disabled backends again for any future checks of -this buffer. To reset the list of disabled backends, turn -`flymake-mode' off and on again, or interactively call -`flymake-start' with a prefix argument. +In any case, backend functions are expected to return quickly or signal +an error, in which case the backend is disabled. Flymake will not try +disabled backends again for any future checks of this buffer. To reset +the list of disabled backends, turn `flymake-mode' off and on again, or +interactively call `flymake-start' with a prefix argument. If the function returns, Flymake considers the backend to be -\"running\". If it has not done so already, the backend is -expected to call the function REPORT-FN with a single argument -REPORT-ACTION also followed by an optional list of keyword-value -pairs in the form (:REPORT-KEY VALUE :REPORT-KEY2 VALUE2...). +\"running\". If it has not done so already, the backend is expected to +call the function REPORT-FN with a single argument REPORT-ACTION also +followed by an optional list of keyword-value pairs in the +form (:REPORT-KEY VALUE :REPORT-KEY2 VALUE2...). Currently accepted values for REPORT-ACTION are: * A (possibly empty) list of diagnostic objects created with - `flymake-make-diagnostic', causing Flymake to delete all - previous diagnostic annotations in the buffer and create new - ones from this list. + `flymake-make-diagnostic', causing Flymake to delete all previous + diagnostic annotations in the buffer and create new ones from this + list. - A backend may call REPORT-FN repeatedly in this manner, but - only until Flymake considers that the most recently requested - buffer check is now obsolete because, say, buffer contents have - changed in the meantime. The backend is only given notice of - this via a renewed call to the backend function. Thus, to - prevent making obsolete reports and wasting resources, backend - functions should first cancel any ongoing processing from - previous calls. + A backend may call REPORT-FN repeatedly in this manner, but only until + Flymake considers that the most recently requested buffer check is now + obsolete because, say, buffer contents have changed in the meantime. + The backend is only given notice of this via a renewed call to the + backend function. Thus, to prevent making obsolete reports and + wasting resources, backend functions should first cancel any ongoing + processing from previous calls. -* The symbol `:panic', signaling that the backend has encountered - an exceptional situation and should be disabled. +* The symbol `:panic', signaling that the backend has encountered an + exceptional situation and should be disabled. Currently accepted REPORT-KEY arguments are: -* `:explanation' value should give user-readable details of - the situation encountered, if any. +* `:explanation' value should give user-readable details of the + situation encountered, if any. -* `:force': value should be a boolean suggesting that Flymake - consider the report even if it was somehow unexpected. +* `:force': value should be a boolean suggesting that Flymake consider + the report even if it was somehow unexpected. -* `:region': a cons (BEG . END) of buffer positions indicating - that the report applies to that region only. Specifically, - this means that Flymake will only delete diagnostic annotations - of past reports if they intersect the region by at least one - character.") +* `:region': a cons (BEG . END) of buffer positions specifying that + Flymake should only delete diagnostic annotations of past reports if + they intersect the region by at least one character. The list of + diagnostics objects in the report need not be contained in the region. + This makes it allows backends to choose between accumulating or + completely replacing diagnostics across different invocations of + REPORT-FN, by specifying a either 0-length region or the full buffer.") (put 'flymake-diagnostic-functions 'safe-local-variable #'null) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 4994a5a37ea..2174c8d7908 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -403,6 +403,20 @@ triggers in `gdb-handler-list'." (gdb-wait-for-pending func) (funcall func))))) +(defun gdb-start-wait-for-pending (var func) + "Start waiting for pending GDB commands with VAR and FUNC. +This calls `gdb-wait-for-pending' if there isn't already a timer waiting +for running the same FUNC, as indicated by a non-nil value of VAR. +VAR should be a symbol of a boolean variable. +The assumption is that when FUNC will be called, it will do the job for +all the events that need to run FUNC after the pending GDB commands are +finished. +FUNC should reset VAR to nil, so further events of the same kind will +be handled after FUNC exits." + (when (null (symbol-value var)) + (set var t) + (gdb-wait-for-pending func))) + ;; Publish-subscribe (defmacro gdb-add-subscriber (publisher subscriber) @@ -2638,6 +2652,9 @@ means to decode using the coding-system set for the GDB process." (defun gdb-ignored-notification (_token _output-field)) +(defvar gdb--update-threads-queued-p nil + "If non-nil, we already queued the `update-threads' signal.") + ;; gdb-invalidate-threads is defined to accept 'update-threads signal (defun gdb-thread-created (_token _output-field)) (defun gdb-thread-exited (_token output-field) @@ -2649,9 +2666,17 @@ Unset `gdb-thread-number' if current thread exited and update threads list." ;; When we continue current thread and it quickly exits, ;; the pending triggers in gdb-handler-list left after gdb-running ;; disallow us to properly call -thread-info without --thread option. - ;; Thus we need to use gdb-wait-for-pending. - (gdb-wait-for-pending - (lambda () (gdb-emit-signal gdb-buf-publisher 'update-threads))))) + ;; Thus we need to use gdb-wait-for-pending. But we should start + ;; waiting only once if we get a long series of =thread-exited + ;; notifications during the wait period, because otherwise we will + ;; flood the Emacs main loop with many timers. When the time + ;; expires, it will process all the threads that exited meanwhile, + ;; and the next =thread-exited notification will start a new wait. + (gdb-start-wait-for-pending + 'gdb--update-threads-queued-p + (lambda () + (setq gdb--update-threads-queued-p nil) + (gdb-emit-signal gdb-buf-publisher 'update-threads))))) (defun gdb-thread-selected (_token output-field) "Handler for =thread-selected MI output record. diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index a14bd9e357b..e0552b3a7b2 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -29,7 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (require 'compile) (defgroup grep nil diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index 0c665f2afdf..3043b04c5ad 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -169,13 +169,25 @@ ;; These variables help hideshow know what is considered a block, which ;; function to use to get the block positions, etc. ;; -;; A block is defined as text surrounded by `hs-block-start-regexp' and -;; `hs-block-end-regexp'. +;; A (code) block is defined as text surrounded by +;; `hs-block-start-regexp' and `hs-block-end-regexp'. ;; ;; For some major modes, forward-sexp does not work properly. In those ;; cases, `hs-forward-sexp-function' specifies another function to use ;; instead. +;; *** Non-regexp matching +;; +;; By default, Hideshow uses regular expressions to match blocks. For +;; something more advanced than regexp is necessary to modify these +;; variables (see their docstring): +;; - `hs-forward-sexp-function' +;; - `hs-find-block-beginning-function' +;; - `hs-find-next-block-function' +;; - `hs-looking-at-block-start-predicate' +;; - `hs-inside-comment-predicate' (For comments) +;; - `hs-block-end-regexp' (Preferably, this should be set to nil) +;; ;; *** Tree-sitter support ;; ;; All the treesit based modes already have support for hiding/showing @@ -616,24 +628,26 @@ Note that `mode-line-format' is buffer-local.") (defvar-local hs-block-start-regexp "\\s(" "Regexp for beginning of block.") -;; This is useless, so probably should be deprecated. (defvar-local hs-block-start-mdata-select 0 "Element in `hs-block-start-regexp' match data to consider as block start. -The internal function `hs-forward-sexp' moves point to the beginning of this -element (using `match-beginning') before calling `hs-forward-sexp-function'.") +This is used by `hs-block-positions' to move point to the beginning of +this element (using `match-beginning') before calling +`hs-forward-sexp-function'. + +This is used for regexp matching.") (defvar-local hs-block-end-regexp "\\s)" "Regexp for end of block. -As a special case, the value can be also a function without arguments to -determine if point is looking at the end of the block, and return -non-nil and set `match-data' to that block end positions.") +This is mostly used to determine if point is at the end of the block. + +As a special case, it can be nil (to use the position from +`hs-forward-sexp-function'), or a function without arguments. If it's a +function, it should return non-nil if point is at end of a block, and +set `match-data' to that position.") (defvar-local hs-c-start-regexp nil "Regexp for beginning of comments. -Differs from mode-specific comment regexps in that surrounding -whitespace is stripped. - -If not bound, hideshow will use current `comment-start' value without +If not bound, Hideshow will use current `comment-start' value without any trailing whitespace.") (define-obsolete-variable-alias @@ -641,13 +655,13 @@ any trailing whitespace.") 'hs-forward-sexp-function "31.1") (defvar-local hs-forward-sexp-function #'forward-sexp - "Function used to do a `forward-sexp'. -It is called with 1 argument (like `forward-sexp'). + "Function used to reposition point to the end of the region to hide. +For backward compatibility, the function is called with one argument, +which can be ignored. -Should change for Algol-ish modes. For single-character block -delimiters such as `(' and `)' `hs-forward-sexp-function' would just be -`forward-sexp'. For other modes such as simula, a more specialized -function is necessary.") +The function is called in front of the beginning of the block (usually the +current value of `hs-block-start-regexp' in the buffer) and should +reposition point to the end of the block.") (define-obsolete-variable-alias 'hs-adjust-block-beginning @@ -655,22 +669,23 @@ function is necessary.") (defvar-local hs-adjust-block-beginning-function nil "Function used to tweak the block beginning. -It should return the position from where we should start hiding, as -opposed to hiding it from the position returned when searching for -`hs-block-start-regexp'. +It is called at the beginning of the block (usually the current value of +`hs-block-start-regexp' in the buffer) and should return the start +position of the region in the buffer that will be hidden. It is called with a single argument ARG which is the position in buffer after the block beginning.") (defvar-local hs-adjust-block-end-function nil "Function used to tweak the block end. +It is called at the end of the block with one argument, the start +position of the region in the buffer that will be hidden. It should +return either the last position to hide or nil. If it returns nil, +Hideshow will guess the end position. + This is useful to ensure some characters such as parenthesis or curly braces get properly hidden in modes without parenthesis pairs -delimiters (such as python). - -It is called with one argument, which is the start position where the -overlay will be created, and should return either the last position to -hide or nil. If it returns nil, hideshow will guess the end position.") +delimiters (such as python).") (define-obsolete-variable-alias 'hs-find-block-beginning-func @@ -679,13 +694,9 @@ hide or nil. If it returns nil, hideshow will guess the end position.") (defvar-local hs-find-block-beginning-function #'hs-find-block-beg-fn--default - "Function used to do `hs-find-block-beginning'. -It should reposition point at the beginning of the current block -and return point, or nil if original point was not in a block. - -Specifying this function is necessary for languages such as -Python, where regexp search and `syntax-ppss' check is not enough -to find the beginning of the current block.") + "Function used to reposition point at the beginning of current block. +If it finds the block beginning, it should reposition point there and +return non-nil, otherwise it should return nil.") (define-obsolete-variable-alias 'hs-find-next-block-func @@ -694,20 +705,20 @@ to find the beginning of the current block.") (defvar-local hs-find-next-block-function #'hs-find-next-block-fn--default - "Function used to do `hs-find-next-block'. + "Function to find the start of the next block. It should reposition point at next block start. -It is called with three arguments REGEXP, BOUND, and COMMENTS. REGEXP -is a regexp representing block start. When block start is found, -`match-data' should be set using REGEXP. BOUND is a buffer position -that limits the search. When COMMENTS is non-nil, REGEXP matches not -only beginning of a block but also beginning of a comment. In this -case, the function should find nearest block or comment and return -non-nil. +It is called with three arguments REGEXP, BOUND, and COMMENTS. -Specifying this function is necessary for languages such as Python, -where regexp search is not enough to find the beginning of the next -block.") +REGEXP is a regexp representing block start. When block start is found, +should set the match data according to the beginning position of the +matched REGEXP or block start position. + +BOUND is a buffer position that limits the search. + +When COMMENTS is non-nil, REGEXP matches not only beginning of a block +but also beginning of a comment. In this case, the function should find +the nearest block or comment and return non-nil.") (define-obsolete-variable-alias 'hs-looking-at-block-start-p-func @@ -716,16 +727,13 @@ block.") (defvar-local hs-looking-at-block-start-predicate #'hs-looking-at-block-start-p--default - "Function used to do `hs-looking-at-block-start-p'. -It should return non-nil if the point is at the block start and set -match data with the beginning and end of that position. - -Specifying this function is necessary for languages such as -Python, where `looking-at' and `syntax-ppss' check is not enough -to check if the point is at the block start.") + "Function used to check if point is at the block start. +It should return non-nil if point is at the block start and modify the +match data to the block beginning start and end positions (specifically, +for `match-end').") (defvar-local hs-inside-comment-predicate #'hs-inside-comment-p--default - "Function used to check if point is inside a comment. + "Function used to get comment positions. If point is inside a comment, the function should return a list containing the buffer position of the start and the end of the comment, otherwise it should return nil.") @@ -802,21 +810,24 @@ point. If either ADJUST-BEG or ADJUST-END are non-nil, adjust block positions according to `hs-adjust-block-beginning', `hs-adjust-block-end-function' -and `hs-block-end-regexp'." +and `hs-block-end-regexp'. + +This is for code block positions only, for comments use +`hs-inside-comment-predicate'." ;; `catch' is used here if the search fails due unbalanced parentheses ;; or any other unknown error caused in `hs-forward-sexp-function'. (catch 'hs--block-exit (save-match-data (save-excursion (when (funcall hs-looking-at-block-start-predicate) - (let ((beg (match-end 0)) end) - ;; `beg' is the point at the end of the block - ;; beginning, which may need to be adjusted + (let* ((beg (match-end 0)) end) + ;; `beg' is the point at the block beginning, which may need + ;; to be adjusted (when adjust-beg + (setq beg (pos-eol)) (save-excursion (when hs-adjust-block-beginning-function - (goto-char (funcall hs-adjust-block-beginning-function beg))) - (setq beg (pos-eol)))) + (goto-char (funcall hs-adjust-block-beginning-function beg))))) (goto-char (match-beginning hs-block-start-mdata-select)) (condition-case _ @@ -1146,7 +1157,7 @@ property of an overlay." (overlay-put ov 'invisible (and hide-p 'hs))) (defun hs-looking-at-block-start-p--default () - "Return non-nil if the point is at the block start." + "Return non-nil if point is at the block start." (and (looking-at hs-block-start-regexp) (save-match-data (not (nth 8 (syntax-ppss)))))) @@ -1262,7 +1273,7 @@ Return point, or nil if original point was not in a block." ;; look backward for the start of a block that contains the cursor (save-excursion (while (and (re-search-backward hs-block-start-regexp nil t) - (goto-char (match-beginning hs-block-start-mdata-select)) + (goto-char (match-beginning 0)) ;; go again if in a comment or a string (or (save-match-data (nth 8 (syntax-ppss))) (not (setq done (and (<= here (cadr (hs-block-positions))) @@ -1487,36 +1498,38 @@ Key bindings: :keymap hs-minor-mode-map (setq hs-headline nil) - (if hs-minor-mode - (progn - (unless (and comment-start comment-end) - (setq hs-minor-mode nil) - (user-error "%S doesn't support the Hideshow minor mode" - major-mode)) + (cond + ((and hs-minor-mode + (not (and comment-start comment-end))) + (setq hs-minor-mode nil) + (message "%S doesn't support the Hideshow minor mode" + major-mode)) - ;; Set the old variables - (hs-grok-mode-type) - ;; Turn off this mode if we change major modes. - (add-hook 'change-major-mode-hook - #'turn-off-hideshow nil t) - (setq-local line-move-ignore-invisible t) - (add-to-invisibility-spec '(hs . t)) - ;; Add block indicators - (when (and hs-show-indicators - (or (and (integerp hs-indicator-maximum-buffer-size) - (< (buffer-size) hs-indicator-maximum-buffer-size)) - (not hs-indicator-maximum-buffer-size))) - (when (and (not (display-graphic-p)) - (eq hs-indicator-type 'fringe)) - (setq-local hs-indicator-type 'margin)) - (when (eq hs-indicator-type 'margin) - (setq-local left-margin-width (1+ left-margin-width)) - (setq-local fringes-outside-margins t) - ;; Force display of margins - (when (eq (current-buffer) (window-buffer)) - (set-window-buffer nil (window-buffer)))) - (jit-lock-register #'hs--add-indicators))) + (hs-minor-mode + ;; Set the old variables + (hs-grok-mode-type) + ;; Turn off this mode if we change major modes. + (add-hook 'change-major-mode-hook + #'turn-off-hideshow nil t) + (setq-local line-move-ignore-invisible t) + (add-to-invisibility-spec '(hs . t)) + ;; Add block indicators + (when (and hs-show-indicators + (or (and (integerp hs-indicator-maximum-buffer-size) + (< (buffer-size) hs-indicator-maximum-buffer-size)) + (not hs-indicator-maximum-buffer-size))) + (when (and (not (display-graphic-p)) + (eq hs-indicator-type 'fringe)) + (setq-local hs-indicator-type 'margin)) + (when (eq hs-indicator-type 'margin) + (setq-local left-margin-width (1+ left-margin-width)) + (setq-local fringes-outside-margins t) + ;; Force display of margins + (when (eq (current-buffer) (window-buffer)) + (set-window-buffer nil (window-buffer)))) + (jit-lock-register #'hs--add-indicators))) + (t (remove-from-invisibility-spec '(hs . t)) (remove-overlays nil nil 'hs-indicator t) (remove-overlays nil nil 'invisible 'hs) @@ -1528,7 +1541,7 @@ Key bindings: (kill-local-variable 'fringes-outside-margins) ;; Force removal of margins (when (eq (current-buffer) (window-buffer)) - (set-window-buffer nil (window-buffer))))))) + (set-window-buffer nil (window-buffer)))))))) ;;;; that's it diff --git a/lisp/progmodes/json-ts-mode.el b/lisp/progmodes/json-ts-mode.el index 0f9f4f4f6a7..cd4cb468095 100644 --- a/lisp/progmodes/json-ts-mode.el +++ b/lisp/progmodes/json-ts-mode.el @@ -128,6 +128,60 @@ Return nil if there is no name or if NODE is not a defun node." t) "\"" "\"")))) +(defun json-ts--get-path-at-node (node) + "Get the path from the root of the JSON tree to NODE. +Return a list of keys (strings) and indices (numbers). +NODE is a tree-sitter node." + (let ((path nil) + (parent nil)) + (while (setq parent (treesit-node-parent node)) + (let ((type (treesit-node-type parent))) + (cond + ((equal type "array") + (push (treesit-node-index node t) path)) + ((equal type "pair") + (let ((key (treesit-node-child-by-field-name parent "key"))) + (push (treesit-node-text key t) path))))) + (setq node parent)) + path)) + +(defun json-ts--path-to-jq (path) + "Convert PATH list to a jq-style path string. +PATH is a list of keys (strings) and indices (numbers)." + (mapconcat + (lambda (x) + (cond + ((numberp x) (format "[%d]" x)) + ((stringp x) + (let ((key (string-trim x "\"" "\""))) + (if (string-match-p (rx bos (any alpha "_") (* (any alnum "_")) eos) key) + (format ".%s" key) + (format "[%S]" key)))) + (t ""))) + path + "")) + +(defun json-ts--path-to-python (path) + "Convert PATH list to a Python-style path string. +PATH is a list of keys (strings) and indices (numbers)." + (mapconcat + (lambda (x) + (cond + ((numberp x) (format "[%d]" x)) + ((stringp x) (format "[\"%s\"]" x)) + (t ""))) + path + "")) + +(defun json-ts-jq-path-at-point () + "Show the JSON path at point in jq format." + (interactive) + (if-let* ((node (treesit-node-at (point)))) + (let ((path (json-ts--path-to-jq (json-ts--get-path-at-node node)))) + (kill-new path) + (message "%s" path)) + (user-error "No JSON node at point"))) + ;;;###autoload (define-derived-mode json-ts-mode prog-mode "JSON" "Major mode for editing JSON, powered by tree-sitter." diff --git a/lisp/progmodes/lua-mode.el b/lisp/progmodes/lua-mode.el index 622adc1d29d..bc042599759 100644 --- a/lisp/progmodes/lua-mode.el +++ b/lisp/progmodes/lua-mode.el @@ -354,8 +354,8 @@ traceback location." ("string" . ("byte" "char" "dump" "find" "format" "gmatch" "gsub" "len" "lower" "match" "pack" "packsize" "rep" "reverse" "sub" "unpack" "upper")) - ("table" . ("concat" "insert" "maxn" "move" "pack" "remove" "sort" - "unpack")) + ("table" . ("concat" "create" "insert" "maxn" "move" "pack" "remove" + "sort" "unpack")) ("utf8" . ("char" "charpattern" "codepoint" "codes" "len" "offset"))))) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index d4a1f2a60b4..997c876b1fa 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1,7 +1,7 @@ ;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2026 Free Software Foundation, Inc. -;; Version: 0.11.1 +;; Version: 0.11.2 ;; Package-Requires: ((emacs "26.1") (xref "1.7.0")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -177,6 +177,7 @@ (require 'cl-generic) (require 'cl-lib) (require 'seq) +(require 'generator) (eval-when-compile (require 'subr-x)) (defgroup project nil @@ -591,7 +592,7 @@ See `project-vc-extra-root-markers' for the marker value format.") ;; FIXME: Learn to invalidate when the value changes: ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'. (or (vc-file-getprop dir 'project-vc) - ;; FIXME: Cache for a shorter time. + ;; FIXME: Cache for a shorter time (bug#78545). (let ((res (project-try-vc--search dir))) (and res (vc-file-setprop dir 'project-vc res)) res))) @@ -698,9 +699,7 @@ See `project-vc-extra-root-markers' for the marker value format.") (if backend (vc-call-backend backend 'project-list-files dir ignores) (project--files-in-directory - dir (append ignores (append - (project-ignores nil nil) - ignores)))))) + dir (append ignores (project-ignores nil nil)))))) (or dirs (list (project-root project))))) @@ -842,6 +841,7 @@ See `project-vc-extra-root-markers' for the marker value format.") (project--value-in-dir 'project-vc-ignores dir))) (defun project--vc-ignores (dir backend extra-ignores) + (require 'vc) (append (when backend (delq @@ -1595,6 +1595,11 @@ create it if it doesn't already exist." (declare-function fileloop-continue "fileloop" ()) +(iter-defun project--files-safe () + (dolist (file (project-files (project-current t))) + (when (file-regular-p file) + (iter-yield file)))) + ;;;###autoload (defun project-search (regexp) "Search for REGEXP in all the files of the project. @@ -1604,7 +1609,7 @@ command \\[fileloop-continue]." (interactive "sSearch (regexp): ") (fileloop-initialize-search regexp - (project-files (project-current t)) + (project--files-safe) 'default) (fileloop-continue)) @@ -1625,7 +1630,7 @@ If you exit the `query-replace', you can later continue the (list from to)))) (fileloop-initialize-replace from to - (project-files (project-current t)) + (project--files-safe) 'default) (fileloop-continue)) @@ -2629,13 +2634,37 @@ would otherwise have the same name." ;;; Project mode-line +(defvar project-name-cache-timeout 300 + "Number of seconds to cache the project name. +Used by `project-name-cached'.") + +(defun project-name-cached (dir) + "Return the cached project name for the directory DIR. +Until it's cached, retrieve the project name using `project-current' +and `project-name', then put the name to the cache for the time defined +by the variable `project-name-cache-timeout'. This function is useful +for project indicators such as on the mode line." + (let ((cached (vc-file-getprop dir 'project-name)) + (current-time (float-time))) + (if (and cached (< (- current-time (cdr cached)) + project-name-cache-timeout)) + (let ((value (car cached))) + (if (eq value 'none) nil value)) + (let ((res (when-let* ((project (project-current nil dir))) + (project-name project)))) + (vc-file-setprop dir 'project-name (cons (or res 'none) current-time)) + res)))) + ;;;###autoload (defcustom project-mode-line nil "Whether to show current project name and Project menu on the mode line. This feature requires the presence of the following item in `mode-line-format': `(project-mode-line project-mode-line-format)'; it -is part of the default mode line beginning with Emacs 30." - :type 'boolean +is part of the default mode line beginning with Emacs 30. When the +value is `non-remote', show the project name only for local files." + :type '(choice (const :tag "Don't show project on mode line" nil) + (const :tag "Show project only for local files" non-remote) + (const :tag "Always show project on mode line" t)) :group 'project :version "30.1") @@ -2653,18 +2682,20 @@ is part of the default mode line beginning with Emacs 30." (defun project-mode-line-format () "Compose the project mode-line." - (when-let* ((project (project-current))) + (unless (and (eq project-mode-line 'non-remote) + (file-remote-p default-directory)) ;; Preserve the global value of 'last-coding-system-used' ;; that 'write-region' needs to set for 'basic-save-buffer', ;; but updating the mode line might occur at the same time ;; during saving the buffer and 'project-name' can change ;; 'last-coding-system-used' when reading the project name ;; from .dir-locals.el also enables flyspell-mode (bug#66825). - (let ((last-coding-system-used last-coding-system-used)) + (when-let* ((last-coding-system-used last-coding-system-used) + (project-name (project-name-cached default-directory))) (concat " " (propertize - (project-name project) + project-name 'face project-mode-line-face 'mouse-face 'mode-line-highlight 'help-echo "mouse-1: Project menu" diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 1161edfcc32..b6981c9156c 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -3694,13 +3694,18 @@ def __PYTHON_EL_eval(source, filename): (defconst python-shell-eval-file-setup-code "\ def __PYTHON_EL_eval_file(filename, tempname, delete): - import codecs, os, re + import os, re, sys + if sys.version_info.major < 3: + import codecs + _open = codecs.open + else: + _open = open pattern = r'^[ \t\f]*#.*?coding[:=][ \t]*([-_.a-zA-Z0-9]+)' - with codecs.open(tempname or filename, encoding='latin-1') as file: + with _open(tempname or filename, encoding='latin-1') as file: match = re.match(pattern, file.readline()) match = match or re.match(pattern, file.readline()) encoding = match.group(1) if match else 'utf-8' - with codecs.open(tempname or filename, encoding=encoding) as file: + with _open(tempname or filename, encoding=encoding) as file: source = file.read().encode(encoding) if delete and tempname: os.remove(tempname) @@ -3811,6 +3816,16 @@ variable. (compilation-shell-minor-mode 1) (python-pdbtrack-setup-tracking)) +(defvar-local python-shell--process-cache) +(defvar-local python-shell--process-cache-valid) + +(defun python-shell--invalidate-process-cache () + "Invalidate process cache." + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (setq python-shell--process-cache nil + python-shell--process-cache-valid nil)))) + (defun python-shell-make-comint (cmd proc-name &optional show internal) "Create a Python shell comint buffer. CMD is the Python command to be executed and PROC-NAME is the @@ -3827,6 +3842,7 @@ killed." (let* ((proc-buffer-name (format (if (not internal) "*%s*" " *%s*") proc-name))) (when (not (comint-check-proc proc-buffer-name)) + (python-shell--invalidate-process-cache) (let* ((cmdlist (split-string-and-unquote cmd)) (interpreter (car cmdlist)) (args (cdr cmdlist)) @@ -3950,7 +3966,15 @@ If current buffer is in `inferior-python-mode', return it." (defun python-shell-get-process () "Return inferior Python process for current buffer." - (get-buffer-process (python-shell-get-buffer))) + (unless (and python-shell--process-cache-valid + (or (not python-shell--process-cache) + (and (process-live-p python-shell--process-cache) + (buffer-live-p + (process-buffer python-shell--process-cache))))) + (setq python-shell--process-cache + (get-buffer-process (python-shell-get-buffer)) + python-shell--process-cache-valid t)) + python-shell--process-cache) (defun python-shell-get-process-or-error (&optional interactivep) "Return inferior Python process for current buffer or signal error. @@ -4509,6 +4533,13 @@ def __PYTHON_EL_get_completions(text): "Code used to setup completion in inferior Python processes." :type 'string) +(defun python-shell-completion-send-setup-code () + "Send `python-shell-completion-setup-code' to inferior Python process." + (python-shell-send-string-no-output python-shell-completion-setup-code)) + +(add-hook 'python-shell-first-prompt-hook + #'python-shell-completion-send-setup-code) + (define-obsolete-variable-alias 'python-shell-completion-module-string-code 'python-shell-completion-string-code @@ -4837,12 +4868,16 @@ With argument MSG show activation/deactivation message." (defun python-shell-completion-get-completions (process input) "Get completions of INPUT using PROCESS." (with-current-buffer (process-buffer process) - (python--parse-json-array - (python-shell-send-string-no-output - (format "%s\nprint(__PYTHON_EL_get_completions(%s))" - python-shell-completion-setup-code - (python-shell--encode-string input)) - process)))) + (let ((completions + (python-shell-send-string-no-output + (format "print(__PYTHON_EL_get_completions(%s))" + (python-shell--encode-string input)) + process))) + (condition-case nil + (python--parse-json-array completions) + (json-parse-error + (python--parse-json-array + (car (last (split-string completions "[\n\r]+" t))))))))) (defun python-shell--get-multiline-input () "Return lines at a multi-line input in Python shell." @@ -7450,7 +7485,8 @@ implementations: `python-mode' and `python-ts-mode'." (treesit-major-mode-setup) ;; Enable the `sexp' navigation by default (setq-local forward-sexp-function #'treesit-forward-sexp - treesit-sexp-thing 'sexp) + treesit-sexp-thing 'sexp + treesit-sexp-thing-down-list 'list) (when (>= emacs-major-version 31) (setq-local hs-treesit-things '(or defun sexp)) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 31cbe274f47..a82a7884e40 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -2599,45 +2599,80 @@ you define your own `sql-mode-mysql-font-lock-keywords'.") '("^[.].*$" . font-lock-doc-face) ;; SQLite Keyword + ;; https://sqlite.org/lang_keywords.html (sql-font-lock-keywords-builder 'font-lock-keyword-face nil -"abort" "action" "add" "after" "all" "alter" "analyze" "and" "as" -"asc" "attach" "autoincrement" "before" "begin" "between" "by" -"cascade" "case" "cast" "check" "collate" "column" "commit" "conflict" -"constraint" "create" "cross" "database" "default" "deferrable" -"deferred" "delete" "desc" "detach" "distinct" "drop" "each" "else" -"end" "escape" "except" "exclusive" "exists" "explain" "fail" "for" -"foreign" "from" "full" "glob" "group" "having" "if" "ignore" -"immediate" "in" "index" "indexed" "initially" "inner" "insert" -"instead" "intersect" "into" "is" "isnull" "join" "key" "left" "like" -"limit" "match" "natural" "no" "not" "notnull" "null" "of" "offset" -"on" "or" "order" "outer" "plan" "pragma" "primary" "query" "raise" -"references" "regexp" "reindex" "release" "rename" "replace" -"restrict" "right" "rollback" "row" "savepoint" "select" "set" "table" -"temp" "temporary" "then" "to" "transaction" "trigger" "union" -"unique" "update" "using" "vacuum" "values" "view" "virtual" "when" -"where" +"abort" "action" "add" "after" "all" "alter" "always" "analyze" "and" "as" +"asc" "attach" "autoincrement" "before" "begin" "between" "by" "cascade" "case" +"cast" "check" "collate" "column" "commit" "conflict" "constraint" "create" +"cross" "current" "current_date" "current_time" "current_timestamp" "database" +"default" "deferrable" "deferred" "delete" "desc" "detach" "distinct" "do" +"drop" "each" "else" "end" "escape" "except" "exclude" "exclusive" "exists" +"explain" "fail" "filter" "first" "following" "for" "foreign" "from" "full" +"generated" "glob" "group" "groups" "having" "if" "ignore" "immediate" "in" +"index" "indexed" "initially" "inner" "insert" "instead" "intersect" "into" +"is" "isnull" "join" "key" "last" "left" "like" "limit" "match" "materialized" +"natural" "no" "not" "nothing" "notnull" "null" "nulls" "of" "offset" "on" "or" +"order" "others" "outer" "over" "partition" "plan" "pragma" "preceding" +"primary" "query" "raise" "range" "recursive" "references" "regexp" "reindex" +"release" "rename" "replace" "restrict" "returning" "right" "rollback" "row" +"rows" "savepoint" "select" "set" "table" "temp" "temporary" "then" "ties" "to" +"transaction" "trigger" "unbounded" "union" "unique" "update" "using" "vacuum" +"values" "view" "virtual" "when" "where" "window" "with" "without" ) ;; SQLite Data types + ;; https://sqlite.org/datatype3.html (sql-font-lock-keywords-builder 'font-lock-type-face nil -"int" "integer" "tinyint" "smallint" "mediumint" "bigint" "unsigned" -"big" "int2" "int8" "character" "varchar" "varying" "nchar" "native" -"nvarchar" "text" "clob" "blob" "real" "double" "precision" "float" -"numeric" "number" "decimal" "boolean" "date" "datetime" +"int" "integer" "tinyint" "smallint" "mediumint" "bigint" "unsigned big int" +"int2" "int8" "character" "varchar" "varying character" "nchar" +"native character" "nvarchar" "text" "clob" "blob" "real" "double" +"double precision" "float" "umeric" "decimal" "boolean" "date" "datetime" + ) ;; SQLite Functions (sql-font-lock-keywords-builder 'font-lock-builtin-face nil + ;; Core functions -"abs" "changes" "coalesce" "glob" "ifnull" "hex" "last_insert_rowid" -"length" "like" "load_extension" "lower" "ltrim" "max" "min" "nullif" -"quote" "random" "randomblob" "replace" "round" "rtrim" "soundex" -"sqlite_compileoption_get" "sqlite_compileoption_used" -"sqlite_source_id" "sqlite_version" "substr" "total_changes" "trim" -"typeof" "upper" "zeroblob" +;; https://sqlite.org/lang_corefunc.html +"abs" "changes" "char" "coalesce" "concat" "concat_ws" "format" "glob" "hex" +"if" "ifnull" "iif" "instr" "last_insert_rowid" "length" "like" "like" +"likelihood" "likely" "load_extension" "load_extension" "lower" "ltrim" "ltrim" +"max" "min" "nullif" "octet_length" "printf" "quote" "random" "randomblob" +"replace" "round" "round" "rtrim" "rtrim" "sign" "soundex" +"sqlite_compileoption_get" "sqlite_compileoption_used" "sqlite_offset" +"sqlite_source_id" "sqlite_version" "substr" "substr" "substring" "substring" +"total_changes" "trim" "trim" "typeof" "unhex" "unhex" "unicode" "unistr" +"unistr_quote" "unlikely" "upper" "zeroblob" + ;; Date/time functions -"time" "julianday" "strftime" -"current_date" "current_time" "current_timestamp" +;; https://sqlite.org/lang_datefunc.html +"date" "time" "datetime" "julianday" "unixepoch" "strftime" "timediff" + ;; Aggregate functions -"avg" "count" "group_concat" "max" "min" "sum" "total" +;; https://sqlite.org/lang_aggfunc.html +"avg" "count" "count" "group_concat" "group_concat" "max" "median" "min" +"percentile" "percentile_cont" "percentile_disc" "string_agg" "sum" "total" + +;; Window functions +;; https://sqlite.org/windowfunctions.html +"row_number" "rank" "dense_rank" "percent_rank" "cume_dist" "ntile" "lag" +"lead" "first_value" "last_value" "nth_value" + +;; Math functions +;; https://sqlite.org/lang_mathfunc.html +"acos" "acosh" "asin" "asinh" "atan" "atan2" "atanh" "ceil" "ceiling" "cos" +"cosh" "degrees" "exp" "floor" "ln" "log" "log" "log10" "log2" "mod" "pi" "pow" +"power" "radians" "sin" "sinh" "sqrt" "tan" "tanh" "trunc" + +;; JSON functions +;; https://sqlite.org/json1.html +"json" "jsonb" "json_array" "jsonb_array" "json_array_length" +"json_error_position" "json_extract" "jsonb_extract" "->" "->>" "json_insert" +"jsonb_insert" "json_object" "jsonb_object" "json_patch" "jsonb_patch" +"json_pretty" "json_remove" "jsonb_remove" "json_replace" "jsonb_replace" +"json_set" "jsonb_set" "json_type" "json_valid" "json_quote" "json_group_array" +"jsonb_group_array" "json_group_object" "jsonb_group_object" "json_each" +"json_tree" "jsonb_each" "jsonb_tree" + ))) "SQLite SQL keywords used by font-lock. diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index a25d3c24553..961d7b57fa4 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -9,7 +9,7 @@ ;; Keywords: languages ;; The "Version" is the date followed by the decimal rendition of the Git ;; commit hex. -;; Version: 2025.11.08.248496848 +;; Version: 2026.01.18.088738971 ;; Yoni Rabkin contacted the maintainer of this ;; file on 19/3/2008, and the maintainer agreed that when a bug is @@ -124,7 +124,7 @@ ;; ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2025-11-08-ecfc2d0-vpo-GNU" +(defconst verilog-mode-version "2026-01-18-54a0c9b-vpo-GNU" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -12283,9 +12283,10 @@ If PAR-VALUES replace final strings with these parameter values." auto-inst-vector auto-inst-vector-tpl tpl-net dflt-bits) - ;; Replace parameters in bit-width + ;; Replace parameters in vl-bits & vl-widths (when (and check-values - (not (equal vl-bits ""))) + (or (not (equal vl-bits "")) + (not (equal vl-width "")))) (while check-values (setq vl-bits (verilog-string-replace-matches (concat "\\<" (nth 0 (car check-values)) "\\>") diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 22797335b10..84a3fa4dfba 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -247,7 +247,9 @@ generic functions.") ;;;###autoload (defun xref-find-backend () - (run-hook-with-args-until-success 'xref-backend-functions)) + (or + (run-hook-with-args-until-success 'xref-backend-functions) + (user-error "No Xref backend available"))) (cl-defgeneric xref-backend-definitions (backend identifier) "Find definitions of IDENTIFIER. @@ -269,9 +271,7 @@ To create an xref object, call `xref-make'.") The result must be a list of xref objects. If no references can be found, return nil. -The default implementation uses `semantic-symref-tool-alist' to -find a search tool; by default, this uses \"find | grep\" in the -current project's main and external roots." +The default implementation uses `xref-references-in-directory'." (mapcan (lambda (dir) (message "Searching %s..." dir) @@ -1793,15 +1793,43 @@ and just use etags." (declare-function grep-expand-template "grep") (defvar ede-minor-mode) ;; ede.el +(defcustom xref-references-in-directory-function + #'xref-references-in-directory-semantic + "Function to find all references to a symbol in a directory. +It should take two string arguments: SYMBOL and DIR. +And return a list of xref values representing all code references to +SYMBOL in files under DIR." + :type '(choice + (const :tag "Using Grep via Find" xref-references-in-directory-grep) + (const :tag "Using Semantic Symbol Reference API" + xref-references-in-directory-semantic) + function) + :version "31.1") + ;;;###autoload (defun xref-references-in-directory (symbol dir) "Find all references to SYMBOL in directory DIR. +See `xref-references-in-directory-function' for the implementation. +Return a list of xref values." + (cl-assert (directory-name-p dir)) + (funcall xref-references-in-directory-function symbol dir)) + +(defun xref-references-in-directory-grep (symbol dir) + "Find all references to SYMBOL in directory DIR using find and grep. +Return a list of xref values. The files in DIR are filtered according +to its project's list of ignore patterns (as returned by +`project-ignores'), or the default ignores if there is no project." + (let ((ignores (project-ignores (project-current nil dir) dir))) + (xref-matches-in-directory (regexp-quote symbol) "*" dir ignores + 'symbol))) + +(defun xref-references-in-directory-semantic (symbol dir) + "Find all references to SYMBOL in directory DIR. Return a list of xref values. This function uses the Semantic Symbol Reference API, see `semantic-symref-tool-alist' for details on which tools are used, and when." - (cl-assert (directory-name-p dir)) (require 'semantic/symref) (defvar semantic-symref-tool) @@ -1831,12 +1859,13 @@ and when." "27.1") ;;;###autoload -(defun xref-matches-in-directory (regexp files dir ignores) +(defun xref-matches-in-directory (regexp files dir ignores &optional delimited) "Find all matches for REGEXP in directory DIR. Return a list of xref values. Only files matching some of FILES and none of IGNORES are searched. FILES is a string with glob patterns separated by spaces. -IGNORES is a list of glob patterns for files to ignore." +IGNORES is a list of glob patterns for files to ignore. +If DELIMITED is `symbol', only select matches that span full symbols." ;; DIR can also be a regular file for now; let's not advertise that. (grep-compute-defaults) (defvar grep-find-template) @@ -1855,6 +1884,9 @@ IGNORES is a list of glob patterns for files to ignore." (local-dir (directory-file-name (file-name-unquote (file-local-name (expand-file-name dir))))) + (hits-regexp (if (eq delimited 'symbol) + (format "\\_<%s\\_>" regexp) + regexp)) (buf (get-buffer-create " *xref-grep*")) (`(,grep-re ,file-group ,line-group . ,_) (car grep-regexp-alist)) (status nil) @@ -1864,20 +1896,9 @@ IGNORES is a list of glob patterns for files to ignore." (setq default-directory dir) (setq status (process-file-shell-command command nil t)) - (goto-char (point-min)) - ;; Can't use the exit status: Grep exits with 1 to mean "no - ;; matches found". Find exits with 1 if any of the invocations - ;; exit with non-zero. "No matches" and "Grep program not found" - ;; are all the same to it. - (when (and (/= (point-min) (point-max)) - (not (looking-at grep-re))) - (user-error "Search failed with status %d: %s" status (buffer-string))) - (while (re-search-forward grep-re nil t) - (push (list (string-to-number (match-string line-group)) - (concat local-dir (substring (match-string file-group) 1)) - (buffer-substring-no-properties (point) (line-end-position))) - hits))) - (xref--convert-hits (nreverse hits) regexp))) + (setq hits (xref--parse-hits grep-re line-group file-group status + local-dir))) + (xref--convert-hits (xref--sort-hits hits) hits-regexp))) (define-obsolete-function-alias 'xref-collect-matches @@ -2003,29 +2024,42 @@ to control which program to use when looking for matches." nil shell-command-switch command)))) - (goto-char (point-min)) - (when (and (/= (point-min) (point-max)) - (not (looking-at grep-re)) - ;; TODO: Show these matches as well somehow? - ;; Matching both Grep's and Ripgrep 13's messages. - (not (looking-at ".*[bB]inary file.* matches"))) - (user-error "Search failed with status %d: %s" status - (buffer-substring (point-min) (line-end-position)))) - (while (re-search-forward grep-re nil t) - (push (list (string-to-number (match-string line-group)) - (match-string file-group) - (buffer-substring-no-properties (point) (line-end-position))) - hits))) - ;; By default, ripgrep's output order is non-deterministic - ;; (https://github.com/BurntSushi/ripgrep/issues/152) - ;; because it does the search in parallel. - ;; Grep's output also comes out in seemingly arbitrary order, - ;; though stable one. Let's sort both for better UI. - (setq hits - (sort (nreverse hits) - (lambda (h1 h2) - (string< (cadr h1) (cadr h2))))) - (xref--convert-hits hits regexp))) + (setq hits (xref--parse-hits grep-re line-group file-group status))) + (xref--convert-hits (xref--sort-hits hits) regexp))) + +(defun xref--parse-hits ( grep-re line-group file-group status + &optional parent-dir) + (let (hits) + (goto-char (point-min)) + ;; Can't use the exit status: Grep exits with 1 to mean "no + ;; matches found". Find exits with 1 if any of the invocations + ;; exit with non-zero. "No matches" and "Grep program not found" + ;; are all the same to it. + (when (and (/= (point-min) (point-max)) + (not (looking-at grep-re)) + ;; TODO: Show these matches as well somehow? + ;; Matching both Grep's and Ripgrep 13's messages. + (not (looking-at ".*[bB]inary file.* matches"))) + (user-error "Search failed with status %d: %s" status + (buffer-substring (point-min) (line-end-position)))) + (while (re-search-forward grep-re nil t) + (push (list (string-to-number (match-string line-group)) + (if parent-dir + (concat parent-dir (substring (match-string file-group) 1)) + (match-string file-group)) + (buffer-substring-no-properties (point) (line-end-position))) + hits)) + (nreverse hits))) + +(defun xref--sort-hits (hits) + ;; By default, ripgrep's output order is non-deterministic + ;; (https://github.com/BurntSushi/ripgrep/issues/152) + ;; because it does the search in parallel. + ;; Grep's output also comes out in seemingly arbitrary order, + ;; though stable one. Let's sort both for better UI. + (sort hits + (lambda (h1 h2) + (string< (cadr h1) (cadr h2))))) (defun xref--process-file-region ( start end program &optional buffer display diff --git a/lisp/repeat.el b/lisp/repeat.el index 9ac72f50384..1b32558f426 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -591,14 +591,17 @@ This function can be used to force exit of repetition while it's active." (if-let* ((hint (and (symbolp cmd) (get cmd 'repeat-hint))) (last (aref key (1- (length key))))) - ;; Reuse `read-multiple-choice' formatting. - (if (= (length key) 1) + ;; Possibly reuse `read-multiple-choice' formatting. + (if (and (= (length key) 1) (characterp last)) (cdr (rmc--add-key-description (list last hint))) (format "%s (%s)" (propertize (key-description key) 'face 'read-multiple-choice-face) - (cdr (rmc--add-key-description - (list (event-basic-type last) hint))))) + (if (characterp (event-basic-type last)) + (cdr (rmc--add-key-description + (list (event-basic-type last) hint))) + hint))) + ;; No hint (propertize (key-description key) 'face 'read-multiple-choice-face)))) keys ", ") diff --git a/lisp/replace.el b/lisp/replace.el index 933249d824c..d8b27544128 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1878,6 +1878,9 @@ is not modified." (bound-and-true-p ido-everywhere)) (substitute-command-keys "(\\\\[ido-select-text] to end): ")) + ((bound-and-true-p icomplete-mode) + (substitute-command-keys + "(\\\\[icomplete-exit] to end): ")) ((bound-and-true-p fido-mode) (substitute-command-keys "(\\\\[icomplete-fido-exit] to end): ")) diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 3dc015f2c22..8297ab76443 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -391,7 +391,7 @@ may have changed) back to `save-place-alist'." coding-system-for-write)) (let ((print-length nil) (print-level nil)) - (pp save-place-alist (current-buffer))) + (prin1 save-place-alist (current-buffer))) (let ((version-control (cond ((null save-place-version-control) nil) diff --git a/lisp/scroll-bar.el b/lisp/scroll-bar.el index 09195ae6598..b9d1d3a441e 100644 --- a/lisp/scroll-bar.el +++ b/lisp/scroll-bar.el @@ -29,7 +29,6 @@ ;;; Code: (require 'mouse) -(eval-when-compile (require 'cl-lib)) ;;;; Utilities. diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el index 86d5ce1e383..7f4f5b56a1f 100644 --- a/lisp/shadowfile.el +++ b/lisp/shadowfile.el @@ -667,6 +667,12 @@ PAIR must be `eq' to one of the elements of that list." (setq shadow-files-to-copy (cl-remove-if (lambda (s) (eq s pair)) shadow-files-to-copy))) +(defun shadow-find-file-noselect (filename &optional nowarn) + "Like `find-file-noselect', but make buffer name ephemeral." + (with-current-buffer (find-file-noselect filename nowarn) + (rename-buffer (format " *%s*" (buffer-name))) + (current-buffer))) + (defun shadow-read-files () "Visit and load `shadow-info-file' and `shadow-todo-file'. Thus restores shadowfile's state from your last Emacs session. @@ -682,7 +688,9 @@ Return t unless files were locked; then return nil." (save-current-buffer (when shadow-info-file (set-buffer (setq shadow-info-buffer - (find-file-noselect shadow-info-file 'nowarn))) + (shadow-find-file-noselect shadow-info-file 'nowarn))) + (lisp-data-mode) + (setq-local lexical-binding t) (when (and (not (buffer-modified-p)) (file-newer-than-file-p (make-auto-save-file-name) shadow-info-file)) @@ -693,7 +701,9 @@ Return t unless files were locked; then return nil." (eval-buffer)) (when shadow-todo-file (set-buffer (setq shadow-todo-buffer - (find-file-noselect shadow-todo-file 'nowarn))) + (shadow-find-file-noselect shadow-todo-file 'nowarn))) + (lisp-data-mode) + (setq-local lexical-binding t) (when (and (not (buffer-modified-p)) (file-newer-than-file-p (make-auto-save-file-name) shadow-todo-file)) @@ -713,7 +723,8 @@ defined, the old hashtable info is invalid." (if shadow-info-file (save-current-buffer (if (not shadow-info-buffer) - (setq shadow-info-buffer (find-file-noselect shadow-info-file))) + (setq shadow-info-buffer + (shadow-find-file-noselect shadow-info-file))) (set-buffer shadow-info-buffer) (setq buffer-read-only nil) (delete-region (point-min) (point-max)) @@ -726,7 +737,8 @@ defined, the old hashtable info is invalid." With non-nil argument also saves the buffer." (save-excursion (if (not shadow-todo-buffer) - (setq shadow-todo-buffer (find-file-noselect shadow-todo-file))) + (setq shadow-todo-buffer + (shadow-find-file-noselect shadow-todo-file))) (set-buffer shadow-todo-buffer) (setq buffer-read-only nil) (delete-region (point-min) (point-max)) diff --git a/lisp/simple.el b/lisp/simple.el index d79aa2d3046..99930c3090c 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1638,15 +1638,14 @@ Note that on changing from non-nil to nil, the former contents of 'goto-line-history) buffer)))) -(defun goto-line (line &optional buffer relative) +(defun goto-line (line &optional buffer relative interactive) "Go to LINE, counting from line 1 at beginning of buffer. If called interactively, a numeric prefix argument specifies LINE; without a numeric prefix argument, read LINE from the minibuffer. -If optional argument BUFFER is non-nil, switch to that buffer and -move to line LINE there. If called interactively with \\[universal-argument] -as argument, BUFFER is the most recently selected other buffer. +If called interactively with \\[universal-argument], switch to the +most recently selected other buffer and move to line LINE there. If optional argument RELATIVE is non-nil, counting starts at the beginning of the accessible portion of the (potentially narrowed) buffer. @@ -1659,21 +1658,24 @@ Prior to moving point, this function sets the mark (without activating it), unless Transient Mark mode is enabled and the mark is already active. +A non-nil INTERACTIVE argument pushes the mark and switches the buffer +if optional argument BUFFER is non-nil. + This function is usually the wrong thing to use in a Lisp program. What you probably want instead is something like: (goto-char (point-min)) (forward-line (1- N)) If at all possible, an even better solution is to use char counts rather than line counts." - (declare (interactive-only forward-line)) - (interactive (goto-line-read-args)) + (interactive (append (goto-line-read-args) '(nil t))) ;; Switch to the desired buffer, one way or another. - (if buffer + (when interactive + (when buffer (let ((window (get-buffer-window buffer))) (if window (select-window window) (switch-to-buffer-other-window buffer)))) - ;; Leave mark at previous position - (or (region-active-p) (push-mark)) + ;; Leave mark at previous position + (or (region-active-p) (push-mark))) ;; Move to the specified line number in that buffer. (let ((pos (save-restriction (unless relative (widen)) @@ -1690,14 +1692,13 @@ rather than line counts." (widen)) (goto-char pos))) -(defun goto-line-relative (line &optional buffer) +(defun goto-line-relative (line &optional buffer interactive) "Go to LINE, counting from line at (point-min). The line number is relative to the accessible portion of the narrowed -buffer. The argument BUFFER is the same as in the function `goto-line'." - (declare (interactive-only forward-line)) - (interactive (goto-line-read-args t)) - (with-suppressed-warnings ((interactive-only goto-line)) - (goto-line line buffer t))) +buffer. The arguments BUFFER and INTERACTIVE are the same as in the +function `goto-line'." + (interactive (append (goto-line-read-args t) t)) + (goto-line line buffer t interactive)) (defun count-words-region (start end &optional arg) "Count the number of words in the region. @@ -7874,10 +7875,10 @@ This function uses the definition of the default face for the currently selected frame." (let ((dfh (default-font-height)) (lsp (if (display-graphic-p) - (or line-spacing - (default-value 'line-spacing) - (frame-parameter nil 'line-spacing) - 0) + (total-line-spacing (or line-spacing + (default-value 'line-spacing) + (frame-parameter nil 'line-spacing) + 0)) 0))) (if (floatp lsp) (setq lsp (truncate (* (frame-char-height) lsp)))) @@ -10730,7 +10731,7 @@ Called from `temp-buffer-show-hook'." (if (display-mouse-p) "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n" "Type \\[minibuffer-choose-completion] on a completion to select it.\n")) - (if minibuffer-visible-completions + (if (eq minibuffer-visible-completions t) (substitute-command-keys "Type \\[minibuffer-next-completion], \\[minibuffer-previous-completion], \ \\[minibuffer-next-line-completion], \\[minibuffer-previous-line-completion] \ diff --git a/lisp/subr.el b/lisp/subr.el index 2b94cd11e74..40325c30326 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2027,8 +2027,9 @@ and `event-end' functions." (let* ((spacing (when (display-graphic-p frame) (or (with-current-buffer (window-buffer (frame-selected-window frame)) - line-spacing) - (frame-parameter frame 'line-spacing))))) + (total-line-spacing)) + (total-line-spacing + (frame-parameter frame 'line-spacing)))))) (cond ((floatp spacing) (setq spacing (truncate (* spacing (frame-char-height frame))))) @@ -4836,7 +4837,6 @@ It also runs the string through `yank-transform-functions'." (get-text-property 0 'yank-handler string))) (param (or (nth 1 handler) string)) (opoint (point)) - (inhibit-read-only inhibit-read-only) end) ;; FIXME: This throws away any yank-undo-function set by previous calls @@ -4847,17 +4847,14 @@ It also runs the string through `yank-transform-functions'." (insert param)) (setq end (point)) - ;; Prevent read-only properties from interfering with the - ;; following text property changes. - (setq inhibit-read-only t) + (with-silent-modifications + (unless (nth 2 handler) ; NOEXCLUDE + (remove-yank-excluded-properties opoint end)) - (unless (nth 2 handler) ; NOEXCLUDE - (remove-yank-excluded-properties opoint end)) - - ;; If last inserted char has properties, mark them as rear-nonsticky. - (if (and (> end opoint) - (text-properties-at (1- end))) - (put-text-property (1- end) end 'rear-nonsticky t)) + ;; If last inserted char has properties, mark them as rear-nonsticky. + (if (and (> end opoint) + (text-properties-at (1- end))) + (put-text-property (1- end) end 'rear-nonsticky t))) (if (eq yank-undo-function t) ; not set by FUNCTION (setq yank-undo-function (nth 3 handler))) ; UNDO @@ -7011,7 +7008,8 @@ nothing." (progress-reporter-do-update reporter value suffix))) (defun make-progress-reporter (message &optional min-value max-value - current-value min-change min-time) + current-value min-change min-time + context) "Return progress reporter object for use with `progress-reporter-update'. MESSAGE is shown in the echo area, with a status indicator @@ -7038,13 +7036,18 @@ and/or MAX-VALUE are nil. Optional MIN-TIME specifies the minimum interval time between echo area updates (default is 0.2 seconds.) If the OS is not capable of measuring fractions of seconds, this parameter is -effectively rounded up." +effectively rounded up. + +Optional CONTEXT can be nil or `async'. It is consulted by back ends before +showing progress updates. For example, when CONTEXT is `async', +the echo area progress reports may be muted if the echo area is busy." (when (string-match "[[:alnum:]]\\'" message) (setq message (concat message "..."))) (unless min-time (setq min-time 0.2)) (let ((reporter (cons (or min-value 0) + ;; FIXME: Use defstruct. (vector (if (>= min-time 0.02) (float-time) nil) min-value @@ -7053,7 +7056,9 @@ effectively rounded up." (if min-change (max (min min-change 50) 1) 1) min-time ;; SUFFIX - nil)))) + nil + ;; + context)))) ;; Force a call to `message' now. (progress-reporter-update reporter (or current-value min-value)) reporter)) @@ -7064,6 +7069,10 @@ effectively rounded up." "Return REPORTER's text." (aref (cdr reporter) 3)) +(defun progress-reporter-context (reporter) + "Return REPORTER's context." + (aref (cdr reporter) 7)) + (defun progress-reporter-force-update (reporter &optional value new-message suffix) "Report progress of an operation in the echo area unconditionally. @@ -7082,20 +7091,26 @@ NEW-MESSAGE, if non-nil, sets a new message for the reporter." (defun progress-reporter-echo-area (reporter state) "Progress reporter echo area update function. REPORTER and STATE are the same as in -`progress-reporter-update-functions'." +`progress-reporter-update-functions'. + +Do not emit a message if the reporter context is `async' and the echo +area is busy with something else." (let ((text (progress-reporter-text reporter))) - (pcase state - ((pred floatp) - (if (plusp state) - (message "%s%d%%" text (* state 100.0)) - (message "%s" text))) - ((pred integerp) - (let ((message-log-max nil) - (pulse-char (aref progress-reporter--pulse-characters - state))) - (message "%s %s" text pulse-char))) - ('done - (message "%sdone" text))))) + (unless (and (eq (progress-reporter-context reporter) 'async) + (current-message) + (not (string-prefix-p text (current-message)))) + (pcase state + ((pred floatp) + (if (plusp state) + (message "%s%d%%" text (* state 100.0)) + (message "%s" text))) + ((pred integerp) + (let ((message-log-max nil) + (pulse-char (aref progress-reporter--pulse-characters + state))) + (message "%s %s" text pulse-char))) + ('done + (message "%sdone" text)))))) (defun progress-reporter-do-update (reporter value &optional suffix) (let* ((parameters (cdr reporter)) @@ -7607,7 +7622,18 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"." TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." (declare (important-return-value t)) - (string-trim-left (string-trim-right string trim-right) trim-left)) + (let* ((beg (and (string-match (if trim-left + (concat "\\`\\(?:" trim-left "\\)") + "\\`[ \t\n\r]+") + string) + (match-end 0))) + (end (string-match-p (if trim-right + (concat "\\(?:" trim-right "\\)\\'") + "[ \t\n\r]+\\'") + string beg))) + (if (or beg end) + (substring string beg end) + string))) (let ((missing (make-symbol "missing"))) (defsubst hash-table-contains-p (key table) @@ -7911,4 +7937,12 @@ and return the value found in PLACE instead." ,(funcall setter val) ,val))))) +(defun total-line-spacing (&optional line-spacing-param) + "Return numeric value of line-spacing, summing it if it's a cons. + When LINE-SPACING-PARAM is provided, calculate from it instead." + (let ((v (or line-spacing-param line-spacing))) + (pcase v + ((pred numberp) v) + (`(,above . ,below) (+ above below))))) + ;;; subr.el ends here diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 680edae95f1..4cc090bca94 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -48,23 +48,29 @@ (defface tab-bar-tab '((default :inherit tab-bar) - (((class color) (min-colors 88)) + (((class color) (min-colors 88) (background light)) :box (:line-width 1 :style released-button)) + (((class color) (min-colors 88) (background dark)) + :box (:line-width 1 :style released-button) + :background "grey40" + :foreground "white") (t :inverse-video nil)) "Tab bar face for selected tab." - :version "27.1" + :version "31.1" :group 'tab-bar-faces) (defface tab-bar-tab-inactive '((default :inherit tab-bar-tab) - (((class color) (min-colors 88)) + (((class color) (min-colors 88) (background light)) :background "grey75") + (((class color) (min-colors 88) (background dark)) + :background "grey20") (t :inverse-video t)) "Tab bar face for non-selected tab." - :version "27.1" + :version "31.1" :group 'tab-bar-faces) (defface tab-bar-tab-group-current @@ -86,10 +92,14 @@ :group 'tab-bar-faces) (defface tab-bar-tab-highlight - '((((class color) (min-colors 88)) + '((((class color) (min-colors 88) (background light)) :box (:line-width 1 :style released-button) :background "grey85" :foreground "black") + (((class color) (min-colors 88) (background dark)) + :box (:line-width 1 :style released-button) + :background "grey40" + :foreground "white") (t :inverse-video nil)) "Tab bar face for highlighting." :version "31.1" @@ -1954,6 +1964,42 @@ configuration." (delete-window)) (tab-bar-switch-to-recent-tab)) +(defun tab-bar-split-tab (&optional tab arg) + "Split windows of specified TAB into two separate tabs. +TAB defaults to the selected tab. ARG specifies the number +of windows to consider for splitting and defaults to 1. +Interactively, ARG is the prefix argument. + +First divide the child windows of TAB's main window into two parts. +The first part includes the first ARG child windows if ARG is positive, +or -ARG last windows if it's negative. The second part includes the +remaining child windows of TAB's main window. Then clone into a +newly-created tab each of the windows of the part which does not +include TAB's selected window and delete those windows from TAB." + (interactive "i\nP") + (let* ((tab (or tab (1+ (tab-bar--current-tab-index)))) + (_ (unless (eq tab (1+ (tab-bar--current-tab-index))) + (tab-bar-select-tab tab))) + (main (window-main-window)) + (total-window-count (window-child-count main)) + (arg (or arg 1))) + (cond + ((window-live-p main) + (user-error "Cannot split tab with only one window")) + ((or (not (numberp arg)) (zerop arg)) + (user-error "Invalid ARG %s for splitting tab" arg)) + ((>= (abs arg) total-window-count) + (user-error "ARG %s exceeds number of windows %s that can be split off" + (abs arg) (1- total-window-count))) + (t + (let* ((comb (window-get-split-combination main arg)) + (ws (window-state-get comb))) + (delete-window comb) + (tab-bar-new-tab) + (window-state-put ws (window-main-window))))))) + +(defalias 'split-tab #'tab-bar-split-tab) + (defun tab-bar-merge-tabs (&optional tab1 tab2 vertical) "Merge the main window of TAB2 into TAB1. Split the main window of TAB1 and make the new window display @@ -2865,9 +2911,20 @@ with those specified by the selected window configuration." (defun tab-bar--reusable-frames (all-frames) + "Process the `reusable-frames' buffer display action alist entry. +Return a frame list. Used with the `display-buffer-in-tab' action." (cond ((eq all-frames t) (frame-list)) ((eq all-frames 'visible) (visible-frame-list)) + ;; The standard behavior for a `reusable-frames' value of 0 is implemented in + ;; candidate_window_p() in window.c, and we have to go via `window-list-1' to + ;; utilize this. We list the selected frame first. + ((eq all-frames 0) (let (frames) + (dolist (w (window-list-1 nil nil 0)) + (let ((f (window-frame w))) + (unless (memq f frames) + (push f frames)))) + (nreverse frames))) ((framep all-frames) (list all-frames)) (t (list (selected-frame))))) @@ -2883,6 +2940,9 @@ The optional argument ALL-FRAMES specifies the frames to consider: - `visible' means consider all tabs on all visible frames. +- 0 (the number zero) means consider all tabs on all visible and + iconified frames. + - A frame means consider all tabs on that frame only. - Any other value of ALL-FRAMES means consider all tabs on the @@ -2935,27 +2995,40 @@ ALIST is an association list of action symbols and values. See Info node `(elisp) Buffer Display Action Alists' for details of such alists. -If ALIST contains a `tab-name' entry, it creates a new tab with that name and -displays BUFFER in a new tab. If a tab with this name already exists, it -switches to that tab before displaying BUFFER. The `tab-name' entry can be -a function, in which case it is called with two arguments: BUFFER and ALIST, -and should return the tab name. When a `tab-name' entry is omitted, create -a new tab without an explicit name. +If ALIST contains a non-nil `reusable-frames' entry then the frames +indicated by its value are searched for an existing tab which already +displays BUFFER. The possible values of `reusable-frames' are: -The ALIST entry `tab-group' (string or function) defines the tab group. - -If ALIST contains a `reusable-frames' entry, its value determines -which frames to search for a reusable tab: - nil -- do not reuse any frames; - a frame -- just that frame; + t -- all existing frames; `visible' -- all visible frames; 0 -- all frames on the current terminal; - t -- all frames; - other non-nil values -- use the selected frame. + A frame -- that frame only; + Any other non-nil value -- the selected frame; + nil -- do not search any frames (equivalent to omitting the entry). -If ALIST contains a non-nil `ignore-current-tab' entry, then the buffers -of the current tab are skipped when searching for a reusable tab. -Otherwise, prefer buffers of the current tab. +\(Note that the meaning of nil is different to the typical meaning of +nil for a `reusable-frames' entry in a buffer display action alist.) + +If ALIST contains a non-nil `ignore-current-tab' entry then skip the +current tab when searching for a reusable tab, otherwise prefer the +current tab if it already displays BUFFER. + +If a window displaying BUFFER is located in any reusable tab, select +that tab and window. + +If no such window is located, display BUFFER in a new or existing tab +based on the ALIST entry `tab-name' (string or function). If a tab with +this name already exists then select that tab, otherwise create a new +tab with this name. If `tab-name' is a function it is called with two +arguments (BUFFER and ALIST) and should return the tab name. If +`tab-name' is omitted or nil, create a new tab without an explicit name. + +If a new tab is created and ALIST contains a non-nil `tab-group' entry +\(string or function), this defines the tab group, overriding user +option `tab-bar-new-tab-group'. + +To create a new tab unconditionally, use `display-buffer-in-new-tab' +instead. This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be @@ -2994,16 +3067,17 @@ ALIST is an association list of action symbols and values. See Info node `(elisp) Buffer Display Action Alists' for details of such alists. -Like `display-buffer-in-tab', but always creates a new tab unconditionally, -without checking if a suitable tab already exists. +If ALIST contains a non-nil `tab-name' entry (string or function) then +display BUFFER in a new tab with this name. If `tab-name' is a function +it is called with two arguments (BUFFER and ALIST) and should return the +tab name. If `tab-name' is omitted or nil, create a new tab without an +explicit name. -If ALIST contains a `tab-name' entry, it creates a new tab with that name -and displays BUFFER in a new tab. The `tab-name' entry can be a function, -in which case it is called with two arguments: BUFFER and ALIST, and should -return the tab name. When a `tab-name' entry is omitted, create a new tab -without an explicit name. +If ALIST contains a non-nil `tab-group' entry (string or function), this +defines the tab group, overriding user option `tab-bar-new-tab-group'. -The ALIST entry `tab-group' (string or function) defines the tab group. +To check for a suitable existing tab to reuse before creating a new tab, +use `display-buffer-in-tab' instead. This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 7ff36a5250f..832b2b74437 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -62,20 +62,26 @@ is selected." (defface tab-line-tab '((default :inherit tab-line) - (((class color) (min-colors 88)) + (((class color) (min-colors 88) (background light)) :box (:line-width 1 :style released-button)) + (((class color) (min-colors 88) (background dark)) + :box (:line-width 1 :style released-button) + :background "grey40" + :foreground "white") (t :inverse-video nil)) "Tab line face for selected tab." - :version "27.1" + :version "31.1" :group 'tab-line-faces) (defface tab-line-tab-inactive '((default :inherit tab-line-tab) - (((class color) (min-colors 88)) + (((class color) (min-colors 88) (background light)) :background "grey75") + (((class color) (min-colors 88) (background dark)) + :background "grey20") (t :inverse-video t)) "Tab line face for non-selected tab." - :version "27.1" + :version "31.1" :group 'tab-line-faces) (defface tab-line-tab-inactive-alternate @@ -115,20 +121,26 @@ function `tab-line-tab-face-group'." (defface tab-line-tab-current '((default :inherit tab-line-tab) - (((class color) (min-colors 88)) - :background "grey85")) + (((class color) (min-colors 88) (background light)) + :background "grey85") + (((class color) (min-colors 88) (background dark)) + :background "grey40")) "Tab line face for tab with current buffer in selected window." - :version "27.1" + :version "31.1" :group 'tab-line-faces) (defface tab-line-highlight - '((((class color) (min-colors 88)) + '((((class color) (min-colors 88) (background light)) :box (:line-width 1 :style released-button) :background "grey85" :foreground "black") + (((class color) (min-colors 88) (background dark)) + :box (:line-width 1 :style released-button) + :background "grey40" + :foreground "white") (t :inverse-video nil)) "Tab line face for highlighting." - :version "27.1" + :version "31.1" :group 'tab-line-faces) (defface tab-line-close-highlight diff --git a/lisp/term.el b/lisp/term.el index 34b3450624c..9ac77730350 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -1009,9 +1009,11 @@ For custom keybindings purposes please note there is also ["Paging" term-pager-toggle :style toggle :selected term-pager-count :help "Toggle paging feature"])) +(defvar term--buffers-changed nil) + (defun term--update-term-menu (&optional force) (when (and (lookup-key term-mode-map [menu-bar terminal]) - (or force (frame-or-buffer-changed-p))) + (or force (frame-or-buffer-changed-p 'term--buffers-changed))) (let ((buffer-list (match-buffers '(derived-mode . term-mode)))) (easy-menu-change nil diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index 1e6c9a1a920..50135b104a0 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -80,6 +80,26 @@ capabilities, and only when that terminal understands bracketed paste." :version "28.1" :type 'boolean) +(defcustom xterm-update-cursor nil + "Whether to try to update cursor appearance on text terminals. +This works only for Xterm-compatible text terminals. + +If set to t all supported attributes of the cursor are updated. +If set to `type' only the cursor type is updated. This uses the CSI +DECSCUSR escape sequence. +If set to `color' only the cursor color is updated. This uses the OSC +12 and OSC 112 escape sequences." + :version "31.1" + :type '(radio (const :tag "Do not update" nil) + (const :tag "Update" t) + (const :tag "Update type only" type) + (const :tag "Update color only" color))) + +;; MacOS Terminal.app does not handle OSC 112 if it is terminated with +;; \e\\. It only handles OSC 112 if it is terminated by \a. +(defconst xterm--reset-cursor-color-escape-sequence "\e]112\a" + "OSC 112 escape sequence to reset cursor color to terminal default.") + (defconst xterm-paste-ending-sequence "\e[201~" "Characters sent by the terminal to end a bracketed paste.") @@ -89,7 +109,8 @@ capabilities, and only when that terminal understands bracketed paste." "WezTerm" ;; "XTerm" ;Disabled because OSC52 support is opt-in only. "iTerm2" ;OSC52 support has opt-in/out UI on first usage - "kitty") + "kitty" + "foot") word-end) "Regexp for terminals that automatically enable `xterm-mouse-mode' at startup. This will get matched against the terminal's XTVERSION string. @@ -746,20 +767,22 @@ Return the pasted text as a string." (let ((str (xterm--read-string ?\e ?\\))) (when (string-match "rgb:\\([a-f0-9]+\\)/\\([a-f0-9]+\\)/\\([a-f0-9]+\\)" str) - (let ((recompute-faces - (xterm-maybe-set-dark-background-mode - (string-to-number (match-string 1 str) 16) - (string-to-number (match-string 2 str) 16) - (string-to-number (match-string 3 str) 16)))) + (set-terminal-parameter + nil 'xterm--background-color + (list (string-to-number (match-string 1 str) 16) + (string-to-number (match-string 2 str) 16) + (string-to-number (match-string 3 str) 16)))))) - ;; Recompute faces here in case the background mode was - ;; set to dark. We used to call - ;; `tty-set-up-initial-frame-faces' only once, but that - ;; caused the light background faces to be computed - ;; incorrectly. See: - ;; https://lists.gnu.org/r/emacs-devel/2010-01/msg00439.html - (when recompute-faces - (tty-set-up-initial-frame-faces)))))) +(defun xterm--report-foreground-handler () + ;; The reply is similar to in `xterm--report-background-handler'. + (let ((str (xterm--read-string ?\e ?\\))) + (when (string-match + "rgb:\\([a-f0-9]+\\)/\\([a-f0-9]+\\)/\\([a-f0-9]+\\)" str) + (set-terminal-parameter + nil 'xterm--foreground-color + (list (string-to-number (match-string 1 str) 16) + (string-to-number (match-string 2 str) 16) + (string-to-number (match-string 3 str) 16)))))) (defun xterm--version-handler () ;; The reply should be: \e [ > NUMBER1 ; NUMBER2 ; NUMBER3 c @@ -784,7 +807,9 @@ Return the pasted text as a string." ;; Gnome terminal 3.38.0 reports 65;6200;1. (when (> version 4000) (xterm--query "\e]11;?\e\\" - '(("\e]11;" . xterm--report-background-handler)))) + '(("\e]11;" . xterm--report-background-handler))) + (xterm--query "\e]10;?\e\\" + '(("\e]10;" . xterm--report-foreground-handler)))) (setq version 200)) (when (equal (match-string 1 str) "83") ;; `screen' (which returns 83;40003;0) seems to also lack support for @@ -798,7 +823,9 @@ Return the pasted text as a string." ;; versions do too...) (when (>= version 242) (xterm--query "\e]11;?\e\\" - '(("\e]11;" . xterm--report-background-handler)))) + '(("\e]11;" . xterm--report-background-handler))) + (xterm--query "\e]10;?\e\\" + '(("\e]10;" . xterm--report-foreground-handler)))) ;; If version is 216 (the version when modifyOtherKeys was ;; introduced) or higher, initialize the @@ -816,6 +843,16 @@ Return the pasted text as a string." ;;(xterm--init-activate-get-selection) (xterm--init-activate-set-selection)))))) +(defun xterm--primary-da-handler () + ;; The reply should be: \e [ ? NUMBER1 ; ... ; NUMBER_N c + (let ((str (xterm--read-string ?c))) + (when (member "52" (split-string str ";" t)) + ;; Many modern terminals include 52 in their primary DA response, + ;; to indicate support for *writing* to the OS clipboard. The + ;; specification does not guarantee the clipboard can be read. See + ;; https://github.com/contour-terminal/vt-extensions/blob/master/clipboard-extension.md + (xterm--init-activate-set-selection)))) + (defvar xterm-query-timeout 2 "Seconds to wait for an answer from the terminal. Can be nil to mean \"no timeout\".") @@ -942,18 +979,20 @@ We run the first FUNCTION whose STRING matches the input events." (tty-set-up-initial-frame-faces) (if (eq xterm-extra-capabilities 'check) - ;; Try to find out the type of terminal by sending a "Secondary - ;; Device Attributes (DA)" query. - (xterm--query "\e[>0c" - ;; Some terminals (like macOS's Terminal.app) respond to - ;; this query as if it were a "Primary Device Attributes" - ;; query instead, so we should handle that too. - '(("\e[?" . xterm--version-handler) - ("\e[>" . xterm--version-handler))) + (progn + ;; Try to find out the type of terminal by sending a "Secondary + ;; Device Attributes (DA)" query. + (xterm--query "\e[>0c" + '(("\e[>" . xterm--version-handler))) + ;; Check primary DA for OSC-52 support + (xterm--query "\e[c" + '(("\e[?" . xterm--primary-da-handler)))) (when (memq 'reportBackground xterm-extra-capabilities) (xterm--query "\e]11;?\e\\" - '(("\e]11;" . xterm--report-background-handler)))) + '(("\e]11;" . xterm--report-background-handler))) + (xterm--query "\e]10;?\e\\" + '(("\e]10;" . xterm--report-foreground-handler)))) (when (memq 'modifyOtherKeys xterm-extra-capabilities) (xterm--init-modify-other-keys)) @@ -965,6 +1004,29 @@ We run the first FUNCTION whose STRING matches the input events." (when xterm-set-window-title (xterm--init-frame-title)) + (when xterm-update-cursor + (xterm--init-update-cursor)) + + (let ((bg-color (terminal-parameter nil 'xterm--background-color)) + (fg-color (terminal-parameter nil 'xterm--foreground-color))) + (when bg-color + (let ((recompute-faces + (apply #'xterm--set-background-mode bg-color))) + + ;; Recompute faces here in case the background mode was + ;; set to dark. We used to call + ;; `tty-set-up-initial-frame-faces' only once, but that + ;; caused the light background faces to be computed + ;; incorrectly. See: + ;; https://lists.gnu.org/r/emacs-devel/2010-01/msg00439.html + (when recompute-faces + (tty-set-up-initial-frame-faces)))) + (when (or bg-color fg-color) + (add-hook 'after-make-frame-functions 'xterm--maybe-update-default-face) + ;; Manually update, after-make-frame-functions was already called + ;; for initial frame. + (xterm--maybe-update-default-face (selected-frame)))) + (when (and (not xterm-mouse-mode-called) ;; Only automatically enable xterm mouse on terminals ;; confirmed to still support all critical editing @@ -981,6 +1043,16 @@ We run the first FUNCTION whose STRING matches the input events." ;; We likewise unconditionally enable support for focus tracking. (xterm--init-focus-tracking)) +(defun xterm--post-command-hook () + "Hook for xterm features that need to be frequently updated." + (unless (display-graphic-p) + (when xterm-set-window-title + (xterm-set-window-title)) + (when (memq xterm-update-cursor '(t type)) + (xterm--update-cursor-type)) + (when (memq xterm-update-cursor '(t color)) + (xterm--update-cursor-color)))) + (defun terminal-init-xterm () "Terminal initialization function for xterm." (unwind-protect @@ -1023,7 +1095,7 @@ We run the first FUNCTION whose STRING matches the input events." (xterm-set-window-title) (add-hook 'after-make-frame-functions 'xterm-set-window-title-flag) (add-hook 'window-configuration-change-hook 'xterm-unset-window-title-flag) - (add-hook 'post-command-hook 'xterm-set-window-title) + (add-hook 'post-command-hook 'xterm--post-command-hook) (add-hook 'minibuffer-exit-hook 'xterm-set-window-title)) (defvar xterm-window-title-flag nil @@ -1229,12 +1301,103 @@ versions of xterm." ;; right colors, so clear them. (clear-face-cache))) -(defun xterm-maybe-set-dark-background-mode (redc greenc bluec) +(defun xterm--set-background-mode (redc greenc bluec) ;; Use the heuristic in `frame-set-background-mode' to decide if a ;; frame is dark. - (when (< (+ redc greenc bluec) (* .6 (+ 65535 65535 65535))) - (set-terminal-parameter nil 'background-mode 'dark) - t)) + (set-terminal-parameter + nil 'background-mode + (if (< (+ redc greenc bluec) (* .6 (+ 65535 65535 65535))) + 'dark + 'light))) + +(defun xterm--maybe-update-default-face (frame) + (let ((bg-color (terminal-parameter (frame-terminal frame) + 'xterm--background-color)) + (fg-color (terminal-parameter (frame-terminal frame) + 'xterm--foreground-color)) + (default-bg (face-attribute 'default :background frame)) + (default-fg (face-attribute 'default :foreground frame))) + (when (and bg-color (string-equal default-bg "unspecified-bg")) + (let ((r (car bg-color)) + (g (cadr bg-color)) + (b (caddr bg-color))) + (set-face-background 'default (format "#%04x%04x%04x" r g b) frame))) + (when (and fg-color (string-equal default-fg "unspecified-fg")) + (let ((r (car fg-color)) + (g (cadr fg-color)) + (b (caddr fg-color))) + (set-face-foreground 'default (format "#%04x%04x%04x" r g b) frame))))) + +(defun xterm--init-update-cursor () + "Register hooks to run `xterm--update-cursor-type' appropriately." + (when (memq xterm-update-cursor '(color t)) + (push xterm--reset-cursor-color-escape-sequence + (terminal-parameter nil 'tty-mode-reset-strings)) + ;; No need to set `tty-mode-set-strings' because + ;; `xterm--post-command-hook' handles restoring the cursor color. + + (xterm--update-cursor-color)) + (when (memq xterm-update-cursor '(type t)) + (xterm--update-cursor-type)) + (add-hook 'post-command-hook 'xterm--post-command-hook)) + +(defconst xterm--cursor-type-to-int + '(nil 0 + box 1 + hollow 1 + bar 5 + hbar 3) + "Mapping of cursor type symbols to control sequence integers. +Cursor type symbols are the same as for `cursor-type'.") + +(defun xterm--set-cursor-type (terminal type) + (let ((type-int (or (plist-get xterm--cursor-type-to-int type) 1)) + (old (terminal-parameter terminal 'xterm--cursor-style))) + (when old + (set-terminal-parameter + terminal + 'tty-mode-set-strings + (delete (format "\e[%d q" old) + (terminal-parameter terminal 'tty-mode-set-strings)))) + (let ((set-string (format "\e[%d q" type-int))) + (push set-string (terminal-parameter terminal 'tty-mode-set-strings)) + (send-string-to-terminal set-string terminal)) + (unless old + ;; Assume that the default cursor is appropriate when exiting Emacs. + (push "\e[0 q" (terminal-parameter terminal 'tty-mode-reset-strings))) + (set-terminal-parameter terminal 'xterm--cursor-type type-int))) + +(defun xterm--update-cursor-type () + "Update the cursor type for Xterm-compatible terminals. +This updates the selected frame's terminal based on `cursor-type'." + (let ((buffer-cursor cursor-type) + (window-cursor (window-cursor-type)) + (frame-cursor (frame-parameter nil 'cursor-type)) + type) + ;; All of them can be conses, in which case the type symbol is the car. + (when (consp buffer-cursor) (setf buffer-cursor (car buffer-cursor))) + (when (consp window-cursor) (setf window-cursor (car window-cursor))) + (when (consp frame-cursor) (setf frame-cursor (car frame-cursor))) + (cond ((not (eq window-cursor t)) + (setf type window-cursor)) + ((not (eq buffer-cursor t)) + (setf type buffer-cursor)) + (t + (setf type frame-cursor))) + (xterm--set-cursor-type nil type))) + +(defun xterm--update-cursor-color () + "Update the cursor color for Xterm-compatible terminals. +This updates the selected frame's terminal based on the face `cursor'." + (if-let* ((color (color-values (face-background 'cursor))) + (r (nth 0 color)) + (g (nth 1 color)) + (b (nth 2 color))) + (send-string-to-terminal (format "\e]12;rgb:%04x/%04x/%04x\e\\" r g b)) + ;; The background is `unspecified' or one of its variants. We don't + ;; know the right cursor color to use, so fall back to the terminal + ;; default. + (send-string-to-terminal xterm--reset-cursor-color-escape-sequence))) (provide 'xterm) ;Backward compatibility. (provide 'term/xterm) diff --git a/lisp/textmodes/emacs-news-mode.el b/lisp/textmodes/emacs-news-mode.el index 12687ff325e..511e6f4a669 100644 --- a/lisp/textmodes/emacs-news-mode.el +++ b/lisp/textmodes/emacs-news-mode.el @@ -23,7 +23,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (require 'outline) (require 'subr-x) ; `emacs-etc--hide-local-variables' diff --git a/lisp/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el index 25fa74943c8..7061609fb83 100644 --- a/lisp/textmodes/html-ts-mode.el +++ b/lisp/textmodes/html-ts-mode.el @@ -145,6 +145,21 @@ Return nil if there is no name or if NODE is not a defun node." (skip-chars-backward " \t\n") (pos-bol))))) +(defun html-ts-mode--show-paren-data () + ;; Exclude unbalanced tags when the closing tag is missing. + (let ((default (treesit-show-paren-data))) + (when (= (length default) 4) + (let ((pos1 (min (nth 0 default) (nth 2 default))) + (pos2 (max (nth 0 default) (nth 2 default)))) + (when (and (equal (treesit-node-type + (treesit-node-at pos1)) + "<") + (not (equal (treesit-node-type + (treesit-node-at pos2)) + " REPLACEMENT as an abbrev, if enabled. +This is controlled by the variable `ispell--save-correction-as-abbrev'." + (require 'abbrev) + (when ispell--save-correction-as-abbrev + (define-abbrev global-abbrev-table misspelled replacement) + (message "\"%s\" now expands to \"%s\" globally" misspelled replacement))) (defun ispell-send-string (string) "Send the string STRING to the Ispell process." @@ -1971,38 +2003,42 @@ quit spell session exited." (message "%s is incorrect" (funcall ispell-format-word-function word)))) (t ; prompt for correct word. - (save-window-excursion - (setq replace (ispell-command-loop - (car (cdr (cdr poss))) - (car (cdr (cdr (cdr poss)))) - (car poss) start end))) - (cond ((equal 0 replace) - (ispell-add-per-file-word-list (car poss))) - (replace - (setq new-word (if (atom replace) replace (car replace)) - cursor-location (+ (- (length word) (- end start)) - cursor-location)) - (if (not (equal new-word (car poss))) - (progn - (goto-char start) - ;; Insert first and then delete, - ;; to avoid collapsing markers before and after - ;; into a single place. - (insert new-word) - (delete-region (point) end) - ;; It is meaningless to preserve the cursor position - ;; inside a word that has changed. - (setq cursor-location (point)) - (setq end (point)))) - (if (not (atom replace)) ;recheck spelling of replacement - (progn - (if (car (cdr replace)) ; query replace requested - (save-window-excursion - (query-replace word new-word t))) - (goto-char start) - ;; single word could be split into multiple words - (setq ispell-quit (not (ispell-region start end))) - )))) + (let ((ispell--abbrev-saving-allowed t) + (ispell--save-correction-as-abbrev + ispell-save-corrections-as-abbrevs)) + (save-window-excursion + (setq replace (ispell-command-loop + (car (cdr (cdr poss))) + (car (cdr (cdr (cdr poss)))) + (car poss) start end))) + (cond ((equal 0 replace) + (ispell-add-per-file-word-list (car poss))) + (replace + (setq new-word (if (atom replace) replace (car replace)) + cursor-location (+ (- (length word) (- end start)) + cursor-location)) + (ispell--maybe-save-correction-abbrev (car poss) new-word) + (if (not (equal new-word (car poss))) + (progn + (goto-char start) + ;; Insert first and then delete, + ;; to avoid collapsing markers before and after + ;; into a single place. + (insert new-word) + (delete-region (point) end) + ;; It is meaningless to preserve the cursor position + ;; inside a word that has changed. + (setq cursor-location (point)) + (setq end (point)))) + (if (not (atom replace)) ;recheck spelling of replacement + (progn + (if (car (cdr replace)) ; query replace requested + (save-window-excursion + (query-replace word new-word t))) + (goto-char start) + ;; single word could be split into multiple words + (setq ispell-quit (not (ispell-region start end))) + ))))) ;; keep if rechecking word and we keep choices win. (if (get-buffer ispell-choices-buffer) (kill-buffer ispell-choices-buffer)))) @@ -2167,9 +2203,12 @@ Global `ispell-quit' is set to start location to continue spell session." (choices miss) (window-min-height (min window-min-height ispell-choices-win-default-height)) - (command-characters '( ? ?i ?a ?A ?r ?R ?? ?x ?X ?q ?l ?u ?m )) + (command-characters + (append '( ? ?i ?a ?A ?r ?R ?? ?x ?X ?q ?l ?u ?m ) + (and ispell--abbrev-saving-allowed + '(?\C-u)))) (skipped 0) - char num result textwin) + char num result textwin abbrev-prefix) ;; setup the *Choices* buffer with valid data. (with-current-buffer (get-buffer-create ispell-choices-buffer) @@ -2235,8 +2274,14 @@ Global `ispell-quit' is set to start location to continue spell session." (progn (undo-boundary) (let (message-log-max) - (message (concat "C-h or ? for more options; SPC to leave " - "unchanged, Character to replace word"))) + (message + (concat + "C-h or ? for more options; SPC to leave " + "unchanged, Character to replace word" + (and ispell--abbrev-saving-allowed abbrev-prefix + (if ispell--save-correction-as-abbrev + " [won't save as abbrev]" + " [will save as abbrev]"))))) (let ((inhibit-quit t) (input-valid t)) (setq char nil skipped 0) @@ -2262,6 +2307,22 @@ Global `ispell-quit' is set to start location to continue spell session." (setq com-chars (cdr com-chars))) (setq num (- char ?0 skipped))) + (if (and abbrev-prefix + (or (memq char '(?r ?R)) + (and (>= num 0) (< num count)))) + ;; If the user typed `C-u' before this replacement + ;; command, then toggle abbrev saving for this + ;; correction. + (setq ispell--save-correction-as-abbrev + (not ispell--save-correction-as-abbrev) + abbrev-prefix nil) + ;; If the user typed `C-u' but not before a + ;; replacement command, then nullify the effect of + ;; `C-u' for subsequent commands. + (when (and abbrev-prefix + (not (= char ?\C-u))) + (setq abbrev-prefix nil))) + (cond ((= char ? ) nil) ; accept word this time only ((= char ?i) ; accept and insert word into pers dict @@ -2419,6 +2480,9 @@ Global `ispell-quit' is set to start location to continue spell session." ((= char ?\C-z) (funcall (key-binding "\C-z")) t) + ((and (= char ?\C-u) ispell--abbrev-saving-allowed) + (setq abbrev-prefix (not abbrev-prefix)) + t) (t (ding) t)))))) result) ;; protected @@ -2463,6 +2527,7 @@ Selections are: \\`m' Place typed-in value in personal dictionary, then recheck current word. \\`C-l' Redraw screen. \\`C-r' Recursive edit. +\\`C-u' Toggle abbrev saving for an immediately subsequent replacement command. \\`C-z' Suspend Emacs or iconify frame." (if (equal ispell-help-in-bufferp 'electric) @@ -2497,6 +2562,7 @@ Selections are: \\`m' Place typed-in value in personal dictionary, then recheck current word. \\`C-l' Redraw screen. \\`C-r' Recursive edit. +\\`C-u' Toggle abbrev saving for an immediately subsequent replacement command. \\`C-z' Suspend Emacs or iconify frame.")) nil))) @@ -2506,12 +2572,14 @@ Selections are: (help-2 (concat "[l]ook a word up in alternate dictionary; " "e[x/X]it; [q]uit session")) (help-3 (concat "[u]ncapitalized insert into dict. " - "Type `x C-h f ispell-help' for more help"))) + (and ispell--abbrev-saving-allowed + "C-u toggles abbrev saving (next replacement)."))) + (help-4 (concat "Type `x C-h f ispell-help' for more help"))) (save-window-excursion (if ispell-help-in-bufferp (let ((buffer (get-buffer-create "*Ispell Help*"))) (with-current-buffer buffer - (insert (concat help-1 "\n" help-2 "\n" help-3))) + (insert (concat help-1 "\n" help-2 "\n" help-3 "\n" help-4))) (ispell-display-buffer buffer) (sit-for (max 0.5 ispell-help-timeout)) (kill-buffer "*Ispell Help*")) @@ -2522,7 +2590,7 @@ Selections are: (message nil) ;;(set-minibuffer-window (selected-window)) (enlarge-window 2) - (insert (concat help-1 "\n" help-2 "\n" help-3)) + (insert (concat help-1 "\n" help-2 "\n" help-3 "\n" help-4)) (sit-for (max 0.5 ispell-help-timeout))) (erase-buffer))))))) @@ -3505,7 +3573,9 @@ word that was queried about." (word-len (length (car poss))) (line-end (copy-marker ispell-end)) (line-start (copy-marker ispell-start)) - recheck-region replace) + recheck-region replace + (ispell--abbrev-saving-allowed t) + (ispell--save-correction-as-abbrev ispell-save-corrections-as-abbrevs)) (goto-char word-start) ;; Adjust the horizontal scroll & point (ispell-horiz-scroll) @@ -3573,11 +3643,13 @@ word that was queried about." (progn (insert replace) ; Insert dictionary word. (ispell-send-replacement (car poss) replace) + (ispell--maybe-save-correction-abbrev (car poss) replace) (setq accept-list (cons replace accept-list))) (let ((replace-word (car replace))) ;; Recheck hand entered replacement word. (insert replace-word) (ispell-send-replacement (car poss) replace-word) + (ispell--maybe-save-correction-abbrev (car poss) replace-word) (if (car (cdr replace)) (save-window-excursion (delete-other-windows) ; to correctly show help. diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el index 8b75b7c52a8..b23b1a1d0ed 100644 --- a/lisp/textmodes/picture.el +++ b/lisp/textmodes/picture.el @@ -235,8 +235,8 @@ Use \"\\[command-apropos] picture-movement\" to see commands which control motio (char-ht (frame-char-height frame)) (spacing (when (display-graphic-p frame) (or (with-current-buffer (window-buffer window) - line-spacing) - (frame-parameter frame 'line-spacing))))) + (total-line-spacing)) + (total-line-spacing (frame-parameter frame 'line-spacing)))))) (cond ((floatp spacing) (setq spacing (truncate (* spacing char-ht)))) ((null spacing) diff --git a/lisp/textmodes/reftex-auc.el b/lisp/textmodes/reftex-auc.el index 3f7709e1497..0396c3bcd8f 100644 --- a/lisp/textmodes/reftex-auc.el +++ b/lisp/textmodes/reftex-auc.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'reftex) (declare-function TeX-argument-prompt "ext:tex" diff --git a/lisp/textmodes/reftex-dcr.el b/lisp/textmodes/reftex-dcr.el index 3d49e2f2410..b2e1bb61ddb 100644 --- a/lisp/textmodes/reftex-dcr.el +++ b/lisp/textmodes/reftex-dcr.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (declare-function bibtex-beginning-of-entry "bibtex" ()) (require 'reftex) diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index 890bd9551c7..e9acf91c824 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (provide 'reftex-global) (require 'reftex) diff --git a/lisp/textmodes/reftex-sel.el b/lisp/textmodes/reftex-sel.el index dd119ae341b..f75b15c6eb9 100644 --- a/lisp/textmodes/reftex-sel.el +++ b/lisp/textmodes/reftex-sel.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'reftex) ;; Common bindings in reftex-select-label-mode-map diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 99659edbef7..2170fcea6e9 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -452,9 +452,6 @@ When more these are fontified together with `sgml-font-lock-keywords'.") (defvar sgml-display-text () "Tag names as lowercase symbols, and display string when invisible.") -;; internal -(defvar sgml-tags-invisible nil) - (defcustom sgml-tag-alist '(("![" ("ignore" t) ("include" t)) ("!attlist") @@ -1059,7 +1056,7 @@ Return t if after a closing tag." ;; Ignore empty tags like . "\\([^>]*[^/>]\\)?>")) point close) - (forward-list 1) + (forward-sexp 1) (setq point (point)) ;; FIXME: This re-search-forward will mistakenly match ;; tag-like text inside attributes. @@ -1072,7 +1069,7 @@ Return t if after a closing tag." (unless close (goto-char point) (setq return nil))) - (forward-list 1)) + (forward-sexp 1)) (setq arg (1- arg))) return))) @@ -1089,7 +1086,8 @@ With prefix argument ARG, repeat this ARG times." (interactive "p") (while (>= arg 1) (save-excursion - (let* (close open) + (let* ((forward-sexp-function nil) + close open) (if (looking-at "[ \t\n]*<") ;; just before tag (if (eq (char-after (match-end 0)) ?/) @@ -1107,7 +1105,7 @@ With prefix argument ARG, repeat this ARG times." (sgml-skip-tag-backward 1) (if (or (not (eq (following-char) ?<)) (save-excursion - (forward-list 1) + (forward-sexp 1) (<= (point) point))) (error "Not on or before tag"))))) (if close @@ -1140,22 +1138,17 @@ With prefix argument ARG, repeat this ARG times." read-only t) (symbol-plist 'sgml-tag)))) -(defun sgml-tags-invisible (arg) +(define-minor-mode sgml-tags-invisible "Toggle visibility of existing tags." - (interactive "P") - (let ((inhibit-read-only t) - string) - (with-silent-modifications - (save-excursion - (goto-char (point-min)) - (if (setq-local sgml-tags-invisible - (if arg - (>= (prefix-numeric-value arg) 0) - (not sgml-tags-invisible))) - (while (re-search-forward sgml-tag-name-re nil t) - (setq string - (cdr (assq (intern-soft (downcase (match-string 1))) - sgml-display-text))) + :global nil + (with-silent-modifications + (save-excursion + (goto-char (point-min)) + (if sgml-tags-invisible + (while (re-search-forward sgml-tag-name-re nil t) + (let ((string + (cdr (assq (intern-soft (downcase (match-string 1))) + sgml-display-text)))) (goto-char (match-beginning 0)) (and (stringp string) (not (overlays-at (point))) @@ -1163,17 +1156,18 @@ With prefix argument ARG, repeat this ARG times." (overlay-put ol 'before-string string) (overlay-put ol 'sgml-tag t))) (put-text-property (point) - (progn (forward-list) (point)) - 'category 'sgml-tag)) - (let ((pos (point-min))) - (while (< (setq pos (next-overlay-change pos)) (point-max)) - (dolist (ol (overlays-at pos)) - (if (overlay-get ol 'sgml-tag) - (delete-overlay ol))))) - (remove-text-properties (point-min) (point-max) '(category nil))))) - (cursor-sensor-mode (if sgml-tags-invisible 1 -1)) - (run-hooks 'sgml-tags-invisible-hook) - (message ""))) + (let ((forward-sexp-function nil)) + (forward-sexp 1) + (point)) + 'category 'sgml-tag))) + (let ((pos (point-min))) + (while (< (setq pos (next-overlay-change pos)) (point-max)) + (dolist (ol (overlays-at pos)) + (if (overlay-get ol 'sgml-tag) + (delete-overlay ol))))) + (remove-text-properties (point-min) (point-max) '(category nil))))) + (when sgml-tags-invisible + (cursor-sensor-mode 1))) (defun sgml-cursor-sensor (window x dir) ;; Show preceding or following hidden tag, depending of cursor direction (and diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el index 5c9449a2238..b5b496a30dc 100644 --- a/lisp/textmodes/text-mode.el +++ b/lisp/textmodes/text-mode.el @@ -269,6 +269,56 @@ The argument NLINES says how many lines to center." (setq nlines (1+ nlines)) (forward-line -1))))) +;; Actually defined in track-changes.el. +(defvar track-changes-undo-only) +(declare-function track-changes-register "track-changes" + ( signal &optional &key nobefore disjoint immediate)) +(declare-function track-changes-unregister "track-changes" (id)) +(declare-function track-changes-fetch "track-changes" (id func)) + +(defvar-local center-line-mode--track-changes nil) + +(defun center-line-mode--track-changes-signal (tracker) + (track-changes-fetch + tracker + #'center-line-mode--track-changes-function)) + +(defun center-line-mode--track-changes-function (beg end _before) + (unless track-changes-undo-only + (save-excursion + (let ((beg-line (line-number-at-pos beg)) + (end-line (line-number-at-pos end)) + (should-center-last-line-p + (progn + (goto-char end) + (null + (or (bolp) + (and (eolp) + (looking-back "[\r\n\t ]" (1- (point))))))))) + (goto-char beg) + (dotimes (_ (- end-line beg-line)) ; all but last line + (unless (and (bolp) (eolp)) + (center-line)) + (forward-line 1)) + (when should-center-last-line-p + (center-line))))) + ;; Disregard our own changes. + (track-changes-fetch center-line-mode--track-changes #'ignore)) + +(define-minor-mode center-line-mode + "Minor mode for keeping modified lines centered horizontally. +Calls `center-line' on each line of the modified region to center the +text within the width specified by `fill-column'." + :lighter " Center-Line" + (require 'track-changes) + (if center-line-mode + (setq center-line-mode--track-changes + (track-changes-register + #'center-line-mode--track-changes-signal + :nobefore t)) + (when center-line-mode--track-changes + (track-changes-unregister center-line-mode--track-changes)))) + (define-obsolete-function-alias 'indented-text-mode #'text-mode "29.1") diff --git a/lisp/textmodes/yaml-ts-mode.el b/lisp/textmodes/yaml-ts-mode.el index 32e3ea0212a..948186b5a9a 100644 --- a/lisp/textmodes/yaml-ts-mode.el +++ b/lisp/textmodes/yaml-ts-mode.el @@ -41,6 +41,20 @@ :commit "b733d3f5f5005890f324333dd57e1f0badec5c87") t) +(defgroup yaml-ts-mode nil + "Major mode for editing YAML files." + :prefix "yaml-ts-mode-" + :group 'languages) + +(defcustom yaml-ts-mode-yamllint-options nil + "Additional options to pass to yamllint command used for Flymake support. +If non-nil, this should be a single string with command-line options +for the yamllint command, with individual options separated by whitespace." + :group 'yaml-ts-mode + :version "31.1" + :type '(choice (const :tag "None" nil) + (string :tag "Options as a single string"))) + (defvar yaml-ts-mode--syntax-table (let ((table (make-syntax-table))) (modify-syntax-entry ?# "<" table) @@ -175,6 +189,77 @@ Return nil if there is no name or if NODE is not a defun node." (when (string-match-p yaml-ts-mode--outline-nodes (treesit-node-type node)) (not (treesit-node-top-level node yaml-ts-mode--outline-nodes)))) +;;; Flymake integration +(defvar-local yaml-ts-mode--flymake-process nil + "Store the Flymake process.") + +(defun yaml-ts-mode-flymake (report-fn &rest _args) + "YAML backend for Flymake. +Calls REPORT-FN directly." + (when (process-live-p yaml-ts-mode--flymake-process) + (kill-process yaml-ts-mode--flymake-process)) + (let ((yamllint (executable-find "yamllint")) + (params (if yaml-ts-mode-yamllint-options + (append (split-string yaml-ts-mode-yamllint-options) '("-f" "parsable" "-")) + '("-f" "parsable" "-"))) + + (source (current-buffer)) + (diagnostics-pattern (eval-when-compile + (rx bol (+? nonl) ":" ; every diagnostic line start with the filename + (group (1+ digit)) ":" ; 1: line + (group (1+ digit)) ":" ; 2: column + (+ (syntax whitespace)) + (group (or "[error]" "[warning]")) ; 3: type + (+ (syntax whitespace)) + (group (+? nonl)) ;; 4: message + eol)))) + + (if (not yamllint) + (error "Unable to find yamllint command") + (save-restriction + (widen) + (setq yaml-ts-mode--flymake-process + (make-process + :name "yaml-ts-mode-flymake" + :noquery t + :connection-type 'pipe + :buffer (generate-new-buffer " *yaml-ts-mode-flymake*") + :command `(,yamllint ,@params) + :sentinel + (lambda (proc _event) + (when (eq 'exit (process-status proc)) + (unwind-protect + (if (with-current-buffer source + (eq proc yaml-ts-mode--flymake-process)) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (let (diags) + (while (search-forward-regexp + diagnostics-pattern + nil t) + (let* ((beg + (car (flymake-diag-region + source + (string-to-number (match-string 1)) + (string-to-number (match-string 2))))) + (end + (cdr (flymake-diag-region + source + (string-to-number (match-string 1)) + (string-to-number (match-string 2))))) + (msg (match-string 4)) + (type (if (string= "[warning]" (match-string 3)) + :warning + :error))) + (push (flymake-make-diagnostic + source beg end type msg) + diags)) + (funcall report-fn diags)))) + (flymake-log :warning "Canceling obsolete check %s" proc)) + (kill-buffer (process-buffer proc))))))) + (process-send-region yaml-ts-mode--flymake-process (point-min) (point-max)) + (process-send-eof yaml-ts-mode--flymake-process))))) + ;;;###autoload (define-derived-mode yaml-ts-mode text-mode "YAML" "Major mode for editing YAML, powered by tree-sitter." @@ -215,6 +300,9 @@ Return nil if there is no name or if NODE is not a defun node." ;; Outline minor mode. (setq-local treesit-outline-predicate #'yaml-ts-mode--outline-predicate) + ;; Flymake + (add-hook 'flymake-diagnostic-functions #'yaml-ts-mode-flymake nil 'local) + (treesit-major-mode-setup) (setq-local hs-treesit-things "block_mapping_pair") diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el index d401836fd4b..dc7c918816b 100644 --- a/lisp/time-stamp.el +++ b/lisp/time-stamp.el @@ -236,27 +236,43 @@ your init file, you would be incompatible with other people's files.") (defvar time-stamp-inserts-lines nil ;Do not change! "Whether \\[time-stamp] can change the number of lines in a file. -If nil, \\[time-stamp] skips as many lines as there are newlines in -`time-stamp-format' before looking for the `time-stamp-end' pattern, -thus it tries not to change the number of lines in the buffer. -If non-nil, \\[time-stamp] starts looking for the end pattern -immediately after the start pattern. This behavior can cause -unexpected changes in the buffer if used carelessly, but it is useful -for generating repeated time stamps. +When `time-stamp-format' contains newline characters, the intent +is ambiguous: does the author want to update a single multi-line +time stamp, or create a repeated time stamp by inserting new lines? +This variable controls the interpretation. + +If nil, `time-stamp' tries not to change the number of lines in the +buffer and treats the format as one single, multi-line time stamp. +The `time-stamp-end' must start N lines after the end of +`time-stamp-start', where N is the number of newlines in +`time-stamp-format'. + +If this variable is non-nil, `time-stamp' is willing to add lines +to the buffer. The end pattern must start somewhere in the +remainder of the same line where the start pattern ends. +This behavior lets a file accumulate repeated time stamps. + +In the most common case that `time-stamp-format' contains no +newlines, this variable has no effect; the end of the start +and the start of the end are always on the same line. These variables are best changed with file-local variables. -If you were to change `time-stamp-end' or `time-stamp-inserts-lines' in -your init file, you would be incompatible with other people's files.") +If you were to change `time-stamp-start', `time-stamp-end' or +`time-stamp-inserts-lines' in your init file, you would be +incompatible with other people's files.") ;;;###autoload(put 'time-stamp-inserts-lines 'safe-local-variable #'booleanp) (defvar time-stamp-count 1 ;Do not change! "How many templates \\[time-stamp] will look for in a buffer. -If the value is greater than 1, the same time stamp will be written in -each case. If you want to insert different text on different lines, +If the value is greater than 1, the same time stamp will be +written in each case. + +If you want to insert different text on different lines, then instead of changing this variable, include a newline (written as \"\\n\") in `time-stamp-format' or the format part of `time-stamp-pattern'. +See the variable `time-stamp-inserts-lines'. `time-stamp-count' is best changed with a file-local variable. If you were to change it in your init file, you would be incompatible @@ -279,8 +295,8 @@ value of `time-stamp-line-limit' as the number. The second part is a regexp identifying the pattern preceding the time stamp. This part may be omitted to use the value of `time-stamp-start'. -The third part specifies the format of the time stamp inserted. Specify -this part as \"%%\" to use the value of `time-stamp-format'. +The third part specifies the format of the time stamp inserted. +This part may be \"%%\" to use the value of `time-stamp-format'. The fourth part is a regexp identifying the pattern following the time stamp. This part may be omitted to use the value of `time-stamp-end'. @@ -331,9 +347,9 @@ of the file before running this function, by default can look like one of the following (your choice): Time-stamp: <> Time-stamp: \" \" -This function writes the current time between the brackets or quotes, -by default formatted like this: - Time-stamp: <2024-08-07 17:10:21 gildea> +This function writes the current time between the angle brackets +or quotes, by default formatted like this: + Time-stamp: <2025-08-07 17:10:21 gildea> Although you can run this function manually to update a time stamp once, usually you want automatic time stamp updating. @@ -351,7 +367,8 @@ If the file has no time stamp template or if `time-stamp-active' is nil, this function does nothing. You can set `time-stamp-pattern' in a file's local variables list -to customize the information in the time stamp and where it is written." +to customize the information in the time stamp, the surrounding +template, and where in the file it can occur." (interactive) (let ((line-limit time-stamp-line-limit) (ts-start time-stamp-start) @@ -528,7 +545,7 @@ time is used. The time zone is determined by `time-stamp-time-zone'." ;;; ambiguous formats--formats that are changing (over time) incompatibly. (defun time-stamp-string-preprocess (format &optional time) - "Use a FORMAT to format date, time, file, and user information. + "Use FORMAT to format date, time, and user information. Optional second argument TIME is only for testing. This is an internal routine implementing extensions to `format-time-string' and all `time-stamp-format' compatibility." @@ -879,7 +896,7 @@ TYPE is :short for the unqualified name, :full for the full name." When non-nil, `time-stamp' warns about unstable and soon-to-be-changing conversions found in that buffer's `time-stamp-format' value. The warning is displayed only -when a buffer's time-stamp is updated; merely viewing a file +when a buffer's time stamp is updated; merely viewing a file does not warn. If nil, these warnings are disabled, which would be a bad idea. diff --git a/lisp/transient.el b/lisp/transient.el index a464a6f09ef..a7e2e5daa23 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -5,7 +5,7 @@ ;; Author: Jonas Bernoulli ;; URL: https://github.com/magit/transient ;; Keywords: extensions -;; Version: 0.11.0 +;; Version: 0.12.0 ;; SPDX-License-Identifier: GPL-3.0-or-later @@ -33,7 +33,7 @@ ;;; Code: ;;;; Frontmatter -(defconst transient-version "v0.11.0-10-g6637364e-builtin") +(defconst transient-version "v0.12.0-15-gfe5214e6-builtin") (require 'cl-lib) (require 'eieio) @@ -669,15 +669,16 @@ See also option `transient-highlight-mismatched-keys'." (insert-file-contents file) (read (current-buffer)))))) -(defun transient--pp-to-file (list file) - (make-directory (file-name-directory file) t) - (setq list (cl-sort (copy-sequence list) #'string< :key #'car)) - (with-temp-file file - (let ((print-level nil) - (print-length nil) - (pp-default-function 'pp-28) - (fill-column 999)) - (pp list (current-buffer))))) +(defun transient--pp-to-file (value file) + (when (or value (file-exists-p file)) + (make-directory (file-name-directory file) t) + (setq value (cl-sort (copy-sequence value) #'string< :key #'car)) + (with-temp-file file + (let ((print-level nil) + (print-length nil) + (pp-default-function 'pp-28) + (fill-column 999)) + (pp value (current-buffer)))))) (defvar transient-values (transient--read-file-contents transient-values-file) @@ -1215,15 +1216,15 @@ commands are aliases for." (while-let ((arg (car args)) (arg (cond - ;; Inline group definition. - ((vectorp arg) - (pop args)) - ;; Quoted include, as one would expect. - ((eq (car-safe arg) 'quote) - (cadr (pop args))) - ;; Unquoted include, for compatibility. - ((and arg (symbolp arg)) - (pop args))))) + ;; Inline group definition. + ((vectorp arg) + (pop args)) + ;; Quoted include, as one would expect. + ((eq (car-safe arg) 'quote) + (cadr (pop args))) + ;; Unquoted include, for compatibility. + ((and arg (symbolp arg)) + (pop args))))) (push arg suffixes)) (when (eq (car-safe (car args)) 'declare) (setq declare (car args)) @@ -1234,11 +1235,11 @@ commands are aliases for." (unless (cdr declare) (setq declare nil))) (cond - ((not args)) - (nobody - (error "%s: No function body allowed" form)) - ((not (eq (car-safe (nth (if declare 1 0) args)) 'interactive)) - (error "%s: Interactive form missing" form))) + ((not args)) + (nobody + (error "%s: No function body allowed" form)) + ((not (eq (car-safe (nth (if declare 1 0) args)) 'interactive)) + (error "%s: Interactive form missing" form))) (list (if (eq (car-safe class) 'quote) (cadr class) class) @@ -1502,40 +1503,40 @@ Intended for use in a group's `:setup-children' function." (symbol suffix))) (`(,elt ,group) (transient--locate-child prefix loc))) (cond - ((not elt) - (funcall (if transient-error-on-insert-failure #'error #'message) - "Cannot insert %S into %s; %s not found" - suffix prefix loc)) - ((or (and (vectorp suffix) (not (vectorp elt))) - (and (listp suffix) (vectorp elt)) - (and (stringp suffix) (vectorp elt))) - (funcall (if transient-error-on-insert-failure #'error #'message) - "Cannot place %S into %s at %s; %s" - suffix prefix loc - "suffixes and groups cannot be siblings")) - (t - (when-let* ((_(not (eq keep-other 'always))) - (bindingp (listp suf)) - (key (transient--suffix-key suf)) - (conflict (car (transient--locate-child prefix key))) - (conflictp - (and (not (and (eq action 'replace) - (eq conflict elt))) - (or (not keep-other) - (eq (plist-get (transient--suffix-props suf) - :command) - (plist-get (transient--suffix-props conflict) - :command))) - (equal (transient--suffix-predicate suf) - (transient--suffix-predicate conflict))))) - (transient-remove-suffix prefix key) - (pcase-setq `(,elt ,group) (transient--locate-child prefix loc))) - (let ((mem (memq elt (aref group 2)))) - (pcase-exhaustive action - ('insert (setcdr mem (cons elt (cdr mem))) - (setcar mem suf)) - ('append (setcdr mem (cons suf (cdr mem)))) - ('replace (setcar mem suf)))))))) + ((not elt) + (funcall (if transient-error-on-insert-failure #'error #'message) + "Cannot insert %S into %s; %s not found" + suffix prefix loc)) + ((or (and (vectorp suffix) (not (vectorp elt))) + (and (listp suffix) (vectorp elt)) + (and (stringp suffix) (vectorp elt))) + (funcall (if transient-error-on-insert-failure #'error #'message) + "Cannot place %S into %s at %s; %s" + suffix prefix loc + "suffixes and groups cannot be siblings")) + (t + (when-let* ((_(not (eq keep-other 'always))) + (bindingp (listp suf)) + (key (transient--suffix-key suf)) + (conflict (car (transient--locate-child prefix key))) + (conflictp + (and (not (and (eq action 'replace) + (eq conflict elt))) + (or (not keep-other) + (eq (plist-get (transient--suffix-props suf) + :command) + (plist-get (transient--suffix-props conflict) + :command))) + (equal (transient--suffix-predicate suf) + (transient--suffix-predicate conflict))))) + (transient-remove-suffix prefix key) + (pcase-setq `(,elt ,group) (transient--locate-child prefix loc))) + (let ((mem (memq elt (aref group 2)))) + (pcase-exhaustive action + ('insert (setcdr mem (cons elt (cdr mem))) + (setcar mem suf)) + ('append (setcdr mem (cons suf (cdr mem)))) + ('replace (setcar mem suf)))))))) ;;;###autoload (defun transient-insert-suffix (prefix loc suffix &optional keep-other) @@ -1644,20 +1645,20 @@ See info node `(transient)Modifying Existing Transients'." (setq group (transient--get-layout group))) (when (vectorp loc) (setq loc (append loc nil))) - (if (listp loc) - (and-let* ((match (transient--nth (pop loc) (aref group 2)))) - (if loc - (transient--locate-child - match (cond ((or (stringp (car loc)) - (symbolp (car loc))) - (car loc)) - ((symbolp match) - (vconcat (cons 0 loc))) - ((vconcat loc)))) - (list match group))) - (seq-some (lambda (child) - (transient--match-child group loc child)) - (aref group 2)))) + (cond* + ((atom loc) + (seq-some (lambda (child) + (transient--match-child group loc child)) + (aref group 2))) + ((bind-and* (match (transient--nth (pop loc) (aref group 2)))) + (cond (loc (transient--locate-child + match (cond ((or (stringp (car loc)) + (symbolp (car loc))) + (car loc)) + ((symbolp match) + (vconcat (cons 0 loc))) + ((vconcat loc))))) + ((list match group)))))) (defun transient--match-child (group loc child) (cl-etypecase child @@ -1931,23 +1932,23 @@ probably use this instead: (or transient--suffixes transient-current-suffixes)))) (cond - ((length= suffixes 1) - (car suffixes)) - ((cl-find-if (lambda (obj) - (equal (listify-key-sequence (kbd (oref obj key))) - (listify-key-sequence (this-command-keys)))) - suffixes)) - ;; COMMAND is only provided if `this-command' is meaningless, in - ;; which case `this-command-keys' is also meaningless, making it - ;; impossible to disambiguate bindings for the same command. - (command (car suffixes)) - ;; If COMMAND is nil, then failure to disambiguate likely means - ;; that there is a bug somewhere. - ((length> suffixes 1) - (error "BUG: Cannot unambiguously determine suffix object")) - ;; It is legitimate to use this function as a predicate of sorts. - ;; `transient--pre-command' and `transient-help' are examples. - (t nil)))) + ((length= suffixes 1) + (car suffixes)) + ((cl-find-if (lambda (obj) + (equal (listify-key-sequence (kbd (oref obj key))) + (listify-key-sequence (this-command-keys)))) + suffixes)) + ;; COMMAND is only provided if `this-command' is meaningless, in + ;; which case `this-command-keys' is also meaningless, making it + ;; impossible to disambiguate bindings for the same command. + (command (car suffixes)) + ;; If COMMAND is nil, then failure to disambiguate likely means + ;; that there is a bug somewhere. + ((length> suffixes 1) + (error "BUG: Cannot unambiguously determine suffix object")) + ;; It is legitimate to use this function as a predicate of sorts. + ;; `transient--pre-command' and `transient-help' are examples. + (t nil)))) ((bind-and* (obj (transient--suffix-prototype (or command this-command))) (obj (clone obj))) (transient-init-scope obj) @@ -2254,31 +2255,31 @@ of the corresponding object." ((cl-typep obj 'transient-infix) 'infix) (t 'suffix))) (pre (cond - ((oref obj inactive) nil) - ((oref obj inapt) #'transient--do-warn-inapt) - ((slot-boundp obj 'transient) - (pcase (list kind - (transient--resolve-pre-command - (oref obj transient) nil t) - return) - (`(prefix t ,_) #'transient--do-recurse) - (`(prefix nil ,_) #'transient--do-stack) - (`(infix t ,_) #'transient--do-stay) - (`(suffix t ,_) #'transient--do-call) - ('(suffix nil t) #'transient--do-return) - (`(,_ nil ,_) #'transient--do-exit) - (`(,_ ,do ,_) do))) - ((not (lookup-key transient-predicate-map id)) - (pcase (list kind default return) - (`(prefix ,(or 'transient--do-stay 'transient--do-call) ,_) - #'transient--do-recurse) - (`(prefix t ,_) #'transient--do-recurse) - (`(prefix ,_ ,_) #'transient--do-stack) - (`(infix ,_ ,_) #'transient--do-stay) - (`(suffix t ,_) #'transient--do-call) - ('(suffix nil t) #'transient--do-return) - (`(suffix nil nil) #'transient--do-exit) - (`(suffix ,do ,_) do)))))) + ((oref obj inactive) nil) + ((oref obj inapt) #'transient--do-warn-inapt) + ((slot-boundp obj 'transient) + (pcase (list kind + (transient--resolve-pre-command + (oref obj transient) nil t) + return) + (`(prefix t ,_) #'transient--do-recurse) + (`(prefix nil ,_) #'transient--do-stack) + (`(infix t ,_) #'transient--do-stay) + (`(suffix t ,_) #'transient--do-call) + ('(suffix nil t) #'transient--do-return) + (`(,_ nil ,_) #'transient--do-exit) + (`(,_ ,do ,_) do))) + ((not (lookup-key transient-predicate-map id)) + (pcase (list kind default return) + (`(prefix ,(or 'transient--do-stay 'transient--do-call) ,_) + #'transient--do-recurse) + (`(prefix t ,_) #'transient--do-recurse) + (`(prefix ,_ ,_) #'transient--do-stack) + (`(infix ,_ ,_) #'transient--do-stay) + (`(suffix t ,_) #'transient--do-call) + ('(suffix nil t) #'transient--do-return) + (`(suffix nil nil) #'transient--do-exit) + (`(suffix ,do ,_) do)))))) (when pre (if-let* ((alt (lookup-key map id))) (unless (eq alt pre) @@ -2336,24 +2337,24 @@ EDIT may be non-nil." (transient--debug 'setup) (transient--with-emergency-exit :setup (cond - ((not name) - ;; Switching between regular and edit mode. - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map) - (setq name (oref transient--prefix command)) - (setq params (list :scope (oref transient--prefix scope)))) - (transient--prefix - ;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}" - ;; of an outer prefix. Unlike the usual `transient--do-stack', - ;; these predicates fail to clean up after the outer prefix. - (transient--pop-keymap 'transient--transient-map) - (transient--pop-keymap 'transient--redisplay-map)) - ((not (or layout ; resuming parent/suspended prefix - transient-current-command)) ; entering child prefix - (transient--stack-zap)) ; replace suspended prefix, if any - (edit - ;; Returning from help to edit. - (setq transient--editp t))) + ((not name) + ;; Switching between regular and edit mode. + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map) + (setq name (oref transient--prefix command)) + (setq params (list :scope (oref transient--prefix scope)))) + (transient--prefix + ;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}" + ;; of an outer prefix. Unlike the usual `transient--do-stack', + ;; these predicates fail to clean up after the outer prefix. + (transient--pop-keymap 'transient--transient-map) + (transient--pop-keymap 'transient--redisplay-map)) + ((not (or layout ; resuming parent/suspended prefix + transient-current-command)) ; entering child prefix + (transient--stack-zap)) ; replace suspended prefix, if any + (edit + ;; Returning from help to edit. + (setq transient--editp t))) (transient--env-apply (lambda () (transient--init-transient name layout params) @@ -2570,25 +2571,25 @@ value. Otherwise return CHILDREN as is.") (if if-not if-nil if-non-nil if-mode if-not-mode if-derived if-not-derived default) (cond - (if (funcall if)) - (if-not (not (funcall if-not))) - (if-non-nil (symbol-value if-non-nil)) - (if-nil (not (symbol-value if-nil))) - (if-mode (if (atom if-mode) - (eq major-mode if-mode) - (memq major-mode if-mode))) - (if-not-mode (not (if (atom if-not-mode) - (eq major-mode if-not-mode) - (memq major-mode if-not-mode)))) - (if-derived (if (or (atom if-derived) - (>= emacs-major-version 30)) - (derived-mode-p if-derived) - (apply #'derived-mode-p if-derived))) - (if-not-derived (not (if (or (atom if-not-derived) - (>= emacs-major-version 30)) - (derived-mode-p if-not-derived) - (apply #'derived-mode-p if-not-derived)))) - (default))) + (if (funcall if)) + (if-not (not (funcall if-not))) + (if-non-nil (symbol-value if-non-nil)) + (if-nil (not (symbol-value if-nil))) + (if-mode (if (atom if-mode) + (eq major-mode if-mode) + (memq major-mode if-mode))) + (if-not-mode (not (if (atom if-not-mode) + (eq major-mode if-not-mode) + (memq major-mode if-not-mode)))) + (if-derived (if (or (atom if-derived) + (>= emacs-major-version 30)) + (derived-mode-p if-derived) + (apply #'derived-mode-p if-derived))) + (if-not-derived (not (if (or (atom if-not-derived) + (>= emacs-major-version 30)) + (derived-mode-p if-not-derived) + (apply #'derived-mode-p if-not-derived)))) + (default))) (defun transient--suffix-predicate (spec) (let ((props (transient--suffix-props spec))) @@ -2649,30 +2650,30 @@ value. Otherwise return CHILDREN as is.") (not (transient--get-pre-command this-command nil 'suffix))) (setq this-command this-original-command)) (cond - ((memq this-command '(transient-update transient-quit-seq)) - (transient--pop-keymap 'transient--redisplay-map)) - ((and transient--helpp - (not (memq this-command transient--quit-commands))) - (cond - ((transient-help) - (transient--do-suspend) - (setq this-command 'transient-suspend) - (transient--pre-exit)) - ((not (transient--edebug-command-p)) - (setq this-command 'transient-undefined)))) - ((and transient--editp - (transient-suffix-object) - (not (memq this-command - (cons 'transient-help transient--quit-commands)))) - (setq this-command 'transient-set-level) - (transient--wrap-command)) - (t - (setq transient--exitp nil) - (let ((exitp (eq (transient--call-pre-command) transient--exit))) - (transient--wrap-command) - (when exitp - (transient--maybe-set-value 'exit) - (transient--pre-exit))))))) + ((memq this-command '(transient-update transient-quit-seq)) + (transient--pop-keymap 'transient--redisplay-map)) + ((and transient--helpp + (not (memq this-command transient--quit-commands))) + (cond + ((transient-help) + (transient--do-suspend) + (setq this-command 'transient-suspend) + (transient--pre-exit)) + ((not (transient--edebug-command-p)) + (setq this-command 'transient-undefined)))) + ((and transient--editp + (transient-suffix-object) + (not (memq this-command + (cons 'transient-help transient--quit-commands)))) + (setq this-command 'transient-set-level) + (transient--wrap-command)) + (t + (setq transient--exitp nil) + (let ((exitp (eq (transient--call-pre-command) transient--exit))) + (transient--wrap-command) + (when exitp + (transient--maybe-set-value 'exit) + (transient--pre-exit))))))) (defun transient--pre-exit () (transient--debug 'pre-exit) @@ -2787,25 +2788,25 @@ value. Otherwise return CHILDREN as is.") (advice (lambda (fn &rest args) (interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (let ((debugger #'transient--exit-and-debug)) - (if-let* ((obj suffix) - (grp (oref obj parent)) - (adv (or (oref obj advice*) - (oref grp advice*)))) - (funcall - adv #'advice-eval-interactive-spec spec) - (advice-eval-interactive-spec spec))) - (setq abort nil)) - (when abort - (when-let* ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind command)) - (when (symbolp command) - (remove-function (symbol-function command) advice)) - (oset prefix unwind-suffix nil)))))) + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (if-let* ((obj suffix) + (grp (oref obj parent)) + (adv (or (oref obj advice*) + (oref grp advice*)))) + (funcall + adv #'advice-eval-interactive-spec spec) + (advice-eval-interactive-spec spec))) + (setq abort nil)) + (when abort + (when-let* ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-interactive) + (funcall unwind command)) + (when (symbolp command) + (remove-function (symbol-function command) advice)) + (oset prefix unwind-suffix nil)))))) (unwind-protect (let ((debugger #'transient--exit-and-debug)) (if-let* ((obj suffix) @@ -3316,21 +3317,22 @@ transient is active." ;;;; Help -(defun transient-help (&optional interactive) +(defun transient-help (&optional interactivep) "Show help for the active transient or one of its suffixes. \n(fn)" (interactive (list t)) - (if interactive - (setq transient--helpp t) - (with-demoted-errors "transient-help: %S" - (when (lookup-key transient--transient-map - (this-single-command-raw-keys)) - (setq transient--helpp nil) - (transient--display-help #'transient-show-help - (if (eq this-original-command 'transient-help) - transient--prefix - (or (transient-suffix-object) - this-original-command))))))) + (cond + (interactivep + (setq transient--helpp t)) + ((lookup-key transient--transient-map + (this-single-command-raw-keys)) + (setq transient--helpp nil) + (with-demoted-errors "transient-help: %S" + (transient--display-help #'transient-show-help + (if (eq this-original-command 'transient-help) + transient--prefix + (or (transient-suffix-object) + this-original-command))))))) (transient-define-suffix transient-describe () "From a transient menu, describe something in another buffer. @@ -3358,55 +3360,55 @@ For example: (defun transient-set-level (&optional command level) "Set the level of the transient or one of its suffix commands." (interactive - (let ((command this-original-command) - (prefix (oref transient--prefix command))) - (and (or (not (eq command 'transient-set-level)) - (and transient--editp - (setq command prefix))) - (list command - (let ((keys (this-single-command-raw-keys))) - (and (lookup-key transient--transient-map keys) - (progn - (transient--show) - (string-to-number - (transient--read-number-N - (format "Set level for `%s': " command) - nil nil (not (eq command prefix))))))))))) + (let ((command this-original-command) + (prefix (oref transient--prefix command))) + (and (or (not (eq command 'transient-set-level)) + (and transient--editp + (setq command prefix))) + (list command + (let ((keys (this-single-command-raw-keys))) + (and (lookup-key transient--transient-map keys) + (progn + (transient--show) + (string-to-number + (transient--read-number-N + (format "Set level for `%s': " command) + nil nil (not (eq command prefix))))))))))) (cond - ((not command) - (setq transient--editp t) - (transient-setup)) - (level - (let* ((prefix (oref transient--prefix command)) - (alist (alist-get prefix transient-levels)) - (akey command)) - (cond ((eq command prefix) - (oset transient--prefix level level) - (setq akey t)) - (t - (oset (transient-suffix-object command) level level) - (when (cdr (cl-remove-if-not (lambda (obj) - (eq (oref obj command) command)) - transient--suffixes)) - (setq akey (cons command (this-command-keys)))))) - (setf (alist-get akey alist) level) - (setf (alist-get prefix transient-levels) alist)) - (transient-save-levels) - (transient--show)) - (t - (transient-undefined)))) + ((not command) + (setq transient--editp t) + (transient-setup)) + (level + (let* ((prefix (oref transient--prefix command)) + (alist (alist-get prefix transient-levels)) + (akey command)) + (cond ((eq command prefix) + (oset transient--prefix level level) + (setq akey t)) + (t + (oset (transient-suffix-object command) level level) + (when (cdr (cl-remove-if-not (lambda (obj) + (eq (oref obj command) command)) + transient--suffixes)) + (setq akey (cons command (this-command-keys)))))) + (setf (alist-get akey alist) level) + (setf (alist-get prefix transient-levels) alist)) + (transient-save-levels) + (transient--show)) + (t + (transient-undefined)))) (transient-define-suffix transient-toggle-level-limit () "Toggle whether to temporarily display suffixes on all levels." :description (lambda () (cond - (transient--all-levels-p - (format "Hide suffix %s" - (propertize - (format "levels > %s" (oref (transient-prefix-object) level)) - 'face 'transient-higher-level))) - ("Show all suffix levels"))) + (transient--all-levels-p + (format "Hide suffix %s" + (propertize + (format "levels > %s" (oref (transient-prefix-object) level)) + 'face 'transient-higher-level))) + ("Show all suffix levels"))) :transient t (interactive) (setq transient--all-levels-p (not transient--all-levels-p)) @@ -3695,13 +3697,13 @@ it\", in which case it is pointless to preserve history.)" 'transient--history)) (value (cond - (reader (funcall reader prompt initial-input history)) - (multi-value - (completing-read-multiple prompt choices nil nil - initial-input history)) - (choices - (completing-read prompt choices nil t initial-input history)) - ((read-string prompt initial-input history))))) + (reader (funcall reader prompt initial-input history)) + (multi-value + (completing-read-multiple prompt choices nil nil + initial-input history)) + (choices + (completing-read prompt choices nil t initial-input history)) + ((read-string prompt initial-input history))))) (cond ((and (equal value "") (not allow-empty)) (setq value nil)) ((and (equal value "\"\"") allow-empty) @@ -4097,17 +4099,19 @@ a string, using the empty string for the empty value, or nil if the option does not appear in ARGS. Append \"=\ to ARG to indicate that it is an option." - (if (string-suffix-p "=" arg) - (save-match-data - (and-let* ((match (let ((case-fold-search nil) - (re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'" - (substring arg 0 -1)))) - (cl-find-if (lambda (a) - (and (stringp a) - (string-match re a))) - args)))) - (or (match-string 1 match) ""))) - (and (member arg args) t))) + (save-match-data + (cond* + ((member arg args) t) + ((bind-and* + (_(string-suffix-p "=" arg)) + (match (let ((case-fold-search nil) + (re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'" + (substring arg 0 -1)))) + (cl-find-if (lambda (a) + (and (stringp a) + (string-match re a))) + args)))) + (match-string 1 match))))) ;;;; Return @@ -4177,21 +4181,23 @@ be non-nil. If either is non-nil, try the following in order: class definition or using its `transient-init-scope' method. If no prefix matches, return nil." - (if (or prefixes classes) - (let ((prefixes (ensure-list prefixes)) - (type (if (symbolp classes) classes (cons 'or classes)))) - (if-let* ((obj (cl-flet ((match (obj) - (and obj - (or (memq (oref obj command) prefixes) - (cl-typep obj type)) - obj))) - (or (match transient-current-prefix) - (match transient--prefix))))) - (oref obj scope) - (and (get (car prefixes) 'transient--prefix) - (oref (transient--init-prefix (car prefixes)) scope)))) - (and-let* ((obj (transient-prefix-object))) - (oref obj scope)))) + (cond* + ((or prefixes classes) + (let* ((prefixes (ensure-list prefixes)) + (type (if (symbolp classes) classes (cons 'or classes))) + (match (lambda (obj) + (and obj + (or (memq (oref obj command) prefixes) + (cl-typep obj type)) + obj)))) + (cond* + ((bind-and* (obj (or (funcall match transient-current-prefix) + (funcall match transient--prefix)))) + (oref obj scope)) + ((get (car prefixes) 'transient--prefix) + (oref (transient--init-prefix (car prefixes)) scope))))) + ((bind-and* (obj (transient-prefix-object))) + (oref obj scope)))) ;;;; History @@ -4309,15 +4315,15 @@ have a history of their own.") (and (minibuffer-selected-window) (selected-window)))) (cond - ((eq (car (window-parameter win 'quit-restore)) 'other) - ;; Window used to display another buffer. - (set-window-parameter win 'no-other-window - (window-parameter win 'prev--no-other-window)) - (set-window-parameter win 'prev--no-other-window nil)) - ((with-demoted-errors "Error while exiting transient: %S" - (if (window-parent win) - (delete-window win) - (delete-frame (window-frame win) t))))) + ((eq (car (window-parameter win 'quit-restore)) 'other) + ;; Window used to display another buffer. + (set-window-parameter win 'no-other-window + (window-parameter win 'prev--no-other-window)) + (set-window-parameter win 'prev--no-other-window nil)) + ((with-demoted-errors "Error while exiting transient: %S" + (if (window-parent win) + (delete-window win) + (delete-frame (window-frame win) t))))) (when remain-in-minibuffer-window (select-window remain-in-minibuffer-window)))) (when (buffer-live-p transient--buffer) @@ -4576,49 +4582,49 @@ as a button." (let ((len (length transient--redisplay-key)) (seq (cl-coerce (edmacro-parse-keys key t) 'list))) (cond - ((member (seq-take seq len) - (list transient--redisplay-key - (thread-last transient--redisplay-key - (cl-substitute ?- 'kp-subtract) - (cl-substitute ?= 'kp-equal) - (cl-substitute ?+ 'kp-add)))) - (let ((pre (key-description (vconcat (seq-take seq len)))) - (suf (key-description (vconcat (seq-drop seq len))))) - (setq pre (string-replace "RET" "C-m" pre)) - (setq pre (string-replace "TAB" "C-i" pre)) - (setq suf (string-replace "RET" "C-m" suf)) - (setq suf (string-replace "TAB" "C-i" suf)) - ;; We use e.g., "-k" instead of the more correct "- k", - ;; because the former is prettier. If we did that in - ;; the definition, then we want to drop the space that - ;; is reinserted above. False-positives are possible - ;; for silly bindings like "-C-c C-c". - (unless (string-search " " key) - (setq pre (string-replace " " "" pre)) - (setq suf (string-replace " " "" suf))) - (concat (propertize pre 'face 'transient-unreachable-key) - (and (string-prefix-p (concat pre " ") key) " ") - (propertize suf 'face (transient--key-face cmd key)) - (save-excursion - (and (string-match " +\\'" key) - (propertize (match-string 0 key) - 'face 'fixed-pitch)))))) - ((transient--lookup-key transient-sticky-map (kbd key)) - (propertize key 'face (transient--key-face cmd key))) - (t - (propertize key 'face 'transient-unreachable-key)))) + ((member (seq-take seq len) + (list transient--redisplay-key + (thread-last transient--redisplay-key + (cl-substitute ?- 'kp-subtract) + (cl-substitute ?= 'kp-equal) + (cl-substitute ?+ 'kp-add)))) + (let ((pre (key-description (vconcat (seq-take seq len)))) + (suf (key-description (vconcat (seq-drop seq len))))) + (setq pre (string-replace "RET" "C-m" pre)) + (setq pre (string-replace "TAB" "C-i" pre)) + (setq suf (string-replace "RET" "C-m" suf)) + (setq suf (string-replace "TAB" "C-i" suf)) + ;; We use e.g., "-k" instead of the more correct "- k", + ;; because the former is prettier. If we did that in + ;; the definition, then we want to drop the space that + ;; is reinserted above. False-positives are possible + ;; for silly bindings like "-C-c C-c". + (unless (string-search " " key) + (setq pre (string-replace " " "" pre)) + (setq suf (string-replace " " "" suf))) + (concat (propertize pre 'face 'transient-unreachable-key) + (and (string-prefix-p (concat pre " ") key) " ") + (propertize suf 'face (transient--key-face cmd key)) + (save-excursion + (and (string-match " +\\'" key) + (propertize (match-string 0 key) + 'face 'fixed-pitch)))))) + ((transient--lookup-key transient-sticky-map (kbd key)) + (propertize key 'face (transient--key-face cmd key))) + (t + (propertize key 'face 'transient-unreachable-key)))) (propertize key 'face (transient--key-face cmd key))))) (cl-defmethod transient-format-key :around ((obj transient-argument)) "Handle `transient-highlight-mismatched-keys'." (let ((key (cl-call-next-method obj))) (cond - ((not transient-highlight-mismatched-keys) key) - ((not (slot-boundp obj 'shortarg)) - (transient--add-face key 'transient-nonstandard-key)) - ((not (string-equal key (oref obj shortarg))) - (transient--add-face key 'transient-mismatched-key)) - (key)))) + ((not transient-highlight-mismatched-keys) key) + ((not (slot-boundp obj 'shortarg)) + (transient--add-face key 'transient-nonstandard-key)) + ((not (string-equal key (oref obj shortarg))) + (transient--add-face key 'transient-mismatched-key)) + (key)))) (cl-defgeneric transient-format-description (obj) "Format OBJ's `description' for display and return the result.") @@ -4631,7 +4637,7 @@ and its value is returned to the caller." (cl-defmethod transient-format-description ((obj transient-value-preset)) (pcase-let* (((eieio description key set) obj) - ((eieio value) transient--prefix) + (value (transient--get-extended-value)) (active (seq-set-equal-p set value))) (format "%s %s" @@ -4752,23 +4758,24 @@ apply the face `transient-unreachable' to the complete string." (propertize "|" 'face 'transient-delimiter)))))) (cl-defmethod transient--get-description ((obj transient-child)) - (and-let* ((desc (oref obj description))) - (if (functionp desc) - (if (= (car (transient--func-arity desc)) 1) - (funcall desc obj) - (funcall desc)) - desc))) + (cond* + ((bind* (desc (oref obj description)))) + ((functionp desc) + (condition-case nil + (funcall desc obj) + (wrong-number-of-arguments (funcall desc)))) + (desc))) (cl-defmethod transient--get-face ((obj transient-suffix) slot) - (and-let* ((_(slot-boundp obj slot)) - (face (slot-value obj slot))) - (if (and (not (facep face)) - (functionp face)) - (let ((transient--pending-suffix obj)) - (if (= (car (transient--func-arity face)) 1) - (funcall face obj) - (funcall face))) - face))) + (cond* + ((not (slot-boundp obj slot)) nil) + ((bind* (face (slot-value obj slot)))) + ((facep face) face) + ((functionp face) + (let ((transient--pending-suffix obj)) + (condition-case nil + (funcall face obj) + (wrong-number-of-arguments (funcall face))))))) (defun transient--add-face (string face &optional append beg end) (let ((str (copy-sequence string))) @@ -4875,7 +4882,7 @@ prefix method." ((eq this-command 'transient-help) (transient-show-help transient--prefix)) ((bind-and* (prefix (get (oref obj command) 'transient--prefix)) - (n/a (not (eq (oref transient--prefix command) this-command)))) + (_(not (eq (oref transient--prefix command) this-command)))) (transient-show-help prefix)) ((bind-and* (show-help (oref obj show-help))) (funcall show-help obj)) @@ -5116,20 +5123,20 @@ See `forward-button' for information about N." (defun transient--goto-button (command) (cond - ((stringp command) - (when (re-search-forward (concat "^" (regexp-quote command)) nil t) - (goto-char (match-beginning 0)))) - (command - (cl-flet ((found () - (and-let* ((button (button-at (point)))) - (eq (button-get button 'command) command)))) - (while (and (ignore-errors (forward-button 1)) - (not (found)))) - (unless (found) - (goto-char (point-min)) - (ignore-errors (forward-button 1)) - (unless (found) - (goto-char (point-min)))))))) + ((stringp command) + (when (re-search-forward (concat "^" (regexp-quote command)) nil t) + (goto-char (match-beginning 0)))) + (command + (cl-flet ((found () + (and-let* ((button (button-at (point)))) + (eq (button-get button 'command) command)))) + (while (and (ignore-errors (forward-button 1)) + (not (found)))) + (unless (found) + (goto-char (point-min)) + (ignore-errors (forward-button 1)) + (unless (found) + (goto-char (point-min)))))))) (defun transient--heading-at-point () (and (eq (get-text-property (point) 'face) 'transient-heading) @@ -5253,7 +5260,7 @@ that binding back, then call this function in your init file like so: Individual transients may already bind \\`q' to something else and such a binding would shadow the quit binding. If that is the case then \\`Q' is bound to whatever \\`q' would have been bound -to by setting `transient-substitute-key-function' to a function +to, by setting `transient-substitute-key-function' to a function that does that. Of course \\`Q' may already be bound to something else, so that function binds \\`M-q' to that command instead. Of course \\`M-q' may already be bound to something else, but @@ -5275,9 +5282,6 @@ we stop there." (face-remap-reset-base 'default) (face-remap-add-relative 'default 'fixed-pitch)) -(defun transient--func-arity (fn) - (func-arity (advice--cd*r (if (symbolp fn) (symbol-function fn) fn)))) - (defun transient--seq-reductions-from (function sequence initial-value) (let ((acc (list initial-value))) (seq-doseq (elt sequence) @@ -5373,7 +5377,11 @@ as stand-in for elements of exhausted lists." ;;;; _ (provide 'transient) ;; Local Variables: -;; indent-tabs-mode: nil ;; checkdoc-symbol-words: ("command-line" "edit-mode" "help-mode") +;; indent-tabs-mode: nil +;; lisp-indent-local-overrides: ( +;; (cond . 0) +;; (cond* . 0) +;; (interactive . 0)) ;; End: ;;; transient.el ends here diff --git a/lisp/treesit.el b/lisp/treesit.el index 4421523d0be..3feaa51c0a6 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -78,7 +78,9 @@ in a Emacs not built with tree-sitter library." (declare-function treesit-node-p "treesit.c") (declare-function treesit-compiled-query-p "treesit.c") (declare-function treesit-query-p "treesit.c") + (declare-function treesit-query-eagerly-compiled-p "treesit.c") (declare-function treesit-query-language "treesit.c") + (declare-function treesit-query-source "treesit.c") (declare-function treesit-node-parser "treesit.c") @@ -88,8 +90,12 @@ in a Emacs not built with tree-sitter library." (declare-function treesit-parser-buffer "treesit.c") (declare-function treesit-parser-language "treesit.c") (declare-function treesit-parser-tag "treesit.c") + (declare-function treesit-parser-embed-level "treesit.c") + (declare-function treesit-parser-set-embed-level "treesit.c") + (declare-function treesit-parser-changed-regions "treesit.c") (declare-function treesit-parser-root-node "treesit.c") + (declare-function treesit-parse-string "treesit.c") (declare-function treesit-parser-set-included-ranges "treesit.c") (declare-function treesit-parser-included-ranges "treesit.c") @@ -994,9 +1000,6 @@ is nil." (null (treesit-parser-embed-level parser))))) parsers)) -(declare-function treesit-parser-set-embed-level "treesit.c") -(declare-function treesit-parser-embed-level "treesit.c") - (defun treesit--update-ranges-non-local ( host-parser query embed-lang modified-tick embed-level &optional beg end offset range-fn) @@ -1469,7 +1472,10 @@ done via `customize-variable'. To see which syntactical categories are fontified by each level in a particular major mode, examine the buffer-local value of the -variable `treesit-font-lock-feature-list'." +variable `treesit-font-lock-feature-list'. + +Setting this variable directly with `setq' or `let' doesn't work; +use `setopt' or \\[customize-option] instead." :type 'integer :set #'treesit--font-lock-level-setter :version "29.1") @@ -1696,15 +1702,16 @@ no match, return 3." (&optional add-list remove-list language) "Enable/disable font-lock features and validate and compile queries. -Enable each feature in ADD-LIST, disable each feature in -REMOVE-LIST. +When either ADD-LIST or REMOVE-LIST is non-nil, enable/disable features +according to ADD-LIST and REMOVE-LIST, on top of the currently enabled +features in the buffer. -If both ADD-LIST and REMOVE-LIST are omitted, recompute each -feature according to `treesit-font-lock-feature-list' and +If (and only if) both ADD-LIST and REMOVE-LIST are omitted, recompute +each feature according to `treesit-font-lock-feature-list' and `treesit-font-lock-level'. If the value of `treesit-font-lock-level', is N, then the features in the first N sublists of -`treesit-font-lock-feature-list' are enabled, and the rest of -the features are disabled. +`treesit-font-lock-feature-list' are enabled, and the rest of the +features are disabled. ADD-LIST and REMOVE-LIST are lists of feature symbols. The same feature symbol cannot appear in both lists; the function @@ -2174,8 +2181,6 @@ parser." (signal 'treesit-no-parser nil)))) (car (treesit-parser-list)))) -(declare-function treesit-parser-changed-regions "treesit.c") - (defun treesit--pre-redisplay (&rest _) "Force a reparse on primary parser and mark regions to be fontified." (unless (eq treesit--pre-redisplay-tick (buffer-chars-modified-tick)) @@ -4282,11 +4287,9 @@ For BOUND, MOVE, BACKWARD, LOOKING-AT, see the descriptions in "Tree-sitter implementation of `hs-find-block-beginning-function'." (let* ((pred (bound-and-true-p hs-treesit-things)) (thing (treesit-thing-at (point) pred)) - (beg (when thing (treesit-node-start thing))) - (end (when beg (min (1+ beg) (point-max))))) + (beg (when thing (treesit-node-start thing)))) (when thing (goto-char beg) - (set-match-data (list beg end)) t))) (defun treesit-hs-find-next-block (_regexp maxp comments) diff --git a/lisp/tutorial.el b/lisp/tutorial.el index 113d13d11c2..c071c1ff1d8 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -153,60 +153,17 @@ options: " you can use " (if (string-match-p "^the .*menus?$" where) "" - "the key") + "the key ") where (format-message " to get the function `%s'." db)))) (fill-region (point-min) (point))))) (help-print-return-message)))) -(defun tutorial--sort-keys (left right) - "Sort predicate for use with `tutorial--default-keys'. -This is a predicate function to `sort'. - -The sorting is for presentation purpose only and is done on the -key sequence. - -LEFT and RIGHT are the elements to compare." - (let ((x (append (cadr left) nil)) - (y (append (cadr right) nil))) - ;; Skip the front part of the key sequences if they are equal: - (while (and x y - (listp x) (listp y) - (equal (car x) (car y))) - (setq x (cdr x)) - (setq y (cdr y))) - ;; Try to make a comparison that is useful for presentation (this - ;; could be made nicer perhaps): - (let ((cx (car x)) - (cy (car y))) - ;;(message "x=%s, y=%s;;;; cx=%s, cy=%s" x y cx cy) - (cond - ;; Lists? Then call this again - ((and cx cy - (listp cx) - (listp cy)) - (tutorial--sort-keys cx cy)) - ;; Are both numbers? Then just compare them - ((and (wholenump cx) - (wholenump cy)) - (> cx cy)) - ;; Is one of them a number? Let that be bigger then. - ((wholenump cx) - t) - ((wholenump cy) - nil) - ;; Are both symbols? Compare the names then. - ((and (symbolp cx) - (symbolp cy)) - (string< (symbol-name cy) - (symbol-name cx))))))) - (defconst tutorial--default-keys - ;; On window system, `suspend-emacs' is replaced in the default keymap. - (let* ((suspend-emacs 'suspend-frame) - (default-keys + (eval-when-compile + (let ((default-keys ;; The first few are not mentioned but are basic: - `((ESC-prefix [27]) + '((ESC-prefix [27]) (Control-X-prefix [?\C-x]) (mode-specific-command-prefix [?\C-c]) (save-buffers-kill-terminal [?\C-x ?\C-c]) @@ -227,7 +184,7 @@ LEFT and RIGHT are the elements to compare." (move-end-of-line [?\C-e]) (backward-sentence [?\M-a]) (forward-sentence [?\M-e]) - (newline "\r") + (newline [?\C-m]) (beginning-of-buffer [?\M-<]) (end-of-buffer [?\M->]) (universal-argument [?\C-u]) @@ -245,7 +202,7 @@ LEFT and RIGHT are the elements to compare." ;; * INSERTING AND DELETING ;; C-u 8 * to insert ********. - (delete-backward-char "\d") + (delete-backward-char [?\C-?]) (delete-char [?\C-d]) (backward-kill-word [?\M-\d]) (kill-word [?\M-d]) @@ -309,8 +266,8 @@ LEFT and RIGHT are the elements to compare." ;; * CONCLUSION ;;(iconify-or-deiconify-frame [?\C-z]) - (,suspend-emacs [?\C-z])))) - (sort default-keys 'tutorial--sort-keys)) + (suspend-frame [?\C-z])))) + (sort default-keys :key #'cadr))) "Default Emacs key bindings that the tutorial depends on.") (defun tutorial--detailed-help (button) diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el index 5c052ad92fe..275555b4838 100644 --- a/lisp/url/url-dav.el +++ b/lisp/url/url-dav.el @@ -27,8 +27,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'xml) (require 'url-util) (require 'url-handlers) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index dcba8c44792..5c0fb5fba4c 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -875,6 +875,7 @@ If the prefix ARG is given, restrict the view to the current file instead." (apply #'narrow-to-region (if arg (diff-bounds-of-file) (diff-bounds-of-hunk))) (setq-local diff-narrowed-to (if arg 'file 'hunk))) +(put 'diff-restrict-view 'disabled t) (defun diff--some-hunks-p () (save-excursion @@ -2358,7 +2359,7 @@ applied. Other non-nil values are reserved." (while (pcase-let ((`(,buf ,line-offset ,pos ,_src ,dst ,switched) (diff-find-source-location nil reverse test))) ;; FIXME: Should respect `diff-apply-hunk-to-backup-file' - ;; similarly to how `diff-apply-buffer' does. + ;; similarly to how `diff-apply-hunk' does. ;; Prompt for each relevant file. (cond ((and line-offset (not switched)) (push (cons pos dst) diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 87ffc6dfe0e..27c62847b50 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -130,7 +130,7 @@ (defvar-keymap log-view-mode-map "RET" #'log-view-toggle-entry-display - "M-" #'log-view-display-entry-and-diff + "M-RET" #'log-view-display-entry-and-diff "m" #'log-view-mark-entry "u" #'log-view-unmark-entry "U" #'log-view-unmark-all-entries diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 6cb162a96f5..5781ddc45d9 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -294,10 +294,10 @@ That is, refreshing the VC-Dir buffer also hides `up-to-date' and '(menu-item "Compare with Base Version" vc-diff :help "Compare file set with the base version")) (define-key map [logo] - '(menu-item "Show Outgoing Log" vc-log-outgoing + '(menu-item "Show Outgoing Log" vc-root-log-outgoing :help "Show a log of changes that will be sent with a push operation")) (define-key map [logi] - '(menu-item "Show Incoming Log" vc-log-incoming + '(menu-item "Show Incoming Log" vc-root-log-incoming :help "Show a log of changes that will be received with a pull operation")) (define-key map [log] '(menu-item "Show History" vc-print-log @@ -354,8 +354,8 @@ That is, refreshing the VC-Dir buffer also hides `up-to-date' and (define-key map "P" #'vc-push) ;; C-x v P (define-key map "l" #'vc-print-log) ;; C-x v l (define-key map "L" #'vc-print-root-log) ;; C-x v L - (define-key map "I" #'vc-log-incoming) ;; C-x v I - (define-key map "O" #'vc-log-outgoing) ;; C-x v O + (define-key map "I" #'vc-root-log-incoming) ;; C-x v I + (define-key map "O" #'vc-root-log-outgoing) ;; C-x v O ;; More confusing than helpful, probably ;;(define-key map "R" #'vc-revert) ;; u is taken by vc-dir-unmark. ;;(define-key map "A" #'vc-annotate) ;; g is taken by revert-buffer @@ -396,6 +396,11 @@ That is, refreshing the VC-Dir buffer also hides `up-to-date' and (define-key map (kbd "M-s a C-s") #'vc-dir-isearch) (define-key map (kbd "M-s a M-C-s") #'vc-dir-isearch-regexp) (define-key map "G" #'vc-dir-ignore) + (define-key map "@" #'vc-revert) + (define-key map "Tl" #'vc-log-outgoing-base) + (define-key map "TL" #'vc-root-log-outgoing-base) + (define-key map "T=" #'vc-diff-outgoing-base) + (define-key map "TD" #'vc-root-diff-outgoing-base) (let ((branch-map (make-sparse-keymap))) (define-key map "b" branch-map) @@ -1335,7 +1340,7 @@ the *vc-dir* buffer. (defvar-keymap vc-dir-outgoing-revisions-map :doc "Local keymap for viewing outgoing revisions." - "" #'vc-log-outgoing) + "" #'vc-root-log-outgoing) (defcustom vc-dir-show-outgoing-count t "Whether to display the number of unpushed revisions in VC-Dir. @@ -1386,7 +1391,7 @@ specific headers." 'mouse-face 'highlight 'keymap vc-dir-outgoing-revisions-map 'help-echo "\\\ -\\[vc-log-outgoing]: List outgoing revisions") +\\[vc-root-log-outgoing]: List outgoing revisions") "\n")))) (defun vc-dir-refresh-files (files) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 29e8a24ca0a..73db9c0f181 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -767,13 +767,79 @@ or an empty string if none." :files files :update-function update-function))) -(defun vc-git--current-branch () +(defun vc-git-working-branch () + "Return the name of the current branch, or nil if HEAD is detached." (vc-git--out-match '("symbolic-ref" "HEAD") "^\\(refs/heads/\\)?\\(.+\\)$" 2)) +(defun vc-git-trunk-or-topic-p () + "Return `topic' if branch has distinct pull and push remotes, else nil. +This is able to identify topic branches for certain forge workflows." + (let* ((branch (vc-git-working-branch)) + (merge (string-trim-right + (vc-git--out-str "config" (format "branch.%s.remote" + branch)))) + (push (string-trim-right + (vc-git--out-str "config" (format "branch.%s.pushRemote" + branch)))) + (push (if (string-empty-p push) + (string-trim-right + (vc-git--out-str "config" "remote.pushDefault")) + push))) + (and (plusp (length merge)) + (plusp (length push)) + (not (equal merge push)) + 'topic))) + +(defun vc-git-topic-outgoing-base () + "Return the outgoing base for the current branch as a string. +This works by considering the current branch as a topic branch +(whether or not it actually is). +Requires that the corresponding trunk exists as a local branch. + +The algorithm employed is as follows. Find all merge bases between the +current branch and other local branches. Each of these is a commit on +the current branch. Use `git merge-base --independent' on them all to +find the topologically most recent. Take the branch for which that +commit is a merge base with the current branch to be the branch into +which the current branch will eventually be merged. Find its upstream. +(If there is more than one branch whose merge base with the current +branch is that same topologically most recent commit, try them +one-by-one, accepting the first that has an upstream.)" + (cl-flet ((get-line () (buffer-substring (point) (pos-eol)))) + (let* ((branches (vc-git-branches)) + (current (pop branches)) + merge-bases) + (with-temp-buffer + (dolist (branch branches) + (erase-buffer) + (when (vc-git--out-ok "merge-base" "--all" branch current) + (goto-char (point-min)) + (while (not (eobp)) + (push branch + (alist-get (get-line) merge-bases nil nil #'equal)) + (forward-line 1)))) + (erase-buffer) + (unless (apply #'vc-git--out-ok "merge-base" "--independent" + (mapcar #'car merge-bases)) + (error "`git merge-base --independent' failed")) + ;; If 'git merge-base --independent' printed more than one line, + ;; just pick the first. + (goto-char (point-min)) + (catch 'ret + (dolist (target (cdr (assoc (get-line) merge-bases))) + (erase-buffer) + (when (vc-git--out-ok "for-each-ref" + "--format=%(upstream:short)" + (concat "refs/heads/" target)) + (goto-char (point-min)) + (let ((outgoing-base (get-line))) + (unless (string-empty-p outgoing-base) + (throw 'ret outgoing-base)))))))))) + (defun vc-git-dir--branch-headers () "Return headers for branch-related information." - (let ((branch (vc-git--current-branch)) + (let ((branch (vc-git-working-branch)) tracking remote-url) (if branch (when-let* ((branch-merge @@ -1758,7 +1824,7 @@ If LIMIT is a non-empty string, use it as a base revision." ;; If the branch has no upstream, and we weren't supplied ;; with one, then fetching is always useless (bug#79952). (or upstream-location - (and-let* ((branch (vc-git--current-branch))) + (and-let* ((branch (vc-git-working-branch))) (with-temp-buffer (vc-git--out-ok "config" "--get" (format "branch.%s.remote" @@ -2235,7 +2301,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defun vc-git-revision-published-p (rev) "Whether we think REV has been pushed such that it is public history. Considers only the current branch. Does not fetch." - (let ((branch (vc-git--current-branch)) + (let ((branch (vc-git-working-branch)) (rev (vc-git--rev-parse rev))) (vc-git--assert-revision-on-branch rev branch) (and @@ -2334,7 +2400,7 @@ Rebase may --autosquash your other squash!/fixup!/amend!; proceed?"))) (defun vc-git-delete-revision (rev) "Rebase current branch to remove REV." - (vc-git--assert-revision-on-branch rev (vc-git--current-branch)) + (vc-git--assert-revision-on-branch rev (vc-git-working-branch)) (with-temp-buffer (vc-git-command t 0 nil "log" "--merges" (format "%s~1.." rev)) (unless (bobp) @@ -2352,13 +2418,13 @@ Rebase may --autosquash your other squash!/fixup!/amend!; proceed?"))) (defun vc-git-delete-revisions-from-end (rev) "Hard reset back to REV. It is an error if REV is not on the current branch." - (vc-git--assert-revision-on-branch rev (vc-git--current-branch)) + (vc-git--assert-revision-on-branch rev (vc-git-working-branch)) (vc-git-command nil 0 nil "reset" "--hard" rev)) (defun vc-git-uncommit-revisions-from-end (rev) "Mixed reset back to REV. It is an error if REV is not on the current branch." - (vc-git--assert-revision-on-branch rev (vc-git--current-branch)) + (vc-git--assert-revision-on-branch rev (vc-git-working-branch)) (vc-git-command nil 0 nil "reset" "--mixed" rev)) (defvar vc-git-extra-menu-map diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index aeed1de5567..90e25ba43f4 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1941,6 +1941,42 @@ It is an error if REV is not on the current branch." (vc-hg--assert-rev-on-current-branch rev) (vc-hg--reset-back-to rev t)) +(defun vc-hg--working-branch () + "Return alist with currently active bookmark, if any, and current branch. +Keys into the alist are `branch' and `bookmark', values are the name of +the currently active bookmark (or nil) and the name of the current +branch, as strings." + (with-temp-buffer + (vc-hg-command t nil nil "summary") + (goto-char (point-min)) + (re-search-forward "^branch: \\(.+\\)$") + (let ((alist `((branch . ,(match-string 1))))) + (goto-char (point-min)) + (if (re-search-forward "^bookmarks: \\*\\(\\S-+\\)" nil t) + (cl-acons 'bookmark (match-string 1) alist) + alist)))) + +(defun vc-hg-working-branch () + "Return currently active bookmark if one exists, else current branch. +The return value is always a string." + (let ((alist (vc-hg--working-branch))) + (cdr (or (assq 'bookmark alist) (assq 'branch alist))))) + +(defun vc-hg-trunk-or-topic-p () + "Return `topic' if there is a currently active bookmark, else nil." + (and (assq 'bookmark (vc-hg--working-branch)) 'topic)) + +(defun vc-hg-topic-outgoing-base () + "Return outgoing base for current commit considered as a topic branch. +The current implementation always returns the name of the current +branch, meaning to query the remote head for the current branch +(and not any active bookmark if it also exists remotely). +This is based on the following assumptions: +(i) if there is an active bookmark, it will eventually be merged into + whatever the remote head is +(ii) there is only one remote head for the current branch." + (assq 'branch (vc-hg--working-branch))) + (provide 'vc-hg) ;;; vc-hg.el ends here diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index ef80fc084ab..f3519465c07 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -1014,16 +1014,19 @@ In the latter case, VC mode is deactivated for this buffer." "i" #'vc-register "l" #'vc-print-log "L" #'vc-print-root-log - "I" #'vc-log-incoming - "O" #'vc-log-outgoing + "I" #'vc-root-log-incoming + "O" #'vc-root-log-outgoing "M L" #'vc-log-mergebase "M D" #'vc-diff-mergebase - "o =" #'vc-diff-outgoing-base - "o D" #'vc-root-diff-outgoing-base + "T l" #'vc-log-outgoing-base + "T L" #'vc-root-log-outgoing-base + "T =" #'vc-diff-outgoing-base + "T D" #'vc-root-diff-outgoing-base "m" #'vc-merge "r" #'vc-retrieve-tag "s" #'vc-create-tag - "u" #'vc-revert + "u" #'vc-revert ; The traditional binding. + "@" #'vc-revert ; Following VC-Dir's binding. "v" #'vc-next-action "+" #'vc-update "P" #'vc-push @@ -1044,11 +1047,11 @@ In the latter case, VC mode is deactivated for this buffer." (define-key ctl-x-map "v" 'vc-prefix-map) (defvar-keymap vc-incoming-prefix-map - "L" #'vc-log-incoming + "L" #'vc-root-log-incoming "=" #'vc-diff-incoming "D" #'vc-root-diff-incoming) (defvar-keymap vc-outgoing-prefix-map - "L" #'vc-log-outgoing + "L" #'vc-root-log-outgoing "=" #'vc-diff-outgoing "D" #'vc-root-diff-outgoing) @@ -1056,9 +1059,10 @@ In the latter case, VC mode is deactivated for this buffer." "Whether \\`C-x v I' and \\`C-x v O' are prefix commands. Historically Emacs bound \\`C-x v I' and \\`C-x v O' directly to commands. That is still the default. If this option is customized to -non-nil, these key sequences becomes prefix commands. `vc-log-incoming' -moves to \\`C-x v I L', `vc-log-outgoing' moves to \\`C-x v O L', and -other commands receive global bindings where they had none before." +non-nil, these key sequences becomes prefix commands. +`vc-root-log-incoming' moves to \\`C-x v I L', `vc-root-log-outgoing' +moves to \\`C-x v O L', and other commands receive global bindings where +they had none before." :type 'boolean :version "31.1" :set (lambda (symbol value) @@ -1070,8 +1074,8 @@ other commands receive global bindings where they had none before." (keymap-set map "I" vc-incoming-prefix-map) (keymap-set map "O" vc-outgoing-prefix-map)) (dolist (map maps) - (keymap-set map "I" #'vc-log-incoming) - (keymap-set map "O" #'vc-log-outgoing)))) + (keymap-set map "I" #'vc-root-log-incoming) + (keymap-set map "O" #'vc-root-log-outgoing)))) (set-default symbol value))) (defvar vc-menu-map @@ -1122,10 +1126,10 @@ other commands receive global bindings where they had none before." '(menu-item "Update ChangeLog" vc-update-change-log :help "Find change log file and add entries from recent version control logs")) (define-key map [vc-log-out] - '(menu-item "Show Outgoing Log" vc-log-outgoing + '(menu-item "Show Outgoing Log" vc-root-log-outgoing :help "Show a log of changes that will be sent with a push operation")) (define-key map [vc-log-in] - '(menu-item "Show Incoming Log" vc-log-incoming + '(menu-item "Show Incoming Log" vc-root-log-incoming :help "Show a log of changes that will be received with a pull operation")) (define-key map [vc-print-log] '(menu-item "Show History" vc-print-log @@ -1186,6 +1190,14 @@ other commands receive global bindings where they had none before." (defun vc-default-extra-menu (_backend) nil) +(defun vc--safe-branch-regexps-p (val) + "Return non-nil if VAL is a safe local value for \\+`vc-*-branch-regexps'." + (or (eq val t) + (and (listp val) + (all (lambda (elt) + (or (symbolp elt) (stringp elt))) + val)))) + (provide 'vc-hooks) ;;; vc-hooks.el ends here diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el index fa664e51220..c43b37627fb 100644 --- a/lisp/vc/vc-src.el +++ b/lisp/vc/vc-src.el @@ -82,7 +82,6 @@ ;;; (eval-when-compile - (require 'cl-lib) (require 'vc)) (declare-function vc-setup-buffer "vc-dispatcher" (buf)) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 94bc72fc406..770906ff6cc 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -610,6 +610,36 @@ ;; does a sanity check whether there aren't any uncommitted changes at ;; or below DIR, and then performs a tree walk, using the `checkout' ;; function to retrieve the corresponding revisions. +;; +;; - working-branch () +;; +;; Return the name of the current branch, if there is one, else nil. +;; +;; - trunk-or-topic-p () +;; +;; For the current branch, or the closest equivalent for a VCS without +;; named branches, return `trunk' if it is definitely a longer-lived +;; trunk branch, `topic' if it is definitely a shorter-lived topic +;; branch, or nil if no general determination can be made. +;; +;; What counts as a longer-lived or shorter-lived branch for VC is +;; explained in Info node `(emacs)Outstanding Changes' and in the +;; docstrings for the `vc-trunk-branch-regexps' and +;; `vc-topic-branch-regexps' user options. +;; +;; - topic-outgoing-base () +;; +;; Return an outgoing base for the current branch (or the closest +;; equivalent for a VCS without named branches) considered as a topic +;; branch. That is, on the assumption that the current branch is a +;; shorter-lived branch which will later be merged into a longer-lived +;; branch, return, if possible, the upstream location to which those +;; changes will be merged. See Info node `(emacs) Outstanding +;; Changes'. The return value should be suitable for passing to the +;; incoming-revision backend function as its UPSTREAM-LOCATION +;; argument. For example, for Git the value will typically be of the +;; form 'origin/foo' whereas Mercurial uses the unmodified name of the +;; longer-lived branch. ;; MISCELLANEOUS ;; @@ -1474,7 +1504,7 @@ BEWARE: this function may change the current buffer." (vc-deduce-fileset not-state-changing allow-unregistered state-model-only-files))) ((and (not buffer-file-name) (setq backend (vc-responsible-backend default-directory))) - (list backend nil)) + (list backend (list default-directory))) ((and allow-unregistered (not (vc-registered buffer-file-name))) (if state-model-only-files (list (vc-backend-for-registration (buffer-file-name)) @@ -3126,21 +3156,189 @@ global binding." (vc-symbolic-working-revision (caadr fileset) backend) (called-interactively-p 'interactive)))) -;; For the following two commands, the default meaning for -;; UPSTREAM-LOCATION may become dependent on whether we are on a -;; shorter-lived or longer-lived ("trunk") branch. If we are on the -;; trunk then it will always be the place `vc-push' would push to. If -;; we are on a shorter-lived branch, it may instead become the remote -;; trunk branch from which the shorter-lived branch was branched. That -;; way you can use these commands to get a summary of all unmerged work -;; outstanding on the short-lived branch. -;; -;; The obstacle to doing this is that VC lacks any distinction between -;; shorter-lived and trunk branches. But we all work with both of -;; these, for almost any VCS workflow. E.g. modern workflows which -;; eschew traditional feature branches still have a long-lived trunk -;; plus shorter-lived local branches for merge requests or patch series. -;; --spwhitton +;; This is used in .dir-locals.el in the Emacs source tree. +;;;###autoload (put 'vc-trunk-branch-regexps 'safe-local-variable +;;;###autoload #'vc--safe-branch-regexps-p) +(defcustom vc-trunk-branch-regexps '("trunk" "master" "main" "default") + "Regular expressions matching the names of longer-lived VCS branches. +There value can be of one of the following forms: +- A list of regular expressions. A trunk branch is one whose name + matches any of the regular expressions. If an element of the list + contains no characters that are special in regular expressions, then + the regexp is implicitly anchored at both ends, i.e., it is the full + name of a branch. +- A list whose first element is `not' and whose remaining elements are + regular expressions. This is the same as the previous case except + that a trunk branch is one whose name does *not* match any of the + regular expressions. +- The symbol t. A trunk branch is any branch that + `vc-topic-branch-regexps' does not positively identify as a topic + branch. +- An empty list (or, the symbol nil). The branch name does not indicate + whether a branch is a trunk. Emacs will ask the backend whether it + thinks the current branch is a trunk. + +In VC, trunk branches are those where you've finished sharing the work +on the branch with your collaborators just as soon as you've checked it +in, and in the case of a decentralized VCS, pushed it. In addition, +typically you never delete trunk branches. + +The specific VCS workflow you are using may only acknowledge a single +trunk, and give other names to kinds of branches which VC would consider +to be just further trunks. + +If trunk branches in your project can be identified by name, include +regexps matching their names in the value of this variable. This is +more reliable than letting Emacs ask the backend. + +See also `vc-topic-branch-regexps'." + :type '(choice (repeat :tag "Regexps" string) + (cons :tag "Negated regexps" + (const not) (repeat :tag "Regexps" string)) + (const :tag "Inverse of `vc-branch-trunk-regexps'" t)) + :safe #'vc--safe-branch-regexps-p + :version "31.1") + +;; This is used in .dir-locals.el in the Emacs source tree. +;;;###autoload (put 'vc-topic-branch-regexps 'safe-local-variable +;;;###autoload #'vc--safe-branch-regexps-p) +(defcustom vc-topic-branch-regexps nil + "Regular expressions matching the names of shorter-lived VCS branches. +There value can be of one of the following forms: +- A list of regular expressions. A topic branch is one whose name + matches any of the regular expressions. If an element of the list + contains no characters that are special in regular expressions, then + the regexp is implicitly anchored at both ends, i.e., it is the full + name of a branch. +- A list whose first element is `not' and whose remaining elements are + regular expressions. This is the same as the previous case except + that a topic branch is one whose name does *not* match any of the + regular expressions. +- The symbol t. A topic branch is any branch that + `vc-trunk-branch-regexps' does not positively identify as a trunk + branch. +- An empty list (or, the symbol nil). The branch name does not indicate + whether a branch is a topic branch. Emacs will ask the backend + whether it thinks the current branch is a topic branch. + +In VC, topic branches are those where checking in work, and pushing it +in the case of a decentralized VCS, is not enough to complete the +process of sharing the changes with your collaborators. In addition, +it's required that you merge the topic branch into another branch. +After this is done, typically you delete the topic branch. + +Topic branches are sometimes called \"feature branches\", though it is +also common for that term to be reserved for only a certain kind of +topic branch. + +If topic branches in your project can be identified by name, include +regexps matching their names in the value of this variable. This is +more reliable than letting Emacs ask the backend. + +See also `vc-trunk-branch-regexps'." + :type '(choice (repeat :tag "Regexps" string) + (cons :tag "Negated regexps" + (const not) (repeat :tag "Regexps" string)) + (const :tag "Inverse of `vc-trunk-branch-regexps'" t)) + :safe #'vc--safe-branch-regexps-p + :version "31.1") + +(defun vc--match-branch-name-regexps (branch) + "Match against `vc-trunk-branch-regexps' and `vc-topic-branch-regexps'. +See the docstrings for those two variables for how this matching works. + +If BRANCH matches both sets of regexps we signal an error; this is to +allow for future extension. +If BRANCH matches neither set of regexps return nil to mean that the +defcustoms don't decide the matter of which kind of branch this is." + (when (and (eq vc-trunk-branch-regexps t) + (eq vc-topic-branch-regexps t)) + (user-error "\ +`vc-trunk-branch-regexps' and `vc-topic-branch-regexps' cannot both be `t'")) + (cl-labels ((join-regexps (regexps) + (mapconcat (lambda (elt) + (format (if (equal (regexp-quote elt) elt) + "\\`%s\\'" + "\\(?:%s\\)") + elt)) + regexps "\\|")) + (compile-regexps (regexps) + (if regexps + (let* ((negated (eq (car regexps) 'not)) + (joined (join-regexps (if negated + (cdr regexps) + regexps)))) + (if negated + (lambda (s) (not (string-match-p joined s))) + (lambda (s) (string-match-p joined s)))) + #'ignore)) + (match-trunk (if (eq vc-trunk-branch-regexps t) + (lambda (s) (not (match-topic s))) + (compile-regexps vc-trunk-branch-regexps))) + (match-topic (if (eq vc-topic-branch-regexps t) + (lambda (s) (not (match-trunk s))) + (compile-regexps vc-topic-branch-regexps)))) + (let ((trunk (match-trunk branch)) + (topic (match-topic branch))) + (cond ((and trunk topic) + (error "Branch name `%s' matches both \ +`vc-trunk-branch-regexps' and `vc-topic-branch-regexps'" + branch)) + (trunk 'trunk) + (topic 'topic))))) + +(defun vc--outgoing-base (backend) + "Return an outgoing base for the current branch under VC backend BACKEND. +The outgoing base is the upstream location for which outstanding changes +on this branch are destined once they are no longer outstanding. + +There are two stages to determining the outgoing base. +First we decide whether we think this is a shorter-lived or a +longer-lived (\"trunk\") branch (see `vc-trunk-branch-regexps' and +`vc-topic-branch-regexps' regarding this distinction), as follows: +1. Ask the backend for the name of the current branch. + If it returns non-nil, compare that name against + `vc-trunk-branch-regexps' and `vc-topic-branch-regexps'. +2. If that doesn't settle it, either because the backend returns nil for + the name of the current branch, or because comparing the name against + the two regexp defcustoms yields no decisive answer, call BACKEND's + `trunk-or-topic-p' VC API function. +3. If that doesn't settle it either, assume this is a shorter-lived + branch. This is based on how it's commands primarily intended for + working with shorter-lived branches that call this function. +Second, if we have determined that this is a trunk, return nil, meaning +that the outgoing base is the place to which `vc-push' would push. +Otherwise, we have determined that this is a shorter-lived branch, and +we return the value of calling BACKEND's `topic-outgoing-base' VC API +function." + ;; For further discussion see bug#80006. + (let* ((branch (vc-call-backend backend 'working-branch)) + (type (or (and branch (vc--match-branch-name-regexps branch)) + (vc-call-backend backend 'trunk-or-topic-p) + 'topic))) + (and (eq type 'topic) + (vc-call-backend backend 'topic-outgoing-base)))) + +(defun vc--outgoing-base-mergebase (backend &optional upstream-location refresh) + "Return, under VC backend BACKEND, the merge base with UPSTREAM-LOCATION. +Normally UPSTREAM-LOCATION, if non-nil, is a string. +If UPSTREAM-LOCATION is nil, it means to call `vc--outgoing-base' and +use its return value as UPSTREAM-LOCATION. If `vc--outgoing-base' +returns nil, that means to use the place to which `vc-push' would push. +If UPSTREAM-LOCATION is the special value t, it means to use the place +to which `vc-push' would push as UPSTREAM-LOCATION, unconditionally. +(This is passed when the user invokes an outgoing base command with a + \\`C-u C-u' prefix argument; see `vc--maybe-read-outgoing-base'.) +REFRESH is passed on to `vc--incoming-revision'." + (if-let* ((incoming + (vc--incoming-revision backend + (pcase upstream-location + ('t nil) + ('nil (vc--outgoing-base backend)) + (_ upstream-location)) + refresh))) + (vc-call-backend backend 'mergebase incoming) + (user-error "No incoming revision -- local-only branch?"))) ;;;###autoload (defun vc-root-diff-outgoing-base (&optional upstream-location) @@ -3149,17 +3347,23 @@ The merge base with UPSTREAM-LOCATION means the common ancestor of the working revision and UPSTREAM-LOCATION. Uncommitted changes are included in the diff. -When unspecified UPSTREAM-LOCATION is the place \\[vc-push] would push -to. This default meaning for UPSTREAM-LOCATION may change in a future -release of Emacs. +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. When called interactively with a prefix argument, prompt for UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION can be a remote branch name. -This command is like `vc-root-diff-outgoing' except that it includes -uncommitted changes." - (interactive (list (vc--maybe-read-upstream-location))) +When called interactively with a \\[universal-argument] \\[universal-argument] \ +prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch. (With a double prefix argument, this command is like +`vc-diff-outgoing' except that it includes uncommitted changes.)" + (interactive (list (vc--maybe-read-outgoing-base))) (vc--with-backend-in-rootdir "VC root-diff" (vc-diff-outgoing-base upstream-location `(,backend (,rootdir))))) @@ -3171,25 +3375,91 @@ The merge base with UPSTREAM-LOCATION means the common ancestor of the working revision and UPSTREAM-LOCATION. Uncommitted changes are included in the diff. -When unspecified UPSTREAM-LOCATION is the place \\[vc-push] would push -to. This default meaning for UPSTREAM-LOCATION may change in a future -release of Emacs. +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. When called interactively with a prefix argument, prompt for UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION can be a remote branch name. -This command is like to `vc-diff-outgoing' except that it includes -uncommitted changes." - (interactive (list (vc--maybe-read-upstream-location) nil)) - (let* ((fileset (or fileset (vc-deduce-fileset t))) - (backend (car fileset)) - (incoming (vc--incoming-revision backend upstream-location))) +When called interactively with a \\[universal-argument] \\[universal-argument] \ +prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch. (With a double prefix argument, this command is like +`vc-diff-outgoing' except that it includes uncommitted changes.) + +When called from Lisp, optional argument FILESET overrides the fileset." + (interactive (let ((fileset (vc-deduce-fileset t))) + (list (vc--maybe-read-outgoing-base (car fileset)) + fileset))) + (let ((fileset (or fileset (vc-deduce-fileset t)))) (vc-diff-internal vc-allow-async-diff fileset - (vc-call-backend backend 'mergebase incoming) + (vc--outgoing-base-mergebase (car fileset) + upstream-location) nil (called-interactively-p 'interactive)))) +;;;###autoload +(defun vc-log-outgoing-base (&optional upstream-location fileset) + "Show log for the VC fileset since the merge base with UPSTREAM-LOCATION. +The merge base with UPSTREAM-LOCATION means the common ancestor of the +working revision and UPSTREAM-LOCATION. + +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. + +When called interactively with a prefix argument, prompt for +UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION +can be a remote branch name. + +When called interactively with a \\[universal-argument] \\[universal-argument] \ +prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch. + +When called from Lisp, optional argument FILESET overrides the fileset." + (interactive (let ((fileset (vc-deduce-fileset t))) + (list (vc--maybe-read-outgoing-base (car fileset)) + fileset))) + (let* ((fileset (or fileset (vc-deduce-fileset t))) + (backend (car fileset))) + (vc-print-log-internal backend (cadr fileset) nil nil + (vc--outgoing-base-mergebase backend + upstream-location)))) + +;;;###autoload +(defun vc-root-log-outgoing-base (&optional upstream-location) + "Show log of revisions since the merge base with UPSTREAM-LOCATION. +The merge base with UPSTREAM-LOCATION means the common ancestor of the +working revision and UPSTREAM-LOCATION. + +When unspecified, UPSTREAM-LOCATION is the outgoing base. +For a trunk branch this is always the place \\[vc-push] would push to. +For a topic branch, query the backend for an appropriate outgoing base. +See `vc-trunk-branch-regexps' and `vc-topic-branch-regexps' regarding +the difference between trunk and topic branches. + +When called interactively with a prefix argument, prompt for +UPSTREAM-LOCATION. In some version control systems, UPSTREAM-LOCATION +can be a remote branch name. + +When called interactively with a \\[universal-argument] \\[universal-argument] \ +prefix argument, always +use the place to which \\[vc-push] would push to as the outgoing base, +i.e., treat this branch as a trunk branch even if Emacs thinks it is a +topic branch." + (interactive (list (vc--maybe-read-outgoing-base))) + (vc--with-backend-in-rootdir "VC revision log" + (vc-log-outgoing-base upstream-location `(,backend (,rootdir))))) + (declare-function ediff-load-version-control "ediff" (&optional silent)) (declare-function ediff-vc-internal "ediff-vers" (rev1 rev2 &optional startup-hooks)) @@ -4062,9 +4332,9 @@ that some users might prefer for interactive usage." "Read the name of a branch to log. FILESET, if non-nil, means to pass the current VC fileset to `vc-read-revision'." - (let ((branch (vc-read-revision "Branch to log: " - (and fileset - (cadr (vc-deduce-fileset t)))))) + (let* ((fileset (and fileset (vc-deduce-fileset t))) + (branch (vc-read-revision "Branch to log: " + (cadr fileset) (car fileset)))) (when (string-empty-p branch) (user-error "No branch specified")) branch)) @@ -4111,11 +4381,44 @@ starting at that revision. Tags and remote references also work." "History of upstream locations for VC incoming and outgoing commands.") (defun vc--maybe-read-upstream-location () + "Read upstream location if there is a prefix argument, else return nil." (and current-prefix-arg (let ((res (read-string "Upstream location/branch (empty for default): " nil 'vc-remote-location-history))) (and (not (string-empty-p res)) res)))) +(defun vc--maybe-read-outgoing-base (&optional backend) + "Return upstream location for interactive uses of outgoing base commands. +If there is no prefix argument, return nil. +If the current prefix argument is \\`C-u C-u', return t. +Otherwise prompt for an upstream location. +BACKEND is the VC backend." + (cond + ((equal current-prefix-arg '(16)) t) + (current-prefix-arg + (let* ((outgoing-base (vc-call-backend (or backend + (vc-deduce-backend)) + 'topic-outgoing-base)) + ;; If OUTGOING-BASE is non-nil then 'C-u C-x v T ... RET' is + ;; how the user can force Emacs to treat the current branch + ;; as a topic while having Emacs automatically determine the + ;; outgoing base with which to do so (otherwise, forcing + ;; Emacs to treat the current branch as a topic if it thinks + ;; it's a trunk requires specifying an outgoing base which + ;; will have that effect). + ;; + ;; In this case that OUTGOING-BASE is non-nil, it isn't + ;; possible to specify an empty string as the outgoing base, + ;; which normally means that Emacs should treat the current + ;; branch as a trunk. That's okay because you can use a + ;; double prefix argument to achieve that. + (res (read-string (if outgoing-base + (format-prompt "Upstream location/branch" + outgoing-base) + "Upstream location/branch (empty to treat as trunk): ") + nil 'vc-remote-location-history outgoing-base))) + (and (not (string-empty-p res)) res))))) + (defun vc--incoming-revision (backend &optional upstream-location refresh) ;; Some backends don't support REFRESH and so always behave as though ;; REFRESH is non-nil. This is not just for a lack of implementation @@ -4148,7 +4451,7 @@ starting at that revision. Tags and remote references also work." (user-error "No incoming revision -- local-only branch?"))))) ;;;###autoload -(defun vc-log-incoming (&optional upstream-location) +(defun vc-root-log-incoming (&optional upstream-location) "Show log of changes that will be received with pull from UPSTREAM-LOCATION. When unspecified UPSTREAM-LOCATION is the place \\[vc-update] would pull from. When called interactively with a prefix argument, prompt for @@ -4158,6 +4461,10 @@ can be a remote branch name." (vc--with-backend-in-rootdir "VC root-log" (vc-incoming-outgoing-internal backend upstream-location "*vc-incoming*" 'log-incoming))) +;; We plan to reuse the name `vc-log-incoming' for the fileset-specific +;; command in Emacs 32.1. --spwhitton +(define-obsolete-function-alias 'vc-log-incoming #'vc-root-log-incoming + "31.1") (defun vc-default-log-incoming (backend buffer upstream-location) (let ((incoming (vc--incoming-revision backend upstream-location @@ -4168,7 +4475,7 @@ can be a remote branch name." (vc-call-backend backend 'mergebase incoming)))) ;;;###autoload -(defun vc-log-outgoing (&optional upstream-location) +(defun vc-root-log-outgoing (&optional upstream-location) "Show log of changes that will be sent with a push to UPSTREAM-LOCATION. When unspecified UPSTREAM-LOCATION is the place \\[vc-push] would push to. When called interactively with a prefix argument, prompt for @@ -4178,6 +4485,10 @@ can be a remote branch name." (vc--with-backend-in-rootdir "VC root-log" (vc-incoming-outgoing-internal backend upstream-location "*vc-outgoing*" 'log-outgoing))) +;; We plan to reuse the name `vc-log-outgoing' for the fileset-specific +;; command in Emacs 32.1. --spwhitton +(define-obsolete-function-alias 'vc-log-outgoing #'vc-root-log-outgoing + "31.1") (defun vc-default-log-outgoing (backend buffer upstream-location) (let ((incoming (vc--incoming-revision backend upstream-location)) @@ -5471,7 +5782,8 @@ MOVE non-nil means to move instead of copy." (with-temp-buffer (cond* (patch-string (diff-mode) - (insert patch-string)) + (let ((inhibit-read-only t)) ; `diff-default-read-only'. + (insert patch-string))) ;; Some backends don't tolerate unregistered files ;; appearing in the fileset for a diff operation. ((bind* (diff-fileset @@ -5613,6 +5925,9 @@ except that this command works only in file-visiting buffers." 'get-change-comment))) (format "Summary: %s\n" (string-trim (funcall fn files rev)))))) +(defalias 'vc-default-working-branch #'ignore) +(defalias 'vc-default-trunk-or-topic-p #'ignore) + ;; These things should probably be generally available diff --git a/lisp/whitespace.el b/lisp/whitespace.el index c93a1e098cb..2e89d2ae977 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -887,7 +887,7 @@ This variable is used when `whitespace-style' includes `tab-mark', (defcustom whitespace-global-modes t - "Modes for which global `whitespace-mode' is automagically turned on. + "Modes for which global `whitespace-mode' is automatically turned on. Global `whitespace-mode' is controlled by the command `global-whitespace-mode'. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 10d92fc3951..6d576a10b73 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -4362,7 +4362,10 @@ is inline." "Non-nil if VALUE is a defined color or a RGB hex string." (and (stringp value) (or (color-defined-p value) - (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value)))) + (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value) + ;; TTYs also allow unspecified-fg / unspecified-bg as color + ;; values even though they are technically not colors. + (string-match-p "^unspecified-\\(?:fg\\|bg\\)$" value)))) (defun widget-color-validate (widget) "Check that WIDGET's value is a valid color." diff --git a/lisp/window-x.el b/lisp/window-x.el index e8ee58dcdc2..4197d5a0a26 100644 --- a/lisp/window-x.el +++ b/lisp/window-x.el @@ -340,6 +340,51 @@ FRAME1." (delete-frame frame2) frame1)) +;;;###autoload +(defun window-get-split-combination (window arg) + "Return window combination suitable for `split-frame'. + +WINDOW is the main window in which the combination should be derived. +ARG is the argument passed to `split-frame'. Return a +combination of windows `split-frame' is considered to split off." + (let* ((reverse (< arg 0)) + ;; This is where the pivot window is. + (total-window-count (window-child-count window)) + (pivot-window-pos (- (if reverse + (+ total-window-count arg) + arg) + 1)) + (pivot-window (window-child window)) + (active-window (frame-selected-window window)) + ;; If FRAME's selected window is on the left side of the + ;; pivot window. + (active-window-on-left (eq pivot-window active-window))) + ;; We want the 2nd level window that the active window is a + ;; part of. + (while (not (eq (window-parent active-window) window)) + (setq active-window (window-parent active-window))) + + ;; Now we need to find the pivot window + (dotimes (_ pivot-window-pos) + (setq pivot-window (window-next-sibling pivot-window)) + (when (eq active-window pivot-window) + (setq active-window-on-left t))) + + ;; Now we have pivot-window set, and we just need to + ;; combine. We want to split away all windows from the + ;; side of the pivot that doesn't contain the active + ;; window. + (let* ((first (window-child window)) + (last (window-last-child window)) + (next-pivot-sib (window-next-sibling pivot-window)) + (right-comb (if (eq next-pivot-sib last) + last + (combine-windows next-pivot-sib last))) + (left-comb (if (eq first pivot-window) + first + (combine-windows first pivot-window)))) + (if active-window-on-left right-comb left-comb)))) + ;;;###autoload (defun split-frame (&optional frame arg) "Split windows of specified FRAME into two separate frames. @@ -371,47 +416,12 @@ absolute value of ARG. Return the new frame." ((>= (abs arg) total-window-count) (user-error "ARG %s exceeds number of windows %s that can be split off" (abs arg) (1- total-window-count))) - (t (let* ((reverse (< arg 0)) - ;; This is where the pivot window is. - (pivot-window-pos (- (if reverse - (+ total-window-count arg) - arg) - 1)) - (pivot-window (window-child main)) - (active-window (frame-selected-window frame)) - ;; If FRAME's selected window is on the left side of the - ;; pivot window. - (active-window-on-left (eq pivot-window active-window))) - ;; We want the 2nd level window that the active window is a - ;; part of. - (while (not (eq (window-parent active-window) main)) - (setq active-window (window-parent active-window))) - - ;; Now we need to find the pivot window - (dotimes (_ pivot-window-pos) - (setq pivot-window (window-next-sibling pivot-window)) - (when (eq active-window pivot-window) - (setq active-window-on-left t))) - - ;; Now we have pivot-window set, and we just need to - ;; combine. We want to split away all windows from the - ;; side of the pivot that doesn't contain the active - ;; window. - (let* ((first (window-child main)) - (last (window-last-child main)) - (next-pivot-sib (window-next-sibling pivot-window)) - (right-comb (if (eq next-pivot-sib last) - last - (combine-windows next-pivot-sib last))) - (left-comb (if (eq first pivot-window) - first - (combine-windows first pivot-window))) - ;; comb-win is the combination that will be - ;; split off. - (comb-win (if active-window-on-left right-comb left-comb))) - (window-state-put (window-state-get comb-win) - (window-main-window (make-frame))) - (delete-window comb-win))))))) + (t + (let ((comb (window-get-split-combination main arg))) + (window-state-put (window-state-get comb) + (window-main-window (make-frame))) + (delete-window comb)) + )))) (provide 'window-x) ;;; window-x.el ends here diff --git a/lisp/window.el b/lisp/window.el index 6b08706b9ac..3a1ebd16fa6 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -2850,9 +2850,15 @@ as small) as possible, but don't signal an error." (let* ((frame (window-frame window)) (root (frame-root-window frame)) (height (window-pixel-height window)) - (min-height (+ (frame-char-height frame) - (- (window-pixel-height window) - (window-body-height window t)))) + ;; Take line-spacing into account if the line-spacing is + ;; configured as a cons cell with above > 0 to prevent + ;; mini-window jiggling. + (ls (or (buffer-local-value 'line-spacing (window-buffer window)) + (frame-parameter frame 'line-spacing))) + (min-height (+ (if (and (consp ls) (> (car ls) 0)) + (window-default-line-height window) + (frame-char-height frame)) + (- height (window-body-height window t)))) (max-delta (- (window-pixel-height root) (window-min-size root nil nil t)))) ;; Don't make mini window too small. @@ -5502,8 +5508,13 @@ elsewhere. This value is used by `quit-windows-on'." ;; If quit-restore-prev was not used, reset the quit-restore ;; parameter (set-window-parameter window 'quit-restore nil)) - ;; If the previously selected window is still alive, select it. - (window--quit-restore-select-window quit-restore-2)) + ;; If WINDOW is the selected window and the previously selected + ;; window is still alive, try to select that window. But do that + ;; only if WINDOW is either the selected window or we are neither + ;; "burying" nor "killing". + (unless (and (not (eq window (selected-window))) + (memq bury-or-kill '(killing burying))) + (window--quit-restore-select-window quit-restore-2))) (t ;; Show some other buffer in WINDOW and leave the ;; quit-restore(-prev) parameters alone (Juri's idea). @@ -7573,6 +7584,17 @@ strategy." (with-selected-window window (split-window-right)))) +(defun window--frame-landscape-p (&optional frame) + "Non-nil if FRAME is wider than it is tall. +This means actually wider on the screen, not character-wise. +On text frames, use the heuristic that characters are roughtly twice as +tall as they are wide." + (if (display-graphic-p frame) + (> (frame-pixel-width frame) (frame-pixel-height frame)) + ;; On a terminal, displayed characters are usually roughly twice as + ;; tall as they are wide. + (> (frame-width frame) (* 2 (frame-height frame))))) + (defun split-window-sensibly (&optional window) "Split WINDOW in a way suitable for `display-buffer'. The variable `split-window-preferred-direction' prescribes an order of @@ -7613,7 +7635,7 @@ split." (or (if (or (eql split-window-preferred-direction 'horizontal) (and (eql split-window-preferred-direction 'longest) - (> (frame-width) (frame-height)))) + (window--frame-landscape-p (window-frame window)))) (or (window--try-horizontal-split window) (window--try-vertical-split window)) (or (window--try-vertical-split window) @@ -7987,18 +8009,25 @@ See the info node `(elisp)Dedicated Windows' for more details." (defconst display-buffer--action-function-custom-type '(choice :tag "Function" (const :tag "--" ignore) ; default for insertion - (const display-buffer-reuse-window) - (const display-buffer-pop-up-window) (const display-buffer-same-window) + (const display-buffer-reuse-window) + (const display-buffer-in-previous-window) + (const display-buffer-reuse-mode-window) + (const display-buffer-use-some-window) + (const display-buffer-use-least-recent-window) + (const display-buffer-pop-up-window) (const display-buffer-pop-up-frame) (const display-buffer-full-frame) + (const display-buffer-use-some-frame) (const display-buffer-in-child-frame) + (const display-buffer-in-side-window) + (const display-buffer-in-atom-window) (const display-buffer-below-selected) (const display-buffer-at-bottom) - (const display-buffer-in-previous-window) - (const display-buffer-use-least-recent-window) - (const display-buffer-use-some-window) - (const display-buffer-use-some-frame) + (const display-buffer-in-direction) + (const display-buffer-in-tab) + (const display-buffer-in-new-tab) + (const display-buffer-no-window) (function :tag "Other function")) "Custom type for `display-buffer' action functions.") @@ -8131,22 +8160,28 @@ To change which window is used, set `display-buffer-alist' to an expression containing one of these \"action\" functions: `display-buffer-same-window' -- Use the selected window. - `display-buffer-reuse-window' -- Use a window already showing - the buffer. - `display-buffer-in-previous-window' -- Use a window that did - show the buffer before. + `display-buffer-reuse-window' -- Use a window already showing the buffer. + `display-buffer-in-previous-window' -- Use a window that has previously + displayed the buffer. + `display-buffer-reuse-mode-window' -- Use a window currently showing a + buffer with the required major mode. `display-buffer-use-some-window' -- Use some existing window. - `display-buffer-use-least-recent-window' -- Try to avoid reusing - windows that have recently been switched to. + `display-buffer-use-least-recent-window' -- Try to avoid reusing windows + that have recently been switched to. `display-buffer-pop-up-window' -- Pop up a new window. + `display-buffer-pop-up-frame' -- Use a new frame. `display-buffer-full-frame' -- Delete other windows and use the full frame. - `display-buffer-below-selected' -- Use or pop up a window below - the selected one. - `display-buffer-at-bottom' -- Use or pop up a window at the - bottom of the selected frame. - `display-buffer-pop-up-frame' -- Show the buffer on a new frame. - `display-buffer-in-child-frame' -- Show the buffer in a - child frame. + `display-buffer-use-some-frame' -- Use a frame meeting a predicate. + `display-buffer-in-child-frame' -- Use a child frame of the selected frame. + `display-buffer-in-side-window' -- Use a side window of the selected frame. + `display-buffer-in-atom-window' -- Use an atomic window. + `display-buffer-below-selected' -- Use or pop up a window below the + selected one. + `display-buffer-at-bottom' -- Use or pop up a window at the bottom of the + selected frame. + `display-buffer-in-direction' -- Use a window in a specified direction. + `display-buffer-in-tab' -- Use an appropriate existing tab or a new tab. + `display-buffer-in-new-tab' -- Use a new tab. `display-buffer-no-window' -- Do not display the buffer and have `display-buffer' return nil immediately. @@ -8208,7 +8243,7 @@ Action alist entries are: Possible values are nil (the selected frame), t (any live frame), visible (any visible frame), 0 (any visible or iconified frame) or an existing live frame. - `pop-up-frames' -- Same effect as the eponymous variable. + \\+`pop-up-frames' -- Same effect as the eponymous variable. Takes precedence over the variable. `pop-up-frame-parameters' -- The value specifies an alist of frame parameters to give a new frame, if one is created. @@ -8307,9 +8342,13 @@ Action alist entries are: selected regardless of which windows were selected afterwards within this command. `category' -- If the caller of `display-buffer' passes an alist entry - `(category . symbol)' in its action argument, then you can match - the displayed buffer by using the same category in the condition - part of `display-buffer-alist' entries. + `(category . symbol)' in its action argument, then you can match + the displayed buffer by using the same category in the condition + part of `display-buffer-alist' entries. + `tab-name' -- If non-nil, specifies the name of the tab in which to + display the buffer; see `display-buffer-in-new-tab'. + \\+`tab-group' -- If non-nil, specifies the tab group to use when creating + a new tab; see `display-buffer-in-new-tab'. The entries `window-height', `window-width', `window-size' and `preserve-size' are applied only when the window used for @@ -8561,7 +8600,9 @@ indirectly called by the latter." (window--maybe-raise-frame (window-frame window))))))) (defun display-buffer-reuse-mode-window (buffer alist) - "Return a window based on the mode of the buffer it displays. + "Display BUFFER in a window with a buffer of the required major mode. + +Return a window based on the major mode of the buffer it displays. Display BUFFER in the returned window. Return nil if no usable window is found. @@ -9882,8 +9923,8 @@ face on WINDOW's frame." (buffer (window-buffer window)) (space-height (or (and (display-graphic-p frame) - (or (buffer-local-value 'line-spacing buffer) - (frame-parameter frame 'line-spacing))) + (total-line-spacing (or (buffer-local-value 'line-spacing buffer) + (frame-parameter frame 'line-spacing)))) 0))) (+ font-height (if (floatp space-height) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index d8aac1250c4..c75cd047495 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -31,7 +31,6 @@ ;; And is pointless when we do, since it's in C and so preloaded. ;;(require 'xwidget-internal) -(require 'cl-lib) (require 'bookmark) (require 'format-spec) diff --git a/lisp/yank-media.el b/lisp/yank-media.el index 8c55ee3da9f..f01d5ba7d59 100644 --- a/lisp/yank-media.el +++ b/lisp/yank-media.el @@ -24,7 +24,6 @@ ;;; Code: -(require 'cl-lib) (require 'seq) (defvar yank-media--registered-handlers nil) diff --git a/m4/alloca.m4 b/m4/alloca.m4 index 7e29940e713..ff0c59dd415 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,7 +1,7 @@ # alloca.m4 # serial 21 -dnl Copyright (C) 2002-2004, 2006-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2004, 2006-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/codeset.m4 b/m4/codeset.m4 index 301e8524870..4ab542f4291 100644 --- a/m4/codeset.m4 +++ b/m4/codeset.m4 @@ -1,7 +1,7 @@ # codeset.m4 # serial 5 (gettext-0.18.2) -dnl Copyright (C) 2000-2002, 2006, 2008-2014, 2016, 2019-2026 Free -dnl Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2006, 2008-2014, 2016, 2019-2026 Free Software +dnl Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/d-type.m4 b/m4/d-type.m4 index 3888f5c2904..0c335f8b1df 100644 --- a/m4/d-type.m4 +++ b/m4/d-type.m4 @@ -1,7 +1,7 @@ # d-type.m4 # serial 12 -dnl Copyright (C) 1997, 1999-2004, 2006, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 1997, 1999-2004, 2006, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dup2.m4 b/m4/dup2.m4 index a94fef03f9f..e1d518983b5 100644 --- a/m4/dup2.m4 +++ b/m4/dup2.m4 @@ -1,7 +1,6 @@ # dup2.m4 # serial 28 -dnl Copyright (C) 2002, 2005, 2007, 2009-2026 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2005, 2007, 2009-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/filemode.m4 b/m4/filemode.m4 index c434d8e35d5..9bf319abf54 100644 --- a/m4/filemode.m4 +++ b/m4/filemode.m4 @@ -1,7 +1,6 @@ # filemode.m4 # serial 9 -dnl Copyright (C) 2002, 2005-2006, 2009-2026 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fsusage.m4 b/m4/fsusage.m4 index 2806e1a702c..db6e0e3b636 100644 --- a/m4/fsusage.m4 +++ b/m4/fsusage.m4 @@ -1,7 +1,7 @@ # fsusage.m4 # serial 37 -dnl Copyright (C) 1997-1998, 2000-2001, 2003-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 1997-1998, 2000-2001, 2003-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getgroups.m4 b/m4/getgroups.m4 index e9e067df688..34ac3a6300e 100644 --- a/m4/getgroups.m4 +++ b/m4/getgroups.m4 @@ -1,7 +1,7 @@ # getgroups.m4 # serial 25 -dnl Copyright (C) 1996-1997, 1999-2004, 2008-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 1996-1997, 1999-2004, 2008-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getline.m4 b/m4/getline.m4 index cb9e839fdd9..ed32fa10bfb 100644 --- a/m4/getline.m4 +++ b/m4/getline.m4 @@ -1,8 +1,8 @@ # getline.m4 # serial 35 -dnl Copyright (C) 1998-2003, 2005-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 1998-2003, 2005-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/gettime.m4 b/m4/gettime.m4 index 66d2d6c939f..0afe2aab169 100644 --- a/m4/gettime.m4 +++ b/m4/gettime.m4 @@ -1,7 +1,6 @@ # gettime.m4 # serial 15 -dnl Copyright (C) 2002, 2004-2006, 2009-2026 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2004-2006, 2009-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4 index b72864271ff..3728c13e999 100644 --- a/m4/gettimeofday.m4 +++ b/m4/gettimeofday.m4 @@ -1,7 +1,7 @@ # gettimeofday.m4 # serial 30 -dnl Copyright (C) 2001-2003, 2005, 2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2001-2003, 2005, 2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/group-member.m4 b/m4/group-member.m4 index bb185977b13..5e5c3709c39 100644 --- a/m4/group-member.m4 +++ b/m4/group-member.m4 @@ -1,7 +1,7 @@ # group-member.m4 # serial 14 -dnl Copyright (C) 1999-2001, 2003-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 1999-2001, 2003-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/locale-en.m4 b/m4/locale-en.m4 index cc54a15fac4..f5e035f3675 100644 --- a/m4/locale-en.m4 +++ b/m4/locale-en.m4 @@ -19,7 +19,7 @@ AC_DEFUN_ONCE([gt_LOCALE_EN_UTF8], *-musl* | midipix*) dnl On musl libc, all kinds of ll_CC.UTF-8 locales exist, even without dnl any locale file on disk. But they are effectively equivalent to the - dnl C.UTF-8 locale, except for locale categories (such as LC_MESSSAGES) + dnl C.UTF-8 locale, except for locale categories (such as LC_MESSAGES) dnl for which localizations (.mo files) have been installed. gt_cv_locale_en_utf8=en_US.UTF-8 ;; diff --git a/m4/manywarnings.m4 b/m4/manywarnings.m4 index ca35e69eecc..0824226fa71 100644 --- a/m4/manywarnings.m4 +++ b/m4/manywarnings.m4 @@ -1,5 +1,5 @@ # manywarnings.m4 -# serial 29 +# serial 32 dnl Copyright (C) 2008-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -110,8 +110,8 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)], -Wduplicated-branches \ -Wduplicated-cond \ -Wextra \ - -Wformat-signedness \ -Wflex-array-member-not-at-end \ + -Wformat-signedness \ -Winit-self \ -Winline \ -Winvalid-pch \ @@ -138,8 +138,6 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)], -Wsuggest-attribute=malloc \ -Wsuggest-attribute=noreturn \ -Wsuggest-attribute=pure \ - -Wsuggest-final-methods \ - -Wsuggest-final-types \ -Wsync-nand \ -Wtrampolines \ -Wuninitialized \ @@ -150,7 +148,6 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)], -Wvector-operation-performance \ -Wvla \ -Wwrite-strings \ - \ ; do AS_VAR_APPEND([$1], [" $gl_manywarn_item"]) done @@ -169,20 +166,29 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)], AS_VAR_APPEND([$1], [' -Wunused-const-variable=2']) AS_VAR_APPEND([$1], [' -Wvla-larger-than=4031']) - # These are needed for older GCC versions. + # These depend on the GCC version. if test -n "$GCC" && gl_gcc_version=`($CC --version) 2>/dev/null`; then case $gl_gcc_version in - 'gcc (GCC) '[[0-3]].* | \ - 'gcc (GCC) '4.[[0-7]].*) + gcc*' ('*') '[[0-3]].* | \ + gcc*' ('*') '4.[[0-7]].*) AS_VAR_APPEND([$1], [' -fdiagnostics-show-option']) AS_VAR_APPEND([$1], [' -funit-at-a-time']) ;; esac case $gl_gcc_version in - 'gcc (GCC) '[[0-9]].*) + gcc*' ('*') '[[0-9]].*) AS_VAR_APPEND([$1], [' -fno-common']) ;; esac + case $gl_gcc_version in + gcc*' ('*') '?.* | gcc*' ('*') '1[[0-4]].*) + # In GCC < 15 the option either does not exist, + # or is accepted but always warns. + ;; + *) + AS_VAR_APPEND([$1], [' -Wzero-as-null-pointer-constant']) + ;; + esac fi # These options are not supported by gcc, but are useful with clang. diff --git a/m4/mempcpy.m4 b/m4/mempcpy.m4 index d6b5b8f0b4a..eda1b31c44d 100644 --- a/m4/mempcpy.m4 +++ b/m4/mempcpy.m4 @@ -1,7 +1,7 @@ # mempcpy.m4 # serial 14 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/memrchr.m4 b/m4/memrchr.m4 index 59fda84cf61..7e4e39f2ec1 100644 --- a/m4/memrchr.m4 +++ b/m4/memrchr.m4 @@ -1,7 +1,7 @@ # memrchr.m4 # serial 11 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mktime.m4 b/m4/mktime.m4 index a186def45d5..fa32d138402 100644 --- a/m4/mktime.m4 +++ b/m4/mktime.m4 @@ -1,7 +1,7 @@ # mktime.m4 # serial 43 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/ndk-build.m4 b/m4/ndk-build.m4 index 89ae6c54ff4..12135a0d501 100644 --- a/m4/ndk-build.m4 +++ b/m4/ndk-build.m4 @@ -77,7 +77,7 @@ AS_CASE(["$ndk_ABI"], # This is a map between pkg-config style package names and Android # ones. -ndk_package_map="libwebpdemux:webpdemux libxml-2.0:libxml2" +ndk_package_map="libwebpdemux:webpdemux libwebp:webp libxml-2.0:libxml2" ndk_package_map="$ndk_package_map sqlite3:libsqlite_static_minimal" ndk_package_map="$ndk_package_map MagickWand:libmagickwand-7 lcms2:liblcms2" diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4 index 5c5cc1289d5..f9d699174e4 100644 --- a/m4/nstrftime.m4 +++ b/m4/nstrftime.m4 @@ -1,7 +1,7 @@ # nstrftime.m4 # serial 40 -dnl Copyright (C) 1996-1997, 1999-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 1996-1997, 1999-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 index 4d45922846e..d6bdf43e9ef 100644 --- a/m4/pathmax.m4 +++ b/m4/pathmax.m4 @@ -1,7 +1,7 @@ # pathmax.m4 # serial 11 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/selinux-selinux-h.m4 b/m4/selinux-selinux-h.m4 index 5b934461623..b3fcd2102e2 100644 --- a/m4/selinux-selinux-h.m4 +++ b/m4/selinux-selinux-h.m4 @@ -88,10 +88,13 @@ AC_DEFUN([gl_LIBSELINUX], # Warn if SELinux is found but libselinux is absent; if test "$ac_cv_search_setfilecon" = no; then - if test "$host" = "$build" && test -d /selinux; then + if test "$host" = "$build" \ + && { test -d /sys/fs/selinux || test -d /selinux; }; then AC_MSG_WARN([This system supports SELinux but libselinux is missing.]) AC_MSG_WARN([AC_PACKAGE_NAME will be compiled without SELinux support.]) fi - with_selinux=no + if test "$with_selinux" = maybe; then + with_selinux=no + fi fi ]) diff --git a/m4/sig2str.m4 b/m4/sig2str.m4 index 709dd958f97..d2e37ad9e6c 100644 --- a/m4/sig2str.m4 +++ b/m4/sig2str.m4 @@ -1,7 +1,6 @@ # sig2str.m4 # serial 9 -dnl Copyright (C) 2002, 2005-2006, 2009-2026 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4 index 5ff06768677..8710cb7233e 100644 --- a/m4/ssize_t.m4 +++ b/m4/ssize_t.m4 @@ -1,7 +1,6 @@ # ssize_t.m4 # serial 6 -dnl Copyright (C) 2001-2003, 2006, 2010-2026 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2001-2003, 2006, 2010-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index d3bc20b6a4e..10eb1dfa2d4 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -1,7 +1,7 @@ # stat-time.m4 # serial 1 -dnl Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2026 Free -dnl Software Foundation, Inc. +dnl Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2026 Free Software +dnl Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index bef82c9688b..f35d661125d 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -1,5 +1,5 @@ # stdlib_h.m4 -# serial 85 +# serial 86 dnl Copyright (C) 2007-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -223,6 +223,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], HAVE_STRTOULL=1; AC_SUBST([HAVE_STRTOULL]) HAVE_STRUCT_RANDOM_DATA=1; AC_SUBST([HAVE_STRUCT_RANDOM_DATA]) HAVE_SYS_LOADAVG_H=0; AC_SUBST([HAVE_SYS_LOADAVG_H]) + HAVE_SYS_PROCESS_H=0; AC_SUBST([HAVE_SYS_PROCESS_H]) HAVE_UNLOCKPT=1; AC_SUBST([HAVE_UNLOCKPT]) HAVE_DECL_UNSETENV=1; AC_SUBST([HAVE_DECL_UNSETENV]) REPLACE__EXIT=0; AC_SUBST([REPLACE__EXIT]) diff --git a/m4/strnlen.m4 b/m4/strnlen.m4 index 764a84dc497..a712df9deaa 100644 --- a/m4/strnlen.m4 +++ b/m4/strnlen.m4 @@ -1,7 +1,7 @@ # strnlen.m4 # serial 15 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/strtoimax.m4 b/m4/strtoimax.m4 index cf628673bad..c6280d02ff8 100644 --- a/m4/strtoimax.m4 +++ b/m4/strtoimax.m4 @@ -1,7 +1,6 @@ # strtoimax.m4 # serial 17 -dnl Copyright (C) 2002-2004, 2006, 2009-2026 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002-2004, 2006, 2009-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/strtoll.m4 b/m4/strtoll.m4 index fa5adc54cb5..4ee81fbcc4a 100644 --- a/m4/strtoll.m4 +++ b/m4/strtoll.m4 @@ -1,7 +1,6 @@ # strtoll.m4 # serial 12 -dnl Copyright (C) 2002, 2004, 2006, 2008-2026 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2004, 2006, 2008-2026 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/time_h.m4 b/m4/time_h.m4 index 1cfc168b912..8d896ea526d 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -1,7 +1,7 @@ # time_h.m4 # serial 27 -dnl Copyright (C) 2000-2001, 2003-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2000-2001, 2003-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/timespec.m4 b/m4/timespec.m4 index 8317cb29868..101f94a371d 100644 --- a/m4/timespec.m4 +++ b/m4/timespec.m4 @@ -1,7 +1,7 @@ # timespec.m4 # serial 15 -dnl Copyright (C) 2000-2001, 2003-2007, 2009-2026 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2000-2001, 2003-2007, 2009-2026 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/nt/inc/ms-w32.h b/nt/inc/ms-w32.h index fc853959b49..1e2af4a424e 100644 --- a/nt/inc/ms-w32.h +++ b/nt/inc/ms-w32.h @@ -227,7 +227,6 @@ extern void w32_reset_stack_overflow_guard (void); #define select sys_select #define pselect sys_select #define sleep sys_sleep -#define strerror sys_strerror #undef unlink #define unlink sys_unlink #undef opendir @@ -268,6 +267,13 @@ extern int sys_umask (int); #define cmputc sys_cmputc #define Wcm_clear sys_Wcm_clear +/* MinGW64 system headers include string.h too early, causing the + compiler to emit a warning about sys_strerror having no + prototype, or the linker fail to link. */ +#include +#define strerror sys_strerror +char *sys_strerror (int); + #endif /* emacs */ /* Used both in Emacs, in lib-src, and in Gnulib. */ diff --git a/src/alloc.c b/src/alloc.c index 3c3ee34bac2..d0999a655fc 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6279,14 +6279,7 @@ DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", doc: /* Reclaim storage for Lisp objects no longer needed. Garbage collection happens automatically if you cons more than `gc-cons-threshold' bytes of Lisp data since previous garbage collection. -`garbage-collect' normally returns a list with info on amount of space in use, -where each entry has the form (NAME SIZE USED FREE), where: -- NAME is a symbol describing the kind of objects this entry represents, -- SIZE is the number of bytes used by each one, -- USED is the number of those objects that were found live in the heap, -- FREE is the number of those objects that are not live but that Emacs - keeps around for future allocations (maybe because it does not know how - to return them to the OS). +It returns the same info as `garbage-collect-heapsize'. Note that calling this function does not guarantee that absolutely all unreachable objects will be garbage-collected. Emacs uses a @@ -6303,8 +6296,29 @@ For further details, see Info node `(elisp)Garbage Collection'. */) specbind (Qsymbols_with_pos_enabled, Qnil); garbage_collect (); unbind_to (count, Qnil); + return Fgarbage_collect_heapsize (); +} + +DEFUN ("garbage-collect-heapsize", Fgarbage_collect_heapsize, + Sgarbage_collect_heapsize, 0, 0, 0, + doc: /* Return a list with info on amount of space in use. +This info may not be fully up to date unless it is called right after +a full garbage collection cycle. +Each entry has the form (NAME SIZE USED FREE), where: +- NAME is a symbol describing the kind of objects this entry represents, +- SIZE is the number of bytes used by each one, +- USED is the number of those objects that were found live in the heap, +- FREE is the number of those objects that are not live but that Emacs + keeps around for future allocations (maybe because it does not know how + to return them to the OS). */) + (void) +{ struct gcstat gcst = gcstat; + /* FIXME: Maybe we could/should add a field countaing the approximate + amount of memory allocated since the last GC, such as + 'gc_threshold - consing_until_gc'. */ + Lisp_Object total[] = { list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)), make_int (gcst.total_conses), @@ -7836,6 +7850,7 @@ N should be nonnegative. */); defsubr (&Smake_finalizer); defsubr (&Sgarbage_collect); defsubr (&Sgarbage_collect_maybe); + defsubr (&Sgarbage_collect_heapsize); defsubr (&Smemory_info); defsubr (&Smemory_use_counts); #if defined GNU_LINUX && defined __GLIBC__ && \ diff --git a/src/androidfns.c b/src/androidfns.c index 039fcebd2ff..6d9af385ce7 100644 --- a/src/androidfns.c +++ b/src/androidfns.c @@ -858,6 +858,8 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, XSETFRAME (frame, f); + frame_set_id_from_params (f, parms); + f->terminal = dpyinfo->terminal; f->output_method = output_android; diff --git a/src/buffer.c b/src/buffer.c index 00fc13774a1..c1c0441a70e 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -5943,12 +5943,15 @@ cursor's appearance is instead controlled by the variable `cursor-in-non-selected-windows'. */); DEFVAR_PER_BUFFER ("line-spacing", - extra_line_spacing, Qnumberp, + extra_line_spacing, Qnil, doc: /* Additional space to put between lines when displaying a buffer. The space is measured in pixels, and put below lines on graphic displays, see `display-graphic-p'. If value is a floating point number, it specifies the spacing relative -to the default frame line height. A value of nil means add no extra space. */); +to the default frame line height. +If value is a cons cell containing a pair of floats or integers, +it is interpreted as space above and below the line, respectively. +A value of nil means add no extra space. */); DEFVAR_PER_BUFFER ("cursor-in-non-selected-windows", cursor_in_non_selected_windows, Qnil, diff --git a/src/buffer.h b/src/buffer.h index 1f8dae2280b..104b8dcad38 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -579,7 +579,10 @@ struct buffer Lisp_Object cursor_type_; /* An integer > 0 means put that number of pixels below text lines - in the display of this buffer. */ + in the display of this buffer. + A float ~ 1.0 means add extra number of pixels below text lines + relative to the line height. + A cons means put car spacing above and cdr spacing below the line. */ Lisp_Object extra_line_spacing_; #ifdef HAVE_TREE_SITTER @@ -1566,7 +1569,9 @@ BUF_FETCH_CHAR_AS_MULTIBYTE (struct buffer *buf, ptrdiff_t pos) : UNIBYTE_TO_CHAR (BUF_FETCH_BYTE (buf, pos))); } -/* Return number of windows showing B. */ +/* Return number of windows showing B or a buffer that has B as its base + buffer. If B is an indirect buffer, this returns buffer_window_count + of its base buffer. */ INLINE int buffer_window_count (struct buffer *b) diff --git a/src/dbusbind.c b/src/dbusbind.c index d93aef096f4..cb705e9e92a 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -1640,14 +1640,135 @@ usage: (dbus-message-internal &rest REST) */) return result; } +/* Alist of registered inhibitor locks for D-Bus. + An entry in this list is a list (FD WHAT WHY BLOCK). + The car of the list is a file descriptor retrieved from a + 'dbus-make-inhibitor-lock` call. The cdr of the list represents the + three arguments 'dbus-make-inhibitor-lock` was called with. */ +static Lisp_Object xd_registered_inhibitor_locks; + +DEFUN ("dbus-make-inhibitor-lock", Fdbus_make_inhibitor_lock, + Sdbus_make_inhibitor_lock, + 2, 3, 0, + doc: /* Inhibit system shutdowns and sleep states. + +WHAT is a colon-separated string of lock types, i.e. "shutdown", +"sleep", "idle", "handle-power-key", "handle-suspend-key", +"handle-hibernate-key", "handle-lid-switch". Example: "shutdown:idle". + +WHY is a descriptive string of why the lock is taken. Example: "Package +Update in Progress". + +The optional BLOCK is the mode of the inhibitor lock, either "block" +(BLOCK is non-nil), or "delay". + +It returns a file descriptor or nil, if the lock cannot be acquired. If +there is already an inhibitor lock for the triple (WHAT WHY BLOCK), this +lock is returned. + +For details of the arguments, see Info node `(dbus)Inhibitor Locks'. */) + (Lisp_Object what, Lisp_Object why, Lisp_Object block) +{ + CHECK_STRING (what); + CHECK_STRING (why); + if (!NILP (block)) + block = Qt; + Lisp_Object who = build_string ("Emacs"); + Lisp_Object mode = + (NILP (block)) ? build_string ("delay") : build_string ("block"); + + /* Check, whether it is registered already. */ + Lisp_Object triple = list3 (what, why, block); + Lisp_Object registered = Frassoc (triple, xd_registered_inhibitor_locks); + if (!NILP (registered)) + return CAR_SAFE (registered); + + /* Register lock. */ + Lisp_Object lock = + calln (Qdbus_call_method, QCsystem, + build_string ("org.freedesktop.login1"), + build_string ("/org/freedesktop/login1"), + build_string ("org.freedesktop.login1.Manager"), + build_string ("Inhibit"), what, who, why, mode); + + xd_registered_inhibitor_locks = + Fcons (Fcons (lock, triple), xd_registered_inhibitor_locks); + return lock; +} + +DEFUN ("dbus-close-inhibitor-lock", Fdbus_close_inhibitor_lock, + Sdbus_close_inhibitor_lock, + 1, 1, 0, + doc: /* Close inhibitor lock file descriptor. + +LOCK, a file descriptor, must be the result of a `dbus-make-inhibitor-lock' +call. It returns t in case of success, or nil if it isn't be possible +to close the lock, or if the lock is closed already. + +For details, see Info node `(dbus)Inhibitor Locks'. */) + (Lisp_Object lock) +{ + CHECK_FIXNUM (lock); + + /* Check, whether it is registered. */ + Lisp_Object registered = assoc_no_quit (lock, xd_registered_inhibitor_locks); + if (NILP (registered)) + return Qnil; + else + { + xd_registered_inhibitor_locks = + Fdelete (registered, xd_registered_inhibitor_locks); + return (emacs_close (XFIXNAT (lock)) == 0) ? Qt : Qnil; + } +} + +DEFUN ("dbus-registered-inhibitor-locks", Fdbus_registered_inhibitor_locks, + Sdbus_registered_inhibitor_locks, + 0, 0, 0, + doc: /* Return registered inhibitor locks, an alist. +This allows to check, whether other packages of the running Emacs +instance have acquired an inhibitor lock as well. +An entry in this list is a list (FD WHAT WHY BLOCK). +The car of the list is the file descriptor retrieved from a +'dbus-make-inhibitor-lock` call. The cdr of the list represents the +three arguments 'dbus-make-inhibitor-lock` was called with. */) + (void) +{ + /* We return a copy of xd_registered_inhibitor_locks, in order to + protect it against malicious manipulation. */ + Lisp_Object registered = xd_registered_inhibitor_locks; + Lisp_Object result = Qnil; + for (; !NILP (registered); registered = CDR_SAFE (registered)) + result = Fcons (Fcopy_sequence (CAR_SAFE (registered)), result); + return Fnreverse (result); +} + +/* Construct a D-Bus event, and store it into the input event queue. */ +static void +xd_store_event (Lisp_Object handler, Lisp_Object handler_args, + Lisp_Object event_args) +{ + struct input_event event; + EVENT_INIT (event); + event.kind = DBUS_EVENT; + event.frame_or_window = Qnil; + /* Handler and handler args. */ + event.arg = Fcons (handler, handler_args); + /* Event args. */ + event.arg = CALLN (Fappend, event_args, event.arg); + /* Store it into the input event queue. */ + kbd_buffer_store_event (&event); + + XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg)); +} + /* Read one queued incoming message of the D-Bus BUS. BUS is either a Lisp symbol, :system, :session, :system-private or :session-private, or a string denoting the bus address. */ static void xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) { - Lisp_Object args, key, value; - struct input_event event; + Lisp_Object args, event_args, key, value; DBusMessage *dmessage; DBusMessageIter iter; int dtype; @@ -1699,6 +1820,27 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) mtype == DBUS_MESSAGE_TYPE_ERROR ? error_name : member, XD_OBJECT_TO_STRING (args)); + /* Add type, serial, uname, destination, path, interface and member + or error_name to the event_args. */ + event_args + = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR + ? error_name == NULL ? Qnil : build_string (error_name) + : member == NULL ? Qnil : build_string (member), + Qnil); + event_args = Fcons ((interface == NULL ? Qnil : build_string (interface)), + event_args); + event_args = Fcons ((path == NULL ? Qnil : build_string (path)), + event_args); + event_args = Fcons ((destination == NULL ? Qnil : build_string (destination)), + event_args); + event_args = Fcons ((uname == NULL ? Qnil : build_string (uname)), + event_args); + event_args = Fcons (INT_TO_INTEGER (serial), event_args); + event_args = Fcons (make_fixnum (mtype), event_args); + + /* Add the bus symbol to the event. */ + event_args = Fcons (bus, event_args); + if (mtype == DBUS_MESSAGE_TYPE_INVALID) goto cleanup; @@ -1716,12 +1858,8 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) /* Remove the entry. */ Fremhash (key, Vdbus_registered_objects_table); - /* Construct an event. */ - EVENT_INIT (event); - event.kind = DBUS_EVENT; - event.frame_or_window = Qnil; - /* Handler. */ - event.arg = Fcons (value, args); + /* Store the event. */ + xd_store_event (value, args, event_args); } else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */ @@ -1752,6 +1890,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) Fgethash (key, Vdbus_registered_objects_table, Qnil)); } + Lisp_Object called_handlers = Qnil; /* Loop over the registered functions. Construct an event. */ for (; !NILP (value); value = CDR_SAFE (value)) { @@ -1770,45 +1909,15 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) Lisp_Object handler = CAR_SAFE (CDR_SAFE (key_path_etc)); if (NILP (handler)) continue; + if (!NILP (memq_no_quit (handler, called_handlers))) + continue; + called_handlers = Fcons (handler, called_handlers); - /* Construct an event and exit the loop. */ - EVENT_INIT (event); - event.kind = DBUS_EVENT; - event.frame_or_window = Qnil; - event.arg = Fcons (handler, args); - break; + /* Store the event. */ + xd_store_event (handler, args, event_args); } - - if (NILP (value)) - goto monitor; } - /* Add type, serial, uname, destination, path, interface and member - or error_name to the event. */ - event.arg - = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR - ? error_name == NULL ? Qnil : build_string (error_name) - : member == NULL ? Qnil : build_string (member), - event.arg); - event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)), - event.arg); - event.arg = Fcons ((path == NULL ? Qnil : build_string (path)), - event.arg); - event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)), - event.arg); - event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)), - event.arg); - event.arg = Fcons (INT_TO_INTEGER (serial), event.arg); - event.arg = Fcons (make_fixnum (mtype), event.arg); - - /* Add the bus symbol to the event. */ - event.arg = Fcons (bus, event.arg); - - /* Store it into the input event queue. */ - kbd_buffer_store_event (&event); - - XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg)); - /* Monitor. */ monitor: /* Search for a registered function of the message. */ @@ -1819,39 +1928,9 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) if (NILP (value)) goto cleanup; - /* Construct an event. */ - EVENT_INIT (event); - event.kind = DBUS_EVENT; - event.frame_or_window = Qnil; - - /* Add type, serial, uname, destination, path, interface, member - or error_name and handler to the event. */ - event.arg - = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))), - args); - event.arg - = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR - ? error_name == NULL ? Qnil : build_string (error_name) - : member == NULL ? Qnil : build_string (member), - event.arg); - event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)), - event.arg); - event.arg = Fcons ((path == NULL ? Qnil : build_string (path)), - event.arg); - event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)), - event.arg); - event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)), - event.arg); - event.arg = Fcons (INT_TO_INTEGER (serial), event.arg); - event.arg = Fcons (make_fixnum (mtype), event.arg); - - /* Add the bus symbol to the event. */ - event.arg = Fcons (bus, event.arg); - - /* Store it into the input event queue. */ - kbd_buffer_store_event (&event); - - XD_DEBUG_MESSAGE ("Monitor event stored: %s", XD_OBJECT_TO_STRING (event.arg)); + /* Store the event. */ + xd_store_event (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))), + args, event_args); /* Cleanup. */ cleanup: @@ -1916,6 +1995,7 @@ static void syms_of_dbusbind_for_pdumper (void) { xd_registered_buses = Qnil; + xd_registered_inhibitor_locks = Qnil; } void @@ -1923,6 +2003,9 @@ syms_of_dbusbind (void) { defsubr (&Sdbus__init_bus); defsubr (&Sdbus_get_unique_name); + defsubr (&Sdbus_make_inhibitor_lock); + defsubr (&Sdbus_close_inhibitor_lock); + defsubr (&Sdbus_registered_inhibitor_locks); DEFSYM (Qdbus_message_internal, "dbus-message-internal"); defsubr (&Sdbus_message_internal); @@ -1977,6 +2060,7 @@ syms_of_dbusbind (void) /* Miscellaneous Lisp symbols. */ DEFSYM (Qdbus_get_name_owner, "dbus-get-name-owner"); + DEFSYM (Qdbus_call_method, "dbus-call-method"); DEFVAR_LISP ("dbus-compiled-version", Vdbus_compiled_version, @@ -2082,6 +2166,7 @@ be called when the D-Bus reply message arrives. */); /* Initialize internal objects. */ pdumper_do_now_and_after_load (syms_of_dbusbind_for_pdumper); staticpro (&xd_registered_buses); + staticpro (&xd_registered_inhibitor_locks); Fprovide (intern_c_string ("dbusbind"), Qnil); } diff --git a/src/dispextern.h b/src/dispextern.h index 1877ce96112..f9407461f5c 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -964,6 +964,9 @@ struct glyph_row in last row when checking if row is fully visible. */ int extra_line_spacing; + /* Part of extra_line_spacing that should go above the line. */ + int extra_line_spacing_above; + /* First position in this row. This is the text position, including overlay position information etc, where the display of this row started, and can thus be less than the position of the first @@ -2783,6 +2786,10 @@ struct it window systems only.) */ int extra_line_spacing; + /* Default amount of additional space in pixels above lines (for + window systems only). */ + int extra_line_spacing_above; + /* Max extra line spacing added in this row. */ int max_extra_line_spacing; diff --git a/src/eval.c b/src/eval.c index e84beeee91b..f2ef7e3a767 100644 --- a/src/eval.c +++ b/src/eval.c @@ -301,11 +301,10 @@ call_debugger (Lisp_Object arg) specpdl_ref count = SPECPDL_INDEX (); Lisp_Object val; - /* The previous value of 40 is too small now that the debugger - prints using cl-prin1 instead of prin1. Printing lists nested 8 - deep (which is the value of print-level used in the debugger) - currently requires 77 additional frames. See bug#31919. */ - max_ensure_room (100); + /* The debugger currently requires 77 additional frames to print lists + nested 8 deep (the value of print-level used in the debugger) using + cl-prin1 (bug#31919), with a margin to be on the safe side. */ + max_ensure_room (200); #ifdef HAVE_WINDOW_SYSTEM if (display_hourglass_p) @@ -2013,7 +2012,9 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool continuable) if (!NILP (find_handler_clause (h->tag_or_ch, conditions))) { specpdl_ref count = SPECPDL_INDEX (); - max_ensure_room (20); + /* Add some room in case this is for debugging, as in + call_debugger. */ + max_ensure_room (200); push_handler (make_fixnum (skip + h->bytecode_dest), SKIP_CONDITIONS); calln (h->val, error); diff --git a/src/fns.c b/src/fns.c index f76a3b7ef20..85c27d0e625 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2107,6 +2107,31 @@ argument. */) return list; } +/* Like Fdelq but do not report errors and neither quit nor process + signals. Use only on objects known to be non-circular lists. */ +Lisp_Object +delq_no_quit (Lisp_Object elt, Lisp_Object list) +{ + Lisp_Object prev = Qnil, tail = list; + + for (; !NILP (tail); tail = XCDR (tail)) + { + Lisp_Object tem = XCAR (tail); + + if (EQ (elt, tem)) + { + if (NILP (prev)) + list = XCDR (tail); + else + Fsetcdr (prev, XCDR (tail)); + } + else + prev = tail; + } + + return list; +} + DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0, doc: /* Delete members of SEQ which are `equal' to ELT, and return the result. SEQ must be a sequence (i.e. a list, a vector, or a string). diff --git a/src/frame.c b/src/frame.c index 24bc95f5c08..ffac559252d 100644 --- a/src/frame.c +++ b/src/frame.c @@ -338,6 +338,83 @@ return values. */) : Qnil); } + +/* Frame id. */ + +EMACS_UINT frame_next_id = 1; /* 0 indicates no id (yet) set. */ + +DEFUN ("frame-id", Fframe_id, Sframe_id, 0, 1, 0, + doc: /* Return FRAME's id. +If FRAME is nil, use the selected frame. +Return nil if the id has not been set. */) + (Lisp_Object frame) +{ + if (NILP (frame)) + frame = selected_frame; + struct frame *f = decode_live_frame (frame); + if (f->id == 0) + return Qnil; + else + return make_fixnum (f->id); +} + +/** frame_set_id: Set frame F's id to ID. + + If ID is 0 and F's ID is 0, use frame_next_id and increment it, + otherwise, use ID. + + Signal an error if ID >= frame_next_id. + Signal an error if ID is in use on another live frame. + + Return ID if it was used, 0 otherwise. */ +EMACS_UINT +frame_set_id (struct frame *f, EMACS_UINT id) +{ + if (id >= frame_next_id) + error ("Specified frame ID unassigned"); + + if (id > 0) + { + eassume (CONSP (Vframe_list)); + Lisp_Object frame, tail = Qnil; + FOR_EACH_FRAME (tail, frame) + { + if (id == XFRAME (frame)->id) + error ("Specified frame ID already in use"); + } + } + + if (id == 0) + if (f->id != 0) + return 0; + else + f->id = frame_next_id++; + else + f->id = id; + return f->id; +} + +/** frame_set_id_from_params: Set frame F's id from params, if present. + + Call frame_set_id to using the frame parameter 'frame-id, if present + and a valid positive integer greater than 0, otherwise use 0. + + Return frame_set_id's return value. */ +EMACS_UINT +frame_set_id_from_params (struct frame *f, Lisp_Object params) +{ + EMACS_UINT id = 0; + Lisp_Object param_id = Fcdr (Fassq (Qframe_id, params)); + if (TYPE_RANGED_FIXNUMP (int, param_id)) + { + EMACS_INT id_1 = XFIXNUM (param_id); + if (id_1 > 0) + id = (EMACS_UINT) id_1; + } + return frame_set_id (f, id); +} + + DEFUN ("window-system", Fwindow_system, Swindow_system, 0, 1, 0, doc: /* The name of the window system that FRAME is displaying through. The value is a symbol: @@ -1359,6 +1436,7 @@ make_initial_frame (void) f = make_frame (true); XSETFRAME (frame, f); + frame_set_id (f, 0); Vframe_list = Fcons (frame, Vframe_list); @@ -1743,6 +1821,7 @@ affects all frames on the same terminal device. */) frames don't obscure other frames. */ Lisp_Object parent = Fcdr (Fassq (Qparent_frame, parms)); struct frame *f = make_terminal_frame (t, parent, parms); + frame_set_id_from_params (f, parms); if (!noninteractive) init_frame_faces (f); @@ -2779,9 +2858,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force) delete_all_child_windows (f->root_window); fset_root_window (f, Qnil); - block_input (); - Vframe_list = Fdelq (frame, Vframe_list); - unblock_input (); + Vframe_list = delq_no_quit (frame, Vframe_list); SET_FRAME_VISIBLE (f, false); /* Allow the vector of menu bar contents to be freed in the next @@ -2811,6 +2888,15 @@ delete_frame (Lisp_Object frame, Lisp_Object force) promise that the terminal of the frame must be valid until we have called the window-system-dependent frame destruction routine. */ + /* Remember if this was a GUI child frame, so we can + process pending window system events after destruction. */ + bool was_gui_child_frame = FRAME_WINDOW_P (f) && FRAME_PARENT_FRAME (f); +#ifdef HAVE_X_WINDOWS + /* Save the X display before the frame is destroyed, so we can + sync with the X server afterwards. */ + Display *child_frame_display = (was_gui_child_frame && FRAME_X_P (f) + ? FRAME_X_DISPLAY (f) : NULL); +#endif { struct terminal *terminal; block_input (); @@ -2820,6 +2906,24 @@ delete_frame (Lisp_Object frame, Lisp_Object force) f->terminal = 0; /* Now the frame is dead. */ unblock_input (); + /* When a GUI child frame is deleted, the window system may + generate events that affect the parent frame (e.g. + ConfigureNotify, Expose, etc.). We need to sync with the + X server to ensure all events from the frame destruction + have been received, then process them to ensure subsequent + operations like `recenter' see up-to-date window state. + (Bug#76186) */ +#ifdef HAVE_X_WINDOWS + if (child_frame_display) + { + block_input (); + XSync (child_frame_display, False); + unblock_input (); + } +#endif + if (was_gui_child_frame) + swallow_events (false); + /* Clear markers and overlays set by F on behalf of an input method. */ #ifdef HAVE_TEXT_CONVERSION @@ -4526,10 +4630,11 @@ DEFUN ("set-frame-position", Fset_frame_position, doc: /* Set position of FRAME to (X, Y). FRAME must be a live frame and defaults to the selected one. X and Y, if positive, specify the coordinate of the left and top edge of FRAME's -outer frame in pixels relative to an origin (0, 0) of FRAME's display. -If any of X or Y is negative, it specifies the coordinates of the right -or bottom edge of the outer frame of FRAME relative to the right or -bottom edge of FRAME's display. */) +outer frame in pixels relative to an origin (0, 0) of FRAME's display +or, if FRAME is a child frame, its parent frame. If any of X or Y is +negative, it specifies the coordinates of the right or bottom edge of +the outer frame of FRAME relative to the right or bottom edge of FRAME's +display or parent frame. */) (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { struct frame *f = decode_live_frame (frame); @@ -5377,18 +5482,60 @@ void gui_set_line_spacing (struct frame *f, Lisp_Object new_value, Lisp_Object old_value) { if (NILP (new_value)) - f->extra_line_spacing = 0; + { + f->extra_line_spacing = 0; + f->extra_line_spacing_above = 0; + } else if (RANGED_FIXNUMP (0, new_value, INT_MAX)) - f->extra_line_spacing = XFIXNAT (new_value); + { + f->extra_line_spacing = XFIXNAT (new_value); + f->extra_line_spacing_above = 0; + } else if (FLOATP (new_value)) { - int new_spacing = XFLOAT_DATA (new_value) * FRAME_LINE_HEIGHT (f) + 0.5; + int new_spacing = XFLOAT_DATA (new_value) * FRAME_LINE_HEIGHT (f); - if (new_spacing >= 0) + if (new_spacing >= 0) { f->extra_line_spacing = new_spacing; + f->extra_line_spacing_above = 0; + } else signal_error ("Invalid line-spacing", new_value); } + else if (CONSP (new_value)) + { + Lisp_Object above = XCAR (new_value); + Lisp_Object below = XCDR (new_value); + + /* Integer pair case. */ + if (RANGED_FIXNUMP (0, above, INT_MAX) + && RANGED_FIXNUMP (0, below, INT_MAX)) + { + f->extra_line_spacing = XFIXNAT (above) + XFIXNAT (below); + f->extra_line_spacing_above = XFIXNAT (above); + } + + /* Float pair case. */ + else if (FLOATP (XCAR (new_value)) + && FLOATP (XCDR (new_value))) + { + int new_spacing = (XFLOAT_DATA (above) + XFLOAT_DATA (below)) * FRAME_LINE_HEIGHT (f); + int spacing_above = XFLOAT_DATA (above) * FRAME_LINE_HEIGHT (f); + if(new_spacing >= 0 && spacing_above >= 0) + { + f->extra_line_spacing = new_spacing; + f->extra_line_spacing_above = spacing_above; + } + else + signal_error ("Invalid line-spacing", new_value); + } + + /* Unmatched pair case. */ + else + { + signal_error ("Invalid line-spacing", new_value); + } + } else signal_error ("Invalid line-spacing", new_value); if (FRAME_VISIBLE_P (f)) @@ -7205,6 +7352,9 @@ syms_of_frame (void) DEFSYM (Qfont_parameter, "font-parameter"); DEFSYM (Qforce, "force"); DEFSYM (Qinhibit, "inhibit"); + DEFSYM (Qframe_id, "frame-id"); + DEFSYM (Qcloned_from, "cloned-from"); + DEFSYM (Qundeleted, "undeleted"); for (int i = 0; i < ARRAYELTS (frame_parms); i++) { @@ -7589,6 +7739,9 @@ allow `make-frame' to show the current buffer even if its hidden. */); #else frame_internal_parameters = list3 (Qname, Qparent_id, Qwindow_id); #endif + frame_internal_parameters = Fcons (Qframe_id, frame_internal_parameters); + frame_internal_parameters = Fcons (Qcloned_from, frame_internal_parameters); + frame_internal_parameters = Fcons (Qundeleted, frame_internal_parameters); DEFVAR_LISP ("alter-fullscreen-frames", alter_fullscreen_frames, doc: /* How to handle requests to resize fullscreen frames. @@ -7613,6 +7766,7 @@ The default is \\+`inhibit' in NS builds and nil everywhere else. */); alter_fullscreen_frames = Qnil; #endif + defsubr (&Sframe_id); defsubr (&Sframep); defsubr (&Sframe_live_p); defsubr (&Swindow_system); diff --git a/src/frame.h b/src/frame.h index 668ff94e13d..56493ba8cd7 100644 --- a/src/frame.h +++ b/src/frame.h @@ -292,6 +292,9 @@ struct frame struct image_cache *image_cache; #endif /* HAVE_WINDOW_SYSTEM */ + /* Unique frame id. */ + EMACS_UINT id; + /* Tab-bar item index of the item on which a mouse button was pressed. */ int last_tab_bar_item; @@ -715,9 +718,16 @@ struct frame frame parameter. 0 means don't do gamma correction. */ double gamma; - /* Additional space to put between text lines on this frame. */ + /* Additional space to put below text lines on this frame. + Also takes part in line height calculation. */ int extra_line_spacing; + /* Amount of space (included in extra_line_spacing) that goes ABOVE + line line. + IMPORTANT: Don't use this for line height calculations. + (5 . 20) means that extra_line_spacing is 25 with 5 above. */ + int extra_line_spacing_above; + /* All display backends seem to need these two pixel values. */ unsigned long background_pixel; unsigned long foreground_pixel; @@ -1415,6 +1425,10 @@ FRAME_PARENT_FRAME (struct frame *f) #define AUTO_FRAME_ARG(name, parameter, value) \ AUTO_LIST1 (name, AUTO_CONS_EXPR (parameter, value)) +extern EMACS_UINT frame_next_id; +extern EMACS_UINT frame_set_id (struct frame *f, EMACS_UINT id); +extern EMACS_UINT frame_set_id_from_params (struct frame *f, Lisp_Object params); + /* False means there are no visible garbaged frames. */ extern bool frame_garbaged; diff --git a/src/haikufns.c b/src/haikufns.c index 21507a43a26..e24dfd2193e 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -750,6 +750,8 @@ haiku_create_frame (Lisp_Object parms) XSETFRAME (frame, f); + frame_set_id_from_params (f, parms); + f->terminal = dpyinfo->terminal; f->output_method = output_haiku; diff --git a/src/igc.c b/src/igc.c index 6ee4d13bf6a..7d5a5af7b2d 100644 --- a/src/igc.c +++ b/src/igc.c @@ -145,7 +145,7 @@ along with GNU Emacs. If not, see . */ # ifndef HASH_glyph_matrix_559A8DDA89 # error "struct glyph_matrix changed" # endif -# ifndef HASH_frame_B282EBF860 +# ifndef HASH_frame_A6A197F2D1 # error "struct frame changed" # endif # ifndef HASH_window_AAD29CF361 diff --git a/src/image.c b/src/image.c index b2719385852..19d830bb9c2 100644 --- a/src/image.c +++ b/src/image.c @@ -271,8 +271,7 @@ image_pix_context_get_pixel (Emacs_Pix_Context image, int x, int y) } static Emacs_Pix_Container -image_pix_container_create_from_bitmap_data (struct frame *f, - char *data, unsigned int width, +image_pix_container_create_from_bitmap_data (char *data, unsigned int width, unsigned int height, unsigned long fg, unsigned long bg) @@ -1472,7 +1471,8 @@ struct image_keyword /* True means key must be present. */ bool mandatory_p; - /* Used to recognize duplicate keywords in a property list. */ + /* True means key is present. + Also used to recognize duplicate keywords in a property list. */ bool count; /* The value that was found. */ @@ -1570,7 +1570,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, /* Unlike the other integer-related cases, this one does not verify that VALUE fits in 'int'. This is because callers want EMACS_INT. */ - if (!FIXNUMP (value) || XFIXNUM (value) < 0) + if (!FIXNATP (value)) return false; break; @@ -2139,6 +2139,7 @@ image_clear_image_1 (struct frame *f, struct image *img, int flags) static void image_clear_image (struct frame *f, struct image *img) { + img->lisp_data = Qnil; block_input (); image_clear_image_1 (f, img, (CLEAR_IMAGE_PIXMAP @@ -2280,8 +2281,7 @@ filter_image_spec (Lisp_Object spec) breaks the image cache. Filter those out. */ if (!(EQ (key, QCanimate_buffer) || EQ (key, QCanimate_tardiness) - || EQ (key, QCanimate_position) - || EQ (key, QCanimate_multi_frame_data))) + || EQ (key, QCanimate_position))) { out = Fcons (value, out); out = Fcons (key, out); @@ -2443,23 +2443,27 @@ clear_image_caches (Lisp_Object filter) DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache, 0, 2, 0, - doc: /* Clear the image cache. + doc: /* Clear the image and animation caches. FILTER nil or a frame means clear all images in the selected frame. FILTER t means clear the image caches of all frames. Anything else means clear only those images that refer to FILTER, which is then usually a filename. -This function also clears the image animation cache. If -ANIMATION-CACHE is non-nil, only the image spec `eq' with -ANIMATION-CACHE is removed, and other image cache entries are not -evicted. */) - (Lisp_Object filter, Lisp_Object animation_cache) +This function also clears the image animation cache. +ANIMATION-FILTER nil means clear all animation cache entries. +Otherwise, clear the image spec `eq' to ANIMATION-FILTER only +from the animation cache, and do not clear any image caches. +This can help reduce memory usage after an animation is stopped +but the image is still displayed. */) + (Lisp_Object filter, Lisp_Object animation_filter) { - if (!NILP (animation_cache)) + if (!NILP (animation_filter)) { - CHECK_CONS (animation_cache); + /* IMAGEP? */ + CHECK_CONS (animation_filter); #if defined (HAVE_WEBP) || defined (HAVE_GIF) - anim_prune_animation_cache (XCDR (animation_cache)); + /* FIXME: Implement the ImageMagick case. */ + anim_prune_animation_cache (XCDR (animation_filter)); #endif return Qnil; } @@ -2475,10 +2479,10 @@ evicted. */) return Qnil; } -static size_t +static intptr_t image_size_in_bytes (struct image *img) { - size_t size = 0; + intptr_t size = 0; #if defined USE_CAIRO Emacs_Pixmap pm = img->pixmap; @@ -2523,14 +2527,14 @@ image_size_in_bytes (struct image *img) return size; } -static size_t +static intptr_t image_frame_cache_size (struct frame *f) { struct image_cache *c = FRAME_IMAGE_CACHE (f); if (!c) return 0; - size_t total = 0; + intptr_t total = 0; for (ptrdiff_t i = 0; i < c->used; ++i) { struct image *img = c->images[i]; @@ -3696,41 +3700,78 @@ cache_image (struct frame *f, struct image *img) #if defined (HAVE_WEBP) || defined (HAVE_GIF) +# ifdef HAVE_GIF +struct gif_anim_handle +{ + struct GifFileType *gif; + unsigned long *pixmap; +}; +# endif /* HAVE_GIF */ + +# ifdef HAVE_WEBP +struct webp_anim_handle +{ + /* Decoder iterator+compositor. */ + struct WebPAnimDecoder *dec; + /* Owned copy of input WebP bitstream data consumed by decoder, + which it must outlive unchanged. */ + uint8_t *contents; + /* Timestamp in milliseconds of last decoded frame. */ + int timestamp; +}; +# endif /* HAVE_WEBP */ + /* To speed animations up, we keep a cache (based on EQ-ness of the image spec/object) where we put the animator iterator. */ struct anim_cache { + /* 'Key' of this cache entry. + Typically the cdr (plist) of an image spec. */ Lisp_Object spec; - /* For webp, this will be an iterator, and for libgif, a gif handle. */ - void *handle; - /* If we need to maintain temporary data of some sort. */ - void *temp; + /* Image type dependent animation handle (e.g., WebP iterator), freed + by 'destructor'. The union allows maintaining multiple fields per + image type and image frame without further heap allocations. */ + union anim_handle + { +# ifdef HAVE_GIF + struct gif_anim_handle gif; +# endif /* HAVE_GIF */ +# ifdef HAVE_WEBP + struct webp_anim_handle webp; +# endif /* HAVE_WEBP */ + } handle; /* A function to call to free the handle. */ - void (*destructor) (void *); - int index, width, height, frames; + void (*destructor) (union anim_handle *); + /* Current frame index, and total number of frames. Note that + different image formats may start at different indices. */ + int index, frames; + /* Animation frame dimensions. */ + int width, height; /* This is used to be able to say something about the cache size. - We don't actually know how much memory the different libraries - actually use here (since these cache structures are opaque), so - this is mostly just the size of the original image file. */ - int byte_size; + We don't know how much memory the different libraries actually + use here (since these cache structures are opaque), so this is + mostly just the size of the original image file. */ + intmax_t byte_size; + /* Last time this cache entry was updated. */ struct timespec update_time; struct anim_cache *next; }; static struct anim_cache *anim_cache = NULL; -static struct anim_cache * +/* Return a new animation cache entry for image SPEC (which need not be + an image specification, and is typically its cdr/plist). + Freed only by pruning the cache. */ +static ATTRIBUTE_MALLOC struct anim_cache * anim_create_cache (Lisp_Object spec) { - struct anim_cache *cache = xmalloc (sizeof (struct anim_cache)); - cache->handle = NULL; - cache->temp = NULL; - - cache->index = -1; - cache->next = NULL; + struct anim_cache *cache = xzalloc (sizeof *cache); cache->spec = spec; - cache->byte_size = 0; + cache->index = -1; + cache->frames = -1; + cache->width = -1; + cache->height = -1; return cache; } @@ -3752,10 +3793,8 @@ anim_prune_animation_cache (Lisp_Object clear) || (NILP (clear) && timespec_cmp (old, cache->update_time) > 0) || EQ (clear, cache->spec)) { - if (cache->handle) - cache->destructor (cache); - if (cache->temp) - xfree (cache->temp); + if (cache->destructor) + cache->destructor (&cache->handle); *pcache = cache->next; xfree (cache); } @@ -3791,12 +3830,8 @@ anim_get_animation_cache (Lisp_Object spec) #endif /* HAVE_WEBP || HAVE_GIF */ -/* Call FN on every image in the image cache of frame F. Used to mark - Lisp Objects in the image cache. */ - -/* Mark Lisp objects in image IMG. */ #ifndef HAVE_MPS - +/* Mark Lisp objects in image IMG. */ static void mark_image (struct image *img) { @@ -3807,6 +3842,8 @@ mark_image (struct image *img) mark_object (img->lisp_data); } +/* Mark every image in image cache C, as well as the global animation + cache. */ void mark_image_cache (struct image_cache *c) { @@ -3949,7 +3986,7 @@ x_destroy_x_image (XImage *ximg) static Picture x_create_xrender_picture (struct frame *f, Emacs_Pixmap pixmap, int depth) { - Picture p; + Picture p = None; Display *display = FRAME_X_DISPLAY (f); if (FRAME_DISPLAY_INFO (f)->xrender_supported_p) @@ -3984,15 +4021,7 @@ x_create_xrender_picture (struct frame *f, Emacs_Pixmap pixmap, int depth) p = XRenderCreatePicture (display, pixmap, format, attr_mask, &attr); } else - { - image_error ("Specified image bit depth is not supported by XRender"); - return 0; - } - } - else - { - /* XRender not supported on this display. */ - return 0; + image_error ("Specified image bit depth is not supported by XRender"); } return p; @@ -4625,7 +4654,7 @@ enum xbm_token /* Return true if OBJECT is a valid XBM-type image specification. - A valid specification is a list starting with the symbol `image' + A valid specification is a list starting with the symbol `image'. The rest of the list is a property list which must contain an entry `:type xbm'. @@ -4648,8 +4677,8 @@ enum xbm_token Both the file and data forms may contain the additional entries `:background COLOR' and `:foreground COLOR'. If not present, - foreground and background of the frame on which the image is - displayed is used. */ + the foreground and background of the frame on which the image is + displayed are used. */ static bool xbm_image_p (Lisp_Object object) @@ -4667,18 +4696,14 @@ xbm_image_p (Lisp_Object object) if (kw[XBM_DATA].count) return 0; } - else if (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value)) - { - /* In-memory XBM file. */ - if (kw[XBM_FILE].count) - return 0; - } - else + else if (! (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value))) + /* Not an in-memory XBM file. */ { Lisp_Object data; int width, height, stride; - /* Entries for `:width', `:height' and `:data' must be present. */ + /* Entries for `:data-width', `:data-height', and `:data' must be + present. */ if (!kw[XBM_DATA_WIDTH].count || !kw[XBM_DATA_HEIGHT].count || !kw[XBM_DATA].count) @@ -4962,7 +4987,7 @@ Create_Pixmap_From_Bitmap_Data (struct frame *f, struct image *img, char *data, fg = lookup_rgb_color (f, fgbg[0].red, fgbg[0].green, fgbg[0].blue); bg = lookup_rgb_color (f, fgbg[1].red, fgbg[1].green, fgbg[1].blue); img->pixmap - = image_pix_container_create_from_bitmap_data (f, data, img->width, + = image_pix_container_create_from_bitmap_data (data, img->width, img->height, fg, bg); #elif defined HAVE_X_WINDOWS img->pixmap @@ -7465,7 +7490,7 @@ image_build_heuristic_mask (struct frame *f, struct image *img, PBM (mono, gray, color) ***********************************************************************/ -/* Indices of image specification fields in gs_format, below. */ +/* Indices of image specification fields in pbm_format, below. */ enum pbm_keyword_index { @@ -7885,7 +7910,7 @@ enum native_image_keyword_index /* Vector of image_keyword structures describing the format of valid user-defined image specifications. */ -static const struct image_keyword native_image_format[] = +static const struct image_keyword native_image_format[NATIVE_IMAGE_LAST] = { {":type", IMAGE_SYMBOL_VALUE, 1}, {":data", IMAGE_STRING_VALUE, 0}, @@ -7908,8 +7933,8 @@ native_image_p (Lisp_Object object) struct image_keyword fmt[NATIVE_IMAGE_LAST]; memcpy (fmt, native_image_format, sizeof fmt); - if (!parse_image_spec (object, fmt, 10, Qnative_image)) - return 0; + if (!parse_image_spec (object, fmt, NATIVE_IMAGE_LAST, Qnative_image)) + return false; /* Must specify either the :data or :file keyword. */ return fmt[NATIVE_IMAGE_FILE].count + fmt[NATIVE_IMAGE_DATA].count == 1; @@ -8610,7 +8635,7 @@ png_load (struct frame *f, struct image *img) #if defined (HAVE_JPEG) -/* Indices of image specification fields in gs_format, below. */ +/* Indices of image specification fields in jpeg_format, below. */ enum jpeg_keyword_index { @@ -9649,15 +9674,6 @@ static const struct image_keyword gif_format[GIF_LAST] = {":background", IMAGE_STRING_OR_NIL_VALUE, 0} }; -/* Free X resources of GIF image IMG which is used on frame F. */ - -static void -gif_clear_image (struct frame *f, struct image *img) -{ - img->lisp_data = Qnil; - image_clear_image (f, img); -} - /* Return true if OBJECT is a valid GIF image specification. */ static bool @@ -9841,11 +9857,15 @@ static const int interlace_increment[] = {8, 8, 4, 2}; #define GIF_LOCAL_DESCRIPTOR_EXTENSION 249 +/* Release gif_anim_handle resources. */ static void -gif_destroy (struct anim_cache* cache) +gif_destroy (union anim_handle *handle) { - int gif_err; - gif_close (cache->handle, &gif_err); + struct gif_anim_handle *h = &handle->gif; + gif_close (h->gif, NULL); + h->gif = NULL; + xfree (h->pixmap); + h->pixmap = NULL; } static bool @@ -9862,9 +9882,10 @@ gif_load (struct frame *f, struct image *img) EMACS_INT idx = -1; int gif_err; struct anim_cache* cache = NULL; + struct gif_anim_handle *anim_handle = NULL; /* Which sub-image are we to display? */ Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL); - int byte_size = 0; + intmax_t byte_size = 0; idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0; @@ -9872,12 +9893,15 @@ gif_load (struct frame *f, struct image *img) { /* If this is an animated image, create a cache for it. */ cache = anim_get_animation_cache (XCDR (img->spec)); + anim_handle = &cache->handle.gif; /* We have an old cache entry, so use it. */ - if (cache->handle) + if (anim_handle->gif) { - gif = cache->handle; - pixmap = cache->temp; - /* We're out of sync, so start from the beginning. */ + gif = anim_handle->gif; + pixmap = anim_handle->pixmap; + /* We're out of sync, so start from the beginning. + FIXME: Can't we fast-forward like webp_load does when + idx > cache->index, instead of restarting? */ if (cache->index != idx - 1) cache->index = -1; } @@ -10034,10 +10058,10 @@ gif_load (struct frame *f, struct image *img) } /* It's an animated image, so initialize the cache. */ - if (cache && !cache->handle) + if (cache && !anim_handle->gif) { - cache->handle = gif; - cache->destructor = (void (*)(void *)) &gif_destroy; + anim_handle->gif = gif; + cache->destructor = gif_destroy; cache->width = width; cache->height = height; cache->byte_size = byte_size; @@ -10066,8 +10090,8 @@ gif_load (struct frame *f, struct image *img) if (!pixmap) { pixmap = xmalloc (width * height * sizeof (unsigned long)); - if (cache) - cache->temp = pixmap; + if (anim_handle) + anim_handle->pixmap = pixmap; } /* Clear the part of the screen image not covered by the image. @@ -10120,7 +10144,7 @@ gif_load (struct frame *f, struct image *img) int start_frame = 0; /* We have animation data in the cache. */ - if (cache && cache->temp) + if (cache && anim_handle->pixmap) { start_frame = cache->index + 1; if (start_frame > idx) @@ -10280,11 +10304,16 @@ gif_load (struct frame *f, struct image *img) delay |= ext->Bytes[1]; } } + /* FIXME: Expose this via a nicer interface (bug#66221#122). */ img->lisp_data = list2 (Qextension_data, img->lisp_data); + /* We used to return a default delay of 1/15th of a second. + Meanwhile browsers have settled on 1/10th of a second. + For consistency across image types and to afford user + configuration, we now return a non-nil nonnumeric value that + image-multi-frame-p turns into image-default-frame-delay. */ img->lisp_data = Fcons (Qdelay, - /* Default GIF delay is 1/15th of a second. */ - Fcons (make_float (delay? delay / 100.0: 1.0 / 15), + Fcons (delay ? make_float (delay / 100.0) : Qt, img->lisp_data)); } @@ -10295,8 +10324,7 @@ gif_load (struct frame *f, struct image *img) if (!cache) { - if (pixmap) - xfree (pixmap); + xfree (pixmap); if (gif_close (gif, &gif_err) == GIF_ERROR) { #if HAVE_GIFERRORSTRING @@ -10322,13 +10350,12 @@ gif_load (struct frame *f, struct image *img) return true; gif_error: - if (pixmap) - xfree (pixmap); + xfree (pixmap); gif_close (gif, NULL); - if (cache) + if (anim_handle) { - cache->handle = NULL; - cache->temp = NULL; + anim_handle->gif = NULL; + anim_handle->pixmap = NULL; } return false; } @@ -10401,7 +10428,6 @@ webp_image_p (Lisp_Object object) /* WebP library details. */ -DEF_DLL_FN (int, WebPGetInfo, (const uint8_t *, size_t, int *, int *)); /* WebPGetFeatures is a static inline function defined in WebP's decode.h. Since we cannot use that with dynamically-loaded libwebp DLL, we instead load the internal function it calls and redirect to @@ -10412,16 +10438,16 @@ DEF_DLL_FN (uint8_t *, WebPDecodeRGBA, (const uint8_t *, size_t, int *, int *)); DEF_DLL_FN (uint8_t *, WebPDecodeRGB, (const uint8_t *, size_t, int *, int *)); DEF_DLL_FN (void, WebPFree, (void *)); DEF_DLL_FN (uint32_t, WebPDemuxGetI, (const WebPDemuxer *, WebPFormatFeature)); -DEF_DLL_FN (WebPDemuxer *, WebPDemuxInternal, - (const WebPData *, int, WebPDemuxState *, int)); -DEF_DLL_FN (void, WebPDemuxDelete, (WebPDemuxer *)); +DEF_DLL_FN (int, WebPAnimDecoderGetInfo, + (const WebPAnimDecoder* dec, WebPAnimInfo* info)); DEF_DLL_FN (int, WebPAnimDecoderGetNext, (WebPAnimDecoder *, uint8_t **, int *)); DEF_DLL_FN (WebPAnimDecoder *, WebPAnimDecoderNewInternal, (const WebPData *, const WebPAnimDecoderOptions *, int)); -DEF_DLL_FN (int, WebPAnimDecoderOptionsInitInternal, - (WebPAnimDecoderOptions *, int)); DEF_DLL_FN (int, WebPAnimDecoderHasMoreFrames, (const WebPAnimDecoder *)); +DEF_DLL_FN (void, WebPAnimDecoderReset, (WebPAnimDecoder *)); +DEF_DLL_FN (const WebPDemuxer *, WebPAnimDecoderGetDemuxer, + (const WebPAnimDecoder *)); DEF_DLL_FN (void, WebPAnimDecoderDelete, (WebPAnimDecoder *)); static bool @@ -10433,60 +10459,61 @@ init_webp_functions (void) && (library2 = w32_delayed_load (Qwebpdemux)))) return false; - LOAD_DLL_FN (library1, WebPGetInfo); LOAD_DLL_FN (library1, WebPGetFeaturesInternal); LOAD_DLL_FN (library1, WebPDecodeRGBA); LOAD_DLL_FN (library1, WebPDecodeRGB); LOAD_DLL_FN (library1, WebPFree); LOAD_DLL_FN (library2, WebPDemuxGetI); - LOAD_DLL_FN (library2, WebPDemuxInternal); - LOAD_DLL_FN (library2, WebPDemuxDelete); + LOAD_DLL_FN (library2, WebPAnimDecoderGetInfo); LOAD_DLL_FN (library2, WebPAnimDecoderGetNext); LOAD_DLL_FN (library2, WebPAnimDecoderNewInternal); - LOAD_DLL_FN (library2, WebPAnimDecoderOptionsInitInternal); LOAD_DLL_FN (library2, WebPAnimDecoderHasMoreFrames); + LOAD_DLL_FN (library2, WebPAnimDecoderReset); + LOAD_DLL_FN (library2, WebPAnimDecoderGetDemuxer); LOAD_DLL_FN (library2, WebPAnimDecoderDelete); return true; } -#undef WebPGetInfo #undef WebPGetFeatures #undef WebPDecodeRGBA #undef WebPDecodeRGB #undef WebPFree #undef WebPDemuxGetI -#undef WebPDemux -#undef WebPDemuxDelete +#undef WebPAnimDecoderGetInfo #undef WebPAnimDecoderGetNext #undef WebPAnimDecoderNew -#undef WebPAnimDecoderOptionsInit #undef WebPAnimDecoderHasMoreFrames +#undef WebPAnimDecoderReset +#undef WebPAnimDecoderGetDemuxer #undef WebPAnimDecoderDelete -#define WebPGetInfo fn_WebPGetInfo #define WebPGetFeatures(d,s,f) \ fn_WebPGetFeaturesInternal(d,s,f,WEBP_DECODER_ABI_VERSION) #define WebPDecodeRGBA fn_WebPDecodeRGBA #define WebPDecodeRGB fn_WebPDecodeRGB #define WebPFree fn_WebPFree #define WebPDemuxGetI fn_WebPDemuxGetI -#define WebPDemux(d) \ - fn_WebPDemuxInternal(d,0,NULL,WEBP_DEMUX_ABI_VERSION) -#define WebPDemuxDelete fn_WebPDemuxDelete +#define WebPAnimDecoderGetInfo fn_WebPAnimDecoderGetInfo #define WebPAnimDecoderGetNext fn_WebPAnimDecoderGetNext #define WebPAnimDecoderNew(d,o) \ fn_WebPAnimDecoderNewInternal(d,o,WEBP_DEMUX_ABI_VERSION) -#define WebPAnimDecoderOptionsInit(o) \ - fn_WebPAnimDecoderOptionsInitInternal(o,WEBP_DEMUX_ABI_VERSION) #define WebPAnimDecoderHasMoreFrames fn_WebPAnimDecoderHasMoreFrames +#define WebPAnimDecoderReset fn_WebPAnimDecoderReset +#define WebPAnimDecoderGetDemuxer fn_WebPAnimDecoderGetDemuxer #define WebPAnimDecoderDelete fn_WebPAnimDecoderDelete #endif /* WINDOWSNT */ +/* Release webp_anim_handle resources. */ static void -webp_destroy (struct anim_cache* cache) +webp_destroy (union anim_handle *handle) { - WebPAnimDecoderDelete (cache->handle); + struct webp_anim_handle *h = &handle->webp; + WebPAnimDecoderDelete (h->dec); + h->dec = NULL; + xfree (h->contents); + h->contents = NULL; + h->timestamp = 0; } /* Load WebP image IMG for use on frame F. Value is true if @@ -10495,171 +10522,228 @@ webp_destroy (struct anim_cache* cache) static bool webp_load (struct frame *f, struct image *img) { + /* Return value. */ + bool success = false; + /* Owned copies and borrowed views of input WebP bitstream data and + decoded image/frame, respectively. IOW, contents_cpy and + decoded_cpy must always be freed, and contents and decoded must + never be freed. */ + uint8_t *contents_cpy = NULL; + uint8_t const *contents = NULL; + uint8_t *decoded_cpy = NULL; + uint8_t *decoded = NULL; + + /* Non-nil :index suggests the image is animated; check the cache. */ + Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL); + struct anim_cache *cache = (NILP (image_number) ? NULL + : anim_get_animation_cache (XCDR (img->spec))); + struct webp_anim_handle *anim_handle = cache ? &cache->handle.webp : NULL; + + /* Image spec inputs. */ + Lisp_Object specified_data = Qnil; + Lisp_Object specified_file = Qnil; + /* Size of WebP contents. */ ptrdiff_t size = 0; - uint8_t *contents; - Lisp_Object file = Qnil; - int frames = 0; - double delay = 0; - WebPAnimDecoder* anim = NULL; + /* WebP features parsed from bitstream headers. */ + WebPBitstreamFeatures features = { 0 }; - /* Open the WebP file. */ - Lisp_Object specified_file = image_spec_value (img->spec, QCfile, NULL); - Lisp_Object specified_data = image_spec_value (img->spec, QCdata, NULL); - - if (NILP (specified_data)) + if (! (anim_handle && anim_handle->dec)) + /* If there is no cache entry, read in image contents. */ { - contents = (uint8_t *) slurp_image (specified_file, &size, "WebP"); - if (contents == NULL) - return false; - } - else - { - if (!STRINGP (specified_data)) + specified_data = image_spec_value (img->spec, QCdata, NULL); + if (NILP (specified_data)) + { + /* Open the WebP file. */ + specified_file = image_spec_value (img->spec, QCfile, NULL); + contents_cpy = (uint8_t *) slurp_image (specified_file, + &size, "WebP"); + if (!contents_cpy) + goto cleanup; + contents = contents_cpy; + } + else if (STRINGP (specified_data)) + { + contents = SDATA (specified_data); + size = SBYTES (specified_data); + } + else { image_invalid_data_error (specified_data); - return false; + goto cleanup; } - contents = SDATA (specified_data); - size = SBYTES (specified_data); - } - /* Validate the WebP image header. */ - if (!WebPGetInfo (contents, size, NULL, NULL)) - { - if (!NILP (file)) - image_error ("Not a WebP file: `%s'", file); - else - image_error ("Invalid header in WebP image data"); - goto webp_error1; - } - - Lisp_Object image_number = image_spec_value (img->spec, QCindex, NULL); - ptrdiff_t idx = FIXNUMP (image_number) ? XFIXNAT (image_number) : 0; - - /* Get WebP features. */ - WebPBitstreamFeatures features; - VP8StatusCode result = WebPGetFeatures (contents, size, &features); - switch (result) - { - case VP8_STATUS_OK: - break; - case VP8_STATUS_NOT_ENOUGH_DATA: - case VP8_STATUS_OUT_OF_MEMORY: - case VP8_STATUS_INVALID_PARAM: - case VP8_STATUS_BITSTREAM_ERROR: - case VP8_STATUS_UNSUPPORTED_FEATURE: - case VP8_STATUS_SUSPENDED: - case VP8_STATUS_USER_ABORT: - default: - /* Error out in all other cases. */ - if (!NILP (file)) - image_error ("Error when interpreting WebP image data: `%s'", file); - else - image_error ("Error when interpreting WebP image data"); - goto webp_error1; - } - - uint8_t *decoded = NULL; - int width, height; - - if (features.has_animation) - { - /* Animated image. */ - int timestamp; - - struct anim_cache* cache = anim_get_animation_cache (XCDR (img->spec)); - /* Get the next frame from the animation cache. */ - if (cache->handle && cache->index == idx - 1) + /* Get WebP features. This can return various error codes while + validating WebP headers, but we (currently) only distinguish + success. */ + if (WebPGetFeatures (contents, size, &features) != VP8_STATUS_OK) { - WebPAnimDecoderGetNext (cache->handle, &decoded, ×tamp); - delay = timestamp; - cache->index++; - anim = cache->handle; - width = cache->width; - height = cache->height; - frames = cache->frames; + image_error (NILP (specified_data) + ? "Error parsing WebP headers from file: `%s'" + : "Error parsing WebP headers from image data", + specified_file); + goto cleanup; + } + } + + /* Dimensions of still image or animation frame. */ + int width = -1; + int height = -1; + /* Number of animation frames. */ + int frames = -1; + /* Current animation frame's duration in ms. */ + int duration = -1; + + if ((anim_handle && anim_handle->dec) || features.has_animation) + /* Animated image. */ + { + if (!cache) + /* If the lookup was initially skipped due to the absence of an + :index, do it now. */ + { + cache = anim_get_animation_cache (XCDR (img->spec)); + anim_handle = &cache->handle.webp; + } + + if (anim_handle->dec) + /* If WebPGetFeatures was skipped, get the already parsed + features from the cached decoder. */ + { + WebPDemuxer const *dmux + = WebPAnimDecoderGetDemuxer (anim_handle->dec); + uint32_t const flags = WebPDemuxGetI (dmux, WEBP_FF_FORMAT_FLAGS); + features.has_alpha = !!(flags & ALPHA_FLAG); + features.has_animation = !!(flags & ANIMATION_FLAG); } else + /* If there was no decoder in the cache, create one now. */ { - /* Start a new cache entry. */ - if (cache->handle) - WebPAnimDecoderDelete (cache->handle); + /* If the data is from a Lisp string, copy it over so that it + doesn't get garbage-collected. If it's fresh from a file, + then another copy isn't needed to keep it alive. Either + way, ownership transfers to the anim cache which frees + memory during pruning. */ + anim_handle->contents = (STRINGP (specified_data) + ? (uint8_t *) xlispstrdup (specified_data) + : contents_cpy); + contents_cpy = NULL; + contents = anim_handle->contents; + cache->destructor = webp_destroy; - WebPData webp_data; - if (NILP (specified_data)) - /* If we got the data from a file, then we don't need to - copy the data. */ - webp_data.bytes = cache->temp = contents; - else - /* We got the data from a string, so copy it over so that - it doesn't get garbage-collected. */ + /* The WebPData docs can be interpreted as requiring it be + allocated, initialized, and cleared via its dedicated API. + However that seems to apply mostly to the mux API that we + don't use; the demux API we use treats WebPData as + read-only POD, so this should be fine. */ + WebPData const webp_data = { .bytes = contents, .size = size }; + /* We could ask for multithreaded decoding here. */ + anim_handle->dec = WebPAnimDecoderNew (&webp_data, NULL); + if (!anim_handle->dec) { - webp_data.bytes = xmalloc (size); - memcpy ((void*) webp_data.bytes, contents, size); + image_error (NILP (specified_data) + ? "Error parsing WebP file: `%s'" + : "Error parsing WebP image data", + specified_file); + goto cleanup; } - /* In any case, we release the allocated memory when we - purge the anim cache. */ - webp_data.size = size; - - /* This is used just for reporting by `image-cache-size'. */ - cache->byte_size = size; /* Get the width/height of the total image. */ - WebPDemuxer* demux = WebPDemux (&webp_data); - cache->width = width = WebPDemuxGetI (demux, WEBP_FF_CANVAS_WIDTH); - cache->height = height = WebPDemuxGetI (demux, - WEBP_FF_CANVAS_HEIGHT); - cache->frames = frames = WebPDemuxGetI (demux, WEBP_FF_FRAME_COUNT); - cache->destructor = (void (*)(void *)) webp_destroy; - WebPDemuxDelete (demux); + WebPAnimInfo info; + if (!WebPAnimDecoderGetInfo (anim_handle->dec, &info)) + { + image_error (NILP (specified_data) + ? ("Error getting global animation info " + "from WebP file: `%s'") + : ("Error getting global animation info " + "from WebP image data"), + specified_file); + goto cleanup; + } - WebPAnimDecoderOptions dec_options; - WebPAnimDecoderOptionsInit (&dec_options); - anim = WebPAnimDecoderNew (&webp_data, &dec_options); + /* Other libwebp[demux] APIs (and WebPAnimInfo internally) + store these values as int, so this should be safe. */ + cache->width = info.canvas_width; + cache->height = info.canvas_height; + cache->frames = info.frame_count; + /* This is used just for reporting by `image-cache-size'. */ + cache->byte_size = size; + } - cache->handle = anim; - cache->index = idx; + width = cache->width; + height = cache->height; + frames = cache->frames; - while (WebPAnimDecoderHasMoreFrames (anim)) { - WebPAnimDecoderGetNext (anim, &decoded, ×tamp); - /* Each frame has its own delay, but we don't really support - that. So just use the delay from the first frame. */ - if (delay == 0) - delay = timestamp; - /* Stop when we get to the desired index. */ - if (idx-- == 0) - break; - } + /* Desired frame number. */ + EMACS_INT idx = (FIXNUMP (image_number) + ? min (XFIXNAT (image_number), frames) : 0); + if (cache->index >= idx) + /* The decoder cannot rewind (nor be queried for the last + frame's decoded pixels and timestamp), so restart from + the first frame. We could avoid restarting when + cache->index == idx by adding more fields to + webp_anim_handle, but it may not be worth it. */ + { + WebPAnimDecoderReset (anim_handle->dec); + anim_handle->timestamp = 0; + cache->index = -1; + } + + /* Decode until desired frame number. */ + for (; + (cache->index < idx + && WebPAnimDecoderHasMoreFrames (anim_handle->dec)); + cache->index++) + { + int timestamp; + if (!WebPAnimDecoderGetNext (anim_handle->dec, &decoded, ×tamp)) + { + image_error (NILP (specified_data) + ? "Error decoding frame #%d from WebP file: `%s'" + : "Error decoding frame #%d from WebP image data", + cache->index + 1, specified_file); + goto cleanup; + } + eassert (anim_handle->timestamp >= 0); + eassert (timestamp >= anim_handle->timestamp); + duration = timestamp - anim_handle->timestamp; + anim_handle->timestamp = timestamp; } } else + /* Non-animated image. */ { - /* Non-animated image. */ + /* Could performance be improved by using the 'advanced' + WebPDecoderConfig API to request scaling/cropping as + appropriate for Emacs frame and image dimensions, + similarly to the SVG code? */ if (features.has_alpha) /* Linear [r0, g0, b0, a0, r1, g1, b1, a1, ...] order. */ - decoded = WebPDecodeRGBA (contents, size, &width, &height); + decoded_cpy = WebPDecodeRGBA (contents, size, &width, &height); else /* Linear [r0, g0, b0, r1, g1, b1, ...] order. */ - decoded = WebPDecodeRGB (contents, size, &width, &height); + decoded_cpy = WebPDecodeRGB (contents, size, &width, &height); + decoded = decoded_cpy; } if (!decoded) { - image_error ("Error when decoding WebP image data"); - goto webp_error1; + image_error (NILP (specified_data) + ? "Error decoding WebP file: `%s'" + : "Error decoding WebP image data", + specified_file); + goto cleanup; } if (!(width <= INT_MAX && height <= INT_MAX && check_image_size (f, width, height))) { image_size_error (); - goto webp_error2; + goto cleanup; } /* Create the x image and pixmap. */ Emacs_Pix_Container ximg; if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, false)) - goto webp_error2; + goto cleanup; /* Find the background to use if the WebP image contains an alpha channel. */ @@ -10696,7 +10780,7 @@ webp_load (struct frame *f, struct image *img) img->corners[RIGHT_CORNER] = img->corners[LEFT_CORNER] + width; - uint8_t *p = decoded; + uint8_t const *p = decoded; for (int y = 0; y < height; ++y) { for (int x = 0; x < width; ++x) @@ -10704,7 +10788,7 @@ webp_load (struct frame *f, struct image *img) int r, g, b; /* The WebP alpha channel allows 256 levels of partial transparency. Blend it with the background manually. */ - if (features.has_alpha || anim) + if (features.has_alpha || features.has_animation) { float a = (float) p[3] / UINT8_MAX; r = (int)(a * p[0] + (1 - a) * bg_color.red) << 8; @@ -10734,29 +10818,31 @@ webp_load (struct frame *f, struct image *img) img->width = width; img->height = height; - /* Return animation data. */ - img->lisp_data = Fcons (Qcount, - Fcons (make_fixnum (frames), - img->lisp_data)); - img->lisp_data = Fcons (Qdelay, - Fcons (make_float (delay / 1000), - img->lisp_data)); + if (features.has_animation) + /* Return animation metadata. */ + { + eassert (frames > 0); + eassert (duration >= 0); + img->lisp_data = Fcons (Qcount, + Fcons (make_fixnum (frames), + img->lisp_data)); + /* WebP spec: interpretation of no/small frame duration is + implementation-defined. In practice browsers and libwebp tools + map small durations to 100ms to protect against annoying + images. For consistency across image types and user + configurability, we return a non-nil nonnumeric value that + image-multi-frame-p turns into image-default-frame-delay. */ + img->lisp_data + = Fcons (Qdelay, + Fcons (duration ? make_float (duration / 1000.0) : Qt, + img->lisp_data)); + } - /* Clean up. */ - if (!anim) - WebPFree (decoded); - if (NILP (specified_data) && !anim) - xfree (contents); - return true; - - webp_error2: - if (!anim) - WebPFree (decoded); - - webp_error1: - if (NILP (specified_data)) - xfree (contents); - return false; + success = true; + cleanup: + WebPFree (decoded_cpy); + xfree (contents_cpy); + return success; } #endif /* HAVE_WEBP */ @@ -10817,15 +10903,6 @@ static struct image_keyword imagemagick_format[IMAGEMAGICK_LAST] = {":crop", IMAGE_DONT_CHECK_VALUE_TYPE, 0} }; -/* Free X resources of imagemagick image IMG which is used on frame F. */ - -static void -imagemagick_clear_image (struct frame *f, - struct image *img) -{ - image_clear_image (f, img); -} - /* Return true if OBJECT is a valid IMAGEMAGICK image specification. Do this by calling parse_image_spec and supplying the keywords that identify the IMAGEMAGICK format. */ @@ -10915,7 +10992,7 @@ imagemagick_filename_hint (Lisp_Object spec, char hint_buffer[MaxTextExtent]) } /* Animated images (e.g., GIF89a) are composed from one "master image" - (which is the first one, and then there's a number of images that + (which is the first one), and then there's a number of images that follow. If following images have non-transparent colors, these are composed "on top" of the master image. So, in general, one has to compute all the preceding images to be able to display a particular @@ -10924,7 +11001,10 @@ imagemagick_filename_hint (Lisp_Object spec, char hint_buffer[MaxTextExtent]) Computing all the preceding images is too slow, so we maintain a cache of previously computed images. We have to maintain a cache separate from the image cache, because the images may be scaled - before display. */ + before display. + + FIXME: Consolidate this with the GIF and WebP anim_cache. + Not just for DRY, but for Fclear_image_cache too. */ struct animation_cache { @@ -12800,7 +12880,7 @@ DEFUN ("image-cache-size", Fimage_cache_size, Simage_cache_size, 0, 0, 0, (void) { Lisp_Object tail, frame; - size_t total = 0; + intmax_t total = 0; FOR_EACH_FRAME (tail, frame) if (FRAME_WINDOW_P (XFRAME (frame))) @@ -12845,7 +12925,7 @@ initialize_image_type (struct image_type const *type) Lisp_Object tested = Fassq (typesym, Vlibrary_cache); /* If we failed to load the library before, don't try again. */ if (CONSP (tested)) - return !NILP (XCDR (tested)) ? true : false; + return !NILP (XCDR (tested)); bool (*init) (void) = type->init; if (init) @@ -12868,7 +12948,7 @@ static struct image_type const image_types[] = #endif #ifdef HAVE_IMAGEMAGICK { SYMBOL_INDEX (Qimagemagick), imagemagick_image_p, imagemagick_load, - imagemagick_clear_image }, + image_clear_image }, #endif #ifdef HAVE_RSVG { SYMBOL_INDEX (Qsvg), svg_image_p, svg_load, image_clear_image, @@ -12879,7 +12959,7 @@ static struct image_type const image_types[] = IMAGE_TYPE_INIT (init_png_functions) }, #endif #if defined HAVE_GIF - { SYMBOL_INDEX (Qgif), gif_image_p, gif_load, gif_clear_image, + { SYMBOL_INDEX (Qgif), gif_image_p, gif_load, image_clear_image, IMAGE_TYPE_INIT (init_gif_functions) }, #endif #if defined HAVE_TIFF @@ -12909,8 +12989,8 @@ static struct image_type native_image_type = image_clear_image }; #endif -/* Look up image type TYPE, and return a pointer to its image_type - structure. Return 0 if TYPE is not a known image type. */ +/* Look up image TYPE, and return a pointer to its image_type structure. + Return a null pointer if TYPE is not a known image type. */ static struct image_type const * lookup_image_type (Lisp_Object type) @@ -12929,11 +13009,12 @@ lookup_image_type (Lisp_Object type) return NULL; } -/* Prune the animation caches. If CLEAR, remove all animation cache - entries. */ +/* Prune old entries from the animation cache. + If CLEAR, remove all animation cache entries. */ void image_prune_animation_caches (bool clear) { + /* FIXME: Consolidate these animation cache implementations. */ #if defined (HAVE_WEBP) || defined (HAVE_GIF) anim_prune_animation_cache (clear? Qt: Qnil); #endif @@ -13085,11 +13166,18 @@ non-numeric, there is no explicit limit on the size of images. */); #if defined (HAVE_WEBP) \ || (defined (HAVE_NATIVE_IMAGE_API) \ - && ((defined (HAVE_NS) && defined (NS_IMPL_COCOA)) \ - || defined (HAVE_HAIKU))) + && (defined (HAVE_NS) || defined (HAVE_HAIKU))) DEFSYM (Qwebp, "webp"); DEFSYM (Qwebpdemux, "webpdemux"); +#if !defined (NS_IMPL_GNUSTEP) || defined (HAVE_WEBP) add_image_type (Qwebp); +#else + + /* On GNUstep, WEBP support is provided via ImageMagick only if + gnustep-gui is built with --enable-imagemagick. */ + if (image_can_use_native_api (Qwebp)) + add_image_type (Qwebp); +#endif /* NS_IMPL_GNUSTEP && !HAVE_WEBP */ #endif #if defined (HAVE_IMAGEMAGICK) @@ -13112,18 +13200,27 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (Qgobject, "gobject"); #endif /* HAVE_NTGUI */ #elif defined HAVE_NATIVE_IMAGE_API \ - && ((defined HAVE_NS && defined NS_IMPL_COCOA) \ - || defined HAVE_HAIKU) + && (defined HAVE_NS || defined HAVE_HAIKU) DEFSYM (Qsvg, "svg"); - /* On Haiku, the SVG translator may not be installed. */ + /* On Haiku, the SVG translator may not be installed. On GNUstep, SVG + support is provided by ImageMagick so not guaranteed. Furthermore, + some distros (e.g., Debian) ship ImageMagick's SVG module in a + separate binary package which may not be installed. */ if (image_can_use_native_api (Qsvg)) add_image_type (Qsvg); #endif #ifdef HAVE_NS DEFSYM (Qheic, "heic"); +#ifdef NS_IMPL_COCOA add_image_type (Qheic); +#else + + /* HEIC support in gnustep-gui is provided by ImageMagick. */ + if (image_can_use_native_api (Qheic)) + add_image_type (Qheic); +#endif /* NS_IMPL_GNUSTEP */ #endif #if HAVE_NATIVE_IMAGE_API @@ -13159,7 +13256,6 @@ non-numeric, there is no explicit limit on the size of images. */); DEFSYM (QCanimate_buffer, ":animate-buffer"); DEFSYM (QCanimate_tardiness, ":animate-tardiness"); DEFSYM (QCanimate_position, ":animate-position"); - DEFSYM (QCanimate_multi_frame_data, ":animate-multi-frame-data"); defsubr (&Simage_transforms_p); diff --git a/src/indent.c b/src/indent.c index 427350020fd..9721c95dcf7 100644 --- a/src/indent.c +++ b/src/indent.c @@ -2506,7 +2506,11 @@ buffer, whether or not it is currently displayed in some window. */) an addition to the hscroll amount. */ if (!NILP (lcols)) { - if (it.method == GET_FROM_STRING && !NILP (it.from_overlay)) + /* Start at beginning of line if inside an overlay string, to + avoid becoming stuck at the beginning of the overlay string. */ + if (it.continuation_lines_width <= 0 /* not in continuation line */ + && it.hpos > 0 /* and not at BOL */ + && it.method == GET_FROM_STRING && !NILP (it.from_overlay)) reseat_at_previous_visible_line_start(&it); move_it_in_display_line (&it, ZV, first_x + to_x, MOVE_TO_X); diff --git a/src/keyboard.c b/src/keyboard.c index 35de83ddb50..c848351ea35 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1806,7 +1806,8 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) TEXT_PROP_MEANS_INVISIBLE (val)) #endif && !NILP (val = get_char_property_and_overlay - (make_fixnum (end), Qinvisible, Qnil, &overlay)) + (make_fixnum (end), Qinvisible, + selected_window, &overlay)) && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) { ellipsis = ellipsis || inv > 1 @@ -1824,7 +1825,8 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) TEXT_PROP_MEANS_INVISIBLE (val)) #endif && !NILP (val = get_char_property_and_overlay - (make_fixnum (beg - 1), Qinvisible, Qnil, &overlay)) + (make_fixnum (beg - 1), Qinvisible, + selected_window, &overlay)) && (inv = TEXT_PROP_MEANS_INVISIBLE (val))) { ellipsis = ellipsis || inv > 1 @@ -1891,11 +1893,11 @@ adjust_point_for_property (ptrdiff_t last_pt, bool modified) could lead to an infinite loop. */ ; else if (val = Fget_pos_property (make_fixnum (PT), - Qinvisible, Qnil), + Qinvisible, selected_window), TEXT_PROP_MEANS_INVISIBLE (val) && (val = (Fget_pos_property (make_fixnum (PT == beg ? end : beg), - Qinvisible, Qnil)), + Qinvisible, selected_window)), !TEXT_PROP_MEANS_INVISIBLE (val))) (check_composition = check_display = true, SET_PT (PT == beg ? end : beg)); @@ -10166,6 +10168,13 @@ read_char_x_menu_prompt (Lisp_Object map, return Qnil ; } +static Lisp_Object +follow_key (Lisp_Object keymap, Lisp_Object key) +{ + return access_keymap (get_keymap (keymap, 0, 1), + key, 1, 0, 1); +} + static Lisp_Object read_char_minibuf_menu_prompt (int commandflag, Lisp_Object map) @@ -10377,7 +10386,10 @@ read_char_minibuf_menu_prompt (int commandflag, if (!FIXNUMP (obj) || XFIXNUM (obj) == -2 || (! EQ (obj, menu_prompt_more_char) && (!FIXNUMP (menu_prompt_more_char) - || ! BASE_EQ (obj, make_fixnum (Ctl (XFIXNUM (menu_prompt_more_char))))))) + || ! BASE_EQ (obj, make_fixnum (Ctl (XFIXNUM (menu_prompt_more_char)))))) + /* If 'menu_prompt_more_char' collides with a binding in the + map, gives precedence to the map's binding (bug#80146). */ + || !NILP (follow_key (map, obj))) { if (!NILP (KVAR (current_kboard, defining_kbd_macro))) store_kbd_macro_char (obj); @@ -10389,13 +10401,6 @@ read_char_minibuf_menu_prompt (int commandflag, /* Reading key sequences. */ -static Lisp_Object -follow_key (Lisp_Object keymap, Lisp_Object key) -{ - return access_keymap (get_keymap (keymap, 0, 1), - key, 1, 0, 1); -} - static Lisp_Object active_maps (Lisp_Object first_event, Lisp_Object second_event) { @@ -12533,7 +12538,7 @@ set_waiting_for_input (struct timespec *time_to_clear) { input_available_clear_time = time_to_clear; - /* Tell handle_interrupt to throw back to read_char, */ + /* Tell handle_interrupt to throw back to read_char. */ waiting_for_input = true; /* If handle_interrupt was called before and buffered a C-g, @@ -12941,7 +12946,8 @@ See also `current-input-mode'. */) error ("QUIT must be an ASCII character"); #ifndef DOS_NT - /* this causes startup screen to be restored and messes with the mouse */ + /* This causes startup screen to be restored and messes with the + mouse. */ reset_sys_modes (tty); #endif diff --git a/src/lisp.h b/src/lisp.h index 4b099431ab6..a378fe13ce3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4581,6 +4581,7 @@ extern Lisp_Object nconc2 (Lisp_Object, Lisp_Object); extern Lisp_Object assq_no_quit (Lisp_Object, Lisp_Object); extern Lisp_Object assq_no_signal (Lisp_Object, Lisp_Object); extern Lisp_Object assoc_no_quit (Lisp_Object, Lisp_Object); +extern Lisp_Object delq_no_quit (Lisp_Object, Lisp_Object); extern ptrdiff_t string_char_to_byte (Lisp_Object, ptrdiff_t); extern ptrdiff_t string_byte_to_char (Lisp_Object, ptrdiff_t); extern Lisp_Object string_to_multibyte (Lisp_Object); diff --git a/src/lread.c b/src/lread.c index ac303ce5db1..53ae5db383e 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2382,7 +2382,7 @@ variable and any -*- lexical-binding: t -*- settings in the buffer; if there is no such setting, and the buffer-local value of the variable is nil, the buffer will be -evaluated with the value of `lexical binding' equal to its +evaluated with the value of `lexical-binding' equal to its top-level default value, as returned by `default-toplevel-value'. This function preserves the position of point. */) diff --git a/src/nsfns.m b/src/nsfns.m index 2c63eec83b6..6992eaa74ce 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -1262,6 +1262,8 @@ Turn the input menu (an NSMenu) into a lisp list for tracking on lisp side. XSETFRAME (frame, f); + frame_set_id_from_params (f, parms); + f->terminal = dpyinfo->terminal; f->output_method = output_ns; @@ -3480,16 +3482,17 @@ ATTRIBUTES return the outer edges of FRAME (Qouter_edges), the inner || EQ (fullscreen_symbol, Qfullscreen)); int border = fullscreen ? 0 : f->border_width; int title_height = fullscreen ? 0 : FRAME_NS_TITLEBAR_HEIGHT (f); + int tool_bar_height = FRAME_TOOLBAR_HEIGHT (f); int native_width = FRAME_PIXEL_WIDTH (f); int native_height = FRAME_PIXEL_HEIGHT (f); int outer_width = native_width + 2 * border; - int outer_height = native_height + 2 * border + title_height; + int outer_height + = native_height + 2 * border + title_height + tool_bar_height; int native_left = f->left_pos + border; int native_top = f->top_pos + border + title_height; int native_right = f->left_pos + outer_width - border; int native_bottom = f->top_pos + outer_height - border; int internal_border_width = FRAME_INTERNAL_BORDER_WIDTH (f); - int tool_bar_height = FRAME_TOOLBAR_HEIGHT (f); int tool_bar_width = (tool_bar_height ? outer_width - 2 * internal_border_width : 0); diff --git a/src/nsimage.m b/src/nsimage.m index 3c318c37cfd..426ce20eb05 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -102,6 +102,16 @@ Updated by Christian Limpach (chris@nice.ch) imageType = @"gif"; else if (EQ (type, Qtiff)) imageType = @"tiff"; +#ifndef HAVE_RSVG + else if (EQ (type, Qsvg)) + imageType = @"svg"; +#endif +#ifndef HAVE_WEBP + else if (EQ (type, Qwebp)) + imageType = @"webp"; +#endif + else if (EQ (type, Qheic)) + imageType = @"heic"; types = [NSImage imageFileTypes]; #endif diff --git a/src/nsterm.h b/src/nsterm.h index aae94a0ab26..6229feff3d7 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -279,7 +279,7 @@ char const * nstrace_fullscreen_type_name (int); #define NSTRACE_WHEN(cond, ...) \ __attribute__ ((cleanup (nstrace_restore_global_trace_state))) \ - int nstrace_saved_enabled_global = nstrace_enabled_global; \ + int __attribute__ ((unused)) nstrace_saved_enabled_global = nstrace_enabled_global;\ __attribute__ ((cleanup (nstrace_leave))) \ int nstrace_enabled = nstrace_enabled_global && (cond); \ if (nstrace_enabled) { ++nstrace_depth; } \ diff --git a/src/nsterm.m b/src/nsterm.m index 2b2b41273fb..cc44c58a938 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -1227,7 +1227,7 @@ - (id)init { nestCount = 0; isAttached = false; -#ifdef NS_IMPL_GNUSTEP +#if NS_IMPL_GNUSTEP && !HAVE_DECL_NSIMAGENAMECAUTION // GNUstep doesn't provide named images. This was reported in // 2011, see https://savannah.gnu.org/bugs/?33396 // @@ -5072,18 +5072,14 @@ Function modeled after x_draw_glyph_string_box (). if (writefds && FD_ISSET(k, writefds)) ++nr; } - /* emacs -nw doesn't have an NSApp, so we're done. */ - if (NSApp == nil) - return thread_select (pselect, nfds, readfds, writefds, exceptfds, - timeout, sigmask); - - if (![NSThread isMainThread] + if (NSApp == nil + || ![NSThread isMainThread] || (timeout && timeout->tv_sec == 0 && timeout->tv_nsec == 0)) - thread_select (pselect, nfds, readfds, writefds, - exceptfds, timeout, sigmask); + return thread_select (pselect, nfds, readfds, writefds, + exceptfds, timeout, sigmask); else { - struct timespec t = {0, 0}; + struct timespec t = {0, 1}; thread_select (pselect, 0, NULL, NULL, NULL, &t, sigmask); } @@ -7070,8 +7066,8 @@ - (void)resetCursorRects [self addCursorRect: visible cursor: currentCursor]; #if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 -#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 - if ([currentCursor respondsToSelector: @selector(setOnMouseEntered)]) +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 + if ([currentCursor respondsToSelector: @selector(setOnMouseEntered:)]) #endif [currentCursor setOnMouseEntered: YES]; #endif @@ -10585,9 +10581,9 @@ - (void)resetCursorRects [self addCursorRect: visible cursor: [NSCursor arrowCursor]]; #if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 -#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 if ([[NSCursor arrowCursor] respondsToSelector: - @selector(setOnMouseEntered)]) + @selector(setOnMouseEntered:)]) #endif [[NSCursor arrowCursor] setOnMouseEntered: YES]; #endif @@ -11425,7 +11421,11 @@ Convert an X font name (XLFD) to an NS font name. Each SYMBOL is `control', `meta', `alt', `super', `hyper' or `none'. If `none', the key is ignored by Emacs and retains its standard meaning. */); +#ifdef NS_IMPL_COCOA ns_command_modifier = Qsuper; +#else + ns_command_modifier = Qmeta; +#endif DEFVAR_LISP ("ns-right-command-modifier", ns_right_command_modifier, doc: /* This variable describes the behavior of the right command key. diff --git a/src/pdumper.c b/src/pdumper.c index 337fb63b526..f5b646d175f 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2902,9 +2902,13 @@ dump_obarray (struct dump_context *ctx, Lisp_Object object) static dump_off dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) { -#if CHECK_STRUCTS && !defined HASH_buffer_text_07D802E2D4 +#if CHECK_STRUCTS && !defined HASH_buffer_46DA92A241 # error "buffer changed. See CHECK_STRUCTS comment in config.h." #endif +#if CHECK_STRUCTS && !defined HASH_buffer_text_07D802E2D4 +# error "buffer_text changed. See CHECK_STRUCTS comment in config.h." +#endif + struct buffer munged_buffer = *in_buffer; struct buffer *buffer = &munged_buffer; @@ -6041,11 +6045,25 @@ pdumper_set_emacs_execdir (char *emacs_executable) && !IS_DIRECTORY_SEP (p[-1])) --p; eassert (p > emacs_executable); - emacs_execdir = xpalloc (emacs_execdir, &execdir_size, - p - emacs_executable + 1 - execdir_size, -1, 1); - memcpy (emacs_execdir, emacs_executable, p - emacs_executable); - execdir_len = p - emacs_executable; - emacs_execdir[execdir_len] = '\0'; + +#if HAVE_NS && !NS_SELF_CONTAINED + if (strcmp (p, "Emacs") == 0) + { + /* This is the Emacs executable from the non-self-contained app + bundle which can be anywhere on the system. Fortunately, the + location of the Lisp resources is known. */ + emacs_execdir = (char *) BINDIR; + execdir_len = strlen (BINDIR); + } + else +#endif + { + emacs_execdir = xpalloc (emacs_execdir, &execdir_size, + p - emacs_executable + 1 - execdir_size, -1, 1); + memcpy (emacs_execdir, emacs_executable, p - emacs_executable); + execdir_len = p - emacs_executable; + emacs_execdir[execdir_len] = '\0'; + } } #endif diff --git a/src/pgtkfns.c b/src/pgtkfns.c index 74dca25adfc..6797e63b6d9 100644 --- a/src/pgtkfns.c +++ b/src/pgtkfns.c @@ -1283,6 +1283,8 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, 1, 1, 0, XSETFRAME (frame, f); + frame_set_id_from_params (f, parms); + f->terminal = dpyinfo->terminal; f->output_method = output_pgtk; diff --git a/src/treesit.c b/src/treesit.c index ae73885e71d..231da968fe1 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -81,11 +81,11 @@ along with GNU Emacs. If not, see . */ #undef ts_query_predicates_for_pattern #undef ts_query_string_value_for_id #undef ts_set_allocator -#undef ts_tree_cursor_copy #undef ts_tree_cursor_current_node #undef ts_tree_cursor_delete #undef ts_tree_cursor_goto_first_child #undef ts_tree_cursor_goto_first_child_for_byte +#undef ts_tree_cursor_goto_previous_sibling #undef ts_tree_cursor_goto_next_sibling #undef ts_tree_cursor_goto_parent #undef ts_tree_cursor_new @@ -153,12 +153,12 @@ DEF_DLL_FN (const char *, ts_query_string_value_for_id, (const TSQuery *, uint32_t, uint32_t *)); DEF_DLL_FN (void, ts_set_allocator, (void *(*)(size_t), void *(*)(size_t, size_t), void *(*)(void *, size_t), void (*)(void *))); -DEF_DLL_FN (TSTreeCursor, ts_tree_cursor_copy, (const TSTreeCursor *)); DEF_DLL_FN (TSNode, ts_tree_cursor_current_node, (const TSTreeCursor *)); DEF_DLL_FN (void, ts_tree_cursor_delete, (const TSTreeCursor *)); DEF_DLL_FN (bool, ts_tree_cursor_goto_first_child, (TSTreeCursor *)); DEF_DLL_FN (int64_t, ts_tree_cursor_goto_first_child_for_byte, (TSTreeCursor *, uint32_t)); DEF_DLL_FN (bool, ts_tree_cursor_goto_next_sibling, (TSTreeCursor *)); +DEF_DLL_FN (bool, ts_tree_cursor_goto_previous_sibling, (TSTreeCursor *)); DEF_DLL_FN (bool, ts_tree_cursor_goto_parent, (TSTreeCursor *)); DEF_DLL_FN (TSTreeCursor, ts_tree_cursor_new, (TSNode)); DEF_DLL_FN (void, ts_tree_delete, (TSTree *)); @@ -221,12 +221,12 @@ init_treesit_functions (void) LOAD_DLL_FN (library, ts_query_predicates_for_pattern); LOAD_DLL_FN (library, ts_query_string_value_for_id); LOAD_DLL_FN (library, ts_set_allocator); - LOAD_DLL_FN (library, ts_tree_cursor_copy); LOAD_DLL_FN (library, ts_tree_cursor_current_node); LOAD_DLL_FN (library, ts_tree_cursor_delete); LOAD_DLL_FN (library, ts_tree_cursor_goto_first_child); LOAD_DLL_FN (library, ts_tree_cursor_goto_first_child_for_byte); LOAD_DLL_FN (library, ts_tree_cursor_goto_next_sibling); + LOAD_DLL_FN (library, ts_tree_cursor_goto_previous_sibling); LOAD_DLL_FN (library, ts_tree_cursor_goto_parent); LOAD_DLL_FN (library, ts_tree_cursor_new); LOAD_DLL_FN (library, ts_tree_delete); @@ -283,12 +283,12 @@ init_treesit_functions (void) #define ts_query_predicates_for_pattern fn_ts_query_predicates_for_pattern #define ts_query_string_value_for_id fn_ts_query_string_value_for_id #define ts_set_allocator fn_ts_set_allocator -#define ts_tree_cursor_copy fn_ts_tree_cursor_copy #define ts_tree_cursor_current_node fn_ts_tree_cursor_current_node #define ts_tree_cursor_delete fn_ts_tree_cursor_delete #define ts_tree_cursor_goto_first_child fn_ts_tree_cursor_goto_first_child #define ts_tree_cursor_goto_first_child_for_byte fn_ts_tree_cursor_goto_first_child_for_byte #define ts_tree_cursor_goto_next_sibling fn_ts_tree_cursor_goto_next_sibling +#define ts_tree_cursor_goto_previous_sibling fn_ts_tree_cursor_goto_previous_sibling #define ts_tree_cursor_goto_parent fn_ts_tree_cursor_goto_parent #define ts_tree_cursor_new fn_ts_tree_cursor_new #define ts_tree_delete fn_ts_tree_delete @@ -4278,50 +4278,14 @@ treesit_traverse_sibling_helper (TSTreeCursor *cursor, } else /* Backward. */ { - /* Go to first child and go through each sibling, until we find - the one just before the starting node. */ - TSNode start = ts_tree_cursor_current_node (cursor); - if (!ts_tree_cursor_goto_parent (cursor)) - return false; - treesit_assume_true (ts_tree_cursor_goto_first_child (cursor)); - - /* Now CURSOR is at the first child. If we started at the first - child, then there is no further siblings. */ - TSNode first_child = ts_tree_cursor_current_node (cursor); - if (ts_node_eq (first_child, start)) - return false; - - /* PROBE is always DELTA siblings ahead of CURSOR. */ - TSTreeCursor probe = ts_tree_cursor_copy (cursor); - /* This is position of PROBE minus position of CURSOR. */ - ptrdiff_t delta = 0; - TSNode probe_node; - TSNode cursor_node; - while (ts_tree_cursor_goto_next_sibling (&probe)) + if (!named) + return ts_tree_cursor_goto_previous_sibling (cursor); + /* Else named... */ + while (ts_tree_cursor_goto_previous_sibling (cursor)) { - /* Move PROBE forward, if it equals to the starting node, - CURSOR points to the node we want (prev valid sibling of - the starting node). */ - delta++; - probe_node = ts_tree_cursor_current_node (&probe); - - /* PROBE matched, depending on NAMED, return true/false. */ - if (ts_node_eq (probe_node, start)) - { - ts_tree_cursor_delete (&probe); - cursor_node = ts_tree_cursor_current_node (cursor); - ts_tree_cursor_delete (&probe); - return (!named || (named && ts_node_is_named (cursor_node))); - } - - /* PROBE didn't match, move CURSOR forward to PROBE's - position, but if we are looking for named nodes, only - move CURSOR to PROBE if PROBE is at a named node. */ - if (!named || (named && ts_node_is_named (probe_node))) - for (; delta > 0; delta--) - treesit_assume_true (ts_tree_cursor_goto_next_sibling (cursor)); + if (ts_node_is_named (ts_tree_cursor_current_node (cursor))) + return true; } - ts_tree_cursor_delete (&probe); return false; } } diff --git a/src/w32.c b/src/w32.c index 2735fc6fcdb..8409656a7b7 100644 --- a/src/w32.c +++ b/src/w32.c @@ -84,10 +84,6 @@ int sys_dup2 (int, int); int sys_read (int, char *, unsigned int); int sys_write (int, const void *, unsigned int); struct tm *sys_localtime (const time_t *); -/* MinGW64 system headers include string.h too early, causing the - compiler to emit a warning about sys_strerror having no - prototype. */ -char *sys_strerror (int); clock_t sys_clock (void); #ifdef HAVE_MODULES diff --git a/src/w32fns.c b/src/w32fns.c index de62e4e12f1..7fd7ce2eea8 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -6326,6 +6326,8 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, XSETFRAME (frame, f); + frame_set_id_from_params (f, parameters); + parent_frame = gui_display_get_arg (dpyinfo, parameters, Qparent_frame, NULL, NULL, RES_TYPE_SYMBOL); diff --git a/src/window.c b/src/window.c index 03668e54321..4e2a2f631a1 100644 --- a/src/window.c +++ b/src/window.c @@ -5913,11 +5913,11 @@ resize_mini_window_apply (struct window *w, int delta) * line of text. */ void -grow_mini_window (struct window *w, int delta) +grow_mini_window (struct window *w, int delta, int unit) { struct frame *f = XFRAME (w->frame); int old_height = window_body_height (w, WINDOW_BODY_IN_PIXELS); - int min_height = FRAME_LINE_HEIGHT (f); + int min_height = unit; eassert (MINI_WINDOW_P (w)); @@ -5945,7 +5945,7 @@ grow_mini_window (struct window *w, int delta) resize_mini_window_apply (w, -XFIXNUM (grow)); } FRAME_WINDOWS_FROZEN (f) - = window_body_height (w, WINDOW_BODY_IN_PIXELS) > FRAME_LINE_HEIGHT (f); + = window_body_height (w, WINDOW_BODY_IN_PIXELS) > unit; } /** @@ -5955,11 +5955,10 @@ grow_mini_window (struct window *w, int delta) * line of text. */ void -shrink_mini_window (struct window *w) +shrink_mini_window (struct window *w, int unit) { struct frame *f = XFRAME (w->frame); - int delta = (window_body_height (w, WINDOW_BODY_IN_PIXELS) - - FRAME_LINE_HEIGHT (f)); + int delta = (window_body_height (w, WINDOW_BODY_IN_PIXELS) - unit); eassert (MINI_WINDOW_P (w)); @@ -5978,10 +5977,10 @@ shrink_mini_window (struct window *w) else if (delta < 0) /* delta can be less than zero after adding horizontal scroll bar. */ - grow_mini_window (w, -delta); + grow_mini_window (w, -delta, unit); FRAME_WINDOWS_FROZEN (f) - = window_body_height (w, WINDOW_BODY_IN_PIXELS) > FRAME_LINE_HEIGHT (f); + = window_body_height (w, WINDOW_BODY_IN_PIXELS) > unit; } DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal, @@ -8665,6 +8664,67 @@ WINDOW must be a live window and defaults to the selected one. */) return decode_live_window (window)->cursor_type; } +DEFUN ("window-cursor-info", Fwindow_cursor_info, Swindow_cursor_info, + 0, 1, 0, + doc: /* Return information about the cursor of WINDOW. +WINDOW must be a live window and defaults to the selected one. + +The returned value is a vector of 6 elements: + [TYPE X Y WIDTH HEIGHT ASCENT] +where + TYPE is the symbol representing the type of the cursor. See + `cursor-type' for the meaning of the value. + X and Y are pixel coordinates of the cursor's top-left corner, relative + to the top-left corner of WINDOW's text area. + WIDTH and HEIGHT are the pixel dimensions of the cursor. + ASCENT is the number of pixels the cursor extends above the baseline. + +If the cursor is not currently displayed for WINDOW, return nil. + +Note that any element except the first one in the returned vector may be +-1 if the actual value is currently unavailable. */) + (Lisp_Object window) +{ + struct window *w = decode_live_window (window); + + if (!w->phys_cursor_on_p) + return Qnil; + + /* Default values for TTY frames. */ + int phys_cursor_width = 1, phys_cursor_height = 1, phys_cursor_ascent = 1; + +#ifdef HAVE_WINDOW_SYSTEM + struct frame *f = XFRAME (WINDOW_FRAME (w)); + struct glyph *phys_cursor_glyph = get_phys_cursor_glyph (w); + + if (FRAME_WINDOW_P (f)) + { + phys_cursor_width = w->phys_cursor_width; + phys_cursor_height = w->phys_cursor_height; + phys_cursor_ascent = w->phys_cursor_ascent; + } + + /* If on a stretch glyph, and `x-stretch-cursor' is nil, use the + canonical character width instead, except for (H)BAR cursors. + This mimics what the various *term.c backends do in their + *_draw_stretch_glyph methods. */ + if (phys_cursor_glyph + && phys_cursor_glyph->type == STRETCH_GLYPH + && !(w->phys_cursor_type == BAR_CURSOR + || w->phys_cursor_type == HBAR_CURSOR) + && !x_stretch_cursor_p) + phys_cursor_width = min (FRAME_COLUMN_WIDTH (f), phys_cursor_width); +#endif + + return CALLN (Fvector, + w->cursor_type, + make_fixnum (w->phys_cursor.x), + make_fixnum (w->phys_cursor.y), + make_fixnum (phys_cursor_width), + make_fixnum (phys_cursor_height), + make_fixnum (phys_cursor_ascent)); +} + /*********************************************************************** Scroll bars @@ -9636,5 +9696,6 @@ name to `'ignore'. */); defsubr (&Sset_window_parameter); defsubr (&Swindow_discard_buffer); defsubr (&Swindow_cursor_type); + defsubr (&Swindow_cursor_info); defsubr (&Sset_window_cursor_type); } diff --git a/src/window.h b/src/window.h index 70e1b74cfdf..86b5ac3b022 100644 --- a/src/window.h +++ b/src/window.h @@ -1126,8 +1126,8 @@ extern Lisp_Object window_from_coordinates (struct frame *, int, int, extern void resize_frame_windows (struct frame *, int, bool); extern void restore_window_configuration (Lisp_Object); extern void delete_all_child_windows (Lisp_Object); -extern void grow_mini_window (struct window *, int); -extern void shrink_mini_window (struct window *); +extern void grow_mini_window (struct window *, int, int); +extern void shrink_mini_window (struct window *, int); extern int window_relative_x_coord (struct window *, enum window_part, int); void run_window_change_functions (void); diff --git a/src/xdisp.c b/src/xdisp.c index ba5f6027d27..d7db4039afa 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -3320,13 +3320,50 @@ init_iterator (struct it *it, struct window *w, if (base_face_id == DEFAULT_FACE_ID && FRAME_WINDOW_P (it->f)) { + Lisp_Object line_space_above; + Lisp_Object line_space_below; + if (FIXNATP (BVAR (current_buffer, extra_line_spacing))) - it->extra_line_spacing = XFIXNAT (BVAR (current_buffer, extra_line_spacing)); + { + it->extra_line_spacing = XFIXNAT (BVAR (current_buffer, extra_line_spacing)); + it->extra_line_spacing_above = 0; + } else if (FLOATP (BVAR (current_buffer, extra_line_spacing))) - it->extra_line_spacing = (XFLOAT_DATA (BVAR (current_buffer, extra_line_spacing)) - * FRAME_LINE_HEIGHT (it->f)); + { + it->extra_line_spacing = (XFLOAT_DATA (BVAR (current_buffer, extra_line_spacing)) + * FRAME_LINE_HEIGHT (it->f)); + it->extra_line_spacing_above = 0; + } + else if (CONSP (BVAR (current_buffer, extra_line_spacing))) + { + line_space_above = XCAR (BVAR (current_buffer, extra_line_spacing)); + line_space_below = XCDR (BVAR (current_buffer, extra_line_spacing)); + /* Integer pair case. */ + if (FIXNATP (line_space_above) && FIXNATP (line_space_below)) + { + int line_space_total = XFIXNAT (line_space_below) + XFIXNAT (line_space_above); + it->extra_line_spacing = line_space_total; + it->extra_line_spacing_above = XFIXNAT (line_space_above); + } + /* Float pair case. */ + else if (FLOATP (line_space_above) && FLOATP (line_space_below)) + { + double line_space_total = XFLOAT_DATA (line_space_above) + XFLOAT_DATA (line_space_below); + it->extra_line_spacing = (line_space_total * FRAME_LINE_HEIGHT (it->f)); + it->extra_line_spacing_above = (XFLOAT_DATA (line_space_above) * FRAME_LINE_HEIGHT (it->f)); + } + /* Invalid cons. */ + else + { + it->extra_line_spacing = 0; + it->extra_line_spacing_above = 0; + } + } else if (it->f->extra_line_spacing > 0) - it->extra_line_spacing = it->f->extra_line_spacing; + { + it->extra_line_spacing = it->f->extra_line_spacing; + it->extra_line_spacing_above = it->f->extra_line_spacing_above; + } } /* If realized faces have been removed, e.g. because of face @@ -13165,7 +13202,7 @@ resize_mini_window (struct window *w, bool exact_p) else { struct it it; - int unit = FRAME_LINE_HEIGHT (f); + int unit; int height, max_height; struct text_pos start; struct buffer *old_current_buffer = NULL; @@ -13179,6 +13216,10 @@ resize_mini_window (struct window *w, bool exact_p) init_iterator (&it, w, BEGV, BEGV_BYTE, NULL, DEFAULT_FACE_ID); + /* Unit includes line spacing if line spacing is added above */ + unit = FRAME_LINE_HEIGHT (f) + + (it.extra_line_spacing_above ? it.extra_line_spacing : 0); + /* Compute the max. number of lines specified by the user. */ if (FLOATP (Vmax_mini_window_height)) max_height = XFLOAT_DATA (Vmax_mini_window_height) * windows_height; @@ -13211,7 +13252,10 @@ resize_mini_window (struct window *w, bool exact_p) } else height = it.current_y + it.max_ascent + it.max_descent; - height -= min (it.extra_line_spacing, it.max_extra_line_spacing); + + /* Remove final line spacing in the mini-window */ + if (!it.extra_line_spacing_above) + height -= min (it.extra_line_spacing, it.max_extra_line_spacing); /* Compute a suitable window start. */ if (height > max_height) @@ -13249,13 +13293,13 @@ resize_mini_window (struct window *w, bool exact_p) /* Let it grow only, until we display an empty message, in which case the window shrinks again. */ if (height > old_height) - grow_mini_window (w, height - old_height); + grow_mini_window (w, height - old_height, unit); else if (height < old_height && (exact_p || BEGV == ZV)) - shrink_mini_window (w); + shrink_mini_window (w, unit); } else if (height != old_height) /* Always resize to exact size needed. */ - grow_mini_window (w, height - old_height); + grow_mini_window (w, height - old_height, unit); if (old_current_buffer) set_buffer_internal (old_current_buffer); @@ -24076,6 +24120,7 @@ append_space_for_newline (struct it *it, bool default_face_p) { Lisp_Object height, total_height; int extra_line_spacing = it->extra_line_spacing; + int extra_line_spacing_above = it->extra_line_spacing_above; int boff = font->baseline_offset; if (font->vertical_centering) @@ -24117,7 +24162,7 @@ append_space_for_newline (struct it *it, bool default_face_p) if (!NILP (total_height)) spacing = calc_line_height_property (it, total_height, font, - boff, false); + boff, false); else { spacing = get_it_property (it, Qline_spacing); @@ -24129,11 +24174,13 @@ append_space_for_newline (struct it *it, bool default_face_p) extra_line_spacing = XFIXNUM (spacing); if (!NILP (total_height)) extra_line_spacing -= (it->phys_ascent + it->phys_descent); + } } if (extra_line_spacing > 0) { - it->descent += extra_line_spacing; + it->descent += (extra_line_spacing - extra_line_spacing_above); + it->ascent += extra_line_spacing_above; if (extra_line_spacing > it->max_extra_line_spacing) it->max_extra_line_spacing = extra_line_spacing; } @@ -33150,6 +33197,7 @@ void gui_produce_glyphs (struct it *it) { int extra_line_spacing = it->extra_line_spacing; + int extra_line_spacing_above = it->extra_line_spacing_above; it->glyph_not_available_p = false; @@ -33903,7 +33951,8 @@ gui_produce_glyphs (struct it *it) if (extra_line_spacing > 0) { - it->descent += extra_line_spacing; + it->descent += extra_line_spacing - extra_line_spacing_above; + it->ascent += extra_line_spacing_above; if (extra_line_spacing > it->max_extra_line_spacing) it->max_extra_line_spacing = extra_line_spacing; } diff --git a/src/xfns.c b/src/xfns.c index b214c9eb2f0..1c5ac5d3021 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5029,6 +5029,8 @@ This function is an internal primitive--use `make-frame' instead. */) XSETFRAME (frame, f); + frame_set_id_from_params (f, parms); + f->terminal = dpyinfo->terminal; f->output_method = output_x_window; @@ -6655,7 +6657,8 @@ Internal use only, use `display-monitor-attributes-list' instead. */) #else i = gdk_screen_get_monitor_at_window (gscreen, gwin); #endif - ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i))); + if (0 <= i && i < n_monitors) + ASET (monitor_frames, i, Fcons (frame, AREF (monitor_frames, i))); } } diff --git a/test/Makefile.in b/test/Makefile.in index cb69d9ba795..779094e79f1 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -215,7 +215,8 @@ EXCLUDE_TESTS = ## To speed up parallel builds, put these slow test files (which can ## take longer than all the rest combined) at the start of the list. -SLOW_TESTS = ${srcdir}/lisp/net/tramp-tests.el +SLOW_TESTS = ${srcdir}/lisp/emacs-lisp/package-vc-tests.el \ + ${srcdir}/lisp/net/tramp-tests.el ELFILES := $(sort $(shell find ${srcdir} -name manual -prune -o \ -name data -prune -o -name infra -prune -o \ @@ -232,6 +233,15 @@ LOGFILES := $(patsubst %.el,%.log, \ $(patsubst $(srcdir)/%,%,$(ELFILES))) TESTS := $(LOGFILES:.log=) +## Some tests show problems when run in parallel with other tests. +## Suppress parallelism for them when SELECTOR is equal to +## SELECTOR_EXPENSIVE or SELECTOR_ALL. +PARALLEL_TESTS := $(LOGFILES) +ifeq ($(subst $(SELECTOR_ALL),yes,$(subst $(SELECTOR_EXPENSIVE),yes,$(SELECTOR_ACTUAL))), yes) +$(eval NOT_PARALLEL_TESTS := $(filter lisp/autorevert-tests.log lisp/filenotify-tests.log lisp/net/tramp-tests.log, $(LOGFILES))) +$(eval PARALLEL_TESTS := $(filter-out $(NOT_PARALLEL_TESTS), ${LOGFILES})) +endif + ## If we have to interrupt a hanging test, preserve the log so we can ## see what the problem was. .PRECIOUS: %.log @@ -362,7 +372,12 @@ ifeq ($(TEST_INTERACTIVE), yes) $(patsubst %,-l %,$(if $(findstring $(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \ $(TEST_RUN_ERT) else - -@${MAKE} -k ${LOGFILES} +ifdef NOT_PARALLEL_TESTS + -@${MAKE} -k -j1 ${NOT_PARALLEL_TESTS} +endif +ifdef PARALLEL_TESTS + -@${MAKE} -k ${PARALLEL_TESTS} +endif @$(emacs) --batch -l ert --eval \ "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES} endif diff --git a/test/README b/test/README index ae0577a70c1..82b599df92b 100644 --- a/test/README +++ b/test/README @@ -32,6 +32,16 @@ following tags are recognized: * :unstable The test is under development. It shall run on demand only. +The following examples expect this directory as the current working +directory. If you call make from Emacs' root directory, use "make -C +test" instead. + +Running several tests in parallel could result in unexpected side +effects with ephemeral test errors. Therefore, it is recommend not to +use "make -j". Nonetheless, when expensive tests are activated, some of +the tests do not run parallel anyway. See make variable +$NOT_PARALLEL_TESTS. + The Makefile sets the environment variable $EMACS_TEST_DIRECTORY, which points to this directory. This environment variable does not exist when the tests are run outside make. The Makefile supports the @@ -92,6 +102,9 @@ use it directly: make SELECTOR='test-foo-remote' +Setting $SELECTOR in combination with the check-expensive or check-all +make targets is ignored. + Note that although the test files are always compiled (unless they set no-byte-compile), the source files will be run when expensive or unstable tests are involved, to give nicer backtraces. To run the diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index d12b8a8d371..886f3f16f9e 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -882,18 +882,8 @@ An existing calc stack is reused, otherwise a new one is created." (ert-deftest calc-math-vector-is-string () "Test `math-vector-is-string' with varying `calc-string-maximum-character'. - -All tests operate on both an integer vector and the corresponding -complex vector. The sets covered are: - -1. `calc-string-maximum-character' is a valid character. The last case -with `0x3FFFFF' is borderline, as integers above it will not make it -past the `characterp' test. -2. `calc-string-maximum-character' is negative, so the test always fails. -3. `calc-string-maximum-character' is above `(max-char)', so only the -first `characterp' test is active. -4. `calc-string-maximum-character' has an invalid type, which triggers -an error in the comparison." +When `calc-string-maximum-character' isn’t a valid character, +`math-vector-is-string' should return nil for all vectors." (cl-flet* ((make-vec (lambda (contents) (append (list 'vec) contents))) (make-cplx (lambda (x) (list 'cplx x 0))) (make-cplx-vec (lambda (contents) @@ -902,50 +892,20 @@ an error in the comparison." (dolist (maxchar '(#x7F #xFF #x10FFFF #x3FFFFD #x3FFFFF)) (let* ((calc-string-maximum-character maxchar) (small-chars (number-sequence (- maxchar 2) maxchar)) - (large-chars (number-sequence maxchar (+ maxchar 2))) - (small-real-vec (make-vec small-chars)) - (large-real-vec (make-vec large-chars)) - (small-cplx-vec (make-cplx-vec small-chars)) - (large-cplx-vec (make-cplx-vec large-chars))) - (should (math-vector-is-string small-real-vec)) - (should-not (math-vector-is-string large-real-vec)) - (should (math-vector-is-string small-cplx-vec)) - (should-not (math-vector-is-string large-cplx-vec)))) - ;; 2: calc-string-maximum-character is negative - (let* ((maxchar -1) - (calc-string-maximum-character maxchar) - (valid-contents (number-sequence 0 2)) - (invalid-contents (number-sequence (- maxchar 2) maxchar)) - (valid-real-vec (make-vec valid-contents)) - (invalid-real-vec (make-vec invalid-contents)) - (valid-cplx-vec (make-cplx-vec valid-contents)) - (invalid-cplx-vec (make-cplx-vec invalid-contents))) - (should-not (math-vector-is-string valid-real-vec)) - (should-not (math-vector-is-string invalid-real-vec)) - (should-not (math-vector-is-string valid-cplx-vec)) - (should-not (math-vector-is-string invalid-cplx-vec))) - ;; 3: calc-string-maximum-character is larger than (max-char) - (let* ((maxchar (+ (max-char) 3)) - (calc-string-maximum-character maxchar) - (valid-chars (number-sequence (- (max-char) 2) (max-char))) - (invalid-chars (number-sequence (1+ (max-char)) maxchar)) - (valid-real-vec (make-vec valid-chars)) - (invalid-real-vec (make-vec invalid-chars)) - (valid-cplx-vec (make-cplx-vec valid-chars)) - (invalid-cplx-vec (make-cplx-vec invalid-chars))) - (should (math-vector-is-string valid-real-vec)) - (should-not (math-vector-is-string invalid-real-vec)) - (should (math-vector-is-string valid-cplx-vec)) - (should-not (math-vector-is-string invalid-cplx-vec))) - ;; 4: calc-string-maximum-character has the wrong type - (let* ((calc-string-maximum-character "wrong type") - (contents (number-sequence 0 2)) - (real-vec (make-vec contents)) - (cplx-vec (make-cplx-vec contents))) - (should-error (math-vector-is-string real-vec) - :type 'wrong-type-argument) - (should-error (math-vector-is-string cplx-vec) - :type 'wrong-type-argument)))) + (large-chars (number-sequence maxchar (+ maxchar 2)))) + (should (math-vector-is-string (make-vec small-chars))) + (should-not (math-vector-is-string (make-vec large-chars))) + (should (math-vector-is-string (make-cplx-vec small-chars))) + (should-not (math-vector-is-string (make-cplx-vec large-chars))))) + ;; 2: calc-string-maximum-character is not a valid character + (dolist (maxchar (list -1 (1+ (max-char)) "wrong type")) + (let ((calc-string-maximum-character maxchar) + (valid-chars (number-sequence 0 2)) + (invalid-chars (number-sequence -2 -1))) + (should-not (math-vector-is-string (make-vec valid-chars))) + (should-not (math-vector-is-string (make-vec invalid-chars))) + (should-not (math-vector-is-string (make-cplx-vec valid-chars))) + (should-not (math-vector-is-string (make-cplx-vec invalid-chars))))))) (ert-deftest calc-inhibit-startup-message () "Test user option `calc-inhibit-startup-message'." diff --git a/test/lisp/calendar/cal-bahai-tests.el b/test/lisp/calendar/cal-bahai-tests.el new file mode 100644 index 00000000000..bd95cbc4bcc --- /dev/null +++ b/test/lisp/calendar/cal-bahai-tests.el @@ -0,0 +1,137 @@ +;;; cal-bahai-tests.el --- tests for the Bahá’í calendar. -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Free Software Foundation, Inc. + +;; Author: John Wiegley +;; Keywords: calendar +;; Human-Keywords: Bahá’í calendar, Bahá’í, Baha'i, Bahai, calendar, diary +;; Package: calendar + +;; 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 . + +;;; Commentary: + +;; The following code verifies the astronomical calculations against +;; official dates published by the Bahá’í World Centre. +;; +;; BACKGROUND: 2014 Calendar Reform +;; -------------------------------- +;; On 10 July 2014, the Universal House of Justice announced provisions +;; for the uniform implementation of the Badí' calendar, effective from +;; Naw-Rúz 172 BE (March 2015). The key provisions are: +;; +;; 1. NAW-RÚZ DETERMINATION: +;; "The Festival of Naw-Rúz falleth on the day that the sun entereth +;; the sign of Aries, even should this occur no more than one minute +;; before sunset." Tehran is the reference point for determining the +;; moment of the vernal equinox. If the equinox occurs before sunset +;; in Tehran, that day is Naw-Rúz; otherwise, the following day is. +;; +;; 2. TWIN HOLY BIRTHDAYS: +;; "They will now be observed on the first and the second day +;; following the occurrence of the eighth new moon after Naw-Rúz, +;; as determined in advance by astronomical tables using Ṭihrán as +;; the point of reference." +;; +;; VERIFICATION APPROACH +;; --------------------- +;; The functions below compare calculated dates against official data +;; from the Bahá’í World Centre, covering the 50-year period from +;; 172 BE (2015 CE) to 221 BE (2064 CE). This data was extracted from +;; the official ICS calendar file distributed by the Bahá’í World Centre. +;; +;; The verification confirms: +;; - Naw-Rúz dates: Calculated using `solar-equinoxes/solstices' for the +;; vernal equinox and `solar-sunrise-sunset' for Tehran sunset times. +;; - Twin Holy Birthdays: Calculated using `lunar-new-moon-on-or-after' +;; to find the eighth new moon after Naw-Rúz. + +;;; Code: + +(require 'ert) +(require 'cal-bahai) + +(defconst calendar-bahai--nawruz-reference-dates + '((2015 3 21) (2016 3 20) (2017 3 20) (2018 3 21) (2019 3 21) + (2020 3 20) (2021 3 20) (2022 3 21) (2023 3 21) (2024 3 20) + (2025 3 20) (2026 3 21) (2027 3 21) (2028 3 20) (2029 3 20) + (2030 3 20) (2031 3 21) (2032 3 20) (2033 3 20) (2034 3 20) + (2035 3 21) (2036 3 20) (2037 3 20) (2038 3 20) (2039 3 21) + (2040 3 20) (2041 3 20) (2042 3 20) (2043 3 21) (2044 3 20) + (2045 3 20) (2046 3 20) (2047 3 21) (2048 3 20) (2049 3 20) + (2050 3 20) (2051 3 21) (2052 3 20) (2053 3 20) (2054 3 20) + (2055 3 21) (2056 3 20) (2057 3 20) (2058 3 20) (2059 3 20) + (2060 3 20) (2061 3 20) (2062 3 20) (2063 3 20) (2064 3 20)) + "Official Naw-Rúz dates from the Bahá’í World Centre (2015-2064). +Each entry is (GREGORIAN-YEAR MONTH DAY). These dates are extracted +from the official ICS calendar file and serve as the authoritative +reference for verifying the astronomical calculations. + +The dates show that Naw-Rúz falls on March 20 or 21, depending on +when the vernal equinox occurs relative to sunset in Tehran.") + +(defconst calendar-bahai--twin-birthdays-reference-dates + '(;; (GREG-YEAR BAB-MONTH BAB-DAY BAHA-MONTH BAHA-DAY) + (2015 11 13 11 14) (2016 11 1 11 2) (2017 10 21 10 22) + (2018 11 9 11 10) (2019 10 29 10 30) (2020 10 18 10 19) + (2021 11 6 11 7) (2022 10 26 10 27) (2023 10 16 10 17) + (2024 11 2 11 3) (2025 10 22 10 23) (2026 11 10 11 11) + (2027 10 30 10 31) (2028 10 19 10 20) (2029 11 7 11 8) + (2030 10 28 10 29) (2031 10 17 10 18) (2032 11 4 11 5) + (2033 10 24 10 25) (2034 11 12 11 13) (2035 11 1 11 2) + (2036 10 20 10 21) (2037 11 8 11 9) (2038 10 29 10 30) + (2039 10 19 10 20) (2040 11 6 11 7) (2041 10 26 10 27) + (2042 10 15 10 16) (2043 11 3 11 4) (2044 10 22 10 23) + (2045 11 10 11 11) (2046 10 30 10 31) (2047 10 20 10 21) + (2048 11 7 11 8) (2049 10 28 10 29) (2050 10 17 10 18) + (2051 11 5 11 6) (2052 10 24 10 25) (2053 11 11 11 12) + (2054 11 1 11 2) (2055 10 21 10 22) (2056 11 8 11 9) + (2057 10 29 10 30) (2058 10 18 10 19) (2059 11 6 11 7) + (2060 10 25 10 26) (2061 10 14 10 15) (2062 11 2 11 3) + (2063 10 23 10 24) (2064 11 10 11 11)) + "Official Twin Holy Birthday dates from the Bahá’í World Centre (2015-2064). +Each entry is (GREGORIAN-YEAR BAB-MONTH BAB-DAY BAHA-MONTH BAHA-DAY). + +The Birth of the Báb and the Birth of Bahá’u’lláh are celebrated on +consecutive days, determined by the eighth new moon after Naw-Rúz. +These dates move through the Gregorian calendar, typically falling +between mid-October and mid-November (Bahá’í months of Mashíyyat, +\\='Ilm, and Qudrat).") + +(ert-deftest calendar-bahai-verify-nawruz () + "Verify Naw-Rúz calculations against official reference dates." + (pcase-dolist (`(,greg-year ,expected-month ,expected-day) + calendar-bahai--nawruz-reference-dates) + (let* ((expected (list expected-month expected-day greg-year)) + (computed (calendar-bahai-nawruz-for-gregorian-year greg-year))) + (should (equal computed expected))))) + +(ert-deftest calendar-bahai-verify-twin-birthdays () + "Verify Twin Holy Birthday calculations against official reference dates." + (pcase-dolist (`(,greg-year ,bab-month ,bab-day ,baha-month ,baha-day) + calendar-bahai--twin-birthdays-reference-dates) + (let* ((bahai-year (- greg-year (1- 1844))) + (expected-bab (list bab-month bab-day greg-year)) + (expected-baha (list baha-month baha-day greg-year))) + ;; Only verify from reform year onwards + (when (>= bahai-year calendar-bahai-reform-year) + (pcase-let* ((`(,computed-bab ,computed-baha) + (calendar-bahai-twin-holy-birthdays-for-year bahai-year))) + (should (equal computed-bab expected-bab)) + (should (equal computed-baha expected-baha))))))) + +(provide 'cal-bahai-tests) +;;; cal-bahai-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index cb78c1c2290..a8c34e8e45b 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -242,7 +242,7 @@ Must called from within a `tar-mode' buffer." (should (package-installed-p 'simple-single)) ;; Check if we properly report an "already installed". (should (condition-case nil - (progn (package-install 'simple-single) nil) + (progn (package-install 'simple-single nil 'interactive) nil) (user-error t))) (should (package-installed-p 'simple-single)) (let* ((simple-pkg-dir (file-name-as-directory diff --git a/test/lisp/emacs-lisp/package-vc-tests.el b/test/lisp/emacs-lisp/package-vc-tests.el index 5c7930f12af..5ae36e79bcc 100644 --- a/test/lisp/emacs-lisp/package-vc-tests.el +++ b/test/lisp/emacs-lisp/package-vc-tests.el @@ -65,25 +65,28 @@ of symbols, then preserve temporary directories and buffers for each package that matches a symbol in the list. When this variable is t then preserve all temporary directories.") +(defvar package-vc-tests-repos (make-hash-table)) + (defvar package-vc-tests-dir) (defvar package-vc-tests-packages) (defvar package-vc-tests-repository) (eval-and-compile - (defun package-vc-tests-packages () + (defun package-vc-tests-packages (&optional full) "Return a list of package definitions to test. When variable `package-vc-tests-packages' is bound then return its -value. If `package-vc-tests-dir' is bound then each entry is in a form -of (PKG CHECKOUT-DIR LISP-DIR INSTALL-FUN), where PKG is a package -name (a symbol), CHECKOUT-DIR is an expected checkout directory, -LISP-DIR is a directory with package's sources (relative to +value. If `package-vc-tests-dir' is bound or FULL is non nil then each +entry is in a form of (PKG CHECKOUT-DIR LISP-DIR INSTALL-FUN), where PKG +is a package name (a symbol), CHECKOUT-DIR either is nil when +`package-vc-tests-dir' is not bound or is an expected checkout +directory, LISP-DIR is a directory with package's sources (relative to CHECKOUT-DIR), and INSTALL-FUN is a function that checkouts and install the package. Otherwise each entry is in a form of PKG." (if (boundp 'package-vc-tests-packages) package-vc-tests-packages (cl-macrolet ((test-package-def (pkg checkout-dir-exp lisp-dir install-fun) - `(if (boundp 'package-vc-tests-dir) + `(if (or (boundp 'package-vc-tests-dir) full) (list ',pkg (expand-file-name (symbol-name ',pkg) @@ -91,51 +94,54 @@ the package. Otherwise each entry is in a form of PKG." ,lisp-dir #',install-fun) ',pkg))) - (list - ;; checkout and install with `package-vc-install' (on ELPA) - (test-package-def - test-package-one package-user-dir nil - package-vc-tests-install-from-elpa) - ;; checkout and install with `package-vc-install' (not on ELPA) - (test-package-def - test-package-two package-user-dir nil - package-vc-tests-install-from-spec) - ;; checkout with `package-vc-checktout' and install with - ;; `package-vc-install-from-checkout' (on ELPA) - (test-package-def - test-package-three package-vc-tests-dir nil - package-vc-tests-checkout-from-elpa-install-from-checkout) - ;; checkout with git and install with - ;; `package-vc-install-from-checkout' - (test-package-def - test-package-four package-vc-tests-dir nil - package-vc-tests-checkout-with-git-install-from-checkout) - ;; sources in "lisp" sub directory, checkout and install with - ;; `package-vc-install' (not on ELPA) - (test-package-def - test-package-five package-user-dir "lisp" - package-vc-tests-install-from-spec) - ;; sources in "lisp" sub directory, checkout with git and - ;; install with `package-vc-install-from-checkout' - (test-package-def - test-package-six package-vc-tests-dir "lisp" - package-vc-tests-checkout-with-git-install-from-checkout) - ;; sources in "src" sub directory, checkout and install with - ;; `package-vc-install' (on ELPA) - (test-package-def - test-package-seven package-user-dir "src" - package-vc-tests-install-from-elpa) - ;; sources in "src" sub directory, checkout with - ;; `package-vc-checktout' and install with - ;; `package-vc-install-from-checkout' (on ELPA) - (test-package-def - test-package-eight package-vc-tests-dir nil - package-vc-tests-checkout-from-elpa-install-from-checkout) - ;; sources in "custom-dir" sub directory, checkout and install - ;; with `package-vc-install' (on ELPA) - (test-package-def - test-package-nine package-user-dir "custom-dir" - package-vc-tests-install-from-elpa)))))) + (let* ((tests-dir (bound-and-true-p package-vc-tests-dir)) + (user-dir (and tests-dir package-user-dir))) + (list + ;; checkout and install with `package-vc-install' (on ELPA) + (test-package-def + test-package-one user-dir nil + package-vc-tests-install-from-elpa) + ;; checkout and install with `package-vc-install' (not on + ;; ELPA) + (test-package-def + test-package-two user-dir nil + package-vc-tests-install-from-spec) + ;; checkout with `package-vc-checktout' and install with + ;; `package-vc-install-from-checkout' (on ELPA) + (test-package-def + test-package-three tests-dir nil + package-vc-tests-checkout-from-elpa-install-from-checkout) + ;; checkout with git and install with + ;; `package-vc-install-from-checkout' + (test-package-def + test-package-four tests-dir nil + package-vc-tests-checkout-with-git-install-from-checkout) + ;; sources in "lisp" sub directory, checkout and install with + ;; `package-vc-install' (not on ELPA) + (test-package-def + test-package-five user-dir "lisp" + package-vc-tests-install-from-spec) + ;; sources in "lisp" sub directory, checkout with git and + ;; install with `package-vc-install-from-checkout' + (test-package-def + test-package-six tests-dir "lisp" + package-vc-tests-checkout-with-git-install-from-checkout) + ;; sources in "src" sub directory, checkout and install with + ;; `package-vc-install' (on ELPA) + (test-package-def + test-package-seven user-dir "src" + package-vc-tests-install-from-elpa) + ;; sources in "src" sub directory, checkout with + ;; `package-vc-checktout' and install with + ;; `package-vc-install-from-checkout' (on ELPA) + (test-package-def + test-package-eight tests-dir nil + package-vc-tests-checkout-from-elpa-install-from-checkout) + ;; sources in "custom-dir" sub directory, checkout and + ;; install with `package-vc-install' (on ELPA) + (test-package-def + test-package-nine user-dir "custom-dir" + package-vc-tests-install-from-elpa))))))) ;; TODO: add test for deleting packages, with asserting ;; `package-vc-selected-packages' @@ -165,12 +171,11 @@ When LISP-DIR is non-nil place the NAME file under LISP-DIR." (error "Failed to invoke sed on %s" in-file)) (vc-git-command nil 0 nil "add" "."))) -(defun package-vc-tests-create-repository (suffix &optional lisp-dir) - "Create a test package repository with SUFFIX. +(defun package-vc-tests-create-repository (suffix repos-dir &optional lisp-dir) + "Create a test package repository with SUFFIX in REPOS-DIR. If LISP-DIR is non-nil place sources of the package in LISP-DIR." (let* ((name (format "test-package-%s" suffix)) - (repo-dir (expand-file-name (file-name-concat "repo" name) - package-vc-tests-dir))) + (repo-dir (expand-file-name name repos-dir))) (make-directory (expand-file-name (or lisp-dir ".") repo-dir) t) (let ((default-directory repo-dir) (process-environment @@ -179,7 +184,8 @@ If LISP-DIR is non-nil place sources of the package in LISP-DIR." (format "GIT_AUTHOR_NAME=%s" name) (format "GIT_COMMITTER_NAME=%s" name)) process-environment))) - (vc-git-command nil 0 nil "init" "-b" "master") + (vc-git-command nil 0 nil "init") + (vc-git-command nil 0 nil "checkout" "-b" "master") (package-vc-tests-add suffix "test-package-SUFFIX-lib-v0.1.el.in" lisp-dir) (package-vc-tests-add @@ -395,6 +401,11 @@ names." (not (member lisp-dir '("lisp" "src"))) (list :lisp-dir lisp-dir))))) +(defun package-vc-tests-make-temp-dir (prefix) + "Create temp directory with PREFIX." + (expand-file-name + (make-temp-file prefix t (format-time-string "-%Y%m%d.%H%M%S.%3N")))) + (defun package-vc-with-tests-environment (pkg function) "Call FUNCTION with no arguments within a test environment set up for PKG." ;; Create a test package sources repository, based on skeleton files @@ -402,10 +413,7 @@ names." ;; that: ;; (let* ((package-vc-tests-dir - (expand-file-name - (make-temp-file "package-vc-tests-" - t - (format-time-string "-%Y%m%d.%H%M%S.%3N")))) + (package-vc-tests-make-temp-dir "package-vc-tests-")) ;; - packages are installed into test directory (package-user-dir (expand-file-name "elpa" package-vc-tests-dir)) @@ -424,13 +432,25 @@ names." (package-vc-tests-packages (package-vc-tests-packages)) ;; - create a test package bundle (package-vc-tests-repository - (let* ((pkg-name (symbol-name pkg)) - (suffix (and (string-match - (rx ?- (group (1+ (not ?-))) eos) - pkg-name) - (match-string 1 pkg-name)))) - (package-vc-tests-create-repository - suffix (cadr (alist-get pkg package-vc-tests-packages))))) + (or + (gethash pkg package-vc-tests-repos) + (let* ((pkg-name (symbol-name pkg)) + (suffix (and (string-match + (rx ?- (group (1+ (not ?-))) eos) + pkg-name) + (match-string 1 pkg-name))) + (repos-dir + (or (gethash 'repos-dir package-vc-tests-repos) + (puthash 'repos-dir + (package-vc-tests-make-temp-dir + "package-vc-tests-repos-") + package-vc-tests-repos)))) + (puthash pkg + (package-vc-tests-create-repository + suffix + repos-dir + (cadr (alist-get pkg package-vc-tests-packages))) + package-vc-tests-repos)))) ;; - find all packages that are present in a test ELPA (package-vc-tests-elpa-packages (cl-loop @@ -491,6 +511,12 @@ names." (package-vc-allow-build-commands t)) (funcall function))) +(defun package-vc-tests-preserve-pkg-artifacts-p (pkg) + "Return non nil if files and buffers for PKG should be preserved." + (or (memq package-vc-tests-preserve-artifacts `(t ,pkg)) + (and (listp package-vc-tests-preserve-artifacts) + (memq pkg package-vc-tests-preserve-artifacts)))) + (defun package-vc-tests-environment-tear-down (pkg) "Tear down test environment for PKG. Unbind package defined symbols, and remove package defined features and @@ -534,27 +560,74 @@ when PKG matches `package-vc-tests-preserve-artifacts'." (package-vc-tests-log-buffer-name pkg type))) '(doc make))))) - (if (or (memq package-vc-tests-preserve-artifacts `(t ,pkg)) - (and (listp package-vc-tests-preserve-artifacts) - (memq pkg package-vc-tests-preserve-artifacts))) + (if (package-vc-tests-preserve-pkg-artifacts-p pkg) (let ((buffers - (mapconcat (lambda (buffer) - (with-current-buffer buffer - (let* ((old-name (buffer-name)) - (new-name (make-temp-name - (string-trim old-name)))) - (rename-buffer new-name) - (concat old-name " -> " new-name)))) - buffers - ", "))) + (if buffers + (format " and %s: %s" + (if (cdr buffers) "buffers" "buffer") + (mapconcat + (lambda (buffer) + (with-current-buffer buffer + (let* ((old-name (buffer-name)) + (new-name (make-temp-name + (string-trim old-name)))) + (rename-buffer new-name) + (format "`%s' -> `%s'" + old-name new-name)))) + buffers + ", ")) + "")) + (repo-dir (car (gethash pkg package-vc-tests-repos)))) (message - "package-vc-tests: preserving temporary directory: %s%s" + "package-vc-tests: preserving temporary %s: %s%s%s" + (if repo-dir "directories" "directory") package-vc-tests-dir - (and buffers (format " and buffers: %s" buffers)))) + (if repo-dir (format " and %s" repo-dir) "") + buffers)) (delete-directory package-vc-tests-dir t) (dolist (buffer buffers) (kill-buffer buffer))))) +;; Tests create a repository for a package only once per a tests run. +;; The repository location is cached in `package-vc-tests-repos'. To +;; support development, clear the cache on start of each tests run, such +;; that the package repository contains files from the source code. +;; When tests run completes delete repositories accounting for +;; `package-vc-tests-preserve-artifacts', which see. + +(defun package-vc-tests-add-ert-run-tests-listener (args) + "Add `package-vc-tests' repositories cleanup to listener in ARGS." + (if-let* ((listener (cadr args)) + ((functionp listener))) + (cl-list* + (car args) + (lambda (event-type &rest event-args) + (cl-case event-type + (run-started + (clrhash package-vc-tests-repos)) + (run-ended + (when-let* ((repos-dir (gethash 'repos-dir + package-vc-tests-repos)) + ((file-directory-p repos-dir))) + (if package-vc-tests-preserve-artifacts + (progn + (dolist (pkg (package-vc-tests-packages)) + (unless + (package-vc-tests-preserve-pkg-artifacts-p pkg) + (when-let* ((repo-dir + (car (gethash pkg package-vc-tests-repos))) + ((file-directory-p repo-dir))) + (delete-directory repo-dir t)))) + (when (directory-empty-p repos-dir) + (delete-directory repos-dir))) + (delete-directory repos-dir t))))) + (apply listener (cons event-type event-args))) + (drop 2 args)) + args)) + +(advice-add #'ert-run-tests + :filter-args #'package-vc-tests-add-ert-run-tests-listener) + (defun package-vc-tests-with-installed (pkg function) "Call FUNCTION with PKG installed in a test environment. FUNCTION should have no arguments." @@ -678,27 +751,33 @@ contains key `:tags' use its value as tests tags." (error "`package-vc' tests first argument has to be a symbol")) (let ((file (or (macroexp-file-name) buffer-file-name)) (tests '()) (fn (gensym)) + (pkg-arg (car args)) + (skip-forms (take-while (lambda (form) + (memq (car-safe form) '(skip-when + skip-unless))) + body)) (tags (plist-get (cdr-safe args) :tags))) + (setq body (nthcdr (length skip-forms) body)) (dolist (pkg (package-vc-tests-packages)) (let ((name (intern (format "package-vc-tests-%s/%s" name pkg)))) (push - `(ert-set-test - ',name - (make-ert-test - :name ',name - :tags (cons 'package-vc ',tags) - :file-name ,file - :body - (lambda () - (package-vc-tests-with-installed - ',pkg (funcall ,fn ',pkg)) - nil))) + `(ert-set-test ',name + (make-ert-test + :name ',name + :tags (cons 'package-vc ',tags) + :file-name ,file + :body + (lambda () + (funcall ,fn ',pkg) + nil))) tests))) - `(let ((,fn (lambda (,(car args)) - (cl-macrolet ((skip-when (form) `(ert--skip-when ,form)) - (skip-unless (form) `(ert--skip-unless ,form))) - (lambda () ,@body))))) - ,@tests))) + `(cl-macrolet ((skip-when (form) `(ert--skip-when ,form)) + (skip-unless (form) `(ert--skip-unless ,form))) + (let ((,fn (lambda (,pkg-arg) + ,@skip-forms + (package-vc-tests-with-installed ,pkg-arg + (lambda () ,@body))))) + ,@tests)))) (package-vc-test-deftest install-post-conditions (pkg) (let ((install-begin @@ -984,7 +1063,7 @@ contains key `:tags' use its value as tests tags." (should (package-vc-tests-package-vc-async-wait 5 1 '("log" "--decorate") - (package-vc-log-incoming (package-vc-tests-package-desc pkg t)) + (package-vc-root-log-incoming (package-vc-tests-package-desc pkg t)) t)) (let ((incoming-buffer (get-buffer "*vc-incoming*")) (pattern (rx (literal @@ -1006,7 +1085,7 @@ contains key `:tags' use its value as tests tags." (package-vc-test-deftest pkg-spec-make-shell-command (pkg) ;; Only `package-vc-install' runs make and shell command - (skip-unless (memq (caddr (alist-get pkg package-vc-tests-packages)) + (skip-unless (memq (caddr (alist-get pkg (package-vc-tests-packages t))) '(package-vc-tests-install-from-elpa package-vc-tests-install-from-spec))) (let* ((desc (package-vc-tests-package-desc pkg t)) @@ -1024,7 +1103,7 @@ contains key `:tags' use its value as tests tags." ;; Only `package-vc-install' builds info manuals, but only when ;; executable install-info is available. (skip-unless (and (executable-find "install-info") - (memq (caddr (alist-get pkg package-vc-tests-packages)) + (memq (caddr (alist-get pkg (package-vc-tests-packages t))) '(package-vc-tests-install-from-elpa package-vc-tests-install-from-spec)))) (should-not (package-vc-tests-log-buffer-exists 'doc pkg)) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 6b731699a67..9b8a643c731 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -80,6 +80,7 @@ (ert-deftest pcase-tests-quote-optimization () ;; FIXME: We could/should also test that we get a corresponding ;; "shadowed branch" warning. + (require 'byte-opt) ;; FIXME: Needed for pcase to see that `consp' is `pure'. (should-not (pcase-tests-grep 'FOO (macroexpand '(pcase EXP (`(,_ . ,_) (BAR)) @@ -191,4 +192,22 @@ (should (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x))) (should-not (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x)))))) +(ert-deftest pcase-pred-equiv () + (cl-flet ((f1 (x) (pcase x ((pred atom) 1) (_ 2)))) + (should (equal (f1 'a) 1)) + (should (equal (f1 nil) 1)) + (should (equal (f1 '(a)) 2))) + (cl-flet ((f2 (x) (pcase x ((pred nlistp) 1) (_ 2)))) + (should (equal (f2 'a) 1)) + (should (equal (f2 nil) 2)) + (should (equal (f2 '(a)) 2))) + (cl-flet ((f3 (x) (pcase x ((pred identity) 1) (_ 2)))) + (should (equal (f3 'a) 1)) + (should (equal (f3 nil) 2)) + (should (equal (f3 '(a)) 1))) + (cl-flet ((f4 (x) (pcase x ((pred not) 1) (_ 2)))) + (should (equal (f4 'a) 2)) + (should (equal (f4 nil) 1)) + (should (equal (f4 '(a)) 2)))) + ;;; pcase-tests.el ends here. diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index f3754d5d37f..cad4dcbb7aa 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -537,31 +537,6 @@ ;; Substring tests -(ert-deftest subr-x-test-string-trim-left () - "Test `string-trim-left' behavior." - (should (equal (string-trim-left "") "")) - (should (equal (string-trim-left " \t\n\r") "")) - (should (equal (string-trim-left " \t\n\ra") "a")) - (should (equal (string-trim-left "a \t\n\r") "a \t\n\r")) - (should (equal (string-trim-left "" "") "")) - (should (equal (string-trim-left "a" "") "a")) - (should (equal (string-trim-left "aa" "a*") "")) - (should (equal (string-trim-left "ba" "a*") "ba")) - (should (equal (string-trim-left "aa" "a*?") "aa")) - (should (equal (string-trim-left "aa" "a+?") "a"))) - -(ert-deftest subr-x-test-string-trim-right () - "Test `string-trim-right' behavior." - (should (equal (string-trim-right "") "")) - (should (equal (string-trim-right " \t\n\r") "")) - (should (equal (string-trim-right " \t\n\ra") " \t\n\ra")) - (should (equal (string-trim-right "a \t\n\r") "a")) - (should (equal (string-trim-right "" "") "")) - (should (equal (string-trim-right "a" "") "a")) - (should (equal (string-trim-right "aa" "a*") "")) - (should (equal (string-trim-right "ab" "a*") "ab")) - (should (equal (string-trim-right "aa" "a*?") ""))) - (ert-deftest subr-x-test-string-remove-prefix () "Test `string-remove-prefix' behavior." (should (equal (string-remove-prefix "" "") "")) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 1bbee0dad52..6d0172e98fc 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -165,19 +165,6 @@ (advice-remove 'buffer-local-value 'erc-with-server-buffer))) -(ert-deftest erc--doarray () - (let ((array "abcdefg") - out) - ;; No return form. - (should-not (erc--doarray (c array) (push c out))) - (should (equal out '(?g ?f ?e ?d ?c ?b ?a))) - - ;; Return form evaluated upon completion. - (setq out nil) - (should (= 42 (erc--doarray (c array (+ 39 (length out))) - (when (cl-evenp c) (push c out))))) - (should (equal out '(?f ?d ?b))))) - (ert-deftest erc-hide-prompt () (let ((erc-hide-prompt erc-hide-prompt) (inhibit-message noninteractive) @@ -1000,87 +987,88 @@ (setq erc-channel-users (make-hash-table :test #'equal) erc--target (erc--target-from-string "#test")) - (let ((orig-handle-fn (symbol-function 'erc--handle-channel-mode)) - calls) - (cl-letf (((symbol-function 'erc--handle-channel-mode) - (lambda (&rest r) (push r calls) (apply orig-handle-fn r))) - ((symbol-function 'erc-update-mode-line) #'ignore)) + (cl-letf ((calls ()) + ((symbol-function 'erc-update-mode-line) #'ignore)) + (advice-add 'erc--handle-channel-mode + :before (lambda (&rest r) (push r calls)) + '((name . erc-tests-spy))) - (ert-info ("Unknown user not created") - (erc--update-channel-modes "+o" "bob") - (should-not (erc-get-channel-user "bob"))) + (ert-info ("Unknown user not created") + (erc--update-channel-modes "+o" "bob") + (should-not (erc-get-channel-user "bob"))) - (ert-info ("Status updated when user known") - (puthash "bob" (cons (erc-add-server-user - "bob" (make-erc-server-user - :nickname "bob" - :buffers (list (current-buffer)))) - (make-erc-channel-user)) - erc-channel-users) - ;; Also asserts fallback behavior for traditional prefixes. - (should-not (erc-channel-user-op-p "bob")) - (erc--update-channel-modes "+o" "bob") - (should (erc-channel-user-op-p "bob")) - (erc--update-channel-modes "-o" "bob") ; status revoked - (should-not (erc-channel-user-op-p "bob"))) + (ert-info ("Status updated when user known") + (puthash "bob" (cons (erc-add-server-user + "bob" (make-erc-server-user + :nickname "bob" + :buffers (list (current-buffer)))) + (make-erc-channel-user)) + erc-channel-users) + ;; Also asserts fallback behavior for traditional prefixes. + (should-not (erc-channel-user-op-p "bob")) + (erc--update-channel-modes "+o" "bob") + (should (erc-channel-user-op-p "bob")) + (erc--update-channel-modes "-o" "bob") ; status revoked + (should-not (erc-channel-user-op-p "bob"))) - (ert-info ("Unknown nullary added and removed") - (should-not erc--channel-modes) - (should-not erc-channel-modes) - (erc--update-channel-modes "+u") - (should (equal erc-channel-modes '("u"))) - (should (eq t (gethash ?u erc--channel-modes))) - (should (equal (pop calls) '(?d ?u t nil))) - (erc--update-channel-modes "-u") - (should (equal (pop calls) '(?d ?u nil nil))) - (should-not (gethash ?u erc--channel-modes)) - (should-not erc-channel-modes) - (should-not calls)) + (ert-info ("Unknown nullary added and removed") + (should-not erc--channel-modes) + (should-not erc-channel-modes) + (erc--update-channel-modes "+u") + (should (equal erc-channel-modes '("u"))) + (should (eq t (gethash ?u erc--channel-modes))) + (should (equal (pop calls) '(?d ?u t nil))) + (erc--update-channel-modes "-u") + (should (equal (pop calls) '(?d ?u nil nil))) + (should-not (gethash ?u erc--channel-modes)) + (should-not erc-channel-modes) + (should-not calls)) - (ert-info ("Fallback for Type B includes mode letter k") - (erc--update-channel-modes "+k" "h2") - (should (equal (pop calls) '(?b ?k t "h2"))) - (should-not erc-channel-modes) - (should (equal "h2" (gethash ?k erc--channel-modes))) - (erc--update-channel-modes "-k" "*") - (should (equal (pop calls) '(?b ?k nil "*"))) - (should-not calls) - (should-not (gethash ?k erc--channel-modes)) - (should-not erc-channel-modes)) + (ert-info ("Fallback for Type B includes mode letter k") + (erc--update-channel-modes "+k" "h2") + (should (equal (pop calls) '(?b ?k t "h2"))) + (should-not erc-channel-modes) + (should (equal "h2" (gethash ?k erc--channel-modes))) + (erc--update-channel-modes "-k" "*") + (should (equal (pop calls) '(?b ?k nil "*"))) + (should-not calls) + (should-not (gethash ?k erc--channel-modes)) + (should-not erc-channel-modes)) - (ert-info ("Fallback for Type C includes mode letter l") - (erc--update-channel-modes "+l" "3") - (should (equal (pop calls) '(?c ?l t "3"))) - (should-not erc-channel-modes) - (should (equal "3" (gethash ?l erc--channel-modes))) - (erc--update-channel-modes "-l" nil) - (should (equal (pop calls) '(?c ?l nil nil))) - (should-not (gethash ?l erc--channel-modes)) - (should-not erc-channel-modes)) + (ert-info ("Fallback for Type C includes mode letter l") + (erc--update-channel-modes "+l" "3") + (should (equal (pop calls) '(?c ?l t "3"))) + (should-not erc-channel-modes) + (should (equal "3" (gethash ?l erc--channel-modes))) + (erc--update-channel-modes "-l" nil) + (should (equal (pop calls) '(?c ?l nil nil))) + (should-not (gethash ?l erc--channel-modes)) + (should-not erc-channel-modes)) - (ert-info ("Advertised supersedes heuristics") - (setq erc-server-parameters - '(("PREFIX" . "(ov)@+") - ;; Add phony 5th type for this CHANMODES value for - ;; robustness in case some server gets creative. - ("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz,FAKE"))) - (erc--update-channel-modes "+qu" "fool!*@*") - (should (equal (pop calls) '(?d ?u t nil))) - (should (equal (pop calls) '(?a ?q t "fool!*@*"))) - (should (equal 1 (gethash ?q erc--channel-modes))) - (should (eq t (gethash ?u erc--channel-modes))) - (should (equal erc-channel-modes '("u"))) - (should-not (erc-channel-user-owner-p "bob")) + (ert-info ("Advertised supersedes heuristics") + (setq erc-server-parameters + '(("PREFIX" . "(ov)@+") + ;; Add phony 5th type for this CHANMODES value for + ;; robustness in case some server gets creative. + ("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz,FAKE"))) + (erc--update-channel-modes "+qu" "fool!*@*") + (should (equal (pop calls) '(?d ?u t nil))) + (should (equal (pop calls) '(?a ?q t "fool!*@*"))) + (should (equal 1 (gethash ?q erc--channel-modes))) + (should (eq t (gethash ?u erc--channel-modes))) + (should (equal erc-channel-modes '("u"))) + (should-not (erc-channel-user-owner-p "bob")) - ;; Remove fool!*@* from list mode "q". - (erc--update-channel-modes "-uq" "fool!*@*") - (should (equal (pop calls) '(?a ?q nil "fool!*@*"))) - (should (equal (pop calls) '(?d ?u nil nil))) - (should-not (gethash ?u erc--channel-modes)) - (should-not erc-channel-modes) - (should (equal 0 (gethash ?q erc--channel-modes)))) + ;; Remove fool!*@* from list mode "q". + (erc--update-channel-modes "-uq" "fool!*@*") + (should (equal (pop calls) '(?a ?q nil "fool!*@*"))) + (should (equal (pop calls) '(?d ?u nil nil))) + (should-not (gethash ?u erc--channel-modes)) + (should-not erc-channel-modes) + (should (equal 0 (gethash ?q erc--channel-modes)))) - (should-not calls)))) + (should-not calls) + (advice-remove 'erc--handle-channel-mode 'erc-tests-spy))) (ert-deftest erc--channel-modes () ;; Only mark :unstable when running locally. diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el index f78ad80c43b..b161ea17305 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-tests.el +++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el @@ -1221,7 +1221,7 @@ DIALOGS are symbols representing the base names of dialog files in (proc (apply #'start-process args))) (set-process-query-on-exit-flag proc nil) (with-current-buffer buffer - (erc-d-t-search-for 5 "Starting") + (erc-d-t-search-for 10 "Starting") (search-forward " (") (backward-char)) (let ((pair (read buffer))) diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 7a68e637653..fc826aba8d4 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -1256,6 +1256,10 @@ delivered." :tags '(:expensive-test) (skip-unless (file-notify--test-local-enabled)) + (let ((file-notify-debug ;; Temporarily. + (or file-notify-debug + (getenv "EMACS_EMBA_CI")))) + (with-file-notify-test (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) (should @@ -1334,7 +1338,7 @@ delivered." (file-notify--rm-descriptor file-notify--test-desc) ;; The environment shall be cleaned up. - (file-notify--test-cleanup-p)))) + (file-notify--test-cleanup-p))))) (file-notify--deftest-remote file-notify-test08-backup "Check that backup keeps file notification for remote files.") diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 3490bebd8d6..53ce1929cad 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -28,6 +28,10 @@ (defvar dbus-debug) (defvar dbus-message-type-signal) (declare-function dbus-get-unique-name "dbusbind.c" (bus)) +(declare-function dbus-close-inhibitor-lock "dbusbind.c" (lock)) +(declare-function dbus-registered-inhibitor-locks "dbusbind.c" ()) +(declare-function dbus-make-inhibitor-lock "dbusbind.c" + (what why &optional block)) (defconst dbus--test-enabled-session-bus (and (featurep 'dbusbind) @@ -48,6 +52,15 @@ (defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" "Test interface.") +(defconst dbus--test-systemd-service "org.freedesktop.login1" + "Systemd service.") + +(defconst dbus--test-systemd-path "/org/freedesktop/login1" + "Systemd object path.") + +(defconst dbus--test-systemd-manager-interface "org.freedesktop.login1.Manager" + "Systemd Manager interface.") + (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) @@ -607,6 +620,7 @@ This includes initialization and closing the bus." (let ((method1 "Method1") (method2 "Method2") (handler #'dbus--test-method-handler) + dbus-debug ; There would be errors otherwise. registered) ;; The service is not registered yet. @@ -759,6 +773,7 @@ Returns the respective error." (unwind-protect (let ((method "Method") (handler #'dbus--test-method-authorizable-handler) + dbus-debug ; There would be errors otherwise. registered) ;; Register. @@ -850,7 +865,7 @@ Returns the respective error." (dbus-event-path-name dbus--test-event-expected)) (equal (dbus-event-member-name last-input-event) (dbus-event-member-name dbus--test-event-expected)))) - (setq dbus--test-signal-received args))))) + (push args dbus--test-signal-received))))) (defun dbus--test-timeout-handler (&rest _ignore) "Timeout handler, reporting a failed test." @@ -885,7 +900,7 @@ Returns the respective error." (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) - (should (equal dbus--test-signal-received '("foo"))) + (should (equal dbus--test-signal-received '(("foo")))) ;; Send two arguments, compound types. (setq dbus--test-signal-received nil) @@ -896,7 +911,7 @@ Returns the respective error." (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) - (should (equal dbus--test-signal-received '((1 2 3) ("bar")))) + (should (equal dbus--test-signal-received '(((1 2 3) ("bar"))))) ;; Unregister signal. (should (dbus-unregister-object registered)) @@ -905,6 +920,86 @@ Returns the respective error." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) +(defun dbus--test-signal-handler1 (&rest args) + "Signal handler for `dbus-test05-register-signal-several-handlers'." + ;; (message "dbus--test-signal-handler1 %S" last-input-event) + (dbus--test-signal-handler (cons "dbus--test-signal-handler1" args))) + +(defun dbus--test-signal-handler2 (&rest args) + "Signal handler for `dbus-test05-register-signal-several-handlers'." + ;; (message "dbus--test-signal-handler2 %S" last-input-event) + (dbus--test-signal-handler (cons "dbus--test-signal-handler2" args))) + +(ert-deftest dbus-test05-register-signal-several-handlers () + "Check signal registration for an own service. +It shall call several handlers per received signal." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((member "Member") + (handler1 #'dbus--test-signal-handler1) + (handler2 #'dbus--test-signal-handler2) + registered1 registered2) + + ;; Register signal handlers. + (should + (equal + (setq + registered1 + (dbus-register-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member handler1)) + `((:signal :session ,dbus--test-interface ,member) + (,dbus--test-service ,dbus--test-path ,handler1)))) + (should + (equal + (setq + registered2 + (dbus-register-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member handler2)) + `((:signal :session ,dbus--test-interface ,member) + (,dbus--test-service ,dbus--test-path ,handler2)))) + + ;; Send one argument, basic type. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member "foo") + (with-timeout (1 (dbus--test-timeout-handler)) + (while (length< dbus--test-signal-received 2) + (read-event nil nil 0.1))) + (should + (member + '(("dbus--test-signal-handler1" "foo")) dbus--test-signal-received)) + (should + (member + '(("dbus--test-signal-handler2" "foo")) dbus--test-signal-received)) + + ;; Unregister one signal. + (should (dbus-unregister-object registered1)) + (should-not (dbus-unregister-object registered1)) + + ;; Send one argument, basic type. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member "foo") + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should + (equal + dbus--test-signal-received '((("dbus--test-signal-handler2" "foo"))))) + + ;; Unregister the other signal. + (should (dbus-unregister-object registered2)) + (should-not (dbus-unregister-object registered2))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + (ert-deftest dbus-test05-register-signal-with-nils () "Check signal registration for an own service. SERVICE, PATH, INTERFACE and SIGNAL are ‘nil’. This is interpreted as a @@ -956,7 +1051,7 @@ wildcard for the respective argument." (with-timeout (1 (dbus--test-timeout-handler)) (while (null dbus--test-signal-received) (read-event nil nil 0.1))) - (should (equal dbus--test-signal-received '("foo"))) + (should (equal dbus--test-signal-received '(("foo")))) ;; Unregister signal. (should (dbus-unregister-object registered)) @@ -1317,7 +1412,7 @@ wildcard for the respective argument." ;; "invalidated_properties" (an array of strings). (should (equal dbus--test-signal-received - `(,dbus--test-interface ((,property ("foo"))) ()))) + `((,dbus--test-interface ((,property ("foo"))) ())))) (should (equal @@ -1341,7 +1436,7 @@ wildcard for the respective argument." (should (equal dbus--test-signal-received - `(,dbus--test-interface ((,property ((1 2 3)))) ()))) + `((,dbus--test-interface ((,property ((1 2 3)))) ())))) (should (equal @@ -2213,6 +2308,90 @@ The argument EXPECTED-ARGS is a list of expected arguments for the method." ;; Cleanup. (dbus-unregister-service :session dbus--test-service))) +(ert-deftest dbus-test10-inhibitor-locks () + "Check `dbus-*-inhibitor-locks'." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-system-bus) + (skip-unless (dbus-ping :system dbus--test-systemd-service 1000)) + + (let (lock1 lock2) + ;; Create inhibitor lock. + (setq lock1 (dbus-make-inhibitor-lock "sleep" "Test delay")) + (should (natnump lock1)) + ;; The lock is reported by systemd. + (should + (member + (list "sleep" "Emacs" "Test delay" "delay" (user-uid) (emacs-pid)) + (dbus-call-method + :system dbus--test-systemd-service dbus--test-systemd-path + dbus--test-systemd-manager-interface "ListInhibitors"))) + ;; The lock is registered internally. + (should + (member + (list lock1 "sleep" "Test delay" nil) + (dbus-registered-inhibitor-locks))) + ;; There exist a file descriptor. + (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) + (should (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock1)))) + + ;; It is not possible to modify registered inhibitor locks on Lisp level. + (setcar (assoc lock1 (dbus-registered-inhibitor-locks)) 'malicious) + (should (assoc lock1 (dbus-registered-inhibitor-locks))) + (should-not (assoc 'malicious (dbus-registered-inhibitor-locks))) + + ;; Creating it again returns the same inhibitor lock. + (should (= lock1 (dbus-make-inhibitor-lock "sleep" "Test delay"))) + + ;; Create another inhibitor lock. + (setq lock2 (dbus-make-inhibitor-lock "sleep" "Test block" 'block)) + (should (natnump lock2)) + (should-not (= lock1 lock2)) + ;; The lock is reported by systemd. + (should + (member + (list "sleep" "Emacs" "Test block" "block" (user-uid) (emacs-pid)) + (dbus-call-method + :system dbus--test-systemd-service dbus--test-systemd-path + dbus--test-systemd-manager-interface "ListInhibitors"))) + ;; The lock is registered internally. + (should + (member + (list lock2 "sleep" "Test block" t) + (dbus-registered-inhibitor-locks))) + ;; There exist a file descriptor. + (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) + (should (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock2)))) + + ;; Close the first inhibitor lock. + (should (dbus-close-inhibitor-lock lock1)) + ;; The internal registration has gone. + (should-not + (member + (list lock1 "sleep" "Test delay" nil) + (dbus-registered-inhibitor-locks))) + ;; The file descriptor has been deleted. + (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) + (should-not (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock1)))) + + ;; Closing it again is a noop. + (should-not (dbus-close-inhibitor-lock lock1)) + + ;; Creating it again returns (another?) inhibitor lock. + (setq lock1 (dbus-make-inhibitor-lock "sleep" "Test delay")) + (should (natnump lock1)) + ;; The lock is registered internally. + (should + (member + (list lock1 "sleep" "Test delay" nil) + (dbus-registered-inhibitor-locks))) + ;; There exist a file descriptor. + (when (file-directory-p (format "/proc/%d/fd" (emacs-pid))) + (should (file-symlink-p (format "/proc/%d/fd/%d" (emacs-pid) lock1)))) + + ;; Close the inhibitor locks. + (should (dbus-close-inhibitor-lock lock1)) + (should (dbus-close-inhibitor-lock lock2)))) + (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index cb8253e66f6..bbfe15d2f59 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2145,6 +2145,7 @@ being the result.") (ert-deftest tramp-test03-file-name-defaults () "Check default values for some methods." + :tags '(:expensive-test) (skip-unless (eq tramp-syntax 'default)) ;; Default values in tramp-adb.el. @@ -2158,9 +2159,8 @@ being the result.") (string-equal (file-remote-p (format "/-:%s@:" u) 'method) "ftp")))) ;; Default values in tramp-sh.el and tramp-sudoedit.el. (when (assoc "su" tramp-methods) - (dolist - (h `("127.0.0.1" "[::1]" "localhost" "localhost4" "localhost6" - "ip6-localhost" "ip6-loopback" ,(system-name))) + ;; "::1" is used as "[::1]" in remote file names. + (dolist (h (cons "[::1]" (delete "::1" tramp-local-host-names))) (should (string-equal (file-remote-p (format "/-:root@%s:" h) 'method) "su")))) (dolist (m '("su" "sudo" "ksu" "doas" "sudoedit")) @@ -2802,6 +2802,7 @@ This checks also `file-name-as-directory', `file-name-directory', ;; The following test is inspired by Bug#35497. (ert-deftest tramp-test10-write-region-file-precious-flag () "Check that `file-precious-flag' is respected with Tramp in use." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) @@ -2835,6 +2836,7 @@ This checks also `file-name-as-directory', `file-name-directory', ;; The following test is inspired by Bug#55166. (ert-deftest tramp-test10-write-region-other-file-name-handler () "Check that another file name handler in VISIT is acknowledged." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) (skip-unless (executable-find "gzip")) @@ -3445,6 +3447,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; advice for older Emacs versions, so we check that this has been fixed. (ert-deftest tramp-test16-file-expand-wildcards () "Check `file-expand-wildcards'." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) @@ -3592,6 +3595,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ert-deftest tramp-test17-dired-with-wildcards () "Check `dired' with wildcards." + :tags '(:expensive-test) ;; `separate' syntax and IPv6 host name syntax do not work. (skip-unless (not (string-match-p (rx "[") ert-remote-temporary-file-directory))) @@ -3709,6 +3713,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; The following test is inspired by Bug#45691. (ert-deftest tramp-test17-insert-directory-one-file () "Check `insert-directory' inside directory listing." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) ;; Relative file names in dired are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) @@ -5055,7 +5060,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (dolist (elt (append - (mapcar #'intern (all-completions "tramp-" obarray #'functionp)) + (apropos-internal (rx bos "tramp-") #'functionp) '(completion-file-name-table read-file-name))) (unless (get elt 'tramp-suppress-trace) (trace-function-background elt)))) @@ -6499,6 +6504,7 @@ INPUT, if non-nil, is a string sent to the process." ;; This test is inspired by Bug#27009. (ert-deftest tramp-test33-environment-variables-and-port-numbers () "Check that two connections with separate ports are different." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) ;; We test it only for the mock-up connection; otherwise there might ;; be problems with the used ports. @@ -6708,6 +6714,7 @@ INPUT, if non-nil, is a string sent to the process." ;; This test is inspired by Bug#33781. (ert-deftest tramp-test35-remote-path () "Check loooong `tramp-remote-path'." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) @@ -7135,6 +7142,7 @@ INPUT, if non-nil, is a string sent to the process." (ert-deftest tramp-test39-make-lock-file-name () "Check `make-lock-file-name', `lock-file', `unlock-file' and `file-locked-p'." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) @@ -7296,6 +7304,7 @@ INPUT, if non-nil, is a string sent to the process." (ert-deftest tramp-test39-detect-external-change () "Check that an external file modification is reported." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) @@ -7936,6 +7945,7 @@ This requires restrictions of file name syntax." (ert-deftest tramp-test42-utf8 () "Check UTF8 encoding in file names and file contents." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-container-p))) (skip-unless (not (tramp--test-rsync-p))) @@ -8006,6 +8016,7 @@ This requires restrictions of file name syntax." (ert-deftest tramp-test43-file-system-info () "Check that `file-system-info' returns proper values." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (when-let* ((fsi (file-system-info ert-remote-temporary-file-directory))) @@ -8019,6 +8030,7 @@ This requires restrictions of file name syntax." "Check results of user/group functions. `file-user-uid', `file-group-gid', and `tramp-get-remote-*' should all return proper values." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (let ((default-directory ert-remote-temporary-file-directory)) @@ -8247,6 +8259,42 @@ process sentinels. They shall not disturb each other." ;; (tramp--test-deftest-direct-async-process tramp-test45-asynchronous-requests ;; 'unstable) +;; This test is inspired by Bug#49954 and Bug#60534. +(ert-deftest tramp-test45-force-remote-file-error () + "Force `remote-file-error'." + :tags '(:expensive-test :tramp-asynchronous-processes :unstable) + ;; It shall run only if selected explicitly. + (skip-unless + (eq (ert--stats-selector ert--current-run-stats) + (ert-test-name (ert--stats-current-test ert--current-run-stats)))) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + + (let ((default-directory ert-remote-temporary-file-directory) + ;; Do not cache Tramp properties. + (remote-file-name-inhibit-cache t) + (p (start-file-process-shell-command + "test" (generate-new-buffer "test" 'inhibit-buffer-hooks) + "while true; do echo test; sleep 0.2; done"))) + + (set-process-filter + p (lambda (&rest _) + (message "filter %s" default-directory) + (directory-files default-directory) + (dired-uncache default-directory))) + + (run-at-time + 0 0.2 (lambda () + (message "timer %s" default-directory) + (directory-files default-directory) + (dired-uncache default-directory))) + + (while t + (accept-process-output) + (message "main %s" default-directory) + (directory-files default-directory) + (dired-uncache default-directory)))) + (ert-deftest tramp-test46-dired-compress-file () "Check that Tramp (un)compresses normal files." (skip-unless (tramp--test-enabled)) @@ -8623,6 +8671,7 @@ process sentinels. They shall not disturb each other." ;; This test is inspired by Bug#78572. (ert-deftest tramp-test48-session-timeout () "Check that Tramp handles a session timeout properly." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) @@ -8703,6 +8752,7 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test49-external-backend-function () "Check that Tramp handles external functions for a given backend." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) @@ -8847,6 +8897,7 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test50-recursive-load () "Check that Tramp does not fail due to recursive load." + :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (let ((default-directory (expand-file-name temporary-file-directory))) diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index ac6fd5174bb..7267754dc7d 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -238,39 +238,47 @@ directory hierarchy." ,@body) (remove-hook 'jsonrpc-event-hook #',log-event-hook-sym)))))) -(cl-defmacro eglot--wait-for ((events-sym &optional (timeout 1) message) args &body body) +(cl-defmacro eglot--wait-for ((events-sym &optional (timeout 1) message) + args &body body) (declare (indent 2) (debug (sexp sexp sexp &rest form))) - `(eglot--with-timeout '(,timeout ,(or message - (format "waiting for:\n%s" (pp-to-string body)))) + `(eglot--with-timeout '(,timeout + ,(or message + (format "waiting for:\n%s" (pp-to-string body)))) (eglot--test-message "waiting for `%s'" (with-output-to-string (mapc #'princ ',body))) - (let ((events - (cl-loop thereis (cl-loop for json in ,events-sym - for method = (plist-get json :method) - when (keywordp method) - do (plist-put json :method - (substring - (symbol-name method) - 1)) - when (funcall - (jsonrpc-lambda ,args ,@body) json) - return (cons json before) - collect json into before) - for i from 0 - when (zerop (mod i 5)) - ;; do (eglot--test-message "still struggling to find in %s" - ;; ,events-sym) - do - ;; `read-event' is essential to have the file - ;; watchers come through. - (cond ((fboundp 'flush-standard-output) - (read-event nil nil 0.1) (princ ".") - (flush-standard-output)) - (t - (read-event "." nil 0.1))) - (accept-process-output nil 0.1)))) - (setq ,events-sym (cdr events)) - (cl-destructuring-bind (&key method id &allow-other-keys) (car events) + (let ((probe + (cl-loop + thereis + (cl-loop for (json . tail) on ,events-sym + for method = (plist-get json :method) + when (keywordp method) + do (plist-put + json :method (substring (symbol-name method) 1)) + when (funcall (jsonrpc-lambda ,args ,@body) json) + return json + do + (unless + ;; $/progress is *truly* uninteresting and spammy + (string-match "\\$/progress" (format "%s" method)) + (eglot--test-message + "skip uninteresting event %s[%s]" + (plist-get json :method) + (plist-get json :id))) + finally (setq ,events-sym tail)) + for i from 0 + when (zerop (mod i 5)) + ;; do (eglot--test-message "still struggling to find in %s" + ;; ,events-sym) + do + ;; `read-event' is essential to have the file + ;; watchers come through. + (cond ((fboundp 'flush-standard-output) + (read-event nil nil 0.1) (princ ".") + (flush-standard-output)) + (t + (read-event "." nil 0.1))) + (accept-process-output nil 0.1)))) + (cl-destructuring-bind (&key method id &allow-other-keys) probe (eglot--test-message "detected: %s" (or method (and id (format "id=%s" id)))))))) @@ -286,10 +294,13 @@ directory hierarchy." (define-derived-mode typescript-mode prog-mode "TypeScript") (add-to-list 'auto-mode-alist '("\\.ts\\'" . typescript-mode))) -(defun eglot--tests-connect (&optional timeout) +(cl-defun eglot--tests-connect (&key timeout server) (let* ((timeout (or timeout 10)) (eglot-sync-connect t) - (eglot-connect-timeout timeout)) + (eglot-connect-timeout timeout) + (eglot-server-programs + (if server `((,major-mode . ,(split-string server))) + eglot-server-programs))) (apply #'eglot--connect (eglot--guess-contact)))) (defun eglot--simulate-key-event (char) @@ -317,7 +328,7 @@ directory hierarchy." (with-current-buffer (eglot--find-file-noselect "project/src/main/java/foo/Main.java") (eglot--sniffing (:server-notifications s-notifs) - (should (eglot--tests-connect 20)) + (should (eglot--tests-connect :timeout 20)) (eglot--wait-for (s-notifs 10) (&key _id method &allow-other-keys) (string= method "language/status")))))) @@ -431,15 +442,69 @@ directory hierarchy." (with-current-buffer (eglot--find-file-noselect "diag-project/main.c") (eglot--sniffing (:server-notifications s-notifs) - (eglot--tests-connect) - (eglot--wait-for (s-notifs 10) - (&key _id method &allow-other-keys) - (string= method "textDocument/publishDiagnostics")) + (eglot--tests-connect :server "clangd") (flymake-start) + (eglot--wait-for (s-notifs 10) + (&key method &allow-other-keys) + (string= method "textDocument/publishDiagnostics")) (goto-char (point-min)) (flymake-goto-next-error 1 '() t) (should (eq 'flymake-error (face-at-point))))))) +(ert-deftest eglot-test-basic-pull-diagnostics () + "Test basic diagnostics." + (skip-unless (executable-find "ty")) + (eglot--with-fixture + `(("diag-project" . + (("main.py" . "def main:\npuss")))) + (with-current-buffer + (eglot--find-file-noselect "diag-project/main.py") + (eglot--sniffing (:server-replies s-replies) + (eglot--tests-connect :server "ty server") + (flymake-start) + (eglot--wait-for (s-replies 5) + (&key _id method &allow-other-keys) + (string= method "textDocument/diagnostic")) + (goto-char (point-min)) + (flymake-goto-next-error 1 '() t) + (should (eq 'flymake-error (face-at-point))))))) + +(ert-deftest eglot-test-basic-stream-diagnostics () + "Test basic diagnostics." + (skip-unless (executable-find "rass")) + (skip-unless (executable-find "ruff")) + (skip-unless (executable-find "ty")) + (eglot--with-fixture + `(("diag-project" . + (("main.py" . "from lib import greet\ndef main():\n greet()") + ("lib.py" . "def geet():\n print('hello')")))) + (set-buffer (eglot--find-file-noselect "diag-project/main.py")) + (eglot--sniffing (:server-notifications s-notifs) + (eglot--tests-connect :server "rass -- ty server -- ruff server") + (flymake-start) + (cl-loop repeat 2 ;; 2 stream notifs for 2 rass servers + do (eglot--wait-for (s-notifs 5) + (&key method &allow-other-keys) + (string= method "$/streamDiagnostics"))) + (goto-char (point-min)) + (flymake-goto-next-error 1 '() t) + (should (eq 'flymake-error (face-at-point)))) + + ;; Now fix it + (set-buffer (eglot--find-file-noselect "lib.py")) + (search-forward "geet") + (replace-match "greet") + (eglot--sniffing (:server-notifications s-notifs) + (eglot--signal-textDocument/didChange) + (set-buffer (eglot--find-file-noselect "main.py")) + (flymake-start) + (cl-loop repeat 2 + do (eglot--wait-for (s-notifs 5) + (&key method &allow-other-keys) + (string= method "$/streamDiagnostics"))) + (goto-char (point-min)) + (should-error (flymake-goto-next-error 1 '() t))))) + (ert-deftest eglot-test-basic-symlink () "Test basic symlink support." (skip-unless (executable-find "clangd")) @@ -710,7 +775,7 @@ directory hierarchy." ;; This originally appeared in github#1339 (skip-unless (executable-find "rust-analyzer")) (skip-unless (executable-find "cargo")) - (skip-when (getenv "EMACS_EMBA_CI")) + (skip-unless (not (getenv "EMACS_EMBA_CI"))) (eglot--with-fixture '(("cmpl-project" . (("main.rs" . @@ -1069,7 +1134,7 @@ int main() { (let ((eglot-sync-connect t) (eglot-server-programs `((c-mode . ("sh" "-c" "sleep 1 && clangd"))))) - (should (eglot--tests-connect 3)))))) + (should (eglot--tests-connect :timeout 3)))))) (ert-deftest eglot-test-slow-sync-connection-intime () "Connect synchronously with `eglot-sync-connect' set to 2." @@ -1081,7 +1146,7 @@ int main() { (let ((eglot-sync-connect 2) (eglot-server-programs `((c-mode . ("sh" "-c" "sleep 1 && clangd"))))) - (should (eglot--tests-connect 3)))))) + (should (eglot--tests-connect :timeout 3)))))) (ert-deftest eglot-test-slow-async-connection () "Connect asynchronously with `eglot-sync-connect' set to 2." @@ -1511,7 +1576,14 @@ GUESSED-MAJOR-MODES-SYM are bound to the useful return values of '(3 "Timeout waiting for semantic tokens") (while (not (save-excursion (goto-char pos) - (text-property-search-forward 'eglot--semtok-faces))) + (cl-loop + for from = (point) then to + while (< from (point-max)) + for faces = (get-text-property from 'eglot--semtok-faces) + for to = (or (next-single-property-change + from 'eglot--semtok-faces) + (point-max)) + when faces return t))) (accept-process-output nil 0.1) (font-lock-ensure)))) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 311d60dae18..8211347ba11 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -407,7 +407,7 @@ to (xref-elisp-test-descr-to-target xref)." ;; cl-defstruct location. (list (cons - (xref-make "(cl-defstruct (xref-elisp-location (:constructor xref-make-elisp-location)))" + (xref-make "(cl-defstruct xref-elisp-location (:constructor xref-make-elisp-location))" (xref-make-elisp-location 'xref-elisp-location 'define-type (expand-file-name "../../../lisp/progmodes/elisp-mode.el" emacs-test-dir))) diff --git a/test/lisp/progmodes/json-ts-mode-tests.el b/test/lisp/progmodes/json-ts-mode-tests.el new file mode 100644 index 00000000000..4fe4582f2f1 --- /dev/null +++ b/test/lisp/progmodes/json-ts-mode-tests.el @@ -0,0 +1,86 @@ +;;; json-ts-mode-tests.el --- Tests for json-ts-mode.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 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 . + +;;; Commentary: + +;; Tests for json-ts-mode. + +;;; Code: + +(require 'ert) +(require 'treesit) +(require 'json-ts-mode) + +(ert-deftest json-ts-mode-test-path-at-point () + "Test `json-ts--get-path-at-node' and `json-ts--path-to-jq'." + (skip-unless (treesit-language-available-p 'json)) + (with-temp-buffer + (json-ts-mode) + (insert "{\"a\": [1, {\"b\": 2}, 3]}") + + ;; Point at '1' (index 0 of array 'a') + (goto-char (point-min)) + (search-forward "1") + (backward-char) + (should (equal (json-ts--path-to-jq (json-ts--get-path-at-node (treesit-node-at (point)))) + ".a[0]")) + + ;; Point at '2' (key 'b' inside object at index 1) + (goto-char (point-min)) + (search-forward "2") + (backward-char) + (should (equal (json-ts--path-to-jq (json-ts--get-path-at-node (treesit-node-at (point)))) + ".a[1].b")) + + ;; Point at '3' (index 2 of array 'a') + (goto-char (point-min)) + (search-forward "3") + (backward-char) + (should (equal (json-ts--path-to-jq (json-ts--get-path-at-node (treesit-node-at (point)))) + ".a[2]")))) + +(ert-deftest json-ts-mode-test-path-at-point-complex-keys () + "Test path generation with complex keys." + (skip-unless (treesit-language-available-p 'json)) + (with-temp-buffer + (json-ts-mode) + (insert "{\"key.with.dot\": {\"key with space\": 1}}") + + (goto-char (point-min)) + (search-forward "1") + (backward-char) + (should (equal (json-ts--path-to-jq (json-ts--get-path-at-node (treesit-node-at (point)))) + "[\"key.with.dot\"][\"key with space\"]")))) + +(ert-deftest json-ts-mode-test-jq-path-keys () + "Test `json-ts--path-to-jq' with various key formats." + (should (equal (json-ts--path-to-jq '("v123")) ".v123")) + (should (equal (json-ts--path-to-jq '("-123")) "[\"-123\"]")) + (should (equal (json-ts--path-to-jq '("v_v")) ".v_v")) + (should (equal (json-ts--path-to-jq '("123")) "[\"123\"]")) + (should (equal (json-ts--path-to-jq '("_123")) "._123")) + (should (equal (json-ts--path-to-jq '("1v2")) "[\"1v2\"]"))) + +(ert-deftest json-ts-mode-test-path-to-python () + "Test `json-ts--path-to-python'." + (should (equal (json-ts--path-to-python '("a" 0 "b")) + "[\"a\"][0][\"b\"]"))) + +(provide 'json-ts-mode-tests) +;;; json-ts-mode-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 7aabc6ce6c8..4d9237f08b6 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1609,6 +1609,36 @@ final or penultimate step during initialization.")) '("A" "B" "C"))) ) +(ert-deftest subr-string-trim-left () + (should (equal (string-trim-left "") "")) + (should (equal (string-trim-left " \t\n\r") "")) + (should (equal (string-trim-left " \t\n\ra") "a")) + (should (equal (string-trim-left "a \t\n\r") "a \t\n\r")) + (should (equal (string-trim-left "" "") "")) + (should (equal (string-trim-left "a" "") "a")) + (should (equal (string-trim-left "aa" "a*") "")) + (should (equal (string-trim-left "ba" "a*") "ba")) + (should (equal (string-trim-left "aa" "a*?") "aa")) + (should (equal (string-trim-left "aa" "a+?") "a"))) + +(ert-deftest subr-string-trim-right () + (should (equal (string-trim-right "") "")) + (should (equal (string-trim-right " \t\n\r") "")) + (should (equal (string-trim-right " \t\n\ra") " \t\n\ra")) + (should (equal (string-trim-right "a \t\n\r") "a")) + (should (equal (string-trim-right "" "") "")) + (should (equal (string-trim-right "a" "") "a")) + (should (equal (string-trim-right "aa" "a*") "")) + (should (equal (string-trim-right "ab" "a*") "ab")) + (should (equal (string-trim-right "aa" "a*?") ""))) + +(ert-deftest subr-string-trim () + (should (equal (string-trim " \t\r abc\t\n \t") "abc")) + (should (equal (string-trim "::abc;;" nil nil) "::abc;;")) + (should (equal (string-trim "::abc;;" nil ";+") "::abc")) + (should (equal (string-trim "::abc;;" ":+" nil) "abc;;")) + (should (equal (string-trim "::abc;;" ":+" ";+") "abc"))) + (defun subr--identity (x) x) (ert-deftest subr-drop-while () @@ -1664,5 +1694,20 @@ final or penultimate step during initialization.")) (should (equal (funcall (subr--identity #'any) #'minusp ls) '(-1 -2 -3))) (should (equal (funcall (subr--identity #'any) #'stringp ls) nil)))) +(ert-deftest total-line-spacing () + (progn + (let ((line-spacing 10)) + (should (equal (total-line-spacing) line-spacing) )) + (let ((line-spacing 0.8)) + (should (equal (total-line-spacing) 0.8))) + (let ((line-spacing '(10 . 5))) + (should (equal (total-line-spacing) 15))) + (let ((line-spacing '(0.3 . 0.4))) + (should (equal (total-line-spacing) 0.7))) + (should (equal (total-line-spacing 10) 10)) + (should (equal (total-line-spacing 0.3) 0.3)) + (should (equal (total-line-spacing '(1 . 3)) 4)) + (should (equal (total-line-spacing '(0.1 . 0.1 )) 0.2)))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/textmodes/ispell-tests/ispell-tests.el b/test/lisp/textmodes/ispell-tests/ispell-tests.el index 15687ed6f0f..95f88be3b51 100644 --- a/test/lisp/textmodes/ispell-tests/ispell-tests.el +++ b/test/lisp/textmodes/ispell-tests/ispell-tests.el @@ -779,6 +779,11 @@ hunspell. Hence skipping." (ispell-tests--letopt ((ispell-program-name (ispell-tests--some-backend))) + (ispell-check-version) + (if (and ispell-really-aspell + (equal ispell-program-name "ispell")) + ;; Don't let Aspell hide its true nature. + (setq ispell-program-name "aspell")) (let ((test-dictname (ispell-tests--some-valid-dictionary ispell-program-name)) (test-extcharmode "~latin3") (test-parser "~testparser") diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index 0c83e8cc80d..76126c77602 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -434,15 +434,15 @@ say EXPECTED should not be run through `format-time-string'." (do-one (lambda (conv expected reftime) `(,should-fn (time-stamp-test--string-equal - (time-stamp-string ,conv ,reftime) - ,(let ((fmt-form + (time-stamp-string ,conv ,reftime) + ,(let ((fmt-form (if literal expected `(format-time-string ,expected ,reftime time-stamp-time-zone)))) - (dolist (fn filter-list fmt-form) - (setq fmt-form `(funcall ',fn ,fmt-form)))) - )))) + (dolist (fn filter-list fmt-form) + (setq fmt-form `(funcall ',fn ,fmt-form)))) + )))) (result (list 'progn))) (when (memq :literal filter-list) (setq literal t) @@ -784,7 +784,7 @@ This is a separate function so it can have an `ert-explainer' property." (ert-deftest time-stamp-format-letter-case () "Test `time-stamp' upcase and downcase modifiers not tested elsewhere." (with-time-stamp-test-env - (time-stamp-test ("%*^A" "%*#A") "%^A") + (time-stamp-test-AB ("%*^A" "%*#A") "%^A") )) ;;; Tests of helper functions @@ -796,6 +796,30 @@ This is a separate function so it can have an `ert-explainer' property." (time-stamp-string time-stamp-format ref-time1))) (should (equal (time-stamp-string 'not-a-string ref-time1) nil)))) +(ert-deftest time-stamp-helper-string-used () + "Test that `time-stamp' uses `time-stamp-string'." + ;; Because the formatting tests use only time-stamp-string, we + ;; test that time-stamp-string is actually used by time-stamp. + (with-time-stamp-test-env + (let ((time-stamp-format "not the default string used %Y%%") + (ts-string-calls 0)) + (cl-letf (((symbol-function 'time-stamp-string) + (lambda (&optional ts-format _time) + (should (equal ts-format time-stamp-format)) + (incf ts-string-calls) + "tss-res"))) + (with-temp-buffer + ;; no template, no call to time-stamp-string expected + (time-stamp) + (should (= ts-string-calls 0)) + (should (equal (buffer-string) "")) + ;; with template, expect one call + (insert "Time-stamp: <>") + (time-stamp) + (should (= ts-string-calls 1)) + (should (equal (buffer-string) "Time-stamp: ")) + ))))) + (ert-deftest time-stamp-helper-zone-type-p () "Test `time-stamp-zone-type-p'." (should (time-stamp-zone-type-p t)) diff --git a/test/lisp/vc/vc-tests/vc-test-misc.el b/test/lisp/vc/vc-tests/vc-test-misc.el index 6bf0aed46d9..72dc8de22bf 100644 --- a/test/lisp/vc/vc-tests/vc-test-misc.el +++ b/test/lisp/vc/vc-tests/vc-test-misc.el @@ -217,5 +217,30 @@ (should (equal (buffer-string) "foo\n")))) (kill-buffer buf)))) +(ert-deftest vc-test-match-branch-name-regexps () + "Test `vc--match-branch-name-regexps'." + (let ((vc-trunk-branch-regexps '("master" "main"))) + (let ((vc-topic-branch-regexps '("m.*"))) + (should-error (vc--match-branch-name-regexps "master"))) + (let ((vc-topic-branch-regexps '("f" "o"))) + (should (eq (vc--match-branch-name-regexps "master") 'trunk)) + (should (null (vc--match-branch-name-regexps "foo")))) + (let ((vc-topic-branch-regexps '("f.*" "o"))) + (should (eq (vc--match-branch-name-regexps "master") 'trunk)) + (should (eq (vc--match-branch-name-regexps "foo") 'topic))) + (let (vc-topic-branch-regexps) + (should (eq (vc--match-branch-name-regexps "master") 'trunk)) + (should (null (vc--match-branch-name-regexps "foo")))) + (let ((vc-topic-branch-regexps t)) + (should (eq (vc--match-branch-name-regexps "master") 'trunk)) + (should (eq (vc--match-branch-name-regexps "foo") 'topic)))) + (let ((vc-trunk-branch-regexps '(not "master"))) + (let (vc-topic-branch-regexps) + (should (null (vc--match-branch-name-regexps "master"))) + (should (eq (vc--match-branch-name-regexps "foo") 'trunk))) + (let ((vc-topic-branch-regexps t)) + (should (eq (vc--match-branch-name-regexps "master") 'topic)) + (should (eq (vc--match-branch-name-regexps "foo") 'trunk))))) + (provide 'vc-test-misc) ;;; vc-test-misc.el ends here diff --git a/test/lisp/vc/vc-tests/vc-tests.el b/test/lisp/vc/vc-tests/vc-tests.el index 153c48d7bdf..ca79a340a46 100644 --- a/test/lisp/vc/vc-tests/vc-tests.el +++ b/test/lisp/vc/vc-tests/vc-tests.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2014-2026 Free Software Foundation, Inc. ;; Author: Michael Albinus -;; Author: Sean Whitton +;; Sean Whitton ;; This file is part of GNU Emacs. ;; diff --git a/test/manual/etags/CTAGS.good_update b/test/manual/etags/CTAGS.good_update index 22f7a4421e3..2e29a2cb93e 100644 --- a/test/manual/etags/CTAGS.good_update +++ b/test/manual/etags/CTAGS.good_update @@ -607,7 +607,7 @@ FOR_EACH_ALIST_VALUE c-src/emacs/src/lisp.h /^#define FOR_EACH_ALIST_VALUE(head_ FOR_EACH_TAIL c-src/emacs/src/lisp.h /^#define FOR_EACH_TAIL(hare, list, tortoise, n) \\$/ FRAMEP c-src/emacs/src/lisp.h /^FRAMEP (Lisp_Object a)$/ FRC make-src/Makefile /^FRC:;$/ -FREEFLOOD c-src/emacs/src/gmalloc.c 1863 +FREEFLOOD c-src/emacs/src/gmalloc.c 1866 FSRC make-src/Makefile /^FSRC=entry.for entry.strange_suffix entry.strange$/ FUN0 y-src/parse.y /^yylex FUN0()$/ FUN1 y-src/parse.y /^str_to_col FUN1(char **,str)$/ @@ -953,12 +953,12 @@ Lua_help c-src/etags.c 600 Lua_suffixes c-src/etags.c 598 M ruby-src/test1.ru /^module A::M; end$/ MAGENTA cp-src/screen.hpp 17 -MAGICBYTE c-src/emacs/src/gmalloc.c 1861 -MAGICFREE c-src/emacs/src/gmalloc.c 1860 -MAGICWORD c-src/emacs/src/gmalloc.c 1859 +MAGICBYTE c-src/emacs/src/gmalloc.c 1864 +MAGICFREE c-src/emacs/src/gmalloc.c 1863 +MAGICWORD c-src/emacs/src/gmalloc.c 1862 MAKE make-src/Makefile /^MAKE:=$(MAKE) --no-print-directory$/ MAKESRC make-src/Makefile /^MAKESRC=Makefile$/ -MALLOCFLOOD c-src/emacs/src/gmalloc.c 1862 +MALLOCFLOOD c-src/emacs/src/gmalloc.c 1865 MANY c-src/emacs/src/lisp.h 2833 MARKERP c-src/emacs/src/lisp.h /^# define MARKERP(x) lisp_h_MARKERP (x)$/ MAXPATHLEN c-src/etags.c 115 @@ -1734,7 +1734,7 @@ __malloc_extra_blocks c-src/emacs/src/gmalloc.c 382 __malloc_initialize c-src/emacs/src/gmalloc.c /^__malloc_initialize (void)$/ __malloc_initialized c-src/emacs/src/gmalloc.c 380 __repr__ pyt-src/server.py /^ def __repr__(self):$/ -__sbrk c-src/emacs/src/gmalloc.c 1516 +__sbrk c-src/emacs/src/gmalloc.c 1518 __str__ pyt-src/server.py /^ def __str__(self):$/ __up c.c 160 _aligned_blocks c-src/emacs/src/gmalloc.c 1006 @@ -1869,7 +1869,7 @@ align c-src/emacs/src/gmalloc.c /^align (size_t size)$/ alignas c-src/emacs/src/lisp.h /^# define alignas(alignment) \/* empty *\/$/ aligned c-src/emacs/src/gmalloc.c 199 aligned_alloc c-src/emacs/src/gmalloc.c /^aligned_alloc (size_t alignment, size_t size)$/ -aligned_alloc c-src/emacs/src/gmalloc.c 1722 +aligned_alloc c-src/emacs/src/gmalloc.c 1725 aligned_alloc c-src/emacs/src/gmalloc.c 71 alignlist c-src/emacs/src/gmalloc.c 196 alive cp-src/conway.hpp 7 @@ -2073,7 +2073,7 @@ cacheLRUEntry_s c.c 172 cacheLRUEntry_t c.c 177 calculate_goal_info merc-src/accumulator.m /^:- pred calculate_goal_info(hlds_goal_expr::in, hl/ calloc c-src/emacs/src/gmalloc.c /^calloc (size_t nmemb, size_t size)$/ -calloc c-src/emacs/src/gmalloc.c 1721 +calloc c-src/emacs/src/gmalloc.c 1724 calloc c-src/emacs/src/gmalloc.c 66 calloc c-src/emacs/src/gmalloc.c 70 can_be_null c-src/emacs/src/regex.h 370 @@ -2703,7 +2703,7 @@ frag c-src/emacs/src/gmalloc.c 152 frame_local c-src/emacs/src/lisp.h 2341 free c-src/emacs/src/gmalloc.c /^free (void *ptr)$/ free c-src/emacs/src/gmalloc.c 166 -free c-src/emacs/src/gmalloc.c 1723 +free c-src/emacs/src/gmalloc.c 1726 free c-src/emacs/src/gmalloc.c 67 free c-src/emacs/src/gmalloc.c 72 free_fdesc c-src/etags.c /^free_fdesc (register fdesc *fdp)$/ @@ -2814,7 +2814,7 @@ hash_table_test c-src/emacs/src/lisp.h 1805 hashfn c-src/emacs/src/lisp.h /^ EMACS_UINT (*hashfn) (struct hash_table_test *t,/ hat tex-src/texinfo.tex /^\\def\\hat{\\realbackslash hat}$/ hat tex-src/texinfo.tex /^\\def\\hat{\\realbackslash hat}%$/ -hdr c-src/emacs/src/gmalloc.c 1865 +hdr c-src/emacs/src/gmalloc.c 1868 head_table c-src/emacs/src/keyboard.c 11027 header c-src/emacs/src/lisp.h 1371 header c-src/emacs/src/lisp.h 1388 @@ -3244,7 +3244,7 @@ mach_task_self c-src/machsyscalls.h /^SYSCALL (mach_task_self, -28,$/ mach_thread_self c-src/machsyscalls.h /^SYSCALL (mach_thread_self, -27,$/ macheader tex-src/texinfo.tex /^\\def\\defmac{\\defparsebody\\Edefmac\\defmacx\\defmache/ macx\defmacheader tex-src/texinfo.tex /^\\def\\defmac{\\defparsebody\\Edefmac\\defmacx\\defmache/ -magic c-src/emacs/src/gmalloc.c 1868 +magic c-src/emacs/src/gmalloc.c 1871 mainmagstep tex-src/texinfo.tex /^\\let\\mainmagstep=\\magstep1$/ mainmagstep tex-src/texinfo.tex /^\\let\\mainmagstep=\\magstephalf$/ maintaining.info make-src/Makefile /^maintaining.info: maintaining.texi$/ @@ -3272,7 +3272,7 @@ make_uninit_sub_char_table c-src/emacs/src/lisp.h /^make_uninit_sub_char_table ( make_uninit_vector c-src/emacs/src/lisp.h /^make_uninit_vector (ptrdiff_t size)$/ malloc c-src/emacs/src/gmalloc.c /^extern void *malloc (size_t size) ATTRIBUTE_MALLOC/ malloc c-src/emacs/src/gmalloc.c /^malloc (size_t size)$/ -malloc c-src/emacs/src/gmalloc.c 1719 +malloc c-src/emacs/src/gmalloc.c 1722 malloc c-src/emacs/src/gmalloc.c 64 malloc c-src/emacs/src/gmalloc.c 68 malloc_atfork_handler_child c-src/emacs/src/gmalloc.c /^malloc_atfork_handler_child (void)$/ @@ -3305,7 +3305,7 @@ maybe_gc c-src/emacs/src/lisp.h /^maybe_gc (void)$/ mcCSC cp-src/c.C 6 mcheck c-src/emacs/src/gmalloc.c /^mcheck (void (*func) (enum mcheck_status))$/ mcheck_status c-src/emacs/src/gmalloc.c 283 -mcheck_used c-src/emacs/src/gmalloc.c 2017 +mcheck_used c-src/emacs/src/gmalloc.c 2020 mdbcomp merc-src/accumulator.m /^:- import_module mdbcomp.$/ me22b lua-src/test.lua /^ local function test.me22b (one)$/ me_22a lua-src/test.lua /^ function test.me_22a(one, two)$/ @@ -3639,7 +3639,7 @@ pagealignmacro tex-src/texinfo.tex /^\\global\\let\\pagealignmacro=\\chappager$/ pagealignmacro tex-src/texinfo.tex /^\\global\\let\\pagealignmacro=\\chappager}$/ pagebody tex-src/texinfo.tex /^\\def\\pagebody#1{\\vbox to\\pageheight{\\boxmaxdepth=\\/ pagecontents tex-src/texinfo.tex /^\\gdef\\pagecontents#1{\\ifvoid\\topins\\else\\unvbox\\to/ -pagesize c-src/emacs/src/gmalloc.c 1707 +pagesize c-src/emacs/src/gmalloc.c 1710 pagesofar tex-src/texinfo.tex /^\\def\\pagesofar{\\unvbox\\partialpage %$/ pair merc-src/accumulator.m /^:- import_module pair.$/ par tex-src/texinfo.tex /^\\let\\par=\\lisppar$/ @@ -3854,7 +3854,7 @@ readauxfile tex-src/texinfo.tex /^\\def\\readauxfile{%$/ readline c-src/etags.c /^readline (linebuffer *lbp, FILE *stream)$/ readline_internal c-src/etags.c /^readline_internal (linebuffer *lbp, register FILE / realloc c-src/emacs/src/gmalloc.c /^realloc (void *ptr, size_t size)$/ -realloc c-src/emacs/src/gmalloc.c 1720 +realloc c-src/emacs/src/gmalloc.c 1723 realloc c-src/emacs/src/gmalloc.c 65 realloc c-src/emacs/src/gmalloc.c 69 reallochook c-src/emacs/src/gmalloc.c /^reallochook (void *ptr, size_t size)$/ @@ -4078,7 +4078,7 @@ site cp-src/conway.hpp /^ site(int xi, int yi): x(xi), y(yi), alive(0) {/ site cp-src/conway.hpp 5 size c-src/emacs/src/gmalloc.c 156 size c-src/emacs/src/gmalloc.c 163 -size c-src/emacs/src/gmalloc.c 1867 +size c-src/emacs/src/gmalloc.c 1870 size c-src/emacs/src/lisp.h 1364 size c-src/emacs/src/lisp.h 1390 size c-src/etags.c 236 diff --git a/test/manual/etags/README b/test/manual/etags/README index f198e584da3..8493794c01c 100644 --- a/test/manual/etags/README +++ b/test/manual/etags/README @@ -51,7 +51,9 @@ corresponding "good" files, one by one. Like this: $ cp ETAGS ETAGS.good_7 $ make check $ cp CTAGS CTAGS.good - $ make check + $ head -n 100 CTAGS.good_update > CTAGS + $ tail -n 100 CTAGS.good_update >> CTAGS + $ ../../../lib-src/etags --ctags -o CTAGS -u - < srclist $ cp CTAGS CTAGS.good_update $ make check $ cp CTAGS CTAGS.good_crlf diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 9ed76a42603..5f534ed513a 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -8650,4 +8650,22 @@ Finally, kill the buffer and its temporary file." (should (= (point-min) 1)) (should (= (point-max) 5001)))) +(ert-deftest test-line-spacing () + "Test `line-spacing' impact on text size" + (skip-unless (display-graphic-p)) + (let* + ((size-with-text (lambda (ls) + (with-temp-buffer + (setq-local line-spacing ls) + (insert "X\nX") + (cdr (buffer-text-pixel-size)))))) + (cl-loop for x from 0 to 50 + for y from 0 to 50 + do + (ert-info ((format "((linespacing '(%d . %d)) == (linespacing %d)" x y (+ x y)) + :prefix "Linespace check: ") + (should (= + (funcall size-with-text (+ x y)) + (funcall size-with-text (cons x y)))))))) + ;;; buffer-tests.el ends here diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 95dd829df92..7c65e19f43d 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -38,10 +38,9 @@ (should (= (random 1) 0)) (should (>= (random 10) 0)) (should (< (random 10) 10)) - ;; On OpenBSD random is non-deterministic. - (if (and (eq system-type 'berkeley-unix) - (string-match-p "openbsd" system-configuration)) - (should (not (equal (random "seed") (random "seed")))) + ;; On OpenBSD random is always non-deterministic. + (unless (and (eq system-type 'berkeley-unix) + (string-match-p "openbsd" system-configuration)) (should (equal (random "seed") (random "seed")))) ;; The probability of four calls being the same is low. ;; This makes sure that the value isn't constant. diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 2f3dd4b8043..2cc5b37b187 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -106,6 +106,9 @@ process to complete." (looking-at "hello stdout!"))) (should (with-current-buffer stderr-buffer (goto-char (point-min)) + ;; Instrument for bug#80166. + (when (getenv "EMACS_EMBA_CI") + (message "stderr\n%s" (buffer-string))) (looking-at "hello stderr!")))))) (ert-deftest process-test-stderr-filter ()