commit 7304cc8a9ca8a7d19baaa24f0a72c7ad9a6a9716 (HEAD, refs/remotes/origin/master) Author: Eric Abrahamsen Date: Sat Nov 25 17:46:07 2023 -0800 Simplify gnus-group-search-forward Bug#67445 * lisp/gnus/gnus-group.el (gnus-group-search-forward): The special-case check for backwards-and-bobp is odd and unnecessary, just perform an equivalent search from point depending on direction. diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 01e6a8f317f..9a1a6f9b27d 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1745,45 +1745,43 @@ gnus-group-level gnus-level-killed)) (defun gnus-group-search-forward (&optional backward all level first-too) - "Find the next newsgroup with unread articles. -If BACKWARD is non-nil, find the previous newsgroup instead. -If ALL is non-nil, just find any newsgroup. -If LEVEL is non-nil, find group with level LEVEL, or higher if no such -group exists. -If FIRST-TOO, the current line is also eligible as a target." + "Move point to the next newsgroup with unread articles. +If BACKWARD is non-nil, move to the previous newsgroup instead. +If ALL is non-nil, consider any newsgroup, not only those with +unread articles. If LEVEL is non-nil, find group with level +LEVEL, or higher if no such group exists. If FIRST-TOO, the +current line is also eligible as a target." (let ((way (if backward -1 1)) (low gnus-level-killed) (beg (point)) pos found lev) - (if (and backward (progn (beginning-of-line)) (bobp)) - nil - (unless first-too - (forward-line way)) - (while (and - (not (eobp)) - (not (setq - found - (and - (get-text-property (point) 'gnus-group) - (or all - (and - (let ((unread - (get-text-property (point) 'gnus-unread))) - (and (numberp unread) (> unread 0))) - (setq lev (get-text-property (point) - 'gnus-level)) - (<= lev gnus-level-subscribed))) - (or (not level) - (and (setq lev (get-text-property (point) - 'gnus-level)) - (or (= lev level) - (and (< lev low) - (< level lev) - (progn - (setq low lev) - (setq pos (point)) - nil)))))))) - (zerop (forward-line way))))) + (unless first-too + (forward-line way)) + (while (and + (not (if backward (bobp) (eobp))) + (not (setq + found + (and + (get-text-property (point) 'gnus-group) + (or all + (and + (let ((unread + (get-text-property (point) 'gnus-unread))) + (and (numberp unread) (> unread 0))) + (setq lev (get-text-property (point) + 'gnus-level)) + (<= lev gnus-level-subscribed))) + (or (not level) + (and (setq lev (get-text-property (point) + 'gnus-level)) + (or (= lev level) + (and (< lev low) + (< level lev) + (progn + (setq low lev) + (setq pos (point)) + nil)))))))) + (zerop (forward-line way)))) (if found (progn (gnus-group-position-point) t) (goto-char (or pos beg)) commit a7c16e73c084848cb5af2552f5221db67ce64536 Author: Po Lu Date: Sun Nov 26 08:29:40 2023 +0800 * src/pdumper.c (dump_vectorlike): Avert compiler warning. diff --git a/src/pdumper.c b/src/pdumper.c index f7a7fbc2d1b..831267cdd18 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3074,7 +3074,7 @@ dump_vectorlike (struct dump_context *ctx, break; } char msg[60]; - snprintf (msg, sizeof msg, "pseudovector type %d", ptype); + snprintf (msg, sizeof msg, "pseudovector type %d", (int) ptype); error_unsupported_dump_object (ctx, lv, msg); } commit fb0198bf7e2f2ebda42b4b580a6360b0c327697c Author: Po Lu Date: Sun Nov 26 08:27:38 2023 +0800 ; Update Autoconf auxiliaries in exec * exec/config.guess: * exec/config.sub: Update configury files. diff --git a/exec/config.guess b/exec/config.guess index c7f17e8fb97..e7a6fe3e6d1 100755 --- a/exec/config.guess +++ b/exec/config.guess @@ -1,10 +1,10 @@ #!/usr/bin/sh # Attempt to guess a canonical system name. -# Copyright 1992-2022 Free Software Foundation, Inc. +# Copyright 1992-2023 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale -timestamp='2022-05-25' +timestamp='2023-06-23' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -47,7 +47,7 @@ me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] -Output the configuration name of the system \`$me' is run on. +Output the configuration name of the system '$me' is run on. Options: -h, --help print this help, then exit @@ -60,13 +60,13 @@ version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright 1992-2022 Free Software Foundation, Inc. +Copyright 1992-2023 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." help=" -Try \`$me --help' for more information." +Try '$me --help' for more information." # Parse command line while test $# -gt 0 ; do @@ -102,8 +102,8 @@ GUESS= # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. +# Historically, 'CC_FOR_BUILD' used to be named 'HOST_CC'. We still +# use 'HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. @@ -459,7 +459,7 @@ case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in UNAME_RELEASE=`uname -v` ;; esac - # Japanese Language versions have a version number like `4.1.3-JL'. + # Japanese Language versions have a version number like '4.1.3-JL'. SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/'` GUESS=sparc-sun-sunos$SUN_REL ;; @@ -966,6 +966,12 @@ EOF GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_MACHINE-unknown-$GNU_SYS$GNU_REL-$LIBC ;; + x86_64:[Mm]anagarm:*:*|i?86:[Mm]anagarm:*:*) + GUESS="$UNAME_MACHINE-pc-managarm-mlibc" + ;; + *:[Mm]anagarm:*:*) + GUESS="$UNAME_MACHINE-unknown-managarm-mlibc" + ;; *:Minix:*:*) GUESS=$UNAME_MACHINE-unknown-minix ;; @@ -1036,7 +1042,7 @@ EOF k1om:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; - loongarch32:Linux:*:* | loongarch64:Linux:*:* | loongarchx32:Linux:*:*) + loongarch32:Linux:*:* | loongarch64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; m32r*:Linux:*:*) @@ -1191,7 +1197,7 @@ EOF GUESS=$UNAME_MACHINE-pc-sysv4.2uw$UNAME_VERSION ;; i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility + # If we were able to find 'uname', then EMX Unix compatibility # is probably installed. GUESS=$UNAME_MACHINE-pc-os2-emx ;; @@ -1332,7 +1338,7 @@ EOF GUESS=ns32k-sni-sysv fi ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + PENTIUM:*:4.0*:*) # Unisys 'ClearPath HMP IX 4000' SVR4/MP effort # says GUESS=i586-unisys-sysv4 ;; diff --git a/exec/config.sub b/exec/config.sub index b41da55df45..a6d99a0f15f 100755 --- a/exec/config.sub +++ b/exec/config.sub @@ -1,10 +1,10 @@ #!/usr/bin/sh # Configuration validation subroutine script. -# Copyright 1992-2022 Free Software Foundation, Inc. +# Copyright 1992-2023 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale -timestamp='2022-01-03' +timestamp='2023-06-23' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -76,13 +76,13 @@ Report bugs and patches to ." version="\ GNU config.sub ($timestamp) -Copyright 1992-2022 Free Software Foundation, Inc. +Copyright 1992-2023 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." help=" -Try \`$me --help' for more information." +Try '$me --help' for more information." # Parse command line while test $# -gt 0 ; do @@ -130,7 +130,7 @@ IFS=$saved_IFS # Separate into logical components for further validation case $1 in *-*-*-*-*) - echo Invalid configuration \`"$1"\': more than four components >&2 + echo "Invalid configuration '$1': more than four components" >&2 exit 1 ;; *-*-*-*) @@ -145,7 +145,7 @@ case $1 in nto-qnx* | linux-* | uclinux-uclibc* \ | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \ | netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \ - | storm-chaos* | os2-emx* | rtmk-nova*) + | storm-chaos* | os2-emx* | rtmk-nova* | managarm-*) basic_machine=$field1 basic_os=$maybe_os ;; @@ -943,7 +943,7 @@ $basic_machine EOF IFS=$saved_IFS ;; - # We use `pc' rather than `unknown' + # We use 'pc' rather than 'unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) @@ -1075,7 +1075,7 @@ case $cpu-$vendor in pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) cpu=i586 ;; - pentiumpro-* | p6-* | 6x86-* | athlon-* | athalon_*-*) + pentiumpro-* | p6-* | 6x86-* | athlon-* | athlon_*-*) cpu=i686 ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) @@ -1207,7 +1207,7 @@ case $cpu-$vendor in | k1om \ | le32 | le64 \ | lm32 \ - | loongarch32 | loongarch64 | loongarchx32 \ + | loongarch32 | loongarch64 \ | m32c | m32r | m32rle \ | m5200 | m68000 | m680[012346]0 | m68360 | m683?2 | m68k \ | m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x \ @@ -1285,7 +1285,7 @@ case $cpu-$vendor in ;; *) - echo Invalid configuration \`"$1"\': machine \`"$cpu-$vendor"\' not recognized 1>&2 + echo "Invalid configuration '$1': machine '$cpu-$vendor' not recognized" 1>&2 exit 1 ;; esac @@ -1341,6 +1341,10 @@ EOF kernel=linux os=`echo "$basic_os" | sed -e 's|linux|gnu|'` ;; + managarm*) + kernel=managarm + os=`echo "$basic_os" | sed -e 's|managarm|mlibc|'` + ;; *) kernel= os=$basic_os @@ -1754,7 +1758,7 @@ case $os in | onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \ | midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \ | nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr* \ - | fiwix* ) + | fiwix* | mlibc* ) ;; # This one is extra strict with allowed versions sco3.2v2 | sco3.2v[4-9]* | sco5v6*) @@ -1762,8 +1766,11 @@ case $os in ;; none) ;; + kernel* ) + # Restricted further below + ;; *) - echo Invalid configuration \`"$1"\': OS \`"$os"\' not recognized 1>&2 + echo "Invalid configuration '$1': OS '$os' not recognized" 1>&2 exit 1 ;; esac @@ -1772,14 +1779,24 @@ esac # (given a valid OS), if there is a kernel. case $kernel-$os in linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* \ - | linux-musl* | linux-relibc* | linux-uclibc* ) + | linux-musl* | linux-relibc* | linux-uclibc* | linux-mlibc* ) ;; uclinux-uclibc* ) ;; - -dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* ) + managarm-mlibc* | managarm-kernel* ) + ;; + -dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* | -mlibc* ) # These are just libc implementations, not actual OSes, and thus # require a kernel. - echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2 + echo "Invalid configuration '$1': libc '$os' needs explicit kernel." 1>&2 + exit 1 + ;; + -kernel* ) + echo "Invalid configuration '$1': '$os' needs explicit kernel." 1>&2 + exit 1 + ;; + *-kernel* ) + echo "Invalid configuration '$1': '$kernel' does not support '$os'." 1>&2 exit 1 ;; kfreebsd*-gnu* | kopensolaris*-gnu*) @@ -1796,7 +1813,7 @@ case $kernel-$os in # Blank kernel with real OS is always fine. ;; *-*) - echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2 + echo "Invalid configuration '$1': Kernel '$kernel' not known to work with OS '$os'." 1>&2 exit 1 ;; esac commit d2ce30afdd22291eeeaea7f3566bb7bd6bb14dda Author: F. Jason Park Date: Sat Nov 25 14:26:24 2023 -0800 ; Mark test for erc--update-channel-modes as :unstable * test/lisp/erc/erc-scenarios-auth-source.el (erc-scenarios-common--auth-source): Extend timeout. * test/lisp/erc/erc-scenarios-base-buffer-display.el (erc-scenarios-base-buffer-display--count-reset-timeout): Await initial condition. * test/lisp/erc/erc-scenarios-base-renick.el (erc-scenarios-base-renick-queries-solo): Extend timeout. * test/lisp/erc/erc-scenarios-misc.el (erc-scenarios-base-flood): Extend timeout. * test/lisp/erc/erc-tests.el (erc--channel-modes): Mark test as :unstable pending further investigation. This test has been shown to be unreliable, possibly because it expects Emacs to report characters being a certain width in all environments. Thanks to Mattias Engdegård for reporting this failure. * test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld: Extend timeouts. * test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld: Extend timeouts. diff --git a/test/lisp/erc/erc-scenarios-auth-source.el b/test/lisp/erc/erc-scenarios-auth-source.el index 641b881666e..7eaf90e1e41 100644 --- a/test/lisp/erc/erc-scenarios-auth-source.el +++ b/test/lisp/erc/erc-scenarios-auth-source.el @@ -56,7 +56,7 @@ erc-scenarios-common--auth-source (should (string= (buffer-name) (if id (symbol-name id) (format "127.0.0.1:%d" port)))) - (erc-d-t-wait-for 5 (eq erc-network 'FooNet)))))) + (erc-d-t-wait-for 10 (eq erc-network 'FooNet)))))) (ert-deftest erc-scenarios-base-auth-source-server--dialed () :tags '(:expensive-test) diff --git a/test/lisp/erc/erc-scenarios-base-buffer-display.el b/test/lisp/erc/erc-scenarios-base-buffer-display.el index 6a80baeaaa9..889f274b8b1 100644 --- a/test/lisp/erc/erc-scenarios-base-buffer-display.el +++ b/test/lisp/erc/erc-scenarios-base-buffer-display.el @@ -193,7 +193,7 @@ erc-scenarios-base-buffer-display--count-reset-timeout (lambda (_) (with-current-buffer "FooNet" - (should erc--server-reconnect-display-timer)) + (erc-d-t-wait-for 1 erc--server-reconnect-display-timer)) ;; A non-interactive JOIN command doesn't signal that we're ;; done auto-reconnecting. diff --git a/test/lisp/erc/erc-scenarios-base-renick.el b/test/lisp/erc/erc-scenarios-base-renick.el index 2bf3ef46257..5a87e5871f7 100644 --- a/test/lisp/erc/erc-scenarios-base-renick.el +++ b/test/lisp/erc/erc-scenarios-base-renick.el @@ -173,7 +173,7 @@ erc-scenarios-base-renick-queries-solo (with-current-buffer erc-server-buffer-foo (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) - (erc-d-t-wait-for 1 (get-buffer "foonet")) + (erc-d-t-wait-for 10 (get-buffer "foonet")) (ert-info ("Joined by bouncer to #foo, pal persent") (with-current-buffer (erc-d-t-wait-for 1 (get-buffer "#foo")) diff --git a/test/lisp/erc/erc-scenarios-misc.el b/test/lisp/erc/erc-scenarios-misc.el index bb925eed836..2efcd7ec7fb 100644 --- a/test/lisp/erc/erc-scenarios-misc.el +++ b/test/lisp/erc/erc-scenarios-misc.el @@ -75,7 +75,7 @@ erc-scenarios-base-flood (ert-info ("All output sent") (with-current-buffer "#chan/foonet" - (funcall expect 8 "Some man or other")) + (funcall expect 16 "Some man or other")) (with-current-buffer "#chan/barnet" (funcall expect 10 "That's he that was Othello"))))) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 980928aceac..1d0eb70578a 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -812,6 +812,8 @@ erc--update-channel-modes (should-not calls)))) (ert-deftest erc--channel-modes () + :tags (and (null (getenv "CI")) '(:unstable)) + (setq erc--isupport-params (make-hash-table) erc--target (erc--target-from-string "#test") erc-server-parameters diff --git a/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld b/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld index cc7aff10076..5b64a58c98f 100644 --- a/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld +++ b/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :barnet:changeme")) -((nick 1 "NICK tester")) -((user 2 "USER user 0 * :tester") +((pass 10 "PASS :barnet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester") (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.barnet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC") diff --git a/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld b/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld index 3a846108466..260ff74c20c 100644 --- a/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld +++ b/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :foonet:changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :foonet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC") commit 0a6d0a4959ae1d4ad70563fbf9e57f5543cf49f7 Author: F. Jason Park Date: Fri Nov 24 15:00:55 2023 -0800 Simplify option erc-fill-wrap-merge-indicator * lisp/erc/erc-fill.el (erc-fill-function): Add hyperlink to `erc-fill-wrap-mode' in doc string. (erc-fill-wrap-merge-indicator-face): New face. The rationale for adding this is that hard-coding `erc-fill-wrap-merge-indicator' to use specific non-ERC faces forces folks to customize the option by specifying a value manually, which may not be easy for new users, seeing as its :type is relatively complex. (erc-fill-wrap-merge-indicator): Add new preset without leading space, for narrow windows, and replace `shadow' with `erc-fill-wrap-merge-indicator-face' everywhere. (erc-fill-wrap-mode): Add configuration hint to doc string for related options when facing narrow windows. (erc-fill--wrap-insert-merged-post, erc-fill--wrap-insert-merged-pre): Fix sloppy thinko in which "-pre" and "-post" stash variables for precomputed values were swapped. Also accommodate :type string variant for option `erc-fill-wrap-merge-indicator'. (erc-fill--wrap-rejigger-region): Clear pre-computed merge-indicator value. (Bug#60936) diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index 83f60fd3162..fc572666461 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -91,7 +91,8 @@ erc-fill-function an initial \"prefix\" width and `erc-fill-wrap-margin-width' instead of `erc-fill-column' for influencing initial message width. For adjusting these during a session, see the commands -`erc-fill-wrap-nudge' and `erc-fill-wrap-refill-buffer'." +`erc-fill-wrap-nudge' and `erc-fill-wrap-refill-buffer'. Read +more about this style in the doc string for `erc-fill-wrap-mode'." :type '(choice (const :tag "Variable Filling" erc-fill-variable) (const :tag "Static Filling" erc-fill-static) (const :tag "Dynamic word-wrap" erc-fill-wrap) @@ -267,6 +268,14 @@ erc-fill-wrap-merge :package-version '(ERC . "5.6") :type 'boolean) +(defface erc-fill-wrap-merge-indicator-face + '((((min-colors 88) (background light)) :foreground "Gray") + (((min-colors 16) (background light)) :foreground "LightGray") + (((min-colors 16) (background dark)) :foreground "DimGray") + (t :inherit shadow)) + "ERC `fill-wrap' merge-indicator face." + :group 'erc-faces) + (defcustom erc-fill-wrap-merge-indicator nil "Indicator to help distinguish between merged messages. Only matters when the option `erc-fill-wrap-merge' is enabled. @@ -277,21 +286,33 @@ erc-fill-wrap-merge-indicator intervening padding supplied by `erc-fill-line-spacing' and is meant to supplant that option in text terminals.) In either case, the second element should be a character, like ?>, and the -last element a valid face. When in doubt, try the first prefab -choice, (pre #xb7 shadow), which replaces a continued speaker's -name with a nondescript dot-product-like glyph in `shadow' face. -This option is currently experimental, and changing its value -mid-session is not supported." +last element a valid face. In special cases, you may also +specify a cons of `pre'/`post' and a string, which tells ERC you +know what you're doing and not to manage the process for you. If +unsure, try either of the first two presets, both of which +replace a continued speaker's name with a dot-product-like glyph +in `shadow' face. Note that this option is still experimental, +and changing its value mid-session is not yet supported (though, +if you must, make sure to run \\[erc-fill-wrap-refill-buffer] +afterward)." :package-version '(ERC . "5.6") - :type '(choice (const nil) - (const :tag "Leading MIDDLE DOT as speaker (U+00B7)" - (pre #xb7 shadow)) - (const :tag "Trailing PARAGRAPH SIGN (U+00B6)" - (post #xb6 shadow)) - (const :tag "Leading > as speaker" (pre ?> shadow)) - (const :tag "Trailing ~" (post ?~ shadow)) - (list :tag "User-provided" - (choice (const pre) (const post)) character face))) + :type + '(choice (const nil) + (const :tag "Leading MIDDLE DOT (U+00B7) as speaker" + (pre #xb7 erc-fill-wrap-merge-indicator-face)) + (const :tag "Leading MIDDLE DOT (U+00B7) sans gap" + (pre . #("\u00b7" 0 1 (font-lock-face + erc-fill-wrap-merge-indicator-face)))) + (const :tag "Leading RIGHT-ANGLE BRACKET (>) as speaker" + (pre ?> erc-fill-wrap-merge-indicator-face)) + (const :tag "Trailing PARAGRAPH SIGN (U+00B6)" + (post #xb6 erc-fill-wrap-merge-indicator-face)) + (const :tag "Trailing TILDE (~)" + (post ?~ erc-fill-wrap-merge-indicator-face)) + (cons :tag "User-provided string (advanced)" + (choice (const pre) (const post)) string) + (list :tag "User-provided character-face pairing" + (choice (const pre) (const post)) character face))) (defun erc-fill--wrap-move (normal-cmd visual-cmd &rest args) (apply (pcase erc-fill--wrap-visual-keys @@ -439,7 +460,9 @@ fill-wrap by the option `erc-fill-wrap-margin-width'. To use it, either include `fill-wrap' in `erc-modules' or set `erc-fill-function' to `erc-fill-wrap'. Most users will want to enable the -`scrolltobottom' module as well. Once active, use +`scrolltobottom' module as well. + +During sessions in which this module is active, use \\[erc-fill-wrap-nudge] to adjust the width of the indent and the stamp margin, and use \\[erc-fill-wrap-toggle-truncate-lines] for cycling between logical- and screen-line oriented command @@ -447,7 +470,11 @@ fill-wrap alignment problems after running certain commands, like `text-scale-adjust'. Also see related stylistic options `erc-fill-line-spacing', `erc-fill-wrap-merge', and -`erc-fill-wrap-merge-indicator'. +`erc-fill-wrap-merge-indicator'. Hint: in narrow windows, where +is space tight, try setting `erc-fill-static-center' to 1. And +if you also use the option `erc-fill-wrap-merge-indicator', set +that to value-menu item \"Leading MIDDLE DOT (U+00B7) sans gap\" +or one of the various \"trailing\" items. This module imposes various restrictions on the appearance of timestamps. Most notably, it insists on displaying them in the @@ -600,14 +627,17 @@ erc-fill--wrap-insert-merged-post (save-restriction (widen) (cl-assert (= ?\n (char-before (point)))) - (unless erc-fill--wrap-merge-indicator-pre - (let ((option erc-fill-wrap-merge-indicator)) - (setq erc-fill--wrap-merge-indicator-pre - (propertize (concat (string (nth 1 option)) "\n") - 'font-lock-face (nth 2 option))))) + (unless erc-fill--wrap-merge-indicator-post + (let ((option (cdr erc-fill-wrap-merge-indicator))) + (setq erc-fill--wrap-merge-indicator-post + (if (stringp option) + (concat option + (and (not (string-suffix-p "\n" option)) "\n")) + (propertize (concat (string (car option)) "\n") + 'font-lock-face (cadr option)))))) (unless (eq (field-at-pos (- (point) 2)) 'erc-timestamp) (put-text-property (1- (point)) (point) - 'display erc-fill--wrap-merge-indicator-pre))) + 'display erc-fill--wrap-merge-indicator-post))) 0)) (defun erc-fill--wrap-insert-merged-pre () @@ -615,14 +645,16 @@ erc-fill--wrap-insert-merged-pre (if erc-fill--wrap-merge-indicator-post (progn (put-text-property (point-min) (point) 'display - (car erc-fill--wrap-merge-indicator-post)) - (cdr erc-fill--wrap-merge-indicator-post)) - (let* ((option erc-fill-wrap-merge-indicator) - (s (concat (propertize (string (nth 1 option)) - 'font-lock-face (nth 2 option)) - " "))) + (car erc-fill--wrap-merge-indicator-pre)) + (cdr erc-fill--wrap-merge-indicator-pre)) + (let* ((option (cdr erc-fill-wrap-merge-indicator)) + (s (if (stringp option) + (concat option) + (concat (propertize (string (car option)) + 'font-lock-face (cadr option)) + " ")))) (put-text-property (point-min) (point) 'display s) - (cdr (setq erc-fill--wrap-merge-indicator-post + (cdr (setq erc-fill--wrap-merge-indicator-pre (cons s (erc-fill--wrap-measure (point-min) (point)))))))) (defun erc-fill-wrap () @@ -698,6 +730,8 @@ erc-fill--wrap-rejigger-region With REPAIRP, destructively fill gaps and re-merge speakers." (goto-char start) (cl-assert (null erc-fill--wrap-rejigger-last-message)) + (setq erc-fill--wrap-merge-indicator-pre nil + erc-fill--wrap-merge-indicator-post nil) (let (erc-fill--wrap-rejigger-last-message) (while-let (((< (point) finish)) commit 278a6e1916cd78a405501ac0431f1b90cdb6cfaf Author: Mattias Engdegård Date: Sat Nov 25 17:36:53 2023 +0100 Refactor pseudovector printing * src/print.c (print_vectorlike): Split into... (print_bignum, print_bool_vector, print_vectorlike_unreadable): ...these functions. Exhaustive switch on pseudovector type. Remove unused return value. (print_object): Use new functions and simplify. diff --git a/src/print.c b/src/print.c index 4eee8319f65..a5d57adbd3b 100644 --- a/src/print.c +++ b/src/print.c @@ -1599,76 +1599,69 @@ print_pointer (Lisp_Object printcharfun, char *buf, const char *prefix, } #endif -static bool -print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, - char *buf) +static void +print_bignum (Lisp_Object obj, Lisp_Object printcharfun) { - /* First do all the vectorlike types that have a readable syntax. */ - switch (PSEUDOVECTOR_TYPE (XVECTOR (obj))) - { - case PVEC_BIGNUM: - { - ptrdiff_t size = bignum_bufsize (obj, 10); - USE_SAFE_ALLOCA; - char *str = SAFE_ALLOCA (size); - ptrdiff_t len = bignum_to_c_string (str, size, obj, 10); - strout (str, len, len, printcharfun); - SAFE_FREE (); - } - return true; - - case PVEC_BOOL_VECTOR: - { - EMACS_INT size = bool_vector_size (obj); - ptrdiff_t size_in_bytes = bool_vector_bytes (size); - ptrdiff_t real_size_in_bytes = size_in_bytes; - unsigned char *data = bool_vector_uchar_data (obj); - - int len = sprintf (buf, "#&%"pI"d\"", size); - strout (buf, len, len, printcharfun); + ptrdiff_t size = bignum_bufsize (obj, 10); + USE_SAFE_ALLOCA; + char *str = SAFE_ALLOCA (size); + ptrdiff_t len = bignum_to_c_string (str, size, obj, 10); + strout (str, len, len, printcharfun); + SAFE_FREE (); +} - /* Don't print more bytes than the specified maximum. - Negative values of print-length are invalid. Treat them - like a print-length of nil. */ - if (FIXNATP (Vprint_length) - && XFIXNAT (Vprint_length) < size_in_bytes) - size_in_bytes = XFIXNAT (Vprint_length); +static void +print_bool_vector (Lisp_Object obj, Lisp_Object printcharfun) +{ + EMACS_INT size = bool_vector_size (obj); + ptrdiff_t size_in_bytes = bool_vector_bytes (size); + ptrdiff_t real_size_in_bytes = size_in_bytes; + unsigned char *data = bool_vector_uchar_data (obj); - for (ptrdiff_t i = 0; i < size_in_bytes; i++) - { - maybe_quit (); - unsigned char c = data[i]; - if (c == '\n' && print_escape_newlines) - print_c_string ("\\n", printcharfun); - else if (c == '\f' && print_escape_newlines) - print_c_string ("\\f", printcharfun); - else if (c > '\177' - || (print_escape_control_characters && c_iscntrl (c))) - { - /* Use octal escapes to avoid encoding issues. */ - octalout (c, data, i + 1, size_in_bytes, printcharfun); - } - else - { - if (c == '\"' || c == '\\') - printchar ('\\', printcharfun); - printchar (c, printcharfun); - } - } + char buf[sizeof "#&" + INT_STRLEN_BOUND (ptrdiff_t)]; + int len = sprintf (buf, "#&%"pI"d\"", size); + strout (buf, len, len, printcharfun); - if (size_in_bytes < real_size_in_bytes) - print_c_string (" ...", printcharfun); - printchar ('\"', printcharfun); - } - return true; + /* Don't print more bytes than the specified maximum. + Negative values of print-length are invalid. Treat them + like a print-length of nil. */ + if (FIXNATP (Vprint_length) + && XFIXNAT (Vprint_length) < size_in_bytes) + size_in_bytes = XFIXNAT (Vprint_length); - default: - break; + for (ptrdiff_t i = 0; i < size_in_bytes; i++) + { + maybe_quit (); + unsigned char c = data[i]; + if (c == '\n' && print_escape_newlines) + print_c_string ("\\n", printcharfun); + else if (c == '\f' && print_escape_newlines) + print_c_string ("\\f", printcharfun); + else if (c > '\177' + || (print_escape_control_characters && c_iscntrl (c))) + { + /* Use octal escapes to avoid encoding issues. */ + octalout (c, data, i + 1, size_in_bytes, printcharfun); + } + else + { + if (c == '\"' || c == '\\') + printchar ('\\', printcharfun); + printchar (c, printcharfun); + } } - /* Then do all the pseudovector types that don't have a readable - syntax. First check whether this is handled by - `print-unreadable-function'. */ + if (size_in_bytes < real_size_in_bytes) + print_c_string (" ...", printcharfun); + printchar ('\"', printcharfun); +} + +/* Print a pseudovector that has no readable syntax. */ +static void +print_vectorlike_unreadable (Lisp_Object obj, Lisp_Object printcharfun, + bool escapeflag, char *buf) +{ + /* First check whether this is handled by `print-unreadable-function'. */ if (!NILP (Vprint_unreadable_function) && FUNCTIONP (Vprint_unreadable_function)) { @@ -1697,7 +1690,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, if (STRINGP (result)) print_string (result, printcharfun); /* It's handled, so stop processing here. */ - return true; + return; } } @@ -1718,7 +1711,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun); } printchar ('>', printcharfun); - break; + return; case PVEC_SYMBOL_WITH_POS: { @@ -1742,7 +1735,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, printchar ('>', printcharfun); } } - break; + return; case PVEC_OVERLAY: print_c_string ("#', printcharfun); - break; + return; case PVEC_USER_PTR: { @@ -1769,14 +1762,14 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, strout (buf, i, i, printcharfun); printchar ('>', printcharfun); } - break; + return; case PVEC_FINALIZER: print_c_string ("#function)) print_c_string (" used", printcharfun); printchar ('>', printcharfun); - break; + return; case PVEC_MISC_PTR: { @@ -1785,7 +1778,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, int i = sprintf (buf, "#", xmint_pointer (obj)); strout (buf, i, i, printcharfun); } - break; + return; case PVEC_PROCESS: if (escapeflag) @@ -1796,13 +1789,13 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } else print_string (XPROCESS (obj)->name, printcharfun); - break; + return; case PVEC_SUBR: print_c_string ("#symbol_name, printcharfun); printchar ('>', printcharfun); - break; + return; case PVEC_XWIDGET: #ifdef HAVE_XWIDGETS @@ -1822,15 +1815,15 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, #endif strout (buf, len, len, printcharfun); } - break; + return; } -#else - emacs_abort (); #endif + break; + case PVEC_XWIDGET_VIEW: print_c_string ("#', printcharfun); - break; + return; case PVEC_WINDOW: { @@ -1845,7 +1838,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } printchar ('>', printcharfun); } - break; + return; case PVEC_TERMINAL: { @@ -1859,7 +1852,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } printchar ('>', printcharfun); } - break; + return; case PVEC_BUFFER: if (!BUFFER_LIVE_P (XBUFFER (obj))) @@ -1872,11 +1865,11 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } else print_string (BVAR (XBUFFER (obj), name), printcharfun); - break; + return; case PVEC_WINDOW_CONFIGURATION: print_c_string ("#", printcharfun); - break; + return; case PVEC_FRAME: { @@ -1900,7 +1893,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, int len = sprintf (buf, " %p>", ptr); strout (buf, len, len, printcharfun); } - break; + return; case PVEC_FONT: { @@ -1933,7 +1926,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } printchar ('>', printcharfun); } - break; + return; case PVEC_THREAD: print_c_string ("#', printcharfun); - break; + return; case PVEC_MUTEX: print_c_string ("#', printcharfun); - break; + return; case PVEC_CONDVAR: print_c_string ("#', printcharfun); - break; + return; -#ifdef HAVE_MODULES case PVEC_MODULE_FUNCTION: +#ifdef HAVE_MODULES { print_c_string ("#', printcharfun); + return; } - break; #endif -#ifdef HAVE_NATIVE_COMP + break; + case PVEC_NATIVE_COMP_UNIT: +#ifdef HAVE_NATIVE_COMP { struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj); print_c_string ("#optimize_qualities, printcharfun, escapeflag); printchar ('>', printcharfun); + return; } - break; #endif + break; -#ifdef HAVE_TREE_SITTER case PVEC_TS_PARSER: +#ifdef HAVE_TREE_SITTER print_c_string ("#language_symbol; /* No need to print the buffer because it's not that useful: we usually know which buffer a parser belongs to. */ print_string (Fsymbol_name (language), printcharfun); printchar ('>', printcharfun); + return; +#endif break; + case PVEC_TS_NODE: +#ifdef HAVE_TREE_SITTER /* Prints # or #. */ print_c_string ("#", printcharfun); - break; + return; } printchar (' ', printcharfun); /* Now the node must be up-to-date, and calling functions like @@ -2053,11 +2053,16 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, printchar ('-', printcharfun); print_object (Ftreesit_node_end (obj), printcharfun, escapeflag); printchar ('>', printcharfun); + return; +#endif break; + case PVEC_TS_COMPILED_QUERY: +#ifdef HAVE_TREE_SITTER print_c_string ("#", printcharfun); - break; + return; #endif + break; case PVEC_SQLITE: { @@ -2073,13 +2078,23 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, print_c_string (XSQLITE (obj)->name, printcharfun); printchar ('>', printcharfun); } - break; + return; - default: - emacs_abort (); + /* Types handled earlier. */ + case PVEC_NORMAL_VECTOR: + case PVEC_RECORD: + case PVEC_COMPILED: + case PVEC_CHAR_TABLE: + case PVEC_SUB_CHAR_TABLE: + case PVEC_HASH_TABLE: + case PVEC_BIGNUM: + case PVEC_BOOL_VECTOR: + /* Impossible cases. */ + case PVEC_FREE: + case PVEC_OTHER: + break; } - - return true; + emacs_abort (); } static char @@ -2523,29 +2538,21 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) switch (PSEUDOVECTOR_TYPE (XVECTOR (obj))) { case PVEC_NORMAL_VECTOR: - { - print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj), - printcharfun); - goto next_obj; - } + print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj), + printcharfun); + goto next_obj; case PVEC_RECORD: - { - print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj), - printcharfun); - goto next_obj; - } + print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; case PVEC_COMPILED: - { - print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj), - printcharfun); - goto next_obj; - } + print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; case PVEC_CHAR_TABLE: - { - print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj), - printcharfun); - goto next_obj; - } + print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; case PVEC_SUB_CHAR_TABLE: { /* Make each lowest sub_char_table start a new line. @@ -2614,30 +2621,22 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) goto next_obj; } + case PVEC_BIGNUM: + print_bignum (obj, printcharfun); + break; + + case PVEC_BOOL_VECTOR: + print_bool_vector (obj, printcharfun); + break; + default: + print_vectorlike_unreadable (obj, printcharfun, escapeflag, buf); break; } - - if (print_vectorlike (obj, printcharfun, escapeflag, buf)) break; - FALLTHROUGH; default: - { - int len; - /* We're in trouble if this happens! - Probably should just emacs_abort (). */ - print_c_string ("#"), - printcharfun); - break; - } + emacs_abort (); } print_depth--; commit f8fe0cf1bbc03889774741c622f8d768cbf431b8 Author: Mattias Engdegård Date: Sat Nov 25 11:26:54 2023 +0100 ; * src/pdumper.c (dump_vectorlike): Populate switch fully. diff --git a/src/pdumper.c b/src/pdumper.c index 379e128e2b4..f7a7fbc2d1b 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3004,7 +3004,8 @@ dump_vectorlike (struct dump_context *ctx, # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); - switch (PSEUDOVECTOR_TYPE (v)) + enum pvec_type ptype = PSEUDOVECTOR_TYPE (v); + switch (ptype) { case PVEC_FONT: /* There are three kinds of font objects that all use PVEC_FONT, @@ -3021,76 +3022,60 @@ dump_vectorlike (struct dump_context *ctx, case PVEC_CHAR_TABLE: case PVEC_SUB_CHAR_TABLE: case PVEC_RECORD: - offset = dump_vectorlike_generic (ctx, &v->header); - break; + return dump_vectorlike_generic (ctx, &v->header); case PVEC_BOOL_VECTOR: - offset = dump_bool_vector(ctx, v); - break; + return dump_bool_vector(ctx, v); case PVEC_HASH_TABLE: - offset = dump_hash_table (ctx, lv, offset); - break; + return dump_hash_table (ctx, lv, offset); case PVEC_BUFFER: - offset = dump_buffer (ctx, XBUFFER (lv)); - break; + return dump_buffer (ctx, XBUFFER (lv)); case PVEC_SUBR: - offset = dump_subr (ctx, XSUBR (lv)); - break; + return dump_subr (ctx, XSUBR (lv)); case PVEC_FRAME: case PVEC_WINDOW: case PVEC_PROCESS: case PVEC_TERMINAL: - offset = dump_nilled_pseudovec (ctx, &v->header); - break; + return dump_nilled_pseudovec (ctx, &v->header); case PVEC_MARKER: - offset = dump_marker (ctx, XMARKER (lv)); - break; + return dump_marker (ctx, XMARKER (lv)); case PVEC_OVERLAY: - offset = dump_overlay (ctx, XOVERLAY (lv)); - break; + return dump_overlay (ctx, XOVERLAY (lv)); case PVEC_FINALIZER: - offset = dump_finalizer (ctx, XFINALIZER (lv)); - break; + return dump_finalizer (ctx, XFINALIZER (lv)); case PVEC_BIGNUM: - offset = dump_bignum (ctx, lv); - break; -#ifdef HAVE_NATIVE_COMP + return dump_bignum (ctx, lv); case PVEC_NATIVE_COMP_UNIT: - offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); - break; +#ifdef HAVE_NATIVE_COMP + return dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); #endif - case PVEC_WINDOW_CONFIGURATION: - error_unsupported_dump_object (ctx, lv, "window configuration"); - case PVEC_OTHER: - error_unsupported_dump_object (ctx, lv, "other?!"); - case PVEC_XWIDGET: - error_unsupported_dump_object (ctx, lv, "xwidget"); - case PVEC_XWIDGET_VIEW: - error_unsupported_dump_object (ctx, lv, "xwidget view"); - case PVEC_MISC_PTR: - case PVEC_USER_PTR: - error_unsupported_dump_object (ctx, lv, "smuggled pointers"); + break; case PVEC_THREAD: if (main_thread_p (v)) { eassert (dump_object_emacs_ptr (lv)); return DUMP_OBJECT_IS_RUNTIME_MAGIC; } - error_unsupported_dump_object (ctx, lv, "thread"); + break; + case PVEC_WINDOW_CONFIGURATION: + case PVEC_OTHER: + case PVEC_XWIDGET: + case PVEC_XWIDGET_VIEW: + case PVEC_MISC_PTR: + case PVEC_USER_PTR: case PVEC_MUTEX: - error_unsupported_dump_object (ctx, lv, "mutex"); case PVEC_CONDVAR: - error_unsupported_dump_object (ctx, lv, "condvar"); case PVEC_SQLITE: - error_unsupported_dump_object (ctx, lv, "sqlite"); case PVEC_MODULE_FUNCTION: - error_unsupported_dump_object (ctx, lv, "module function"); case PVEC_SYMBOL_WITH_POS: - error_unsupported_dump_object (ctx, lv, "symbol with pos"); - default: - error_unsupported_dump_object(ctx, lv, "weird pseudovector"); + case PVEC_FREE: + case PVEC_TS_PARSER: + case PVEC_TS_NODE: + case PVEC_TS_COMPILED_QUERY: + break; } - - return offset; + char msg[60]; + snprintf (msg, sizeof msg, "pseudovector type %d", ptype); + error_unsupported_dump_object (ctx, lv, msg); } /* Add an object to the dump. commit 82bba6713fc9d5c7cc24c182236df4f16545e941 Author: Stefan Monnier Date: Sat Nov 25 11:03:08 2023 -0500 regex-emacs.c (forall_firstchar): Fix regression bug#67226 All zero-width operations need to be taken into account when reaching `succeed` in `mutually_exclusive_one`! * src/regex-emacs.c (forall_firstchar_1): Call `f` for all zero-width matching operators. (analyze_first_fastmap, analyze_first_null, mutually_exclusive_one): Adjust accordingly. diff --git a/src/regex-emacs.c b/src/regex-emacs.c index 95c3366652d..cb4fbd58faa 100644 --- a/src/regex-emacs.c +++ b/src/regex-emacs.c @@ -2857,6 +2857,9 @@ forall_firstchar_1 (re_char *p, re_char *pend, else switch (*p) { + case no_op: + p++; continue; + /* Cases which stop the iteration. */ case succeed: case exactn: @@ -2872,15 +2875,9 @@ forall_firstchar_1 (re_char *p, re_char *pend, /* Cases which may match the empty string. */ case at_dot: case begbuf: - case no_op: case wordbound: case notwordbound: case begline: - p++; - continue; - - /* Cases which may match the empty string and may - tell us something about the next char. */ case endline: case endbuf: case wordbeg: @@ -3201,6 +3198,11 @@ analyze_first_fastmap (const re_char *p, void *arg) } return true; + case at_dot: + case begbuf: + case wordbound: + case notwordbound: + case begline: case endline: case endbuf: case wordbeg: @@ -3244,6 +3246,11 @@ analyze_first_null (const re_char *p, void *arg) case notcategoryspec: return true; + case at_dot: + case begbuf: + case wordbound: + case notwordbound: + case begline: case endline: case endbuf: case wordbeg: @@ -3983,6 +3990,13 @@ #define RETURN_CONSTRAIN(v) \ RETURN_CONSTRAIN (*data->p1 == syntaxspec && (data->p1[1] == Ssymbol || data->p1[1] == Sword)); + case at_dot: + case begbuf: + case wordbound: + case notwordbound: + case begline: + RETURN_CONSTRAIN (false); + case duplicate: /* At this point, we know nothing about what this can match, sadly. */ return false; commit c20226a1ef5fbdfd3e71e2ef8654ee19994c0f2f Author: Aymeric Agon-Rambosson Date: Sat Nov 25 10:07:49 2023 -0500 Repair `tab-first-completion` (bug#67158) Copyright-paperwork-exempt: yes * lisp/indent.el (indent-for-tab-command): Use `syntax-class` to fix longstanding thinko introduced back in 2020 in commit 64c851166442. Rework the check for `syn` because TAB always completed when `tab-first-completion` had value `word-or-paren` or `word-or-paren-or-punct`. diff --git a/lisp/indent.el b/lisp/indent.el index 89de0a1d7d1..f64049d64b2 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -170,8 +170,7 @@ indent-for-tab-command (t (let ((old-tick (buffer-chars-modified-tick)) (old-point (point)) - (old-indent (current-indentation)) - (syn (syntax-after (point)))) + (old-indent (current-indentation))) ;; Indent the line. (or (not (eq (indent--funcall-widened indent-line-function) 'noindent)) @@ -185,19 +184,14 @@ indent-for-tab-command ((and (eq tab-always-indent 'complete) (eql old-point (point)) (eql old-tick (buffer-chars-modified-tick)) - (or (null tab-first-completion) - (eq last-command this-command) - (and (eq tab-first-completion 'eol) - (eolp)) - (and (memq tab-first-completion - '(word word-or-paren word-or-paren-or-punct)) - (not (eql 2 syn))) - (and (memq tab-first-completion - '(word-or-paren word-or-paren-or-punct)) - (not (or (eql 4 syn) - (eql 5 syn)))) - (and (eq tab-first-completion 'word-or-paren-or-punct) - (not (eql 1 syn))))) + (or (eq last-command this-command) + (let ((syn (syntax-class (syntax-after (point))))) + (pcase tab-first-completion + ('nil t) + ('eol (eolp)) + ('word (not (eql 2 syn))) + ('word-or-paren (not (memql syn '(2 4 5)))) + ('word-or-paren-or-punct (not (memq syn '(2 4 5 1)))))))) (completion-at-point)) ;; If a prefix argument was given, rigidly indent the following commit efae0e68efc79bc5eb7c86a30c127006d3b374e2 Author: Dmitry Gutov Date: Sat Nov 25 17:04:32 2023 +0200 (project-prompt-project-name): Simplify a bit * lisp/progmodes/project.el (project-prompt-project-name): Fold the inner 'let' into 'when-let'. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 27cca2e0f35..f7f057396e1 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1802,12 +1802,12 @@ project-prompt-project-name ;; Iterate in reverse order so project--name-history is in ;; the same order as project--list. (dolist (dir (reverse (project-known-project-roots))) - ;; we filter out directories that no longer map to a project, + ;; We filter out directories that no longer map to a project, ;; since they don't have a clean project-name. - (when-let (proj (project--find-in-directory dir)) - (let ((name (project-name proj))) - (push name project--name-history) - (push (cons name proj) ret)))) + (when-let ((proj (project--find-in-directory dir)) + (name (project-name proj))) + (push name project--name-history) + (push (cons name proj) ret))) ret)) ;; XXX: Just using this for the category (for the substring ;; completion style). commit ab37e0b56a9eb204ec73c8d5f65aac3bfe5ea6ff Author: Dmitry Gutov Date: Sat Nov 25 16:07:06 2023 +0200 ; project-prompt-project-name: Reword a comment diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index bdf8aab003b..27cca2e0f35 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1800,7 +1800,7 @@ project-prompt-project-name (choices (let (ret) ;; Iterate in reverse order so project--name-history is in - ;; the correct order. + ;; the same order as project--list. (dolist (dir (reverse (project-known-project-roots))) ;; we filter out directories that no longer map to a project, ;; since they don't have a clean project-name. commit 9cd72fbfa62860e130e2884cd3515887edc9d34b Author: Eli Zaretskii Date: Sat Nov 25 07:05:57 2023 -0500 ; * configure.ac: Fix the unexec build. diff --git a/configure.ac b/configure.ac index debc6d1078f..759dcd14d50 100644 --- a/configure.ac +++ b/configure.ac @@ -5158,6 +5158,9 @@ AC_DEFUN # Check if libgccjit really works. AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken]) fi + if test "$with_unexec" = yes; then + with_native_compilation=no + fi fi if test "${with_native_compilation}" != "no"; then commit d8726dd382a74737d19b958eaa037232fc9fb592 Merge: 8157d49060b 77ab00207d6 Author: Eli Zaretskii Date: Sat Nov 25 06:42:53 2023 -0500 Merge from origin/emacs-29 77ab00207d6 ; * admin/authors.el (authors-aliases): Add Noah Peart. 6f843f03dc2 typescript-ts-mode: Add missing 'operator' to treesit-fon... 0676a029310 Extend D-Bus doc and test df094dd4bc1 Do not unregister a D-Bus service which is a unique name e6ad97a3338 Fix byte-compilation warnings about 'sqlite-rollback' commit 8157d49060b9b55f49fd25ea79c20413d8f97730 Merge: 0de7efe897b e736a1b5a2a Author: Eli Zaretskii Date: Sat Nov 25 12:58:21 2023 +0200 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 0de7efe897b54e703f05c192f064e143e3426b2d Author: Rahguzar Date: Wed Oct 25 15:20:29 2023 +0200 Don't insert subscript on a newline * lisp/net/shr.el (shr-tag-sub): Don't insert subscript on a newline. (Bug#66676) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 71c16ebd126..9f030b4c743 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1451,6 +1451,13 @@ shr-tag-sup (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-sub (dom) + ;; Why would a subscript be at the beginning of a line? It does + ;; happen sometimes because of a
tag and the intent seems to be + ;; alignment of subscript and superscript but I don't think that is + ;; possible in Emacs. So we remove the newline in that case. + (when (bolp) + (forward-char -1) + (delete-char 1)) (let ((start (point))) (shr-generic dom) (put-text-property start (point) 'display `(raise ,shr-sub-raise-factor)) commit d0d9d7f5fa3b306ac66a3b529e337eb3623a475b Author: Rahguzar Date: Tue Oct 24 23:35:44 2023 +0200 Optionally turn on visual-line-mode + outline support * lisp/net/eww.el (eww-render): Turn on 'visual-line-mode' in absence of filling. (eww-mode): Set 'outline-regexp' and 'outline-level'. (Bug#66676) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index d8a66b2ce32..77bb6be2904 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -657,6 +657,8 @@ eww-render (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) + (unless shr-fill-text + (visual-line-mode)) (run-hooks 'eww-after-render-hook) ;; Enable undo again so that undo works in text input ;; boxes. @@ -1217,6 +1219,8 @@ eww-mode (setq-local shr-url-transformer #'eww--transform-url) ;; Also rescale images when rescaling the text. (add-hook 'text-scale-mode-hook #'eww--rescale-images nil t) + (setq-local outline-search-function 'shr-outline-search + outline-level 'shr-outline-level) (setq buffer-read-only t)) (defvar text-scale-mode) commit d41a5e4b1bafbb974d2c886d3198d9bda7821591 Author: Rahguzar Date: Tue Oct 24 22:07:51 2023 +0200 Outline support for shr rendered documents * lisp/net/shr.el (shr-heading): Propertize heading with level. (shr-outline-search): An 'outline-search-function' that finds headings using text property search. (shr-outline-level): Outline level for 'shr-outline-search'. (Bug#66676) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index e54b1a65784..71c16ebd126 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1272,7 +1272,11 @@ shr-image-displayer (defun shr-heading (dom &rest types) (shr-ensure-paragraph) - (apply #'shr-fontize-dom dom types) + (let ((start (point)) + (level (string-to-number + (string-remove-prefix "shr-h" (symbol-name (car types)))))) + (apply #'shr-fontize-dom dom types) + (put-text-property start (pos-eol) 'outline-level level)) (shr-ensure-paragraph)) (defun shr-urlify (start url &optional title) @@ -2069,6 +2073,41 @@ shr-tag-bdi (shr-generic dom) (insert ?\N{POP DIRECTIONAL ISOLATE})) +;;; Outline Support +(defun shr-outline-search (&optional bound move backward looking-at) + "A function that can be used as `outline-search-function' for rendered html. +See `outline-search-function' for BOUND, MOVE, BACKWARD and LOOKING-AT." + (if looking-at + (get-text-property (point) 'outline-level) + (let ((heading-found nil) + (bound (or bound + (if backward (point-min) (point-max))))) + (save-excursion + (when (and (not (bolp)) + (get-text-property (point) 'outline-level)) + (forward-line (if backward -1 1))) + (if backward + (unless (get-text-property (point) 'outline-level) + (goto-char (or (previous-single-property-change + (point) 'outline-level nil bound) + bound))) + (goto-char (or (text-property-not-all (point) bound 'outline-level nil) + bound))) + (goto-char (pos-bol)) + (when (get-text-property (point) 'outline-level) + (setq heading-found (point)))) + (if heading-found + (progn + (set-match-data (list heading-found heading-found)) + (goto-char heading-found)) + (when move + (goto-char bound) + nil))))) + +(defun shr-outline-level () + "Function to be used as `outline-level' with `shr-outline-search'." + (get-text-property (point) 'outline-level)) + ;;; Table rendering algorithm. ;; Table rendering is the only complicated thing here. We do this by commit 42545444055d102deeb2e5513ca20a060dca00f3 Author: Rahguzar Date: Tue Oct 24 20:30:23 2023 +0200 Allow displaying images inline * lisp/net/shr.el (shr-max-inline-image-size): New custom variable. (shr--inline-image-p): New helper function to decide if an image should be inserted inline. (shr-insert, shr-put-image, shr-tag-img): Use 'shr-max-inline-image-size' to insert some images inline. (Bug#66676) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 4e551663e9d..e54b1a65784 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -187,6 +187,24 @@ shr-image-ascent :version "30.1" :type 'integer) +(defcustom shr-max-inline-image-size nil + "If non-nil, determines when the images can be displayed inline. +If nil, images are never displayed inline. + +It non-nil, it should be cons (WIDTH . HEIGHT). + +WIDTH can be an integer which is interpreted as number of pixels. If the width +of an image exceeds this amount, the image is displayed on a separate line. +WIDTH can also be floating point number, in which case the image is displayed +inline if it occupies less than this fraction of window width. + +HEIGHT can be also be an integer or a floating point number. If it is an +integer and the pixel height of an image exceeds it, the image image is +displyed on a separate line. If it is a float number , the limit is +interpreted as a multiple of the height of default font." + :version "30.1" + :type '(choice (const nil) (cons number number))) + (defvar shr-content-function nil "If bound, this should be a function that will return the content. This is used for cid: URLs, and the function is called with the @@ -721,7 +739,8 @@ shr--translate-insertion-chars (replace-match " " t t))) (defun shr-insert (text) - (when (and (not (bolp)) + (when (and (not shr-max-inline-image-size) + (not (bolp)) (get-text-property (1- (point)) 'image-url)) (insert "\n")) (cond @@ -1073,6 +1092,19 @@ shr-image-from-data (declare-function image-size "image.c" (spec &optional pixels frame)) (declare-function image-animate "image" (image &optional index limit position)) +(defun shr--inline-image-p (image) + "Return non-nil if IMAGE should be displayed inline." + (when shr-max-inline-image-size + (let ((size (image-size image t)) + (max-width (car shr-max-inline-image-size)) + (max-height (cdr shr-max-inline-image-size))) + (unless (integerp max-width) + (setq max-width (* max-width (window-width nil t)))) + (unless (integerp max-height) + (setq max-height (* max-height (frame-char-height)))) + (and (< (car size) max-width) + (< (cdr size) max-height))))) + (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. SPEC is either an image data blob, or a list where the first @@ -1103,19 +1135,25 @@ shr-put-image (plist-get flags :width) (plist-get flags :height))))))) (when image + ;; The trailing space can confuse shr-insert into not + ;; putting any space after inline images. + (setq alt (string-trim alt)) ;; When inserting big-ish pictures, put them at the ;; beginning of the line. - (when (and (> (current-column) 0) - (> (car (image-size image t)) 400)) - (insert "\n")) - (let ((image-pos (point))) - (if (eq size 'original) - (insert-sliced-image image (or alt "*") nil 20 1) - (insert-image image (or alt "*"))) - (put-text-property start (point) 'image-size size) - (when (and shr-image-animate - (cdr (image-multi-frame-p image))) - (image-animate image nil 60 image-pos)))) + (let ((inline (shr--inline-image-p image))) + (when (and (> (current-column) 0) + (not inline)) + (insert "\n")) + (let ((image-pos (point))) + (if (eq size 'original) + (insert-sliced-image image (or alt "*") nil 20 1) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) + (when (and (not inline) shr-max-inline-image-size) + (insert "\n")) + (when (and shr-image-animate + (cdr (image-multi-frame-p image))) + (image-animate image nil 60 image-pos))))) image) (insert (or alt "")))) @@ -1676,7 +1714,8 @@ shr-tag-img (and dom (or (> (length (dom-attr dom 'src)) 0) (> (length (dom-attr dom 'srcset)) 0)))) - (when (> (current-column) 0) + (when (and (not shr-max-inline-image-size) + (> (current-column) 0)) (insert "\n")) (let ((alt (dom-attr dom 'alt)) (width (shr-string-number (dom-attr dom 'width))) @@ -1727,8 +1766,14 @@ shr-tag-img (when (image-type-available-p 'svg) (insert-image (shr-make-placeholder-image dom) - (or alt ""))) - (insert " ") + (or (string-trim alt) ""))) + ;; Paradoxically this space causes shr not to insert spaces after + ;; inline images. Since the image is temporary it seem like there + ;; should be no downside to not inserting it but since I don't + ;; understand the code well and for the sake of backward compatibility + ;; we preserve it unless user has set `shr-max-inline-image-size'. + (unless shr-max-inline-image-size + (insert " ")) (url-queue-retrieve url #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) commit 88bd83d17839f6df259c1fc820fdea320545ec4b Author: Rahguzar Date: Mon Oct 23 21:23:53 2023 +0200 Make some aspects of shr rendering customizable * lisp/net/shr.el (shr-fill-text, shr-sup-raise-factor) (shr-sub-raise-factor, shr-image-ascent): New custom variables. (shr-fill-lines): Only fill if 'shr-fill-text' is non-nil. (shr-put-image): Use 'shr-image-ascent' as value of :ascent. (shr-rescale-image, shr-make-placeholder-image): Use 'shr-image-ascent'. (shr-tag-sup, shr-tag-sub): Use 'shr-sup/sub-raise-factor'. (Bug#66676) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 645e1cc51e5..4e551663e9d 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -163,6 +163,30 @@ shr-offer-extend-specpdl :version "28.1" :type 'boolean) +(defcustom shr-fill-text t + "Non-nil means to fill the text according to the width of the window. +If nil, text is not filled, and `visual-line-mode' can be used to reflow text." + :version "30.1" + :type 'boolean) + + +(defcustom shr-sup-raise-factor 0.2 + "The value of raise property for superscripts. +Should be a non-negative float number between 0 and 1." + :version "30.1" + :type 'float) + +(defcustom shr-sub-raise-factor -0.2 + "The value of raise property for subscripts. +Should be a non-positive float number between 0 and 1." + :version "30.1" + :type 'float) + +(defcustom shr-image-ascent 100 + "The value to be used for :ascent property when inserting images." + :version "30.1" + :type 'integer) + (defvar shr-content-function nil "If bound, this should be a function that will return the content. This is used for cid: URLs, and the function is called with the @@ -741,7 +765,7 @@ shr-insert (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) - (if (<= shr-internal-width 0) + (if (or (not shr-fill-text) (<= shr-internal-width 0)) nil (save-restriction (narrow-to-region start end) @@ -1063,11 +1087,11 @@ shr-put-image (start (point)) (image (cond ((eq size 'original) - (create-image data nil t :ascent 100 + (create-image data nil t :ascent shr-image-ascent :format content-type)) ((eq content-type 'image/svg+xml) (when (image-type-available-p 'svg) - (create-image data 'svg t :ascent 100))) + (create-image data 'svg t :ascent shr-image-ascent))) ((eq size 'full) (ignore-errors (shr-rescale-image data content-type @@ -1114,7 +1138,7 @@ shr-rescale-image MAX-WIDTH/MAX-HEIGHT. If not given, use the current window width/height instead." (if (not (get-buffer-window (current-buffer) t)) - (create-image data nil t :ascent 100) + (create-image data nil t :ascent shr-image-ascent) (let* ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer)))) (max-width (truncate (* shr-max-image-proportion @@ -1135,13 +1159,13 @@ shr-rescale-image (< (* height scaling) max-height)) (create-image data (shr--image-type) t - :ascent 100 + :ascent shr-image-ascent :width width :height height :format content-type) (create-image data (shr--image-type) t - :ascent 100 + :ascent shr-image-ascent :max-width max-width :max-height max-height :format content-type))))) @@ -1381,13 +1405,13 @@ shr-tag-svg (defun shr-tag-sup (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise 0.2)) + (put-text-property start (point) 'display `(raise ,shr-sup-raise-factor)) (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-sub (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise -0.2)) + (put-text-property start (point) 'display `(raise ,shr-sub-raise-factor)) (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-p (dom) @@ -1840,7 +1864,7 @@ shr-make-placeholder-image (svg-rectangle svg 0 0 width height :gradient "background" :stroke-width 2 :stroke-color "black") (let ((image (svg-image svg :scale 1))) - (setf (image-property image :ascent) 100) + (setf (image-property image :ascent) shr-image-ascent) image))) (defun shr-tag-pre (dom) commit e736a1b5a2aa2dd8dbaba32a408db70822fe434f Author: Ulrich Müller Date: Fri Nov 17 12:16:54 2023 +0100 Don't enable pinentry loopback mode for gpgsm * lisp/epg.el (epg--start): Passphrase entry through the minibuffer is currently not supported with gpgsm, therefore don't pass "--pinentry-mode loopback" as an argument when the protocol is CMS. (Bug#67012) * doc/misc/epa.texi (GnuPG Pinentry): Document it. diff --git a/doc/misc/epa.texi b/doc/misc/epa.texi index 917fd588593..1aeaef8990f 100644 --- a/doc/misc/epa.texi +++ b/doc/misc/epa.texi @@ -640,6 +640,9 @@ GnuPG Pinentry Emacs. @end enumerate +Note that loopback Pinentry does not work with @command{gpgsm}, +therefore EasyPG will ignore this setting for it. + There are other options available to use Emacs as Pinentry, you might come across a Pinentry called @command{pinentry-emacs} or @command{gpg-agent} option @code{allow-emacs-pinentry}. However, diff --git a/lisp/epg.el b/lisp/epg.el index aae9b9444b4..b994c1b9ca2 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -595,7 +595,12 @@ epg--start (if (epg-context-textmode context) '("--textmode")) (if (epg-context-output-file context) (list "--output" (epg-context-output-file context))) - (if (epg-context-pinentry-mode context) + (if (and (epg-context-pinentry-mode context) + (not + ;; loopback doesn't work with gpgsm + (and (eq (epg-context-protocol context) 'CMS) + (eq (epg-context-pinentry-mode context) + 'loopback)))) (list "--pinentry-mode" (symbol-name (epg-context-pinentry-mode context)))) commit 9656fe03585077370b18c7ece2407e55df24a5fa Author: Liu Hui Date: Mon Nov 20 12:09:15 2023 +0800 Add option `dired-filename-display-length' * lisp/dired.el (dired-filename-display-length): New option. (dired-insert-set-properties): Set invisible property for long filenames. (dired--get-ellipsis-length, dired--get-filename-display-length) (dired-filename-update-invisibility-spec): New functions. (dired-mode): Add filename invisibility spec. (dired-make-directory-clickable) (dired-kill-when-opening-new-dired-buffer) (dired-hide-details-preserved-columns): Add missing :group. * lisp/wdired.el (wdired-change-to-wdired-mode) (wdired-change-to-dired-mode): Update filename invisibility spec. * etc/NEWS: Announce the change. (Bug#67161) diff --git a/etc/NEWS b/etc/NEWS index 259af667c03..458e9e513de 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -496,6 +496,13 @@ It also controls how to move point when encountering a boundary (e.g., if every line is visible, invoking 'dired-next-line' at the last line will move to the first line). The default is nil. +*** New user option 'dired-filename-display-length'. +It is an integer representing the maximum display length of filenames. +The middle part of filename whose length exceeds the restriction is +hidden and an ellipsis is displayed instead. A value of 'window' +means using the right edge of window as the display restriction. The +default is nil. + ** Ediff --- diff --git a/lisp/dired.el b/lisp/dired.el index a3d7c636d29..23a6fc034e1 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -350,6 +350,7 @@ dired-after-readin-hook (defcustom dired-make-directory-clickable t "When non-nil, make the directory at the start of the dired buffer clickable." :version "29.1" + :group 'dired :type 'boolean) (defcustom dired-initial-position-hook nil @@ -429,6 +430,7 @@ dired-mark-region (defcustom dired-kill-when-opening-new-dired-buffer nil "If non-nil, kill the current buffer when selecting a new directory." :type 'boolean + :group 'dired :version "28.1") (defcustom dired-guess-shell-case-fold-search t @@ -516,6 +518,22 @@ dired-movement-style (defcustom dired-hide-details-preserved-columns nil "List of columns which are not hidden in `dired-hide-details-mode'." :type '(repeat integer) + :group 'dired + :version "30.1") + +(defcustom dired-filename-display-length nil + "If non-nil, restrict the display length of filenames. +If the value is the symbol `window', the right edge of current +window is used as the restriction. Otherwise, it should be an +integer representing the maximum filename length. + +The middle part of filename whose length exceeds the restriction +is hidden by using the `invisible' property and an ellipsis is +displayed instead." + :type '(choice (const :tag "No restriction" nil) + (const :tag "Window" window) + (integer :tag "Integer")) + :group 'dired :version "30.1") @@ -1901,51 +1919,72 @@ dired-click-to-select-mode (defvar dired-click-to-select-map) (defun dired-insert-set-properties (beg end) - "Add various text properties to the lines in the region, from BEG to END." + "Add various text properties to the lines in the region, from BEG to END. +Overlays could be added when some user options are enabled, e.g., +`dired-filename-display-length'." + (remove-overlays beg end 'invisible 'dired-filename-hide) (save-excursion (goto-char beg) - (while (< (point) end) - (ignore-errors - (if (not (dired-move-to-filename)) - (unless (or (looking-at-p "^$") - (looking-at-p dired-subdir-regexp)) - (put-text-property (line-beginning-position) - (1+ (line-end-position)) - 'invisible 'dired-hide-details-information)) - (save-excursion - (let ((end (1- (point))) - (opoint (goto-char (1+ (pos-bol)))) - (i 0)) - (put-text-property opoint end 'invisible 'dired-hide-details-detail) - (while (re-search-forward "[^ ]+" end t) - (when (member (cl-incf i) dired-hide-details-preserved-columns) - (put-text-property opoint (point) 'invisible nil)) - (setq opoint (point))))) - (let ((beg (point)) (end (save-excursion - (dired-move-to-end-of-filename) - (1- (point))))) - (if dired-click-to-select-mode - (put-text-property beg end 'keymap - dired-click-to-select-map) - (when (and dired-mouse-drag-files (fboundp 'x-begin-drag)) - (put-text-property beg end 'keymap - dired-mouse-drag-files-map))) - (add-text-properties - beg (1+ end) - `(mouse-face - highlight - dired-filename t - help-echo ,(if dired-click-to-select-mode - "mouse-2: mark or unmark this file" - (if (and dired-mouse-drag-files - (fboundp 'x-begin-drag)) - "down-mouse-1: drag this file to another program + (let ((ell-len (dired--get-ellipsis-length)) maxlen filename-col) + (while (< (point) end) + (ignore-errors + (if (not (dired-move-to-filename)) + (unless (or (looking-at-p "^$") + (looking-at-p dired-subdir-regexp)) + (put-text-property (line-beginning-position) + (1+ (line-end-position)) + 'invisible 'dired-hide-details-information)) + (save-excursion + (let ((end (1- (point))) + (opoint (goto-char (1+ (pos-bol)))) + (i 0)) + (put-text-property opoint end 'invisible 'dired-hide-details-detail) + (while (re-search-forward "[^ ]+" end t) + (when (member (cl-incf i) dired-hide-details-preserved-columns) + (put-text-property opoint (point) 'invisible nil)) + (setq opoint (point))))) + (let ((beg (point)) (end (save-excursion + (dired-move-to-end-of-filename) + (1- (point))))) + (if dired-click-to-select-mode + (put-text-property beg end 'keymap + dired-click-to-select-map) + (when (and dired-mouse-drag-files (fboundp 'x-begin-drag)) + (put-text-property beg end 'keymap + dired-mouse-drag-files-map))) + (when dired-filename-display-length + (let ((len (string-width (buffer-substring beg (1+ end)))) + ell-beg) + (or maxlen (setq maxlen (dired--get-filename-display-length))) + (when (and (integerp maxlen) (> len maxlen (+ ell-len 2))) + (or filename-col (setq filename-col (current-column))) + (move-to-column (+ filename-col (/ maxlen 2))) + (setq ell-beg (point)) + (move-to-column (+ filename-col (/ maxlen 2) + (- len maxlen) ell-len)) + ;; Here we use overlays because isearch by default + ;; doesn't support finding matches in hidden text + ;; made invisible via text properties. + (let ((ov (make-overlay ell-beg (point)))) + (overlay-put ov 'invisible 'dired-filename-hide) + (overlay-put ov 'isearch-open-invisible t) + (overlay-put ov 'evaporate t))))) + (add-text-properties + beg (1+ end) + `(mouse-face + highlight + dired-filename t + help-echo ,(if dired-click-to-select-mode + "mouse-2: mark or unmark this file" + (if (and dired-mouse-drag-files + (fboundp 'x-begin-drag)) + "down-mouse-1: drag this file to another program mouse-2: visit this file in other window" - "mouse-2: visit this file in other window")))) - (when (< (+ end 5) (line-end-position)) - (put-text-property (+ end 5) (line-end-position) - 'invisible 'dired-hide-details-link))))) - (forward-line 1)))) + "mouse-2: visit this file in other window")))) + (when (< (+ end 5) (line-end-position)) + (put-text-property (+ end 5) (line-end-position) + 'invisible 'dired-hide-details-link))))) + (forward-line 1))))) (defun dired--make-directory-clickable () (save-excursion @@ -1977,6 +2016,24 @@ dired--make-directory-clickable "RET" click)))) (setq segment-start (point))))))) +(defun dired--get-ellipsis-length () + "Return length of ellipsis." + (let* ((dt (or (window-display-table) + buffer-display-table + standard-display-table)) + (glyphs (and dt (display-table-slot dt 'selective-display)))) + (string-width (if glyphs (concat glyphs) "...")))) + +(defun dired--get-filename-display-length () + "Return maximum display length of filename. +When `dired-filename-display-length' is not an integer, the +function actually returns the number of columns available for +displaying the file names, and should be called with point at the +first character of the file name." + (if (integerp dired-filename-display-length) + dired-filename-display-length + (- (window-max-chars-per-line) 1 (current-column)))) + ;;; Reverting a dired buffer @@ -2618,6 +2675,7 @@ dired-mode mode-line-buffer-identification (propertized-buffer-identification "%17b")) (add-to-invisibility-spec '(dired . t)) + (dired-filename-update-invisibility-spec) ;; Ignore dired-hide-details-* value of invisible text property by default. (when (eq buffer-invisibility-spec t) (setq buffer-invisibility-spec (list t))) @@ -3117,6 +3175,15 @@ dired-hide-details-update-invisibility-spec ;;; Functions to hide/unhide text +(defun dired-filename-update-invisibility-spec () + "Update `buffer-invisibility-spec' for filenames. +Specifically, the filename invisibility spec is added in Dired +buffers and removed in WDired buffers." + (funcall (if (derived-mode-p 'dired-mode) + 'add-to-invisibility-spec + 'remove-from-invisibility-spec) + '(dired-filename-hide . t))) + (defun dired--find-hidden-pos (start end) (text-property-any start end 'invisible 'dired)) diff --git a/lisp/wdired.el b/lisp/wdired.el index 079d93d6011..b5b01f0d089 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -261,6 +261,10 @@ wdired-change-to-wdired-mode (add-function :override (local 'revert-buffer-function) #'wdired-revert) (set-buffer-modified-p nil) (setq buffer-undo-list nil) + ;; Non-nil `dired-filename-display-length' may cause filenames to be + ;; hidden partly, so we remove filename invisibility spec + ;; temporarily to ensure filenames are visible for editing. + (dired-filename-update-invisibility-spec) (run-mode-hooks 'wdired-mode-hook) (message "%s" (substitute-command-keys "Press \\[wdired-finish-edit] when finished \ @@ -456,6 +460,9 @@ wdired-change-to-dired-mode (dired-sort-set-mode-line) (dired-advertise) (dired-hide-details-update-invisibility-spec) + ;; Restore filename invisibility spec that is removed in + ;; `wdired-change-to-wdired-mode'. + (dired-filename-update-invisibility-spec) (remove-hook 'kill-buffer-hook #'wdired-check-kill-buffer t) (remove-hook 'before-change-functions #'wdired--before-change-fn t) (remove-hook 'after-change-functions #'wdired--restore-properties t) commit 38e2291cce0e396dcb6f379cf74471ab9504522b Author: Eli Zaretskii Date: Sat Nov 25 12:30:03 2023 +0200 Fix merging italic and underline faces with other fonts * lisp/faces.el (italic, underline): Leave the 'slant' resp. 'underline' attributes even when they are not supported by the default font. (Bug#67269) diff --git a/lisp/faces.el b/lisp/faces.el index 7eacc40443a..8eaabbffc0e 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2440,7 +2440,10 @@ italic '((((supports :slant italic)) :slant italic) (((supports :underline t)) - :underline t) + ;; Include italic, even if it isn't supported by the default + ;; font, because this face could be merged with another face + ;; which uses font that does have an italic variant. + :underline t :slant italic) (t ;; Default to italic, even if it doesn't appear to be supported, ;; because in some cases the display engine will do its own @@ -2457,7 +2460,9 @@ bold-italic (defface underline '((((supports :underline t)) :underline t) - (((supports :weight bold)) + ;; Include underline, for when this face is merged with another + ;; whose font does support underline. + (((supports :weight bold :underline t)) :weight bold) (t :underline t)) "Basic underlined face." commit dd1c5cca70f77efb739f0157cac75ac7fd289fe2 Author: Eshel Yaron Date: Mon Nov 20 12:45:11 2023 +0100 ; Avoid 'completion-at-point' in 'completion-preview-insert' Insert the completion suggestion directly in 'completion-preview-insert' instead of using 'completion-at-point' to do that. This fixes an issue where 'completion-preview-insert' would not work correctly when the user uses 'add-hook' with a DEPTH argument below a certain value to add functions to 'completion-at-point-functions', and obviates the need to manipulate 'completion-at-point-functions' when showing the preview all together. * lisp/completion-preview.el (completion-preview--make-overlay) (completion-preview-prev-candidate) (completion-preview-next-candidate) (completion-preview-mode): Improve docstring. (completion-preview--exit-function) (completion-preview--insert) (completion-preview-insert-on-completion): Remove, no longer used. (completion-preview--get): Turn into a 'defsubst'. (completion-preview-active-mode) (completion-preview--capf-wrapper): Simplify. (completion-preview--try-table) (completion-preview--update): Keep the completion "base" as a property of the preview overlay, for use in completion exit functions. (completion-preview-insert): Insert completion and call exit function directly instead of manipulating 'completion-at-point' to do so. (Bug#67275) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index 95410e2e5cd..039a330bc84 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -22,10 +22,11 @@ ;;; Commentary: ;; This library provides the Completion Preview mode. This minor mode -;; displays the top completion candidate for the symbol at point in an +;; displays a completion suggestion for the symbol at point in an ;; overlay after point. Check out the customization group ;; `completion-preview' for user options that you may want to tweak. ;; +;; To enable Completion Preview mode, use `completion-preview-mode'. ;; To accept the completion suggestion, press TAB. If you want to ;; ignore a completion suggestion, just go on editing or moving around ;; the buffer. Completion Preview mode continues to update the @@ -48,15 +49,6 @@ ;; that should appear around point for Emacs to suggest a completion. ;; By default, this option is set to 3, so Emacs suggests a completion ;; if you type "foo", but typing just "fo" doesn't show the preview. -;; -;; The user option `completion-preview-insert-on-completion' controls -;; what happens when you invoke `completion-at-point' while the -;; completion preview is visible. By default this option is nil, -;; which tells `completion-at-point' to ignore the completion preview -;; and show the list of completion candidates as usual. If you set -;; `completion-preview-insert-on-completion' to non-nil, then -;; `completion-at-point' inserts the preview directly without looking -;; for more candidates. ;;; Code: @@ -91,11 +83,6 @@ completion-preview-minimum-symbol-length :type 'natnum :version "30.1") -(defcustom completion-preview-insert-on-completion nil - "Whether \\[completion-at-point] inserts the previewed suggestion." - :type 'boolean - :version "30.1") - (defvar completion-preview-sort-function #'minibuffer--sort-by-length-alpha "Sort function to use for choosing a completion candidate to preview.") @@ -149,7 +136,7 @@ completion-preview-hide (setq completion-preview--overlay nil))) (defun completion-preview--make-overlay (pos string) - "Make a new completion preview overlay at POS showing STRING." + "Make preview overlay showing STRING at POS, or move existing preview there." (if completion-preview--overlay (move-overlay completion-preview--overlay pos pos) (setq completion-preview--overlay (make-overlay pos pos)) @@ -162,23 +149,14 @@ completion-preview--make-overlay (overlay-put completion-preview--overlay 'after-string string)) completion-preview--overlay)) -(defun completion-preview--get (prop) +(defsubst completion-preview--get (prop) "Return property PROP of the completion preview overlay." (overlay-get completion-preview--overlay prop)) (define-minor-mode completion-preview-active-mode "Mode for when the completion preview is shown." :interactive nil - (if completion-preview-active-mode - (add-hook 'completion-at-point-functions #'completion-preview--insert -1 t) - (remove-hook 'completion-at-point-functions #'completion-preview--insert t) - (completion-preview-hide))) - -(defun completion-preview--exit-function (func) - "Return an exit function that hides the completion preview and calls FUNC." - (lambda (&rest args) - (completion-preview-active-mode -1) - (when (functionp func) (apply func args)))) + (unless completion-preview-active-mode (completion-preview-hide))) (defun completion-preview--try-table (table beg end props) "Check TABLE for a completion matching the text between BEG and END. @@ -187,16 +165,16 @@ completion-preview--try-table See `completion-at-point-functions' for more details. If TABLE contains a matching completion, return a list -\(PREVIEW BEG END ALL EXIT-FN) where PREVIEW is the text to show -in the completion preview, ALL is the list of all matching -completion candidates, and EXIT-FN is either a function to call -after inserting PREVIEW or nil. If TABLE does not contain -matching completions, or if there are multiple matching -completions and `completion-preview-exact-match-only' is non-nil, -return nil instead." +\(PREVIEW BEG END ALL BASE EXIT-FN) where PREVIEW is the text to +show in the completion preview, ALL is the list of all matching +completion candidates, BASE is a common prefix that TABLE elided +from the start of each candidate, and EXIT-FN is either a +function to call after inserting PREVIEW or nil. If TABLE does +not contain matching completions, or if there are multiple +matching completions and `completion-preview-exact-match-only' is +non-nil, return nil instead." (let* ((pred (plist-get props :predicate)) - (exit-fn (completion-preview--exit-function - (plist-get props :exit-function))) + (exit-fn (plist-get props :exit-function)) (string (buffer-substring beg end)) (md (completion-metadata string table pred)) (sort-fn (or (completion-metadata-get md 'cycle-sort-function) @@ -217,23 +195,23 @@ completion-preview--try-table 'face (if (cdr sorted) 'completion-preview 'completion-preview-exact)) - (+ beg base) end sorted exit-fn)))))) + (+ beg base) end sorted + (substring string 0 base) exit-fn)))))) (defun completion-preview--capf-wrapper (capf) "Translate return value of CAPF to properties for completion preview overlay." - (unless (eq capf #'completion-preview--insert) - (let ((res (ignore-errors (funcall capf)))) - (and (consp res) - (not (functionp res)) - (seq-let (beg end table &rest plist) res - (or (completion-preview--try-table table beg end plist) - (unless (eq 'no (plist-get plist :exclusive)) - ;; Return non-nil to exclude other capfs. - '(nil)))))))) + (let ((res (ignore-errors (funcall capf)))) + (and (consp res) + (not (functionp res)) + (seq-let (beg end table &rest plist) res + (or (completion-preview--try-table table beg end plist) + (unless (eq 'no (plist-get plist :exclusive)) + ;; Return non-nil to exclude other capfs. + '(nil))))))) (defun completion-preview--update () "Update completion preview." - (seq-let (preview beg end all exit-fn) + (seq-let (preview beg end all base exit-fn) (run-hook-wrapped 'completion-at-point-functions #'completion-preview--capf-wrapper) @@ -243,6 +221,7 @@ completion-preview--update (overlay-put ov 'completion-preview-end end) (overlay-put ov 'completion-preview-index 0) (overlay-put ov 'completion-preview-cands all) + (overlay-put ov 'completion-preview-base base) (overlay-put ov 'completion-preview-exit-fn exit-fn) (completion-preview-active-mode))))) @@ -296,35 +275,30 @@ completion-preview--post-command (completion-preview--show)) (completion-preview-active-mode -1))) -(defun completion-preview--insert () - "Completion at point function for inserting the current preview. - -When `completion-preview-insert-on-completion' is nil, this -function returns nil. Completion Preview mode adds this function -to `completion-at-point-functions' when the preview is shown, -such that `completion-at-point' inserts the preview candidate if -and only if `completion-preview-insert-on-completion' is non-nil." - (when (and completion-preview-active-mode - completion-preview-insert-on-completion) - (list (completion-preview--get 'completion-preview-beg) - (completion-preview--get 'completion-preview-end) - (list (nth (completion-preview--get 'completion-preview-index) - (completion-preview--get 'completion-preview-cands))) - :exit-function (completion-preview--get 'completion-preview-exit-fn)))) - (defun completion-preview-insert () - "Insert the completion candidate that the preview shows." + "Insert the completion candidate that the preview is showing." (interactive) - (let ((completion-preview-insert-on-completion t)) - (completion-at-point))) + (if completion-preview-active-mode + (let* ((pre (completion-preview--get 'completion-preview-base)) + (end (completion-preview--get 'completion-preview-end)) + (ind (completion-preview--get 'completion-preview-index)) + (all (completion-preview--get 'completion-preview-cands)) + (efn (completion-preview--get 'completion-preview-exit-fn)) + (aft (completion-preview--get 'after-string)) + (str (concat pre (nth ind all)))) + (completion-preview-active-mode -1) + (goto-char end) + (insert (substring-no-properties aft)) + (when (functionp efn) (funcall efn str 'finished))) + (user-error "No current completion preview"))) (defun completion-preview-prev-candidate () - "Cycle the candidate that the preview shows to the previous suggestion." + "Cycle the candidate that the preview is showing to the previous suggestion." (interactive) (completion-preview-next-candidate -1)) (defun completion-preview-next-candidate (direction) - "Cycle the candidate that the preview shows in direction DIRECTION. + "Cycle the candidate that the preview is showing in direction DIRECTION. DIRECTION should be either 1 which means cycle forward, or -1 which means cycle backward. Interactively, DIRECTION is the @@ -351,7 +325,16 @@ completion-preview-next-candidate ;;;###autoload (define-minor-mode completion-preview-mode - "Show in-buffer completion preview as you type." + "Show in-buffer completion suggestions in a preview as you type. + +This mode automatically shows and updates the completion preview +according to the text around point. +\\\ +When the preview is visible, \\[completion-preview-insert] +accepts the completion suggestion, +\\[completion-preview-next-candidate] cycles forward to the next +completion suggestion, and \\[completion-preview-prev-candidate] +cycles backward." :lighter " CP" (if completion-preview-mode (add-hook 'post-command-hook #'completion-preview--post-command nil t) commit 3c3c46f4298fca9349fab080d974bdf7cdc7c25a Author: Eshel Yaron Date: Sun Nov 19 10:55:15 2023 +0100 ; Improve and add tests for Completion Preview mode Fix handling of capfs that return a function or signal an error, respect the ':exclusive' completion property, fix lingering "exact" face after deletion that makes the matches non-exact, and add tests. * lisp/completion-preview.el (completion-preview--make-overlay): Only reuse the previous 'after-string' if it has the right face. (completion-preview--try-table) (completion-preview--capf-wrapper): New functions. (completion-preview--update): Use them. * test/lisp/completion-preview-tests.el: New file. (Bug#67275) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index 6048d5be272..95410e2e5cd 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -155,7 +155,9 @@ completion-preview--make-overlay (setq completion-preview--overlay (make-overlay pos pos)) (overlay-put completion-preview--overlay 'window (selected-window))) (let ((previous (overlay-get completion-preview--overlay 'after-string))) - (unless (and previous (string= previous string)) + (unless (and previous (string= previous string) + (eq (get-text-property 0 'face previous) + (get-text-property 0 'face string))) (add-text-properties 0 1 '(cursor 1) string) (overlay-put completion-preview--overlay 'after-string string)) completion-preview--overlay)) @@ -178,48 +180,71 @@ completion-preview--exit-function (completion-preview-active-mode -1) (when (functionp func) (apply func args)))) +(defun completion-preview--try-table (table beg end props) + "Check TABLE for a completion matching the text between BEG and END. + +PROPS is a property list with additional information about TABLE. +See `completion-at-point-functions' for more details. + +If TABLE contains a matching completion, return a list +\(PREVIEW BEG END ALL EXIT-FN) where PREVIEW is the text to show +in the completion preview, ALL is the list of all matching +completion candidates, and EXIT-FN is either a function to call +after inserting PREVIEW or nil. If TABLE does not contain +matching completions, or if there are multiple matching +completions and `completion-preview-exact-match-only' is non-nil, +return nil instead." + (let* ((pred (plist-get props :predicate)) + (exit-fn (completion-preview--exit-function + (plist-get props :exit-function))) + (string (buffer-substring beg end)) + (md (completion-metadata string table pred)) + (sort-fn (or (completion-metadata-get md 'cycle-sort-function) + (completion-metadata-get md 'display-sort-function) + completion-preview-sort-function)) + (all (let ((completion-lazy-hilit t)) + (completion-all-completions string table pred + (- (point) beg) md))) + (last (last all)) + (base (or (cdr last) 0)) + (prefix (substring string base))) + (when last + (setcdr last nil) + (when-let ((sorted (funcall sort-fn + (delete prefix (all-completions prefix all))))) + (unless (and (cdr sorted) completion-preview-exact-match-only) + (list (propertize (substring (car sorted) (length prefix)) + 'face (if (cdr sorted) + 'completion-preview + 'completion-preview-exact)) + (+ beg base) end sorted exit-fn)))))) + +(defun completion-preview--capf-wrapper (capf) + "Translate return value of CAPF to properties for completion preview overlay." + (unless (eq capf #'completion-preview--insert) + (let ((res (ignore-errors (funcall capf)))) + (and (consp res) + (not (functionp res)) + (seq-let (beg end table &rest plist) res + (or (completion-preview--try-table table beg end plist) + (unless (eq 'no (plist-get plist :exclusive)) + ;; Return non-nil to exclude other capfs. + '(nil)))))))) + (defun completion-preview--update () "Update completion preview." - (seq-let (beg end table &rest plist) - (let ((completion-preview-insert-on-completion nil)) - (run-hook-with-args-until-success 'completion-at-point-functions)) - (when (and beg end table) - (let* ((pred (plist-get plist :predicate)) - (exit-fn (completion-preview--exit-function - (plist-get plist :exit-function))) - (string (buffer-substring beg end)) - (md (completion-metadata string table pred)) - (sort-fn (or (completion-metadata-get md 'cycle-sort-function) - (completion-metadata-get md 'display-sort-function) - completion-preview-sort-function)) - (all (let ((completion-lazy-hilit t)) - (completion-all-completions string table pred - (- (point) beg) md))) - (last (last all)) - (base (or (cdr last) 0)) - (bbeg (+ beg base)) - (prefix (substring string base))) - (when last - (setcdr last nil) - (let* ((filtered (remove prefix (all-completions prefix all))) - (sorted (funcall sort-fn filtered)) - (multi (cadr sorted)) ; multiple candidates - (cand (car sorted))) - (when (and cand - (not (and multi - completion-preview-exact-match-only))) - (let* ((face (if multi - 'completion-preview - 'completion-preview-exact)) - (after (propertize (substring cand (length prefix)) - 'face face)) - (ov (completion-preview--make-overlay end after))) - (overlay-put ov 'completion-preview-beg bbeg) - (overlay-put ov 'completion-preview-end end) - (overlay-put ov 'completion-preview-index 0) - (overlay-put ov 'completion-preview-cands sorted) - (overlay-put ov 'completion-preview-exit-fn exit-fn) - (completion-preview-active-mode))))))))) + (seq-let (preview beg end all exit-fn) + (run-hook-wrapped + 'completion-at-point-functions + #'completion-preview--capf-wrapper) + (when preview + (let ((ov (completion-preview--make-overlay end preview))) + (overlay-put ov 'completion-preview-beg beg) + (overlay-put ov 'completion-preview-end end) + (overlay-put ov 'completion-preview-index 0) + (overlay-put ov 'completion-preview-cands all) + (overlay-put ov 'completion-preview-exit-fn exit-fn) + (completion-preview-active-mode))))) (defun completion-preview--show () "Show a new completion preview. diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el new file mode 100644 index 00000000000..b5518e96254 --- /dev/null +++ b/test/lisp/completion-preview-tests.el @@ -0,0 +1,184 @@ +;;; completion-preview-tests.el --- tests for completion-preview.el -*- lexical-binding: t -*- + +;; Copyright (C) 2023 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 . + +;;; Code: + +(require 'ert) +(require 'completion-preview) + +(defun completion-preview-tests--capf (completions &rest props) + (lambda () + (when-let ((bounds (bounds-of-thing-at-point 'symbol))) + (append (list (car bounds) (cdr bounds) completions) props)))) + +(defun completion-preview-tests--check-preview (string &optional exact) + "Check that the completion preview is showing STRING. + +If EXACT is non-nil, check that STRING has the +`completion-preview-exact' face. Otherwise check that STRING has +the `completion-preview' face. + +If STRING is nil, check that there is no completion preview +instead." + (if (not string) + (should (not completion-preview--overlay)) + (should completion-preview--overlay) + (let ((after-string (completion-preview--get 'after-string))) + (should (string= after-string string)) + (should (eq (get-text-property 0 'face after-string) + (if exact + 'completion-preview-exact + 'completion-preview)))))) + +(ert-deftest completion-preview () + "Test Completion Preview mode." + (with-temp-buffer + (setq-local completion-at-point-functions + (list (completion-preview-tests--capf '("foobarbaz")))) + + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Exact match + (completion-preview-tests--check-preview "barbaz" 'exact) + + (insert "v") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; No match, no preview + (completion-preview-tests--check-preview nil) + + (delete-char -1) + (let ((this-command 'delete-backward-char)) + (completion-preview--post-command)) + + ;; Exact match again + (completion-preview-tests--check-preview "barbaz" 'exact))) + +(ert-deftest completion-preview-multiple-matches () + "Test Completion Preview mode with multiple matching candidates." + (with-temp-buffer + (setq-local completion-at-point-functions + (list (completion-preview-tests--capf + '("foobar" "foobaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Multiple matches, the preview shows the first one + (completion-preview-tests--check-preview "bar") + + (completion-preview-next-candidate 1) + + ;; Next match + (completion-preview-tests--check-preview "baz"))) + +(ert-deftest completion-preview-exact-match-only () + "Test `completion-preview-exact-match-only'." + (with-temp-buffer + (setq-local completion-at-point-functions + (list (completion-preview-tests--capf + '("spam" "foobar" "foobaz"))) + completion-preview-exact-match-only t) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Multiple matches, so no preview + (completion-preview-tests--check-preview nil) + + (delete-region (point-min) (point-max)) + (insert "spa") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Exact match + (completion-preview-tests--check-preview "m" 'exact))) + +(ert-deftest completion-preview-function-capfs () + "Test Completion Preview mode with capfs that return a function." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (lambda () #'ignore) + (completion-preview-tests--capf + '("foobar" "foobaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "bar"))) + +(ert-deftest completion-preview-non-exclusive-capfs () + "Test Completion Preview mode with non-exclusive capfs." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("spam") :exclusive 'no) + (completion-preview-tests--capf + '("foobar" "foobaz") :exclusive 'no) + (completion-preview-tests--capf + '("foobarbaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "bar") + (setq-local completion-preview-exact-match-only t) + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "barbaz" 'exact))) + +(ert-deftest completion-preview-face-updates () + "Test updating the face in completion preview when match is no longer exact." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("foobarbaz" "food")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "d") + (insert "b") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "arbaz" 'exact) + (delete-char -1) + (let ((this-command 'delete-backward-char)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "d"))) + +(ert-deftest completion-preview-capf-errors () + "Test Completion Preview mode with capfs that signal errors. + +`dabbrev-capf' is one example of such a capf." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (lambda () (user-error "bad")) + (completion-preview-tests--capf + '("foobarbaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "barbaz" 'exact))) + +;;; completion-preview-tests.el ends here commit 77ab00207d6b421e94500ef6e32624c629e58e08 Author: Eli Zaretskii Date: Sat Nov 25 11:48:38 2023 +0200 ; * admin/authors.el (authors-aliases): Add Noah Peart. diff --git a/admin/authors.el b/admin/authors.el index 266b52f4c90..bbb7a928912 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -200,6 +200,7 @@ authors-aliases (nil "montag451@laposte\\.net") (nil "na@aisrntairetnraoitn") ("Nelson Jose dos Santos Ferreira" "Nelson Ferreira") + ("Noah Peart" "noah\\.v\\.peart@gmail\\.com") ("Noorul Islam" "Noorul Islam K M") ;;; ("Tetsurou Okazaki" "OKAZAKI Tetsurou") ; FIXME? (nil "odanoburu@") commit d5e6b3ff5ae0c1d52db848e56341b6299899fdd1 Author: nverno Date: Thu Nov 16 17:55:59 2023 -0800 Fix test name with erts-run-test with Point-Char * lisp/progmodes/erts-mode.el (erts-run-test): Fix finding the test name when Point-Char is defined, (Bug#67235) diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el index 8dce93eae7e..5ff74082461 100644 --- a/lisp/progmodes/erts-mode.el +++ b/lisp/progmodes/erts-mode.el @@ -181,7 +181,8 @@ erts-run-test (ert-test--erts-test (list (cons 'dummy t) (cons 'code (car (read-from-string test-function))) - (cons 'point-char (erts-mode--preceding-spec "Point-Char"))) + (cons 'point-char (save-match-data + (erts-mode--preceding-spec "Point-Char")))) (buffer-file-name)) (:success (message "Test successful")) (ert-test-failed commit 6f843f03dc21c64d2535105c5bf91180aba554d1 Author: nverno Date: Fri Nov 24 07:18:26 2023 -0800 typescript-ts-mode: Add missing 'operator' to treesit-font-lock-features * lisp/progmodes/typescript-ts-mode.el (typescript-ts-mode): Add operator to treesit-font-lock-feature-list (bug#67433). diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index 4e039abd236..a2b16d1beea 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -428,7 +428,7 @@ typescript-ts-mode '((comment declaration) (keyword string escape-sequence) (constant expression identifier number pattern property) - (function bracket delimiter))) + (operator function bracket delimiter))) (setq-local syntax-propertize-function #'typescript-ts--syntax-propertize) (treesit-major-mode-setup))) commit 0676a02931014e64160c71207ab4ef8d4a33a9b1 Author: Michael Albinus Date: Fri Nov 24 16:34:26 2023 +0100 Extend D-Bus doc and test * doc/misc/dbus.texi (Register Objects): Adapt doc of dbus-unregister-service. * test/lisp/net/dbus-tests.el (dbus--test-register-service): Extend test. diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index 2bd6b9556c8..9dff54ff94a 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -1418,6 +1418,9 @@ Register Objects @item :not-owner We are not an owner of the name @var{service}. @end table + +When @var{service} is not a known name but a unique name, the function +returns nil. @end defun When a name has been chosen, Emacs can offer its own methods, which diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 418ae61bb42..66240efd882 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -465,6 +465,9 @@ dbus--test-register-service (should (eq (dbus-unregister-service bus dbus--test-service) :non-existent)) (should-not (member dbus--test-service (dbus-list-known-names bus))) + ;; Unregistering a unique name returns nil. + (should-not (dbus-unregister-service bus ":1.1")) + ;; A service name is a string, constructed of at least two words ;; separated by ".". (should commit df094dd4bc122d0d1539ee01130dd2b4ed006549 Author: Michael Albinus Date: Fri Nov 24 11:09:15 2023 +0100 Do not unregister a D-Bus service which is a unique name * lisp/net/dbus.el (dbus-unregister-service): Check, whether SERVICE is a known name. (Bug#67386) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index f35d11db152..95f92cf7786 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -682,7 +682,9 @@ dbus-unregister-service `:non-existent': Service name does not exist on this bus. `:not-owner': We are neither the primary owner nor waiting in the -queue of this service." +queue of this service. + +When SERVICE is not a known name but a unique name, the function returns nil." (maphash (lambda (key value) @@ -694,14 +696,17 @@ dbus-unregister-service (puthash key (delete elt value) dbus-registered-objects-table) (remhash key dbus-registered-objects-table))))))) dbus-registered-objects-table) - (let ((reply (dbus-call-method - bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "ReleaseName" service))) - (pcase reply - (1 :released) - (2 :non-existent) - (3 :not-owner) - (_ (signal 'dbus-error (list "Could not unregister service" service)))))) + + (unless (string-prefix-p ":" service) + (let ((reply (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "ReleaseName" service))) + (pcase reply + (1 :released) + (2 :non-existent) + (3 :not-owner) + (_ (signal + 'dbus-error (list "Could not unregister service" service))))))) (defun dbus-register-signal (bus service path interface signal handler &rest args) commit e6ad97a3338c22224eb0da3f0d3226be255298a7 Author: Eli Zaretskii Date: Fri Nov 24 09:30:53 2023 +0200 Fix byte-compilation warnings about 'sqlite-rollback' * lisp/sqlite.el (sqlite-transaction, sqlite-commit) (sqlite-rollback): Declare. * lisp/emacs-lisp/multisession.el (sqlite-commit) (sqlite-transaction): Remove declaration. diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index b09777be407..4f95fc91dd8 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -137,8 +137,6 @@ multisession-value (declare-function sqlite-select "sqlite.c") (declare-function sqlite-open "sqlite.c") (declare-function sqlite-pragma "sqlite.c") -(declare-function sqlite-transaction "sqlite.c") -(declare-function sqlite-commit "sqlite.c") (defvar multisession--db nil) diff --git a/lisp/sqlite.el b/lisp/sqlite.el index 8a525739c9a..22a0355d3cd 100644 --- a/lisp/sqlite.el +++ b/lisp/sqlite.el @@ -23,6 +23,10 @@ ;;; Code: +(declare-function sqlite-transaction "sqlite.c") +(declare-function sqlite-commit "sqlite.c") +(declare-function sqlite-rollback "sqlite.c") + (defmacro with-sqlite-transaction (db &rest body) "Execute BODY while holding a transaction for DB. If BODY completes normally, commit the changes and return