diff options
393 files changed, 12417 insertions, 4742 deletions
diff --git a/ChangeLog.4 b/ChangeLog.4 index 975750f40cd..7cfdbd13184 100644 --- a/ChangeLog.4 +++ b/ChangeLog.4 @@ -1,3 +1,934 @@ +2024-10-25 Eli Zaretskii <eliz@gnu.org> + + Skip *.dylib files in 'loaddefs-generate' + + * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate): Add .dylib + to extensions of files that are skipped. (Bug#74001) + +2024-10-24 Vincenzo Pupillo <v.pupillo@gmail.com> + + Highlight namespace name in "use" clause. + + * lisp/progmodes/php-ts-mode.el (php-ts-mode--font-lock-settings): + New rule to highlight namespace name in "use" clause. (Bug#73975) + +2024-10-24 Sean Whitton <spwhitton@spwhitton.name> + + Update special conditionals documentation + + * doc/lispref/control.texi (Conditionals): Document if-let* and + when-let*, not if-let and when-let. Document and-let*. + +2024-10-23 Sean Whitton <spwhitton@spwhitton.name> + + Document and-let* vs. when-let* usage convention + + * lisp/subr.el (and-let*): Document and/and-let* + vs. when/when-let* usage convention (some discussion in + bug#73853). + (when-let*): Add cross-reference to and-let*. + +2024-10-22 Jim Porter <jporterbugs@gmail.com> + + Fix error when splicing Eshell globs and a glob expands to itself + + This could happen when 'eshell-extended-glob' determines that a "glob" + is not really a glob. This mainly happens for remote file names with a + "~" in them, like "/ssh:remote:~/file.txt". + + * lisp/eshell/em-glob.el (eshell-extended-glob): Return a list when + 'eshell-glob-splice-results' is non-nil. + * test/lisp/eshell/em-glob-tests.el + (em-glob-test/expand/splice-results) + em-glob-test/expand/no-splice-results): Extend tests. + +2024-10-22 Stefan Monnier <monnier@iro.umontreal.ca> + + * etc/package-keyring.gpg: Update expiration and add new key + +2024-10-21 Eli Zaretskii <eliz@gnu.org> + + Avoid crashes when scrolling images under winner-mode + + * src/window.c (window_scroll_pixel_based): Fix calculation of a + window's vscroll. (Bug#73933) + +2024-10-20 Eli Zaretskii <eliz@gnu.org> + + * src/lread.c (READ_AND_BUFFER): Reject negative chars (bug#73914). + +2024-10-20 Michael Albinus <michael.albinus@gmx.de> + + * test/Makefile.in: Do not show emacs-module-tests.log by default. + +2024-10-19 Vincenzo Pupillo <v.pupillo@gmail.com> + + Fix 'php-ts-mode': better indentation and font locking + + Incomplete compound_statement or colon_block (statement-group + without a closing brace or closing keyword) that are not inside + a function or method are not recognized as such by tree-sitter-php. + A new function 'php-ts-mode--open-statement-group-heuristic' + handles this case. Font locking of magic methods and better + support for alternative control structure syntax. + Support for latest grammar version. + * lisp/progmodes/php-ts-mode.el + (php-ts-mode--language-source-alist): Updated grammar version. + (php-ts-mode--possibly-braceless-keyword-re): Regular expression + for braceless keyword. + (php-ts-mode--open-statement-group-heuristic): New function. + (php-ts-mode--parent-html-bol): Use the new function and doc fix. + (php-ts-mode--parent-html-heuristic): Use the new function and doc + fix. + (php-ts-mode--indent-styles): Use the new function and add + 'colon_block' support. + (php-ts-mode--class-magic-methods): New predefined magic methods + list. + (php-ts-mode--test-namespace-name-as-prefix-p): Doc fix. + (php-ts-mode--test-namespace-aliasing-clause-p): Fix the test and + doc. + (php-ts-mode--test-namespace-use-group-clause-p): Doc fix. + (php-ts-mode--test-visibility-modifier-operation-clause-p): New + function for the new asymmetric property visibility feature of + PHP 8.4. + (php-ts-mode--font-lock-settings): Font lock for class magic methods + and alternative syntax. Better font lock for 'instanceof'. Use + 'font-lock-function-call-face' for scoped and member call expression. + (bug#73779) + +2024-10-19 Michael Albinus <michael.albinus@gmx.de> + + * lisp/auth-source.el (read-passwd): Remove entry from `post-command-hook'. + +2024-10-19 Eli Zaretskii <eliz@gnu.org> + + New FAQ about Ctrl keys on xterm + + * doc/misc/efaq.texi + (Some Ctrl-modified keys do not work on xterm): New section + (bug#73813). + +2024-10-19 Eli Zaretskii <eliz@gnu.org> + + Autoload 'message-narrow-to-headers-or-head' in mml.el + + * lisp/gnus/mml.el (message-narrow-to-headers-or-head): Autoload + it. (Bug#73815) + +2024-10-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * lisp/emacs-lisp/pcase.el (pcase--make-docstring): Fix bug#73766 + + Do not merge to `master`. + +2024-10-18 Michael Albinus <michael.albinus@gmx.de> + + Locate password icon in global-mode-string + + * doc/emacs/mini.texi (Passwords): Precise the location of the + password icon. + + * doc/lispref/minibuf.texi (Reading a Password): The password icon + is added to global-mode-string. + + * lisp/auth-source.el (read-passwd--mode-line-buffer): Remove. + (read-passwd--hide-password): Fix docstring. + (read-passwd-toggle-visibility): Don't use + `read-passwd--mode-line-buffer'. Check for `read-passwd-mode'. + Force update in all mode lines. + (read-passwd-mode): Set `read-passwd--mode-line-icon' in + `global-mode-string'. (Bug#73768) + +2024-10-18 Robert Pluim <rpluim@gmail.com> + + Explain tty-color-mode frame parameter more. + + * doc/emacs/cmdargs.texi (Colors X): Explain that tty color + support is dynamic. + * doc/lispref/frames.texi (Font and Color Parameters): Explain + that 'tty-color-mode' can be changed on the fly. + * doc/misc/efaq.texi (Colors on a TTY): Explain how to disable + 'tty-color-mode', either at startup or dynamically. + +2024-10-17 Stefan Monnier <monnier@iro.umontreal.ca> + + (track-changes--after): Fix problem found in bug#73041 + + When calling `track-changes--before` (e.g. because of a missing + b-f-c or for some other reason), it sets `track-changes--before-end` + to the right value so we shouldn't increment it right after. + Also, we should update `track-changes--buffer-size` before + calling `track-changes--before` so it doesn't risk signaling + a spurious inconsistency. + + * lisp/emacs-lisp/track-changes.el (track-changes--after): + Update `track-changes--buffer-size` earlier, and don't increment + `track-changes--before-end` when we call `track-changes--before`. + +2024-10-16 Jim Porter <jporterbugs@gmail.com> + + Fix Eshell's evaluation of empty 'progn' forms + + Do not merge to master. + + * lisp/eshell/esh-cmd.el (eshell-do-eval): Make sure we evaluate to + 'nil' for 'progn' forms with no body (bug#73722). + +2024-10-15 Andrea Corallo <acorallo@gnu.org> + + * lisp/progmodes/c-ts-mode.el (treesit-node-eq): Declare to silence warning. + +2024-10-15 Michael Albinus <michael.albinus@gmx.de> + + * admin/notes/emba: Docker builds do not run in a worktree. + +2024-10-15 Ulrich Müller <ulm@gentoo.org> + + * lisp/calc/calc-ext.el (math-approx-sqrt-e): Doc fix (bug#73817). + +2024-10-15 Eli Zaretskii <eliz@gnu.org> + + : Revert a mistaken change + + * lisp/net/dictionary.el (dictionary-word-definition-face): Revert + a mistakenly installed change. + +2024-10-15 Yuan Fu <casouri@gmail.com> + + Fix c-ts-mode--anchor-prev-sibling (bug#73661) + + * lisp/progmodes/c-ts-mode.el: + (c-ts-mode--anchor-prev-sibling): Fix parentheses and use a + slightly more efficient function. + * test/lisp/progmodes/c-ts-mode-resources/indent.erts: Replace + the tab in the test code with spaces. + +2024-10-14 Earl Hyatt <okamsn@protonmail.com> + + Fix formatting of long keyboard macros by 'list-keyboard-macros'. + + * lisp/kmacro.el (kmacro-menu--refresh): Include the second + argument of 'format-kbd-macro' so that the formatted keyboard + macro is on a single line. (Bug#73797) + +2024-10-13 Michael Albinus <michael.albinus@gmx.de> + + * doc/emacs/mini.texi (Passwords): Mention password visibility. + +2024-10-10 Jørgen Kvalsvik <j@lambda.is> (tiny change) + + Fix c-ts-mode indentation for initializer lists (bug#73661) + + The indentation behavior differed between c-mode/c++-mode + and *-ts-mode for initializer lists where the first element was + not at beginning-of-line. The anchor-prev-sibling function gave + up and returned nil, but it should (probably) anchor on the + first element in the initializer list, such as this: + + return { v1, v2, ..., + y1, y2, ... }; + + c-ts-mode behaved better and figured out how to align, but I + added a test for a similar compound literal to prevent + regressions. + + * lisp/progmodes/c-ts-mode.el (c-ts-mode--anchor-prev-sibling): + Anchor at first sibling unless bol is found. + + * test/lisp/progmodes/c-ts-mode-resources/indent.erts: New + initializer list and compound literal test. + +2024-10-09 Eli Zaretskii <eliz@gnu.org> + + Avoid segfaults in Rmail-MIME + + Rmail-MIME decodes text of email, including removal of + CR characters, but that can segfault if the text of some + MIME part is empty. + * src/coding.c (decode_coding_raw_text): + * lisp/mail/rmailmm.el (rmail-mime-insert-decoded-text): Don't + attempt to decode empty text region. + +2024-10-09 Brennan Vincent <brennan@umanwizard.com> (tiny change) + + Eglot: use :immediate t when resolving completions (bug#73279) + + + * lisp/progmodes/eglot.el (eglot-completion-at-point): Tweak + eglot--request call. + +2024-10-09 João Távora <joaotavora@gmail.com> + + Eglot: minor changes to doc and docstrings + + * doc/misc/eglot.texi (Quick Start): Tweak. + (Setting Up LSP Servers): Tweak. + (Customizing Eglot): Clarify eglot-connect-hook and + eglot-initialized-hook. + + * lisp/progmodes/eglot.el (eglot-connect-hook) + (eglot-server-initialized-hook): Rework docstring. + +2024-10-09 Yuan Fu <casouri@gmail.com> + + Revert "Set treesit-primary-parser for tree-sitter modes" + + This reverts commit ed57faafc74e0810b492841deccb3cdc77a258ff. + +2024-10-08 Yuan Fu <casouri@gmail.com> + + Remove duplicate indent rules in elixir-ts-mode + + * lisp/progmodes/elixir-ts-mode.el (elixir-ts-mode): There are + two forms adding heex-ts--indent-rules, remove one of them. + +2024-10-08 Yuan Fu <casouri@gmail.com> + + Set treesit-primary-parser for tree-sitter modes + + I debated whether to do this, since technically speaking it's + not needed for single-language modes. But ultimately it's + better to be explicit and set a good example with builtin modes. + + * lisp/progmodes/cmake-ts-mode.el (cmake-ts-mode): + * lisp/progmodes/csharp-mode.el (csharp-ts-mode): + * lisp/progmodes/dockerfile-ts-mode.el (dockerfile-ts-mode): + * lisp/progmodes/go-ts-mode.el (go-ts-mode): + (go-mod-ts-mode): + * lisp/progmodes/heex-ts-mode.el (heex-ts-mode): + * lisp/progmodes/java-ts-mode.el (java-ts-mode): + * lisp/progmodes/json-ts-mode.el (json-ts-mode): + * lisp/progmodes/lua-ts-mode.el (lua-ts-mode): + * lisp/progmodes/python.el (python-ts-mode): + * lisp/progmodes/ruby-ts-mode.el (ruby-ts-mode): + * lisp/progmodes/rust-ts-mode.el (rust-ts-mode): + * lisp/progmodes/sh-script.el: + * lisp/progmodes/typescript-ts-mode.el (typescript-ts-mode): + (tsx-ts-mode): + * lisp/textmodes/css-mode.el (css-ts-mode): + * lisp/textmodes/html-ts-mode.el (html-ts-mode): + * lisp/textmodes/toml-ts-mode.el (toml-ts-mode): + * lisp/textmodes/yaml-ts-mode.el (yaml-ts-mode): Set + treesit-primary-parser. + +2024-10-06 Stefan Kangas <stefankangas@gmail.com> + + Delete XIE X extension from TODO + + According to Wikipedia, XIE "is no longer included in the X11 reference + distribution, having been removed with X11R6.7 in 2004." + Ref: https://en.wikipedia.org/wiki/X_Image_Extension + + * etc/TODO: Delete item to use XIE X extension. + +2024-10-05 Morgan Willcock <morgan@ice9.digital> + + Restore comment/string check for 'electric-layout-mode' + + This reverts an accidental change which allowed + 'electric-layout-mode' to insert newlines inside strings and + comments. The new behavior can be obtained by setting the + new variable 'electric-layout-allow-in-comment-or-string' to a + non-nil value. + * lisp/electric.el (electric-layout-allow-in-comment-or-string): + New variable to determine whether inserting newlines is + permitted within comments or strings. + (electric-layout-post-self-insert-function-1): Restore the + previous default behavior of not inserting newlines within + comments or strings. + +2024-10-05 Stefan Kangas <stefankangas@gmail.com> + + Update Arni Magnusson's email address + + * .mailmap: + * doc/lispref/ChangeLog.1: + * doc/misc/ChangeLog.1: + * lisp/ChangeLog.16: + * lisp/ChangeLog.17: + * lisp/progmodes/bat-mode.el: Update email address of + Arni Magnusson. (Bug#73631) + +2024-10-05 Stefan Kangas <stefankangas@gmail.com> + + Fix python-ts-mode-map docstring + + * lisp/progmodes/python.el (python-ts-mode-map): Fix docstring. + +2024-10-05 Stefan Kangas <stefankangas@gmail.com> + + Normalize "Commentary" section in eudc.el + + * lisp/net/eudc.el: Normalize "Commentary" section to make + 'M-x describe-package RET eudc RET' more useful. + +2024-10-04 Eli Zaretskii <eliz@gnu.org> + + Expand email abbrevs in X-Debbugs-Cc header. + + * lisp/mail/mailabbrev.el (mail-abbrev-mode-regexp): + * lisp/mail/mailalias.el (mail-address-field-regexp) + (mail-complete-alist): Add "X-Debbugs-Cc" to headers where email + aliases should be expanded, for compatibility with emacsbug.el. + +2024-10-04 Eli Zaretskii <eliz@gnu.org> + + Fix 'list-tags' when invoked from a non-file buffer + + This use case was broken by the improvement that attempts to + offer the current buffer's file name as the default file whose + tags to list. + * lisp/progmodes/etags.el + (tags--get-current-buffer-name-in-tags-file): Doc fix. Return nil + if no file is associated with the current buffer, and avoid + signaling an error if 'buffer-file-name' returns nil. (Bug#37611) + (list-tags): Doc fix. Signal an error if the user specifies no + file name at the prompt. + + * doc/emacs/maintaining.texi (List Identifiers): Fix wording of + the documentation of 'list-tags'. + +2024-10-04 Sean Whitton <spwhitton@spwhitton.name> + + count-windows: Fix reference to walk-windows + + * lisp/window.el (count-windows): Refer to walk-windows for the + precise meaning of both the MINIBUF and ALL-FRAMES arguments, + not just the ALL-FRAMES argument. In both functions, these + arguments are both passed through to window-list-1. + +2024-10-03 Stefan Kangas <stefankangas@gmail.com> + + * lisp/info-look.el (mapc): Add use-package manual's index. + +2024-10-03 Yuan Fu <casouri@gmail.com> + + Update csharp-ts-mode font-lock (bug#73369) + + Adapt to the latest c-sharp grammar. + + * lisp/progmodes/csharp-mode.el: + (csharp-ts-mode--test-this-expression): + (csharp-ts-mode--test-interpolated-string-text): + (csharp-ts-mode--test-type-constraint): + (csharp-ts-mode--test-type-of-expression): + (csharp-ts-mode--test-name-equals): + (csharp-ts-mode--test-if-directive): + (csharp-ts-mode--test-method-declaration-type-field): New + functions. + (csharp-ts-mode--type-field): New variable. + (csharp-ts-mode--font-lock-settings): Fix font-lock rules. + +2024-10-02 Sean Whitton <spwhitton@spwhitton.name> + + Fix inconsistency in value of rcirc-activity-string + + * lisp/net/rcirc.el (rcirc-update-activity-string): Consistently + don't display anything if there aren't any IRC connections. + +2024-10-02 Stefan Kangas <stefankangas@gmail.com> + + Revert "; Minor clarification in variables.texi" + + This reverts commit 44156c2140772fa04ebbc0a488a85f0741e0c2ef. + +2024-10-01 john muhl <jm@pub.pink> + + Tag interactive commands in 'lua-ts-mode' + + * lisp/progmodes/lua-ts-mode.el (lua-ts-send-buffer) + (lua-ts-send-file, lua-ts-send-region): Mark inferior interaction + commands that are only relevant in Lua buffers. (Bug#73586) + +2024-10-01 Stefan Kangas <stefankangas@gmail.com> + + Mention LSP acronym in eglot defgroup docstring + + * lisp/progmodes/eglot.el (eglot): Improve defgroup description by + mentioning the LSP acronym, for users that might be searching for that. + +2024-10-01 Stefan Kangas <stefankangas@gmail.com> + + Change :group of 'eglot' defgroup to 'tools' + + In 'M-x customize', Eglot fits in better in "Programming -> Tools", with + the likes of Flymake and Gud, than it does in "Applications", with ERC + and Newsticker. + + * lisp/progmodes/eglot.el (eglot): Change :group of defgroup to 'tools'. + +2024-09-30 Stefan Kangas <stefankangas@gmail.com> + + Remove out-of-date documentation from python.el + + * lisp/progmodes/python.el: Remove out-of-date documentation about + automatic indentation; 'electric-indent-mode' is enabled by default in + Emacs 24.4 or later, so this is no longer an issue. + +2024-09-30 Jim Porter <jporterbugs@gmail.com> + + Fix executing commands in Eshell using "env" with no local variables + + * lisp/eshell/esh-var.el (eshell/env): Throw 'eshell-replace-command' as + needed. + + * test/lisp/eshell/esh-var-tests.el + (esh-var-test/local-variables/env/no-locals): New test (bug#73479). + +2024-09-29 Gautier Ponsinet <gautier@gautierponsinet.xyz> + + Fix a typo in the calendar manual + + * doc/emacs/calendar.texi (Calendar Unit Motion): Add a missing + parenthesis. (Bug#73555) + +2024-09-28 Morgan Willcock <morgan@ice9.digital> + + Require ert-x for use by 'ert-font-lock-deftest-file' + + This fixes a void-function error when 'ert-font-lock-deftest-file' + is called when ert-x has not already been loaded. + * lisp/emacs-lisp/ert-font-lock.el (ert): Require ert-x so that + 'ert-resource-file' is available for use within + 'ert-font-lock-deftest-file'. (Bug#73254) + +2024-09-28 Vincenzo Pupillo <v.pupillo@gmail.com> + + Fix php-ts-mode font-lock for latest PHP grammar (bug#73516) + + Version 0.23 of the PHP grammar introduced some changes that + affect the font lock. + + * lisp/progmodes/php-ts-mode.el + (php-ts-mode--language-source-alist): Update php, html, js and css + grammars version. + (php-ts-mode--parent-html-heuristic): Fix docstring + (php-ts-mode--test-namespace-name-as-prefix-p): New function. + (php-ts-mode--test-namespace-aliasing-clause-p): New function. + (php-ts-mode--test-namespace-use-group-clause-p): New function. + (php-ts-mode--font-lock-settings): Use the new functions. + +2024-09-27 Stefan Monnier <monnier@iro.umontreal.ca> + + eieio.texi: Fix bug#73505 + + * doc/misc/eieio.texi (Introduction): Remove "missing features" which + aren't missing any more. + (Generics, Methods): Delete sections. + (Inheritance): Adjust reference accordingly. + (Static Methods): Merge into the parent node. + (Writing Methods): Refer to the ELisp manual for `cl-defmethod/defgeneric`. + +2024-09-26 Andrés Ramírez <rrandresf@hotmail.com> (tiny change) + + Delete duplicated line in Viper refcard + + * etc/refcards/viperCard.tex: Delete duplicated line. (Bug#73480) + +2024-09-25 Michael Albinus <michael.albinus@gmx.de> + + Fix Tramp shortdoc integration + + * lisp/net/tramp-integration.el (tramp-syntax): Declare. + (shortdoc): Check, that Tramp has `default' syntax. + +2024-09-25 Juri Linkov <juri@linkov.net> + + * lisp/imenu.el (imenu-flatten): More limitations in docstring (bug#73117) + +2024-09-25 Sean Whitton <spwhitton@spwhitton.name> + + remember-data-file: Don't unconditionally call set-visited-file-name + + * lisp/textmodes/remember.el (remember-data-file): Don't + unconditionally call set-visited-file-name. + +2024-09-25 Thomas Voss <mail@thomasvoss.com> (tiny change) + + Align columns in which-key with wide characters properly + + In the case that a character takes up multiple columns (such as + `…' when used as a truncation character), make sure that the + columns are still aligned properly. + * lisp/which-key.el (which-key--pad-column): Use `string-width' + instead of `length'. (Bug#73463) + +2024-09-25 Roland Winkler <winkler@gnu.org> + + bibtex-mode: fix patch bibtex validation for non-file buffers + +2024-09-24 Robert Pluim <rpluim@gmail.com> + + Document 'buttonize-region' in manual + + It was added in emacs-29, but never added to the lisp reference + manual. + + * doc/lispref/display.texi (Making Buttons): Document + 'buttonize-region'. + +2024-09-24 Tassilo Horn <tsdh@gnu.org> + + Use black-on-white by default for doc-view-svg-face. + + * lisp/doc-view.el (doc-view-svg-face): Define black on white as + default value instead of using the current theme's values. + * etc/NEWS: Adjust entry for doc-view-svg-face. + +2024-09-23 Dmitry Gutov <dmitry@gutov.dev> + + etags-regen-file-extensions: Enable for more extensions + + * lisp/progmodes/etags-regen.el (etags-regen-file-extensions): + Add more extensions, but remove "a". From the ones recognized by + etags, also omit "t", "ml", "l", "def" and "inc", see + https://lists.gnu.org/archive/html/emacs-devel/2024-09/msg00735.html. + (etags-regen--all-files): Use 'string-match-p' for performance. + Bind 'case-fold-search' to t to match extensions in any case. + +2024-09-21 Stephen Berman <stephen.berman@gmx.net> + + Update and improve UI of sql-read-product (bug#73412) + + * lisp/progmodes/sql.el (sql-read-product): In invocation of + completing-read use format-prompt and make deprecated argument + INITIAL-INPUT nil. + (sql-set-product, sql-product-interactive): In invocation of + sql-read-product adjust prompt to use of format-prompt. + +2024-09-21 Philip Kaludercic <philipk@posteo.net> + + Insert correct commit data into VC package descriptions + + * lisp/emacs-lisp/package-vc.el (package-vc-commit): Rename + argument from PKG to PKG-DESC. + (package-vc--generate-description-file): Update the "extras" + section of the package description with the revision string at + generation time. + +2024-09-21 Stefan Kangas <stefankangas@gmail.com> + + Document reporting security issues in user manual + + * doc/emacs/trouble.texi (Bugs): Document how to report important + security issues. + +2024-09-21 Stefan Kangas <stefankangas@gmail.com> + + * BUGS: Minor copy edit. + +2024-09-21 Stefan Monnier <monnier@iro.umontreal.ca> + + Fix font-lock of last character before EOB under 'whitespace-mode' + + * lisp/whitespace.el (whitespace-color-on): Don't use OVERRIDE in + font-lock-keywords; instead, use 'prepend' in the call to + 'font-lock-add-keywords'. (Bug#73332) + +2024-09-21 Eli Zaretskii <eliz@gnu.org> + + Fix 'whitespace-mode' with 'missing-newline-at-eof' + + * lisp/whitespace.el (whitespace-post-command-hook): Refontify + when point moves if 'missing-newline-at-eof' is in + 'whitespace-active-style'. (Bug#73332) + +2024-09-21 Eli Zaretskii <eliz@gnu.org> + + Fix 'replace-regexp' in WDired + + * src/search.c (Freplace_match): Revert the search.c part of the + change from Apr 7, 2024, which aims to fix bug#65451, but causes + bug#73018. Do not merge to master. + + * test/src/editfns-tests.el + (editfns-tests--before/after-change-functions): Expect this test + to fail. + +2024-09-21 Peter Oliver <git@mavit.org.uk> + + Disable xwidgets with recent webkitgtk versions (Bug#66068) + + * configure.ac: Accept only webkit2gtk-4.* versions less than 2.41.92. + +2024-09-21 Yuan Fu <casouri@gmail.com> + + Fix treesit--merge-ranges (bug#73324) + + * lisp/treesit.el (treesit--merge-ranges): Make sure that old + ranges that intersects with START-END are actually discarded. + * test/src/treesit-tests.el (treesit-range-merge): New test. + +2024-09-21 Stefan Kangas <stefankangas@gmail.com> + + Fix midnight-mode documentation + + * lisp/midnight.el (Commentary): Document that 'midnight-mode' should be + enabled using the function, instead of by merely loading the library. + In Emacs 31, doing the latter will no longer work. (Bug#73291) + +2024-09-20 Stefan Monnier <monnier@iro.umontreal.ca> + + editorconfig.el: Fix too naive sync from upstream + + * lisp/editorconfig.el (editorconfig--get-indentation-nxml-mode): + New function. + (editorconfig-indentation-alist): Use it to fix bug#73359. + +2024-09-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * lisp/progmodes/eglot.el (eglot--signal-textDocument/didOpen): Fix bug#72696 + +2024-09-20 Po Lu <luangruo@yahoo.com> + + Disable fontset-related workaround on non-Android systems + + * src/fontset.c (fontset_find_font) [!HAVE_ANDROID]: Don't + refuse to cache font objects whose registries do not agree with + the font specs. (bug#73363) + + Do not merge to master. + +2024-09-20 Sean Whitton <spwhitton@spwhitton.name> + + etags-regen-file-extensions: Add .pm + + * lisp/progmodes/etags-regen.el (etags-regen-file-extensions): + Add .pm. + +2024-09-19 Andrea Corallo <acorallo@gnu.org> + + * src/treesit.c (treesit_debug_print_parser_list): Fix compiler warning. + +2024-09-19 Robert Pluim <rpluim@gmail.com> + + Type-check argument to network-lookup-address-info + + * src/process.c (Fnetwork_lookup_address_info): Check that the + "name" argument is a string, and mention 'puny-encode-domain'. + (Bug#73337) + +2024-09-18 Yuan Fu <casouri@gmail.com> + + Conservative heuristic for tree-sitter parser ranges (bug#73324) + + * src/treesit.c (treesit_sync_visible_region): If the parser's original + ranges don't overlap with visible region, give it a zero range, rather + than don't set any range. + * test/src/treesit-tests.el (treesit-range-fixup-after-edit): Test new + behavior. + +2024-09-17 Mattias Engdegård <mattiase@acm.org> + + Re-enable GC mark trace buffer by default + + Enable GC_REMEMBER_LAST_MARKED by default (it was disabled in Emacs 29) + to make it easier to debug difficult-to-reproduce GC problems + encountered by users. This increases GC costs by about 5 %, which can + be avoided by turning the mark trace buffer back off using the new + --disable-gc-mark-trace option. + + See discussion at + https://lists.gnu.org/archive/html/emacs-devel/2024-09/msg00240.html + + * configure.ac (--disable-gc-mark-trace): New config option. + * etc/NEWS: Mention it. + * src/alloc.c: Enable it by default and avoid a compiler warning. + +2024-09-15 Yuan Fu <casouri@gmail.com> + + Fix treesit_sync_visible_region's range fixup code (bug#73264) + + new_ranges_head + | + v + ( )->( )->( )->( )->( ) + ^ ^ + | | + | lisp_ranges (loop head) + | + prev_cons -> set cdr to nil to cut of the rest + + result: + + ( )->( ) + + * src/treesit.c (treesit_sync_visible_region): Cut off this cons and the + rest, not set the current range's end to nil. + * test/src/treesit-tests.el: + (treesit-range-fixup-after-edit): Add tests for all cases. + +2024-09-15 Po Lu <luangruo@yahoo.com> + + Document unavailability of frame geometry on Wayland + + * etc/PROBLEMS (Runtime problems specific to PGTK build): + Document that frame-edges and company are liable not to return + valid coordinates. (bug#73207) + +2024-09-15 Po Lu <luangruo@yahoo.com> + + Port to Haiku R1/beta5 + + * src/haiku_support.cc (keysym_from_raw_char): Use revised names + for B_HANGUL and B_HANGUL_HANJA. + +2024-09-14 Yuan Fu <casouri@gmail.com> + + Fix c++-ts-mode font-lock for latest c++ grammar (bug#73191) + + * lisp/progmodes/c-ts-mode.el: + (c-ts-mode--keywords): Add "thread_local" keyword. + (c-ts-mode--test-virtual-named-p): New function. + (c-ts-mode--font-lock-settings): Use named/anonymous "virtual" depending + on the grammar. + +2024-09-14 Stefan Kangas <stefankangas@gmail.com> + + * admin/update-copyright: Print reminder to do manual updates. + + * admin/notes/years: Update. + +2024-09-14 Stefan Kangas <stefankangas@gmail.com> + + * etc/TODO: New item "support indentation guides". + + Ref: + https://lists.gnu.org/r/emacs-devel/2024-07/msg01062.html + +2024-09-14 Stephen Berman <stephen.berman@gmx.net> + + Fix regression in widget-move (bug#72995) + + * lisp/wid-edit.el (widget-move): Avoid advancing point only if it + is at the start of a widget at BOB. + + * test/lisp/wid-edit-tests.el (widget-test-widget-move-bug72995): New test. + +2024-09-14 Spencer Baugh <sbaugh@janestreet.com> + + Correctly include fixed strings before a prefix wildcard in PCM + + In 03ac16ece40ba3e3ba805d6a61cc457d84bf3792 I fixed a bug with the + PCM implementation of substring completion, relating to the handling + of PCM wildcards. + However, this fix was incomplete. This change completes the fix by + also including a fixed string if it appears before a 'prefix' + wildcard, even if 'try-completion' doesn't discover that fixed + string grows to a unique completion. + I discovered this bug while working on enhancements to PCM + completion related to 'completion-pcm-leading-wildcard'. + * lisp/minibuffer.el (completion-pcm--merge-completions): Include + fixed strings before 'prefix wildcard. (Bug#72819) + * test/lisp/minibuffer-tests.el (completion-substring-test-5): Add a + test for this behavior. + +2024-09-14 Yuan Fu <casouri@gmail.com> + + Set treesit-primary-parser for c and elixir ts mode + + For buffers with multiple parsers, it's important to set this variable + so font-lock invalidation works smoothly. + + * lisp/progmodes/c-ts-mode.el (c-ts-mode): Set treesit-primary-parser. + * lisp/progmodes/elixir-ts-mode.el (elixir-ts-mode): Set + treesit-primary-parser. + +2024-09-14 Yuan Fu <casouri@gmail.com> + + Fix range handling so it works for multibyte buffer (bug#73204) + + Here by multibyte buffer I mean buffer that includes non-ASCII + characters. + + The problem is illustrated by this comment, which I copied from the + source: + + ====================================================================== + (ref:bytepos-range-pitfall) Suppose we have the following buffer + content ([ ] is a unibyte char, [ ] is a multibyte char): + + [a][b][c][d][e][ f ] + + and the following ranges (denoted by braces): + + [a][b][c][d][e][ f ] + { }{ } + + So far so good, now user deletes a unibyte char at the beginning: + + [b][c][d][e][ f ] + { }{ } + + Oops, now our range cuts into the multibyte char, bad! + ====================================================================== + + * src/treesit.c (treesit_debug_print_parser_list): Minor fix. + (treesit_sync_visible_region): Change the way we fixup ranges, instead + of using the bytepos ranges from tree-sitter, we use the cached lisp + charpos ranges. + (treesit_make_ts_ranges): New function. + (Ftreesit_parser_set_included_ranges): Refactor out the new function + treesit_make_ts_ranges. + (Ftreesit_parser_included_ranges): Rather than getting the ranges from + tree-sitter, just return the cached lisp ranges. + + * src/treesit.h (Lisp_TS_Parser): Add some comment. + * test/src/treesit-tests.el (treesit-range-fixup-after-edit): New test. + +2024-09-14 Yuan Fu <casouri@gmail.com> + + Revert "Read more on each call to treesit's buffer reader" + + This reverts commit bf23382f1f2d6ea072db4e4750f8a345f77a3ef2. + + We move around the gap, narrow regions, ralloc, etc, and don't have a + way to invalidate previously given range. So tree-sitter can't be given + the full range. + +2024-09-14 Yuan Fu <casouri@gmail.com> + + Fix tree-sitter indent preset prev-adaptive-prefix + + * lisp/treesit.el (treesit-simple-indent-presets): Use looking-at so the + call to match-string has the match data to work with. + +2024-09-13 Robert Pluim <rpluim@gmail.com> + + Improve NEWS entries + + * etc/NEWS: Fix typos, and add information about default values of new + user options. + +2024-09-13 Mattias Engdegård <mattiase@acm.org> + + Don't fail uniquify-tests in non-version-controlled source trees + + * test/lisp/uniquify-tests.el (uniquify-project-transform): + Skip test if there is no project (bug#73205). + +2024-09-13 Stefan Kangas <stefankangas@gmail.com> + + * doc/misc/auth.texi: Minor copy edits. + +2024-09-12 Po Lu <luangruo@yahoo.com> + + Fix bug#72254 + + * src/pgtkselect.c (Fpgtk_get_selection_internal): If requesting + TARGETS with just one result, return it as a vector. + (bug#72254) + +2024-09-11 Andrea Corallo <acorallo@gnu.org> + + Bump Emacs version to 30.0.91 + + * nt/README.W32: Update Emacs version. + * msdos/sed2v2.inp: Likewise. + * exec/configure.ac: Likewise. + * configure.ac: Likewise. + * README: Likewise. + 2024-09-11 Yuan Fu <casouri@gmail.com> Fix heex-ts-mode indentation following previews elixir-mode change @@ -101,7 +1032,7 @@ * src/treesit.c (treesit_sync_visible_region): Minimally fix ranges so it doesn't exceed parser's visible range. - (treesit_call_after_change_functions): Update calling sigature to + (treesit_call_after_change_functions): Update calling signature to treesit_make_ranges. (treesit_ensure_parsed, make_treesit_parser): Use the new field within_reparse. @@ -200709,7 +201640,7 @@ This file records repository revisions from commit f2ae39829812098d8269eafbc0fcb98959ee5bb7 (exclusive) to -commit ee3e3a6311196129104881d6e9097bb54d8843af (inclusive). +commit 8e37b537160c1560048ac53529ef09de7561963c (inclusive). See ChangeLog.3 for earlier changes. ;; Local Variables: diff --git a/admin/admin.el b/admin/admin.el index b3f63eef5bb..4a152cdc26b 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -1169,12 +1169,12 @@ changes (in a non-trivial way). This function does not check for that." (declare-function mail-position-on-field "sendmail" (field &optional soft)) (declare-function mail-text "sendmail" ()) - (when-let ((id (alist-get version debbugs-gnu-emacs-blocking-reports - nil nil #'string-equal)) - (status-id (debbugs-get-status id)) - (blockedby-ids (debbugs-get-attribute (car status-id) 'blockedby)) - (blockedby-status - (apply #'debbugs-get-status (sort blockedby-ids #'<)))) + (when-let* ((id (alist-get version debbugs-gnu-emacs-blocking-reports + nil nil #'string-equal)) + (status-id (debbugs-get-status id)) + (blockedby-ids (debbugs-get-attribute (car status-id) 'blockedby)) + (blockedby-status + (apply #'debbugs-get-status (sort blockedby-ids #'<)))) (reporter-submit-bug-report "<emacs-devel@gnu.org>" ; to-address diff --git a/admin/codespell/codespell.exclude b/admin/codespell/codespell.exclude index 1dc4fb8f014..f4c67ae83e8 100644 --- a/admin/codespell/codespell.exclude +++ b/admin/codespell/codespell.exclude @@ -1701,8 +1701,6 @@ Timo Savola, Jorgen Sch@"afer, Holger Schauer, William Schelter, Ralph 5b34fc07085 * lisp/treesit.el (treesit-node-at): Update docstring (bu... 5cf1de683b2 Fix python-fill-paragraph problems on filling strings (bu... 7678b7e46f2 Eglot: check server capability before sending didSave (bu... - 7678b7e46f2 Eglot: check server capability before sending didSave (bu... - 9ac12592781 Fix display of menu-bar bindings of commands in *Help* bu... 9ac12592781 Fix display of menu-bar bindings of commands in *Help* bu... 9e105d483fa Fix c-ts-mode indentation for statement after preproc (bu... When running emacs in a terminal (or at least, in iTerm), keys are not @@ -1736,7 +1734,6 @@ Timo Savola, Jorgen Sch@"afer, Holger Schauer, William Schelter, Ralph ed3bab3cc72 Revert 'forward-sentence-default-function' to return poin... b3e930d328e Revert inadvertent change to lisp/icomplete.el in previou... 973c1d24c6a ruby-ts-mode: Also don't reindent 'identifier' when insid... - 973c1d24c6a ruby-ts-mode: Also don't reindent 'identifier' when insid... e444115d026 Improve keymap-global-set and keymap-local-set interactiv... 8e9783b4ce4 Rebind in read-regexp-map ‘M-c’ to ‘M-s c’ compatible wit... f12f72b0e09 ; * lisp/simple.el (primitive-undo): Clarify error messag... @@ -1744,3 +1741,5 @@ Timo Savola, Jorgen Sch@"afer, Holger Schauer, William Schelter, Ralph b211a63455c Make tab-bar-tab-group-format-function also handle curren... a3c310c11a Create new "use-package" themse and use it for :custom wit... 2a85d81c47 Add support for gathering statistics on use-package declar... + (let* ((nam (buffer-substring (match-beginning 2) (match-end 2))) + (setq nmlst (cons nam nmlst) diff --git a/configure.ac b/configure.ac index 8a5ba7db3d1..1c7545ef984 100644 --- a/configure.ac +++ b/configure.ac @@ -3172,7 +3172,7 @@ if test "${HAVE_W32}" = "yes"; then AC_CHECK_TOOL([WINDRES], [windres], [AC_MSG_ERROR([No resource compiler found.])]) W32_OBJ="w32fns.o w32menu.o w32reg.o w32font.o w32term.o" - W32_OBJ="$W32_OBJ w32xfns.o w32select.o w32uniscribe.o w32cygwinx.o" + W32_OBJ="$W32_OBJ w32xfns.o w32select.o w32uniscribe.o w32dwrite.o w32cygwinx.o" EMACSRES="emacs.res" case "$canonical" in x86_64-*-*) EMACS_MANIFEST="emacs-x64.manifest" ;; @@ -7117,6 +7117,9 @@ AC_CACHE_CHECK([for usable FIONREAD], [emacs_cv_usable_FIONREAD], #ifdef USG5_4 # include <sys/filio.h> #endif + #ifdef HAVE_UNISTD_H + # include <unistd.h> /* defines ioctl() on Solaris */ + #endif ]], [[int foo = ioctl (0, FIONREAD, &foo);]])], [emacs_cv_usable_FIONREAD=yes], diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 5932af301f9..634788392d2 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -1432,7 +1432,7 @@ If you need to contact the Free Software Foundation, see @display Free Software Foundation -31 Milk Street # 960789 +31 Milk Street, # 960789 Boston, MA 02196 USA @end display diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 86b85f16d69..e732911b98f 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -411,7 +411,7 @@ that was visited in the buffer. * Interlocking:: How Emacs protects against simultaneous editing of one file by two users. * Shadowing: File Shadowing. Copying files to ``shadows'' automatically. -* Time Stamps:: Emacs can update time stamps on saved files. +* Time Stamps:: Emacs can update time stamps when a file is saved. @end menu @node Save Commands @@ -997,33 +997,90 @@ File Shadowing is not available on MS Windows. @subsection Updating Time Stamps Automatically @cindex time stamps @cindex modification dates -@cindex locale, date format +@cindex last modified time -You can arrange to put a time stamp in a file, so that it is updated -automatically each time you edit and save the file. The time stamp -must be in the first eight lines of the file, and you should insert it -like this: +You can arrange to have a time stamp in a file be updated +automatically each time you save the file. +(A time stamp may also be called a date stamp or a last modified time.) +Having a time stamp in the text of a file ensures that the time the file +was written will be preserved even if the file is copied or transformed +in a way that loses the file system's modification time. + +There are two steps to setting up automatic time stamping. +First, you need to have a time stamp template +somewhere in the first eight lines of the file. +The template looks like this: @example Time-stamp: <> @end example @noindent -or like this: +or (your choice) like this: @example Time-stamp: " " @end example +@noindent +When time-stamping, Emacs will write the current time, date, and/or +other info between the brackets or quotes. + @findex time-stamp - Then add the function @code{time-stamp} to the hook -@code{before-save-hook} (@pxref{Hooks}). When you save the file, this -function then automatically updates the time stamp with the current -date and time. You can also use the command @kbd{M-x time-stamp} to -update the time stamp manually. By default the time stamp is +Second, add the function @code{time-stamp} +to @code{before-save-hook} (@pxref{Hooks}). +To do this, either customize the option @code{before-save-hook} +(with @kbd{M-x customize-option}, @pxref{Specific Customization}) +or edit your init file adding this line: + +@example +(add-hook 'before-save-hook 'time-stamp) +@end example + +To enable automatic time-stamping for only a specific file, add the +following line to a local variables list +(@pxref{Specifying File Variables}) near the end of the file: + +@example +eval: (add-hook 'before-save-hook 'time-stamp nil t) +@end example + +To update the current buffer's time stamp once +immediately, use the command @kbd{M-x time-stamp}. + +@vindex time-stamp-pattern +To customize the time stamp in a particular file, set the +variable @code{time-stamp-pattern} in that file's local variables list. +You can change where the time stamp starts and ends and how the dynamic +information is to be formatted; see the variable's built-in +documentation for details. +As a simple example, if this line occurs near the top of a file: + +@example +\newcommand@{\yearpublished@}@{@} +@end example + +@noindent +then the following at the end of the file tells @code{time-stamp} how to +identify and update that custom template: + +@example +@group +%% Local variables: +%% time-stamp-pattern: "@{.yearpublished@}@{%Y@}" +%% End: +@end group +@end example + +@vindex time-stamp-format +By default the time stamp is formatted according to your locale setting (@pxref{Environment}) and time zone (@pxref{Time of Day,,, elisp, The Emacs Lisp Reference -Manual}). For customizations, see the Custom group @code{time-stamp}. +Manual}). +See the built-in documentation for the variable @code{time-stamp-format} +for specifics and other variables that affect the formatting. + +For customizations, see the Custom group @code{time-stamp}. @node Reverting @section Reverting a Buffer diff --git a/doc/emacs/mark.texi b/doc/emacs/mark.texi index 0d705769f55..83261d36495 100644 --- a/doc/emacs/mark.texi +++ b/doc/emacs/mark.texi @@ -306,6 +306,7 @@ instead signal an error if the mark is inactive. @cindex Delete Selection mode @cindex mode, Delete Selection @findex delete-selection-mode +@findex delete-selection-local-mode @vindex delete-selection-temporary-region By default, text insertion occurs normally even if the mark is active---for example, typing @kbd{a} inserts the character @samp{a}, @@ -323,7 +324,8 @@ setting @code{delete-selection-temporary-region} to @code{selection}: then temporary regions by @kbd{C-u C-x C-x} won't be replaced, only the ones activated by dragging the mouse or shift-selection. To toggle Delete Selection mode on or off, type @kbd{M-x -delete-selection-mode}. +delete-selection-mode}. To toggle Delete Selection mode on or off +in the current buffer only, type @kbd{M-x delete-selection-local-mode}. @node Mark Ring @section The Mark Ring diff --git a/doc/emacs/mule.texi b/doc/emacs/mule.texi index 8b16c661a7e..84edc0d086a 100644 --- a/doc/emacs/mule.texi +++ b/doc/emacs/mule.texi @@ -1681,6 +1681,7 @@ used. Some examples are: nil 'append) @end example +@vindex use-default-font-for-symbols When modifying the fontset for the @code{symbol} script, the value of @code{use-default-font-for-symbols} will affect whether the fontset is actually used. diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index 948f4128acf..24e043e2c1c 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -84,7 +84,6 @@ mode for the C programming language is @code{c-mode}. @cindex Javascript mode @cindex Awk mode @cindex C# mode -@cindex IDLWAVE mode @cindex JSON mode @cindex SQL mode @cindex TypeScript mode @@ -94,7 +93,7 @@ mode for the C programming language is @code{c-mode}. @cindex TOML mode Emacs has programming language modes for Lisp, Scheme, the Scheme-based DSSSL expression language, Ada, ASM, AWK, C, C++, C#, -Elixir, Fortran, Icon, IDL (CORBA), HEEx, IDLWAVE, Java, Javascript, +Elixir, Fortran, Icon, IDL (CORBA), HEEx, Java, Javascript, Lua, M4, Makefiles, Metafont (@TeX{}'s companion for font creation), Modula2, Object Pascal, Objective-C, Octave, Pascal, Perl, PHP, Pike, PostScript, Prolog, Python, Ruby, Simula, SQL, Tcl, TypeScript, Verilog, @@ -141,10 +140,9 @@ For instance, entering C mode runs the hooks @code{prog-mode-hook} and @code{c-mode-hook}. @xref{Hooks}, for information about hooks. @ifnottex - Separate manuals are available for the modes for Ada (@pxref{Top,, -Ada Mode, ada-mode, Ada Mode}), C/C++/Objective C/Java/Corba -IDL/Pike/AWK (@pxref{Top, , CC Mode, ccmode, CC Mode}), Octave, VHDL, -and IDLWAVE (@pxref{Top,, IDLWAVE, idlwave, IDLWAVE User Manual}). + Separate manuals are available for the modes for Ada (@pxref{Top,, Ada +Mode, ada-mode, Ada Mode}), C/C++/Objective C/Java/Corba IDL/Pike/AWK +(@pxref{Top, , CC Mode, ccmode, CC Mode}), Octave, and VHDL. @end ifnottex @iftex The Emacs distribution contains Info manuals for the major modes for diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi index 65442dd8d19..69a9aa5f31c 100644 --- a/doc/lispref/compile.texi +++ b/doc/lispref/compile.texi @@ -927,6 +927,14 @@ compilation subprocesses in parallel, under the control of Variables}). @end defun +@defun native-compile-directory directory +This function compiles into native code all the @file{*.el} files in the +specified @var{directory} and, recursively, in all of its +subdirectories, if a corresponding @file{.eln} file could not be found +in any of the directories mentioned in the +@code{native-comp-eln-load-path} list (@pxref{Library Search}). +@end defun + @deffn Command emacs-lisp-native-compile This command compiles the file visited by the current buffer into native code, if the file was changed since the last time it was diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 399b7ee562d..80ed2ce899b 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -313,30 +313,41 @@ to make this easier and more readable. The above can be written the following way instead: @example -(when-let ((result1 (do-computation)) - (result2 (do-more result1))) +(when-let* ((result1 (do-computation)) + (result2 (do-more result1))) (do-something result2)) @end example There's a number of variations on this theme, and they're briefly described below. -@defmac if-let spec then-form else-forms... -Evaluate each binding in @var{spec} in turn, like in @code{let*} +@defmac if-let* varlist then-form else-forms... +Evaluate each binding in @var{varlist} in turn, like in @code{let*} (@pxref{Local Variables}), stopping if a binding value is @code{nil}. If all are non-@code{nil}, return the value of @var{then-form}, otherwise the last form in @var{else-forms}. @end defmac -@defmac when-let spec then-forms... -Like @code{if-let}, but without @var{else-forms}. +@defmac when-let* varlist then-forms... +Like @code{if-let*}, but without @var{else-forms}. +@end defmac + +@defmac and-let* varlist then-forms... +Like @code{when-let*}, but in addition, if there are no +@var{then-forms} and all the bindings evaluate to non-@code{nil}, return +the value of the last binding. @end defmac @defmac while-let spec then-forms... -Like @code{when-let}, but repeat until a binding in @var{spec} is +Like @code{when-let*}, but repeat until a binding in @var{spec} is @code{nil}. The return value is always @code{nil}. @end defmac +Some Lisp programmers follow the convention that @code{and} and +@code{and-let*} are for forms evaluated for return value, and +@code{when} and @code{when-let*} are for forms evaluated for side-effect +with returned values ignored. + @node Combining Conditions @section Constructs for Combining Conditions @cindex combining conditions @@ -1441,12 +1452,15 @@ of the clause. As a condition, it counts as true if the first binding's value is non-@code{nil}. @findex match* +@findex pcase* @code{(match* @var{pattern} @var{datum})} means to match @var{datum} against the specified @var{pattern}. The condition counts as true if @var{pattern} matches @var{datum}. The pattern can specify variables to bind to the parts of @var{datum} that they match. +@code{(pcase* @var{pattern} @var{datum})} works in the same way except it +uses the Pcase syntax for @var{pattern}. -Both @code{bind*} and @code{match*} normally bind their bindings over +@code{bind*}, @code{match*}, and @code{pcase*} normally bind their bindings over the execution of the whole containing clause. However, if the clause is written to specify ``non-exit'', the clause's bindings cover the whole rest of the @code{cond*}. @@ -1464,6 +1478,10 @@ next clause (if any). The bindings made in @var{condition} for the @var{body} of the non-exit clause are passed along to the rest of the clauses in this @code{cond*} construct. +Note: @code{pcase*} does not support @code{:non-exit}, and when used in +a non-exit clause, it follows the semantics of @code{pcase-let}, see +@ref{Destructuring with pcase Patterns}. + @subheading Matching clauses A matching clause looks like @code{(match* @var{pattern} @var{datum})}. @@ -1471,7 +1489,7 @@ It evaluates the expression @var{datum} and matches the pattern @var{pattern} (which is not evaluated) against it. @var{pattern} allows these kinds of patterns, and those that are lists -often include other patters within them: +often include other patterns within them: @table @code @item _ diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index d5de08a5c6e..7ada57d3d9c 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -1825,8 +1825,8 @@ overlay properties and text properties for a given character. of them: @table @code -@item priority @kindex priority @r{(overlay property)} +@item priority This property's value determines the priority of the overlay. If you want to specify a priority value, use either @code{nil} (or zero), or a positive integer, or a cons of two values. Any other value triggers @@ -1865,19 +1865,19 @@ Currently, all overlays take priority over text properties. If you need to put overlays in priority order, use the @var{sorted} argument of @code{overlays-at}. @xref{Finding Overlays}. -@item window @kindex window @r{(overlay property)} +@item window If the @code{window} property is non-@code{nil}, then the overlay applies only on that window. -@item category @kindex category @r{(overlay property)} +@item category If an overlay has a @code{category} property, we call it the @dfn{category} of the overlay. It should be a symbol. The properties of the symbol serve as defaults for the properties of the overlay. -@item face @kindex face @r{(overlay property)} +@item face This property controls the appearance of the text (@pxref{Faces}). The value of the property can be the following: @@ -1905,37 +1905,37 @@ form is supported for backward compatibility only, and should be avoided. @end itemize -@item mouse-face @kindex mouse-face @r{(overlay property)} +@item mouse-face This property is used instead of @code{face} when the mouse is within the range of the overlay. However, Emacs ignores all face attributes from this property that alter the text size (e.g., @code{:height}, @code{:weight}, and @code{:slant}); those attributes are always the same as in the unhighlighted text. -@item display @kindex display @r{(overlay property)} +@item display This property activates various features that change the way text is displayed. For example, it can make text appear taller or shorter, higher or lower, wider or narrower, or replaced with an image. @xref{Display Property}. -@item help-echo @kindex help-echo @r{(overlay property)} +@item help-echo If an overlay has a @code{help-echo} property, then when you move the mouse onto the text in the overlay, Emacs displays a help string in the echo area, or as a tooltip. For details see @ref{Text help-echo}. -@item field @kindex field @r{(overlay property)} +@item field @c Copied from Special Properties. Consecutive characters with the same @code{field} property constitute a @emph{field}. Some motion functions including @code{forward-word} and @code{beginning-of-line} stop moving at a field boundary. @xref{Fields}. -@item modification-hooks @kindex modification-hooks @r{(overlay property)} +@item modification-hooks This property's value is a list of functions to be called if any character within the overlay is changed or if text is inserted strictly within the overlay. @@ -1966,26 +1966,26 @@ prepare for that. @xref{Change Hooks}. Text properties also support the @code{modification-hooks} property, but the details are somewhat different (@pxref{Special Properties}). -@item insert-in-front-hooks @kindex insert-in-front-hooks @r{(overlay property)} +@item insert-in-front-hooks This property's value is a list of functions to be called before and after inserting text right at the beginning of the overlay. The calling conventions are the same as for the @code{modification-hooks} functions. -@item insert-behind-hooks @kindex insert-behind-hooks @r{(overlay property)} +@item insert-behind-hooks This property's value is a list of functions to be called before and after inserting text right at the end of the overlay. The calling conventions are the same as for the @code{modification-hooks} functions. -@item invisible @kindex invisible @r{(overlay property)} +@item invisible The @code{invisible} property can make the text in the overlay invisible, which means that it does not appear on the screen. @xref{Invisible Text}, for details. -@item intangible @kindex intangible @r{(overlay property)} +@item intangible The @code{intangible} property on an overlay works just like the @code{intangible} text property. It is obsolete. @xref{Special Properties}, for details. @@ -2000,15 +2000,15 @@ Text}. This property tells incremental search how to make an invisible overlay visible, temporarily, during the search. @xref{Invisible Text}. -@item before-string @kindex before-string @r{(overlay property)} +@item before-string This property's value is a string to add to the display at the beginning of the overlay. The string does not appear in the buffer in any sense---only on the screen. Note that if the text at the beginning of the overlay is made invisible, the string will not be displayed. -@item after-string @kindex after-string @r{(overlay property)} +@item after-string This property's value is a string to add to the display at the end of the overlay. The string does not appear in the buffer in any sense---only on the screen. Note that if the text at the end of the @@ -2022,8 +2022,8 @@ non-continuation line at display-time. @xref{Truncation}. This property specifies a display spec to prepend to each continuation line at display-time. @xref{Truncation}. -@item evaporate @kindex evaporate @r{(overlay property)} +@item evaporate If this property is non-@code{nil}, the overlay is deleted automatically if it becomes empty (i.e., if its length becomes zero). If you give an empty overlay (@pxref{Managing Overlays, empty overlay}) a @@ -2032,9 +2032,18 @@ Note that, unless an overlay has this property, it will not be deleted when the text between its starting and ending positions is deleted from the buffer. -@item keymap +@kindex display-line-numbers-disable @r{(overlay property)} +@item display-line-numbers-disable +This property prevents display of line numbers (@pxref{Display Custom, +display-line-numbers,, emacs, The GNU Emacs Manual}) for the text which +is within an overlay having this property. One situation where using an +overlay with this property is useful is an empty overlay at +end-of-buffer, since otherwise there's no way of preventing the display +of the line number there. + @cindex keymap of character (and overlays) @kindex keymap @r{(overlay property)} +@item keymap If this property is non-@code{nil}, it specifies a keymap for a portion of the text. This keymap takes precedence over most other keymaps (@pxref{Active Keymaps}), and it is used when point is within @@ -2042,8 +2051,8 @@ the overlay, where the front- and rear-advance properties define whether the boundaries are considered as being @emph{within} or not. -@item local-map @kindex local-map @r{(overlay property)} +@item local-map The @code{local-map} property is similar to @code{keymap} but replaces the buffer's local map rather than augmenting existing keymaps. This also means it has lower precedence than minor mode keymaps. @@ -4027,11 +4036,13 @@ in the range @var{from} and @var{to} (inclusive). @var{characters} may be a charset symbol (@pxref{Character Sets}). In that case, use @var{font-spec} for all the characters in the charset. +@vindex use-default-font-for-symbols @var{characters} may be a script symbol (@pxref{Character Properties, char-script-table}). In that case, use @var{font-spec} for all the characters belonging to the script. See also @code{use-default-font-for-symbols}, which affects font selection -when @var{fontset} is @code{symbol}. +when @var{characters} specify or belong to the @code{symbol} script +(which includes symbol and punctuation characters). @var{characters} may be @code{nil}, which means to use @var{font-spec} for any character in @var{fontset} for which no font-spec is @@ -6022,8 +6033,9 @@ is platform dependent, but should be equivalent to bilinear filtering. Disabling smoothing will use the nearest neighbor algorithm. +@vindex image-transform-smoothing If this property is not specified, @code{create-image} will use the -@code{image-transform-smoothing} user option to say whether scaling +@code{image-transform-smoothing} user option to say whether smoothing should be done or not. This option can be @code{nil} (no smoothing), @code{t} (use smoothing) or a predicate function that's called with the image object as the only parameter, and should return either @@ -7024,12 +7036,13 @@ Here is an example of using @code{image-load-path-for-library}: @end example @end defun -@vindex image-scaling-factor +@vindex image-scaling-factor, and automatic image scaling Images are automatically scaled when created based on the @code{image-scaling-factor} variable. The value is either a floating point number (where numbers higher than 1 means to increase the size and lower means to shrink the size), or the symbol @code{auto}, which -will compute a scaling factor based on the font pixel size. +will compute a scaling factor based on the font pixel size. @xref{Image +Descriptors}. @node Showing Images @subsection Showing Images diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index edeba3288fc..bf4d5c05f3a 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4757,15 +4757,16 @@ to encoding or decoding by any coding system. @node Yanking Media @section Yanking Media - - Data saved within window system selections is not restricted to -plain text. It is possible for selection data to encompass images or -other binary data of the like, as well as rich text content instanced -by HTML, and also PostScript. Since the selection data types incident -to this data are at variance with those for plain text, the insertion -of such data is facilitated by a set of functions dubbed -@dfn{yank-media handlers}, which are registered by each major mode -undertaking its insertion and called where warranted upon the +@cindex yank media from window-system selections + + Data saved within window system selections and the MS-Windows +clipboard is not restricted to plain text. It is possible for selection +data to encompass images or other binary data of the like, as well as +rich text content instanced by HTML, and also PostScript. Since the +selection data types incident to this data are at variance with those +for plain text, the insertion of such data is facilitated by a set of +functions dubbed @dfn{yank-media handlers}, which are registered by each +major mode undertaking its insertion and called where warranted upon the execution of the @code{yank-media} command. @defun yank-media-handler types handler diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index ef3e665f9f2..bf80a21ee9f 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -1510,10 +1510,7 @@ indirect-function}. @kindex void-function This returns the object in the function cell of @var{symbol}. It does not check that the returned object is a legitimate function. - -If the function cell is void, the return value is @code{nil}. To -distinguish between a function cell that is void and one set to -@code{nil}, use @code{fboundp} (see below). +If the function is void, the return value is @code{nil}. @example @group @@ -1533,29 +1530,29 @@ distinguish between a function cell that is void and one set to @end defun @cindex void function cell - If you have never given a symbol any function definition, we say -that that symbol's function cell is @dfn{void}. In other words, the -function cell does not have any Lisp object in it. If you try to call + If you have never given a symbol any function definition, its function +cell contains the default value @code{nil} and we say +that that function is @dfn{void}. If you try to call the symbol as a function, Emacs signals a @code{void-function} error. - Note that void is not the same as @code{nil} or the symbol -@code{void}. The symbols @code{nil} and @code{void} are Lisp objects, -and can be stored into a function cell just as any other object can be -(and @code{void} can be a valid function if you define it with -@code{defun}). A void function cell contains no object whatsoever. + Unlike with void variables (@pxref{Void Variables}), a symbol's +function cell that contains @code{nil} is indistinguishable from the +function's being void. Note that void is not the same as the symbol +@code{void}: @code{void} can be a valid function if you define it with +@code{defun}. You can test the voidness of a symbol's function definition with @code{fboundp}. After you have given a symbol a function definition, you can make it void once more using @code{fmakunbound}. @defun fboundp symbol -This function returns @code{t} if the symbol has an object in its -function cell, @code{nil} otherwise. It does not check that the object -is a legitimate function. +This function returns @code{t} if the symbol has a non-@code{nil} object +in its function cell, @code{nil} otherwise. It does not check that the +object is a legitimate function. @end defun @defun fmakunbound symbol -This function makes @var{symbol}'s function cell void, so that a +This function makes @var{symbol}'s function cell @code{nil}, so that a subsequent attempt to access this cell will cause a @code{void-function} error. It returns @var{symbol}. (See also @code{makunbound}, in @ref{Void Variables}.) diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi index 145d55690c3..87503a45075 100644 --- a/doc/lispref/nonascii.texi +++ b/doc/lispref/nonascii.texi @@ -631,26 +631,31 @@ is @code{nil}, which means the character itself. @item special-uppercase Corresponds to Unicode language- and context-independent special upper-casing rules. The value of this property is a string (which may be empty). For -example mapping for U+00DF @sc{latin small letter sharp s} is -@code{"SS"}. For characters with no special mapping, the value is @code{nil} -which means @code{uppercase} property needs to be consulted instead. +example for U+00DF @sc{latin small letter sharp s} the value is +@code{"SS"}. This mapping overrides the @code{uppercase} property, and +thus the current case table. For characters with no special mapping, +the value is @code{nil}, which means the @code{uppercase} property needs to +be consulted instead. @item special-lowercase Corresponds to Unicode language- and context-independent special lower-casing rules. The value of this property is a string (which may -be empty). For example mapping for U+0130 @sc{latin capital letter i -with dot above} the value is @code{"i\u0307"} (i.e. 2-character string +be empty). For example for U+0130 @sc{latin capital letter i +with dot above} the value is @code{"i\u0307"} (i.e. a 2-character string consisting of @sc{latin small letter i} followed by U+0307 -@sc{combining dot above}). For characters with no special mapping, -the value is @code{nil} which means @code{lowercase} property needs to -be consulted instead. +@sc{combining dot above}). This mapping overrides the @code{lowercase} +property, and thus the current case table. For characters with no +special mapping, the value is @code{nil}, which means the @code{lowercase} +property needs to be consulted instead. @item special-titlecase Corresponds to Unicode unconditional special title-casing rules. The value of -this property is a string (which may be empty). For example mapping for -U+FB01 @sc{latin small ligature fi} the value is @code{"Fi"}. For -characters with no special mapping, the value is @code{nil} which means -@code{titlecase} property needs to be consulted instead. +this property is a string (which may be empty). For example for +U+FB01 @sc{latin small ligature fi} the value is @code{"Fi"}. This +mapping overrides the @code{titlecase} property, and thus the current +case table. For characters with no special mapping, the value is +@code{nil}, which means the @code{titlecase} property needs to be consulted +instead. @end table @defun get-char-code-property char propname diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 53468e0d252..2c19275f946 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2686,10 +2686,12 @@ If non-@code{nil}, do opportunistic @acronym{STARTTLS} upgrades even if Emacs doesn't have built-in @acronym{TLS} support. @item :warn-unless-encrypted @var{boolean} -If non-@code{nil}, and @code{:return-value} is also non-@code{nil}, -Emacs will warn if the connection isn't encrypted. This is useful for -protocols like @acronym{IMAP} and the like, where most users would -expect the network traffic to be encrypted. +If non-@code{nil}, warn the user if the final connection type is not +encrypted. This is useful for protocols like @acronym{IMAP} and the +like, where most users would expect the network traffic to be encrypted. +This may be due to @acronym{STARTTLS} upgrade failure, specifying +@code{:return-list} non-@code{nil} allows you to capture any error +encountered. @vindex network-stream-use-client-certificates @item :client-certificate @var{list-or-t} @@ -2715,6 +2717,9 @@ If non-@code{nil}, the greeting string returned by the host. If non-@code{nil}, the host's capability string. @item :type @var{symbol} The connection type: @samp{plain} or @samp{tls}. +@item :error @var{symbol} +A string describing any error encountered when perfoming +@acronym{STARTTLS} upgrade. @end table @item :shell-command @var{string-or-nil} diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 71d85acb37c..efeddf1a20c 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -1591,9 +1591,12 @@ using @code{string} function, before being passed to one of the casing functions. Of course, no assumptions on the length of the result may be made. - Mapping for such special cases are taken from -@code{special-uppercase}, @code{special-lowercase} and -@code{special-titlecase} @xref{Character Properties}. + Other characters can also have special case-conversion rules. They +all have non-@code{nil} character properties @code{special-uppercase}, +@code{special-lowercase}, or @code{special-titlecase} (@pxref{Character +Properties}) defined by the Unicode Standard. These properties define +special case-conversion rules which override the current case table +(@pxref{Case Tables}). @xref{Text Comparison}, for functions that compare strings; some of them ignore case differences, or can optionally ignore case differences. @@ -1634,14 +1637,32 @@ correspondence. There may be two different lower case letters with the same upper case equivalent. In these cases, you need to specify the maps for both lower case and upper case. - The extra table @var{canonicalize} maps each character to a canonical + Some characters have special case-conversion rules defined for them, +which by default override the current case table. These characters have +non-@code{nil} character properties @code{special-uppercase}, +@code{special-lowercase}, or @code{special-titlecase} (@pxref{Character +Properties}) defined by the Unicode Standard. An example is U+00DF +LATIN SMALL LETTER SHARP S, @ss{}, which by default up-cases to the +string @code{"SS"}, not to U+1E9E LATIN CAPITAL LETTER SHARP S@. To +force these characters to follow the case-table conversions, set the +corresponding Unicode property to @code{nil}: + +@example + (upcase "@ss{}") + => "SS" + (put-char-code-property ?@ss{} 'special-uppercase nil) + (upcase "@ss{}") + => "ẞ" +@end example + + The extra slot @var{canonicalize} of a case table maps each character to a canonical equivalent; any two characters that are related by case-conversion have the same canonical equivalent character. For example, since @samp{a} and @samp{A} are related by case-conversion, they should have the same canonical equivalent character (which should be either @samp{a} for both of them, or @samp{A} for both of them). - The extra table @var{equivalences} is a map that cyclically permutes + The extra slot @var{equivalences} is a map that cyclically permutes each equivalence class (of characters with the same canonical equivalent). (For ordinary @acronym{ASCII}, this would map @samp{a} into @samp{A} and @samp{A} into @samp{a}, and likewise for each set of diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi index c76bf3d3820..c3dc08df2df 100644 --- a/doc/lispref/symbols.texi +++ b/doc/lispref/symbols.texi @@ -100,11 +100,11 @@ the contents of a symbol's function cell, use the function property list. To get a symbol's property list, use the function @code{symbol-plist}. @xref{Symbol Properties}. - The function cell or the value cell may be @dfn{void}, which means -that the cell does not reference any object. (This is not the same -thing as holding the symbol @code{void}, nor the same as holding the -symbol @code{nil}.) Examining a function or value cell that is void -results in an error, such as @samp{Symbol's value as variable is void}. + The value cell may be @dfn{void}, which means that the cell does not +reference any object. (This is not the same thing as holding the symbol +@code{void}, nor the same as holding the symbol @code{nil}.) Examining +a value cell that is void results in an error, such as @samp{Symbol's +value as variable is void}. Because each symbol has separate value and function cells, variables names and function names do not conflict. For example, the symbol diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index df56433fd18..edef9f6333f 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3569,8 +3569,8 @@ the context. The @code{add-face-text-property} function provides a convenient way to set this text property. @xref{Changing Properties}. -@item font-lock-face @kindex font-lock-face @r{(text property)} +@item font-lock-face This property specifies a value for the @code{face} property that Font Lock mode should apply to the underlying text. It is one of the fontification methods used by Font Lock mode, and is useful for @@ -3578,8 +3578,8 @@ special modes that implement their own highlighting. @xref{Precalculated Fontification}. When Font Lock mode is disabled, @code{font-lock-face} has no effect. -@item mouse-face @kindex mouse-face @r{(text property)} +@item mouse-face This property is used instead of @code{face} when the mouse pointer hovers over the text which has this property. When this happens, the entire stretch of text that has the same @code{mouse-face} property @@ -3590,10 +3590,10 @@ that alter the text size (e.g., @code{:height}, @code{:weight}, and @code{:slant}). Those attributes are always the same as for the unhighlighted text. -@item cursor-face @kindex cursor-face @r{(text property)} @findex cursor-face-highlight-mode @vindex cursor-face-highlight-nonselected-window +@item cursor-face This property is similar to @code{mouse-face}, but it is used when point (not the mouse) is inside text that has this property. The highlighting happens only if the mode @@ -3604,8 +3604,8 @@ similarly to what @code{highlight-nonselected-windows} does for the region (@pxref{Mark,, The Mark and the Region, emacs, The GNU Emacs Manual}). -@item fontified @kindex fontified @r{(text property)} +@item fontified This property says whether the text is ready for display. If @code{nil}, Emacs's redisplay routine calls the functions in @code{fontification-functions} (@pxref{Auto Faces}) to prepare this @@ -3618,9 +3618,9 @@ way text is displayed. For example, it can make text appear taller or shorter, higher or lower, wider or narrow, or replaced with an image. @xref{Display Property}. -@item help-echo @kindex help-echo @r{(text property)} @cindex tooltip for help strings +@item help-echo @anchor{Text help-echo} If text has a string as its @code{help-echo} property, then when you move the mouse onto that text, Emacs displays that string in the echo @@ -3655,17 +3655,17 @@ You can alter the way help text is displayed by setting the variable This feature is used in the mode line and for other active text. -@item help-echo-inhibit-substitution @cindex help-echo text, avoid command-key substitution @kindex help-echo-inhibit-substitution @r{(text property)} +@item help-echo-inhibit-substitution If the first character of a @code{help-echo} string has a non-@code{nil} @code{help-echo-inhibit-substitution} property, then it is displayed as-is by @code{show-help-function}, without being passed through @code{substitute-command-keys}. +@cindex help-echo text on fringes @item left-fringe-help @itemx right-fringe-help -@cindex help-echo text on fringes If any visible text of a screen line has the @code{left-fringe-help} or @code{right-fringe-help} text property whose value is a string, then that string will be displayed when the mouse pointer hovers over the @@ -3673,9 +3673,9 @@ corresponding line's fringe through @code{show-help-function} (@pxref{Help display}). This is useful when used together with fringe cursors and bitmaps (@pxref{Fringes}). -@item keymap @cindex keymap of character @kindex keymap @r{(text property)} +@item keymap The @code{keymap} property specifies an additional keymap for commands. When this keymap applies, it is used for key lookup before the minor mode keymaps and before the buffer's local map. @@ -3688,8 +3688,8 @@ character after point applies if it is non-@code{nil} and front-sticky. (For mouse clicks, the position of the click is used instead of the position of point.) -@item local-map @kindex local-map @r{(text property)} +@item local-map This property works like @code{keymap} except that it specifies a keymap to use @emph{instead of} the buffer's local map. For most purposes (perhaps all purposes), it is better to use the @code{keymap} @@ -3699,9 +3699,9 @@ property. The @code{syntax-table} property overrides what the syntax table says about this particular character. @xref{Syntax Properties}. -@item read-only @cindex read-only character @kindex read-only @r{(text property)} +@item read-only If a character has the property @code{read-only}, then modifying that character is not allowed. Any command that would do so gets an error, @code{text-read-only}. If the property value is a string, that string @@ -3717,23 +3717,23 @@ possible to remove a @code{read-only} property unless you know the special trick: bind @code{inhibit-read-only} to a non-@code{nil} value and then remove the property. @xref{Read Only Buffers}. -@item inhibit-read-only @kindex inhibit-read-only @r{(text property)} +@item inhibit-read-only Characters that have the property @code{inhibit-read-only} can be edited even in read-only buffers. @xref{Read Only Buffers}. -@item invisible @kindex invisible @r{(text property)} +@item invisible A non-@code{nil} @code{invisible} property can make a character invisible on the screen. @xref{Invisible Text}, for details. -@kindex inhibit-isearch @r{(text property)} @item inhibit-isearch +@kindex inhibit-isearch @r{(text property)} A non-@code{nil} @code{inhibit-isearch} property will make isearch skip the text. -@item intangible @kindex intangible @r{(text property)} +@item intangible If a group of consecutive characters have equal and non-@code{nil} @code{intangible} properties, then you cannot place point between them. If you try to move point forward into the group, point actually moves to @@ -3754,10 +3754,10 @@ the command loop will move point outside of the invisible text at the end of each command anyway. @xref{Adjusting Point}. For these reasons, this property is obsolete; use the @code{cursor-intangible} property instead. -@item cursor-intangible @kindex cursor-intangible @r{(text property)} @findex cursor-intangible-mode @cindex rear-nonsticky, and cursor-intangible property +@item cursor-intangible When the minor mode @code{cursor-intangible-mode} is turned on, point is moved away from any position that has a non-@code{nil} @code{cursor-intangible} property, just before redisplay happens. @@ -3777,15 +3777,15 @@ When the variable @code{cursor-sensor-inhibit} is non-@code{nil}, the @code{cursor-intangible} property and the @code{cursor-sensor-functions} property (described below) are ignored. -@item field @kindex field @r{(text property)} +@item field Consecutive characters with the same @code{field} property constitute a @dfn{field}. Some motion functions including @code{forward-word} and @code{beginning-of-line} stop moving at a field boundary. @xref{Fields}. -@item cursor @kindex cursor @r{(text property)} +@item cursor Normally, the cursor is displayed at the beginning or the end of any overlay and text property strings that ``hide'' (i.e., are displayed instead of) the current buffer position. You can instead tell Emacs @@ -3834,21 +3834,21 @@ Lisp program wants to put the cursor, or where the user would expect the cursor, when point is located on some buffer position that is ``covered'' by the display or overlay string. -@item pointer @kindex pointer @r{(text property)} +@item pointer This specifies a specific pointer shape when the mouse pointer is over this text or image. @xref{Pointer Shape}, for possible pointer shapes. -@item line-spacing @kindex line-spacing @r{(text property)} +@item line-spacing A newline can have a @code{line-spacing} text or overlay property that controls the height of the display line ending with that newline. The property value overrides the default frame line spacing and the buffer local @code{line-spacing} variable. @xref{Line Height}. -@item line-height @kindex line-height @r{(text property)} +@item line-height A newline can have a @code{line-height} text or overlay property that controls the total height of the display line ending in that newline. @xref{Line Height}. @@ -3892,10 +3892,10 @@ A line-prefix may also be specified for an entire buffer using the @code{line-prefix} text-property takes precedence over the value of the @code{line-prefix} variable). @xref{Truncation}. -@item modification-hooks @cindex change hooks for a character @cindex hooks for changing a character @kindex modification-hooks @r{(text property)} +@item modification-hooks If a character has the property @code{modification-hooks}, then its value should be a list of functions; modifying that character calls all of those functions before the actual modification. Each function @@ -3918,10 +3918,10 @@ recursive calls. @xref{Change Hooks}. Overlays also support the @code{modification-hooks} property, but the details are somewhat different (@pxref{Overlay Properties}). -@item insert-in-front-hooks -@itemx insert-behind-hooks @kindex insert-in-front-hooks @r{(text property)} @kindex insert-behind-hooks @r{(text property)} +@item insert-in-front-hooks +@itemx insert-behind-hooks The operation of inserting text in a buffer also calls the functions listed in the @code{insert-in-front-hooks} property of the following character and in the @code{insert-behind-hooks} property of the @@ -3939,11 +3939,11 @@ prepare for that. See also @ref{Change Hooks}, for other hooks that are called when you change text in a buffer. -@item point-entered -@itemx point-left @cindex hooks for motion of point @kindex point-entered @r{(text property)} @kindex point-left @r{(text property)} +@item point-entered +@itemx point-left The special properties @code{point-entered} and @code{point-left} record hook functions that report motion of point. Each time point moves, Emacs compares these two property values: @@ -3979,9 +3979,9 @@ running the @code{point-left} and @code{point-entered} hooks, see These properties are obsolete; please use @code{cursor-sensor-functions} instead. -@item cursor-sensor-functions @kindex cursor-sensor-functions @r{(text property)} @findex cursor-sensor-mode +@item cursor-sensor-functions This special property records a list of functions that react to cursor motion. Each function in the list is called, just before redisplay, with 3 arguments: the affected window, the previous known position of @@ -3993,15 +3993,15 @@ mode @code{cursor-sensor-mode} is turned on. When the variable @code{cursor-sensor-inhibit} is non-@code{nil}, the @code{cursor-sensor-functions} property is ignored. -@item composition @kindex composition @r{(text property)} +@item composition This text property is used to display a sequence of characters as a single glyph composed from components. But the value of the property itself is completely internal to Emacs and should not be manipulated directly by, for instance, @code{put-text-property}. -@item minibuffer-message @kindex minibuffer-message @r{(text property)} +@item minibuffer-message This text property tells where to display temporary messages in an active minibuffer. Specifically, the first character of the minibuffer text which has this property will have the temporary @@ -4010,6 +4010,12 @@ messages at the end of the minibuffer text. This text property is used by the function that is the default value of @code{set-message-function} (@pxref{Displaying Messages}). +@kindex display-line-numbers-disable @r{(text property)} +@item display-line-numbers-disable +This text property prevents display of line numbers (@pxref{Display +Custom, display-line-numbers,, emacs, The GNU Emacs Manual}) for the +text which has this property. + @end table @defvar inhibit-point-motion-hooks diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index c18438583e4..f6362b4f075 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -4065,6 +4065,7 @@ information is available from * Compose Character:: * Binding combinations of modifiers and function keys:: * Meta key does not work in xterm:: +* Some Ctrl-modified keys do not work on xterm:: @end menu @node Binding keys to commands @@ -4536,6 +4537,25 @@ You might have to replace @samp{Meta} with @samp{Alt}. @end itemize +@node Some Ctrl-modified keys do not work on xterm +@section Why don't some keys like @kbd{C-.} work on xterm? + +If your @code{xterm} version is 216 or newer, you should have keys like +@kbd{C-.} and @kbd{C-,} if you add the following resource specification +to your @file{~/.Xdefaults}: + +@example + XTerm.VT100.modifyOtherKeys: 1 +@end example + +@noindent +If you want to use @code{uxterm}, also add the following: + +@example + UXTerm.VT100.modifyOtherKeys: 1 +@end example + + @c ------------------------------------------------------------ @node Alternate character sets @chapter Alternate character sets diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index a3802c8c6bf..0f6b6b8c5be 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -1915,8 +1915,8 @@ interactve contexts covered by the option @lisp (defun my-erc-interactive-display-buffer (buffer action) "Pop to BUFFER when running \\[erc-tls], clicking a link, etc." - (when-let ((alist (cdr action)) - (found (alist-get 'erc-interactive-display alist))) + (when-let* ((alist (cdr action)) + (found (alist-get 'erc-interactive-display alist))) (if (eq found 'erc-tls) (pop-to-buffer-same-window buffer action) (pop-to-buffer buffer action)))) diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi index 9a2714b14fb..fda1632f1ac 100644 --- a/doc/misc/eshell.texi +++ b/doc/misc/eshell.texi @@ -432,16 +432,6 @@ This command writes a list of all files matching the glob pattern @node Arguments @section Arguments -Ordinarily, Eshell parses arguments in command form as either strings -or numbers, depending on what the parser thinks they look like. To -specify an argument of some other data type, you can use a Lisp form -(@pxref{Invocation}): - -@example -~ $ echo (list 1 2 3) -(1 2 3) -@end example - When calling external commands (and many built-in Eshell commands, too) Eshell will flatten the arguments the command receives, so passing a list as an argument will ``spread'' the elements into @@ -454,13 +444,15 @@ multiple arguments: 3 @end example -@subsection Quoting and escaping +@subsection Quoting and Escaping As with other shells, you can escape special characters and spaces by prefixing the character with a backslash (@samp{\}), or by surrounding the string with apostrophes (@samp{''}) or double quotes (@samp{""}). This is needed especially for file names with special characters like pipe (@samp{|}) or square brackets (@samp{[} or @samp{]}), which could -be part of remote file names. +be part of remote file names. In addition, quoting or escaping an +argument will prevent it from being converted to a number when passed to +a Lisp function. When you escape a character with @samp{\} outside of any quotes, the result is the literal character immediately following it. For @@ -495,7 +487,46 @@ When using expansions (@pxref{Expansion}) in an Eshell command, the result may potentially be of any data type. To ensure that the result is always a string, the expansion can be surrounded by double quotes. -@subsection Special argument types +@subsection Type Conversion +When invoking a Lisp function via command form, Eshell automatically +converts string arguments that look like numbers to actual Lisp +numbers in order to make it easier to work with numeric values. You can +prevent this conversion on a case-by-case basis by quoting or escaping +the argument: + +@example +~ $ type-of 1 +integer +~ $ type-of "1" +string +@end example + +When invoking a subcommand in command form, Eshell will split the output +line-by-line into a list. Additionally, if every line looks like a +number, then Eshell will mark them as numeric so that passing them to a +Lisp function will convert them to Lisp numbers: + +@example +~ $ cat numbers.txt +01 +02 +03 +~ $ + $@@@{cat numbers.txt@} +6 +@end example + +If you find this behavior inconvenient for certain functions, you can +tell Eshell not to perform this conversion for that function: + +@example +(put \\='find-file \\='eshell-no-numeric-conversions t) +@end example + +@vindex eshell-convert-numeric-arguments +You can also disable this conversion behavior entirely by setting +@code{eshell-convert-numeric-arguments} to @code{nil}. + +@subsection Special Argument Types In addition to strings and numbers, Eshell supports a number of special argument types. These let you refer to various other Emacs Lisp data types, such as lists or buffers. @@ -1730,11 +1761,15 @@ satisfied. Repeatedly evaluate @var{subcommand} until @var{conditional} is satisfied. -@item for @var{var} in @var{list}@dots{} @var{subcommand} -Iterate over each element of @var{list}, storing the element in -@var{var} and evaluating @var{subcommand}. If @var{list} is not a list, -treat it as a list of one element. If you specify multiple @var{lists}, -this will iterate over each of them in turn. +@item for @var{var} in @var{sequence}@dots{} @var{subcommand} +Iterate over each element of @var{sequence}, storing the element in +@var{var} and evaluating @var{subcommand}. If @var{sequence} is a +range of the form @code{@var{begin}..@var{end}}, iterate over each +integer between @var{begin} and @var{end}, not including @var{end}. If +@var{sequence} is not a sequence, treat it as a list of one element. + +If you specify multiple @var{sequences}, this will iterate over each of +them in turn. @end table @@ -1764,8 +1799,8 @@ behavior depends on the types of each value being concatenated: Concatenate both values together. @item one or both numbers -Concatenate the string representation of each value, converting back to -a number if possible. +Concatenate the string representation of each value. If either value is +numeric, mark the concatenated value as numeric if possible. @item one or both (non-@code{nil}) lists Concatenate ``adjacent'' elements of each value (possibly converting diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index c02da3fbad1..76379d1a168 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -4,9 +4,9 @@ #+language: en #+options: ':t toc:nil author:t email:t num:t #+startup: content -#+macro: stable-version 4.5.0 -#+macro: release-date 2024-08-21 -#+macro: development-version 4.6.0-dev +#+macro: stable-version 4.6.0 +#+macro: release-date 2024-10-27 +#+macro: development-version 4.7.0-dev #+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ #+macro: space @@texinfo:@: @@ #+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ @@ -50,7 +50,7 @@ Current development target is {{{development-version}}}. :custom_id: h:b14c3fcb-13dd-4144-9d92-2c58b3ed16d3 :end: -Copyright (C) 2020-2023 Free Software Foundation, Inc. +Copyright (C) 2020-2024 Free Software Foundation, Inc. #+begin_quote Permission is granted to copy, distribute and/or modify this document @@ -486,7 +486,7 @@ The reason we recommend ~load-theme~ instead of the other option of ~enable-theme~ is that the former does a kind of "reset" on the face specs. It quite literally loads (or reloads) the theme. Whereas the ~enable-theme~ function simply puts an already loaded theme to the top -of the list of enabled items, re-using whatever state was last loaded. +of the list of enabled items, reusing whatever state was last loaded. As such, ~load-theme~ reads all customizations that may happen during any given Emacs session: even after the initial setup of a theme. @@ -707,10 +707,12 @@ Advanced users may also want to configure the exact attributes of the :PROPERTIES: :CUSTOM_ID: h:4fbfed66-5a89-447a-a07d-a03f6819c5bd :END: -#+vindex: modus-themes-to-toggle -Brief: Choose to Modus themes to toggle between +#+findex: modus-themes-toggle +Brief: Specify which two themes to toggle between when using the command +~modus-themes-toggle~. +#+vindex: modus-themes-to-toggle Symbol: ~modus-themes-to-toggle~ (=list= type) Default value: ='(modus-operandi modus-vivendi)= @@ -718,16 +720,38 @@ Default value: ='(modus-operandi modus-vivendi)= Possible values: - ~modus-operandi~ -- ~modus-vivendi~ - ~modus-operandi-tinted~ -- ~modus-vivendi-tinted~ - ~modus-operandi-deuteranopia~ -- ~modus-vivendi-deuteranopia~ - ~modus-operandi-tritanopia~ +- ~modus-vivendi~ +- ~modus-vivendi-tinted~ +- ~modus-vivendi-deuteranopia~ - ~modus-vivendi-tritanopia~ -Specify two themes to toggle between using the command -~modus-themes-toggle~. +** Option for which themes to rotate +:PROPERTIES: +:CUSTOM_ID: h:a10c0202-3683-4fad-9897-433c25e255f6 +:END: + +#+findex: modus-themes-rotate +Brief: Specify which themes to rotate among when using the command +~modus-themes-rotate~. + +#+vindex: modus-themes-to-rotate +Symbol: ~modus-themes-to-rotate~ (=list= type) + +Default value: =modus-themes-items= (which includes all the Modus themes) + +Possible values: + +- ~modus-operandi~ +- ~modus-operandi-tinted~ +- ~modus-operandi-deuteranopia~ +- ~modus-operandi-tritanopia~ +- ~modus-vivendi~ +- ~modus-vivendi-tinted~ +- ~modus-vivendi-deuteranopia~ +- ~modus-vivendi-tritanopia~ ** Option for font mixing :properties: @@ -1517,6 +1541,101 @@ the general idea (extra space for didactic purposes): ,@modus-themes-preset-overrides-intense)) #+end_src +** DIY Add support for ~engrave-faces~ +:PROPERTIES: +:CUSTOM_ID: h:6c3f87a8-3573-43de-89e0-53f567c0ede1 +:END: + +The ~engraved-faces~ package is used as part of an Org export process +to produce decent colors in the output. Its default style though +requires changes to use the colors of the active Modus theme. + +In the code below we show how to map everything that ~engrave-faces~ +defines to the corresponding entry in the palette of the active Modus +theme. We then use a hook to ensure that the value is updated after we +switch to another theme in the collection ([[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][DIY Use a hook at the post-load-theme phase]]). + +#+begin_src emacs-lisp +(defun my-modus-themes-engraved-faces (&rest _) + (modus-themes-with-colors + (setq engrave-faces-themes + `((default . + (;; faces.el --- excluding: bold, italic, bold-italic, underline, and some others + (default :short "default" :slug "D" :foreground ,fg-main :background ,bg-main :family "Monospace") + (variable-pitch :short "var-pitch" :slug "vp" :foreground ,fg-main :family "Sans Serif") + (shadow :short "shadow" :slug "h" :foreground ,fg-dim) + (success :short "success" :slug "sc" :foreground ,green :weight bold) + (warning :short "warning" :slug "w" :foreground ,warning :weight bold) + (error :short "error" :slug "e" :foreground ,err :weight bold) + (link :short "link" :slug "l" :foreground ,fg-link) + (link-visited :short "link" :slug "lv" :foreground ,fg-link-visited) + (highlight :short "link" :slug "hi" :foreground ,info) + ;; font-lock.el + (font-lock-comment-face :short "fl-comment" :slug "c" :foreground ,comment) + (font-lock-comment-delimiter-face :short "fl-comment-delim" :slug "cd" :foreground ,comment) + (font-lock-string-face :short "fl-string" :slug "s" :foreground ,string) + (font-lock-doc-face :short "fl-doc" :slug "d" :foreground ,docstring) + (font-lock-doc-markup-face :short "fl-doc-markup" :slug "m" :foreground ,docmarkup) + (font-lock-keyword-face :short "fl-keyword" :slug "k" :foreground ,keyword) + (font-lock-builtin-face :short "fl-builtin" :slug "b" :foreground ,builtin) + (font-lock-function-name-face :short "fl-function" :slug "f" :foreground ,fnname) + (font-lock-variable-name-face :short "fl-variable" :slug "v" :foreground ,variable) + (font-lock-type-face :short "fl-type" :slug "t" :foreground ,type) + (font-lock-constant-face :short "fl-constant" :slug "o" :foreground ,constant) + (font-lock-warning-face :short "fl-warning" :slug "wr" :foreground ,warning :weight bold) + (font-lock-negation-char-face :short "fl-neg-char" :slug "nc") + (font-lock-preprocessor-face :short "fl-preprocessor" :slug "pp" :foreground ,preprocessor) + (font-lock-regexp-grouping-construct :short "fl-regexp" :slug "rc" :weight bold) + (font-lock-regexp-grouping-backslash :short "fl-regexp-backslash" :slug "rb" :weight bold) + ;; org-faces.el + (org-block :short "org-block" :slug "ob") ; forcing no background is preferable + (org-block-begin-line :short "org-block-begin" :slug "obb") ; forcing no background is preferable + (org-block-end-line :short "org-block-end" :slug "obe") ; forcing no background is preferable + ;; outlines + (outline-1 :short "outline-1" :slug "Oa" :foreground ,fg-heading-1) + (outline-2 :short "outline-2" :slug "Ob" :foreground ,fg-heading-2) + (outline-3 :short "outline-3" :slug "Oc" :foreground ,fg-heading-3) + (outline-4 :short "outline-4" :slug "Od" :foreground ,fg-heading-4) + (outline-5 :short "outline-5" :slug "Oe" :foreground ,fg-heading-5) + (outline-6 :short "outline-6" :slug "Of" :foreground ,fg-heading-6) + (outline-7 :short "outline-7" :slug "Og" :foreground ,fg-heading-7) + (outline-8 :short "outline-8" :slug "Oh" :foreground ,fg-heading-8) + ;; highlight-numbers.el + (highlight-numbers-number :short "hl-number" :slug "hn" :foreground ,number) + ;; highlight-quoted.el + (highlight-quoted-quote :short "hl-qquote" :slug "hq" :foreground ,string) + (highlight-quoted-symbol :short "hl-qsymbol" :slug "hs" :foreground ,constant) + ;; rainbow-delimiters.el + (rainbow-delimiters-depth-1-face :short "rd-1" :slug "rda" :foreground ,rainbow-0) + (rainbow-delimiters-depth-2-face :short "rd-2" :slug "rdb" :foreground ,rainbow-1) + (rainbow-delimiters-depth-3-face :short "rd-3" :slug "rdc" :foreground ,rainbow-2) + (rainbow-delimiters-depth-4-face :short "rd-4" :slug "rdd" :foreground ,rainbow-3) + (rainbow-delimiters-depth-5-face :short "rd-5" :slug "rde" :foreground ,rainbow-4) + (rainbow-delimiters-depth-6-face :short "rd-6" :slug "rdf" :foreground ,rainbow-5) + (rainbow-delimiters-depth-7-face :short "rd-7" :slug "rdg" :foreground ,rainbow-6) + (rainbow-delimiters-depth-8-face :short "rd-8" :slug "rdh" :foreground ,rainbow-7) + (rainbow-delimiters-depth-9-face :short "rd-9" :slug "rdi" :foreground ,rainbow-8) + ;; ansi-color + (ansi-color-yellow :short "ansi-yellow" :slug "any" :foreground ,fg-term-yellow) + (ansi-color-red :short "ansi-red" :slug "anr" :foreground ,fg-term-red) + (ansi-color-black :short "ansi-black" :slug "anb" :foreground ,fg-term-black) + (ansi-color-green :short "ansi-green" :slug "ang" :foreground ,fg-term-green) + (ansi-color-blue :short "ansi-blue" :slug "anB" :foreground ,fg-term-blue) + (ansi-color-cyan :short "ansi-cyan" :slug "anc" :foreground ,fg-term-cyan) + (ansi-color-white :short "ansi-white" :slug "anw" :foreground ,fg-term-white) + (ansi-color-magenta :short "ansi-magenta" :slug "anm" :foreground ,fg-term-magenta) + (ansi-color-bright-yellow :short "ansi-bright-yellow" :slug "ANy" :foreground ,fg-term-yellow-bright) + (ansi-color-bright-red :short "ansi-bright-red" :slug "ANr" :foreground ,fg-term-red-bright) + (ansi-color-bright-black :short "ansi-bright-black" :slug "ANb" :foregroun ,fg-term-black-bright) + (ansi-color-bright-green :short "ansi-bright-green" :slug "ANg" :foreground ,fg-term-green-bright) + (ansi-color-bright-blue :short "ansi-bright-blue" :slug "ANB" :foreground ,fg-term-blue-bright) + (ansi-color-bright-cyan :short "ansi-bright-cyan" :slug "ANc" :foreground ,fg-term-cyan-bright) + (ansi-color-bright-white :short "ansi-bright-white" :slug "ANw" :foregroun ,fg-term-white-bright) + (ansi-color-bright-magenta :short "ansi-bright-magenta" :slug "ANm" :foregroun ,fg-term-magenta-bright))))))) + +(add-hook 'enable-theme-functions #'my-modus-themes-engraved-faces) +#+end_src + ** DIY Stylistic variants using palette overrides :PROPERTIES: :CUSTOM_ID: h:df1199d8-eaba-47db-805d-6b568a577bf3 @@ -2892,7 +3011,7 @@ above: The reason we no longer provide this option is because it depends on a non-~nil~ value for ~x-underline-at-descent-line~. That variable affects ALL underlines, including those of links. The effect is -intrusive and looks awkard in prose. +intrusive and looks awkward in prose. As such, the Modus themes no longer provide that option but instead offer this piece of documentation to make the user fully aware of the @@ -2907,7 +3026,7 @@ Reload the theme for changes to take effect. #+cindex: Remapping faces There are cases where we need to change the buffer-local attributes of a -face. This might be because we have our own minor mode that re-uses a +face. This might be because we have our own minor mode that reuses a face for a particular purpose, such as a line selection tool that activates ~hl-line-mode~, but we wish to keep it distinct from other buffers. This is where ~face-remap-add-relative~ can be applied and may @@ -3837,7 +3956,7 @@ on what we cover at length elsewhere in this manual: (modus-themes-with-colors (custom-set-faces `(solaire-default-face ((,c :inherit default :background ,bg-dim :foreground ,fg-dim))) - `(solaire-line-number-face ((,c :inherit solaire-default-face :foreground ,fg-unfocused))) + `(solaire-line-number-face ((,c :inherit solaire-default-face :foreground ,fg-dim))) `(solaire-hl-line-face ((,c :background ,bg-active))) `(solaire-org-hide-face ((,c :background ,bg-dim :foreground ,bg-dim)))))) @@ -3848,6 +3967,127 @@ on what we cover at length elsewhere in this manual: Reload the theme for changes to take effect. +** DIY Add support for meow-mode +:PROPERTIES: +:CUSTOM_ID: h:caa5a5c4-18fb-4b9f-91f9-883f216fce41 +:END: + +The ~meow~ package provides a modal editing experience. It is meant to +build on top of the key bindings the user is already familiar with. My +problem as an outsider is that I cannot make sense of all the contexts +where its faces are used in, so I cannot make a good choice of which +styles to use. The following is but a basic attempt to get started. + +#+begin_src emacs-lisp +;; This is not complete, because it is difficult for a non-user to +;; make sense of where all the faces are used in. +(defun my-modus-themes-custom-faces (&rest _) + (modus-themes-with-colors + (custom-set-faces + ;; FIXME: What is a "region cursor" and should it differ from the position highlights below? + `(meow-region-cursor-1 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-0))) + `(meow-region-cursor-2 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-1))) + `(meow-region-cursor-3 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-2))) + + `(meow-position-highlight-number-1 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-0))) + `(meow-position-highlight-number-2 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-1))) + `(meow-position-highlight-number-3 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-2)))))) + +(add-hook 'enable-theme-functions #'my-modus-themes-custom-faces) +#+end_src + +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + +** DIY Add support for combobulate +:PROPERTIES: +:CUSTOM_ID: h:e94bdd17-1c2d-41b5-86c5-83462bd8f30c +:END: + +The ~combobulate~ package provides the means to operate on text that +is underpinned by the ~tree-sitter~ program. Because this is a +specialized case that requires intimate knowledge of the +technicalities, I am not adding support for this package directly at +the theme level. Users can try this instead: + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces (&rest _) + (modus-themes-with-colors + (custom-set-faces + `(combobulate-active-indicator-face ((,c :foreground ,fg-main))) + `(combobulate-dimmed-indicator-face ((,c :inherit shadow))) + `(combobulate-error-indicator-face ((,c :inherit error))) + `(combobulate-query-highlight-fiery-flames-face ((,c :inherit modus-themes-intense-red))) + `(combobulate-query-highlight-gleaming-gold-face ((,c :inherit modus-themes-intense-yellow))) + `(combobulate-query-highlight-majestic-mercury-face ((,c :inherit modus-themes-intense-cyan))) + `(combobulate-query-highlight-mysterious-mauve-face ((,c :inherit modus-themes-intense-magenta))) + `(combobulate-query-highlight-radiant-rind-face ((,c :inherit modus-themes-subtle-red))) + `(combobulate-query-highlight-regal-ripples-face ((,c :inherit modus-themes-intense-blue))) + `(combobulate-query-highlight-serene-shade-face ((,c :inherit modus-themes-subtle-green))) + `(combobulate-query-highlight-silver-shadows-face ((,c :background ,bg-active :foreground ,fg-main))) + `(combobulate-query-highlight-vibrant-veggie-face ((,c :inherit modus-themes-intense-green))) + `(combobulate-query-query-anonymous-face ((,c :inherit modus-themes-bold :foreground ,fg-alt))) + `(combobulate-query-query-builtin-face ((,c :inherit font-lock-builtin-face))) + `(combobulate-query-query-constant-face ((,c :inherit font-lock-constant-face))) + `(combobulate-query-query-doc-markup-face ((,c :inherit font-lock-doc-markup-face))) + `(combobulate-query-query-keyword-face ((,c :inherit font-lock-keyword-face))) + `(combobulate-query-query-predicate-builtin-face ((,c :inherit bold))) + `(combobulate-query-query-string-face ((,c :inherit font-lock-string-face))) + `(combobulate-refactor-choice-face ((,c :inherit modus-themes-slant :foreground ,info))) + `(combobulate-refactor-cursor-face ((,c :foreground ,cursor))) + `(combobulate-refactor-field-face ((,c :background ,bg-inactive :foreground ,fg-main :extend nil))) + `(combobulate-refactor-highlight-face ((,c :inherit highlight))) + `(combobulate-refactor-inactive-choice-face ((,c :inherit modus-themes-slant :foreground ,fg-dim))) + `(combobulate-refactor-inactive-field-face ((,c :background ,bg-dim :foreground ,fg-dim :extend nil))) + `(combobulate-refactor-label-face ((,c :inherit modus-themes-search-replace))) + `(combobulate-tree-branch-face ((,c :inherit shadow))) + `(combobulate-tree-highlighted-node-face ((,c :inherit success))) + `(combobulate-tree-normal-node-face ((,c :foreground ,fg-main))) + `(combobulate-tree-pulse-node-face ((,c :background ,bg-blue-intense :extend t)))))) + +(add-hook 'enable-theme-functions #'my-modus-themes-custom-faces) +#+end_src + +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + +** DIY Add support for howm +:PROPERTIES: +:CUSTOM_ID: h:7ea8fa66-1cd8-47b0-92b4-9998a3068f85 +:END: + +The ~howm~ package is a note-taking solution for Emacs. Users can add +support for its faces with something like the following. + +#+begin_src emacs-lisp +(defun my-modus-themes-custom-faces (&rest _) + (modus-themes-with-colors + (custom-set-faces + `(action-lock-face ((,c :inherit button))) + `(howm-mode-keyword-face (( ))) + `(howm-mode-ref-face ((,c :inherit link))) + `(howm-mode-title-face ((,c :inherit modus-themes-heading-0))) + `(howm-mode-wiki-face ((,c :inherit link))) + `(howm-reminder-deadline-face ((,c :foreground ,date-deadline))) + `(howm-reminder-late-deadline-face ((,c :inherit bold :foreground ,date-deadline))) + `(howm-reminder-defer-face ((,c :foreground ,date-scheduled))) + `(howm-reminder-scheduled-face ((,c :foreground ,date-scheduled))) + `(howm-reminder-done-face ((,c :foreground ,prose-done))) + `(howm-reminder-todo-face ((,c :foreground ,prose-todo))) + `(howm-reminder-normal-face ((,c :foreground ,date-common))) + `(howm-reminder-today-face ((,c :inherit bold :foreground ,date-common))) + `(howm-reminder-tomorrow-face ((,c :inherit bold :foreground ,date-scheduled))) + `(howm-simulate-todo-mode-line-face ((,c :inherit bold))) + `(howm-view-empty-face (( ))) + `(howm-view-hilit-face ((,c :inherit match))) + `(howm-view-name-face ((,c :inherit bold))) + `(iigrep-counts-face1 ((,c :foreground ,rainbow-1))) + `(iigrep-counts-face2 ((,c :foreground ,rainbow-2))) + `(iigrep-counts-face3 ((,c :foreground ,rainbow-3))) + `(iigrep-counts-face4 ((,c :foreground ,rainbow-4))) + `(iigrep-counts-face5 ((,c :foreground ,rainbow-5)))))) + +(add-hook 'enable-theme-functions #'my-modus-themes-custom-faces) +#+end_src + ** DIY Use a hook at the post-load-theme phase :PROPERTIES: :CUSTOM_ID: h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24 @@ -4057,6 +4297,7 @@ have lots of extensions, so the "full support" may not be 100% true… + focus + fold-this + font-lock (generic syntax highlighting) ++ forge + geiser + git-commit + git-gutter (and variants) @@ -4066,6 +4307,7 @@ have lots of extensions, so the "full support" may not be 100% true… + gotest + golden-ratio-scroll-screen + helpful ++ hexl-mode + highlight-numbers + highlight-parentheses ([[#h:24bab397-dcb2-421d-aa6e-ec5bd622b913][Note on highlight-parentheses.el]]) + highlight-thing @@ -4264,7 +4506,6 @@ supported by the themes. + flyspell-correct + fortran-mode + freeze-it -+ forge + git-walktree + goggles + highlight-defined @@ -4534,7 +4775,7 @@ advanced customization options of the themes. [[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]. In the following example, we are assuming that the user wants to (i) -re-use color variables provided by the themes, (ii) be able to retain +reuse color variables provided by the themes, (ii) be able to retain their tweaks while switching between ~modus-operandi~ and ~modus-vivendi~, and (iii) have the option to highlight either the foreground of the parentheses or the background as well. @@ -4554,7 +4795,7 @@ Then we can update our preference with this: (setq my-highlight-parentheses-use-background nil) #+end_src -To re-use colors from the themes, we must wrap our code in the +To reuse colors from the themes, we must wrap our code in the ~modus-themes-with-colors~ macro. Our implementation must interface with the variables ~highlight-parentheses-background-colors~ and/or ~highlight-parentheses-colors~. @@ -5220,7 +5461,7 @@ each of the three channels of light (red, green, blue). For example: : xrandr --output LVDS1 --brightness 1.0 --gamma 0.76:0.75:0.68 Typography is another variable. Some font families are blurry at small -point sizes. Others may have a regular weight that is lighter (thiner) +point sizes. Others may have a regular weight that is lighter (thinner) than that of their peers which may, under certain circumstances, cause a halo effect around each glyph. @@ -5516,19 +5757,19 @@ The Modus themes are a collective effort. Every bit of work matters. Euker, Feng Shu, Filippo Argiolas, Gautier Ponsinet, Gerry Agbobada, Gianluca Recchia, Gonçalo Marrafa, Guilherme Semente, Gustavo Barros, Hörmetjan Yiltiz, Ilja Kocken, Imran Khan, Iris Garcia, Ivan - Popovych, James Ferguson, Jeremy Friesen, Jerry Zhang, Johannes - Grødem, John Haman, John Wick, Jonas Collberg, Jorge Morais, Joshua - O'Connor, Julio C. Villasante, Kenta Usami, Kevin Fleming, Kévin Le - Gouguec, Kevin Kainan Li, Kostadin Ninev, Laith Bahodi, Lasse - Lindner, Len Trigg, Lennart C.{{{space()}}} Karssen, Luis Miguel - Castañeda, Magne Hov, Manuel Giraud, Manuel Uberti, Mark Bestley, - Mark Burton, Mark Simpson, Marko Kocic, Markus Beppler, Matt - Armstrong, Matthias Fuchs, Mattias Engdegård, Mauro Aranda, Maxime - Tréca, Michael Goldenberg, Morgan Smith, Morgan Willcock, Murilo - Pereira, Nicky van Foreest, Nicolas De Jaeghere, Nicolas Semrau, - Olaf Meeuwissen, Oliver Epper, Pablo Stafforini, Paul Poloskov, - Pengji Zhang, Pete Kazmier, Peter Wu, Philip Kaludercic, Pierre - Téchoueyres, Przemysław Kryger, Robert Hepple, Roman Rudakov, + Popovych, Jabir Ali Ouassou, James Ferguson, Jeremy Friesen, Jerry + Zhang, Johannes Grødem, John Haman, John Wick, Jonas Collberg, Jorge + Morais, Joshua O'Connor, Julio C. Villasante, Kenta Usami, Kevin + Fleming, Kévin Le Gouguec, Kevin Kainan Li, Kostadin Ninev, Laith + Bahodi, Lasse Lindner, Len Trigg, Lennart C.{{{space()}}} Karssen, + Luis Miguel Castañeda, Magne Hov, Manuel Giraud, Manuel Uberti, Mark + Bestley, Mark Burton, Mark Simpson, Marko Kocic, Markus Beppler, + Matt Armstrong, Matthias Fuchs, Mattias Engdegård, Mauro Aranda, + Maxime Tréca, Michael Goldenberg, Morgan Smith, Morgan Willcock, + Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Nicolas + Semrau, Olaf Meeuwissen, Oliver Epper, Pablo Stafforini, Paul + Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, Philip Kaludercic, + Pierre Téchoueyres, Przemysław Kryger, Robert Hepple, Roman Rudakov, Russell Sim, Ryan Phillips, Rytis Paškauskas, Rudolf Adamkovič, Sam Kleinman, Samuel Culpepper, Saša Janiška, Shreyas Ragavan, Simon Pugnet, Steve Downey, Tassilo Horn, Thanos Apollo, Thibaut Verron, diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 1b40ce6fa62..93247e318de 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -819,18 +819,18 @@ availability and usability of one of the commands defined in @code{tramp-inline-compress-commands}. @table @asis -@item @option{rsh} @cindex method @option{rsh} @cindex @option{rsh} method +@item @option{rsh} @command{rsh} is an option for connecting to hosts within local networks since @command{rsh} is not as secure as other methods. There should be no reason to use it, as @command{ssh} is a both a complete replacement and ubiquitous. -@item @option{ssh} @cindex method @option{ssh} @cindex @option{ssh} method +@item @option{ssh} @command{ssh} is a more secure option than others to connect to a remote host. @@ -840,25 +840,25 @@ example, a host on port 42 is specified as @file{host#42} (the real host name, a hash sign, then a port number). It is the same as passing @samp{-p 42} to the @command{ssh} command. -@item @option{telnet} @cindex method @option{telnet} @cindex @option{telnet} method +@item @option{telnet} Connecting to a remote host with @command{telnet} is as insecure as the @option{rsh} method. -@item @option{su} @cindex method @option{su} @cindex @option{su} method +@item @option{su} Instead of connecting to a remote host, @command{su} program allows editing as another user. The host can be either @samp{localhost} or the host returned by the function @command{(system-name)}. See @ref{Multi-hops} for an exception to this behavior. -@item @option{androidsu} @cindex method @option{androidsu} @cindex @option{androidsu} method +@item @option{androidsu} Because the default implementation of the @option{su} method and other shell-based methods conflict with non-standard @command{su} @@ -871,9 +871,9 @@ multi-hops are unsupported. This is an optional method, @pxref{Optional methods}. It is enabled by default on @code{android} systems only. -@item @option{sudo} @cindex method @option{sudo} @cindex @option{sudo} method +@item @option{sudo} Similar to @option{su} method, @option{sudo} uses @command{sudo}. @command{sudo} must have sufficient rights to start a shell. @@ -882,17 +882,17 @@ For security reasons, a @option{sudo} connection is disabled after a predefined timeout (5 minutes by default). This can be changed, @pxref{Predefined connection information}. -@item @option{doas} @cindex method @option{doas} @cindex @option{doas} method +@item @option{doas} This method is used on OpenBSD like the @command{sudo} command. Like the @option{sudo} method, a @option{doas} connection is disabled after a predefined timeout. -@item @option{run0} @cindex method @option{run0} @cindex @option{run0} method +@item @option{run0} @c This requires systemd 256. Check with 'systemd-run --version'. This method is used on @code{systemd}-based hosts. A @option{run0} @@ -900,9 +900,9 @@ connection is disabled after a predefined timeout as well. This is an optional method, @pxref{Optional methods}. -@item @option{sg} @cindex method @option{sg} @cindex @option{sg} method +@item @option{sg} The @command{sg} program allows editing as different group. The host can be either @samp{localhost} or the host returned by the function @@ -910,9 +910,9 @@ can be either @samp{localhost} or the host returned by the function denotes a group name. See @ref{Multi-hops} for an exception to this behavior. -@item @option{sshx} @cindex method @option{sshx} @cindex @option{sshx} method +@item @option{sshx} Works like @option{ssh} but without the extra authentication prompts. @option{sshx} uses @samp{ssh -t -t -l @var{user} -o @@ -933,27 +933,27 @@ missing shell prompts that confuses @value{tramp}. @option{sshx} supports the @samp{-p} argument. -@item @option{krlogin} @cindex method @option{krlogin} @cindex @option{krlogin} method @cindex kerberos (with @option{krlogin} method) +@item @option{krlogin} This method is also similar to @option{ssh}. It uses the @command{krlogin -x} command only for remote host login. This method is an optional method, @pxref{Optional methods}. -@item @option{ksu} @cindex method @option{ksu} @cindex @option{ksu} method @cindex kerberos (with @option{ksu} method) +@item @option{ksu} This is another method from the Kerberos suite. It behaves like @option{su}. It is an optional method, @pxref{Optional methods}. -@item @option{plink} @cindex method @option{plink} @cindex @option{plink} method +@item @option{plink} @option{plink} method is for MS Windows users with the PuTTY implementation of SSH@. It uses @samp{plink -ssh} to log in to the @@ -964,9 +964,9 @@ session. @option{plink} method supports the @samp{-P} argument. -@item @option{plinkx} @cindex method @option{plinkx} @cindex @option{plinkx} method +@item @option{plinkx} Another method using PuTTY on MS Windows with session names instead of host names. @option{plinkx} calls @samp{plink -load @var{session} @@ -982,9 +982,9 @@ The following methods allow to access running containers in different ways: @table @asis -@item @option{docker} @cindex method @option{docker} @cindex @option{docker} method +@item @option{docker} Integration for Docker containers. The host name may be either a running container's name or ID, as returned by @samp{docker ps}. @@ -994,9 +994,9 @@ If the @command{docker} program isn't found in your @env{PATH} environment variable, you can tell @value{tramp} its absolute path via the user option @code{tramp-docker-program}. -@item @option{podman} @cindex method @option{podman} @cindex @option{podman} method +@item @option{podman} Podman is an alternative to @option{docker} which may be run rootless, if desired. @@ -1006,9 +1006,9 @@ If the @command{podman} program isn't found in your @env{PATH} environment variable, you can tell @value{tramp} its absolute path via the user option @code{tramp-podman-program}. -@item @option{kubernetes} @cindex method @option{kubernetes} @cindex @option{kubernetes} method +@item @option{kubernetes} Integration for containers in Kubernetes pods. The host name is @samp{@var{pod}}, or @samp{@var{container}.@var{pod}} if an explicit @@ -1025,12 +1025,12 @@ tell @value{tramp} its absolute path via the user option This method does not support user names. -@item @option{toolbox} -@item @option{distrobox} @cindex method @option{toolbox} @cindex @option{toolbox} method +@item @option{toolbox} @cindex method @option{distrobox} @cindex @option{distrobox} method +@item @option{distrobox} Integration of Toolbox or Distrobox system containers, respectively. The host name may be either a container's name or ID, as returned by @@ -1051,9 +1051,9 @@ absolute path via the user option @code{tramp-toolbox-program} or These are optional methods, @pxref{Optional methods}. They do not support user names. -@item @option{flatpak} @cindex method @option{flatpak} @cindex @option{flatpak} method +@item @option{flatpak} Integration of Flatpak sandboxes. The host name may be either an application ID, a sandbox instance ID, or a PID, as returned by @@ -1067,9 +1067,9 @@ the user option @code{tramp-flatpak-program}. This is an optional method, @pxref{Optional methods}. It does not support user names. -@item @option{apptainer} @cindex method @option{apptainer} @cindex @option{apptainer} method +@item @option{apptainer} Integration of Apptainer instances. The host name is the instance name, as returned by @samp{apptainer instance list}. @@ -1082,9 +1082,9 @@ the user option @code{tramp-apptainer-program}. This is an optional method, @pxref{Optional methods}. It does not support user names. -@item @option{nspawn} @cindex method @option{nspawn} @cindex @option{nspawn} method +@item @option{nspawn} Integration of @code{systemd-nspawn} instances. The host name is the instance name, as returned by @samp{machinectl list --all}. @@ -1116,10 +1116,10 @@ files smaller than @code{tramp-copy-size-limit} still use inline methods. @table @asis -@item @option{rcp} @cindex method @option{rcp} @cindex @option{rcp} method @cindex @command{rsh} (with @option{rcp} method) +@item @option{rcp} This method uses the @command{rsh} and @command{rcp} commands to connect to the remote host and transfer files. This is the fastest @@ -1128,10 +1128,10 @@ access method available. The alternative method @option{remcp} uses the @command{remsh} and @command{rcp} commands. -@item @option{scp} @cindex method @option{scp} @cindex @option{scp} method @cindex @command{ssh} (with @option{scp} method) +@item @option{scp} Using a combination of @command{ssh} to connect and @command{scp} to transfer is the most secure. While the performance is good, it is @@ -1144,10 +1144,10 @@ port numbers. For example, @file{host#42} passes @samp{-p 42} in the argument list to @command{ssh}, and @samp{-P 42} in the argument list to @command{scp}. -@item @option{rsync} @cindex method @option{rsync} @cindex @option{rsync} method @cindex @command{ssh} (with @option{rsync} method) +@item @option{rsync} @command{ssh} command to connect in combination with @command{rsync} command to transfer is similar to the @option{scp} method. @@ -1158,10 +1158,10 @@ is lost if the file exists only on one side of the connection. This method supports the @samp{-p} argument. -@item @option{scpx} @cindex method @option{scpx} @cindex @option{scpx} method @cindex @command{ssh} (with @option{scpx} method) +@item @option{scpx} @option{scpx} is useful to avoid login shell questions. It is similar in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -l @@ -1175,16 +1175,16 @@ missing shell prompts that confuses @value{tramp}. This method supports the @samp{-p} argument. -@item @option{pscp} -@item @option{psftp} @cindex method @option{pscp} @cindex @option{pscp} method @cindex @command{plink} (with @option{pscp} method) @cindex @command{putty} (with @option{pscp} method) +@item @option{pscp} @cindex method @option{psftp} @cindex @option{psftp} method @cindex @command{plink} (with @option{psftp} method) @cindex @command{putty} (with @option{psftp} method) +@item @option{psftp} These methods are similar to @option{scp} or @option{sftp}, but they use the @command{plink} command to connect to the remote host, and @@ -1198,12 +1198,12 @@ session. These methods support the @samp{-P} argument. -@item @option{dockercp} -@item @option{podmancp} @cindex method @option{dockercp} @cindex @option{dockercp} method +@item @option{dockercp} @cindex method @option{podmancp} @cindex @option{podmancp} method +@item @option{podmancp} These methods are similar to @option{docker} or @option{podman}, but they use the command @command{docker cp} or @command{podman cp} for @@ -1212,10 +1212,10 @@ transferring large files. These copy commands do not support file globs, and they ignore a user name. -@item @option{fcp} @cindex method @option{fcp} @cindex @option{fcp} method @cindex @command{fsh} (with @option{fcp} method) +@item @option{fcp} This method is similar to @option{scp}, but uses @command{fsh} to connect and @command{fcp} to transfer files. @command{fsh/fcp}, a @@ -1236,10 +1236,10 @@ and @value{tramp} keeps that one connection open. This is an optional method, @pxref{Optional methods}. -@item @option{nc} @cindex method @option{nc} @cindex @option{nc} method @cindex @command{telnet} (with @option{nc} method) +@item @option{nc} Using @command{telnet} to connect and @command{nc} to transfer files is sometimes the only combination suitable for accessing routers or @@ -1249,9 +1249,9 @@ decode programs. This is an optional method, @pxref{Optional methods}. -@item @option{sudoedit} @cindex method @option{sudoedit} @cindex @option{sudoedit} method +@item @option{sudoedit} The @option{sudoedit} method facilitates editing a file as a different user on the local host. You could regard this as @value{tramp}'s @@ -1273,19 +1273,19 @@ use any host name in the remote file name, like Like the @option{sudo} method, a @option{sudoedit} password expires after a predefined timeout. -@item @option{ftp} @cindex method @option{ftp} @cindex @option{ftp} method +@item @option{ftp} When @value{tramp} uses @option{ftp}, it forwards requests to whatever ftp program is specified by Ange FTP@. This external program must be capable of servicing requests from @value{tramp}. -@item @option{smb} @cindex method @option{smb} @cindex @option{smb} method @cindex ms windows (with @option{smb} method) @cindex @command{smbclient} +@item @option{smb} This non-native @value{tramp} method connects via the Server Message Block (SMB) networking protocol to hosts running file servers that are @@ -1354,10 +1354,10 @@ UNC file name specification does not allow the specification of a different user name for authentication like the @command{smbclient} can. -@item @option{adb} @cindex method @option{adb} @cindex @option{adb} method @cindex android (with @option{adb} method) +@item @option{adb} @vindex tramp-adb-program @vindex PATH@r{, environment variable} @@ -1412,22 +1412,22 @@ Emacs must have the message bus system, D-Bus integration active, @pxref{Top, , D-Bus, dbus}. @table @asis -@item @option{afp} @cindex method @option{afp} @cindex @option{afp} method +@item @option{afp} This method is for connecting to remote hosts with the Apple Filing Protocol for accessing files on macOS volumes. @value{tramp} access syntax requires a leading volume (share) name, for example: @file{@trampfn{afp,user@@host,/volume}}. -@item @option{dav} -@item @option{davs} @cindex WebDAV @cindex method @option{dav} -@cindex method @option{davs} @cindex @option{dav} method +@item @option{dav} +@cindex method @option{davs} @cindex @option{davs} method +@item @option{davs} @option{dav} method provides access to WebDAV files and directories based on standard protocols, such as HTTP@. @option{davs} does the same @@ -1438,11 +1438,11 @@ as it is common for OwnCloud or NextCloud file names, are not supported by these methods. See method @option{nextcloud} for handling them. -@item @option{gdrive} @cindex @acronym{GNOME} Online Accounts @cindex method @option{gdrive} @cindex @option{gdrive} method @cindex google drive +@item @option{gdrive} Via the @option{gdrive} method it is possible to access your Google Drive online storage. User and host name of the remote file name are @@ -1456,10 +1456,10 @@ could produce unexpected behavior in case two files in the same directory have the same @code{display-name}, such a situation must be avoided. -@item @option{mtp} @cindex method @option{mtp} @cindex @option{mtp} method @cindex media +@item @option{mtp} Media devices, like cell phones, tablets, cameras, can be accessed via the @option{mtp} method. Just the device name is needed in order to @@ -1475,10 +1475,10 @@ different parts of their file system. name when a single media device is connected. @value{tramp} instead uses @file{@trampfn{mtp,,}} as the default name. -@item @option{nextcloud} @cindex method @option{nextcloud} @cindex @option{nextcloud} method @cindex nextcloud +@item @option{nextcloud} As the name indicates, the method @option{nextcloud} allows you to access OwnCloud or NextCloud hosted files and directories. Like the @@ -1486,9 +1486,9 @@ access OwnCloud or NextCloud hosted files and directories. Like the @command{Online Accounts} application outside Emacs. The method supports port numbers. -@item @option{sftp} @cindex method @option{sftp} @cindex @option{sftp} method +@item @option{sftp} This method uses @command{sftp} in order to securely access remote hosts. @command{sftp} is a more secure option for connecting to hosts @@ -1537,9 +1537,9 @@ operation on them. For some of the file name operations this is not possible, @value{tramp} emulates those operations otherwise. @table @asis -@item @option{rclone} @cindex method @option{rclone} @cindex @option{rclone} method +@item @option{rclone} @vindex tramp-rclone-program The program @command{rclone} enables accessing different system @@ -1550,7 +1550,7 @@ absolute path via the user option @code{tramp-rclone-program}. A system storage must be configured via the @command{rclone config} command, outside Emacs. If you have configured a storage in -@command{rclone} under a name @samp{storage} (for example), you could +@command{rclone} under a name @samp{storage} (for example), you can access it via the remote file name @example @@ -1566,9 +1566,9 @@ for accessing the system storage, you should use it. @ref{GVFS-based methods} for example, methods @option{gdrive} and @option{nextcloud}. -@item @option{sshfs} @cindex method @option{sshfs} @cindex @option{sshfs} method +@item @option{sshfs} @vindex tramp-sshfs-program On local hosts which have installed the @command{sshfs} client for @@ -1591,7 +1591,7 @@ User name and port number are optional. This method does not support password handling, the file system must either be mounted already, or the connection must be established passwordless via ssh keys. -The mount point and mount arguments could be passed as connection +The mount point and mount arguments can be passed as connection properties, @xref{Setup of sshfs method}. @end table @@ -1920,7 +1920,7 @@ support this command. @subsection Tunneling with ssh @vindex ProxyCommand@r{, ssh option} -With @command{ssh}, you could use the @option{ProxyCommand} entry in +With @command{ssh}, you can use the @option{ProxyCommand} entry in @file{~/.ssh/config}: @example @@ -1973,50 +1973,50 @@ They can be installed with Emacs's Package Manager. This includes @c @item ibuffer-tramp.el @c Contact Svend Sorensen <svend@@ciffer.net> -@item incus-tramp @cindex method @option{incus} @cindex @option{incus} method +@item incus-tramp Integration for Incus containers. A container is accessed via @file{@trampfn{incus,user@@container,/path/to/file}}, @samp{user} and @samp{container} have the same meaning as with the @option{docker} method. -@item lxc-tramp @cindex method @option{lxc} @cindex @option{lxc} method +@item lxc-tramp Integration for LXC containers. A container is accessed via @file{@trampfn{lxc,container,/path/to/file}}, @samp{container} has the same meaning as with the @option{docker} method. A @samp{user} specification is ignored. -@item lxd-tramp @cindex method @option{lxd} @cindex @option{lxd} method +@item lxd-tramp Integration for LXD containers. A container is accessed via @file{@trampfn{lxd,user@@container,/path/to/file}}, @samp{user} and @samp{container} have the same meaning as with the @option{docker} method. -@item magit-tramp @cindex method @option{git} @cindex @option{git} method +@item magit-tramp Browsing Git repositories with @code{magit}. A versioned file is accessed via @file{@trampfn{git,rev@@root-dir,/path/to/file}}. @samp{rev} is a Git revision, and @samp{root-dir} is a virtual host name for the root directory, specified in @code{magit-tramp-hosts-alist}. -@item tramp-hdfs @cindex method @option{hdfs} @cindex @option{hdfs} method +@item tramp-hdfs Access of a hadoop/hdfs file system. A file is accessed via @file{@trampfn{hdfs,user@@node,/path/to/file}}, where @samp{user} is the user that you want to use, and @samp{node} is the name of the hadoop server. -@item vagrant-tramp @cindex method @option{vagrant} @cindex @option{vagrant} method +@item vagrant-tramp Convenience method to access vagrant boxes. It is often used in multi-hop file names like @file{@trampfn{vagrant@value{postfixhop}box|sudo,box,/path/to/file}}, @@ -2245,14 +2245,24 @@ like this: @value{tramp} can cache passwords as entered and reuse when needed for the same user or host name independent of the access method. -@vindex password-cache-expiry -@code{password-cache-expiry} sets the duration (in seconds) the -passwords are remembered. Passwords are never saved permanently nor -can they extend beyond the lifetime of the current Emacs session. Set -@code{password-cache-expiry} to @code{nil} to disable expiration. +@vindex auth-source-cache-expiry +@code{auth-source-cache-expiry}@footnote{It overrides +@code{password-cache-expiry}.} sets the duration (in seconds) the +passwords are remembered. Set @code{auth-source-cache-expiry} to +@code{nil} to disable expiration. + +Cached passwords are never saved permanently nor can they extend +beyond the lifetime of the current Emacs session unless you confirm +this interactively. -@vindex password-cache -Set @code{password-cache} to @code{nil} to disable password caching. +@vindex auth-source-do-cache +Set @code{auth-source-do-cache} to @code{nil} to disable password caching. + +For connections which use a session-timeout, like @option{sudo}, +@option{doas} and @option{run0}, the password cache is expired by +@value{tramp} when the session expires (@pxref{Predefined connection +information}). However, this makes only sense if the password cannot +be retrieved from a persistent authentication file or store. @node Connection caching @@ -2317,7 +2327,7 @@ The parameters @code{tramp-remote-shell} and @code{tramp-remote-shell-login} in @code{tramp-methods} now have new values for the remote host. -@var{property} could also be any property found in +@var{property} can also be any property found in @code{tramp-persistency-file-name}. @@ -2467,7 +2477,7 @@ variables, @xref{Connection Variables, , , emacs}. @ifnotinfo variables. @end ifnotinfo -You could define your own search directories like this: +You can define your own search directories like this: @lisp @group @@ -2591,10 +2601,10 @@ which may not be the same as the local login shell prompt, @value{tramp} sets a similar default value for both prompts. @vindex tramp-password-prompt-regexp -@vindex tramp-otp-password-prompt-regexp -@vindex tramp-wrong-passwd-regexp @item @code{tramp-password-prompt-regexp} +@vindex tramp-otp-password-prompt-regexp @item @code{tramp-otp-password-prompt-regexp} +@vindex tramp-wrong-passwd-regexp @item @code{tramp-wrong-passwd-regexp} @value{tramp} uses @code{tramp-password-prompt-regexp} to @@ -2641,10 +2651,10 @@ prompts, for which @value{tramp} uses @code{tramp-wrong-passwd-regexp}. @value{tramp} uses the user option @code{tramp-terminal-type} to set the remote environment variable @env{TERM} for the shells it runs. -By default, it is @t{"dumb"}, but this could be changed. A dumb +By default, it is @t{"dumb"}, but this can be changed. A dumb terminal is best suited to run the background sessions of @value{tramp}. However, running interactive remote shells might -require a different setting. This could be achieved by tweaking the +require a different setting. This can be achieved by tweaking the @env{TERM} environment variable in @code{process-environment}. @lisp @@ -2680,7 +2690,7 @@ process, @xref{Interactive Shell, , , emacs}. @ifnotinfo process. @end ifnotinfo -@value{tramp} adds its own package version to this string, which could +@value{tramp} adds its own package version to this string, which can be used for further tests in an inferior shell. The string of that environment variable looks always like @@ -2691,9 +2701,9 @@ echo $INSIDE_EMACS @end group @end example -@item @command{tset} and other questions @cindex unix command @command{tset} @cindex @command{tset} unix command +@item @command{tset} and other questions To suppress inappropriate prompts for terminal type, @value{tramp} sets the @env{TERM} environment variable before the remote login @@ -2807,9 +2817,9 @@ fi @xref{Interactive Shell, , , emacs}. @end ifinfo -@item @command{busybox} / @command{nc} @cindex unix command @command{nc} @cindex @command{nc} unix command +@item @command{busybox} / @command{nc} @value{tramp}'s @option{nc} method uses the @command{nc} command to install and execute a listener as follows (see @code{tramp-methods}): @@ -2900,7 +2910,8 @@ Host * The corresponding PuTTY configuration is in the @option{Connection} entry, @option{Seconds between keepalives} option. Set this to 5. -There is no counter which could be set. +PuTTY does not have a configuration option equivalent to OpenSSH's +@option{ServerAliveCountMax}. @anchor{Using ssh connection sharing} @@ -3664,8 +3675,8 @@ This command changes the syntax @value{tramp} uses for remote file names. Beside the @code{default} value, @var{syntax} can be @itemize -@item @code{simplified} @cindex simplified syntax +@item @code{simplified} This remote file name syntax is similar to the syntax used by Ange FTP@. A remote file name has the form @@ -3673,8 +3684,8 @@ A remote file name has the form @samp{user@@} part is optional, and the method is determined by @ref{Default Method}. -@item @code{separate} @cindex separate syntax +@item @code{separate} @clear unified @set separate @@ -3914,6 +3925,33 @@ shall be taken, add a proper rule to the user option @end lisp +@subsection Using different proxies for the same destination + +@strong{Note}: This feature is experimental, don't use it in +production systems! + +Sometimes, it is needed to specify different proxies for the same +destination host name. This can happen for the same destination when +the local host is located in different networks over the time. This +can also happen when the remote destination is specified by the remote +same file name, although different hosts are meant depending on the +used proxy. A typical example are docker containers, which run on +different hosts under the same docker name. + +When the user option @code{tramp-show-ad-hoc-proxies} is +non-@code{nil}, such ad-hoc multi-hop file names can be used in +parallel. In the following, on both remote hosts @samp{host1} and +@samp{host2} there is a docker container @samp{name}, respectively: + +@example +@trampfn{ssh@value{postfixhop}user1@@host1|docker,name,} +@trampfn{ssh@value{postfixhop}user2@@host2|docker,name,} +@end example + +If you use the shortened name @samp{@trampfn{docker,name,}}, the last +used proxy definition is expanded for. + + @node Home directories @section Expanding @file{~} to home directory @@ -3958,7 +3996,7 @@ directory has been used already. The methods @option{adb}, @option{rclone} and @option{sshfs} do not support home directory expansion at all. However, @value{tramp} keeps -the home directory in the cache. Therefore, those methods could be +the home directory in the cache. Therefore, those methods can be configured to expand a home directory via a connection property, @xref{Predefined connection information}. Example: @@ -4158,18 +4196,18 @@ Due to the remote shell saving tilde expansions triggered by @code{tramp-histfile-override}. When set to @code{t}, environment variable @env{HISTFILE} is unset, and environment variables @env{HISTFILESIZE} and @env{HISTSIZE} are set to 0. Don't use this -with @command{bash} 5.0.0. There is a bug in @command{bash} which -lets @command{bash} die. +with @command{bash} 5.0.0@: that version has a bug which +causes @command{bash} to die. -Alternatively, @code{tramp-histfile-override} could be a string. -Environment variable @env{HISTFILE} is set to this file name then. Be -careful when setting to @file{/dev/null}; this might result in -undesired results when using @command{bash} as remote shell. +Alternatively, @code{tramp-histfile-override} can be a string. +The environment variable @env{HISTFILE} is then set to this file name. Be +careful if using @file{/dev/null}; this might result in undesired +results when using @command{bash} as remote shell. -Another approach is to disable @value{tramp}'s handling of the -@env{HISTFILE} at all by setting @code{tramp-histfile-override} to -@code{nil}. In this case, saving history could be turned off by -putting this shell code in @file{.bashrc} or @file{.kshrc}: +Another approach is to completely disable @value{tramp}'s handling of +the @env{HISTFILE} by setting @code{tramp-histfile-override} to +@code{nil}. In this case, saving history can be turned off by putting +this shell code in @file{.bashrc} or @file{.kshrc}: @example @group @@ -4206,7 +4244,7 @@ ensures the correct name of the remote shell program. When @code{explicit-shell-file-name} is equal to @code{nil}, calling @code{shell} interactively will prompt for a shell name. -You could use connection-local variables for setting different values +You can use connection-local variables for setting different values of @code{explicit-shell-file-name} for different remote hosts. @ifinfo @xref{Connection Variables, , , emacs}. @@ -4496,11 +4534,11 @@ the @code{process-attributes} output plus the key @code{pid}, and be -@multitable {@bullet{} @code{numberp}} {--- a string of @var{number} width, could contain spaces} +@multitable {@bullet{} @code{numberp}} {--- a string of @var{number} width, can contain spaces} @item @bullet{} @code{numberp} @tab --- a number @item @bullet{} @code{stringp} @tab --- a string without spaces @item @bullet{} @var{number} -@tab --- a string of @var{number} width, could contain spaces +@tab --- a string of @var{number} width, can contain spaces @item @bullet{} @code{nil} @tab --- a string until end of line @end multitable @@ -4607,6 +4645,18 @@ which must be set to a non-@code{nil} value. Example: @end group @end lisp +This enables direct async processes for the host @samp{remotehost}. +If you want to enable direct async processes for all remote hosts +connected via the same method (e.g., @option{ssh}), use instead + +@lisp +@group +(connection-local-set-profiles + '(:application tramp :protocol "ssh") + 'remote-direct-async-process) +@end group +@end lisp + Using direct asynchronous processes in @value{tramp} is not possible, if the remote host is connected via multiple hops (@pxref{Multi-hops}). In this case, @value{tramp} falls back to its @@ -4732,7 +4782,7 @@ anymore. @deffn Command tramp-rename-files source target Replace in all buffers the visiting file name from @var{source} to -@var{target}. @var{source} is a remote directory name, which could +@var{target}. @var{source} is a remote directory name, which can contain also a localname part. @var{target} is the directory name @var{source} is replaced with. Often, @var{target} is a remote directory name on another host, but it can also be a local directory @@ -4781,17 +4831,19 @@ The default target for renaming remote buffer file names. This is an alist of cons cells @code{(source . target)}. The first matching item specifies the target to be applied for renaming buffer file names from source via @code{tramp-rename-files}. @code{source} is a regular -expressions, which matches a remote file name. @code{target} must be -a directory name, which could be remote (including remote directories -@value{tramp} infers by default, such as @file{@trampfn{method,user@@host,}}). +expression, which is used to match a remote file name. @code{target} +must be a directory name, which can be remote (including remote +directories which @value{tramp} infers by default, such as +@file{@trampfn{method,user@@host,}}). -@code{target} can contain the patterns @code{%m}, @code{%u} or -@code{%h}, which are replaced by the method name, user name or host -name of @code{source} when calling @code{tramp-rename-files}. +@code{target} can contain the format specifiers @code{%m}, @code{%u}, +or @code{%h}, which are replaced by the method name, user name, or host +name of @code{source} respectively when calling @code{tramp-rename-files}. -@code{source} could also be a Lisp form, which will be evaluated. The -result must be a string or @code{nil}, which is interpreted as a -regular expression which always matches. +@code{source} can also be a Lisp form, which is evaluated. The result +must be a string (which is used as a regular expression to match) or +@code{nil}, which is interpreted as a regular expression which always +matches. Example entries: @@ -4871,90 +4923,87 @@ archive file names. Accepted suffixes are listed in the constant @code{tramp-archive-suffixes}. They are @itemize -@item @samp{.7z} --- -7-Zip archives @cindex @file{7z} file archive suffix @cindex file archive suffix @file{7z} +@item @samp{.7z} --- +7-Zip archives -@item @samp{.apk} --- -Android package kits @cindex @file{apk} file archive suffix @cindex file archive suffix @file{apk} +@item @samp{.apk} --- +Android package kits -@item @samp{.ar} --- -UNIX archiver formats @cindex @file{ar} file archive suffix @cindex file archive suffix @file{ar} +@item @samp{.ar} --- +UNIX archiver formats -@item @samp{.cab}, @samp{.CAB} --- -Microsoft Windows cabinets @cindex @file{cab} file archive suffix @cindex @file{CAB} file archive suffix @cindex file archive suffix @file{cab} @cindex file archive suffix @file{CAB} +@item @samp{.cab}, @samp{.CAB} --- +Microsoft Windows cabinets -@item @samp{.cpio} --- -CPIO archives @cindex @file{cpio} file archive suffix @cindex file archive suffix @file{cpio} +@item @samp{.cpio} --- +CPIO archives -@item @samp{.crate} --- -Cargo (Rust) packages @cindex @file{crate} file archive suffix @cindex file archive suffix @file{crate} +@item @samp{.crate} --- +Cargo (Rust) packages -@item @samp{.deb} --- -Debian packages @cindex @file{deb} file archive suffix @cindex file archive suffix @file{deb} +@item @samp{.deb} --- +Debian packages -@item @samp{.depot} --- -HP-UX SD depots @cindex @file{depot} file archive suffix @cindex file archive suffix @file{depot} +@item @samp{.depot} --- +HP-UX SD depots -@item @samp{.epub} --- -Electronic publications @cindex @file{epub} file archive suffix @cindex file archive suffix @file{epub} +@item @samp{.epub} --- +Electronic publications -@item @samp{.exe} --- -Self extracting Microsoft Windows EXE files @cindex @file{exe} file archive suffix @cindex file archive suffix @file{exe} +@item @samp{.exe} --- +Self extracting Microsoft Windows EXE files -@item @samp{.iso} --- -ISO 9660 images @cindex @file{iso} file archive suffix @cindex file archive suffix @file{iso} +@item @samp{.iso} --- +ISO 9660 images -@item @samp{.jar} --- -Java archives @cindex @file{jar} file archive suffix @cindex file archive suffix @file{jar} +@item @samp{.jar} --- +Java archives -@item @samp{.lzh}, @samp{.LZH} --- -Microsoft Windows compressed LHA archives @cindex @file{lzh} file archive suffix @cindex @file{LZH} file archive suffix @cindex file archive suffix @file{lzh} @cindex file archive suffix @file{LZH} +@item @samp{.lzh}, @samp{.LZH} --- +Microsoft Windows compressed LHA archives -@item @samp{.msu}, @samp{.MSU} --- -Microsoft Windows Update packages @cindex @file{msu} file archive suffix @cindex @file{MSU} file archive suffix @cindex file archive suffix @file{msu} @cindex file archive suffix @file{MSU} +@item @samp{.msu}, @samp{.MSU} --- +Microsoft Windows Update packages -@item @samp{.mtree} --- -BSD mtree format @cindex @file{mtree} file archive suffix @cindex file archive suffix @file{mtree} +@item @samp{.mtree} --- +BSD mtree format -@item @samp{.odb}, @samp{.odf}, @samp{.odg}, @samp{.odp}, @samp{.ods}, -@samp{.odt} --- -OpenDocument formats @cindex @file{odb} file archive suffix @cindex @file{odf} file archive suffix @cindex @file{odg} file archive suffix @@ -4967,30 +5016,30 @@ OpenDocument formats @cindex file archive suffix @file{odp} @cindex file archive suffix @file{ods} @cindex file archive suffix @file{odt} +@item @samp{.odb}, @samp{.odf}, @samp{.odg}, @samp{.odp}, @samp{.ods}, +@samp{.odt} --- +OpenDocument formats -@item @samp{.pax} --- -Posix archives @cindex @file{pax} file archive suffix @cindex file archive suffix @file{pax} +@item @samp{.pax} --- +Posix archives -@item @samp{.rar} --- -RAR archives @cindex @file{rar} file archive suffix @cindex file archive suffix @file{rar} +@item @samp{.rar} --- +RAR archives -@item @samp{.rpm} --- -Red Hat packages @cindex @file{rpm} file archive suffix @cindex file archive suffix @file{rpm} +@item @samp{.rpm} --- +Red Hat packages -@item @samp{.shar} --- -Shell archives @cindex @file{shar} file archive suffix @cindex file archive suffix @file{shar} +@item @samp{.shar} --- +Shell archives -@item @samp{.tar}, @samp{.tbz}, @samp{.tgz}, @samp{.tlz}, @samp{.txz}, -@samp{.tzst} --- -(Compressed) tape archives @cindex @file{tar} file archive suffix @cindex @file{tbz} file archive suffix @cindex @file{tgz} file archive suffix @@ -5003,33 +5052,36 @@ Shell archives @cindex file archive suffix @file{tlz} @cindex file archive suffix @file{txz} @cindex file archive suffix @file{tzst} +@item @samp{.tar}, @samp{.tbz}, @samp{.tgz}, @samp{.tlz}, @samp{.txz}, +@samp{.tzst} --- +(Compressed) tape archives -@item @samp{.warc} --- -Web archives @cindex @file{warc} file archive suffix @cindex file archive suffix @file{warc} +@item @samp{.warc} --- +Web archives -@item @samp{.xar} --- -macOS XAR archives @cindex @file{xar} file archive suffix @cindex file archive suffix @file{xar} +@item @samp{.xar} --- +macOS XAR archives -@item @samp{.xpi} --- -XPInstall Mozilla addons @cindex @file{xpi} file archive suffix @cindex file archive suffix @file{xpi} +@item @samp{.xpi} --- +XPInstall Mozilla addons -@item @samp{.xps} --- -Open XML Paper Specification (OpenXPS) documents @cindex @file{xps} file archive suffix @cindex file archive suffix @file{xps} +@item @samp{.xps} --- +Open XML Paper Specification (OpenXPS) documents -@item @samp{.zip}, @samp{.ZIP} --- -ZIP archives @cindex @file{zip} file archive suffix @cindex @file{ZIP} file archive suffix @cindex file archive suffix @file{zip} @cindex file archive suffix @file{ZIP} +@item @samp{.zip}, @samp{.ZIP} --- +ZIP archives @end itemize @vindex tramp-archive-compression-suffixes @@ -5043,7 +5095,7 @@ constant @code{tramp-archive-compression-suffixes}. They are row are possible, like @file{/path/to/dir/file.tar.gz.uu/dir/file}. @vindex tramp-archive-all-gvfs-methods -An archive file name could be a remote file name, as in +An archive file name can be a remote file name, as in @file{/ftp:anonymous@@ftp.gnu.org:/gnu/tramp/tramp-2.4.5.tar.gz/INSTALL}. Since all file operations are mapped internally to @acronym{GVFS} operations, remote file names supported by @code{tramp-gvfs} perform @@ -5053,7 +5105,7 @@ than the similar @samp{/scp:user@@host:@dots{}}. See the constant @code{tramp-archive-all-gvfs-methods} for a complete list of @code{tramp-gvfs} supported method names. -If @code{url-handler-mode} is enabled, archives could be visited via +If @code{url-handler-mode} is enabled, archives can be visited via URLs, like @file{https://ftp.gnu.org/gnu/tramp/tramp-2.4.5.tar.gz/INSTALL}. This allows complex file operations like @@ -5081,7 +5133,7 @@ coreutils_8.28-1_amd64.deb/control.tar.gz/control")) @end lisp @vindex tramp-archive-enabled -In order to disable file archives, you could add the following form to +In order to disable file archives, you can add the following form to your init file: @lisp @@ -5157,21 +5209,32 @@ When including @value{tramp}'s messages in the bug report, increase the verbosity level to 6 (@pxref{Traces and Profiles, Traces}) in the @file{~/.emacs} file before repeating steps to the bug. Include the contents of the @file{*tramp/foo*} and @file{*debug tramp/foo*} -buffers with the bug report. Both buffers could contain +buffers with the bug report. Since those buffers could contain non-@acronym{ASCII} characters which are relevant for analysis, append -the buffers as attachments to the bug report. This is also needed in -order to avoid line breaks during mail transfer. +the buffers as attachments to the bug report rather than placing them +inline. This is also needed in order to avoid line breaks getting added +or deleted during mail transfer. -If you send the message from Emacs, you are asked about to append +If you send the message from Emacs, you are asked whether to append these buffers to the bug report. If you use an external mail program, you must save these buffers to files, and append them with that mail program. -@strong{Note} that a verbosity level greater than 6 is not necessary -at this stage. Also note that a verbosity level of 6 or greater, the -contents of files and directories will be included in the debug -buffer. Passwords typed in @value{tramp} will never be included -there. +@strong{Note} that a verbosity level greater than 6 is not necessary at +this stage. Also note that with a verbosity level of 6 or greater, the +contents of files and directories will be included in the debug buffer. +Passwords typed in @value{tramp} will never be included there. + +If you find, that using @value{tramp} with @command{emacs -Q} doesn't +cause any problem, you might check your init file for the suspicious +configuration by bisecting it. That is, comment out about half of the +init file, and check whether the problem still arises when calling +@command{emacs}. If yes, comment out half of the still active code. +Otherwise, comment out the active code, and uncomment the just +commented code. + +Call @command{emacs}, again. Reiterate, until you find the suspicious +configuaration. @node Frequently Asked Questions @@ -5379,7 +5442,7 @@ as value of the @env{TERM} environment variable. If you want to use another value for @env{TERM}, change @code{tramp-terminal-type} and this line accordingly. -Alternatively, you could set the remote login shell explicitly. See +Alternatively, you can set the remote login shell explicitly. See @ref{Remote shell setup} for discussion of this technique, When using fish shell on remote hosts, disable fancy formatting by @@ -5687,7 +5750,7 @@ encrypted}), which are deleted anyway. @c Since Emacs 30. @vindex trash-directory If you want to trash a remote file into a remote trash directory, you -could configure the user option @code{trash-directory} to a +can configure the user option @code{trash-directory} to a connection-local value. @ifinfo @xref{Connection Variables, , , emacs}. @@ -5726,7 +5789,7 @@ is @file{@trampfn{ssh,news@@news.my.domain,/opt/news/etc}}, then: Use simplified syntax: If you always apply the default method (@pxref{Default Method}), you -could use the simplified @value{tramp} syntax (@pxref{Change file name +can use the simplified @value{tramp} syntax (@pxref{Change file name syntax}): @lisp @@ -6038,7 +6101,7 @@ the buffer is remote. See the optional arguments of How to save files when a remote host isn't reachable anymore? If the local machine Emacs is running on changes its network -integration, remote hosts could become unreachable. This happens for +integration, remote hosts could become unreachable. This happens, for example, if the local machine is moved between your office and your home without restarting Emacs. @@ -6058,9 +6121,9 @@ an unresponsive remote host could trigger @code{recentf} to connect that host again and again. If you find the cleanup disturbing, because the file names in -@code{recentf-list} are precious to you, you could add the following -two forms in your @file{~/.emacs} after loading the @code{tramp} and -@code{recentf} packages: +@code{recentf-list} are precious to you, you can add the following +two forms in your @file{~/.emacs} (after loading the @code{tramp} and +@code{recentf} packages): @vindex tramp-cleanup-connection-hook @vindex tramp-cleanup-all-connections-hook diff --git a/doc/misc/use-package.texi b/doc/misc/use-package.texi index da3deb081d9..0ac0341fdc7 100644 --- a/doc/misc/use-package.texi +++ b/doc/misc/use-package.texi @@ -1416,6 +1416,13 @@ for the same variable, as this risks having conflicting values in your use-package declaration and your @code{custom-file}, which can lead to problems that are both tricky and tedious to debug. +Also note that if you use @code{:custom} in a file that you +byte-compile, you could have some unexpected results if you later load +or @code{require} @file{use-package} (e.g., due to lazy loading): the +value of the corresponding user options could be reset back to their +initial values. We therefore recommend against byte-compiling files +that use @file{use-package} with @code{:custom} settings. + @node Faces @section Faces @cindex faces, setting diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index 795d7fad037..b2ead47d0bc 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -264,6 +264,10 @@ In the latter case, if @code{:columns} is non-@code{nil} and there's more elements in the sequence than there is in @code{:columns}, only the @code{:columns} first elements are displayed. +If the @code{:objects} list is empty (and no @code{:objects-function} is +defined), an empty vtable is created. In this case, a @code{:columns} +spec must be provided. + @item :objects-function It's often convenient to generate the objects dynamically (for instance, to make reversion work automatically). In that case, this @@ -295,6 +299,11 @@ The width of @var{n} @samp{x} characters in the table's face. @var{n} percent of the window's width. @end table +If no @code{width} is provided, the width is calculated based on the +column data (provided in the @code{:objects} list or through the +@code{:objects-function}) or, if there is no data, on the basis of the +window width. + @item min-width This uses the same format as @code{width}, but specifies the minimum width (and overrides @code{width} if @code{width} is smaller than this. @@ -576,6 +585,8 @@ index is out of range, @var{object} is prepended to @var{table} if the index is too small, or appended if it is too large. In this case, @var{before} is ignored. +If @var{table} is empty, @var{location} and @var{before} are ignored. + This also updates the displayed table. @end defun diff --git a/etc/AUTHORS b/etc/AUTHORS index 838d2127a7d..3f62ddb8834 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -303,10 +303,10 @@ Anders Waldenborg: changed emacsclient.c Andrea Corallo: wrote comp-common.el comp-cstr-tests.el comp-cstr.el comp-run.el comp-tests.el comp.c comp.el syncdoc-type-hierarchy.el -and changed pdumper.c lread.c bytecomp.el startup.el configure.ac +and changed pdumper.c lread.c bytecomp.el configure.ac startup.el loadup.el comp.h lisp.h cl-macs.el cl-preloaded.el comp-test-funcs.el subr.el Makefile.in data.c elisp-mode.el nadvice.el alloc.c byte-run.el - emacs.c lisp/Makefile.in advice.el and 100 other files + emacs.c lisp/Makefile.in advice.el and 101 other files André A. Gomes: changed ispell.el @@ -372,7 +372,7 @@ Andre Spiegel: changed vc.el vc-hooks.el vc-cvs.el vc-rcs.el vc-sccs.el parse-time.el startup.el tramp-vc.el vc-arch.el vc-mcvs.el vc-svn.el vcdiff viper-util.el -Andrés Ramírez: changed viper-cmd.el +Andrés Ramírez: changed viper-cmd.el viperCard.tex Andre Srinivasan: changed gnus-group.el gnus-sum.el gnus.texi message.el mm-decode.el mml.el nnmail.el @@ -776,6 +776,8 @@ Brendan Kehoe: changed hpux9.h Brendan O'Dea: changed em-unix.el woman.el +Brennan Vincent: changed eglot.el + Brent Goodrick: changed abbrev.el Brent Westbrook: changed eudcb-mailabbrev.el @@ -1736,7 +1738,7 @@ and co-wrote help-tests.el and changed xdisp.c display.texi w32.c msdos.c simple.el w32fns.c files.el fileio.c keyboard.c emacs.c configure.ac text.texi w32term.c dispnew.c frames.texi w32proc.c files.texi xfaces.c window.c - dispextern.h lisp.h and 1397 other files + dispextern.h lisp.h and 1398 other files Eliza Velasquez: changed server.el simple.el @@ -2885,8 +2887,8 @@ Jim Paris: changed process.c Jim Porter: changed eshell.texi esh-cmd.el esh-var.el esh-var-tests.el eshell-tests.el esh-proc.el esh-io.el esh-cmd-tests.el esh-util.el esh-arg.el esh-mode.el esh-proc-tests.el eshell-tests-helpers.el - tramp.el em-cmpl.el em-pred.el em-unix.el em-dirs.el eshell/eshell.el - em-cmpl-tests.el em-glob.el and 137 other files + tramp.el em-cmpl.el em-pred.el em-unix.el em-dirs.el em-glob.el + eshell/eshell.el em-cmpl-tests.el and 137 other files Jim Radford: changed gnus-start.el @@ -3145,6 +3147,8 @@ Jörg Bornemann: changed cmake-ts-mode.el Jorge A. Alfaro-Murillo: changed message.el +Jørgen Kvalsvik: changed c-ts-mode.el indent.erts + Jorgen Schäfer: wrote erc-autoaway.el erc-goodies.el erc-spelling.el and changed erc.el erc-track.el erc-backend.el erc-match.el misc.el erc-stamp.el erc-button.el erc-fill.el erc-members.el erc-truncate.el @@ -4118,7 +4122,7 @@ Matt Hodges: changed textmodes/table.el faces.el iswitchb.el simple.el Mattias Engdegård: changed byte-opt.el bytecomp.el bytecomp-tests.el fns.c subr.el rx.el lisp.h rx-tests.el lread.c searching.texi eval.c - bytecode.c print.c calc-tests.el progmodes/compile.el alloc.c + bytecode.c print.c alloc.c calc-tests.el progmodes/compile.el fns-tests.el macroexp.el subr-tests.el cconv.el data.c and 789 other files @@ -4419,7 +4423,7 @@ Morgan Smith: changed image-dired.el doc-view.el window.el esh-var-tests.el esh-var.el eshell.texi gnus-group-tests.el minibuffer-tests.el minibuffer.el url-vars.el vc-git.el -Morgan Willcock: changed tempo.el +Morgan Willcock: changed tempo.el electric.el ert-font-lock.el Moritz Maxeiner: changed commands.texi cus-start.el dispnew.c xdisp.c @@ -4897,7 +4901,7 @@ Peter Münster: changed image-dired.el gnus-delay.el gnus-demon.el Peter O'Gorman: changed configure.ac frame.h hpux10-20.h termhooks.h Peter Oliver: changed emacsclient.desktop emacsclient-mail.desktop - Makefile.in emacs-mail.desktop misc.texi server.el configure.ac + Makefile.in emacs-mail.desktop configure.ac misc.texi server.el dired-tests.el ediff-diff.el emacs.c emacs.desktop emacs.metainfo.xml emacsclient.1 perl-mode.el ruby-mode-tests.el vc-sccs.el wdired-tests.el @@ -5298,9 +5302,8 @@ Robert P. Goldman: changed org.texi ob-exp.el org.el ox-latex.el Robert Pluim: wrote nsm-tests.el and changed configure.ac process.c keymap.el blocks.awk custom.texi font.c network-stream-tests.el processes.texi emoji-zwj.awk ftfont.c - gtkutil.c process-tests.el unicode vc-git.el files.texi nsterm.m - terminal.c char-fold.el display.texi gnutls.el help.el - and 214 other files + gtkutil.c process-tests.el unicode vc-git.el display.texi files.texi + nsterm.m terminal.c char-fold.el gnutls.el help.el and 215 other files Robert Thorpe: changed cus-start.el indent.el rmail.texi @@ -5526,9 +5529,9 @@ Sean Sieger: changed emacs-lisp-intro.texi Sean Whitton: wrote em-elecslash.el em-extpipe-tests.el em-extpipe.el and changed vc-git.el project.el bindings.el server.el simple.el - vc-dispatcher.el vc.el eshell-tests.el eshell.texi subr-x.el window.el - .dir-locals.el cl-macs.el eshell-tests-helpers.el files.texi ftfont.c - startup.el subr.el term.el INSTALL authors.el and 32 other files + vc-dispatcher.el vc.el window.el eshell-tests.el eshell.texi subr-x.el + subr.el .dir-locals.el cl-macs.el eshell-tests-helpers.el files.texi + ftfont.c remember.el startup.el term.el INSTALL and 34 other files Sebastian Fieber: changed gnus-art.el mm-decode.el mm-view.el @@ -5716,10 +5719,10 @@ Sławomir Nowaczyk: changed emacs.py progmodes/python.el TUTORIAL.pl Spencer Baugh: wrote uniquify-tests.el which-func-tests.el and changed project.el minibuffer.el simple.el progmodes/grep.el vc-hg.el - data-tests.el flymake.el mini.texi startup.el uniquify.el which-func.el - alloc.c autorevert.el bindings.el casefiddle-tests.el casefiddle.c - comint.el crm.el dired-aux.el dired-x.el dired-x.texi - and 22 other files + data-tests.el flymake.el mini.texi minibuffer-tests.el startup.el + uniquify.el which-func.el alloc.c autorevert.el bindings.el + casefiddle-tests.el casefiddle.c comint.el crm.el dired-aux.el + dired-x.el and 22 other files Spencer Thomas: changed dabbrev.el emacsclient.c gnus.texi server.el unexcoff.c @@ -5749,7 +5752,7 @@ and co-wrote help-tests.el keymap-tests.el and changed image-dired.el efaq.texi package.el cperl-mode.el checkdoc.el subr.el help.el simple.el bookmark.el dired.el files.el dired-x.el gnus.texi browse-url.el erc.el keymap.c image-mode.el ediff-util.el - speedbar.el woman.el ffap.el and 1800 other files + speedbar.el woman.el eglot.el and 1801 other files Stefan Merten: co-wrote rst.el @@ -5799,11 +5802,11 @@ Stephen A. Wood: changed fortran.el Stephen Berman: wrote todo-mode-tests.el and co-wrote todo-mode.el visual-wrap.el -and changed wdired.el wid-edit.el todo-mode.texi wdired-tests.el +and changed wid-edit.el wdired.el todo-mode.texi wdired-tests.el diary-lib.el dired.el dired-tests.el doc-view.el files.el info.el minibuffer.el outline.el todo-test-1.todo widget.texi allout.el eww.el find-dired.el frames.texi hl-line.el ibuffer.el menu-bar.el - and 70 other files + and 71 other files Stephen C. Gilardi: changed configure.ac @@ -6086,6 +6089,8 @@ Thomas Riccardi: changed erc-backend.el Thomas Steffen: co-wrote deuglify.el +Thomas Voss: changed which-key.el + Thomas W Murphy: changed outline.el Thomas Wurgler: changed emacs-lock.el subr.el @@ -6323,7 +6328,7 @@ Ulrich Müller: changed configure.ac calc-units.el Makefile.in emacsclient-mail.desktop lib-src/Makefile.in src/Makefile.in version.el bindings.el doctor.el emacs.1 files.el gamegrid.el gud.el language/cyrillic.el server.el strings.texi ChgPane.c ChgSel.c HELLO - INSTALL XMakeAssoc.c and 53 other files + INSTALL XMakeAssoc.c and 54 other files Ulrich Neumerkel: changed xterm.c @@ -6564,6 +6569,9 @@ Xavier Maillard: changed gnus-faq.texi gnus-score.el mh-utils.el spam.el Xiaoyue Chen: changed esh-proc.el +Xie Qi: changed simple.el dired.el customize.texi display.texi + functions.texi keymap.el loading.texi progmodes/python.el xdisp.c + Xi Lu: changed etags.c htmlfontify.el ruby-mode.el CTAGS.good_crlf CTAGS.good_update Makefile TUTORIAL.cn crlf eww.el filesets.el man-tests.el man.el shortdoc.el tramp-sh.el @@ -6641,10 +6649,10 @@ and changed fontset.el message.el nnheader.el nnmail.el Your Name: changed configure.ac Yuan Fu: changed treesit.el treesit.c c-ts-mode.el parsing.texi - progmodes/python.el modes.texi treesit-tests.el js.el indent.erts + treesit-tests.el progmodes/python.el modes.texi js.el indent.erts treesit.h typescript-ts-mode.el c-ts-common.el css-mode.el - java-ts-mode.el print.c rust-ts-mode.el configure.ac sh-script.el - gdb-mi.el go-ts-mode.el lisp.h and 73 other files + java-ts-mode.el rust-ts-mode.el print.c sh-script.el configure.ac + go-ts-mode.el csharp-mode.el gdb-mi.el and 78 other files Yuanle Song: changed rng-xsd.el @@ -33,7 +33,7 @@ incorrectly in rare cases. --- ** New configuration option '--disable-gc-mark-trace'. -This disables the GC mark trace buffer for about 5 % better garbage +This disables the GC mark trace buffer for about 5% better garbage collection performance. Doing so may make it more difficult for Emacs developers to help finding GC-related bugs that you run into, which is why the mark trace buffer is enabled by default. @@ -86,6 +86,14 @@ different values for completion-affecting variables like applies for the styles configuration in 'completion-category-overrides' and 'completion-category-defaults'. +--- +*** Selected completion candidate is preserved across *Completions* updates. +When point is on a completion candidate in the *Completions* buffer +(because of 'minibuffer-next-completion' or for any other reason), point +will still be on that candidate after *Completions* is updated with a +new list of completions. The candidate is automatically deselected when +the *Completions* buffer is hidden. + ** Windows +++ @@ -137,9 +145,9 @@ It is equivalent to running ‘project-any-command’ with ‘find-file’. --- *** The MAYBE-PROMPT argument of 'project-current' can be a string. -When such value is used, the 'project-prompt' values are called with it -as the first argument. This is a way for the callers to indicate, for -example, the reason or the context why the project is asked for. +When such value is used, the 'project-prompter' is called with it as the +first argument. This is a way for the callers to indicate, for example, +the reason or the context why the project is asked for. ** Registers @@ -149,6 +157,11 @@ Killed buffers stored in a register using 'buffer-to-register' are automatically converted to a file-query value if the buffer was visiting a file. +** IDLWAVE has been moved to GNU ELPA. +The version bundled with Emacs is out-of-date, and is now marked as +obsolete. Use 'M-x list-packages' to install the 'idlwave' package from +GNU ELPA instead. + * Editing Changes in Emacs 31.1 @@ -164,10 +177,26 @@ pair with 'completing-read', and removes it from the translation table. *** Emacs now supports Unicode version 16.0. --- +*** New input method 'greek-polytonic'. +This input method has support for polytonic and archaic Greek +characters. + +--- *** New language-environment and input method for Tifinagh. The Tifinagh script is used to write the Berber languages. --- +*** New input methods for Northern Iroquoian languages. +Input methods are now implemented for Haudenosaunee languages in the +Northern Iroquoian language family: 'mohawk-postfix' (Mohawk +[Kanien’kéha / Onkwehonwehnéha]), 'oneida-postfix' (Oneida [Onʌyota:ká: +/ Ukwehuwehnéha]), 'cayuga-postfix' (Cayuga [Gayogo̱ho:nǫhnéha:ˀ]), +'onondaga-postfix' (Onondaga [Onųdaʔgegáʔ]), and 'seneca-postfix' +(Seneca [Onödowá’ga:’]). Additionally, there is a general-purpose +'haudenosaunee-postfix' input method to facilitate writing in the +orthographies of the five languages simultaneously. + +--- ** 'visual-wrap-prefix-mode' now supports variable-pitch fonts. When using 'visual-wrap-prefix-mode' in buffers with variable-pitch fonts, the wrapped text will now be lined up correctly so that it's @@ -206,9 +235,20 @@ Typing 'M-~' while saving some buffers means not to save the buffer and also to mark it as unmodified. This is an alternative way to mark a buffer as unmodified which doesn't require switching to that buffer. +** New minor mode 'delete-selection-local-mode'. +This mode sets 'delete-selection-mode' buffer-locally. This can be +useful for enabling or disabling the features of 'delete-selection-mode' +based on the state of the buffer, such as for the different states of +modal editing packages. + * Changes in Specialized Modes and Packages in Emacs 31.1 +** CL-Lib ++++ +*** 'cl-labels' now also accepts (FUNC EXP) bindings, like 'cl-flet'. +Such bindings make it possible to compute which function to bind to FUNC. + ** Whitespace --- @@ -236,6 +276,14 @@ It removes all the buttons in the specified region. ** Eshell --- +*** New interactive command 'eshell-clear'. +This command scrolls the screen so that only the current prompt is +visible, optionally erasing all the previous input/output as well. +Previously, the Eshell built-in command 'eshell/clear' supported this +(e.g., to call it via 'M-x'), but this new command behaves more +consistently if you have a partially-typed command at the Eshell prompt. + +--- *** New user option 'eshell-command-async-buffer'. This option lets you tell 'eshell-command' how to respond if its output buffer is already in use by another invocation of 'eshell-command', much @@ -257,6 +305,12 @@ where to send the standard error output. See the "(eshell) Entry Points" node in the Eshell manual for more details. +++ +*** You can now loop over ranges of integers with the Eshell 'for' command. +When passing a range like 'BEGIN..END' to the Eshell 'for' command, +Eshell will now iterate over each integer between BEGIN and END, not +including END. + ++++ *** Conditional statements in Eshell now use an 'else' keyword. Eshell now prefers the following form when writing conditionals: @@ -276,6 +330,12 @@ By passing '-t' or '--timeout', you can specify a maximum time to wait for the processes to exit. Additionally, you can now wait for external processes by passing their PIDs. +--- +*** New hook 'eshell-after-initialize-hook'. +This hook runs after an Eshell session has been fully initialized, +immediately before running 'eshell-post-command-hook' for the first +time. + ** SHR +++ @@ -311,6 +371,13 @@ will now automatically turn on 'visual-wrap-prefix-mode' in addition to near window edge and the continuation lines are indented using prefixes computed from surrounding context. +--- +*** New user option 'eww-guess-content-type-functions'. +The value is a list of functions that EWW should call to determine the +content-type of Web pages which don't have a valid 'Content-Type' +header. The default value is a function that considers a page with an +HTML 'doctype' declaration to have context-type "text/html". + ** CC mode +++ @@ -432,6 +499,19 @@ The host name for Kubernetes connections can be of kind used. This overrides the setting in 'tramp-kubernetes-namespace', if any. ++++ +*** Different proxies for the same destination host name can be specified. +A typical example are docker containers, which run on different hosts +under the same docker name. When the user option +'tramp-show-ad-hoc-proxies' is non-nil, such ad-hoc multi-hop file names +can be used in parallel. Example: on both remote hosts "host1" and +"host2" there is a docker container "name", respectively: + + /ssh:user1@host1|docker:name: + /ssh:user2@host2|docker:name: + +This feature is experimental. + ** Diff --- @@ -506,6 +586,20 @@ fontifying them, which can be slow for remote directories. Setting 'dired-check-symlinks' to nil disables these checks. Defaults to t, can be set as a connection-local variable. +--- +*** New user option 'dired-hide-details-hide-absolute-location'. +When Dired's 'dired-hide-details-mode' is enabled, also hide the +'default-directory' absolute location, typically displayed as the first +line in a Dired buffer. + +With 'dired-hide-details-hide-absolute-location': + + project: (100 GiB available) + +Without 'dired-hide-details-hide-absolute-location': + + /absolute/path/to/my/important/project: (100 GiB available) + ** Grep +++ @@ -524,6 +618,12 @@ functionality of the standard 'xref' commands in TeX buffers. You can restore the standard 'etags' backend with the 'M-x xref-etags-mode' toggle. +** BibTeX mode + +--- +*** New user option 'bibtex-entry-ask-for-key'. +When enabled, 'bibtex-entry' asks for a key. + ** Midnight mode --- @@ -551,6 +651,11 @@ instead. *** A new shortcut to navigate to previous menu. The hardcoded '^' shortcut gets you back to the previous menu. +--- +*** New user option 'tmm-shortcut-inside-entry'. +When non-nil, highlight the character shortcut in the menu entry's +string instead of preprending it and 'tmm-mid-prompt' to said entry. + ** Foldout --- @@ -568,6 +673,44 @@ a desktop notification when the song changes, using customized using the new user options 'mpc-notifications-title' and 'mpc-notifications-body'. +--- +*** New user option 'mpc-crossfade-time'. +When non-nil, MPC will crossfade between songs for the specified number +of seconds. Crossfading can be toggled using the command +'mpc-toggle-crossfade' or from the MPC menu. + +--- +*** New command 'mpc-describe-song'. +This command displays information about the currently playing song or +song at point in the MPC-Songs buffer. The list of tags to display can +be customized using the new user option 'mpc-song-viewer-tags' and the +appearance of the list with the new faces 'mpc-song-viewer-tag', +'mpc-song-viewer-value', and 'mpc-song-viewer-empty'. + +** VC + +--- +*** Using 'e' from Log View mode to modify change comments now works for Git. + +--- +*** New user option 'vc-allow-rewriting-published-history'. +Some VCS commands can change your copy of published change history +without warning. In VC we try to detect before that happens, and stop. +You can customize this option to permit rewriting history even though +Emacs thinks it is dangerous. + +--- +*** 'vc-clone' is now an interactive command. +When called interactively, 'vc-clone' now prompts for the remote +repository address, and the directory into which to clone the +repository. It tries to automatically determine the VC backend for +cloning, or prompts for that, too. + +--- +*** 'vc-clone' now accepts an optional argument OPEN-DIR. +When the argument is non-nil, the function switches to a buffer visiting +the directory into which the repository was cloned. + * New Modes and Packages in Emacs 31.1 @@ -595,9 +738,33 @@ All the characters that belong to the 'symbol' script (according to cc-compat.el, info-edit.el, meese.el, otodo-mode.el, rcompile.el, sup-mouse.el, terminal.el, vi.el, vip.el, ws-mode.el, and yow.el. ++++ +** 'if-let' and 'when-let' are now obsolete. +Use 'if-let*', 'when-let*' and 'and-let*' instead. + +This effectively obsoletes the old '(if-let (SYMBOL SOMETHING) ...)' +single binding syntax, which we'd kept only for backwards compatibility. + +--- +** The Eshell 'pwd' command now expands the directory name on all systems. +This ensures that user directories are properly expanded to their full +name. Previously, Eshell only did this for MS-Windows systems. To +restore the old behavior, you can set 'eshell-pwd-convert-function' to +'identity'. + * Lisp Changes in Emacs 31.1 +--- +** New function 'native-compile-directory'. +This function natively-compiles all Lisp files in a directory and in its +sub-directories, recursively, which were not already natively-compiled. + +--- +** New function 'color-blend'. +This function takes two RGB lists and optional ALPHA and returns an RGB +list whose elements are blended in linear space proportional to ALPHA. + +++ ** The 'defcustom' ':local' keyword can now be 'permanent-only'. This means that the variable's 'permanent-local' property is set to t, @@ -671,12 +838,14 @@ text "covered" by the overlay. +++ ** New macro 'cond*'. -The new macro 'cond*' is an alternative to 'pcase'. Like 'pcase', it -can be used to define several clauses, each one with its own condition; -the first clause that matches will cause its body to be evaluated. -'cond*' uses syntax that is different from that of 'pcase', which some -users might find less cryptic. See the Info node "(elisp) cond* Macro" -for details. +The new macro 'cond*' is an alternative to 'cond' and 'pcase'. +Like them, it can be used to define several clauses, each one with its +own condition; the first clause that matches will cause its body to be +evaluated. +'cond*' can use Pcase's pattern matching syntax and also provides +another pattern matching syntax that is different from that of 'pcase', +which some users might find less cryptic. +See the Info node "(elisp) cond* Macro" for details. --- ** New function 'shell-command-do-open'. @@ -685,6 +854,16 @@ This lets a Lisp program access the core functionality of the program, choosing the program according to the operating system's conventions. ++++ +** 'make-vtable' can create an empty vtable. +It is now possible to create a vtable without data, by leaving the +':objects' list empty, or by providing a ':objects-function' that +(initially) produces no data. In such a case, it is necessary to +provide a ':columns' spec, so that the number of columns and their +widths can be determined. Columns widths can be set explicitly, or they +will be calculated based on the window width. + + * Changes in Emacs 31.1 on Non-Free Operating Systems @@ -711,7 +890,32 @@ and later versions. --- ** Emacs on MS-Windows now supports drag-n-drop of text into a buffer. -This is in addition to drag-n-drop of files, that was already supported. +This is in addition to drag-n-drop of files, that was already +supported. As on X, the user options 'dnd-scroll-margin' and +'dnd-indicate-insertion-point' can be used to customize the process. + +--- +** Emacs on MS-Windows now supports color fonts. +On Windows 8.1 and later versions Emacs now uses DirectWrite to draw +text, which supports color fonts. This can be disabled by setting the +variable 'w32-inhibit-dwrite' to t. Also see 'w32-dwrite-available' and +'w32-dwrite-reinit' to check availability and to configure the +DirectWrite rendering parameters. + +To show color Emojis in Emacs, customize the default fontset to use a +color Emoji font installed on your system for the 'emoji' script. + ++++ +** Emacs on MS-Windows now supports 'yank-media'. +This command inserts clipboard data of different formats into the +current buffer, if the major mode supports it. (Support for +'yank-media' will be unavailable on MS-Windows if Emacs was configured +'--without-native-image-api'.) + +--- +** Images on MS-Windows now support the ':transform-smoothing' flag. +Transformed images are smoothed using the bilinear interpolation by +means of the GDI+ library. ---------------------------------------------------------------------- diff --git a/etc/NEWS.30 b/etc/NEWS.30 index c72a87787f3..fbc29206039 100644 --- a/etc/NEWS.30 +++ b/etc/NEWS.30 @@ -57,10 +57,10 @@ operating systems instead. --- ** New configuration option '--disable-gc-mark-trace'. -This disables the GC mark trace buffer for about 5 % better garbage +This disables the GC mark trace buffer for about 5% better garbage collection performance. Doing so may make it more difficult for Emacs developers to help finding GC-related bugs that you run into, which is -why it the mark trace buffer is enabled by default. +why the mark trace buffer is enabled by default. * Startup Changes in Emacs 30.1 @@ -1413,10 +1413,12 @@ method but "sudo" can be configured with user option +++ *** Direct asynchronous processes are indicated by a connection-local variable. If direct asynchronous processes shall be used, set the connection-local -variable 'tramp-direct-async-process' to a non-nil value. This has been -changed, in previous Emacs versions this was indicated by the now -deprecated connection property "direct-async-process". See the Tramp -manual "(tramp) Improving performance of asynchronous remote processes". +variable 'tramp-direct-async-process' to a non-nil value. In previous +Emacs versions this was indicated by the connection property +"direct-async-process". That connection property (though not connection +properties and 'tramp-connection-properties' in general) is now +deprecated. See the Tramp manual "(tramp) Improving performance of +asynchronous remote processes". --- *** Direct asynchronous processes use 'tramp-remote-path'. @@ -955,13 +955,13 @@ This sections contains features found in other official Emacs ports. Emacs 25 has support for xwidgets, a system to include WebKit widgets into an Emacs buffer. -They work on NS, but not very well. For example, trying to display a -xwidget in the "killed" state will make Emacs crash. This is because -the NS code has not been updated to keep with recent changes to the -X11 and GTK code. +They work on NS, but not very well. This is because the NS code has +not been updated to keep with recent changes to the X11 and GTK code. -Many features such as xwidget-webkit-edit-mode do not work correctly -on NS either. +Many features do not work correctly on NS, such as: + - xwidget-webkit-edit-mode + - xwidget-webkit-isearch-mode + - xwidget-webkit-browse-history. **** Respect 'frame-inhibit-implied-resize' When the variable 'frame-inhibit-implied-resize' is non-nil, frames diff --git a/etc/emacs.metainfo.xml b/etc/emacs.metainfo.xml index 80bbd690217..526fb5b0610 100644 --- a/etc/emacs.metainfo.xml +++ b/etc/emacs.metainfo.xml @@ -33,6 +33,8 @@ <url type="help">https://www.gnu.org/software/emacs/documentation.html</url> <url type="donation">https://my.fsf.org/donate/</url> <url type="contact">https://lists.gnu.org/mailman/listinfo/emacs-devel/</url> + <url type="vcs-browser">https://git.savannah.gnu.org/cgit/emacs.git</url> + <url type="contribute">https://www.gnu.org/software/emacs/manual/html_node/emacs/Contributing.html</url> <launchable type="desktop-id">emacs.desktop</launchable> <launchable type="service">emacs.service</launchable> <project_group>GNU</project_group> @@ -45,4 +47,8 @@ </screenshot> </screenshots> <update_contact>emacs-devel_AT_gnu.org</update_contact> + <branding> + <color type="primary" scheme_preference="light">#7f5ab6</color> + <color type="primary" scheme_preference="dark">#624195</color> + </branding> </component> diff --git a/etc/package-keyring.gpg b/etc/package-keyring.gpg Binary files differindex 563acbb16b6..f88d60b2457 100644 --- a/etc/package-keyring.gpg +++ b/etc/package-keyring.gpg diff --git a/etc/symbol-releases.eld b/etc/symbol-releases.eld index 85bc05ac2ef..bdf5858102e 100644 --- a/etc/symbol-releases.eld +++ b/etc/symbol-releases.eld @@ -18,6 +18,11 @@ ;; damaged. See ;; https://github.com/larsbrinkhoff/emacs-history/tree/sources/decuslib.com/decus/vax85b/gnuemax + ("24.4" fun set-transient-map) + ("22.1" fun version=) + ("22.1" fun version<) + ("22.1" fun version<=) + ("22.1" fun read-number) ("19.7" fun defsubst) ("19.34" fun make-directory) ("18.59" fun mark) diff --git a/etc/themes/adwaita-theme.el b/etc/themes/adwaita-theme.el index cea8f85c081..1c3c3b26752 100644 --- a/etc/themes/adwaita-theme.el +++ b/etc/themes/adwaita-theme.el @@ -105,4 +105,4 @@ default look of the Gnome 3 desktop." `(diff-added ((,class (:bold t :foreground "#4E9A06")))) `(diff-removed ((,class (:bold t :foreground "#F5666D")))))) -;;; adwaita-theme.el ends here +;;; adwaita-theme.el ends here diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el index b902f293ca0..820b4d397b5 100644 --- a/etc/themes/manoj-dark-theme.el +++ b/etc/themes/manoj-dark-theme.el @@ -37,7 +37,7 @@ ;; viewed, for example, the Gnus group buffer, consistent and logical ;; color choices are the only sane option. Gnus groups can be newa ;; (blueish) or mail (greenish), have states (large number of under -;; messages, normal, and empty). The large number unread groups have +;; messages, normal, and empty). The large number unread groups have ;; highest luminance (appear brighter), and the empty one have lower ;; luminance (appear grayer), but have the same chroma and saturation. ;; Sub states and group priorities are rendered using a color series @@ -704,4 +704,4 @@ jarring angry fruit salad look to reduce eye fatigue." (provide-theme 'manoj-dark) -;;; manoj-dark.el ends here +;;; manoj-dark-theme.el ends here diff --git a/etc/themes/misterioso-theme.el b/etc/themes/misterioso-theme.el index 75693b59016..6487356fbb1 100644 --- a/etc/themes/misterioso-theme.el +++ b/etc/themes/misterioso-theme.el @@ -134,4 +134,4 @@ (provide-theme 'misterioso) -;;; misterioso-theme.el ends here +;;; misterioso-theme.el ends here diff --git a/etc/themes/modus-operandi-deuteranopia-theme.el b/etc/themes/modus-operandi-deuteranopia-theme.el index 485a71e19b5..58b27b90a18 100644 --- a/etc/themes/modus-operandi-deuteranopia-theme.el +++ b/etc/themes/modus-operandi-deuteranopia-theme.el @@ -304,14 +304,16 @@ standard)." (date-common cyan) (date-deadline yellow-warmer) + (date-deadline-subtle red-faint) (date-event fg-alt) (date-holiday yellow-warmer) (date-holiday-other blue) (date-now fg-main) (date-range fg-alt) (date-scheduled yellow-cooler) + (date-scheduled-subtle yellow-faint) (date-weekday cyan) - (date-weekend yellow-faint) + (date-weekend magenta) ;;;; Line number mappings diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index 6fd2ddd57de..bd6d4b4c50b 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -301,15 +301,17 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Date mappings (date-common cyan) - (date-deadline red) + (date-deadline red-cooler) + (date-deadline-subtle red-faint) (date-event fg-alt) - (date-holiday red-cooler) + (date-holiday red) (date-holiday-other blue) (date-now fg-main) (date-range fg-alt) - (date-scheduled yellow-warmer) + (date-scheduled yellow) + (date-scheduled-subtle yellow-faint) (date-weekday cyan) - (date-weekend red-faint) + (date-weekend magenta) ;;;; Line number mappings diff --git a/etc/themes/modus-operandi-tinted-theme.el b/etc/themes/modus-operandi-tinted-theme.el index c901e834d15..a9be4374f80 100644 --- a/etc/themes/modus-operandi-tinted-theme.el +++ b/etc/themes/modus-operandi-tinted-theme.el @@ -301,15 +301,17 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Date mappings (date-common cyan) - (date-deadline red) + (date-deadline red-cooler) + (date-deadline-subtle red-faint) (date-event fg-alt) - (date-holiday red-cooler) + (date-holiday red) (date-holiday-other blue) (date-now fg-main) (date-range fg-alt) - (date-scheduled yellow-warmer) + (date-scheduled yellow) + (date-scheduled-subtle yellow-faint) (date-weekday cyan) - (date-weekend red-faint) + (date-weekend magenta) ;;;; Line number mappings diff --git a/etc/themes/modus-operandi-tritanopia-theme.el b/etc/themes/modus-operandi-tritanopia-theme.el index ae62198c4ed..c7460ba9054 100644 --- a/etc/themes/modus-operandi-tritanopia-theme.el +++ b/etc/themes/modus-operandi-tritanopia-theme.el @@ -304,14 +304,16 @@ standard)." (date-common cyan-cooler) (date-deadline red) + (date-deadline-subtle red-faint) (date-event fg-alt) (date-holiday red) (date-holiday-other cyan) (date-now fg-main) (date-range fg-alt) (date-scheduled magenta) + (date-scheduled-subtle magenta-faint) (date-weekday cyan) - (date-weekend red-faint) + (date-weekend magenta-warmer) ;;;; Line number mappings diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index 7950a3da39d..c2ffc6e3593 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -5,7 +5,7 @@ ;; Author: Protesilaos Stavrou <info@protesilaos.com> ;; Maintainer: Protesilaos Stavrou <info@protesilaos.com> ;; URL: https://github.com/protesilaos/modus-themes -;; Version: 4.5.0 +;; Version: 4.6.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -287,10 +287,14 @@ set this variable to a nil value." "Alias of `modus-themes-items'.") (defconst modus-themes-items - '( modus-operandi modus-vivendi - modus-operandi-tinted modus-vivendi-tinted - modus-operandi-deuteranopia modus-vivendi-deuteranopia - modus-operandi-tritanopia modus-vivendi-tritanopia) + '( modus-operandi + modus-operandi-tinted + modus-operandi-deuteranopia + modus-operandi-tritanopia + modus-vivendi + modus-vivendi-tinted + modus-vivendi-deuteranopia + modus-vivendi-tritanopia) "Symbols of the Modus themes.") (defcustom modus-themes-to-toggle '(modus-operandi modus-vivendi) @@ -308,18 +312,19 @@ the same as using the command `modus-themes-select'." :type `(choice (const :tag "No toggle" nil) (list :tag "Pick two themes to toggle between" - (choice :tag "Theme one of two" - ,@(mapcar (lambda (theme) - (list 'const theme)) - modus-themes-items)) - (choice :tag "Theme two of two" - ,@(mapcar (lambda (theme) - (list 'const theme)) - modus-themes-items)))) + (choice :tag "Theme one of two" ,@(mapcar (lambda (theme) (list 'const theme)) modus-themes-items)) + (choice :tag "Theme two of two" ,@(mapcar (lambda (theme) (list 'const theme)) modus-themes-items)))) :package-version '(modus-themes . "4.0.0") :version "30.1" - :set #'modus-themes--set-option - :initialize #'custom-initialize-default + :group 'modus-themes) + +(defcustom modus-themes-to-rotate modus-themes-items + "List of Modus themes to rotate among, per `modus-themes-rotate'." + :type `(repeat + (choice :tag "A theme among the `modus-themes-items'" + ,@(mapcar (lambda (theme) (list 'const theme)) modus-themes-items))) + :package-version '(modus-themes . "4.6.0") + :version "31.1" :group 'modus-themes) (defvaralias 'modus-themes-post-load-hook 'modus-themes-after-load-theme-hook) @@ -330,8 +335,6 @@ This is used by the command `modus-themes-toggle'." :type 'hook :package-version '(modus-themes . "4.0.0") :version "30.1" - :set #'modus-themes--set-option - :initialize #'custom-initialize-default :group 'modus-themes) (defvaralias 'modus-themes-slanted-constructs 'modus-themes-italic-constructs) @@ -1106,7 +1109,7 @@ With optional SUFFIX, return THEME-palette-SUFFIX as a symbol." "Return palette value of active Modus theme, else produce `user-error'. With optional OVERRIDES return palette value plus whatever overrides." - (if-let ((theme (modus-themes--current-theme))) + (if-let* ((theme (modus-themes--current-theme))) (if overrides (modus-themes--palette-value theme :overrides) (modus-themes--palette-value theme)) @@ -1182,13 +1185,15 @@ symbol, which is safe when used as a face attribute's value." ;;;; Commands +;;;;; Select a theme with completion + (defvar modus-themes--select-theme-history nil "Minibuffer history of `modus-themes--select-prompt'.") (defun modus-themes--annotate-theme (theme) "Return completion annotation for THEME." - (when-let ((symbol (intern-soft theme)) - (doc-string (get symbol 'theme-documentation))) + (when-let* ((symbol (intern-soft theme)) + (doc-string (get symbol 'theme-documentation))) (format " -- %s" (propertize (car (split-string doc-string "\\.")) 'face 'completions-annotations)))) @@ -1222,6 +1227,8 @@ Disable other themes per `modus-themes-disable-other-themes'." (interactive (list (modus-themes--select-prompt))) (modus-themes-load-theme theme)) +;;;;; Toggle between two themes + (defun modus-themes--toggle-theme-p () "Return non-nil if `modus-themes-to-toggle' are valid." (mapc @@ -1241,6 +1248,7 @@ practically the same as the `modus-themes-select' command). Run `modus-themes-after-load-theme-hook' after loading the theme. Disable other themes per `modus-themes-disable-other-themes'." + (declare (interactive-only t)) (interactive) (if-let* ((themes (modus-themes--toggle-theme-p)) (one (car themes)) @@ -1248,6 +1256,44 @@ Disable other themes per `modus-themes-disable-other-themes'." (modus-themes-load-theme (if (eq (car custom-enabled-themes) one) two one)) (modus-themes-load-theme (modus-themes--select-prompt)))) +;;;;; Rotate through a list of themes + +(defun modus-themes--rotate (themes) + "Rotate THEMES rightward such that the car is moved to the end." + (if (proper-list-p themes) + (let* ((index (seq-position themes (modus-themes--current-theme))) + (offset (1+ index))) + (append (nthcdr offset themes) (take offset themes))) + (error "The `%s' is not a list" themes))) + +(defun modus-themes--rotate-p (themes) + "Return a new theme among THEMES if it is possible to rotate to it." + (if-let* ((new-theme (car (modus-themes--rotate themes)))) + (if (eq new-theme (modus-themes--current-theme)) + (car (modus-themes--rotate-p (modus-themes--rotate themes))) + new-theme) + (error "Cannot determine a theme among `%s'" themes))) + +;;;###autoload +(defun modus-themes-rotate (themes) + "Rotate to the next theme among THEMES. +When called interactively THEMES is the value of `modus-themes-to-rotate'. + +If the current theme is already the next in line, then move to the one +after. Perform the rotation rightwards, such that the first element in +the list becomes the last. Do not modify THEMES in the process." + (interactive (list modus-themes-to-rotate)) + (unless (proper-list-p themes) + "This is not a list of themes: `%s'" themes) + (let ((candidate (modus-themes--rotate-p themes))) + (if (modus-themes--modus-p candidate) + (progn + (message "Rotating to `%s'" (propertize (symbol-name candidate) 'face 'success)) + (modus-themes-load-theme candidate)) + (user-error "`%s' is not part of the Modus collection" candidate)))) + +;;;;; Preview a theme palette + (defun modus-themes--list-colors-render (buffer theme &optional mappings &rest _) "Render colors in BUFFER from THEME for `modus-themes-list-colors'. Optional MAPPINGS changes the output to only list the semantic @@ -1741,12 +1787,12 @@ FG and BG are the main colors." `(all-the-icons-silver ((,c :foreground "gray50"))) `(all-the-icons-yellow ((,c :foreground ,yellow))) ;;;;; all-the-icons-dired - `(all-the-icons-dired-dir-face ((,c :foreground ,cyan-faint))) + `(all-the-icons-dired-dir-face ((,c :foreground ,accent-0))) ;;;;; all-the-icons-ibuffer - `(all-the-icons-ibuffer-dir-face ((,c :foreground ,cyan-faint))) - `(all-the-icons-ibuffer-file-face ((,c :foreground ,blue-faint))) - `(all-the-icons-ibuffer-mode-face ((,c :foreground ,cyan))) - `(all-the-icons-ibuffer-size-face ((,c :foreground ,cyan-cooler))) + `(all-the-icons-ibuffer-dir-face ((,c :foreground ,accent-0))) + `(all-the-icons-ibuffer-file-face ((,c :foreground ,docstring))) + `(all-the-icons-ibuffer-mode-face ((,c :foreground ,type))) + `(all-the-icons-ibuffer-size-face ((,c :foreground ,variable))) ;;;;; annotate `(annotate-annotation ((,c :inherit modus-themes-subtle-blue))) `(annotate-annotation-secondary ((,c :inherit modus-themes-subtle-magenta))) @@ -1942,7 +1988,7 @@ FG and BG are the main colors." `(company-scrollbar-bg ((,c :background ,bg-active))) `(company-scrollbar-fg ((,c :background ,fg-main))) `(company-template-field ((,c :background ,bg-active))) - `(company-tooltip ((,c :background ,bg-dim))) + `(company-tooltip ((,c :inherit modus-themes-fixed-pitch :background ,bg-dim))) `(company-tooltip-annotation ((,c :inherit completions-annotations))) `(company-tooltip-common ((,c :inherit company-echo-common))) `(company-tooltip-deprecated ((,c :inherit company-tooltip :strike-through t))) @@ -1978,7 +2024,7 @@ FG and BG are the main colors." `(corfu-current ((,c :inherit modus-themes-completion-selected))) `(corfu-bar ((,c :background ,fg-dim))) `(corfu-border ((,c :background ,bg-active))) - `(corfu-default ((,c :background ,bg-dim))) + `(corfu-default ((,c :inherit modus-themes-fixed-pitch :background ,bg-dim))) ;;;;; corfu-candidate-overlay `(corfu-candidate-overlay-face ((t :inherit shadow))) ;;;;; corfu-quick @@ -2269,8 +2315,10 @@ FG and BG are the main colors." `(elpher-gemini-heading2 ((,c :inherit modus-themes-heading-2))) `(elpher-gemini-heading3 ((,c :inherit modus-themes-heading-3))) ;;;;; embark + `(embark-collect-group-title ((,c :inherit bold :foreground ,name))) `(embark-keybinding ((,c :inherit modus-themes-key-binding))) - `(embark-collect-marked ((,c :inherit modus-themes-mark-sel))) + `(embark-keybinding-repeat ((,c :inherit bold))) + `(embark-selected ((,c :inherit modus-themes-mark-sel))) ;;;;; ement (ement.el) `(ement-room-fully-read-marker ((,c :inherit success))) `(ement-room-membership ((,c :inherit shadow))) @@ -2439,6 +2487,23 @@ FG and BG are the main colors." `(font-lock-type-face ((,c :inherit modus-themes-bold :foreground ,type))) `(font-lock-variable-name-face ((,c :foreground ,variable))) `(font-lock-warning-face ((,c :inherit modus-themes-bold :foreground ,warning))) +;;;;; forge + `(forge-dimmed ((,c :inherit shadow))) + `(forge-issue-completed ((,c :inherit shadow))) + `(forge-issue-open (( ))) + `(forge-issue-unplanned ((,c :inherit forge-dimmed :strike-through t))) + `(forge-post-author ((,c :inherit bold :foreground ,name))) + `(forge-post-date ((,c :inherit bold :foreground ,date-common))) + `(forge-pullreq-merged ((,c :foreground ,fg-alt))) + `(forge-pullreq-open ((,c :foreground ,info))) + `(forge-pullreq-rejected ((,c :foreground ,err :strike-through t))) + `(forge-topic-done (( ))) + `(forge-topic-pending ((,c :inherit italic))) + `(forge-topic-slug-completed ((,c :inherit forge-dimmed))) + `(forge-topic-slug-open ((,c :inherit forge-dimmed))) + `(forge-topic-slug-saved ((,c :inherit success))) + `(forge-topic-slug-unplanned ((,c :inherit forge-dimmed :strike-through t))) + `(forge-topic-unread ((,c :inherit bold))) ;;;;; geiser `(geiser-font-lock-autodoc-current-arg ((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument))) `(geiser-font-lock-autodoc-identifier ((,c :foreground ,docstring))) @@ -2562,6 +2627,9 @@ FG and BG are the main colors." `(golden-ratio-scroll-highlight-line-face ((,c :background ,bg-cyan-subtle :foreground ,fg-main))) ;;;;; helpful `(helpful-heading ((,c :inherit modus-themes-heading-1))) +;;;;; hexl-mode + `(hexl-address-region ((,c :foreground ,constant))) + `(hexl-ascii-region ((,c :foreground ,variable))) ;;;;; highlight region or ad-hoc regexp ;; HACK 2022-06-23: The :inverse-video prevents hl-line-mode from ;; overriding the background. Such an override really defeats the @@ -2620,6 +2688,11 @@ FG and BG are the main colors." `(hydra-face-pink ((,c :inherit bold :foreground ,magenta))) `(hydra-face-red ((,c :inherit bold :foreground ,red-faint))) `(hydra-face-teal ((,c :inherit bold :foreground ,cyan-cooler))) +;;;;; hyperbole + `(hbut-item-face ((,c :foreground ,info))) + `(hbut-face ((,c :inherit modus-themes-button))) + `(hbut-flash ((,c :background ,bg-search-replace))) + `(ibut-face ((,c :inherit button :background ,bg-link-symbolic :foreground ,fg-link-symbolic :underline ,underline-link-symbolic))) ;;;;; icomplete `(icomplete-first-match ((,c :inherit modus-themes-completion-match-0))) `(icomplete-selected-match ((,c :inherit modus-themes-completion-selected))) @@ -3128,14 +3201,14 @@ FG and BG are the main colors." `(nerd-icons-silver ((,c :foreground "gray50"))) `(nerd-icons-yellow ((,c :foreground ,yellow))) ;;;;; nerd-icons-completion - `(nerd-icons-completion-dir-face ((,c :foreground ,cyan-faint))) + `(nerd-icons-completion-dir-face ((,c :foreground ,accent-0))) ;;;;; nerd-icons-dired - `(nerd-icons-dired-dir-face ((,c :foreground ,cyan-faint))) + `(nerd-icons-dired-dir-face ((,c :foreground ,accent-0))) ;;;;; nerd-icons-ibuffer - `(nerd-icons-ibuffer-dir-face ((,c :foreground ,cyan-faint))) - `(nerd-icons-ibuffer-file-face ((,c :foreground ,blue-faint))) - `(nerd-icons-ibuffer-mode-face ((,c :foreground ,cyan))) - `(nerd-icons-ibuffer-size-face ((,c :foreground ,cyan-cooler))) + `(nerd-icons-ibuffer-dir-face ((,c :foreground ,accent-0))) + `(nerd-icons-ibuffer-file-face ((,c :foreground ,docstring))) + `(nerd-icons-ibuffer-mode-face ((,c :foreground ,type))) + `(nerd-icons-ibuffer-size-face ((,c :foreground ,variable))) ;;;;; neotree `(neo-banner-face ((,c :foreground ,accent-0))) `(neo-button-face ((,c :inherit button))) @@ -3273,7 +3346,7 @@ FG and BG are the main colors." `(org-headline-todo ((,c :inherit org-todo))) `(org-hide ((,c :foreground ,bg-main))) `(org-indent ((,c :inherit (fixed-pitch org-hide)))) - `(org-imminent-deadline ((,c :inherit modus-themes-bold :foreground ,date-deadline))) + `(org-imminent-deadline ((,c :inherit bold :foreground ,date-deadline))) `(org-latex-and-related ((,c :foreground ,type))) `(org-level-1 ((,c :inherit modus-themes-heading-1))) `(org-level-2 ((,c :inherit modus-themes-heading-2))) @@ -3292,9 +3365,9 @@ FG and BG are the main colors." `(org-priority ((,c :foreground ,prose-tag))) `(org-property-value ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-metadata-value))) `(org-quote ((,c :inherit org-block))) - `(org-scheduled ((,c :foreground ,date-scheduled))) - `(org-scheduled-previously ((,c :inherit org-scheduled))) - `(org-scheduled-today ((,c :inherit (modus-themes-bold org-scheduled)))) + `(org-scheduled ((,c :foreground ,date-scheduled-subtle))) + `(org-scheduled-previously ((,c :inherit (bold org-scheduled-today)))) + `(org-scheduled-today ((,c :foreground ,date-scheduled))) `(org-sexp-date ((,c :foreground ,date-common))) `(org-special-keyword ((,c :inherit org-drawer))) `(org-table ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-table))) @@ -3304,8 +3377,8 @@ FG and BG are the main colors." `(org-target ((,c :underline t))) `(org-time-grid ((,c :foreground ,fg-dim))) `(org-todo ((,c :foreground ,prose-todo))) - `(org-upcoming-deadline ((,c :foreground ,date-deadline))) - `(org-upcoming-distant-deadline ((,c :inherit org-upcoming-deadline))) + `(org-upcoming-deadline ((,c :foreground ,date-deadline-subtle))) + `(org-upcoming-distant-deadline ((,c :foreground ,fg-main))) `(org-verbatim ((,c :inherit modus-themes-prose-verbatim))) `(org-verse ((,c :inherit org-block))) `(org-warning ((,c :inherit warning))) diff --git a/etc/themes/modus-vivendi-deuteranopia-theme.el b/etc/themes/modus-vivendi-deuteranopia-theme.el index 815e2403e13..23b31186d15 100644 --- a/etc/themes/modus-vivendi-deuteranopia-theme.el +++ b/etc/themes/modus-vivendi-deuteranopia-theme.el @@ -72,7 +72,7 @@ standard)." (red "#ff5f59") (red-warmer "#ff6b55") - (red-cooler "#ff7f9f") + (red-cooler "#ff7f86") (red-faint "#ff9580") (red-intense "#ff5f5f") (green "#44bc44") @@ -304,14 +304,16 @@ standard)." (date-common cyan) (date-deadline yellow-warmer) + (date-deadline-subtle red-faint) (date-event fg-alt) (date-holiday yellow-warmer) (date-holiday-other blue) (date-now fg-main) (date-range fg-alt) (date-scheduled yellow-cooler) + (date-scheduled-subtle yellow-faint) (date-weekday cyan) - (date-weekend yellow-faint) + (date-weekend magenta) ;;;; Line number mappings diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index 8f56d0ca78e..216bb2a7201 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -70,7 +70,7 @@ which corresponds to a minimum contrast in relative luminance of (red "#ff5f59") (red-warmer "#ff6b55") - (red-cooler "#ff7f9f") + (red-cooler "#ff7f86") (red-faint "#ff9580") (red-intense "#ff5f5f") (green "#44bc44") @@ -301,15 +301,17 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Date mappings (date-common cyan) - (date-deadline red) + (date-deadline red-cooler) + (date-deadline-subtle red-faint) (date-event fg-alt) - (date-holiday red-cooler) + (date-holiday magenta-warmer) (date-holiday-other blue) (date-now fg-main) (date-range fg-alt) - (date-scheduled yellow-warmer) + (date-scheduled yellow-cooler) + (date-scheduled-subtle yellow-faint) (date-weekday cyan) - (date-weekend red-faint) + (date-weekend magenta) ;;;; Line number mappings diff --git a/etc/themes/modus-vivendi-tinted-theme.el b/etc/themes/modus-vivendi-tinted-theme.el index 55c1cd7d2d1..2bbec8aa844 100644 --- a/etc/themes/modus-vivendi-tinted-theme.el +++ b/etc/themes/modus-vivendi-tinted-theme.el @@ -70,7 +70,7 @@ which corresponds to a minimum contrast in relative luminance of (red "#ff5f59") (red-warmer "#ff6b55") - (red-cooler "#ff7f9f") + (red-cooler "#ff7f86") (red-faint "#ff9f80") (red-intense "#ff5f5f") (green "#44bc44") @@ -301,15 +301,17 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Date mappings (date-common cyan) - (date-deadline red) + (date-deadline red-cooler) + (date-deadline-subtle red-faint) (date-event fg-alt) - (date-holiday red-cooler) + (date-holiday magenta-warmer) (date-holiday-other blue) (date-now fg-main) (date-range fg-alt) - (date-scheduled yellow-warmer) + (date-scheduled yellow-cooler) + (date-scheduled-subtle yellow-faint) (date-weekday cyan) - (date-weekend red-faint) + (date-weekend magenta) ;;;; Line number mappings diff --git a/etc/themes/modus-vivendi-tritanopia-theme.el b/etc/themes/modus-vivendi-tritanopia-theme.el index f1bd65e97bc..d18a44b38db 100644 --- a/etc/themes/modus-vivendi-tritanopia-theme.el +++ b/etc/themes/modus-vivendi-tritanopia-theme.el @@ -72,7 +72,7 @@ standard)." (red "#ff5f59") (red-warmer "#ff6740") - (red-cooler "#ff6f9f") + (red-cooler "#ff7f86") (red-faint "#ff9070") (red-intense "#ff5f5f") (green "#44bc44") @@ -304,14 +304,16 @@ standard)." (date-common cyan-cooler) (date-deadline red) + (date-deadline-subtle red-faint) (date-event fg-alt) (date-holiday red-intense) (date-holiday-other cyan-warmer) (date-now fg-main) (date-range fg-alt) (date-scheduled magenta) + (date-scheduled-subtle magenta-faint) (date-weekday cyan) - (date-weekend red-faint) + (date-weekend magenta-warmer) ;;;; Line number mappings diff --git a/lib-src/etags.c b/lib-src/etags.c index a822a823a90..848d8ea73e3 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -7420,7 +7420,7 @@ regex_tag_multiline (void) /* Force explicit tag name, if a name is there. */ pfnote (name, true, buffer + linecharno, - charno - linecharno + 1, lineno, linecharno); + charno - linecharno, lineno, linecharno); if (debug) fprintf (stderr, "%s on %s:%"PRIdMAX": %s\n", diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index b492eb8f07c..4c0969492a0 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -532,7 +532,7 @@ This function can be added to `comint-preoutput-filter-functions'." (while (setq end (string-match ansi-color-control-seq-regexp string start)) (let ((esc-end (match-end 0))) ;; Colorize the old block from start to end using old face. - (when-let ((face (ansi-color--face-vec-face face-vec))) + (when-let* ((face (ansi-color--face-vec-face face-vec))) (put-text-property start end 'font-lock-face face string)) (push (substring string start end) result) @@ -550,7 +550,7 @@ This function can be added to `comint-preoutput-filter-functions'." (when (<= cur-pos esc-end) (string-to-number (match-string 1 string)))))))))) ;; if the rest of the string should have a face, put it there - (when-let ((face (ansi-color--face-vec-face face-vec))) + (when-let* ((face (ansi-color--face-vec-face face-vec))) (put-text-property start (length string) 'font-lock-face face string)) ;; save context, add the remainder of the string to the result @@ -597,7 +597,7 @@ code. It is usually stored as the car of the variable (bright (and ansi-color-bold-is-bright (aref basic-faces 1))) (faces nil)) - (when-let ((fg (car colors))) + (when-let* ((fg (car colors))) (push `(:foreground ,(or (ansi-color--code-as-hex fg) @@ -608,7 +608,7 @@ code. It is usually stored as the car of the variable (mod fg 8)) nil 'default))) faces)) - (when-let ((bg (cadr colors))) + (when-let* ((bg (cadr colors))) (push `(:background ,(or (ansi-color--code-as-hex bg) diff --git a/lisp/ansi-osc.el b/lisp/ansi-osc.el index 8dbaeb45132..6c647c879ad 100644 --- a/lisp/ansi-osc.el +++ b/lisp/ansi-osc.el @@ -84,7 +84,7 @@ located." pos1 (match-beginning 0)))) (setq ansi-osc--marker nil) (delete-region pos0 (point)) - (when-let ((fun (cdr (assoc-string code ansi-osc-handlers)))) + (when-let* ((fun (cdr (assoc-string code ansi-osc-handlers)))) (funcall fun code text))) (put-text-property pos0 end 'invisible t) (setq ansi-osc--marker (copy-marker pos0))))))) @@ -137,7 +137,7 @@ and `shell-dirtrack-mode'." (define-button-type 'ansi-osc-hyperlink 'keymap ansi-osc-hyperlink-map 'help-echo (lambda (_ buffer pos) - (when-let ((url (get-text-property pos 'browse-url-data buffer))) + (when-let* ((url (get-text-property pos 'browse-url-data buffer))) (format "mouse-2, C-c RET: Open %s" url)))) (defvar-local ansi-osc-hyperlink--state nil) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index bf9def681c3..978c07dfddc 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1075,7 +1075,7 @@ return nil. Otherwise point is returned." (while (and (not found) (not (eobp))) (forward-line 1) - (when-let ((descr (archive-get-descr t))) + (when-let* ((descr (archive-get-descr t))) (when (equal (archive--file-desc-ext-file-name descr) file) (setq found t)))) (if (not found) @@ -1097,7 +1097,7 @@ return nil. Otherwise point is returned." (beginning-of-line) (bobp))))) (archive-next-line n) - (when-let ((descr (archive-get-descr t))) + (when-let* ((descr (archive-get-descr t))) (let ((candidate (archive--file-desc-ext-file-name descr)) (buffer (current-buffer))) (when (and candidate diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el index dd93d414d5e..08abcf6b572 100644 --- a/lisp/auth-source-pass.el +++ b/lisp/auth-source-pass.el @@ -88,7 +88,7 @@ HOST, USER, PORT, REQUIRE, and MAX." (auth-source-pass-extra-query-keywords (auth-source-pass--build-result-many host port user require max)) (t - (when-let ((result (auth-source-pass--build-result host port user))) + (when-let* ((result (auth-source-pass--build-result host port user))) (list result))))) (defun auth-source-pass--build-result (hosts port user) @@ -220,7 +220,7 @@ CONTENTS is the contents of a password-store formatted file." (let ((lines (cdr (split-string contents "\n" t "[ \t]+")))) (seq-remove #'null (mapcar (lambda (line) - (when-let ((pos (seq-position line ?:))) + (when-let* ((pos (seq-position line ?:))) (cons (string-trim (substring line 0 pos)) (string-trim (substring line (1+ pos)))))) lines)))) @@ -291,7 +291,7 @@ HOSTS can be a string or a list of strings." (dolist (user (or users (list u))) (dolist (port (or ports (list p))) (dolist (e entries) - (when-let + (when-let* ((m (or (gethash e seen) (auth-source-pass--retrieve-parsed seen e (integerp port)))) ((equal host (plist-get m :host))) diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 557d360bc6a..1e0cde75583 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -2599,7 +2599,7 @@ by doing (clear-string STRING)." ;; Not sure why but it seems that there might be cases where the ;; minibuffer is not always properly reset later on, so undo ;; whatever we've done here (bug#11392). - (remove-hook 'after-change-functions + (remove-hook 'post-command-hook #'read-passwd--hide-password 'local) (kill-local-variable 'post-self-insert-hook) ;; And of course, don't keep the sensitive data around. diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 0fdab6ffc9f..8ffe7f07cee 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -370,6 +370,9 @@ buffer.") "Non-nil when file has been modified on the file system. This has been reported by a file notification event.") +(defvar-local auto-revert--last-time 0 ;; Epoch. + "The last time of buffer was reverted.") + (defvar auto-revert-debug nil "Use for debug messages.") @@ -640,10 +643,10 @@ will use an up-to-date value of `auto-revert-interval'." (defun auto-revert-notify-rm-watch () "Disable file notification for current buffer's associated file." - (when-let ((desc - ;; Don't disable notifications if this is an indirect buffer. - (and (null (buffer-base-buffer)) - auto-revert-notify-watch-descriptor))) + (when-let* ((desc + ;; Don't disable notifications if this is an indirect buffer. + (and (null (buffer-base-buffer)) + auto-revert-notify-watch-descriptor))) (setq auto-revert--buffer-by-watch-descriptor (assoc-delete-all desc auto-revert--buffer-by-watch-descriptor)) (ignore-errors @@ -749,13 +752,16 @@ system.") ;; Mark buffer modified. (setq auto-revert-notify-modified-p t) - ;; Revert the buffer now if we're not locked out. + ;; Lock out the buffer. (unless auto-revert--lockout-timer - (auto-revert-handler) (setq auto-revert--lockout-timer (run-with-timer auto-revert--lockout-interval nil - #'auto-revert--end-lockout buffer)))))))))) + #'auto-revert--end-lockout buffer)) + ;; Revert it when first entry or it was reverted intervals ago. + (when (> (float-time (time-since auto-revert--last-time)) + auto-revert--lockout-interval) + (auto-revert-handler)))))))))) (defun auto-revert--end-lockout (buffer) "End the lockout period after a notification. @@ -801,7 +807,8 @@ This is an internal function used by Auto-Revert Mode." #'buffer-stale--default-function) t)))) eob eoblist) - (setq auto-revert-notify-modified-p nil) + (setq auto-revert-notify-modified-p nil + auto-revert--last-time (current-time)) (when revert (when (and auto-revert-verbose (not (eq revert 'fast))) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 9bd15dde59d..6c617566cd7 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -480,7 +480,7 @@ When called interactively prompt for MARK; RET remove all marks." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (when-let ((entry (tabulated-list-get-entry))) + (when-let* ((entry (tabulated-list-get-entry))) (let ((xmarks (list (aref entry 0) (aref entry 2)))) (when (or (char-equal mark ?\r) (member (char-to-string mark) xmarks)) @@ -891,7 +891,7 @@ See more at `Buffer-menu-filter-predicate'." (declare-function project-root "project" (project)) (defun Buffer-menu-group-by-root (entry) (with-current-buffer (car entry) - (if-let ((project (project-current))) + (if-let* ((project (project-current))) (project-root project) default-directory))) diff --git a/lisp/calculator.el b/lisp/calculator.el index a9fe76259a8..0764a16370c 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -775,7 +775,7 @@ Defaults to 1." (or (nth 4 op) 1)) (defun calculator-add-operators (more-ops) - "This function handles operator addition. + "Handle operator addition. Adds MORE-OPS to `calculator-operator', called initially to handle `calculator-initial-operators' and `calculator-user-operators'." (let ((added-ops nil)) diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index f6fc7a8c162..e6d8b672413 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -214,7 +214,7 @@ This function is like `parse-time-string' except that it returns a Lisp timestamp when successful. See `decode-time' for the meaning of FORM." - (when-let ((time (parse-time-string date-string form))) + (when-let* ((time (parse-time-string date-string form))) (encode-time time))) (provide 'parse-time) diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el index 53256ba3a81..235e09d83c2 100644 --- a/lisp/cedet/pulse.el +++ b/lisp/cedet/pulse.el @@ -167,7 +167,7 @@ Optional argument FACE specifies the face to do the highlighting." (defun pulse-tick (colors stop-time) (if (time-less-p nil stop-time) - (when-let (color (elt colors pulse-momentary-iteration)) + (when-let* ((color (elt colors pulse-momentary-iteration))) (set-face-background 'pulse-highlight-face color) (setq pulse-momentary-iteration (1+ pulse-momentary-iteration))) (pulse-momentary-unhighlight))) diff --git a/lisp/color.el b/lisp/color.el index 79dced4e3d7..cdeaa97ee64 100644 --- a/lisp/color.el +++ b/lisp/color.el @@ -55,6 +55,7 @@ If FRAME cannot display COLOR, return nil." (let ((valmax (float (car (color-values "#ffffffffffff"))))) (mapcar (lambda (x) (/ x valmax)) (color-values color frame)))) +;;;###autoload (defun color-rgb-to-hex (red green blue &optional digits-per-component) "Return hexadecimal #RGB notation for the color specified by RED GREEN BLUE. RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive. @@ -75,6 +76,23 @@ components (e.g. \"#ffff1212ecec\")." (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color))))) +;;;###autoload +(defun color-blend (a b &optional alpha) + "Blend the two colors A and B in linear space with ALPHA. +A and B should be lists (RED GREEN BLUE), where each element is +between 0.0 and 1.0, inclusive. ALPHA controls the influence A +has on the result and should be between 0.0 and 1.0, inclusive. + +For instance: + + (color-blend \\='(1 0.5 1) \\='(0 0 0) 0.75) + => (0.75 0.375 0.75)" + (setq alpha (or alpha 0.5)) + (let (blend) + (dotimes (i 3) + (push (+ (* (nth i a) alpha) (* (nth i b) (- 1 alpha))) blend)) + (nreverse blend))) + (defun color-gradient (start stop step-number) "Return a list with STEP-NUMBER colors from START to STOP. The color list builds a color gradient starting at color START to @@ -446,7 +464,11 @@ See `color-desaturate-hsl'." Given a color defined in terms of hue, saturation, and luminance \(arguments H, S, and L), return a color that is PERCENT lighter. Returns a list (HUE SATURATION LUMINANCE)." - (list H S (color-clamp (+ L (* L (/ percent 100.0)))))) + (let ((p (/ percent 100.0))) + (if (> p 0.0) + (setq L (* L (- 1.0 p))) + (setq p (- (* L (abs p))))) + (list H S (color-clamp (+ L p))))) (defun color-lighten-name (name percent) "Make a color with a specified NAME lighter by PERCENT. diff --git a/lisp/comint.el b/lisp/comint.el index 4961c4e3226..4268fa8dad2 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -4111,7 +4111,7 @@ setting." (font-lock-flush)) (defun comint--fontify-input-ppss-flush-indirect (beg &rest rest) - (when-let ((buf (comint-indirect-buffer t))) + (when-let* ((buf (comint-indirect-buffer t))) (with-current-buffer buf (when (memq #'syntax-ppss-flush-cache before-change-functions) (apply #'syntax-ppss-flush-cache beg rest))))) @@ -4170,7 +4170,7 @@ function called, or nil, if no function was called (if BEG = END)." (text-property-not-all beg1 end 'field 'output) (text-property-any beg1 end 'field 'output)) end)) - (when-let ((fun (if is-output fun-output fun-input))) + (when-let* ((fun (if is-output fun-output fun-input))) (save-restriction (let ((beg2 beg1) (end2 end1)) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index d379b3a1fa6..4564812e8a9 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -380,11 +380,11 @@ candidates or if there are multiple matching completions and (prefix (substring string base))) (when last (setcdr last nil) - (when-let ((sorted (funcall sort-fn - (delete prefix (all-completions prefix all)))) - (common (try-completion prefix sorted)) - (lencom (length common)) - (suffixes sorted)) + (when-let* ((sorted (funcall sort-fn + (delete prefix (all-completions prefix all)))) + (common (try-completion prefix sorted)) + (lencom (length common)) + (suffixes sorted)) (unless (and (cdr suffixes) completion-preview-exact-match-only) ;; Remove the common prefix from each candidate. (while sorted @@ -398,8 +398,8 @@ candidates or if there are multiple matching completions and (and (consp res) (not (functionp res)) (seq-let (beg end table &rest plist) res - (or (when-let ((data (completion-preview--try-table - table beg end plist))) + (or (when-let* ((data (completion-preview--try-table + table beg end plist))) `(,(+ beg (length (car data))) ,end ,plist ,@data)) (unless (eq 'no (plist-get plist :exclusive)) ;; Return non-nil to exclude other capfs. @@ -411,7 +411,7 @@ candidates or if there are multiple matching completions and (run-hook-wrapped 'completion-at-point-functions #'completion-preview--capf-wrapper) - (when-let ((suffix (car suffixes))) + (when-let* ((suffix (car suffixes))) (set-text-properties 0 (length suffix) (list 'face (if (cdr suffixes) 'completion-preview diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index b25dbad5919..8eba4270bcb 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1075,7 +1075,7 @@ even if it doesn't match the type.) (defun setopt--set (variable value) (custom-load-symbol variable) ;; Check that the type is correct. - (when-let ((type (get variable 'custom-type))) + (when-let* ((type (get variable 'custom-type))) (unless (widget-apply (widget-convert type) :match value) (warn "Value `%S' for variable `%s' does not match its type \"%s\"" value variable type))) @@ -5927,7 +5927,7 @@ The appropriate types are: (defun custom-dirlocals-maybe-update-cons () "If focusing out from the first widget in a cons widget, update its value." - (when-let ((w (widget-at))) + (when-let* ((w (widget-at))) (when (widget-get w :custom-dirlocals-symbol) (widget-value-set (widget-get w :parent) (cons (widget-value w) "")) @@ -6018,7 +6018,7 @@ Moves point into the widget that holds the value." If at least an option doesn't validate, signals an error and moves point to the widget with the invalid value." (dolist (opt (custom-dirlocals-get-options)) - (when-let ((w (widget-apply opt :validate))) + (when-let* ((w (widget-apply opt :validate))) (goto-char (widget-get w :from)) (error "%s" (widget-get w :error)))) t) diff --git a/lisp/custom.el b/lisp/custom.el index 1eb6bb7d64d..63d2eea4d94 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1362,7 +1362,7 @@ Return t if THEME was successfully loaded, nil otherwise." t)))) (t (error "Unable to load theme `%s'" theme)))) - (when-let ((obs (get theme 'byte-obsolete-info))) + (when-let* ((obs (get theme 'byte-obsolete-info))) (display-warning 'initialization (format "The `%s' theme is obsolete%s" theme diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el index 7b6cbb78cef..bbe6a64b626 100644 --- a/lisp/dabbrev.el +++ b/lisp/dabbrev.el @@ -464,8 +464,21 @@ direction of search to backward if set non-nil. See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion]." (interactive "*P") - (let (abbrev record-case-pattern - expansion old direction (orig-point (point))) + ;; There are three possible sources of the expansion, which we need to + ;; check in a specific order: + (let ((buf (cond ((window-minibuffer-p) + ;; If we invoked dabbrev-expand in the minibuffer, + ;; this is the buffer from which we entered the + ;; minibuffer. + (window-buffer (get-mru-window))) + ;; Otherwise, if we found the expansion in another + ;; buffer, use that buffer for further expansions. + (dabbrev--last-buffer-found dabbrev--last-buffer-found) + ;; Otherwise, use the buffer where we invoked + ;; dabbrev-expand. + (t (current-buffer)))) + abbrev record-case-pattern expansion old direction + (orig-point (point))) ;; abbrev -- the abbrev to expand ;; expansion -- the expansion found (eventually) or nil until then ;; old -- the text currently in the buffer @@ -480,6 +493,7 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion]." (point))))) ;; Find a different expansion for the same abbrev as last time. (progn + (setq dabbrev--last-buffer-found nil) (setq abbrev dabbrev--last-abbreviation) (setq old dabbrev--last-expansion) (setq direction dabbrev--last-direction)) @@ -488,7 +502,14 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion]." (if (and (eq (preceding-char) ?\s) (markerp dabbrev--last-abbrev-location) (marker-position dabbrev--last-abbrev-location) - (= (point) (1+ dabbrev--last-abbrev-location))) + ;; Comparing with point only makes sense in the buffer + ;; where we called dabbrev-expand, but if that differs + ;; from the buffer containing the expansion, we want to + ;; get the next word in the latter buffer, so we skip + ;; the comparison. + (if (eq buf (current-buffer)) + (= (point) (1+ dabbrev--last-abbrev-location)) + t)) (progn ;; The "abbrev" to expand is just the space. (setq abbrev " ") @@ -549,29 +570,43 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion]." (if old " further" "") abbrev)) (t (if (not (or (eq dabbrev--last-buffer dabbrev--last-buffer-found) - (minibuffer-window-active-p (selected-window)))) + ;; If we are in the minibuffer and an expansion has + ;; been found but dabbrev--last-buffer-found is not + ;; yet set, we need to set it now. + (and dabbrev--last-buffer-found + (minibuffer-window-active-p (selected-window))))) (progn (when (buffer-name dabbrev--last-buffer) (message "Expansion found in `%s'" (buffer-name dabbrev--last-buffer))) (setq dabbrev--last-buffer-found dabbrev--last-buffer)) (message nil)) - (if (and (or (eq (current-buffer) dabbrev--last-buffer) - (null dabbrev--last-buffer) - (buffer-live-p dabbrev--last-buffer)) - (numberp dabbrev--last-expansion-location) - (and (> dabbrev--last-expansion-location (point)))) - (setq dabbrev--last-expansion-location - (copy-marker dabbrev--last-expansion-location))) + ;; To get correct further expansions we have to be sure to use the + ;; buffer containing the already found expansions. + (when dabbrev--last-buffer-found + (setq buf dabbrev--last-buffer-found)) + ;; If the buffer where we called dabbrev-expand differs from the + ;; buffer containing the expansion, make sure copy-marker is + ;; called in the latter buffer. + (with-current-buffer buf + (if (and (or (eq (current-buffer) dabbrev--last-buffer) + (null dabbrev--last-buffer) + (buffer-live-p dabbrev--last-buffer)) + (numberp dabbrev--last-expansion-location) + (and (> dabbrev--last-expansion-location (point)))) + (setq dabbrev--last-expansion-location + (copy-marker dabbrev--last-expansion-location)))) ;; Success: stick it in and return. (setq buffer-undo-list (cons orig-point buffer-undo-list)) (setq expansion (dabbrev--substitute-expansion old abbrev expansion record-case-pattern)) - ;; Save state for re-expand. - (setq dabbrev--last-expansion expansion) - (setq dabbrev--last-abbreviation abbrev) - (setq dabbrev--last-abbrev-location (point-marker)))))) + ;; Save state for re-expand (making sure it's the state of the + ;; buffer containing the already found expansions). + (with-current-buffer buf + (setq dabbrev--last-expansion expansion) + (setq dabbrev--last-abbreviation abbrev) + (setq dabbrev--last-abbrev-location (point-marker))))))) ;;---------------------------------------------------------------- ;; Local functions diff --git a/lisp/delsel.el b/lisp/delsel.el index df99a56d7bc..18d889ab4c8 100644 --- a/lisp/delsel.el +++ b/lisp/delsel.el @@ -95,6 +95,24 @@ information on adapting behavior of commands in Delete Selection mode." (remove-hook 'pre-command-hook 'delete-selection-pre-hook) (add-hook 'pre-command-hook 'delete-selection-pre-hook))) +;;;###autoload +(define-minor-mode delete-selection-local-mode + "Toggle `delete-selection-mode' only in this buffer. + +For compatibility with features and packages that are aware of +`delete-selection-mode', this local mode sets the variable +`delete-selection-mode' in the current buffer as needed." + :global nil :group 'editing-basics + :variable (buffer-local-value 'delete-selection-mode (current-buffer)) + (cond + ((eq delete-selection-mode (default-value 'delete-selection-mode)) + (kill-local-variable 'delete-selection-mode)) + ((not (default-value 'delete-selection-mode)) + ;; Locally enabled, but globally disabled. + (delete-selection-mode 1) ; Setup the hooks. + (setq-default delete-selection-mode nil) ; But keep it globally disabled. + ))) + (defvar delsel--replace-text-or-position nil) ;;;###autoload diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 524a6474cd4..1f8b79f5258 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -673,10 +673,10 @@ The character information includes: (if display (format "terminal code %s" display) "not encodable for terminal")))))) - ,@(when-let ((composition-name - (and composition-string - (eq (aref char-script-table char) 'emoji) - (emoji-describe composition-string)))) + ,@(when-let* ((composition-name + (and composition-string + (eq (aref char-script-table char) 'emoji) + (emoji-describe composition-string)))) (list (list "composition name" composition-name))) ,@(let ((face (if (not (or disp-vector composition)) diff --git a/lisp/desktop.el b/lisp/desktop.el index 06f0bbb946e..3ca684efb49 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -699,7 +699,7 @@ DIRNAME omitted or nil means use `desktop-dirname'." (defun desktop--emacs-pid-running-p (pid) "Return non-nil if an Emacs process whose ID is PID might still be running." - (when-let ((attr (process-attributes pid))) + (when-let* ((attr (process-attributes pid))) (let ((proc-cmd (alist-get 'comm attr)) (my-cmd (file-name-nondirectory (car command-line-args))) (case-fold-search t)) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 98cf09945da..1b78b2e2925 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -218,7 +218,7 @@ toggle between those two." ;;; Menu bindings -(when-let ((menu (lookup-key dired-mode-map [menu-bar]))) +(when-let* ((menu (lookup-key dired-mode-map [menu-bar]))) (easy-menu-add-item menu '("Operate") ["Find Files" dired-do-find-marked-files :help "Find current or marked files"] diff --git a/lisp/dired.el b/lisp/dired.el index 2bf5a221f4e..f79a2220bea 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -387,6 +387,12 @@ new Dired buffers." :version "24.4" :group 'dired) +(defcustom dired-hide-details-hide-absolute-location nil + "Non-nil means `dired-hide-details-mode' hides directory absolute location." + :type 'boolean + :version "31.1" + :group 'dired) + (defcustom dired-always-read-filesystem nil "Non-nil means revert buffers visiting files before searching them. By default, commands like `dired-mark-files-containing-regexp' will @@ -855,7 +861,7 @@ Set it to nil for remote directories, which suffer from a slow connection." (if (not (connection-local-value dired-check-symlinks)) (search-forward-regexp "\\(.+-> ?\\)\\(.+\\)" end t) - (when-let ((file (dired-file-name-at-point))) + (when-let* ((file (dired-file-name-at-point))) (let ((truename (ignore-errors (file-truename file)))) (and (or (not truename) (not (file-directory-p truename))) @@ -1735,11 +1741,11 @@ see `dired-use-ls-dired' for more details.") (executable-find "sh"))) (switch (if remotep "-c" shell-command-switch))) ;; Enable globstar - (when-let ((globstar dired-maybe-use-globstar) - (enable-it - (assoc-default - (file-truename sh) dired-enable-globstar-in-shell - (lambda (reg shell) (string-match reg shell))))) + (when-let* ((globstar dired-maybe-use-globstar) + (enable-it + (assoc-default + (file-truename sh) dired-enable-globstar-in-shell + (lambda (reg shell) (string-match reg shell))))) (setq script (format "%s; %s" enable-it script))) (unless (zerop @@ -1816,12 +1822,25 @@ see `dired-use-ls-dired' for more details.") (when (and (or hdr wildcard) (not (and (looking-at "^ \\(.*\\):$") (file-name-absolute-p (match-string 1))))) - ;; Note that dired-build-subdir-alist will replace the name - ;; by its expansion, so it does not matter whether what we insert - ;; here is fully expanded, but it should be absolute. - (insert " " (or (car-safe dir-wildcard) - (directory-file-name (file-name-directory dir))) - ":\n") + (let* ((dir-indent " ") + (dir-name (or (car-safe dir-wildcard) + (directory-file-name + (file-name-directory dir)))) + (dir-name-point (+ (point) (length dir-indent))) + (hideable-location + (and dired-hide-details-hide-absolute-location + (not (string-empty-p (file-name-nondirectory + dir-name)))))) + ;; Inserted directory name must be absolute, but keep in + ;; mind it may be replaced in some instances like in + ;; `dired-build-subdir-alist'. + (insert dir-indent dir-name ":\n") + (when hideable-location + (put-text-property + dir-name-point + (+ dir-name-point + (length (file-name-directory dir-name))) + 'invisible 'dired-hide-details-absolute-location))) (setq content-point (point))) (when wildcard ;; Insert "wildcard" line where "total" line would be for a full dir. @@ -1844,7 +1863,7 @@ see `dired-use-ls-dired' for more details.") ;; Replace "total" with "total used in directory" to ;; avoid confusion. (replace-match "total used in directory" nil nil nil 1)) - (if-let ((available (get-free-disk-space file))) + (if-let* ((available (get-free-disk-space file))) (cond ((eq dired-free-space 'separate) (end-of-line) @@ -2784,7 +2803,7 @@ Keybindings: (let ((point (window-point w))) (save-excursion (goto-char point) - (if-let ((f (dired-get-filename nil t))) + (if-let* ((f (dired-get-filename nil t))) `((dired-filename . ,f)) `((position . ,(point))))))))) (setq-local window-point-context-use-function @@ -2792,9 +2811,9 @@ Keybindings: (with-current-buffer (window-buffer w) (let ((point (window-point w))) (save-excursion - (if-let ((f (alist-get 'dired-filename context))) + (if-let* ((f (alist-get 'dired-filename context))) (dired-goto-file f) - (when-let ((p (alist-get 'position context))) + (when-let* ((p (alist-get 'position context))) (goto-char p))) (setq point (point))) (set-window-point w point))))) @@ -3257,8 +3276,9 @@ unchanged." When this minor mode is enabled, details such as file ownership and permissions are hidden from view. -See options: `dired-hide-details-hide-symlink-targets' and -`dired-hide-details-hide-information-lines'." +See options: `dired-hide-details-hide-symlink-targets', +`dired-hide-details-hide-information-lines' and +`dired-hide-details-hide-absolute-location'." :group 'dired (unless (derived-mode-p '(dired-mode wdired-mode)) (error "Not a Dired buffer")) @@ -3283,6 +3303,11 @@ See options: `dired-hide-details-hide-symlink-targets' and 'remove-from-invisibility-spec) 'dired-hide-details-information) (funcall (if (and dired-hide-details-mode + dired-hide-details-hide-absolute-location) + #'add-to-invisibility-spec + #'remove-from-invisibility-spec) + 'dired-hide-details-absolute-location) + (funcall (if (and dired-hide-details-mode dired-hide-details-hide-symlink-targets (not (derived-mode-p 'wdired-mode))) 'add-to-invisibility-spec @@ -3688,7 +3713,18 @@ instead of `dired-actual-switches'." (substring new-dir-name (match-end 0))) (expand-file-name new-dir-name)))) (delete-region (point) (match-end 1)) - (insert new-dir-name)) + (let ((new-dir-name-pos (point)) + (hideable-location + (and dired-hide-details-hide-absolute-location + (not (string-empty-p + (file-name-nondirectory new-dir-name)))))) + (insert new-dir-name) + (when hideable-location + (put-text-property + new-dir-name-pos + (+ new-dir-name-pos + (length (file-name-directory new-dir-name))) + 'invisible 'dired-hide-details-absolute-location)))) (setq count (1+ count)) ;; Undo any escaping of newlines and \ by dired-insert-directory. ;; Convert "n" preceded by odd number of \ to newline, and \\ to \. diff --git a/lisp/dnd.el b/lisp/dnd.el index 411f0d5774c..bf8d3908619 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -270,8 +270,8 @@ for it will be modified." ;; assigned their own handlers. (dolist (leftover urls) (setq return-value 'private) - (if-let ((handler (browse-url-select-handler leftover - 'internal))) + (if-let* ((handler (browse-url-select-handler leftover + 'internal))) (funcall handler leftover action) (dnd-insert-text window action leftover))) (or return-value 'private)))) diff --git a/lisp/dom.el b/lisp/dom.el index b329379fdc3..616778051bf 100644 --- a/lisp/dom.el +++ b/lisp/dom.el @@ -65,7 +65,7 @@ (defun dom-remove-attribute (node attribute) "Remove ATTRIBUTE from NODE." (setq node (dom-ensure-node node)) - (when-let ((old (assoc attribute (cadr node)))) + (when-let* ((old (assoc attribute (cadr node)))) (setcar (cdr node) (delq old (cadr node))))) (defmacro dom-attr (node attr) diff --git a/lisp/editorconfig.el b/lisp/editorconfig.el index c21e12559a6..fbc7a59d823 100644 --- a/lisp/editorconfig.el +++ b/lisp/editorconfig.el @@ -434,8 +434,18 @@ heuristic for those modes not found there." (let ((style (gethash 'indent_style props)) (size (gethash 'indent_size props)) (tab_width (gethash 'tab_width props))) - (when tab_width - (setq tab_width (string-to-number tab_width))) + (cond + (tab_width (setq tab_width (string-to-number tab_width))) + ;; The EditorConfig spec is excessively eager to set `tab-width' + ;; even when not explicitly requested (bug#73991). + ;; As a trade-off, we accept `indent_style=tab' as a good enough hint. + ((and (equal style "tab") (editorconfig-string-integer-p size)) + (setq tab_width (string-to-number size)))) + + ;; When users choose `indent_size=tab', they most likely prefer + ;; `indent_style=tab' as well. + (when (and (null style) (equal size "tab")) + (setq style "tab")) (setq size (cond ((editorconfig-string-integer-p size) diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 120972d6cd8..eddb006c500 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -33,7 +33,6 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'pcase)) -(eval-when-compile (require 'subr-x)) ; if-let (require 'find-func) (require 'help-mode) ; Define `help-function-def' button type. (require 'lisp-mode) @@ -202,6 +201,7 @@ frames where the source code location is known.") "+" #'backtrace-multi-line "-" #'backtrace-single-line "." #'backtrace-expand-ellipses + "C-]" #'abort-recursive-edit "<follow-link>" 'mouse-face "<mouse-2>" #'mouse-select-window diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index d8dbfa62bf9..0a89a33cbc3 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -483,7 +483,7 @@ There can be multiple entries for the same NAME if it has several aliases.") `(,fn ,name . ,optimized-rest))) ((guard (when for-effect - (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) + (if-let* ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors (eq tmp 'error-free))))) (byte-compile-log " %s called for effect; deleted" fn) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 29e7882c851..f058fc48cc7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5470,9 +5470,9 @@ FORM is used to provide location, `bytecomp--cus-function' and (setq byte-compile-current-group name)) ;; Check :local - (when-let ((val (and (eq fun 'custom-declare-variable) - (plist-get keyword-args :local))) - (_ (not (member val '(t 'permanent 'permanent-only))))) + (when-let* ((val (and (eq fun 'custom-declare-variable) + (plist-get keyword-args :local))) + (_ (not (member val '(t 'permanent 'permanent-only))))) (bytecomp--cus-warn form ":local keyword does not accept %S" val)))) (byte-compile-normal-call form)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b37f744b175..65bc2cb9173 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2247,15 +2247,35 @@ Like `cl-flet' but the definitions can refer to previous ones. . ,optimized-body)) ,retvar))))))) +(defun cl--self-tco-on-form (var form) + ;; Apply self-tco to the function returned by FORM, assuming that + ;; it will be bound to VAR. + (pcase form + (`(function (lambda ,fargs . ,ebody)) form + (pcase-let* ((`(,decls . ,body) (macroexp-parse-body ebody)) + (`(,ofargs . ,obody) (cl--self-tco var fargs body))) + `(function (lambda ,ofargs ,@decls . ,obody)))) + (`(let ,bindings ,form) + `(let ,bindings ,(cl--self-tco-on-form var form))) + (`(if ,cond ,exp1 ,exp2) + `(if ,cond ,(cl--self-tco-on-form var exp1) + ,(cl--self-tco-on-form var exp2))) + (`(oclosure--fix-type ,exp1 ,exp2) + `(oclosure--fix-type ,exp1 ,(cl--self-tco-on-form var exp2))) + (_ form))) + ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form either (FUNC EXP) +where EXP is a form that should return the function to bind to the +function name FUNC, or (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the -forms of the function body. FUNC is defined in any BODY, as well +forms of the function body. FUNC is in scope in any BODY or EXP, as well as FORM, so you can write recursive and mutually recursive -function definitions. See info node `(cl) Function Bindings' for -details. +function definitions, with the caveat that EXPs are evaluated in sequence +and you cannot call a FUNC before its EXP has been evaluated. +See info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -2273,18 +2293,16 @@ details. (unless (assq 'function newenv) (push (cons 'function #'cl--labels-convert) newenv)) ;; Perform self-tail call elimination. - (setq binds (mapcar - (lambda (bind) - (pcase-let* - ((`(,var ,sargs . ,sbody) bind) - (`(function (lambda ,fargs . ,ebody)) - (macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) - newenv)) - (`(,ofargs . ,obody) - (cl--self-tco var fargs ebody))) - `(,var (function (lambda ,ofargs . ,obody))))) - (nreverse binds))) - `(letrec ,binds + `(letrec ,(mapcar + (lambda (bind) + (pcase-let* ((`(,var ,sargs . ,sbody) bind)) + `(,var ,(cl--self-tco-on-form + var (macroexpand-all + (if (null sbody) + sargs ;A (FUNC EXP) definition. + `(cl-function (lambda ,sargs . ,sbody))) + newenv))))) + (nreverse binds)) . ,(macroexp-unprogn (macroexpand-all (macroexp-progn body) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index e9b94681a4b..78720949b67 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -510,13 +510,13 @@ comes from `comp-primitive-type-specifiers' or the function type declaration itself." (let ((kind 'declared) type-spec) - (when-let ((res (assoc function comp-primitive-type-specifiers))) + (when-let* ((res (assoc function comp-primitive-type-specifiers))) ;; Declared primitive (setf type-spec (cadr res))) (let ((f (and (symbolp function) (symbol-function function)))) (when (and f (null type-spec)) - (if-let ((delc-type (function-get function 'function-type))) + (if-let* ((delc-type (function-get function 'function-type))) ;; Declared Lisp function (setf type-spec delc-type) (when (native-comp-function-p f) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 3f70b42774f..e1350370750 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -89,10 +89,10 @@ Integer values are handled in the `range' slot.") "Return all non built-in type names currently defined." (let (res) (mapatoms (lambda (x) - (when-let ((class (cl-find-class x)) - ;; Ignore EIEIO classes as they can be - ;; redefined at runtime. - (gate (not (eq 'eieio--class (type-of class))))) + (when-let* ((class (cl-find-class x)) + ;; Ignore EIEIO classes as they can be + ;; redefined at runtime. + (gate (not (eq 'eieio--class (type-of class))))) (push x res))) obarray) res)) @@ -528,8 +528,8 @@ Return them as multiple value." `(with-comp-cstr-accessors (if (or (neg src1) (neg src2)) (setf (typeset ,dst) '(number)) - (when-let ((r1 (range ,src1)) - (r2 (range ,src2))) + (when-let* ((r1 (range ,src1)) + (r2 (range ,src2))) (let* ((l1 (comp-cstr-smallest-in-range r1)) (l2 (comp-cstr-smallest-in-range r2)) (h1 (comp-cstr-greatest-in-range r1)) @@ -620,7 +620,7 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (apply #'comp--cstr-union-homogeneous range dst srcs) (cl-return-from comp--cstr-union-1-no-mem dst)) @@ -805,7 +805,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (range dst) () (neg dst) nil) (cl-return-from comp-cstr-intersection-no-mem dst))) - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (if (eq res 'neg) (apply #'comp--cstr-union-homogeneous t dst srcs) (apply #'comp-cstr-intersection-homogeneous dst srcs)) @@ -917,7 +917,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (when (and (null (neg cstr)) (null (valset cstr)) (null (typeset cstr))) - (when-let (range (range cstr)) + (when-let* ((range (range cstr))) (let* ((low (caar range)) (high (cdar (last range)))) (unless (or (eq low '-) @@ -949,7 +949,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (or (null (typeset cstr)) (equal (typeset cstr) '(integer))))))) (t - (if-let ((pred (get type 'cl-deftype-satisfies))) + (if-let* ((pred (get type 'cl-deftype-satisfies))) (and (null (range cstr)) (null (neg cstr)) (if (null (typeset cstr)) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 3c7802c2ee0..b4f8b46b93a 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -370,8 +370,8 @@ Return the trampoline if found or nil otherwise." (memq subr-name native-comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p subr)) - (when-let ((trampoline (or (comp--trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) + (when-let* ((trampoline (or (comp--trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) (comp--install-trampoline subr-name trampoline))))) ;;;###autoload @@ -423,7 +423,7 @@ bytecode definition was not changed in the meantime)." (t (signal 'native-compiler-error (list "Not a file nor directory" file-or-dir))))) (dolist (file file-list) - (if-let ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) + (if-let* ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) ;; Most likely the byte-compiler has requested a deferred ;; compilation, so update `comp-files-queue' to reflect that. (unless (or (null load) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f72d23fee1a..da351e99d91 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -201,9 +201,9 @@ Useful to hook into pass checkers.") "Given FUNCTION return the corresponding `comp-constraint'." (when (symbolp function) (or (gethash function comp-primitive-func-cstr-h) - (when-let ((type (or (when-let ((f (comp--symbol-func-to-fun function))) - (comp-func-declared-type f)) - (function-get function 'function-type)))) + (when-let* ((type (or (when-let* ((f (comp--symbol-func-to-fun function))) + (comp-func-declared-type f)) + (function-get function 'function-type)))) (comp-type-spec-to-cstr type))))) ;; Keep it in sync with the `cl-deftype-satisfies' property set in @@ -617,7 +617,7 @@ In use by the back-end." (defun comp--function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (comp--symbol-func-to-fun f))) + (when-let* ((func (comp--symbol-func-to-fun f))) (comp-func-pure func)))) (defun comp--alloc-class-to-container (alloc-class) @@ -819,7 +819,7 @@ clashes." (defun comp--intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." - (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) + (when-let* ((byte-func (byte-to-native-lambda-byte-func obj))) (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop for form in (comp-ctxt-top-level-forms comp-ctxt) @@ -1705,7 +1705,7 @@ into the C code forwarding the compilation unit." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) (equal (comp-block-lap-addr bb) addr))) - (if-let ((pending (cl-find-if #'pred + (if-let* ((pending (cl-find-if #'pred (comp-limplify-pending-blocks comp-pass)))) (comp-block-name pending) (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) @@ -1882,9 +1882,9 @@ The assume is emitted at the beginning of the block BB." rhs))) (comp-block-insns bb)))) ((pred comp--arithm-cmp-fun-p) - (when-let ((kind (if negated - (comp--negate-arithm-cmp-fun kind) - kind))) + (when-let* ((kind (if negated + (comp--negate-arithm-cmp-fun kind) + kind))) (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) @@ -1900,10 +1900,10 @@ The assume is emitted at the beginning of the block BB." (defun comp--maybe-add-vmvar (op cmp-res insns-seq) "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." - (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) - (new-mvar (make--comp-mvar - :slot - (- (cl-incf (comp-func-vframe-size comp-func)))))) + (if-let* ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) + (new-mvar (make--comp-mvar + :slot + (- (cl-incf (comp-func-vframe-size comp-func)))))) (progn (push `(assume ,new-mvar ,op) (cdr insns-seq)) new-mvar) @@ -2139,14 +2139,14 @@ TARGET-BB-SYM is the symbol name of the target block." for bb being each hash-value of (comp-func-blocks comp-func) do (comp--loop-insn-in-block bb - (when-let ((match - (pcase insn - (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f lhs args))) - (`(,(pred comp--call-op-p) ,f . ,args) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f nil args)))))) + (when-let* ((match + (pcase insn + (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f lhs args))) + (`(,(pred comp--call-op-p) ,f . ,args) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f)) @@ -2340,14 +2340,14 @@ blocks." finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if #'comp-block-idom l))) + (if-let* ((p (cl-find-if #'comp-block-idom l))) p (signal 'native-ice '("can't find first preprocessed"))))) - (when-let ((blocks (comp-func-blocks comp-func)) - (entry (gethash 'entry blocks)) - ;; No point to go on if the only bb is 'entry'. - (bb0 (gethash 'bb_0 blocks))) + (when-let* ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the only bb is 'entry'. + (bb0 (gethash 'bb_0 blocks))) (cl-loop with rev-bb-list = (comp--collect-rev-post-order entry) with changed = t @@ -2450,7 +2450,7 @@ blocks." PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda (funcall pre-lambda bb)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) when (eq bb (comp-block-idom child)) @@ -2508,7 +2508,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (comp--ssa-rename-insn insn in-frame)) (setf (comp-block-final-frame bb) (copy-sequence in-frame)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) @@ -2668,7 +2668,7 @@ Return non-nil if the function is folded successfully." ;; should do basic block pruning in order to be sure that this ;; is not dead-code. This is now left to gcc, to be ;; implemented only if we want a reliable diagnostic here. - (let* ((f (if-let (f-in-ctxt (comp--symbol-func-to-fun f)) + (let* ((f (if-let* ((f-in-ctxt (comp--symbol-func-to-fun f))) ;; If the function is IN the compilation ctxt ;; and know to be pure. (comp-func-byte-func f-in-ctxt) @@ -2685,7 +2685,7 @@ Fold the call in case." (comp-cstr-imm-vld-p (car args))) (setf f (comp-cstr-imm (car args)) args (cdr args))) - (when-let ((cstr-f (comp--get-function-cstr f))) + (when-let* ((cstr-f (comp--get-function-cstr f))) (let ((cstr (comp-cstr-f-ret cstr-f))) (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. @@ -2968,14 +2968,14 @@ FUNCTION can be a function-name or byte compiled function." do (comp--loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn new-form))))))) (defun comp--call-optim (_) @@ -3643,12 +3643,8 @@ the deferred compilation mechanism." Search happens in `native-comp-eln-load-path'." (cl-loop with eln-filename = (comp-el-to-eln-rel-filename filename) - for dir in native-comp-eln-load-path - for f = (expand-file-name eln-filename - (expand-file-name comp-native-version-dir - (expand-file-name - dir - invocation-directory))) + for dir in (comp-eln-load-path-eff) + for f = (expand-file-name eln-filename dir) when (file-exists-p f) do (cl-return f))) @@ -3667,6 +3663,17 @@ the compilation was successful return the compiled function." (comp--native-compile function-or-file nil output)) ;;;###autoload +(defun native-compile-directory (directory) + "Native compile if necessary all the .el files present in DIRECTORY. +Each .el file is native-compiled if the corresponding .eln file is not +found in any directory mentioned in `native-comp-eln-load-path'. +The search within DIRECTORY is perfomed recursively." + (mapc (lambda (file) + (unless (comp-lookup-eln file) + (native-compile file))) + (directory-files-recursively directory ".+\\.el\\'"))) + +;;;###autoload (defun batch-native-compile (&optional for-tarball) "Perform batch native compilation of remaining command-line arguments. diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index 9495ad96a6c..0e4718f088d 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -31,28 +31,35 @@ ;; and, or, if, progn, let, let*, setq. ;; For regexp matching only, it can call string-match and match-string. -;;; ??? If a clause starts with a keyword, -;;; should the element after the keyword be treated in the usual way -;;; as a pattern? Currently `cond*-non-exit-clause-substance' explicitly -;;; prevents that by adding t at the front of its value. +;; ??? If a clause starts with a keyword, +;; should the element after the keyword be treated in the usual way +;; as a pattern? Currently `cond*-non-exit-clause-substance' explicitly +;; prevents that by adding t at the front of its value. ;;; Code: +(require 'cl-lib) ; for cl-assert + (defmacro cond* (&rest clauses) "Extended form of traditional Lisp `cond' construct. A `cond*' construct is a series of clauses, and a clause normally has the form (CONDITION BODY...). CONDITION can be a Lisp expression, as in `cond'. -Or it can be `(bind* BINDINGS...)' or `(match* PATTERN DATUM)'. +Or it can be one of `(pcase* PATTERN DATUM)', +`(bind* BINDINGS...)', or `(match* PATTERN DATUM)', + +`(pcase* PATTERN DATUM)' means to match DATUM against the +pattern PATTERN, using the same pattern syntax as `pcase'. +The condition counts as true if PATTERN matches DATUM. `(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*') for the body of the clause. As a condition, it counts as true if the first binding's value is non-nil. All the bindings are made unconditionally for whatever scope they cover. -`(match* PATTERN DATUM)' means to match DATUM against the pattern PATTERN -The condition counts as true if PATTERN matches DATUM. +`(match* PATTERN DATUM)' is an alternative to `pcase*' that uses another +syntax for its patterns, see `match*'. When a clause's condition is true, and it exits the `cond*' or is the last clause, the value of the last expression @@ -70,7 +77,7 @@ are passed along to the rest of the clauses in this `cond*' construct. \\[match*\\] for documentation of the patterns for use in `match*'." (cond*-convert clauses)) -(defmacro match* (pattern datum) +(defmacro match* (pattern _datum) "This specifies matching DATUM against PATTERN. It is not really a Lisp function, and it is meaningful only in the CONDITION of a `cond*' clause. @@ -133,7 +140,7 @@ ATOM (meaning any other kind of non-list not described above) \(constrain SYMBOL EXP) matches datum if the form EXP is true. EXP can refer to symbols bound earlier in the pattern." - (ignore datum) + ;; FIXME: `byte-compile-warn-x' is not necessarily defined here. (byte-compile-warn-x pattern "`match*' used other than as a `cond*' condition")) (defun cond*-non-exit-clause-p (clause) @@ -245,8 +252,8 @@ This is used for conditional exit clauses." ;; Then always go on to run the UNCONDIT-CLAUSES. (if true-exps `(let ((,init-gensym ,first-value)) -;;; ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES. -;;; as the doc string says, for uniformity with match*? +;;; ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES. +;;; as the doc string says, for uniformity with match*? (let* ,mod-bindings (when ,init-gensym . ,true-exps) @@ -262,6 +269,24 @@ This is used for conditional exit clauses." (let* ,mod-bindings (when ,init-gensym . ,true-exps))))))) + ((eq pat-type 'pcase*) + (if true-exps + (progn + (when uncondit-clauses + ;; FIXME: This happens in cases like + ;; (cond* ((match* `(,x . ,y) EXP) THEN :non-exit) + ;; (t ELSE)) + ;; where ELSE is supposed to run after THEN also (and + ;; with access to `x' and `y'). + (error ":non-exit not supported with `pcase*'")) + (cl-assert (or (null iffalse) rest)) + `(pcase ,(nth 2 condition) + (,(nth 1 condition) ,@true-exps) + (_ ,iffalse))) + (cl-assert (null iffalse)) + (cl-assert (null rest)) + `(pcase-let ((,(nth 1 condition) ,(nth 2 condition))) + (cond* . ,uncondit-clauses)))) ((eq pat-type 'match*) (cond*-match condition true-exps uncondit-clauses iffalse)) (t @@ -369,11 +394,11 @@ as in `cond*-condition'." ;; because they are all gensyms anyway. (if (cdr backtrack-aliases) (setq expression - `(let ,(mapcar 'cdr (cdr backtrack-aliases)) + `(let ,(mapcar #'cdr (cdr backtrack-aliases)) ,expression))) (if retrieve-value-swap-outs (setq expression - `(let ,(mapcar 'cadr retrieve-value-swap-outs) + `(let ,(mapcar #'cadr retrieve-value-swap-outs) ,expression))) ;; If we used a gensym, wrap on code to bind it. (if gensym @@ -397,8 +422,8 @@ This is used for the bindings specified explicitly in match* patterns." (defvar cond*-debug-pattern nil) -;;; ??? Structure type patterns not implemented yet. -;;; ??? Probably should optimize the `nth' calls in handling `list'. +;; ??? Structure type patterns not implemented yet. +;; ??? Probably should optimize the `nth' calls in handling `list'. (defun cond*-subpat (subpat cdr-ignore bindings inside-or backtrack-aliases data) "Generate code to match the subpattern within `match*'. @@ -486,7 +511,7 @@ whether SUBPAT (as well as the subpatterns that contain/precede it) matches," (unless (symbolp elt) (byte-compile-warn-x vars "Non-symbol %s given as name for matched substring" elt))) ;; Bind these variables to nil, before the pattern. - (setq bindings (nconc (mapcar 'list vars) bindings)) + (setq bindings (nconc (mapcar #'list vars) bindings)) ;; Make the expressions to set the variables. (setq setqs (mapcar (lambda (var) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index deebe5109bd..d09229ee890 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1803,12 +1803,21 @@ infinite loops when the code/environment contains a circular object.") (cl-defmethod edebug--match-&-spec-op ((_ (eql '&interpose)) cursor specs) "Compute the specs for `&interpose SPEC FUN ARGS...'. -Extracts the head of the data by matching it against SPEC, -and then matches the rest by calling (FUN HEAD PF ARGS...) -where PF is the parsing function which FUN can call exactly once, -passing it the specs that it needs to match. -Note that HEAD will always be a list, since specs are defined to match -a sequence of elements." +SPECS is a list (SPEC FUN ARGS...), where SPEC is an edebug +specification, FUN is the function from the &interpose form which +transforms the edebug spec, and the optional ARGS is a list of final +arguments to be supplied to FUN. + +Extracts the head of the data by matching it against SPEC, and then +matches the rest by calling (FUN HEAD PF ARGS...). PF is the parsing +function which FUN must call exactly once, passing it one argument, the +specs that it needs to match. FUN's value must be the value of this PF +call, which in turn will be the value of this function. + +Note that HEAD will always be a list, since specs is defined to match a +sequence of elements." + ;; Note: PF is called in FUN rather than in this function, so that it + ;; can use any dynamic bindings created there. (pcase-let* ((`(,spec ,fun . ,args) specs) (exps (edebug-cursor-expressions cursor)) @@ -1817,14 +1826,14 @@ a sequence of elements." (length (edebug-cursor-expressions cursor)))) (head (seq-subseq exps 0 consumed))) (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) - (apply fun `(,head - ,(lambda (newspecs) - ;; FIXME: What'd be the difference if we used - ;; `edebug-match-sublist', which is what - ;; `edebug-list-form-args' uses for the similar purpose - ;; when matching "normal" forms? - (append instrumented-head (edebug-match cursor newspecs))) - ,@args)))) + (apply fun head + (lambda (newspecs) + ;; FIXME: What'd be the difference if we used + ;; `edebug-match-sublist', which is what + ;; `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs))) + args))) (cl-defmethod edebug--match-&-spec-op ((_ (eql '¬)) cursor specs) ;; If any specs match, then fail @@ -3922,8 +3931,8 @@ be installed in `emacs-lisp-mode-map'.") (define-obsolete-variable-alias 'global-edebug-prefix 'edebug-global-prefix "28.1") (defvar edebug-global-prefix - (when-let ((binding - (car (where-is-internal 'Control-X-prefix (list global-map))))) + (when-let* ((binding + (car (where-is-internal 'Control-X-prefix (list global-map))))) (concat binding [?X])) "Prefix key for global edebug commands, available from any buffer.") @@ -4659,8 +4668,8 @@ instrumentation for, defaulting to all functions." functions))))) ;; Remove instrumentation. (dolist (symbol functions) - (when-let ((unwrapped - (edebug--unwrap*-symbol-function symbol))) + (when-let* ((unwrapped + (edebug--unwrap*-symbol-function symbol))) (edebug--strip-plist symbol) (defalias symbol unwrapped))) (message "Removed edebug instrumentation from %s" diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 74f5e21db7d..98d9a2d2f4f 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -769,10 +769,10 @@ dynamically set from ARGS." (let* ((slot (aref slots i)) (slot-name (eieio-slot-descriptor-name slot)) (initform (cl--slot-descriptor-initform slot))) - (unless (or (when-let ((initarg - (car (rassq slot-name - (eieio--class-initarg-tuples - this-class))))) + (unless (or (when-let* ((initarg + (car (rassq slot-name + (eieio--class-initarg-tuples + this-class))))) (plist-get initargs initarg)) ;; Those slots whose initform is constant already have ;; the right value set in the default-object. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index cd60f9f457f..8469440c982 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -395,8 +395,8 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(when-let ((testfile ,(or (macroexp-file-name) - buffer-file-name))) + `(when-let* ((testfile ,(or (macroexp-file-name) + buffer-file-name))) (let ((default-directory (file-name-directory testfile))) (file-truename (if (file-accessible-directory-p "resources/") diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index fa1b7a60a90..97aa233f6e2 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -328,8 +328,8 @@ DATA is displayed to the user and should state the reason for skipping." (unless (eql ,value ',default-value) (list :value ,value)) (unless (eql ,value ',default-value) - (when-let ((-explainer- - (ert--get-explainer ',fn-name))) + (when-let* ((-explainer- + (ert--get-explainer ',fn-name))) (list :explanation (apply -explainer- ,args))))) value) @@ -1352,10 +1352,10 @@ RESULT must be an `ert-test-result-with-condition'." (defun ert-test-location (test) "Return a string description the source location of TEST." - (when-let ((loc - (ignore-errors - (find-function-search-for-symbol - (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (when-let* ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) (let* ((buffer (car loc)) (point (cdr loc)) (file (file-relative-name (buffer-file-name buffer))) @@ -1548,11 +1548,11 @@ test packages depend on each other, it might be helpful.") "Write a JUnit test report, generated from STATS." ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format ;; https://llg.cubic.org/docs/junit/ - (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) - (test-file (symbol-file symbol 'ert--test)) - (test-report - (file-name-with-extension - (or ert-load-file-name test-file) "xml"))) + (when-let* ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name test-file) "xml"))) (with-temp-file test-report (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" @@ -2906,10 +2906,10 @@ write erts files." (setq end-before end-after start-after start-before)) ;; Update persistent specs. - (when-let ((point-char (assq 'point-char specs))) + (when-let* ((point-char (assq 'point-char specs))) (setq gen-specs (map-insert gen-specs 'point-char (cdr point-char)))) - (when-let ((code (cdr (assq 'code specs)))) + (when-let* ((code (cdr (assq 'code specs)))) (setq gen-specs (map-insert gen-specs 'code (car (read-from-string code))))) ;; Get the "after" strings. @@ -2917,12 +2917,12 @@ write erts files." (insert-buffer-substring file-buffer start-after end-after) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-after-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) ;; Get the expected "after" point. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (goto-char (point-min)) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)) @@ -2933,13 +2933,13 @@ write erts files." (insert-buffer-substring file-buffer start-before end-before) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-before-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) (goto-char (point-min)) ;; Place point in the specified place. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)))) (let ((code (cdr (assq 'code gen-specs)))) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index 847ef53a1cb..144b60a2c1d 100644 --- a/lisp/emacs-lisp/icons.el +++ b/lisp/emacs-lisp/icons.el @@ -119,7 +119,7 @@ If OBJECT is an icon, return the icon properties." (setq spec (icons--copy-spec spec)) ;; Let the Customize theme override. (unless inhibit-theme - (when-let ((theme-spec (cadr (car (get icon 'theme-icon))))) + (when-let* ((theme-spec (cadr (car (get icon 'theme-icon))))) (setq spec (icons--merge-spec (icons--copy-spec theme-spec) spec)))) ;; Inherit from the parent spec (recursively). (unless inhibit-inheritance @@ -149,15 +149,15 @@ If OBJECT is an icon, return the icon properties." ;; Go through all the variations in this section ;; and return the first one we can display. (dolist (icon (icon-spec-values type-spec)) - (when-let ((result - (icons--create type icon type-keywords))) + (when-let* ((result + (icons--create type icon type-keywords))) (throw 'found - (if-let ((face (plist-get type-keywords :face))) + (if-let* ((face (plist-get type-keywords :face))) (propertize result 'face face) result))))))))) (unless icon-string (error "Couldn't find any way to display the %s icon" name)) - (when-let ((help (plist-get keywords :help-echo))) + (when-let* ((help (plist-get keywords :help-echo))) (setq icon-string (propertize icon-string 'help-echo help))) (propertize icon-string 'rear-nonsticky t))))) @@ -200,18 +200,18 @@ present if the icon is represented by an image." " " 'display (let ((props (append - (if-let ((height (plist-get keywords :height))) + (if-let* ((height (plist-get keywords :height))) (list :height (if (eq height 'line) (window-default-line-height) height))) - (if-let ((width (plist-get keywords :width))) + (if-let* ((width (plist-get keywords :width))) (list :width (if (eq width 'font) (default-font-width) width))) '(:scale 1) - (if-let ((rotation (plist-get keywords :rotation))) + (if-let* ((rotation (plist-get keywords :rotation))) (list :rotation rotation)) - (if-let ((margin (plist-get keywords :margin))) + (if-let* ((margin (plist-get keywords :margin))) (list :margin margin)) (list :ascent (if (plist-member keywords :ascent) (plist-get keywords :ascent) @@ -219,10 +219,10 @@ present if the icon is represented by an image." (apply 'create-image file nil nil props)))))) (cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords) - (when-let ((font (and (display-multi-font-p) - ;; FIXME: This is not enough for ensuring - ;; display of color Emoji. - (car (internal-char-font nil ?🟠))))) + (when-let* ((font (and (display-multi-font-p) + ;; FIXME: This is not enough for ensuring + ;; display of color Emoji. + (car (internal-char-font nil ?🟠))))) (and (font-has-char-p font (aref icon 0)) icon))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 601cc7bf712..220bb5175ea 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1153,7 +1153,7 @@ is the buffer position of the start of the containing expression." (defun lisp--local-defform-body-p (state) "Return non-nil when at local definition body according to STATE. STATE is the `parse-partial-sexp' state for current position." - (when-let ((start-of-innermost-containing-list (nth 1 state))) + (when-let* ((start-of-innermost-containing-list (nth 1 state))) (let* ((parents (nth 9 state)) (first-cons-after (cdr parents)) (second-cons-after (cdr first-cons-after)) @@ -1171,11 +1171,11 @@ STATE is the `parse-partial-sexp' state for current position." (let (local-definitions-starting-point) (and (save-excursion (goto-char (1+ second-order-parent)) - (when-let ((head (ignore-errors - ;; FIXME: This does not distinguish - ;; between reading nil and a read error. - ;; We don't care but still, better fix this. - (read (current-buffer))))) + (when-let* ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* cl-symbol-macrolet)) ;; In what follows, we rely on (point) returning non-nil. diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 50e90cdf94c..6e843f741d8 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -295,7 +295,7 @@ expression, in which case we want to handle forms differently." (null (plist-get props :set)) (error nil))) ;; Propagate the :safe property to the loaddefs file. - ,@(when-let ((safe (plist-get props :safe))) + ,@(when-let* ((safe (plist-get props :safe))) `((put ',varname 'safe-local-variable ,safe)))))) ;; Extract theme properties. @@ -413,8 +413,8 @@ don't include." (save-excursion ;; Since we're "open-coding", we have to repeat more ;; complicated logic in `hack-local-variables'. - (when-let ((beg - (re-search-forward "read-symbol-shorthands: *" nil t))) + (when-let* ((beg + (re-search-forward "read-symbol-shorthands: *" nil t))) ;; `read-symbol-shorthands' alist ends with two parens. (let* ((end (re-search-forward ")[;\n\s]*)")) (commentless (replace-regexp-in-string @@ -499,7 +499,7 @@ don't include." (when (and autoload-compute-prefixes compute-prefixes) (with-demoted-errors "%S" - (when-let + (when-let* ((form (loaddefs-generate--compute-prefixes load-name))) ;; This output needs to always go in the main loaddefs.el, ;; regardless of `generated-autoload-file'. @@ -591,7 +591,7 @@ instead of just updating them with the new/changed autoloads." ;; we don't want to depend on whether Emacs was ;; built with or without modules support, nor ;; what is the suffix for the underlying OS. - (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) + (unless (string-match "\\.\\(elc\\|so\\|dll\\|dylib\\)" suf) (push suf tmp))) (concat "\\`[^=.].*" (regexp-opt tmp t) "\\'"))) (files (apply #'nconc diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index c923c29bbf7..71be928e30f 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -428,8 +428,8 @@ storage method to list." (tabulated-list-print t) (goto-char (point-min)) (when id - (when-let ((match - (text-property-search-forward 'tabulated-list-id id t))) + (when-let* ((match + (text-property-search-forward 'tabulated-list-id id t))) (goto-char (prop-match-beginning match)))))) (defun multisession-delete-value (id) @@ -456,7 +456,7 @@ storage method to list." (let* ((object (or ;; If the multisession variable already exists, use ;; it (so that we update it). - (if-let (sym (intern-soft (cdr id))) + (if-let* ((sym (intern-soft (cdr id)))) (and (boundp sym) (symbol-value sym)) nil) ;; Create a new object. diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 36df143a82a..ac9254c867a 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -584,7 +584,7 @@ of the piece of advice." ;;;###autoload (defmacro define-advice (symbol args &rest body) "Define an advice and add it to function named SYMBOL. -See `advice-add' and `add-function' for explanation on the +See `advice-add' and `add-function' for explanation of the arguments. If NAME is non-nil, the advice is named `SYMBOL@NAME' and installed with the name NAME; otherwise, the advice is anonymous. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index e168096e153..d30f616f6ea 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -63,71 +63,19 @@ (defconst package-vc--elpa-packages-version 1 "Version number of the package specification format understood by package-vc.") -(defconst package-vc--backend-type - `(choice :convert-widget - ,(lambda (widget) - (let (opts) - (dolist (be vc-handled-backends) - (when (or (vc-find-backend-function be 'clone) - (alist-get 'clone (get be 'vc-functions))) - (push (widget-convert (list 'const be)) opts))) - (widget-put widget :args opts)) - widget)) - "The type of VC backends that support cloning package VCS repositories.") - -(defcustom package-vc-heuristic-alist - `((,(rx bos "http" (? "s") "://" - (or (: (? "www.") "github.com" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "codeberg.org" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: (? "www.") "gitlab" (+ "." (+ alnum)) - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" - (or "r" "git") "/" - (+ (or alnum "-" "." "_")) (? "/"))) - (or (? "/") ".git") eos) - . Git) - (,(rx bos "http" (? "s") "://" - (or (: "hg.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Hg) - (,(rx bos "http" (? "s") "://" - (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Bzr)) - "Alist mapping repository URLs to VC backends. -`package-vc-install' consults this alist to determine the VC -backend from the repository URL when you call it without -specifying a backend. Each element of the alist has the form -\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of -the first association for which the URL of the repository matches -the URL-REGEXP of the association. If no match is found, -`package-vc-install' uses `package-vc-default-backend' instead." - :type `(alist :key-type (regexp :tag "Regular expression matching URLs") - :value-type ,package-vc--backend-type) - :version "29.1") +(define-obsolete-variable-alias + 'package-vc-heuristic-alist + 'vc-clone-heuristic-alist "31.1") (defcustom package-vc-default-backend 'Git "Default VC backend to use for cloning package repositories. `package-vc-install' uses this backend when you specify neither the backend nor a repository URL that's recognized via -`package-vc-heuristic-alist'. +`vc-clone-heuristic-alist'. The value must be a member of `vc-handled-backends' that supports the `clone' VC function." - :type package-vc--backend-type + :type vc-cloneable-backends-custom-type :version "29.1") (defcustom package-vc-register-as-project t @@ -247,8 +195,8 @@ This function is meant to be used as a hook for `package-read-archive-hook'." (car spec))) (setf (alist-get (intern archive) package-vc--archive-data-alist) (cdr spec)) - (when-let ((default-vc (plist-get (cdr spec) :default-vc)) - ((not (memq default-vc vc-handled-backends)))) + (when-let* ((default-vc (plist-get (cdr spec) :default-vc)) + ((not (memq default-vc vc-handled-backends)))) (warn "Archive `%S' expects missing VC backend %S" archive (plist-get (cdr spec) :default-vc))))))))) @@ -279,7 +227,7 @@ asynchronously." (defun package-vc--version (pkg) "Return the version number for the VC package PKG." (cl-assert (package-vc-p pkg)) - (if-let ((main-file (package-vc--main-file pkg))) + (if-let* ((main-file (package-vc--main-file pkg))) (with-temp-buffer (insert-file-contents main-file) (package-strip-rcs-id @@ -626,13 +574,6 @@ documentation and marking the package as installed." ""))) t)) -(defun package-vc--guess-backend (url) - "Guess the VC backend for URL. -This function will internally query `package-vc-heuristic-alist' -and return nil if it cannot reasonably guess." - (and url (alist-get url package-vc-heuristic-alist - nil nil #'string-match-p))) - (declare-function project-remember-projects-under "project" (dir &optional recursive)) (defun package-vc--clone (pkg-desc pkg-spec dir rev) @@ -646,7 +587,7 @@ attribute in PKG-SPEC." (unless (file-exists-p dir) (make-directory (file-name-directory dir) t) (let ((backend (or (plist-get pkg-spec :vc-backend) - (package-vc--guess-backend url) + (vc-guess-url-backend url) (plist-get (alist-get (package-desc-archive pkg-desc) package-vc--archive-data-alist nil nil #'string=) @@ -663,7 +604,7 @@ attribute in PKG-SPEC." ;; Check out the latest release if requested (when (eq rev :last-release) - (if-let ((release-rev (package-vc--release-rev pkg-desc))) + (if-let* ((release-rev (package-vc--release-rev pkg-desc))) (vc-retrieve-tag dir release-rev) (message "No release revision was found, continuing..."))))) @@ -753,7 +694,7 @@ VC packages that have already been installed." ;; pointing towards a repository, and use that as a backup (and-let* ((extras (package-desc-extras (cadr pkg))) (url (alist-get :url extras)) - ((package-vc--guess-backend url))))))) + ((vc-guess-url-backend url))))))) (not allow-url))) (defun package-vc--read-package-desc (prompt &optional installed) @@ -868,7 +809,7 @@ If PACKAGE is a string, it specifies the URL of the package repository. In this case, optional argument BACKEND specifies the VC backend to use for cloning the repository; if it's nil, this function tries to infer which backend to use according to -the value of `package-vc-heuristic-alist' and if that fails it +the value of `vc-clone-heuristic-alist' and if that fails it uses `package-vc-default-backend'. Optional argument NAME specifies the package name in this case; if it's nil, this package uses `file-name-base' on the URL to obtain the package @@ -917,7 +858,7 @@ installs takes precedence." (cdr package) rev)) ((and-let* (((stringp package)) - (backend (or backend (package-vc--guess-backend package)))) + (backend (or backend (vc-guess-url-backend package)))) (package-vc--unpack (package-desc-create :name (or name (intern (file-name-base package))) @@ -930,7 +871,7 @@ installs takes precedence." (or (package-vc--desc->spec (cadr desc)) (and-let* ((extras (package-desc-extras (cadr desc))) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" package)) rev))) @@ -958,7 +899,7 @@ for the last released version of the package." (let ((pkg-spec (or (package-vc--desc->spec pkg-desc) (and-let* ((extras (package-desc-extras pkg-desc)) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" (package-desc-name pkg-desc))))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 90d6150ed0b..af07ba44e28 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -858,22 +858,22 @@ byte-compilation of the new package to fail." (cl-remove-if-not #'stringp (mapcar #'car load-history))))) (dolist (file files) - (when-let ((library (package--library-stem - (file-relative-name file dir))) - (canonical (locate-library library nil effective-path)) - (truename (file-truename canonical)) - ;; Normally, all files in a package are compiled by - ;; now, but don't assume that. E.g. different - ;; versions can add or remove `no-byte-compile'. - (altname (if (string-suffix-p ".el" truename) - (replace-regexp-in-string - "\\.el\\'" ".elc" truename t) - (replace-regexp-in-string - "\\.elc\\'" ".el" truename t))) - (found (or (member truename history) - (and (not (string= altname truename)) - (member altname history)))) - (recent-index (length found))) + (when-let* ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil effective-path)) + (truename (file-truename canonical)) + ;; Normally, all files in a package are compiled by + ;; now, but don't assume that. E.g. different + ;; versions can add or remove `no-byte-compile'. + (altname (if (string-suffix-p ".el" truename) + (replace-regexp-in-string + "\\.el\\'" ".elc" truename t) + (replace-regexp-in-string + "\\.elc\\'" ".el" truename t))) + (found (or (member truename history) + (and (not (string= altname truename)) + (member altname history)))) + (recent-index (length found))) (unless (equal (file-name-base library) (format "%s-autoloads" (package-desc-name pkg-desc))) (push (cons (expand-file-name library dir) recent-index) result)))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 898d460c144..9812621d50e 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -84,14 +84,17 @@ (defun pcase--edebug-match-pat-args (head pf) ;; (cl-assert (null (cdr head))) (setq head (car head)) - (or (alist-get head '((quote sexp) - (or &rest pcase-PAT) - (and &rest pcase-PAT) - (guard form) - (pred &or ("not" pcase-FUN) pcase-FUN) - (app pcase-FUN pcase-PAT))) - (let ((me (pcase--get-macroexpander head))) - (funcall pf (and me (symbolp me) (edebug-get-spec me)))))) + (let ((specs + (or + (alist-get head '((quote sexp) + (or &rest pcase-PAT) + (and &rest pcase-PAT) + (guard form) + (pred &or ("not" pcase-FUN) pcase-FUN) + (app pcase-FUN pcase-PAT))) + (let ((me (pcase--get-macroexpander head))) + (and me (symbolp me) (edebug-get-spec me)))))) + (funcall pf specs))) (defun pcase--get-macroexpander (s) "Return the macroexpander for pcase pattern head S, or nil." diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 12346b3d285..e246e4211bb 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -491,8 +491,8 @@ the bounds of a region containing Lisp code to pretty-print." (cons (cond ((consp (cdr sexp)) (let ((head (car sexp))) - (if-let (((null (cddr sexp))) - (syntax-entry (assq head pp--quoting-syntaxes))) + (if-let* (((null (cddr sexp))) + (syntax-entry (assq head pp--quoting-syntaxes))) (progn (insert (cdr syntax-entry)) (pp--insert-lisp (cadr sexp))) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 3b4907b8f43..df825bd68c8 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -357,7 +357,9 @@ automatically killed, which means that in a such case ;; Flush BUFFER before making it available again, i.e. clear ;; its contents, remove all overlays and buffer-local ;; variables. Is it enough to safely reuse the buffer? - (let ((inhibit-read-only t)) + (let ((inhibit-read-only t) + ;; Avoid deactivating the region as side effect. + deactivate-mark) (erase-buffer)) (delete-all-overlays) (let (change-major-mode-hook) @@ -398,22 +400,25 @@ substring that does not include newlines." ;; Keeping a work buffer around is more efficient than creating a ;; new temporary buffer. (with-work-buffer - ;; If `display-line-numbers' is enabled in internal - ;; buffers (e.g. globally), it breaks width calculation - ;; (bug#59311). Disable `line-prefix' and `wrap-prefix', - ;; for the same reason. - (setq display-line-numbers nil - line-prefix nil wrap-prefix nil) (if buffer (setq-local face-remapping-alist (with-current-buffer buffer face-remapping-alist)) (kill-local-variable 'face-remapping-alist)) - (insert string) + ;; Avoid deactivating the region as side effect. + (let (deactivate-mark) + (insert string)) + ;; If `display-line-numbers' is enabled in internal + ;; buffers (e.g. globally), it breaks width calculation + ;; (bug#59311). Disable `line-prefix' and `wrap-prefix', + ;; for the same reason. + (add-text-properties + (point-min) (point-max) '(display-line-numbers-disable t)) ;; Prefer `remove-text-properties' to `propertize' to avoid ;; creating a new string on each call. (remove-text-properties (point-min) (point-max) '(line-prefix nil wrap-prefix nil)) + (setq line-prefix nil wrap-prefix nil) (car (buffer-text-pixel-size nil nil t))))) ;;;###autoload @@ -475,7 +480,7 @@ this defaults to the current buffer." (t disp))) ;; Remove any old instances. - (when-let ((old (assoc prop disp))) + (when-let* ((old (assoc prop disp))) (setq disp (delete old disp))) (setq disp (cons (list prop value) disp)) (when vector diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 30397137efb..eaf3c5cb561 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -492,8 +492,8 @@ changing `tabulated-list-sort-key'." (if groups (dolist (group groups) (insert (car group) ?\n) - (when-let ((saved-pt-new (tabulated-list-print-entries - (cdr group) sorter update entry-id))) + (when-let* ((saved-pt-new (tabulated-list-print-entries + (cdr group) sorter update entry-id))) (setq saved-pt saved-pt-new))) (setq saved-pt (tabulated-list-print-entries entries sorter update entry-id))) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index f6f2a8d87c0..166755e4dcc 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -407,7 +407,7 @@ This function returns a timer object which you can use in ;; Handle relative times like "2 hours 35 minutes". (when (stringp time) - (when-let ((secs (timer-duration time))) + (when-let* ((secs (timer-duration time))) (setq time (timer-relative-time nil secs)))) ;; Handle "11:23pm" and the like. Interpret it as meaning today diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index d58c6894c16..c4f14d7b4b2 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -45,7 +45,8 @@ getter formatter displayer - -numerical) + -numerical + -aligned) (defclass vtable () ((columns :initarg :columns :accessor vtable-columns) @@ -212,18 +213,12 @@ See info node `(vtable)Top' for vtable documentation." (funcall accessor face2) (plist-get face2 slot)))) (if (and col1 col2) - (vtable--color-blend col1 col2) + (apply #'color-rgb-to-hex + `(,@(color-blend (color-name-to-rgb col1) + (color-name-to-rgb col2)) + 2)) (or col1 col2)))) -;;; FIXME: This is probably not the right way to blend two colors, is -;;; it? -(defun vtable--color-blend (color1 color2) - (cl-destructuring-bind (r g b) - (mapcar (lambda (n) (* (/ n 2) 255.0)) - (cl-mapcar #'+ (color-name-to-rgb color1) - (color-name-to-rgb color2))) - (format "#%02X%02X%02X" r g b))) - ;;; Interface utility functions. (defun vtable-current-table () @@ -271,7 +266,7 @@ If TABLE is found, return the position of the start of the table. If it can't be found, return nil and don't move point." (let ((start (point))) (goto-char (point-min)) - (if-let ((match (text-property-search-forward 'vtable table t))) + (if-let* ((match (text-property-search-forward 'vtable table t))) (goto-char (prop-match-beginning match)) (goto-char start) nil))) @@ -279,7 +274,7 @@ If it can't be found, return nil and don't move point." (defun vtable-goto-column (column) "Go to COLUMN on the current line." (beginning-of-line) - (if-let ((match (text-property-search-forward 'vtable-column column t))) + (if-let* ((match (text-property-search-forward 'vtable-column column t))) (goto-char (prop-match-beginning match)) (end-of-line))) @@ -311,10 +306,10 @@ is signaled." ;; FIXME: If the table's buffer has no visible window, or if its ;; width has changed since the table was updated, the cache key will ;; not match and the object can't be updated. (Bug #69837). - (if-let ((line-number (seq-position (car (vtable--cache table)) old-object - (lambda (a b) - (equal (car a) b)))) - (line (elt (car (vtable--cache table)) line-number))) + (if-let* ((line-number (seq-position (car (vtable--cache table)) old-object + (lambda (a b) + (equal (car a) b)))) + (line (elt (car (vtable--cache table)) line-number))) (progn (setcar line object) (setcdr line (vtable--compute-cached-line table object)) @@ -368,86 +363,89 @@ end (if the index is too large) of the table. BEFORE is ignored in this case. This also updates the displayed table." - ;; FIXME: Inserting an object into an empty vtable currently isn't - ;; possible. `nconc' fails silently (twice), and `setcar' on the cache - ;; raises an error. + ;; If the vtable is empty, just add the object and regenerate the + ;; table. (if (null (vtable-objects table)) - (error "[vtable] Cannot insert object into empty vtable")) - ;; First insert into the objects. - (let ((pos (if location - (if (integerp location) - (prog1 - (nthcdr location (vtable-objects table)) - ;; Do not prepend if index is too large: - (setq before nil)) - (or (memq location (vtable-objects table)) - ;; Prepend if `location' is not found and - ;; `before' is non-nil: - (and before (vtable-objects table)))) - ;; If `location' is nil and `before' is non-nil, we - ;; prepend the new object. - (if before (vtable-objects table))))) - (if (or before ; If `before' is non-nil, `pos' should be, as well. - (and pos (integerp location))) - ;; Add the new object before. - (let ((old-object (car pos))) - (setcar pos object) - (setcdr pos (cons old-object (cdr pos)))) - ;; Otherwise, add the object after. - (if pos - ;; Splice the object into the list. - (setcdr pos (cons object (cdr pos))) - ;; Otherwise, append the object. - (nconc (vtable-objects table) (list object))))) - ;; Then adjust the cache and display. - (save-excursion - (vtable-goto-table table) - (let* ((cache (vtable--cache table)) - (inhibit-read-only t) - (keymap (get-text-property (point) 'keymap)) - (ellipsis (if (vtable-ellipsis table) - (propertize (truncate-string-ellipsis) - 'face (vtable-face table)) - "")) - (ellipsis-width (string-pixel-width ellipsis)) - (elem (if location ; This binding mirrors the binding of `pos' above. - (if (integerp location) - (nth location (car cache)) - (or (assq location (car cache)) - (and before (caar cache)))) - (if before (caar cache)))) - (pos (memq elem (car cache))) - (line (cons object (vtable--compute-cached-line table object)))) - (if (or before + (progn + (setf (vtable-objects table) (list object)) + (vtable--recompute-numerical table (vtable--compute-cached-line table object)) + (vtable-goto-table table) + (vtable-revert-command)) + ;; First insert into the objects. + (let ((pos (if location + (if (integerp location) + (prog1 + (nthcdr location (vtable-objects table)) + ;; Do not prepend if index is too large: + (setq before nil)) + (or (memq location (vtable-objects table)) + ;; Prepend if `location' is not found and + ;; `before' is non-nil: + (and before (vtable-objects table)))) + ;; If `location' is nil and `before' is non-nil, we + ;; prepend the new object. + (if before (vtable-objects table))))) + (if (or before ; If `before' is non-nil, `pos' should be, as well. (and pos (integerp location))) - ;; Add the new object before:. - (let ((old-line (car pos))) - (setcar pos line) - (setcdr pos (cons old-line (cdr pos))) - (unless (vtable-goto-object (car elem)) - (vtable-beginning-of-table))) + ;; Add the new object before. + (let ((old-object (car pos))) + (setcar pos object) + (setcdr pos (cons old-object (cdr pos)))) ;; Otherwise, add the object after. (if pos ;; Splice the object into the list. - (progn - (setcdr pos (cons line (cdr pos))) - (if (vtable-goto-object location) - (forward-line 1) ; Insert *after*. - (vtable-end-of-table))) + (setcdr pos (cons object (cdr pos))) ;; Otherwise, append the object. - (setcar cache (nconc (car cache) (list line))) - (vtable-end-of-table))) - (let ((start (point))) - ;; FIXME: We have to adjust colors in lines below this if we - ;; have :row-colors. - (vtable--insert-line table line 0 - (nth 1 cache) (vtable--spacer table) - ellipsis ellipsis-width) - (add-text-properties start (point) (list 'keymap keymap - 'vtable table))) - ;; We may have inserted a non-numerical value into a previously - ;; all-numerical table, so recompute. - (vtable--recompute-numerical table (cdr line))))) + (nconc (vtable-objects table) (list object))))) + ;; Then adjust the cache and display. + (save-excursion + (vtable-goto-table table) + (let* ((cache (vtable--cache table)) + (inhibit-read-only t) + (keymap (get-text-property (point) 'keymap)) + (ellipsis (if (vtable-ellipsis table) + (propertize (truncate-string-ellipsis) + 'face (vtable-face table)) + "")) + (ellipsis-width (string-pixel-width ellipsis)) + (elem (if location ; This binding mirrors the binding of `pos' above. + (if (integerp location) + (nth location (car cache)) + (or (assq location (car cache)) + (and before (caar cache)))) + (if before (caar cache)))) + (pos (memq elem (car cache))) + (line (cons object (vtable--compute-cached-line table object)))) + (if (or before + (and pos (integerp location))) + ;; Add the new object before:. + (let ((old-line (car pos))) + (setcar pos line) + (setcdr pos (cons old-line (cdr pos))) + (unless (vtable-goto-object (car elem)) + (vtable-beginning-of-table))) + ;; Otherwise, add the object after. + (if pos + ;; Splice the object into the list. + (progn + (setcdr pos (cons line (cdr pos))) + (if (vtable-goto-object location) + (forward-line 1) ; Insert *after*. + (vtable-end-of-table))) + ;; Otherwise, append the object. + (setcar cache (nconc (car cache) (list line))) + (vtable-end-of-table))) + (let ((start (point))) + ;; FIXME: We have to adjust colors in lines below this if we + ;; have :row-colors. + (vtable--insert-line table line 0 + (nth 1 cache) (vtable--spacer table) + ellipsis ellipsis-width) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line)))))) (defun vtable-column (table index) "Return the name of the INDEXth column in TABLE." @@ -470,7 +468,17 @@ This also updates the displayed table." (t (elt object index)))) -(defun vtable--compute-columns (table) +(defun vtable--compute-columns (table &optional recompute) + "Compute column specs for TABLE. +Set the `align', `-aligned' and `-numerical' properties of each column. +If the column contains only numerical data, set `-numerical' to t, +otherwise to nil. `-aligned' indicates whether the column has an +`align' property set by the user. If it does, `align' is not touched, +otherwise it is set to `right' for numeric columns and to `left' for +non-numeric columns. + +If RECOMPUTE is non-nil, do not set `-aligned'. This can be used to +recompute the column specs when the table data has changed." (let ((numerical (make-vector (length (vtable-columns table)) t)) (columns (vtable-columns table))) ;; First determine whether there are any all-numerical columns. @@ -481,11 +489,16 @@ This also updates the displayed table." table)) (setf (elt numerical index) nil))) (vtable-columns table))) + ;; Check if any columns have an explicit `align' property. + (unless recompute + (dolist (column (vtable-columns table)) + (when (vtable-column-align column) + (setf (vtable-column--aligned column) t)))) ;; Then fill in defaults. (seq-map-indexed (lambda (column index) ;; This is used when displaying. - (unless (vtable-column-align column) + (unless (vtable-column--aligned column) (setf (vtable-column-align column) (if (elt numerical index) 'right @@ -638,7 +651,7 @@ This also updates the displayed table." (insert "\n") (put-text-property start (point) 'vtable-object (car line)) (unless column-colors - (when-let ((row-colors (slot-value table '-cached-colors))) + (when-let* ((row-colors (slot-value table '-cached-colors))) (add-face-text-property start (point) (elt row-colors (mod line-number (length row-colors)))))))) @@ -810,7 +823,7 @@ If NEXT, do the next column." (setq recompute t))) line) (when recompute - (vtable--compute-columns table)))) + (vtable--compute-columns table t)))) (defun vtable--set-header-line (table widths spacer) (setq header-line-format @@ -850,32 +863,48 @@ If NEXT, do the next column." (error "Invalid spec: %s" spec)))) (defun vtable--compute-widths (table cache) - "Compute the display widths for TABLE." - (seq-into - (seq-map-indexed - (lambda (column index) - (let ((width - (or - ;; Explicit widths. - (and (vtable-column-width column) - (vtable--compute-width table (vtable-column-width column))) - ;; Compute based on the displayed widths of - ;; the data. - (seq-max (seq-map (lambda (elem) - (nth 1 (elt (cdr elem) index))) - cache))))) - ;; Let min-width/max-width specs have their say. - (when-let ((min-width (and (vtable-column-min-width column) - (vtable--compute-width - table (vtable-column-min-width column))))) - (setq width (max width min-width))) - (when-let ((max-width (and (vtable-column-max-width column) - (vtable--compute-width - table (vtable-column-max-width column))))) - (setq width (min width max-width))) - width)) - (vtable-columns table)) - 'vector)) + "Compute the display widths for TABLE. +CACHE is TABLE's cache data as returned by `vtable--compute-cache'." + (let* ((n-0cols 0) ; Count the number of zero-width columns. + (widths (seq-map-indexed + (lambda (column index) + (let ((width + (or + ;; Explicit widths. + (and (vtable-column-width column) + (vtable--compute-width table (vtable-column-width column))) + ;; If the vtable is empty and no explicit width is given, + ;; set its width to 0 and deal with it below. + (when (null cache) + (setq n-0cols (1+ n-0cols)) + 0) + ;; Otherwise, compute based on the displayed widths of the + ;; data. + (seq-max (seq-map (lambda (elem) + (nth 1 (elt (cdr elem) index))) + cache))))) + ;; Let min-width/max-width specs have their say. + (when-let* ((min-width (and (vtable-column-min-width column) + (vtable--compute-width + table (vtable-column-min-width column))))) + (setq width (max width min-width))) + (when-let* ((max-width (and (vtable-column-max-width column) + (vtable--compute-width + table (vtable-column-max-width column))))) + (setq width (min width max-width))) + width)) + (vtable-columns table)))) + ;; If there are any zero-width columns, divide the remaining window + ;; width evenly over them. + (when (> n-0cols 0) + (let* ((combined-width (apply #'+ widths)) + (default-width (/ (- (window-width nil t) combined-width) n-0cols))) + (setq widths (mapcar (lambda (width) + (if (zerop width) + default-width + width)) + widths)))) + (seq-into widths 'vector))) (defun vtable--compute-cache (table) (seq-map @@ -904,7 +933,7 @@ If NEXT, do the next column." (vtable-keymap table)) (copy-keymap vtable-map) vtable-map))) - (when-let ((actions (vtable-actions table))) + (when-let* ((actions (vtable-actions table))) (while actions (funcall (lambda (key binding) (keymap-set map key diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 68db33bfa68..b11e1ebeb70 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -285,7 +285,7 @@ entirely by setting `warning-suppress-types' or (unless buffer-name (setq buffer-name "*Warnings*")) (with-suppressed-warnings ((obsolete warning-level-aliases)) - (when-let ((new (cdr (assq level warning-level-aliases)))) + (when-let* ((new (cdr (assq level warning-level-aliases)))) (warn "Warning level `%s' is obsolete; use `%s' instead" level new) (setq level new))) (or (< (warning-numeric-level level) diff --git a/lisp/epa-file.el b/lisp/epa-file.el index 90cc91e99a0..ee0a665aa62 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -177,7 +177,7 @@ encryption is used." (nth 3 error))) (let ((exists (file-exists-p local-file))) (when exists - (if-let ((wrong-password (epa--wrong-password-p context))) + (if-let* ((wrong-password (epa--wrong-password-p context))) ;; Don't display the *error* buffer if we just ;; have a wrong password; let the later error ;; handler notify the user. diff --git a/lisp/epa.el b/lisp/epa.el index c29df18bb58..e7856f8463b 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -498,7 +498,7 @@ If SECRET is non-nil, list secret keys instead of public keys." (defun epa-show-key () "Show a key on the current line." (interactive) - (if-let ((key (get-text-property (point) 'epa-key))) + (if-let* ((key (get-text-property (point) 'epa-key))) (save-selected-window (epa--show-key key)) (error "No key on this line"))) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 16e8cae4733..e72fa036f17 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -605,7 +605,7 @@ escape hatch for inhibiting their transmission.") (concat "Unbreakable line encountered " "(Recover input with \\[erc-previous-command])")))) (goto-char upper)) - (when-let ((cmp (find-composition (point) (1+ (point))))) + (when-let* ((cmp (find-composition (point) (1+ (point))))) (if (= (car cmp) (point-min)) (goto-char (nth 1 cmp)) (goto-char (car cmp))))) @@ -1057,9 +1057,9 @@ Conditionally try to reconnect and take appropriate action." (setq erc--hidden-prompt-overlay nil))) (cl-defmethod erc--conceal-prompt () - (when-let (((null erc--hidden-prompt-overlay)) - (ov (make-overlay erc-insert-marker (1- erc-input-marker) - nil 'front-advance))) + (when-let* (((null erc--hidden-prompt-overlay)) + (ov (make-overlay erc-insert-marker (1- erc-input-marker) + nil 'front-advance))) (defvar erc-prompt-hidden) (overlay-put ov 'display erc-prompt-hidden) (setq erc--hidden-prompt-overlay ov))) @@ -2078,12 +2078,12 @@ like `erc-insert-modify-hook'.") (defvar erc-receive-query-display) (defvar erc-receive-query-display-defer) (if privp - (when-let ((erc-join-buffer - (or (and (not erc-receive-query-display-defer) - erc-receive-query-display) - (and erc-ensure-target-buffer-on-privmsg - (or erc-receive-query-display - erc-join-buffer))))) + (when-let* ((erc-join-buffer + (or (and (not erc-receive-query-display-defer) + erc-receive-query-display) + (and erc-ensure-target-buffer-on-privmsg + (or erc-receive-query-display + erc-join-buffer))))) (push `(erc-receive-query-display . ,(intern cmd)) erc--display-context) (setq buffer (erc--open-target nick))) @@ -2262,12 +2262,12 @@ primitive value." (if-let* ((table (or erc--isupport-params (erc-with-server-buffer erc--isupport-params))) (value (with-memoization (gethash key table) - (when-let ((v (assoc (symbol-name key) - (or erc-server-parameters - (erc-with-server-buffer + (when-let* ((v (assoc (symbol-name key) + (or erc-server-parameters + (erc-with-server-buffer erc-server-parameters))))) - (if-let ((val (cdr v)) - ((not (string-empty-p val)))) + (if-let* ((val (cdr v)) + ((not (string-empty-p val)))) (erc--parse-isupport-value val) '--empty--))))) (pcase value diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index c158b443b89..b4a94321947 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -462,18 +462,18 @@ retrieve it during buttonizing via (defun erc-button-add-nickname-buttons (entry) "Search through the buffer for nicknames, and add buttons." - (when-let ((form (nth 2 entry)) - ;; Spoof `form' slot of default legacy `nicknames' entry - ;; so `erc-button--extract-form' sees a function value. - (form (let ((erc-button-buttonize-nicks - (and erc-button-buttonize-nicks - erc-button--modify-nick-function))) - (erc-button--extract-form form))) - (oncep (if-let ((erc-button-highlight-nick-once) - (c (erc--check-msg-prop 'erc--cmd)) - ((memq c erc-button-highlight-nick-once))) - 1 0)) - (seen 0)) + (when-let* ((form (nth 2 entry)) + ;; Spoof `form' slot of default legacy `nicknames' entry + ;; so `erc-button--extract-form' sees a function value. + (form (let ((erc-button-buttonize-nicks + (and erc-button-buttonize-nicks + erc-button--modify-nick-function))) + (erc-button--extract-form form))) + (oncep (if-let* ((erc-button-highlight-nick-once) + (c (erc--check-msg-prop 'erc--cmd)) + ((memq c erc-button-highlight-nick-once))) + 1 0)) + (seen 0)) (goto-char (point-min)) (while-let (((or (zerop seen) (zerop oncep))) @@ -665,14 +665,14 @@ greater than `point-min' with a text property of `erc-callback'.") (p start)) (while (progn ;; Break out of current search context. - (when-let ((low (max (point-min) (1- (pos-bol)))) - (high (min (point-max) (1+ (pos-eol)))) - (prop (get-text-property p 'erc-callback)) - (q (if nextp - (text-property-not-all p high - 'erc-callback prop) - (funcall search-fn p 'erc-callback nil low))) - ((< low q high))) + (when-let* ((low (max (point-min) (1- (pos-bol)))) + (high (min (point-max) (1+ (pos-eol)))) + (prop (get-text-property p 'erc-callback)) + (q (if nextp + (text-property-not-all p high + 'erc-callback prop) + (funcall search-fn p 'erc-callback nil low))) + ((< low q high))) (setq p q)) ;; Assume that buttons occur frequently enough that ;; omitting LIMIT is acceptable. diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 057e7981515..9bb3f650b9b 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -267,9 +267,9 @@ instead of a `set' state, which precludes any actual saving." (rassq known custom-current-group-alist))) (throw 'found known)) (when (setq known (intern-soft (concat "erc-" downed "-mode"))) - (when-let ((found (custom-group-of-mode known))) + (when-let* ((found (custom-group-of-mode known))) (throw 'found found)))) - (when-let ((found (get (erc--normalize-module-symbol s) 'erc-group))) + (when-let* ((found (get (erc--normalize-module-symbol s) 'erc-group))) (throw 'found found))) 'erc)) diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index 1e81adbf6ba..13f1dbf266c 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -172,8 +172,8 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." (save-restriction (narrow-to-region (point) (point-max)) (funcall (or erc-fill--function erc-fill-function)) - (when-let ((erc-fill-line-spacing) - (p (point-min))) + (when-let* ((erc-fill-line-spacing) + (p (point-min))) (widen) (when (or (erc--check-msg-prop 'erc--spkr) (save-excursion @@ -186,9 +186,9 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." "Fills a text such that messages start at column `erc-fill-static-center'." (save-restriction (goto-char (point-min)) - (when-let (((looking-at "^\\(\\S-+\\)")) - ((not (erc--check-msg-prop 'erc--msg 'datestamp))) - (nick (match-string 1))) + (when-let* (((looking-at "^\\(\\S-+\\)")) + ((not (erc--check-msg-prop 'erc--msg 'datestamp))) + (nick (match-string 1))) (progn (let ((fill-column (- erc-fill-column (erc-timestamp-offset))) (fill-prefix (make-string erc-fill-static-center 32))) @@ -322,13 +322,13 @@ command." "Move to start of message text when left of speaker. Basically mimic what `move-beginning-of-line' does with invisible text. Stay put if OLD-POINT lies within hidden region." - (when-let ((erc-fill-wrap-merge) - (prop (get-text-property (point) 'erc-fill--wrap-merge)) - ((or (member prop '("" t)) - (eq 'margin (car-safe (car-safe prop))))) - (end (text-property-not-all (point) (pos-eol) - 'erc-fill--wrap-merge prop)) - ((or (null old-point) (>= old-point end)))) + (when-let* ((erc-fill-wrap-merge) + (prop (get-text-property (point) 'erc-fill--wrap-merge)) + ((or (member prop '("" t)) + (eq 'margin (car-safe (car-safe prop))))) + (end (text-property-not-all (point) (pos-eol) + 'erc-fill--wrap-merge prop)) + ((or (null old-point) (>= old-point end)))) (goto-char end))) (defun erc-fill--wrap-beginning-of-line (arg) @@ -672,10 +672,10 @@ Also cover region with text prop `erc-fill--wrap-merge' set to t." (let ((next-beg (point-max))) (save-restriction (widen) - (when-let (((get-text-property next-beg 'erc-fill--wrap-merge)) - (end (erc--get-inserted-msg-bounds next-beg)) - (beg (pop end)) - (erc-fill--wrap-continued-predicate #'ignore)) + (when-let* (((get-text-property next-beg 'erc-fill--wrap-merge)) + (end (erc--get-inserted-msg-bounds next-beg)) + (beg (pop end)) + (erc-fill--wrap-continued-predicate #'ignore)) (erc-fill--wrap-rejigger-region (1- beg) (1+ end) nil 'repairp)))))) (defun erc-fill--wrap-massage-initial-message-post-clear (beg end) @@ -684,14 +684,14 @@ Also cover region with text prop `erc-fill--wrap-merge' set to t." (erc-stamp--redo-right-stamp-post-clear beg end) ;; With other non-date stamp-insertion functions, remove hidden ;; speaker continuation on first spoken message in buffer. - (when-let (((< end (1- erc-insert-marker))) - (next (text-property-not-all end (min erc-insert-marker - (+ 4096 end)) - 'erc--msg nil)) - (bounds (erc--get-inserted-msg-bounds next)) - (found (text-property-not-all (car bounds) (cdr bounds) - 'erc-fill--wrap-merge nil)) - (erc-fill--wrap-continued-predicate #'ignore)) + (when-let* (((< end (1- erc-insert-marker))) + (next (text-property-not-all end (min erc-insert-marker + (+ 4096 end)) + 'erc--msg nil)) + (bounds (erc--get-inserted-msg-bounds next)) + (found (text-property-not-all (car bounds) (cdr bounds) + 'erc-fill--wrap-merge nil)) + (erc-fill--wrap-continued-predicate #'ignore)) (erc-fill--wrap-rejigger-region (max (1- (car bounds)) (point-min)) (min (1+ (cdr bounds)) erc-insert-marker) nil 'repairp)))) @@ -707,11 +707,11 @@ See `erc-fill-wrap-mode' for details." (funcall erc-fill--wrap-length-function)) (and-let* ((msg-prop (erc--check-msg-prop 'erc--msg)) ((not (eq msg-prop 'unknown)))) - (when-let ((e (erc--get-speaker-bounds)) - (b (pop e)) - ((or erc-fill--wrap-action-dedent-p - (not (erc--check-msg-prop 'erc--ctcp - 'ACTION))))) + (when-let* ((e (erc--get-speaker-bounds)) + (b (pop e)) + ((or erc-fill--wrap-action-dedent-p + (not (erc--check-msg-prop 'erc--ctcp + 'ACTION))))) (goto-char e)) (skip-syntax-forward "^-") (forward-char) @@ -776,18 +776,18 @@ With REPAIRP, destructively fill gaps and re-merge speakers." (end (text-property-not-all beg finish 'line-prefix val))) ;; If this is a left-side stamp on its own line. (remove-text-properties beg (1+ end) '(line-prefix nil wrap-prefix nil)) - (when-let ((repairp) - (dbeg (text-property-not-all beg end - 'erc-fill--wrap-merge nil)) - ((get-text-property (1+ dbeg) 'erc--speaker)) - (dval (get-text-property dbeg 'erc-fill--wrap-merge))) + (when-let* ((repairp) + (dbeg (text-property-not-all beg end + 'erc-fill--wrap-merge nil)) + ((get-text-property (1+ dbeg) 'erc--speaker)) + (dval (get-text-property dbeg 'erc-fill--wrap-merge))) (remove-list-of-text-properties dbeg (text-property-not-all dbeg end 'erc-fill--wrap-merge dval) '(display erc-fill--wrap-merge))) ;; This "should" work w/o `front-sticky' and `rear-nonsticky'. - (let* ((pos (if-let (((eq 'erc-timestamp (field-at-pos beg))) - (b (field-beginning beg)) - ((eq 'datestamp (get-text-property b 'erc--msg)))) + (let* ((pos (if-let* (((eq 'erc-timestamp (field-at-pos beg))) + (b (field-beginning beg)) + ((eq 'datestamp (get-text-property b 'erc--msg)))) b beg)) (erc--msg-props (map-into (text-properties-at pos) 'hash-table)) @@ -802,8 +802,8 @@ With REPAIRP, destructively fill gaps and re-merge speakers." (funcall on-next)) ;; Skip to end of message upon encountering accidental gaps ;; introduced by third parties (or bugs). - (if-let (((/= ?\n (char-after end))) - (next (erc--get-inserted-msg-end beg))) + (if-let* (((/= ?\n (char-after end))) + (next (erc--get-inserted-msg-end beg))) (progn (cl-assert (= ?\n (char-after next))) (when repairp ; eol <= next diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 93d0dc6fd0e..5d1aab4910d 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -141,7 +141,7 @@ or send-related hooks. When recentering has not been performed, attempt to restore last `window-start', if known." (dolist (window (get-buffer-window-list nil nil 'visible)) (with-selected-window window - (when-let + (when-let* ((erc--scrolltobottom-window-info) (found (assq window erc--scrolltobottom-window-info)) ((not (erc--scrolltobottom-confirm (nth 2 found))))) @@ -350,19 +350,19 @@ Do so only when switching to a new buffer in the same window if the replaced buffer is no longer visible in another window and its `window-start' at the time of switching is strictly greater than the indicator's position." - (when-let ((erc-keep-place-indicator-follow) - (window (selected-window)) - ((not (eq window (active-minibuffer-window)))) - (old-buffer (window-old-buffer window)) - ((buffer-live-p old-buffer)) - ((not (eq old-buffer (current-buffer)))) - (ov (buffer-local-value 'erc--keep-place-indicator-overlay - old-buffer)) - ((not (get-buffer-window old-buffer 'visible))) - (prev (assq old-buffer (window-prev-buffers window))) - (old-start (nth 1 prev)) - (old-inmkr (buffer-local-value 'erc-insert-marker old-buffer)) - ((< (overlay-end ov) old-start old-inmkr))) + (when-let* ((erc-keep-place-indicator-follow) + (window (selected-window)) + ((not (eq window (active-minibuffer-window)))) + (old-buffer (window-old-buffer window)) + ((buffer-live-p old-buffer)) + ((not (eq old-buffer (current-buffer)))) + (ov (buffer-local-value 'erc--keep-place-indicator-overlay + old-buffer)) + ((not (get-buffer-window old-buffer 'visible))) + (prev (assq old-buffer (window-prev-buffers window))) + (old-start (nth 1 prev)) + (old-inmkr (buffer-local-value 'erc-insert-marker old-buffer)) + ((< (overlay-end ov) old-start old-inmkr))) (with-current-buffer old-buffer (erc-keep-place-move old-start)))) @@ -392,15 +392,15 @@ and `keep-place-indicator' in different buffers." (progn (erc--restore-initialize-priors erc-keep-place-indicator-mode erc--keep-place-indicator-overlay (make-overlay 0 0)) - (when-let (((memq erc-keep-place-indicator-style '(t arrow))) - (ov-property (if (zerop (fringe-columns 'left)) - 'after-string - 'before-string)) - (display (if (zerop (fringe-columns 'left)) - `((margin left-margin) ,overlay-arrow-string) - '(left-fringe right-triangle - erc-keep-place-indicator-arrow))) - (bef (propertize " " 'display display))) + (when-let* (((memq erc-keep-place-indicator-style '(t arrow))) + (ov-property (if (zerop (fringe-columns 'left)) + 'after-string + 'before-string)) + (display (if (zerop (fringe-columns 'left)) + `((margin left-margin) ,overlay-arrow-string) + '(left-fringe right-triangle + erc-keep-place-indicator-arrow))) + (bef (propertize " " 'display display))) (overlay-put erc--keep-place-indicator-overlay ov-property bef)) (when (memq erc-keep-place-indicator-style '(t face)) (overlay-put erc--keep-place-indicator-overlay 'face @@ -440,11 +440,11 @@ Do this by simulating `keep-place' in all buffers where (defun erc--keep-place-indicator-adjust-on-clear (beg end) "Either shrink region bounded by BEG to END to preserve overlay, or reset." - (when-let ((pos (overlay-start erc--keep-place-indicator-overlay)) - ((<= beg pos end))) + (when-let* ((pos (overlay-start erc--keep-place-indicator-overlay)) + ((<= beg pos end))) (if (and erc-keep-place-indicator-truncation (not erc--called-as-input-p)) - (when-let ((pos (erc--get-inserted-msg-beg pos))) + (when-let* ((pos (erc--get-inserted-msg-beg pos))) (set-marker end pos)) (let (erc--keep-place-move-hook) ;; Move earlier than `beg', which may delimit date stamps, etc. @@ -473,7 +473,7 @@ window's first line. Interpret an integer as an offset in lines." (let ((inhibit-field-text-motion t)) (when pos (goto-char pos)) - (when-let ((pos (erc--get-inserted-msg-beg))) + (when-let* ((pos (erc--get-inserted-msg-beg))) (goto-char pos)) (run-hooks 'erc--keep-place-move-hook) (move-overlay erc--keep-place-indicator-overlay @@ -638,8 +638,8 @@ Do nothing if the variable `erc-command-indicator' is nil." (map-into `((erc--msg . slash-cmd) ,@(reverse ovs)) 'hash-table))))) - (when-let ((string (erc-command-indicator)) - (erc-input-marker (copy-marker erc-input-marker))) + (when-let* ((string (erc-command-indicator)) + (erc-input-marker (copy-marker erc-input-marker))) (erc-display-prompt nil nil string 'erc-command-indicator-face) (remove-text-properties insert-position (point) '(field nil erc-prompt nil)) diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el index 6e8a196255b..2874e2a4a00 100644 --- a/lisp/erc/erc-ibuffer.el +++ b/lisp/erc/erc-ibuffer.el @@ -121,10 +121,10 @@ (define-ibuffer-column erc-members (:name "Users") - (if-let ((table (or erc-channel-users erc-server-users)) - ((hash-table-p table)) - (count (hash-table-count table)) - ((> count 0))) + (if-let* ((table (or erc-channel-users erc-server-users)) + ((hash-table-p table)) + (count (hash-table-count table)) + ((> count 0))) (number-to-string count) "")) diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index cb57d8a00a1..9d08121fee6 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -157,8 +157,8 @@ network or a network ID). Return nil on failure." ;; encountering errors, like a 475 ERR_BADCHANNELKEY. (defun erc-join--remove-requested-channel (_ parsed) "Remove channel from `erc-join--requested-channels'." - (when-let ((channel (cadr (erc-response.command-args parsed))) - ((member channel erc-join--requested-channels))) + (when-let* ((channel (cadr (erc-response.command-args parsed))) + ((member channel erc-join--requested-channels))) (setq erc-join--requested-channels (delete channel erc-join--requested-channels))) nil) @@ -175,7 +175,7 @@ network or a network ID). Return nil on failure." (defun erc-autojoin--join () ;; This is called in the server buffer (pcase-dolist (`(,name . ,channels) erc-autojoin-channels-alist) - (when-let ((match (erc-autojoin-server-match name))) + (when-let* ((match (erc-autojoin-server-match name))) (dolist (chan channels) (let ((buf (erc-get-buffer chan erc-server-process))) (unless (and buf (with-current-buffer buf diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 8311359ed09..a1102ebdcdf 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -360,13 +360,13 @@ The result is converted to lowercase, as IRC is case-insensitive." erc-log-channels-directory))))) (defun erc-generate-log-file-name-with-date (buffer &rest _ignore) - "This function computes a short log file name. + "Compute a short log file name with the current date. The name of the log file is composed of BUFFER and the current date. This function is a possible value for `erc-generate-log-file-name-function'." (concat (buffer-name buffer) "-" (format-time-string "%Y-%m-%d") ".txt")) (defun erc-generate-log-file-name-short (buffer &rest _ignore) - "This function computes a short log file name. + "Compute a short log file name. In fact, it only uses the buffer name of the BUFFER argument, so you can affect that using `rename-buffer' and the-like. This function is a possible value for diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index a5ca05b137a..d1e4a0238a1 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -831,6 +831,10 @@ respectively. The separator is given by `erc-networks--id-sep'." (len 0 :type integer :documentation "Length of active `parts' interval.")) +(define-inline erc-networks--id-string (id) + "Return the symbol for `erc-networks--id' ID as a string." + (inline-quote (symbol-name (erc-networks--id-symbol ,id)))) + ;; For now, please use this instead of `erc-networks--id-fixed-p'. (cl-defgeneric erc-networks--id-given (net-id) "Return the preassigned identifier for a network context, if any. @@ -904,8 +908,8 @@ aside) that aren't also `eq'.") (defun erc-networks--id-qualifying-init-parts () "Return opaque list of atoms to serve as canonical identifier." - (when-let ((network (erc-network)) - (nick (erc-current-nick))) + (when-let* ((network (erc-network)) + (nick (erc-current-nick))) (vector network (erc-downcase nick)))) (defvar erc-networks--id-sep "/" @@ -986,7 +990,7 @@ object." (erc-networks--rename-server-buffer (or proc erc-server-process) parsed) (erc-networks--shrink-ids-and-buffer-names-any) (erc-with-all-buffers-of-server erc-server-process #'erc-target - (when-let + (when-let* ((new-name (erc-networks--reconcile-buffer-names erc--target nid)) ((not (equal (buffer-name) new-name)))) (rename-buffer new-name 'unique)))) @@ -1002,7 +1006,7 @@ object." ((nid erc-networks--id-qualifying) (other erc-networks--id-qualifying)) "Grow NID along with that of the current buffer. Rename the current buffer if its NID has grown." - (when-let ((n (erc-networks--id-qualifying-prefix-length other nid))) + (when-let* ((n (erc-networks--id-qualifying-prefix-length other nid))) (while (and (<= (erc-networks--id-qualifying-len nid) n) (erc-networks--id-qualifying-grow-id nid))) ;; Grow and rename a visited buffer and all its targets @@ -1159,10 +1163,10 @@ TARGET to be an `erc--target' object." ((not (with-suppressed-warnings ((obsolete erc-reuse-buffers)) erc-reuse-buffers)) (cadr (split-string - (symbol-name (erc-networks--id-symbol erc-networks--id)) + (erc-networks--id-string erc-networks--id) "/"))) ((erc--target-channel-local-p target) erc-server-announced-name) - (t (symbol-name (erc-networks--id-symbol erc-networks--id)))))) + (t (erc-networks--id-string erc-networks--id))))) (defun erc-networks--ensure-unique-target-buffer-name () (when-let* ((new-name (erc-networks--construct-target-buffer-name @@ -1171,8 +1175,7 @@ TARGET to be an `erc--target' object." (rename-buffer new-name 'unique))) (defun erc-networks--ensure-unique-server-buffer-name () - (when-let* ((new-name (symbol-name (erc-networks--id-symbol - erc-networks--id))) + (when-let* ((new-name (erc-networks--id-string erc-networks--id)) ((not (equal (buffer-name) new-name)))) (rename-buffer new-name 'unique))) @@ -1387,9 +1390,9 @@ Expect ANNOUNCED to be the server's reported host name." (string= erc-server-announced-name announced))) ;; If a target buffer exists for the current process, kill this ;; stale one after transplanting its content; else reinstate. - (if-let ((actual (erc-get-buffer (erc--target-string erc--target) - new-proc)) - (erc-networks--target-transplant-in-progress-p t)) + (if-let* ((actual (erc-get-buffer (erc--target-string erc--target) + new-proc)) + (erc-networks--target-transplant-in-progress-p t)) (progn (funcall erc-networks--transplant-target-buffer-function (current-buffer) actual) @@ -1489,7 +1492,7 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let ;; buffer may have been deleted. (erc-networks--reclaim-orphaned-target-buffers new-proc erc-networks--id erc-server-announced-name) - (let* ((name (symbol-name (erc-networks--id-symbol erc-networks--id))) + (let* ((name (erc-networks--id-string erc-networks--id)) ;; When this ends up being the current buffer, either we have ;; a "given" ID or the buffer was reused on reconnecting. (existing (get-buffer name))) @@ -1593,7 +1596,7 @@ return the host alone sans URL formatting (for compatibility)." erc-server-alist))))) (s-choose (lambda (entry) (and (equal (nth 1 entry) net) - (if-let ((b (string-search ": " (car entry)))) + (if-let* ((b (string-search ": " (car entry)))) (cons (format "%s (%s)" (nth 2 entry) (substring (car entry) (+ b 2))) (cdr entry)) diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index 6282242f4ac..6d4f8c596fc 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -309,10 +309,10 @@ lower it to the upper bound of `erc-nicks-contrast-range'." "Invert COLOR based on the CAR of `erc-nicks-contrast-range'. Don't bother if the inverted color has less contrast than the input." - (if-let ((con-input (erc-nicks--get-contrast color)) - ((< con-input (car erc-nicks-contrast-range))) - (flipped (mapcar (lambda (c) (- 1.0 c)) color)) - ((> (erc-nicks--get-contrast flipped) con-input))) + (if-let* ((con-input (erc-nicks--get-contrast color)) + ((< con-input (car erc-nicks-contrast-range))) + (flipped (mapcar (lambda (c) (- 1.0 c)) color)) + ((> (erc-nicks--get-contrast flipped) con-input))) flipped color)) @@ -365,8 +365,8 @@ input." (defun erc-nicks--redirect-face-widget-link (args) (pcase args (`(,widget face-link . ,plist) - (when-let ((face (widget-value widget)) - ((get face 'erc-nicks--custom-face))) + (when-let* ((face (widget-value widget)) + ((get face 'erc-nicks--custom-face))) (unless (symbol-file face) (setf (plist-get plist :action) (lambda (&rest _) (erc-nicks--create-defface-template face)))) @@ -518,17 +518,17 @@ Abandon search after examining LIMIT faces." (defun erc-nicks--highlight (nickname &optional base-face) "Return face for NICKNAME unless it or BASE-FACE is blacklisted." - (when-let ((trimmed (erc-nicks--trim nickname)) - ((not (member trimmed erc-nicks--downcased-skip-nicks))) - ((not (and base-face - (erc-nicks--skip-p base-face erc-nicks-skip-faces - erc-nicks--max-skip-search)))) - (key (erc-nicks--gen-key-from-format-spec trimmed))) + (when-let* ((trimmed (erc-nicks--trim nickname)) + ((not (member trimmed erc-nicks--downcased-skip-nicks))) + ((not (and base-face + (erc-nicks--skip-p base-face erc-nicks-skip-faces + erc-nicks--max-skip-search)))) + (key (erc-nicks--gen-key-from-format-spec trimmed))) (erc-nicks--get-face trimmed key))) (defun erc-nicks--highlight-button (nick-object) "Possibly add face to `erc-button--nick-user' NICK-OBJECT." - (when-let + (when-let* ((nick-object) (face (get-text-property (car (erc-button--nick-bounds nick-object)) 'font-lock-face)) @@ -628,13 +628,13 @@ Abandon search after examining LIMIT faces." (customize-face new-face))) (defun erc-nicks--list-faces-help-button-action (face) - (when-let (((or (get face 'erc-nicks--custom-face) - (y-or-n-p (format "Create new persistent face for %s?" - (get face 'erc-nicks--key))))) - (nid (get face 'erc-nicks--netid)) - (foundp (lambda () - (erc-networks--id-equal-p nid erc-networks--id))) - (server-buffer (car (erc-buffer-filter foundp)))) + (when-let* (((or (get face 'erc-nicks--custom-face) + (y-or-n-p (format "Create new persistent face for %s?" + (get face 'erc-nicks--key))))) + (nid (get face 'erc-nicks--netid)) + (foundp (lambda () + (erc-networks--id-equal-p nid erc-networks--id))) + (server-buffer (car (erc-buffer-filter foundp)))) (with-current-buffer server-buffer (erc-nicks-customize-face (get face 'erc-nicks--nick))))) @@ -653,13 +653,13 @@ Abandon search after examining LIMIT faces." (facep (car (button-get (point) 'help-args)))) (button-put (point) 'help-function #'erc-nicks--list-faces-help-button-action) - (if-let ((face (car (button-get (point) 'help-args))) - ((not (get face 'erc-nicks--custom-face))) - ((not (get face 'erc-nicks--key)))) + (if-let* ((face (car (button-get (point) 'help-args))) + ((not (get face 'erc-nicks--custom-face))) + ((not (get face 'erc-nicks--key)))) (progn (delete-region (pos-bol) (1+ (pos-eol))) (forward-line -1)) - (when-let ((nid (get face 'erc-nicks--netid)) - (net (symbol-name (erc-networks--id-symbol nid)))) + (when-let* ((nid (get face 'erc-nicks--netid)) + (net (erc-networks--id-string nid))) (goto-char (button-end (point))) (skip-syntax-forward "-") (put-text-property (point) (1+ (point)) 'rear-nonsticky nil) @@ -690,8 +690,8 @@ ones." (user-error "Pool empty: all colors rejected")) (dolist (nick (hash-table-keys erc-nicks--face-table)) ;; User-tuned faces do not have an `erc-nicks--key' property. - (when-let ((face (gethash nick erc-nicks--face-table)) - (key (get face 'erc-nicks--key))) + (when-let* ((face (gethash nick erc-nicks--face-table)) + (key (get face 'erc-nicks--key))) (setq key (erc-nicks--gen-key-from-format-spec nick)) (put face 'erc-nicks--key key) (set-face-foreground face (erc-nicks--determine-color key)))) @@ -719,8 +719,8 @@ ones." Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"." (let (out) (dolist (face (face-list) (nreverse out)) - (when-let (((string-prefix-p prefix (symbol-name face))) - (color (face-foreground face))) + (when-let* (((string-prefix-p prefix (symbol-name face))) + (color (face-foreground face))) (push color out))))) (defun erc-nicks--reject-uninterned-faces (candidate) @@ -762,13 +762,13 @@ NORMALS. Expect a non-nil CONTENDER to always be ranked." (defun erc-nicks--track-prioritize (current contender contenders ranks normals) "Return a viable non-CURRENT `nicks' face among CONTENDERS. See `erc-track--select-mode-line-face' for parameter types." - (when-let + (when-let* ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) (catch 'contender (dolist (candidate (cdr contenders)) - (when-let (((not (equal candidate current))) - (s (erc-nicks--ours-p candidate)) - ((not (eq s spkr)))) + (when-let* (((not (equal candidate current))) + (s (erc-nicks--ours-p candidate)) + ((not (eq s spkr)))) (throw 'contender candidate)))))) (defun erc-nicks--track-always (current contender contenders ranks normals) @@ -798,9 +798,9 @@ See `erc-track--select-mode-line-face' for parameter types." (defun erc-nicks--remember-face-for-track (face) "Add FACE to local hash table maintained by `track' module." (or (gethash face erc-track--normal-faces) - (if-let ((sym (or (car-safe face) face)) - ((symbolp sym)) - ((get sym 'erc-nicks--key))) + (if-let* ((sym (or (car-safe face) face)) + ((symbolp sym)) + ((get sym 'erc-nicks--key))) (puthash face face erc-track--normal-faces) face))) diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index a32c8b46118..7e78120f799 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el @@ -324,10 +324,10 @@ target buffer." ((when erc--querypoll-timer (cancel-timer erc--querypoll-timer)) (if erc--target - (when-let (((erc-query-buffer-p)) - (ring (erc-with-server-buffer erc--querypoll-ring)) - (index (ring-member ring (current-buffer))) - ((not (erc--querypoll-target-in-chan-p (current-buffer))))) + (when-let* (((erc-query-buffer-p)) + (ring (erc-with-server-buffer erc--querypoll-ring)) + (index (ring-member ring (current-buffer))) + ((not (erc--querypoll-target-in-chan-p (current-buffer))))) (ring-remove ring index) (unless (erc-current-nick-p (erc-target)) (erc-remove-current-channel-member (erc-target)))) @@ -376,8 +376,8 @@ between updates regardless of queue length.") (let ((n (ring-length ring))) (catch 'found (while (natnump (cl-decf n)) - (when-let ((buffer (ring-remove ring)) - ((buffer-live-p buffer))) + (when-let* ((buffer (ring-remove ring)) + ((buffer-live-p buffer))) ;; Push back buffers for users joined to some chan. (if (erc--querypoll-target-in-chan-p buffer) (ring-insert ring buffer) @@ -408,7 +408,7 @@ Then add user to participant rolls in any existing query buffers." (pcase-let ((`(,_ ,channel ,login ,host ,_server ,nick ,_flags, hop-real) args)) (when (and (string= channel "*") (erc-nick-equal-p nick target-nick)) - (if-let ((user (erc-get-server-user nick))) + (if-let* ((user (erc-get-server-user nick))) (erc-update-user user nick host login (erc--extract-352-full-name hop-real)) ;; Don't add unless target is already known. @@ -428,7 +428,7 @@ Then add user to participant rolls in any existing query buffers." (buffer-local-value 'erc-server-connected server-buffer)) (with-current-buffer server-buffer (setq erc--querypoll-timer nil) - (if-let ((buffer (erc--querypoll-get-next erc--querypoll-ring))) + (if-let* ((buffer (erc--querypoll-get-next erc--querypoll-ring))) (letrec ((target (erc--target-string (buffer-local-value 'erc--target buffer))) diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el index 1998e4f129b..65dba95d5c3 100644 --- a/lisp/erc/erc-sasl.el +++ b/lisp/erc/erc-sasl.el @@ -148,17 +148,17 @@ PLIST to contain keyword params known to `auth-source-search'." (defun erc-sasl--read-password (prompt) "Return configured option or server password. If necessary, pass PROMPT to `read-passwd'." - (if-let ((found (pcase (alist-get 'password erc-sasl--options) - ((guard (alist-get 'authfn erc-sasl--options)) - (let-alist erc-sasl--options - (let ((erc-sasl-user .user) - (erc-sasl-password .password) - (erc-sasl-mechanism .mechanism) - (erc-sasl-authzid .authzid) - (erc-sasl-auth-source-function .authfn)) - (funcall .authfn :user (erc-sasl--get-user))))) - (:password erc-session-password) - ((and (pred stringp) v) (unless (string-empty-p v) v))))) + (if-let* ((found (pcase (alist-get 'password erc-sasl--options) + ((guard (alist-get 'authfn erc-sasl--options)) + (let-alist erc-sasl--options + (let ((erc-sasl-user .user) + (erc-sasl-password .password) + (erc-sasl-mechanism .mechanism) + (erc-sasl-authzid .authzid) + (erc-sasl-auth-source-function .authfn)) + (funcall .authfn :user (erc-sasl--get-user))))) + (:password erc-session-password) + ((and (pred stringp) v) (unless (string-empty-p v) v))))) (copy-sequence (erc--unfun found)) (read-passwd prompt))) diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index 0881006ed77..6ea5e03881c 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -578,13 +578,13 @@ as needed." (letrec ((attempts 3) (on-notice (lambda (_proc parsed) - (when-let ((nick (erc-extract-nick - (erc-response.sender parsed))) - ((erc-nick-equal-p nick "nickserv")) - (contents (erc-response.contents parsed)) - (case-fold-search t) - ((string-match (rx (or "ghost" "is not online")) - contents))) + (when-let* ((nick (erc-extract-nick + (erc-response.sender parsed))) + ((erc-nick-equal-p nick "nickserv")) + (contents (erc-response.contents parsed)) + (case-fold-search t) + ((string-match (rx (or "ghost" "is not online")) + contents))) (setq attempts 1) (erc-server-send (concat "NICK " want) 'force)) (when (zerop (cl-decf attempts)) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index e8c41a1f239..ed27881abdc 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -512,13 +512,13 @@ associated with an ERC session." ". Setting to t for the current Emacs session." " Customize it permanently to avoid this message.") (setq speedbar-update-flag t)) - (when-let (((null speedbar-buffer)) - (speedbar-frame-parameters (backquote-list* - '(visibility . nil) - '(no-other-frame . t) - speedbar-frame-parameters)) - (speedbar-after-create-hook #'erc-speedbar--emulate-sidebar) - (original-frame (selected-frame))) + (when-let* (((null speedbar-buffer)) + (speedbar-frame-parameters (backquote-list* + '(visibility . nil) + '(no-other-frame . t) + speedbar-frame-parameters)) + (speedbar-after-create-hook #'erc-speedbar--emulate-sidebar) + (original-frame (selected-frame))) (erc-install-speedbar-variables) ;; Run before toggling mode to prevent timer from being ;; created twice. @@ -591,8 +591,8 @@ For controlling whether the speedbar window is selectable with (and speedbar-buffer (eq speedbar-frame (window-frame (get-buffer-window speedbar-buffer t))))) - (when-let ((buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) - (car (erc-buffer-filter #'erc--server-buffer-p))))) + (when-let* ((buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) + (car (erc-buffer-filter #'erc--server-buffer-p))))) (with-current-buffer buf (erc-speedbar--ensure 'forcep))))) ((remove-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) @@ -649,7 +649,7 @@ unlock the window." (interactive "P") (unless erc-nickbar-mode (user-error "`erc-nickbar-mode' inactive")) - (when-let ((window (get-buffer-window speedbar-buffer))) + (when-let* ((window (get-buffer-window speedbar-buffer))) (let ((val (cond ((natnump arg) t) ((integerp arg) nil) (t (not (erc-compat--window-no-other-p window)))))) @@ -669,10 +669,10 @@ unlock the window." (defun erc-speedbar--compose-nicks-face (orig buffer user cuser) (require 'erc-nicks) (let ((rv (funcall orig buffer user cuser))) - (if-let ((nick (erc-server-user-nickname user)) - (face (with-current-buffer buffer - (erc-nicks--highlight nick rv))) - ((not (eq face erc-button-nickname-face)))) + (if-let* ((nick (erc-server-user-nickname user)) + (face (with-current-buffer buffer + (erc-nicks--highlight nick rv))) + ((not (eq face erc-button-nickname-face)))) (cons face (ensure-list rv)) rv))) diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el index b2f565d71bf..5ff28fa14e8 100644 --- a/lisp/erc/erc-spelling.el +++ b/lisp/erc/erc-spelling.el @@ -52,15 +52,17 @@ (defcustom erc-spelling-dictionaries nil "An alist mapping buffer names to dictionaries. -The `car' of every cell is a buffer name, the `cadr' is the -string name of an associated dictionary. + +Each element is a list of the form (KEY VALUE), where KEY is a buffer +name and VALUE a locale or dictionary name known to `ispell', for +example: ((\"Libera.Chat\" \"en_US\") (\"#esperanto\" \"esperanto\")). + The dictionary is inherited from server buffers, so if you want a default dictionary for some server, you can use a server buffer name here." :type '(choice (const nil) - (repeat (cons (string :tag "Buffer name") - (string :tag "Dictionary")))) - :group 'erc-spelling) + (repeat (list (string :tag "Buffer name") + (string :tag "Dictionary"))))) (defun erc-spelling-init (buffer) "Enable flyspell mode in an ERC buffer. diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index b0ecd67eef7..24bb510fd70 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -197,13 +197,13 @@ from entering them and instead jump over them." (defun erc-stamp--recover-on-reconnect () "Attempt to restore \"last-inserted\" snapshots from prior session." - (when-let ((priors (or erc--server-reconnecting erc--target-priors))) + (when-let* ((priors (or erc--server-reconnecting erc--target-priors))) (dolist (var '(erc-timestamp-last-inserted erc-timestamp-last-inserted-left erc-timestamp-last-inserted-right erc-stamp--deferred-date-stamp erc-stamp--date-stamps)) - (when-let (existing (alist-get var priors)) + (when-let* ((existing (alist-get var priors))) (set var existing))))) (defvar erc-stamp--current-time nil @@ -396,14 +396,14 @@ non-nil." (goto-char (point-min)) (while (progn - (when-let (((< (point) (pos-eol))) - (end (1- (pos-eol))) - ((eq 'erc-timestamp (field-at-pos end))) - (beg (field-beginning end)) - ;; Skip a line that's just a timestamp. - ((> beg (point)))) + (when-let* (((< (point) (pos-eol))) + (end (1- (pos-eol))) + ((eq 'erc-timestamp (field-at-pos end))) + (beg (field-beginning end)) + ;; Skip a line that's just a timestamp. + ((> beg (point)))) (delete-region beg (1+ end))) - (when-let (time (erc--get-inserted-msg-prop 'erc--ts)) + (when-let* ((time (erc--get-inserted-msg-prop 'erc--ts))) (insert (format-time-string "[%H:%M:%S] " time))) (zerop (forward-line)))) "") @@ -505,10 +505,10 @@ and `erc-stamp--margin-left-p', before activating the mode." (&context (erc-stamp--display-margin-mode (eql t)) (erc-stamp--margin-left-p (eql t)) (erc-stamp--skip-left-margin-prompt-p null)) - (when-let (((null erc--hidden-prompt-overlay)) - (prompt (string-pad erc-prompt-hidden left-margin-width nil 'start)) - (ov (make-overlay erc-insert-marker (1- erc-input-marker) - nil 'front-advance))) + (when-let* (((null erc--hidden-prompt-overlay)) + (prompt (string-pad erc-prompt-hidden left-margin-width nil 'start)) + (ov (make-overlay erc-insert-marker (1- erc-input-marker) + nil 'front-advance))) (overlay-put ov 'display `((margin left-margin) ,prompt)) (setq erc--hidden-prompt-overlay ov))) @@ -534,7 +534,7 @@ and `erc-stamp--margin-left-p', before activating the mode." (goto-char (point-min)) (insert-and-inherit (setq erc-timestamp-last-inserted string)) (dolist (p erc-stamp--inherited-props) - (when-let ((v (get-text-property (point) p))) + (when-let* ((v (get-text-property (point) p))) (put-text-property (point-min) (point) p v))) (erc-put-text-property (point-min) (point) 'invisible erc-stamp--invisible-property) @@ -641,7 +641,7 @@ printed just after each line's text (no alignment)." (_ (indent-to pos))) (insert string) (dolist (p erc-stamp--inherited-props) - (when-let ((v (get-text-property (1- from) p))) + (when-let* ((v (get-text-property (1- from) p))) (put-text-property from (point) p v))) (erc-put-text-property from (point) 'field 'erc-timestamp) (erc-put-text-property from (point) 'rear-nonsticky t) @@ -724,13 +724,13 @@ inserted is a date stamp." "Schedule a date stamp to be inserted via HOOK-VAR. Do so when `erc-stamp--deferred-date-stamp' and its `fn' slot are non-nil." - (when-let ((data erc-stamp--deferred-date-stamp) - ((eq (erc-stamp--date-fn data) #'ignore)) - (ct (erc-stamp--date-ts data)) - (rendered (erc-stamp--date-str data)) - (buffer (current-buffer)) - (symbol (make-symbol "erc-stamp--insert-date")) - (marker (setf (erc-stamp--date-marker data) (point-min-marker)))) + (when-let* ((data erc-stamp--deferred-date-stamp) + ((eq (erc-stamp--date-fn data) #'ignore)) + (ct (erc-stamp--date-ts data)) + (rendered (erc-stamp--date-str data)) + (buffer (current-buffer)) + (symbol (make-symbol "erc-stamp--insert-date")) + (marker (setf (erc-stamp--date-marker data) (point-min-marker)))) (setf (erc-stamp--date-fn data) symbol) (fset symbol (lambda (&rest _) @@ -856,15 +856,15 @@ and date stamps inserted by this function." ;; "prepended" date stamps as well. However, since this is a ;; compatibility oriented code path, and pre-5.6 did no such ;; thing, better to punt. - (if-let ((erc-stamp-prepend-date-stamps-p) - (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) - ((not (string= ts-left erc-timestamp-last-inserted-left)))) + (if-let* ((erc-stamp-prepend-date-stamps-p) + (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) + ((not (string= ts-left erc-timestamp-last-inserted-left)))) (progn (goto-char (point-min)) (erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp ts-left) (insert (setq erc-timestamp-last-inserted-left ts-left))) - (when-let + (when-let* (((null erc-stamp--deferred-date-stamp)) (rendered (erc-stamp--format-date-stamp ct)) ((not (string-equal rendered erc-timestamp-last-inserted-left))) @@ -1064,17 +1064,17 @@ with the option `erc-echo-timestamps', see the companion option ;; regardless of `erc-timestamp-only-if-changed-flag'. As of ERC 5.6, ;; recreating inserted messages from scratch isn't doable. (Although, ;; attempting surgery like this is likely unwise.) - (when-let ((erc-stamp--date-mode) - ((< end (1- erc-insert-marker))) ; not a /CLEAR - (bounds (erc--get-inserted-msg-bounds (1+ end))) - (ts (get-text-property (car bounds) 'erc--ts)) - (format (with-suppressed-warnings - ((obsolete erc-timestamp-format-right)) - (or erc-timestamp-format-right erc-timestamp-format))) - (rendered (erc-format-timestamp ts format)) - ((not (equal rendered erc-timestamp-last-inserted-right))) - ((not (eq 'erc-timestamp (field-at-pos (1- (cdr bounds)))))) - (erc--msg-props (map-into `((erc--ts . ,ts)) 'hash-table))) + (when-let* ((erc-stamp--date-mode) + ((< end (1- erc-insert-marker))) ; not a /CLEAR + (bounds (erc--get-inserted-msg-bounds (1+ end))) + (ts (get-text-property (car bounds) 'erc--ts)) + (format (with-suppressed-warnings + ((obsolete erc-timestamp-format-right)) + (or erc-timestamp-format-right erc-timestamp-format))) + (rendered (erc-format-timestamp ts format)) + ((not (equal rendered erc-timestamp-last-inserted-right))) + ((not (eq 'erc-timestamp (field-at-pos (1- (cdr bounds)))))) + (erc--msg-props (map-into `((erc--ts . ,ts)) 'hash-table))) (save-excursion (save-restriction (let ((erc-timestamp-last-inserted erc-timestamp-last-inserted) @@ -1106,12 +1106,12 @@ Call ORIG, an `erc--clear-function', with BEG and END markers." (when (and fullp culled (not skipp) (< 1 beg 3 end)) (set-marker beg 3)) (funcall orig beg end) - (when-let ((culled) - ((not skipp)) - (ct (erc-stamp--date-ts (car culled))) - (hook (make-symbol "temporary-hook")) - (rendered (erc-stamp--format-date-stamp ct)) - (data (make-erc-stamp--date :ts ct :str rendered))) + (when-let* ((culled) + ((not skipp)) + (ct (erc-stamp--date-ts (car culled))) + (hook (make-symbol "temporary-hook")) + (rendered (erc-stamp--format-date-stamp ct)) + (data (make-erc-stamp--date :ts ct :str rendered))) (cl-assert erc-stamp--date-mode) ;; Object successfully removed from model but snapshot remains. (cl-assert (null (cl-find rendered erc-stamp--date-stamps @@ -1144,9 +1144,9 @@ copy non-duplicate `erc-stamp--date' objects from OLD-STAMPS to the current buffer's, maintaining order." (let (need) (dolist (old old-stamps) - (if-let ((new (cl-find (erc-stamp--date-str old) erc-stamp--date-stamps - :test #'string= :key #'erc-stamp--date-str)) - (new-marker (erc-stamp--date-marker new))) + (if-let* ((new (cl-find (erc-stamp--date-str old) erc-stamp--date-stamps + :test #'string= :key #'erc-stamp--date-str)) + (new-marker (erc-stamp--date-marker new))) ;; The new buffer now has a duplicate stamp, so remove the ;; "newer" one from the buffer. (progn diff --git a/lisp/erc/erc-status-sidebar.el b/lisp/erc/erc-status-sidebar.el index dcdef7cfafc..bb11ade221d 100644 --- a/lisp/erc/erc-status-sidebar.el +++ b/lisp/erc/erc-status-sidebar.el @@ -258,17 +258,17 @@ current frame only." (erc-track-mode +1)) (add-hook 'erc--setup-buffer-hook #'erc-status-sidebar--open) ;; Preserve side-window dimensions after `custom-buffer-done'. - (when-let (((not erc--updating-modules-p)) - (buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) - (car (erc-buffer-filter - (lambda () erc-server-connected)))))) + (when-let* (((not erc--updating-modules-p)) + (buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) + (car (erc-buffer-filter + (lambda () erc-server-connected)))))) (with-current-buffer buf (erc-status-sidebar--open)))) ((remove-hook 'erc--setup-buffer-hook #'erc-status-sidebar--open) (erc-status-sidebar-close 'all-frames) - (when-let ((arg erc--module-toggle-prefix-arg) - ((numberp arg)) - ((< arg 0))) + (when-let* ((arg erc--module-toggle-prefix-arg) + ((numberp arg)) + ((< arg 0))) (erc-status-sidebar-kill)))) ;;;###autoload @@ -308,7 +308,7 @@ even if one already exists in another frame." (defun erc-status-sidebar-prefer-target-as-name (buffer) "Return some name to represent buffer in the sidebar." - (if-let ((target (buffer-local-value 'erc--target buffer))) + (if-let* ((target (buffer-local-value 'erc--target buffer))) (cond ((and erc-status-sidebar--trimpat (erc--target-channel-p target)) (string-trim-left (erc--target-string target) erc-status-sidebar--trimpat)) @@ -340,8 +340,8 @@ even if one already exists in another frame." (let ((erc-status-sidebar--trimpat (and (eq erc-status-sidebar-style 'all-mixed) (with-current-buffer (process-buffer proc) - (when-let ((ch-pfxs (erc--get-isupport-entry - 'CHANTYPES 'single))) + (when-let* ((ch-pfxs (erc--get-isupport-entry + 'CHANTYPES 'single))) (regexp-quote ch-pfxs))))) (erc-status-sidebar--prechan (and (eq erc-status-sidebar-style @@ -390,8 +390,8 @@ focused window." (next (cadr (member buffer buflist))) ((buffer-live-p next)) (proc (buffer-local-value 'erc-server-process next)) - (id (process-get proc 'erc-networks--id))) - (symbol-name (erc-networks--id-symbol id))) + (id (process-get proc 'erc-networks--id)) + ((erc-networks--id-string id)))) "???") "\n")) @@ -484,7 +484,7 @@ name stand out." (cl-assert (eq major-mode 'erc-status-sidebar-mode)) (cl-assert (eq (selected-window) window)) (cl-assert (eq (window-buffer window) (current-buffer))) - (when-let ((buf (get-text-property pos 'erc-buf))) + (when-let* ((buf (get-text-property pos 'erc-buf))) ;; Option operates relative to last selected window (select-window (get-mru-window nil nil 'not-selected)) (pop-to-buffer buf erc-status-sidebar-click-display-action))))) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 82e5f402910..97fb7e726bd 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -409,12 +409,12 @@ For now, omit relevant options like `erc-track-shorten-start' and friends, even though they do affect the outcome, because they likely change too infrequently to matter over sub-second intervals and are unlikely to be let-bound or set locally." - (when-let ((hash (setq erc-track--shortened-names-current-hash - (sxhash-equal (list channel-names - (buffer-list) - erc-track-shorten-function)))) - (erc-track--shortened-names) - ((= hash (car erc-track--shortened-names)))) + (when-let* ((hash (setq erc-track--shortened-names-current-hash + (sxhash-equal (list channel-names + (buffer-list) + erc-track-shorten-function)))) + (erc-track--shortened-names) + ((= hash (car erc-track--shortened-names)))) (cdr erc-track--shortened-names))) (gv-define-simple-setter erc-track--shortened-names-get @@ -674,8 +674,8 @@ binding, set the cache variable's local value to that of server's." (when (local-variable-p opt) (erc-track--massage-nick-button-faces opt (symbol-value opt) #'set)) - (when-let ((migrations (get opt 'erc-track--obsolete-faces)) - ((consp migrations))) + (when-let* ((migrations (get opt 'erc-track--obsolete-faces)) + ((consp migrations))) (push (cons opt (mapcar (pcase-lambda (`(,old . ,new)) (format (if new "changed %s to %s" @@ -980,11 +980,11 @@ Failing that, choose the first face in both NEW-FACES and NORMALS." ;; Choose the highest ranked face in `erc-track-faces-priority-list' ;; that's either `cur-face' itself or one appearing in the region ;; being processed. - (when-let ((choice (catch 'face - (dolist (candidate (cdr ranks)) - (when (or (equal candidate cur-face) - (gethash candidate (car new-faces))) - (throw 'face candidate)))))) + (when-let* ((choice (catch 'face + (dolist (candidate (cdr ranks)) + (when (or (equal candidate cur-face) + (gethash candidate (car new-faces))) + (throw 'face candidate)))))) (or (and erc-track--alt-normals-function (funcall erc-track--alt-normals-function cur-face choice new-faces ranks normals)) @@ -1040,7 +1040,7 @@ the current buffer is in `erc-mode'." ;; (in the car), change its face attribute (in the cddr) if ;; necessary. See `erc-modified-channels-alist' for the ;; exact data structure used. - (when-let + (when-let* ((faces (if erc-track-ignore-normal-contenders-p (erc-faces-in (buffer-string)) (erc-track--collect-faces-in))) @@ -1128,7 +1128,7 @@ seen to least." (faces (make-hash-table :test #'equal)) (rfaces ())) (while p - (when-let ((cur (get-text-property p prop))) + (when-let* ((cur (get-text-property p prop))) (unless (gethash cur seen) (puthash cur t seen) (when erc-track--face-reject-function @@ -1214,8 +1214,8 @@ unless any passes.") (current-buffer)) (setq erc-track-last-non-erc-buffer (current-buffer))) ;; and jump to the next active channel - (if-let ((buf (erc-track-get-active-buffer arg)) - ((buffer-live-p buf))) + (if-let* ((buf (erc-track-get-active-buffer arg)) + ((buffer-live-p buf))) (funcall fun buf) (erc-modified-channels-update) (erc-track--switch-buffer fun arg))) @@ -1244,7 +1244,7 @@ reverse it." (erc-track--switch-buffer 'switch-to-buffer-other-window arg)) (defun erc-track--replace-killed-buffer (existing) - (when-let ((found (assq existing erc-modified-channels-alist))) + (when-let* ((found (assq existing erc-modified-channels-alist))) (setcar found (current-buffer)))) (provide 'erc-track) diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el index fd152707708..b6666c76f33 100644 --- a/lisp/erc/erc-truncate.el +++ b/lisp/erc/erc-truncate.el @@ -82,8 +82,8 @@ for other purposes should customize either `erc-enable-logging' or "Enable or disable buffer-local `erc-truncate-mode' modifications." (if erc-truncate-mode (progn - (when-let ((priors (or erc--server-reconnecting erc--target-priors)) - (val (alist-get 'erc-truncate--buffer-size priors))) + (when-let* ((priors (or erc--server-reconnecting erc--target-priors)) + (val (alist-get 'erc-truncate--buffer-size priors))) (setq erc-truncate--buffer-size val)) (add-function :before (local 'erc--clear-function) #'erc-truncate--inhibit-when-local-and-interactive @@ -150,7 +150,7 @@ present in `erc-modules'." ;; `erc-truncate-buffer-to-size' normally runs in a different buffer. (save-excursion (if (and erc--parsed-response erc--msg-props) - (when-let + (when-let* (((not erc--inhibit-clear-p)) ((not (erc--memq-msg-prop 'erc--skip 'truncate))) ;; Determine here because this may be a target buffer and diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 426b29f8e80..7028d0a68cc 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -567,9 +567,9 @@ restore the described historical behavior.") (defun erc--ensure-query-member (nick) "Populate membership table in query buffer for online NICK." (erc-with-buffer (nick) - (when-let (((not erc--decouple-query-and-channel-membership-p)) - ((zerop (hash-table-count erc-channel-users))) - (user (erc-get-server-user nick))) + (when-let* (((not erc--decouple-query-and-channel-membership-p)) + ((zerop (hash-table-count erc-channel-users))) + (user (erc-get-server-user nick))) (erc-update-current-channel-member nick nil t) (erc--unhide-prompt) t))) @@ -579,10 +579,10 @@ restore the described historical behavior.") Ensure targets with an entry in `erc-server-users' are present in `erc-channel-members'." (erc-with-all-buffers-of-server erc-server-process #'erc-query-buffer-p - (when-let (((not erc--decouple-query-and-channel-membership-p)) - ((zerop (hash-table-count erc-channel-users))) - (target (erc-target)) - ((erc-get-server-user target))) + (when-let* (((not erc--decouple-query-and-channel-membership-p)) + ((zerop (hash-table-count erc-channel-users))) + (target (erc-target)) + ((erc-get-server-user target))) (erc-update-current-channel-member target nil t) (erc--unhide-prompt)) erc-server-process)) @@ -666,15 +666,15 @@ Also remove members from the server table if this was their only buffer." (defun erc--remove-channel-users-but (nick) "Drain channel users and remove from server, sparing NICK." - (when-let ((users (erc-with-server-buffer erc-server-users)) - (my-user (gethash (erc-downcase nick) users)) - (original-function erc--forget-server-user-function) - (erc--forget-server-user-function - (if erc--decouple-query-and-channel-membership-p - erc--forget-server-user-function - (lambda (nick user) - (unless (eq user my-user) - (funcall original-function nick user)))))) + (when-let* ((users (erc-with-server-buffer erc-server-users)) + (my-user (gethash (erc-downcase nick) users)) + (original-function erc--forget-server-user-function) + (erc--forget-server-user-function + (if erc--decouple-query-and-channel-membership-p + erc--forget-server-user-function + (lambda (nick user) + (unless (eq user my-user) + (funcall original-function nick user)))))) (erc-remove-channel-users))) (defmacro erc--define-channel-user-status-compat-getter (name c d) @@ -716,9 +716,9 @@ inlining calls to these adapters." "Add or remove membership status associated with LETTER for NICK-OR-CUSR. With RESETP, clear the user's status info completely. If ENABLEP is non-nil, add the status value associated with LETTER." - (when-let ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) - (cdr (erc-get-channel-member nick-or-cusr)))) - (n (erc--get-prefix-flag letter))) + (when-let* ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) + (cdr (erc-get-channel-member nick-or-cusr)))) + (n (erc--get-prefix-flag letter))) (cl-callf (lambda (v) (if resetp (if enablep n 0) @@ -2060,8 +2060,7 @@ same manner." (if (and (with-suppressed-warnings ((obsolete erc-reuse-buffers)) erc-reuse-buffers) id) - (let ((string (symbol-name (erc-networks--id-symbol - (erc-networks--id-create id))))) + (let ((string (erc-networks--id-string (erc-networks--id-create id)))) (when-let* ((buf (get-buffer string)) ((erc-server-process-alive buf))) (user-error "Session with ID %S already exists" string)) @@ -2395,12 +2394,12 @@ invocations by third-party packages.") (defun erc--find-mode (sym) (setq sym (erc--normalize-module-symbol sym)) - (if-let ((mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) - ((and (fboundp mode) - (autoload-do-load (symbol-function mode) mode))) - ((or (get sym 'erc--module) - (symbol-file mode) - (ignore (cl-pushnew sym erc--aberrant-modules))))) + (if-let* ((mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) + ((and (fboundp mode) + (autoload-do-load (symbol-function mode) mode))) + ((or (get sym 'erc--module) + (symbol-file mode) + (ignore (cl-pushnew sym erc--aberrant-modules))))) mode (and (or (and erc--requiring-module-mode-p ;; Also likely non-nil: (eq sym (car features)) @@ -2418,7 +2417,7 @@ invocations by third-party packages.") (defun erc--update-modules (modules) (let (local-modes) (dolist (module modules local-modes) - (if-let ((mode (erc--find-mode module))) + (if-let* ((mode (erc--find-mode module))) (if (custom-variable-p mode) (funcall mode 1) (push mode local-modes)) @@ -3063,9 +3062,8 @@ such inconsistent labeling may pose a problem until the MOTD is received. Setting a fixed `erc-networks--id' can serve as a workaround." (when erc-debug-irc-protocol - (let ((esid (if-let ((erc-networks--id) - (esid (erc-networks--id-symbol erc-networks--id))) - (symbol-name esid) + (let ((esid (if erc-networks--id + (erc-networks--id-string erc-networks--id) (or erc-server-announced-name (format "%s:%s" erc-session-server erc-session-port)))) (ts (when erc-debug-irc-protocol-time-format @@ -3297,10 +3295,10 @@ a full refresh." (insert s) (delete-region erc-insert-marker p)))) (run-hooks 'erc--refresh-prompt-hook) - (when-let (((> erc--refresh-prompt-continue-request 0)) - (n erc--refresh-prompt-continue-request) - (erc--refresh-prompt-continue-request -1) - (b (current-buffer))) + (when-let* (((> erc--refresh-prompt-continue-request 0)) + (n erc--refresh-prompt-continue-request) + (erc--refresh-prompt-continue-request -1) + (b (current-buffer))) (erc-with-all-buffers-of-server erc-server-process (lambda () (not (eq b (current-buffer)))) (if (= n 1) @@ -3677,10 +3675,10 @@ Callers should be aware that this function fails if the property `erc--important-props' has an empty value almost anywhere along the affected region. Use the function `erc--remove-from-prop-value-list' to ensure that props with empty values are excised completely." - (when-let ((registered (erc--check-msg-prop 'erc--important-prop-names)) - (present (seq-intersection props registered)) - (b (or beg (point-min))) - (e (or end (point-max)))) + (when-let* ((registered (erc--check-msg-prop 'erc--important-prop-names)) + (present (seq-intersection props registered)) + (b (or beg (point-min))) + (e (or end (point-max)))) (while-let (((setq b (text-property-not-all b e 'erc--important-props nil))) (val (get-text-property b 'erc--important-props)) @@ -3790,7 +3788,7 @@ reverse order so they end up sorted in buffer interval plists for retrieval by `text-properties-at' and friends." (let (out) (dolist (k erc--ranked-properties) - (when-let ((v (gethash k table))) + (when-let* ((v (gethash k table))) (remhash k table) (setq out (nconc (list k v) out)))) (maphash (lambda (k v) (setq out (nconc (list k v) out))) table) @@ -4132,8 +4130,8 @@ for other purposes.") (defun erc-send-input-line (target line &optional force) "Send LINE to TARGET." - (when-let ((target) - (cmem (erc-get-channel-member (erc-current-nick)))) + (when-let* ((target) + (cmem (erc-get-channel-member (erc-current-nick)))) (setf (erc-channel-user-last-message-time (cdr cmem)) (erc-compat--current-lisp-time))) (when (and (not erc--allow-empty-outgoing-lines-p) (string= line "\n")) @@ -4430,7 +4428,7 @@ of `erc-ignore-list'." (format "Now ignoring %s" user))) (erc-with-server-buffer (when timeout - (if-let ((existing (erc--find-ignore-timer user (current-buffer)))) + (if-let* ((existing (erc--find-ignore-timer user (current-buffer)))) (timer-set-time existing (timer-relative-time nil timeout)) (run-at-time timeout nil #'erc--unignore-user user (current-buffer)))) @@ -4442,11 +4440,11 @@ of `erc-ignore-list'." (erc-with-server-buffer (let ((seen (copy-sequence erc-ignore-list))) (dolist (timer timer-list) - (when-let ((args (erc--get-ignore-timer-args timer)) - ((eq (current-buffer) (nth 1 args))) - (user (car args)) - (delta (- (timer-until timer (current-time)))) - (duration (erc--format-time-period delta))) + (when-let* ((args (erc--get-ignore-timer-args timer)) + ((eq (current-buffer) (nth 1 args))) + (user (car args)) + (delta (- (timer-until timer (current-time)))) + (duration (erc--format-time-period delta))) (setq seen (delete user seen)) (erc-display-message nil 'notice 'active 'ignore-list ?p user ?s duration))) @@ -4477,7 +4475,7 @@ of `erc-ignore-list'." (erc-display-message nil 'notice 'active (format "No longer ignoring %s" user)) (setq erc-ignore-list (delete user erc-ignore-list)) - (when-let ((existing (erc--find-ignore-timer user buffer))) + (when-let* ((existing (erc--find-ignore-timer user buffer))) (cancel-timer existing))))) (defvar erc--clear-function #'delete-region @@ -4669,9 +4667,8 @@ node `(erc) auth-source'." function)) (defun erc--auth-source-determine-params-defaults () - (let* ((net (and-let* ((erc-networks--id) - (esid (erc-networks--id-symbol erc-networks--id)) - ((symbol-name esid))))) + (let* ((net (and erc-networks--id + (erc-networks--id-string erc-networks--id))) (localp (and erc--target (erc--target-channel-local-p erc--target))) (hosts (if localp (list erc-server-announced-name erc-session-server net) @@ -5249,7 +5246,7 @@ Display the query buffer in accordance with `erc-interactive-display'." (erc--display-context `((erc-interactive-display . /QUERY) ,@erc--display-context))) (erc-with-server-buffer - (if-let ((buffer (erc-get-buffer user erc-server-process))) + (if-let* ((buffer (erc-get-buffer user erc-server-process))) (prog1 buffer (erc-setup-buffer buffer)) (prog1 (erc--open-target user) ; becomes current buffer @@ -5654,9 +5651,9 @@ When uninitialized or with option -f, resync `erc-channel-banlist'." (when (< maxw (+ rw lw)) ; scale down when capped (cl-psetq rw (/ (* rw maxw) (* 1.0 (+ rw lw))) lw (/ (* lw maxw) (* 1.0 (+ rw lw))))) - (when-let ((larger (max rw lw)) ; cap ratio at 3:1 - (wavg (* maxw 0.75)) - ((> larger wavg))) + (when-let* ((larger (max rw lw)) ; cap ratio at 3:1 + (wavg (* maxw 0.75)) + ((> larger wavg))) (setq rw (if (eql larger rw) wavg (- maxw wavg)) lw (- maxw rw))) (cl-psetq rw (+ rw (* erc-banlist-fill-padding @@ -6386,8 +6383,8 @@ with `erc--spkr' in the \"msg prop\" environment for any imminent `erc-display-message' invocations, and include any overrides defined in `erc--message-speaker-catalog'. Expect NICK (but not necessarily DISP) to be absent of any existing text properties." - (when-let ((erc-server-process) - (cusr (erc-get-server-user nick))) + (when-let* ((erc-server-process) + (cusr (erc-get-server-user nick))) (setq nick (erc-server-user-nickname cusr))) (erc--ensure-spkr-prop nick (get erc--message-speaker-catalog 'erc--msg-prop-overrides)) @@ -6554,14 +6551,14 @@ similar to that performed by `erc-format-my-nick', but use either `erc--message-speaker-input-query-privmsg' as a formatting template, with MESSAGE being the actual message body. Return a copy with possibly shared text-property values." - (if-let ((erc-show-my-nick) - (nick (erc-current-nick)) - (pfx (erc-get-channel-membership-prefix nick)) - (erc-current-message-catalog erc--message-speaker-catalog) - (key (if (or erc-format-query-as-channel-p - (erc--target-channel-p erc--target)) - 'input-chan-privmsg - 'input-query-privmsg))) + (if-let* ((erc-show-my-nick) + (nick (erc-current-nick)) + (pfx (erc-get-channel-membership-prefix nick)) + (erc-current-message-catalog erc--message-speaker-catalog) + (key (if (or erc-format-query-as-channel-p + (erc--target-channel-p erc--target)) + 'input-chan-privmsg + 'input-query-privmsg))) (progn (cond (erc--msg-props (puthash 'erc--msg key erc--msg-props)) (erc--msg-prop-overrides (push (cons 'erc--msg key) @@ -7194,7 +7191,7 @@ extensions." (let ((names (delete "" (split-string names-string))) (erc-channel-members-changed-hook nil)) (dolist (name names) - (when-let ((args (erc--partition-prefixed-names name))) + (when-let* ((args (erc--partition-prefixed-names name))) (pcase-let* ((`(,status ,nick ,login ,host) args) (cmem (erc-get-channel-user nick))) (progn @@ -8190,10 +8187,10 @@ ERC prints them as a single message joined by newlines.") (let* ((str (erc-user-input)) (state (erc--make-input-split str))) (run-hook-with-args 'erc--input-review-functions state) - (when-let (((not (erc--input-split-abortp state))) - (inhibit-read-only t) - (erc--current-line-input-split state) - (old-buf (current-buffer))) + (when-let* (((not (erc--input-split-abortp state))) + (inhibit-read-only t) + (erc--current-line-input-split state) + (old-buf (current-buffer))) (progn ; unprogn this during next major surgery (erc-set-active-buffer (current-buffer)) ;; Kill the input and the prompt @@ -9187,12 +9184,11 @@ This should be a string with substitution variables recognized by "Return the network or the current target and network combined. If the name of the network is not available, then use the shortened server name instead." - (if-let ((erc--target) - (name (if-let ((erc-networks--id) - (esid (erc-networks--id-symbol erc-networks--id))) - (symbol-name esid) - (erc-shorten-server-name (or erc-server-announced-name - erc-session-server))))) + (if-let* ((erc--target) + (name (if erc-networks--id + (erc-networks--id-string erc-networks--id) + (erc-shorten-server-name (or erc-server-announced-name + erc-session-server))))) (concat (erc--target-string erc--target) "@" name) (buffer-name))) @@ -9773,8 +9769,8 @@ one of the following hooks: `erc-kill-channel-hook' if a channel buffer was killed, or `erc-kill-buffer-hook' if any other buffer." (when (eq major-mode 'erc-mode) - (when-let ((erc--target) - (nick (erc-current-nick))) + (when-let* ((erc--target) + (nick (erc-current-nick))) (erc--remove-channel-users-but nick)) (cond ((eq (erc-server-buffer) (current-buffer)) @@ -9829,10 +9825,10 @@ This function should be on `erc-kill-server-hook'." (defun erc-restore-text-properties () "Ensure the `erc-parsed' and `tags' props cover the entire message." - (when-let ((parsed-posn (erc-find-parsed-property)) + (when-let* ((parsed-posn (erc-find-parsed-property)) (found (erc-get-parsed-vector parsed-posn))) (put-text-property (point-min) (point-max) 'erc-parsed found) - (when-let ((tags (get-text-property parsed-posn 'tags))) + (when-let* ((tags (get-text-property parsed-posn 'tags))) (put-text-property (point-min) (point-max) 'tags tags)))) (defun erc-get-parsed-vector (point) @@ -9858,7 +9854,7 @@ This function should be on `erc-kill-server-hook'." See also `erc-message-type'." ;; IRC numerics are three-digit numbers, possibly with leading 0s. ;; To invert: (if (numberp o) (format "%03d" o) (symbol-name o)) - (if-let ((n (string-to-number command)) ((zerop n))) (intern command) n)) + (if-let* ((n (string-to-number command)) ((zerop n))) (intern command) n)) ;; Teach url.el how to open irc:// URLs with ERC. ;; To activate, customize `url-irc-function' to `url-irc-erc'. diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el index e5bf8d5fe82..4f8f0c1c7e4 100644 --- a/lisp/eshell/em-alias.el +++ b/lisp/eshell/em-alias.el @@ -221,14 +221,14 @@ This is useful after manually editing the contents of the file." (defun eshell-maybe-replace-by-alias--which (command) (unless (and eshell-prevent-alias-expansion (member command eshell-prevent-alias-expansion)) - (when-let ((alias (eshell-lookup-alias command))) + (when-let* ((alias (eshell-lookup-alias command))) (concat command " is an alias, defined as \"" (cadr alias) "\"")))) (defun eshell-maybe-replace-by-alias (command _args) "Call COMMAND's alias definition, if it exists." (unless (and eshell-prevent-alias-expansion (member command eshell-prevent-alias-expansion)) - (when-let ((alias (eshell-lookup-alias command))) + (when-let* ((alias (eshell-lookup-alias command))) (throw 'eshell-replace-command `(let ((eshell-command-name ',eshell-last-command-name) (eshell-command-arguments ',eshell-last-arguments) diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 4c79f7b187a..ef931db62b2 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -444,7 +444,7 @@ to writing a completion function." ('nil (propertize "" 'pcomplete-arg-value arg)) (_ - (propertize (eshell-stringify arg) + (propertize (eshell-stringify arg t) 'pcomplete-arg-value arg)))) args) posns))) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 9cf0994fe78..e005bc98873 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -65,9 +65,7 @@ they lack somewhat in feel from the typical shell equivalents." :version "24.1" ; removed eshell-dirs-initialize :type 'hook) -(defcustom eshell-pwd-convert-function (if (eshell-under-windows-p) - #'expand-file-name - #'identity) +(defcustom eshell-pwd-convert-function #'expand-file-name "The function used to normalize the value of Eshell's `pwd'. The value returned by `pwd' is also used when recording the last-visited directory in the last-dir-ring, so it will affect the @@ -75,7 +73,8 @@ form of the list used by `cd ='." :type '(radio (function-item file-truename) (function-item expand-file-name) (function-item identity) - (function :tag "Other"))) + (function :tag "Other")) + :version "31.1") (defcustom eshell-ask-to-save-last-dir 'always "Determine if the last-dir-ring should be automatically saved. @@ -319,14 +318,13 @@ Thus, this does not include the current directory.") (defun eshell/pwd () "Change output from `pwd' to be cleaner." - (let* ((path default-directory) - (len (length path))) - (if (and (> len 1) - (eq (aref path (1- len)) ?/) - (not (and (eshell-under-windows-p) - (string-match "\\`[A-Za-z]:[\\/]\\'" path)))) - (setq path (substring path 0 (1- (length path))))) - (funcall (or eshell-pwd-convert-function #'identity) path))) + (let ((dir default-directory)) + (when (and (eq (aref dir (1- (length dir))) ?/) + (not (and (eshell-under-windows-p) + (string-match "\\`[A-Za-z]:[\\/]\\'" dir))) + (length> (file-local-name dir) 1)) + (setq dir (substring dir 0 -1))) + (funcall (or eshell-pwd-convert-function #'identity) dir))) (defun eshell-expand-multiple-dots (filename) ;; FIXME: This advice recommendation is rather odd: it's somewhat diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 36e4f90aed2..b94c4e3ed46 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -141,7 +141,7 @@ This mimics the behavior of zsh if non-nil, but bash if nil." (when (boundp 'eshell-special-chars-outside-quoting) (setq-local eshell-special-chars-outside-quoting (append eshell-glob-chars-list eshell-special-chars-outside-quoting))) - (add-hook 'eshell-parse-argument-hook 'eshell-parse-glob-chars t t) + (add-hook 'eshell-parse-argument-hook 'eshell-parse-glob-chars 90 t) (add-hook 'eshell-pre-rewrite-command-hook 'eshell-no-command-globbing nil t)) @@ -149,40 +149,49 @@ This mimics the behavior of zsh if non-nil, but bash if nil." "Don't glob the command argument. Reflect this by modifying TERMS." (ignore (pcase (car terms) - ((or `(eshell-extended-glob ,term) - `(eshell-splice-args (eshell-extended-glob ,term))) + ((or `(eshell-expand-glob ,term) + `(eshell-splice-args (eshell-expand-glob ,term))) (setcar terms term))))) (defun eshell-add-glob-modifier () - "Add `eshell-extended-glob' to the argument modifier list." + "Add `eshell-expand-glob' to the argument modifier list." (when eshell-glob-splice-results (add-hook 'eshell-current-modifiers #'eshell-splice-args 99)) - (add-hook 'eshell-current-modifiers #'eshell-extended-glob)) + (add-hook 'eshell-current-modifiers #'eshell-expand-glob)) (defun eshell-parse-glob-chars () - "Parse a globbing delimiter. -The character is not advanced for ordinary globbing characters, so -that other function may have a chance to override the globbing -interpretation." + "Parse a globbing character." (when (memq (char-after) eshell-glob-chars-list) - (if (not (memq (char-after) '(?\( ?\[))) - (ignore (eshell-add-glob-modifier)) - (let ((here (point))) - (forward-char) - (let* ((delim (char-before)) - (end (eshell-find-delimiter - delim (if (eq delim ?\[) ?\] ?\))))) - (if (not end) - (throw 'eshell-incomplete (char-to-string delim)) - (if (and (eshell-using-module 'eshell-pred) - (eshell-arg-delimiter (1+ end))) - (ignore (goto-char here)) - (eshell-add-glob-modifier) - (prog1 - (buffer-substring-no-properties (1- (point)) (1+ end)) - (goto-char (1+ end)))))))))) + (eshell-add-glob-modifier) + (prog1 + (propertize (char-to-string (char-after)) 'eshell-glob-char t) + (forward-char)))) (defvar eshell-glob-chars-regexp nil) +(defsubst eshell-glob-chars-regexp () + "Return the lazily-created value for `eshell-glob-chars-regexp'." + (or eshell-glob-chars-regexp + (setq-local eshell-glob-chars-regexp + (rx-to-string `(+ (any ,@eshell-glob-chars-list)) t)))) + +(defun eshell-parse-glob-string (glob) + "Add text properties to glob characters in GLOB and return the result." + (let ((regexp (rx-to-string + `(or (seq (group-n 1 "\\") anychar) + (group-n 2 (regexp ,(eshell-glob-chars-regexp)))) + t))) + (with-temp-buffer + (insert glob) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (cond + ((match-beginning 1) ; Remove backslash escape. + (delete-region (match-beginning 1) (match-end 1))) + ((match-beginning 2) ; Propertize globbing character. + (put-text-property (match-beginning 2) (match-end 2) + 'eshell-glob-char t)))) + (buffer-string)))) + (defvar eshell-glob-matches) (defvar message-shown) @@ -190,11 +199,16 @@ interpretation." '(("**/" . recurse) ("***/" . recurse-symlink))) -(defsubst eshell-glob-chars-regexp () - "Return the lazily-created value for `eshell-glob-chars-regexp'." - (or eshell-glob-chars-regexp - (setq-local eshell-glob-chars-regexp - (format "[%s]+" (apply 'string eshell-glob-chars-list))))) +(defsubst eshell--glob-char-p (string index) + (get-text-property index 'eshell-glob-char string)) + +(defsubst eshell--contains-glob-char-p (string) + (text-property-any 0 (length string) 'eshell-glob-char t string)) + +(defun eshell--all-glob-chars-p (string) + (and (length> string 0) + (not (text-property-not-all + 0 (length string) 'eshell-glob-char t string)))) (defun eshell-glob-regexp (pattern) "Convert glob-pattern PATTERN to a regular expression. @@ -211,9 +225,10 @@ The basic syntax is: [a-b] [a-b] matches a character or range [^a] [^a] excludes a character or range -If any characters in PATTERN have the text property `escaped' -set to true, then these characters will match themselves in the -resulting regular expression." +This function only considers in PATTERN that have the text property +`eshell-glob-char' set to t for conversion from glob to regexp syntax. +All other characters are treated as literals. See also +`eshell-parse-glob-chars' and `eshell-parse-glob-string'." (let ((matched-in-pattern 0) ; How much of PATTERN handled regexp) (while (string-match (eshell-glob-chars-regexp) @@ -224,7 +239,7 @@ resulting regular expression." (concat regexp (regexp-quote (substring pattern matched-in-pattern op-begin)))) - (if (get-text-property op-begin 'escaped pattern) + (if (not (eshell--glob-char-p pattern op-begin)) (setq regexp (concat regexp (regexp-quote (char-to-string op-char))) matched-in-pattern (1+ op-begin)) @@ -244,7 +259,11 @@ resulting regular expression." (defun eshell-glob-p (pattern) "Return non-nil if PATTERN has any special glob characters." - (string-match (eshell-glob-chars-regexp) pattern)) + (declare (obsolete nil "31.1")) + ;; "~" is an infix globbing character, so one at the start of a glob + ;; must be a literal. + (let ((start (if (string-prefix-p "~" pattern) 1 0))) + (string-match (eshell-glob-chars-regexp) pattern start))) (defun eshell-glob-convert-1 (glob &optional last) "Convert a GLOB matching a single element of a file name to regexps. @@ -261,8 +280,8 @@ include, and the second for ones to exclude." ;; Split the glob if it contains a negation like x~y. (while (and (eq incl glob) (setq index (string-search "~" glob index))) - (if (or (get-text-property index 'escaped glob) - (or (= (1+ index) len))) + (if (or (not (eshell--glob-char-p glob index)) + (= (1+ index) len)) (setq index (1+ index)) (setq incl (substring glob 0 index) excl (substring glob (1+ index))))) @@ -306,13 +325,18 @@ The result is a list of three elements: (setq start-dir (pop globs)) (setq start-dir (file-name-as-directory "."))) (while globs - (if-let ((recurse (cdr (assoc (car globs) - eshell-glob-recursive-alist)))) + ;; "~" is an infix globbing character, so one at the start of a + ;; glob component must be a literal. + (when (eq (aref (car globs) 0) ?~) + (remove-text-properties 0 1 '(eshell-glob-char) (car globs))) + (if-let* ((recurse (cdr (assoc (car globs) eshell-glob-recursive-alist))) + ((eshell--all-glob-chars-p + (string-trim-right (car globs) "/")))) (if last-saw-recursion (setcar result recurse) (push recurse result) (setq last-saw-recursion t)) - (if (or result (eshell-glob-p (car globs))) + (if (or result (eshell--contains-glob-char-p (car globs))) (push (eshell-glob-convert-1 (car globs) (null (cdr globs))) result) ;; We haven't seen a glob yet, so instead append to the start @@ -324,6 +348,38 @@ The result is a list of three elements: (nreverse result) isdir))) +(defun eshell-expand-glob (glob) + "Return a list of files matched by GLOB. +Each globbing character in GLOB should have a non-nil value for the text +property `eshell-glob-char' (e.g. by `eshell-parse-glob-chars') in order +for it to have syntactic meaning; otherwise, this function treats the +character literally. + +This function is primarily intended for use within Eshell command +forms. If you want to use an ordinary string as a glob, use +`eshell-extended-glob' instead." + (let ((globs (eshell-glob-convert glob)) + eshell-glob-matches message-shown) + (unwind-protect + ;; After examining GLOB, make sure we actually got some globs + ;; before computing the results. We can get zero globs for + ;; remote file names using "~", like "/ssh:remote:~/file.txt". + ;; During Eshell argument parsing, we can't always be sure if + ;; the "~" is a home directory reference or part of a glob + ;; (e.g. if the argument was assembled from variables). + (when (cadr globs) + (apply #'eshell-glob-entries globs)) + (when message-shown + (message nil))) + (cond + (eshell-glob-matches + (sort eshell-glob-matches #'string<)) + ((and eshell-error-if-no-glob (cadr globs)) + (error "No matches found: %s" glob)) + (t + (let ((result (substring-no-properties glob))) + (if eshell-glob-splice-results (list result) result)))))) + (defun eshell-extended-glob (glob) "Return a list of files matched by GLOB. If no files match, signal an error (if `eshell-error-if-no-glob' @@ -339,26 +395,9 @@ syntax. Things that are not supported are: Mainly they are not supported because file matching is done with Emacs regular expressions, and these cannot support the above constructs." - (let ((globs (eshell-glob-convert glob)) - eshell-glob-matches message-shown) - (if (null (cadr globs)) - ;; If, after examining GLOB, there are no actual globs, just - ;; bail out. This can happen for remote file names using "~", - ;; like "/ssh:remote:~/file.txt". During parsing, we can't - ;; always be sure if the "~" is a home directory reference or - ;; part of a glob (e.g. if the argument was assembled from - ;; variables). - glob - (unwind-protect - (apply #'eshell-glob-entries globs) - (if message-shown - (message nil))) - (or (and eshell-glob-matches (sort eshell-glob-matches #'string<)) - (if eshell-error-if-no-glob - (error "No matches found: %s" glob) - (if eshell-glob-splice-results - (list glob) - glob)))))) + (eshell-expand-glob (eshell-parse-glob-string glob))) + +(defconst eshell--glob-anything (eshell-parse-glob-string "*")) ;; FIXME does this really need to abuse eshell-glob-matches, message-shown? (defun eshell-glob-entries (path globs only-dirs) @@ -375,7 +414,7 @@ directories and files." (if (rassq (car globs) eshell-glob-recursive-alist) (setq recurse-p (car globs) glob (or (cadr globs) - (eshell-glob-convert-1 "*" t)) + (eshell-glob-convert-1 eshell--glob-anything t)) glob-remainder (cddr globs)) (setq glob (car globs) glob-remainder (cdr globs))) diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 8bf2e20d320..e8cdb9c82c4 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -246,6 +246,17 @@ scope during the evaluation of TEST-SEXP." (declare-function eshell-extended-glob "em-glob" (glob)) (defvar eshell-error-if-no-glob) +(defvar eshell-glob-splice-results) + +(defun eshell-ls--expand-wildcards (file) + "Expand the shell wildcards in FILE if any." + (if (and (atom file) + (not (file-exists-p file))) + (let ((eshell-error-if-no-glob t) + ;; Ensure `eshell-extended-glob' returns a list. + (eshell-glob-splice-results t)) + (mapcar #'file-relative-name (eshell-extended-glob file))) + (list (file-relative-name file)))) (defun eshell-ls--insert-directory (orig-fun file switches &optional wildcard full-directory-p) @@ -277,13 +288,7 @@ instead." (require 'em-glob) (let* ((insert-func 'insert) (error-func 'insert) - (eshell-error-if-no-glob t) - (target ; Expand the shell wildcards if any. - (if (and (atom file) - (string-match "[[?*]" file) - (not (file-exists-p file))) - (mapcar #'file-relative-name (eshell-extended-glob file)) - (file-relative-name file))) + (target (eshell-ls--expand-wildcards file)) (switches (append eshell-ls-dired-initial-args (and (or (consp dired-directory) wildcard) (list "-d")) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index a9274e7c60d..df7438ffa4d 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -261,8 +261,8 @@ respectively.") (defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the predicate/modifier code." - (add-hook 'eshell-parse-argument-hook - #'eshell-parse-arg-modifier t t) + ;; Make sure this function runs before `eshell-parse-glob-chars'. + (add-hook 'eshell-parse-argument-hook #'eshell-parse-arg-modifier 50 t) (eshell-pred-mode)) (defun eshell-apply-modifiers (lst predicates modifiers string-desc) @@ -442,7 +442,7 @@ before the closing delimiter. This allows modifiers like (error "Unknown %s name specified for modifier `%c'" mod-type mod-char)) (lambda (file) - (when-let ((attrs (file-attributes file))) + (when-let* ((attrs (file-attributes file))) (= (nth attr-index attrs) ugid))))) (defun eshell-pred-file-time (mod-char mod-type attr-index) @@ -467,7 +467,7 @@ before the closing delimiter. This allows modifiers like (list #'time-less-p (lambda (a b) (time-less-p b a)) #'time-equal-p))) - (if-let ((number (eshell-get-numeric-modifier-argument))) + (if-let* ((number (eshell-get-numeric-modifier-argument))) (setq when (time-since (* number quantum))) (let* ((file (or (eshell-get-delimited-modifier-argument) (error "Malformed %s time modifier `%c'" @@ -476,7 +476,7 @@ before the closing delimiter. This allows modifiers like (error "Cannot stat file `%s'" file)))) (setq when (nth attr-index attrs)))) (lambda (file) - (when-let ((attrs (file-attributes file))) + (when-let* ((attrs (file-attributes file))) (funcall qual when (nth attr-index attrs)))))) (defun eshell-pred-file-type (type) @@ -492,13 +492,13 @@ that `ls -l' will show in the first column of its display." '(?b ?c) (list type)))) (lambda (file) - (when-let ((attrs (eshell-file-attributes (directory-file-name file)))) + (when-let* ((attrs (eshell-file-attributes (directory-file-name file)))) (memq (aref (file-attribute-modes attrs) 0) set))))) (defsubst eshell-pred-file-mode (mode) "Return a test which tests that MODE pertains to the file." (lambda (file) - (when-let ((modes (file-modes file 'nofollow))) + (when-let* ((modes (file-modes file 'nofollow))) (not (zerop (logand mode modes)))))) (defun eshell-pred-file-links () @@ -507,7 +507,7 @@ that `ls -l' will show in the first column of its display." (amount (or (eshell-get-numeric-modifier-argument) (error "Invalid file link count modifier `l'")))) (lambda (file) - (when-let ((attrs (eshell-file-attributes file))) + (when-let* ((attrs (eshell-file-attributes file))) (funcall qual (file-attribute-link-number attrs) amount))))) (defun eshell-pred-file-size () @@ -528,7 +528,7 @@ that `ls -l' will show in the first column of its display." (error "Invalid file size modifier `L'")) quantum)) (lambda (file) - (when-let ((attrs (eshell-file-attributes file))) + (when-let* ((attrs (eshell-file-attributes file))) (funcall qual (file-attribute-size attrs) amount))))) (defun eshell-pred-substitute (&optional repeat) diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index 7de2bd4dc21..37970ac0ba5 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -119,6 +119,19 @@ arriving, or after." (add-hook 'eshell-post-command-hook 'eshell-emit-prompt nil t) (eshell-prompt-mode))) +(defun eshell--append-text-property (start end prop value &optional object) + "Append to a text property from START to END. +PROP is the text property to append to, and VALUE is the list of +property values to append. OBJECT is the object to propertize, as with +`put-text-property' (which see)." + (let (next) + (while (< start end) + (setq next (next-single-property-change start prop object end)) + (put-text-property start next prop + (append (get-text-property start prop object) value) + object) + (setq start next)))) + (defun eshell-emit-prompt () "Emit a prompt if eshell is being used interactively." (when (boundp 'ansi-color-context-region) @@ -126,19 +139,16 @@ arriving, or after." (run-hooks 'eshell-before-prompt-hook) (if (not eshell-prompt-function) (set-marker eshell-last-output-end (point)) - (let ((prompt (funcall eshell-prompt-function))) - (add-text-properties - 0 (length prompt) - (if eshell-highlight-prompt - '( read-only t - field prompt - font-lock-face eshell-prompt - front-sticky (read-only field font-lock-face) - rear-nonsticky (read-only field font-lock-face)) - '( field prompt - front-sticky (field) - rear-nonsticky (field))) - prompt) + (let* ((prompt (funcall eshell-prompt-function)) + (len (length prompt)) + (sticky-props '(field))) + (put-text-property 0 len 'field 'prompt prompt) + (when eshell-highlight-prompt + (add-text-properties + 0 len '(read-only t font-lock-face eshell-prompt) prompt) + (setq sticky-props `(read-only font-lock-face . ,sticky-props))) + (eshell--append-text-property 0 len 'front-sticky sticky-props prompt) + (eshell--append-text-property 0 len 'rear-nonsticky sticky-props prompt) (eshell-interactive-filter nil prompt))) (run-hooks 'eshell-after-prompt-hook)) @@ -178,8 +188,8 @@ Like `forward-paragraph', but also stops at the beginning of each prompt." (while (and (> n 0) (< (point) (point-max))) (let ((next-paragraph (save-excursion (forward-paragraph) (point))) (next-prompt (save-excursion - (if-let ((match (text-property-search-forward - 'field 'prompt t t))) + (if-let* ((match (text-property-search-forward + 'field 'prompt t t))) (prop-match-beginning match) (point-max))))) (goto-char (min next-paragraph next-prompt))) @@ -212,7 +222,7 @@ Like `backward-paragraph', but navigates using fields." (pcase (get-text-property (point) 'field) ('command-output) ('prompt (goto-char (field-end))) - (_ (when-let ((match (text-property-search-backward 'field 'prompt t))) + (_ (when-let* ((match (text-property-search-backward 'field 'prompt t))) (goto-char (prop-match-end match))))) ;; Now, move forward/backward to our destination prompt. (if (natnump n) diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el index 03d9a88e32e..f426afb5d28 100644 --- a/lisp/eshell/em-script.el +++ b/lisp/eshell/em-script.el @@ -68,22 +68,24 @@ This includes when running `eshell-command'." 'eshell/source) eshell-interpreter-alist)) (setq-local eshell-complex-commands - (append '("source" ".") eshell-complex-commands)) - ;; these two variables are changed through usage, but we don't want - ;; to ruin it for other modules - (let (eshell-inside-quote-regexp - eshell-outside-quote-regexp) - (and (not (bound-and-true-p eshell-non-interactive-p)) - eshell-login-script - (file-readable-p eshell-login-script) - (eshell-do-eval - `(eshell-commands ,(eshell--source-file eshell-login-script)) - t)) - (and eshell-rc-script - (file-readable-p eshell-rc-script) - (eshell-do-eval - `(eshell-commands ,(eshell--source-file eshell-rc-script)) - t)))) + (append '("source" ".") eshell-complex-commands)) + ;; Run our startup scripts once this Eshell session has finished + ;; initialization. + (add-hook 'eshell-after-initialize-hook #'eshell-run-startup-scripts 90 t)) + +(defun eshell-run-startup-scripts () + "Run any necessary startup scripts for the current Eshell session." + (when (and (not (bound-and-true-p eshell-non-interactive-p)) + eshell-login-script + (file-readable-p eshell-login-script)) + (eshell-do-eval + `(eshell-commands ,(eshell--source-file eshell-login-script)) + t)) + (when (and eshell-rc-script + (file-readable-p eshell-rc-script)) + (eshell-do-eval + `(eshell-commands ,(eshell--source-file eshell-rc-script)) + t))) (defun eshell--source-file (file &optional args subcommand-p) "Return a Lisp form for executing the Eshell commands in FILE, passing ARGS. diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 671573f38c5..9cdc0ca6f25 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -858,119 +858,109 @@ external command." pcomplete-last-completion-raw t) (throw 'pcomplete-completions (pcomplete-read-host-names))))) -(defvar block-size) -(defvar by-bytes) -(defvar dereference-links) -(defvar grand-total) -(defvar human-readable) -(defvar max-depth) -(defvar only-one-filesystem) -(defvar show-all) - -(defsubst eshell-du-size-string (size) - (let* ((str (eshell-printable-size size human-readable block-size t)) - (len (length str))) - (concat str (if (< len 8) - (make-string (- 8 len) ? ))))) - -(defun eshell-du-sum-directory (path depth) +(cl-defun eshell-du-sum-directory (path depth-remaining &rest args + &key print-function show-all + dereference-links only-one-filesystem + seen-files) "Summarize PATH, and its member directories." - (let ((entries (eshell-directory-files-and-attributes path)) - (size 0.0)) - (while entries - (unless (string-match "\\`\\.\\.?\\'" (caar entries)) - (let* ((entry (concat path "/" - (caar entries))) - (symlink (and (stringp (file-attribute-type (cdar entries))) - (file-attribute-type (cdar entries))))) + (let ((size 0.0)) + (dolist (entry (eshell-directory-files-and-attributes path)) + (unless (or (string-match "\\`\\.\\.?\\'" (car entry)) + (gethash (file-attribute-file-identifier (cdr entry)) + seen-files)) + (puthash (file-attribute-file-identifier (cdr entry)) t seen-files) + (let* ((file-name (concat path "/" (car entry))) + (file-type (file-attribute-type (cdr entry))) + (symlink (and (stringp file-type) file-type))) (unless (or (and symlink (not dereference-links)) (and only-one-filesystem (/= only-one-filesystem - (file-attribute-device-number (cdar entries))))) - (if symlink - (setq entry symlink)) + (file-attribute-device-number (cdr entry))))) + (when symlink + (setq file-name symlink)) (setq size (+ size - (if (eq t (car (cdar entries))) - (eshell-du-sum-directory entry (1+ depth)) - (let ((file-size (file-attribute-size (cdar entries)))) - (prog1 - file-size - (if show-all - (eshell-print - (concat (eshell-du-size-string file-size) - entry "\n"))))))))))) - (setq entries (cdr entries))) - (if (or (not max-depth) - (= depth max-depth) - (= depth 0)) - (eshell-print (concat (eshell-du-size-string size) - (directory-file-name path) "\n"))) + (if (eq file-type t) ; This is a directory. + (apply #'eshell-du-sum-directory file-name + (when depth-remaining (1- depth-remaining)) + args) + (let ((file-size (file-attribute-size (cdr entry)))) + (when show-all + (funcall print-function file-size file-name)) + file-size)))))))) + (when (or (not depth-remaining) + (natnump depth-remaining)) + (funcall print-function size (directory-file-name path))) size)) (defun eshell/du (&rest args) "Implementation of \"du\" in Lisp, passing ARGS." - (setq args (if args - (eshell-stringify-list (flatten-tree args)) - '("."))) - (let ((ext-du (eshell-search-path "du"))) - (if (and ext-du - (not (catch 'have-ange-path - (dolist (arg args) - (if (string-equal - (file-remote-p (expand-file-name arg) 'method) "ftp") - (throw 'have-ange-path t)))))) - (throw 'eshell-external (eshell-external-command ext-du args)) - (eshell-eval-using-options - "du" args - '((?a "all" nil show-all - "write counts for all files, not just directories") - (nil "block-size" t block-size - "use SIZE-byte blocks (i.e., --block-size SIZE)") - (?b "bytes" nil by-bytes - "print size in bytes") - (?c "total" nil grand-total - "produce a grand total") - (?d "max-depth" t max-depth - "display data only this many levels of data") - (?h "human-readable" 1024 human-readable - "print sizes in human readable format") - (?H "si" 1000 human-readable - "likewise, but use powers of 1000 not 1024") - (?k "kilobytes" 1024 block-size - "like --block-size 1024") - (?L "dereference" nil dereference-links - "dereference all symbolic links") - (?m "megabytes" 1048576 block-size - "like --block-size 1048576") - (?s "summarize" 0 max-depth - "display only a total for each argument") - (?x "one-file-system" nil only-one-filesystem - "skip directories on different filesystems") - (nil "help" nil nil - "show this usage screen") - :external "du" - :usage "[OPTION]... FILE... + (let ((original-args args)) + (eshell-eval-using-options + "du" args + '((?a "all" nil show-all + "write counts for all files, not just directories") + (nil "block-size" t block-size + "use SIZE-byte blocks (i.e., --block-size SIZE)") + (?b "bytes" 1 block-size + "print size in bytes") + (?c "total" nil grand-total + "produce a grand total") + (?d "max-depth" t max-depth + "display data only this many levels of data") + (?h "human-readable" 1024 human-readable + "print sizes in human readable format") + (?H "si" 1000 human-readable + "likewise, but use powers of 1000 not 1024") + (?k "kilobytes" 1024 block-size + "like --block-size 1024") + (?L "dereference" nil dereference-links + "dereference all symbolic links") + (?m "megabytes" 1048576 block-size + "like --block-size 1048576") + (?s "summarize" 0 max-depth + "display only a total for each argument") + (?x "one-file-system" nil only-one-filesystem + "skip directories on different filesystems") + (nil "help" nil nil + "show this usage screen") + :external "du" + :usage "[OPTION]... FILE... Summarize disk usage of each FILE, recursively for directories.") - (unless by-bytes - (setq block-size (or block-size 1024))) - (if (and max-depth (stringp max-depth)) - (setq max-depth (string-to-number max-depth))) - ;; filesystem support means nothing under Windows - (if (eshell-under-windows-p) - (setq only-one-filesystem nil)) - (let ((size 0.0)) - (while args - (if only-one-filesystem - (setq only-one-filesystem - (file-attribute-device-number (eshell-file-attributes - (file-name-as-directory (car args)))))) - (setq size (+ size (eshell-du-sum-directory - (directory-file-name (car args)) 0))) - (setq args (cdr args))) - (if grand-total - (eshell-print (concat (eshell-du-size-string size) - "total\n")))))))) + ;; If possible, use the external "du" command. + (when-let* (((not (seq-some + (lambda (i) (and (stringp i) (file-remote-p i))) + args))) + (ext-du (eshell-search-path "du"))) + (throw 'eshell-external (eshell-external-command ext-du original-args))) + (setq block-size (or block-size 1024)) + (when (stringp block-size) + (setq block-size (string-to-number block-size))) + (when (stringp max-depth) + (setq max-depth (string-to-number max-depth))) + ;; Filesystem support means nothing under MS-Windows. + (when (eshell-under-windows-p) + (setq only-one-filesystem nil)) + (let ((size 0.0) + (seen-files (make-hash-table :test #'equal)) + (print-function + (lambda (size name) + (let ((size-str (eshell-printable-size size human-readable + block-size t))) + (eshell-print (concat (string-pad size-str 8) name "\n")))))) + (dolist (arg (or args '("."))) + (when only-one-filesystem + (setq only-one-filesystem + (file-attribute-device-number + (eshell-file-attributes (file-name-as-directory arg))))) + (setq size (+ size (eshell-du-sum-directory + (directory-file-name arg) max-depth + :print-function print-function :show-all show-all + :dereference-links dereference-links + :only-one-filesystem only-one-filesystem + :seen-files seen-files)))) + (when grand-total + (funcall print-function size "total")))))) (put 'eshell/du 'eshell-filename-arguments t) diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el index 0a032395fd3..263ec37a720 100644 --- a/lisp/eshell/em-xtra.el +++ b/lisp/eshell/em-xtra.el @@ -40,46 +40,37 @@ naturally accessible within Emacs." ;;; Functions: -(autoload 'eshell-parse-command "esh-cmd") - (defun eshell/expr (&rest args) "Implementation of expr, using the calc package." (calc-eval (eshell-flatten-and-stringify args))) -(defun eshell/substitute (&rest args) +(defun eshell/substitute (new old seq &rest args) "Easy front-end to `cl-substitute', for comparing lists of strings." - (apply #'cl-substitute (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-substitute new old seq :test #'equal args)) -(defun eshell/count (&rest args) +(defun eshell/count (item seq &rest args) "Easy front-end to `cl-count', for comparing lists of strings." - (apply #'cl-count (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-count item seq :test #'equal args)) -(defun eshell/mismatch (&rest args) +(defun eshell/mismatch (seq1 seq2 &rest args) "Easy front-end to `cl-mismatch', for comparing lists of strings." - (apply #'cl-mismatch (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-mismatch seq1 seq2 :test #'equal args)) -(defun eshell/union (&rest args) +(defun eshell/union (list1 list2 &rest args) "Easy front-end to `cl-union', for comparing lists of strings." - (apply #'cl-union (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-union list1 list2 :test #'equal args)) -(defun eshell/intersection (&rest args) +(defun eshell/intersection (list1 list2 &rest args) "Easy front-end to `cl-intersection', for comparing lists of strings." - (apply #'cl-intersection (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-intersection list1 list2 :test #'equal args)) -(defun eshell/set-difference (&rest args) +(defun eshell/set-difference (list1 list2 &rest args) "Easy front-end to `cl-set-difference', for comparing lists of strings." - (apply #'cl-set-difference (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-set-difference list1 list2 :test #'equal args)) -(defun eshell/set-exclusive-or (&rest args) +(defun eshell/set-exclusive-or (list1 list2 &rest args) "Easy front-end to `cl-set-exclusive-or', for comparing lists of strings." - (apply #'cl-set-exclusive-or (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-set-exclusive-or list1 list2 :test #'equal args)) (defalias 'eshell/ff #'find-name-dired) (defalias 'eshell/gf #'find-grep-dired) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index b441cbfc274..8a23bfe20b4 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -53,8 +53,6 @@ yield the values intended." (defvar eshell-current-quoted nil) (defvar eshell-current-argument-plain nil "If non-nil, the current argument is \"plain\", and not part of a command.") -(defvar eshell-inside-quote-regexp nil) -(defvar eshell-outside-quote-regexp nil) ;;; User Variables: @@ -89,66 +87,30 @@ If POS is nil, the location of point is checked." (memq (char-after pos) eshell-delimiter-argument-list)))) (defcustom eshell-parse-argument-hook - (list - ;; a term such as #<buffer NAME>, or #<process NAME> is a buffer - ;; or process reference - 'eshell-parse-special-reference - - ;; numbers convert to numbers if they stand alone - (lambda () - (when (and (not eshell-current-argument) - (not eshell-current-quoted) - (looking-at eshell-number-regexp) - (eshell-arg-delimiter (match-end 0))) - (goto-char (match-end 0)) - (let ((str (match-string 0))) - (if (> (length str) 0) - (add-text-properties 0 (length str) '(number t) str)) - str))) - - ;; parse any non-special characters, based on the current context - (lambda () - (unless eshell-inside-quote-regexp - (setq eshell-inside-quote-regexp - (format "[^%s]+" - (apply 'string eshell-special-chars-inside-quoting)))) - (unless eshell-outside-quote-regexp - (setq eshell-outside-quote-regexp - (format "[^%s]+" - (apply 'string eshell-special-chars-outside-quoting)))) - (when (looking-at (if eshell-current-quoted - eshell-inside-quote-regexp - eshell-outside-quote-regexp)) - (goto-char (match-end 0)) - (let ((str (match-string 0))) - (if str - (set-text-properties 0 (length str) nil str)) - str))) - - ;; whitespace or a comment is an argument delimiter - (lambda () - (let (comment-p) - (when (or (looking-at "[ \t]+") - (and (not eshell-current-argument) - (looking-at "#\\([^<'].*\\|$\\)") - (setq comment-p t))) - (if comment-p - (add-text-properties (match-beginning 0) (match-end 0) - '(comment t))) - (goto-char (match-end 0)) - (eshell-finish-arg)))) - - ;; parse backslash and the character after - 'eshell-parse-backslash - - ;; text beginning with ' is a literally quoted - 'eshell-parse-literal-quote - - ;; text beginning with " is interpolably quoted - 'eshell-parse-double-quote - - ;; argument delimiter - 'eshell-parse-delimiter) + '(;; A term such as #<buffer NAME>, or #<process NAME> is a buffer + ;; or process reference. + eshell-parse-special-reference + ;; Numbers convert to numbers if they stand alone. + eshell-parse-number + ;; Integers convert to numbers if they stand alone or are part of a + ;; range expression. + eshell-parse-integer + ;; Range tokens go between integers and denote a half-open range. + eshell-parse-range-token + ;; Parse any non-special characters, based on the current context. + eshell-parse-non-special + ;; Whitespace is an argument delimiter. + eshell-parse-whitespace + ;; ... so is a comment. + eshell-parse-comment + ;; Parse backslash and the character after. + eshell-parse-backslash + ;; Text beginning with ' is a literally quoted. + eshell-parse-literal-quote + ;; Text beginning with " is interpolably quoted. + eshell-parse-double-quote + ;; Delimiters that separate individual commands. + eshell-parse-delimiter) "Define how to process Eshell command line arguments. When each function on this hook is called, point will be at the current position within the argument list. The function should either @@ -218,13 +180,33 @@ Eshell will expand special refs like \"#<ARG...>\" into (defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the argument parsing code." (eshell-arg-mode) - (setq-local eshell-inside-quote-regexp nil) - (setq-local eshell-outside-quote-regexp nil) - (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook #'eshell-complete-special-reference nil t))) +(defvar eshell--non-special-inside-quote-regexp nil) +(defsubst eshell--non-special-inside-quote-regexp () + (or eshell--non-special-inside-quote-regexp + (setq-local eshell--non-special-inside-quote-regexp + (rx-to-string + `(+ (not (any ,@eshell-special-chars-inside-quoting))) t)))) + +(defvar eshell--non-special-outside-quote-regexp nil) +(defsubst eshell--non-special-outside-quote-regexp () + (or eshell--non-special-outside-quote-regexp + (setq-local eshell--non-special-outside-quote-regexp + (rx-to-string + `(+ (not (any ,@eshell-special-chars-outside-quoting))) t)))) + +(defvar eshell--after-range-token-regexp nil) +(defsubst eshell--after-range-token-regexp () + (or eshell--after-range-token-regexp + (setq-local eshell--after-range-token-regexp + (rx-to-string + `(or (any ,@eshell-special-chars-outside-quoting) + (regexp ,eshell-integer-regexp)) + t)))) + (defsubst eshell-escape-arg (string) "Return STRING with the `escaped' property on it." (if (stringp string) @@ -273,13 +255,15 @@ would produce (\"abc\" \"d\")." (defun eshell-concat-1 (quoted first second) "Concatenate FIRST and SECOND. -If QUOTED is nil and either FIRST or SECOND are numbers, try to -convert the result to a number as well." - (let ((result (concat (eshell-stringify first) (eshell-stringify second)))) - (if (and (not quoted) - (or (numberp first) (numberp second))) - (eshell-convert-to-number result) - result))) +If QUOTED is nil and either FIRST or SECOND are numberlike, try to mark +the result as a number as well." + (let ((result (concat (eshell-stringify first quoted) + (eshell-stringify second quoted)))) + (when (and (not quoted) + (or (numberp first) (eshell--numeric-string-p first) + (numberp second) (eshell--numeric-string-p second))) + (eshell-mark-numeric-string result)) + result)) (defun eshell-concat-groups (quoted &rest args) "Concatenate groups of arguments in ARGS and return the result. @@ -318,8 +302,8 @@ then the result will be: "If there are pending modifications to be made, make them now." (when eshell-current-argument (when eshell-arg-listified - (if-let ((grouped-terms (eshell-prepare-splice - eshell-current-argument))) + (if-let* ((grouped-terms (eshell-prepare-splice + eshell-current-argument))) (setq eshell-current-argument `(eshell-splice-args (eshell-concat-groups ,eshell-current-quoted @@ -441,6 +425,88 @@ Point is left at the end of the arguments." "A stub function that generates an error if a floating splice is found." (error "Splice operator is not permitted in this context")) +(defconst eshell--range-token (propertize ".." 'eshell-range t)) + +(defun eshell-parse-number () + "Parse a numeric argument. +Eshell can treat unquoted arguments matching `eshell-number-regexp' as +their numeric values." + (when (and (not eshell-current-argument) + (not eshell-current-quoted) + (looking-at eshell-number-regexp) + (eshell-arg-delimiter (match-end 0))) + (goto-char (match-end 0)) + (let ((str (match-string 0))) + (add-text-properties 0 (length str) '(number t) str) + str))) + +(defun eshell-parse-integer () + "Parse an integer argument." + (unless eshell-current-quoted + (let ((prev-token (if eshell-arg-listified + (car (last eshell-current-argument)) + eshell-current-argument))) + (when (and (memq prev-token `(nil ,eshell--range-token)) + (looking-at eshell-integer-regexp) + (or (eshell-arg-delimiter (match-end 0)) + (save-excursion + (goto-char (match-end 0)) + (looking-at-p (rx ".."))))) + (goto-char (match-end 0)) + (let ((str (match-string 0))) + (add-text-properties 0 (length str) '(number t) str) + str))))) + +(defun eshell-unmark-range-token (string) + (remove-text-properties 0 (length string) '(eshell-range) string)) + +(defun eshell-parse-range-token () + "Parse a range token. +This separates two integers (possibly as dollar expansions) and denotes +a half-open range." + (when (and (not eshell-current-quoted) + (looking-at (rx "..")) + (or (eshell-arg-delimiter (match-end 0)) + (save-excursion + (goto-char (match-end 0)) + (looking-at (eshell--after-range-token-regexp))))) + ;; If we parse multiple range tokens for a single argument, then + ;; they can't actually be range tokens. Unmark the result to + ;; indicate this. + (when (memq eshell--range-token + (if eshell-arg-listified + eshell-current-argument + (list eshell-current-argument))) + (add-hook 'eshell-current-modifiers #'eshell-unmark-range-token)) + (forward-char 2) + eshell--range-token)) + +(defun eshell-parse-non-special () + "Parse any non-special characters, depending on the current context." + (when (looking-at (if eshell-current-quoted + (eshell--non-special-inside-quote-regexp) + (eshell--non-special-outside-quote-regexp))) + (goto-char (match-end 0)) + (let ((str (match-string 0))) + (when str + (set-text-properties 0 (length str) nil str)) + str))) + +(defun eshell-parse-whitespace () + "Parse any whitespace, finishing the current argument. +These are treated as argument delimiters and so finish the current argument." + (when (looking-at "[ \t]+") + (goto-char (match-end 0)) + (eshell-finish-arg))) + +(defun eshell-parse-comment () + "Parse a comment, finishing the current argument." + (when (and (not eshell-current-argument) + (looking-at "#\\([^<'].*\\|$\\)")) + (add-text-properties (match-beginning 0) (match-end 0) '(comment t)) + (goto-char (match-end 0)) + (eshell-finish-arg))) + (defsubst eshell-looking-at-backslash-return (pos) "Test whether a backslash-return sequence occurs at POS." (declare (obsolete nil "30.1")) @@ -547,7 +613,7 @@ leaves point where it was." (apply #'concat (nreverse strings)))))) (defun eshell-parse-delimiter () - "Parse an argument delimiter, which is essentially a command operator." + "Parse a command delimiter, which is essentially a command operator." ;; this `eshell-operator' keyword gets parsed out by ;; `eshell-split-commands'. Right now the only possibility for ;; error is an incorrect output redirection specifier. diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index c9096b0d159..c0015745ad5 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -488,7 +488,7 @@ command hooks should be run before and after the command." (grouped-terms (eshell-prepare-splice terms))) (cond (grouped-terms - `(let ((new-terms (nconc ,@grouped-terms))) + `(let ((new-terms (append ,@grouped-terms))) (,sym (car new-terms) (cdr new-terms)))) ;; If no terms are spliced, use a simpler command form. ((cdr terms) @@ -526,6 +526,32 @@ the second is ignored." (defvar eshell--local-vars nil "List of locally bound vars that should take precedence over env-vars.") +(iter-defun eshell-for-iterate (&rest args) + "Iterate over the elements of each sequence in ARGS. +If ARGS is not a sequence, treat it as a list of one element." + (dolist (arg args) + (when (eshell--range-string-p arg) + (setq arg (eshell--string-to-range arg))) + (cond + ((eshell-range-p arg) + (let ((i (eshell-range-begin arg)) + (end (eshell-range-end arg))) + ;; NOTE: We could support unbounded ranges here, but those + ;; aren't very easy to use in Eshell yet. (We'd need something + ;; like the "break" statement for "for" loops.) + (cl-assert (and i end)) + (while (< i end) + (iter-yield i) + (cl-incf i)))) + ((stringp arg) + (iter-yield arg)) + ((listp arg) + (dolist (i arg) (iter-yield i))) + ((arrayp arg) + (dotimes (i (length arg)) (iter-yield (aref arg i)))) + (t + (iter-yield arg))))) + (defun eshell-rewrite-for-command (terms) "Rewrite a `for' command into its equivalent Eshell command form. Because the implementation of `for' relies upon conditional evaluation @@ -533,29 +559,21 @@ of its argument (i.e., use of a Lisp special form), it must be implemented via rewriting, rather than as a function." (if (and (equal (car terms) "for") (equal (nth 2 terms) "in")) - (let ((for-items (make-symbol "for-items")) + (let ((iter-symbol (intern (nth 1 terms))) (body (car (last terms)))) (setcdr (last terms 2) nil) - `(let ((,for-items - (append - ,@(mapcar - (lambda (elem) - (if (listp elem) - (eshell-term-as-value elem) - `(list ,elem))) - (nthcdr 3 terms))))) - (while ,for-items - (let ((,(intern (cadr terms)) (car ,for-items)) - (eshell--local-vars (cons ',(intern (cadr terms)) - eshell--local-vars))) - ,body) - (setq ,for-items (cdr ,for-items))))))) + `(let ((eshell--local-vars (cons ',iter-symbol eshell--local-vars))) + (iter-do (,iter-symbol (eshell-for-iterate + ,@(mapcar #'eshell-term-as-value + (nthcdr 3 terms)))) + ,body))))) (defun eshell-structure-basic-command (func names keyword test &rest body) "With TERMS, KEYWORD, and two NAMES, structure a basic command. The first of NAMES should be the positive form, and the second the negative. It's not likely that users should ever need to call this function." + (declare (obsolete nil "31.1")) (unless test (error "Missing test for `%s' command" keyword)) @@ -586,6 +604,12 @@ function." ;; Finally, create the form that represents this structured command. `(,func ,test ,@body)) +(defun eshell-silence-test-command (terms) + "If TERMS is a subcommand, wrap it in `eshell-commands' to silence output." + (if (memq (car-safe terms) '(eshell-as-subcommand eshell-lisp-command)) + `(eshell-command-success (eshell-commands ,terms t)) + terms)) + (defun eshell-rewrite-while-command (terms) "Rewrite a `while' command into its equivalent Eshell command form. Because the implementation of `while' relies upon conditional @@ -593,10 +617,13 @@ evaluation of its argument (i.e., use of a Lisp special form), it must be implemented via rewriting, rather than as a function." (when (and (stringp (car terms)) (member (car terms) '("while" "until"))) - (eshell-structure-basic-command - 'while '("while" "until") (car terms) - (cadr terms) - (caddr terms)))) + (unless (cadr terms) + (error "Missing test for `while' command")) + (let ((condition (eshell-silence-test-command (cadr terms)))) + (unless (string= (car terms) "while") + (setq condition `(not ,condition))) + `(while ,condition + ,(caddr terms))))) (defun eshell-rewrite-if-command (terms) "Rewrite an `if' command into its equivalent Eshell command form. @@ -605,18 +632,21 @@ evaluation of its argument (i.e., use of a Lisp special form), it must be implemented via rewriting, rather than as a function." (when (and (stringp (car terms)) (member (car terms) '("if" "unless"))) - (eshell-structure-basic-command - 'if '("if" "unless") (car terms) - (cadr terms) - (caddr terms) - (if (equal (nth 3 terms) "else") - ;; If there's an "else" keyword, allow chaining together - ;; multiple "if" forms... - (or (eshell-rewrite-if-command (nthcdr 4 terms)) - (nth 4 terms)) - ;; ... otherwise, only allow a single "else" block (without the - ;; keyword) as before for compatibility. - (nth 3 terms))))) + (unless (cadr terms) + (error "Missing test for `while' command")) + (let ((condition (eshell-silence-test-command (cadr terms))) + (then (caddr terms)) + (else (if (equal (nth 3 terms) "else") + ;; If there's an "else" keyword, allow chaining + ;; together multiple "if" forms... + (or (eshell-rewrite-if-command (nthcdr 4 terms)) + (nth 4 terms)) + ;; ... otherwise, only allow a single "else" block + ;; (without the keyword) as before for compatibility. + (nth 3 terms)))) + (unless (string= (car terms) "if") + (setq condition `(not ,condition))) + `(if ,condition ,then ,else)))) (defun eshell-set-exit-info (status &optional result) "Set the exit status and result for the last command. @@ -665,9 +695,10 @@ This means an exit code of 0." sep-terms (nreverse sep-terms)) (while results (cl-assert (car sep-terms)) - (setq final (eshell-structure-basic-command - 'if (string= (pop sep-terms) "&&") "if" - (pop results) final))) + (setq final `(,(if (string= (pop sep-terms) "&&") 'and 'or) + (eshell-command-success + (eshell-deferrable ,(pop results))) + ,final))) final)) (defun eshell-parse-subcommand-argument () @@ -751,12 +782,12 @@ if none)." ;; `eshell-do-eval' [Iterative evaluation]: ;; ;; @ Don't use special forms that conditionally evaluate their -;; arguments, such as `let*', unless Eshell explicitly supports -;; them. Eshell supports the following special forms: `catch', -;; `condition-case', `if', `let', `prog1', `progn', `quote', `setq', -;; `unwind-protect', and `while'. +;; arguments, such as `let*', unless Eshell explicitly supports them. +;; Eshell supports the following special forms: `and', `catch', +;; `condition-case', `if', `let', `or', `prog1', `progn', `quote', +;; `setq', `unwind-protect', and `while'. ;; -;; @ The two `special' variables are `eshell-current-handles' and +;; @ The two "special" variables are `eshell-current-handles' and ;; `eshell-current-subjob-p'. Bind them locally with a `let' if you ;; need to change them. Change them directly only if your intention ;; is to change the calling environment. @@ -803,6 +834,10 @@ returning it as (:eshell-background . PROCESSES)." (eshell-with-handles (,(not silent) 'append) ,object))) +(defmacro eshell-command-success (command) + "Return non-nil if COMMAND exits successfully." + `(progn ,command (eshell-exit-success-p))) + (defvar eshell-this-command-hook nil) (defmacro eshell-do-command (object) @@ -1182,6 +1217,18 @@ have been replaced by constants." (setcar form (car new-form)) (setcdr form (cdr new-form)))) (eshell-do-eval form synchronous-p)) + ((memq (car form) '(and or)) + (eshell-manipulate form (format-message "evaluating %s form" (car form)) + (let* ((result (eshell-do-eval (car args) synchronous-p)) + (value (cadr result))) + (if (or (null (cdr args)) + (if (eq (car form) 'or) value (not value))) + ;; If this is the last sub-form or we short-circuited, + ;; just return the result. + result + ;; Otherwise, remove this sub-form and re-evaluate. + (setcdr form (cdr args)) + (eshell-do-eval form synchronous-p))))) ((eq (car form) 'setcar) (setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p)) (eval form)) @@ -1317,8 +1364,8 @@ have been replaced by constants." (setcar form (car new-form)) (setcdr form (cdr new-form))) (eshell-do-eval form synchronous-p)) - (if-let (((memq (car form) eshell-deferrable-commands)) - (procs (eshell-make-process-list result))) + (if-let* (((memq (car form) eshell-deferrable-commands)) + (procs (eshell-make-process-list result))) (if synchronous-p (funcall #'eshell-wait-for-processes procs) (eshell-manipulate form "inserting ignore form" @@ -1341,9 +1388,9 @@ have been replaced by constants." (run-hook-wrapped 'eshell-named-command-hook (lambda (hook) - (when-let (((symbolp hook)) - (which-func (get hook 'eshell-which-function)) - (result (funcall which-func command))) + (when-let* (((symbolp hook)) + (which-func (get hook 'eshell-which-function)) + (result (funcall which-func command))) (throw 'found result)))) (eshell-plain-command--which name))) (error (eshell-error (format "which: %s\n" (cadr error))))))) @@ -1407,7 +1454,7 @@ COMMAND may result in an alias being executed, or a plain command." sym))) (defun eshell-plain-command--which (command) - (if-let ((sym (eshell--find-plain-lisp-command command))) + (if-let* ((sym (eshell--find-plain-lisp-command command))) (or (with-output-to-string (require 'help-fns) (princ (format "%s is " sym)) @@ -1419,7 +1466,7 @@ COMMAND may result in an alias being executed, or a plain command." "Insert output from a plain COMMAND, using ARGS. COMMAND may result in either a Lisp function being executed by name, or an external command." - (if-let ((sym (eshell--find-plain-lisp-command command))) + (if-let* ((sym (eshell--find-plain-lisp-command command))) (eshell-lisp-command sym args) (eshell-external-command command args))) @@ -1542,9 +1589,7 @@ a string naming a Lisp function." (while args (let ((arg (car args))) (cond - ((and numeric (stringp arg) (> (length arg) 0) - (text-property-any 0 (length arg) - 'number t arg)) + ((and numeric (eshell--numeric-string-p arg)) ;; If any of the arguments are flagged as ;; numbers waiting for conversion, convert ;; them now. diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index 443c39ff0d1..5c2b6b8d2ee 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -364,7 +364,7 @@ is not shared with the original handles." (declare (advertised-calling-convention (handles) "31.1")) (let ((dup-handles (make-vector eshell-number-of-handles nil))) (dotimes (idx eshell-number-of-handles) - (when-let ((handle (aref handles idx))) + (when-let* ((handle (aref handles idx))) (unless steal-p (cl-incf (cdar handle))) (aset dup-handles idx (list (car handle) t)))) @@ -373,7 +373,7 @@ is not shared with the original handles." (defun eshell-protect-handles (handles) "Protect the handles in HANDLES from a being closed." (dotimes (idx eshell-number-of-handles) - (when-let ((handle (aref handles idx))) + (when-let* ((handle (aref handles idx))) (cl-incf (cdar handle)))) handles) @@ -608,7 +608,7 @@ If TARGET is a virtual target (see `eshell-virtual-targets'), return an `eshell-generic-target' instance; otherwise, return a marker for a file named TARGET." (setq mode (or mode 'insert)) - (if-let ((redir (assoc raw-target eshell-virtual-targets))) + (if-let* ((redir (assoc raw-target eshell-virtual-targets))) (let (target) (catch 'eshell-null-device (setq target (if (nth 2 redir) @@ -699,7 +699,7 @@ If status is nil, prompt before killing." (cl-defmethod eshell-close-target ((target eshell-function-target) status) "Close an Eshell function TARGET." - (when-let ((close-function (eshell-function-target-close-function target))) + (when-let* ((close-function (eshell-function-target-close-function target))) (funcall close-function status))) (cl-defgeneric eshell-output-object-to-target (object target) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index ead5a20bec8..4f94934fccd 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -90,6 +90,10 @@ That is to say, the first time during an Emacs session." :type 'hook) +(defcustom eshell-after-initialize-hook nil + "A hook that gets run after an Eshell session has been fully initialized." + :type 'hook) + (defcustom eshell-exit-hook nil "A hook that is run whenever `eshell' is exited. This hook is only run if exiting actually kills the buffer." @@ -406,7 +410,7 @@ and the hook `eshell-exit-hook'." (when eshell-first-time-p (setq eshell-first-time-p nil) (run-hooks 'eshell-first-time-mode-hook)) - + (run-hooks 'eshell-after-initialize-hook) (run-hooks 'eshell-post-command-hook)) (put 'eshell-mode 'mode-class 'special) @@ -533,7 +537,7 @@ Putting this function on `eshell-pre-command-hook' will mimic Plan 9's (eshell-interactive-output-filter nil string))) (defsubst eshell-begin-on-new-line () - "This function outputs a newline if not at beginning of line." + "Print a newline if not at beginning of line." (save-excursion (goto-char eshell-last-output-end) (or (bolp) @@ -872,20 +876,61 @@ When run interactively, widen the buffer first." (goto-char (point-max)) (recenter -1)) -(defun eshell/clear (&optional scrollback) - "Scroll contents of eshell window out of sight, leaving a blank window. -If SCROLLBACK is non-nil, clear the scrollback contents." +(defun eshell-clear (&optional clear-scrollback) + "Scroll contents of the Eshell window out of sight, leaving a blank window. +If CLEAR-SCROLLBACK is non-nil (interactively, with the prefix +argument), clear the scrollback contents. + +Otherwise, the behavior depends on `eshell-scroll-show-maximum-output'. +If non-nil, fill newlines before the current prompt so that the prompt +is the last line in the window; if nil, just scroll the window so that +the prompt is the first line in the window." + (interactive "P") + (cond + (clear-scrollback + (let ((inhibit-read-only t)) + (widen) + (delete-region (point-min) (eshell-end-of-output)))) + (eshell-scroll-show-maximum-output + (save-excursion + (goto-char (eshell-end-of-output)) + (let ((inhibit-read-only t)) + (insert-and-inherit (make-string (window-size) ?\n)))) + (when (< (point) eshell-last-output-end) + (goto-char eshell-last-output-end))) + (t + (when (< (point) eshell-last-output-end) + (goto-char eshell-last-output-end)) + (set-window-start nil (eshell-end-of-output))))) + +(defun eshell/clear (&optional clear-scrollback) + "Scroll contents of the Eshell window out of sight, leaving a blank window. +If CLEAR-SCROLLBACK is non-nil, clear the scrollback contents. + +Otherwise, the behavior depends on `eshell-scroll-show-maximum-output'. +If non-nil, fill newlines before the current prompt so that the prompt +is the last line in the window; if nil, just scroll the window so that +the prompt is the first line in the window. + +This command is for use as an Eshell command (entered at the prompt); +for clearing the Eshell buffer from elsewhere (e.g. via +\\[execute-extended-command]), use `eshell-clear'." (interactive) - (if scrollback - (eshell/clear-scrollback) + (cond + ((null eshell-current-handles) + (eshell-clear clear-scrollback)) + (clear-scrollback + (let ((inhibit-read-only t)) + (erase-buffer))) + (eshell-scroll-show-maximum-output (let ((eshell-input-filter-functions nil)) - (insert (make-string (window-size) ?\n)) - (eshell-send-input)))) + (ignore (eshell-interactive-print (make-string (window-size) ?\n))))) + (t + (recenter 0)))) (defun eshell/clear-scrollback () - "Clear the scrollback content of the eshell window." - (let ((inhibit-read-only t)) - (erase-buffer))) + "Clear the scrollback content of the Eshell window." + (eshell/clear t)) (defun eshell-get-old-input (&optional use-current-region) "Return the command input on the current line. diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 87c95d39603..4755996c40c 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -595,7 +595,7 @@ PROC is the process that's exiting. STRING is the exit message." "buffer for external process `%s' already killed" proc))))) (funcall finish-io))) - (when-let ((entry (assq proc eshell-process-list))) + (when-let* ((entry (assq proc eshell-process-list))) (eshell-remove-process-entry entry)))))) (defun eshell-process-interact (func &optional all query) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 46083184aaa..57dd1353aab 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -343,15 +343,61 @@ If `eshell-convert-numeric-arguments', always return nil." (concat "\\`\\s-*" eshell-number-regexp "\\s-*\\'") string))) +(defsubst eshell--do-mark-numeric-string (string) + (put-text-property 0 (length string) 'number t string)) + +(defun eshell-mark-numeric-string (string) + "If STRING is convertible to a number, add a text property indicating so. +See `eshell-convertible-to-number-p'." + (when (eshell-convertible-to-number-p string) + (eshell--do-mark-numeric-string string)) + string) + +(defsubst eshell--numeric-string-p (string) + "Return non-nil if STRING has been marked as numeric." + (and (stringp string) + (length> string 0) + (not (text-property-not-all 0 (length string) 'number t string)))) + (defun eshell-convert-to-number (string) "Try to convert STRING to a number. If STRING doesn't look like a number (or `eshell-convert-numeric-arguments' is nil), just return STRING unchanged." + (declare (obsolete 'eshell-mark-numeric-string "31.1")) (if (eshell-convertible-to-number-p string) (string-to-number string) string)) +(cl-defstruct (eshell-range + (:constructor nil) + (:constructor eshell-range-create (begin end))) + "A half-open range from BEGIN to END." + begin end) + +(defsubst eshell--range-string-p (string) + "Return non-nil if STRING has been marked as a range." + (and (stringp string) + (text-property-any 0 (length string) 'eshell-range t string))) + +(defun eshell--string-to-range (string) + "Convert STRING to an `eshell-range' object." + (let* ((startpos (text-property-any 0 (length string) 'eshell-range t string)) + (endpos (next-single-property-change startpos 'eshell-range + string (length string))) + range-begin range-end) + (unless (= startpos 0) + (setq range-begin (substring string 0 startpos)) + (unless (eshell--numeric-string-p range-begin) + (user-error "range begin `%s' is not a number" range-begin)) + (setq range-begin (string-to-number range-begin))) + (unless (= endpos (length string)) + (setq range-end (substring string endpos)) + (unless (eshell--numeric-string-p range-end) + (user-error "range end `%s' is not a number" range-end)) + (setq range-end (string-to-number range-end))) + (eshell-range-create range-begin range-end))) + (defun eshell-convert (string &optional to-string) "Convert STRING into a more-native Lisp object. If TO-STRING is non-nil, always return a single string with @@ -366,7 +412,7 @@ trailing newlines removed. Otherwise, this behaves as follows: (cond ((not (stringp string)) (if to-string - (eshell-stringify string) + (eshell-stringify string t) string)) (to-string (string-trim-right string "\n+")) (t (let ((len (length string))) @@ -376,10 +422,10 @@ trailing newlines removed. Otherwise, this behaves as follows: (setq string (substring string 0 (1- len)))) (if (string-search "\n" string) (let ((lines (split-string string "\n"))) - (if (seq-every-p #'eshell-convertible-to-number-p lines) - (mapcar #'string-to-number lines) - lines)) - (eshell-convert-to-number string))))))) + (when (seq-every-p #'eshell-convertible-to-number-p lines) + (mapc #'eshell--do-mark-numeric-string lines)) + lines) + (eshell-mark-numeric-string string))))))) (defvar-local eshell-path-env (getenv "PATH") "Content of $PATH. @@ -451,7 +497,7 @@ Prepend remote identification of `default-directory', if any." (defun eshell-split-filename (filename) "Split a FILENAME into a list of file/directory components." (let* ((remote (file-remote-p filename)) - (filename (file-local-name filename)) + (filename (or (file-remote-p filename 'localname 'never) filename)) (len (length filename)) (index 0) (curr-start 0) parts) @@ -488,25 +534,27 @@ Prepend remote identification of `default-directory', if any." (define-obsolete-function-alias 'eshell-flatten-list #'flatten-tree "27.1") -(defun eshell-stringify (object) +(defun eshell-stringify (object &optional quoted) "Convert OBJECT into a string value." (cond ((stringp object) object) ((numberp object) - (number-to-string object)) + (if quoted + (number-to-string object) + (propertize (number-to-string object) 'number t))) ((and (eq object t) (not eshell-stringify-t)) nil) (t (string-trim-right (pp-to-string object))))) -(defsubst eshell-stringify-list (args) +(defsubst eshell-stringify-list (args &optional quoted) "Convert each element of ARGS into a string value." - (mapcar #'eshell-stringify args)) + (mapcar (lambda (i) (eshell-stringify i quoted)) args)) (defsubst eshell-list-to-string (list) "Convert LIST into a single string separated by spaces." - (mapconcat #'eshell-stringify list " ")) + (mapconcat (lambda (i) (eshell-stringify i t)) list " ")) (defsubst eshell-flatten-and-stringify (&rest args) "Flatten and stringify all of the ARGS into a single string." diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 059bba03ee4..f46f5ef839c 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -495,7 +495,7 @@ process any indices that come after the variable reference." (if splice (setq value `(eshell-list-to-string ,value) splice nil) - (setq value `(eshell-stringify ,value)))) + (setq value `(eshell-stringify ,value t)))) (setq value `(eshell-escape-arg ,value)) (when splice (setq value `(eshell-splice-args ,value))) @@ -567,7 +567,7 @@ Possible variable references are: (list (function (lambda () (delete-file ,temp) - (when-let ((buffer (get-file-buffer ,temp))) + (when-let* ((buffer (get-file-buffer ,temp))) (kill-buffer buffer))))))) (eshell-apply-indices ,temp indices ,eshell-current-quoted)) (goto-char (1+ end)))))) @@ -587,11 +587,11 @@ Possible variable references are: (or (eshell-unescape-inner-double-quote (point-max)) (cons (point) (point-max))) (let (name) - (when-let ((delim - (catch 'eshell-incomplete - (ignore (setq name (if (eq (char-after) ?\') - (eshell-parse-literal-quote) - (eshell-parse-double-quote))))))) + (when-let* ((delim + (catch 'eshell-incomplete + (ignore (setq name (if (eq (char-after) ?\') + (eshell-parse-literal-quote) + (eshell-parse-double-quote))))))) (throw 'eshell-incomplete (concat "$" delim))) (when name `(eshell-get-variable ,(eval name) indices ,eshell-current-quoted))))) @@ -607,8 +607,6 @@ Possible variable references are: (t (error "Invalid variable reference")))) -(defvar eshell-glob-function) - (defun eshell-parse-indices () "Parse and return a list of index-lists. This produces a series of Lisp forms to be processed by @@ -625,7 +623,7 @@ For example, \"[0 1][2]\" becomes: (forward-char) (eshell-with-temp-command (or (eshell-unescape-inner-double-quote end) (cons (point) end)) - (let (eshell-glob-function (eshell-current-quoted nil)) + (let ((eshell-current-quoted nil)) (setq indices (cons (eshell-parse-arguments (point-min) (point-max)) indices)))) @@ -643,24 +641,13 @@ in the cons is nil. Otherwise (including if INDEX is not a string), return the original value of INDEX." - (save-match-data - (cond - ((and (stringp index) (get-text-property 0 'number index)) - (string-to-number index)) - ((and (stringp index) - (not (text-property-any 0 (length index) 'escaped t index)) - (string-match (rx string-start - (group-n 1 (? (regexp eshell-integer-regexp))) - ".." - (group-n 2 (? (regexp eshell-integer-regexp))) - string-end) - index)) - (let ((begin (match-string 1 index)) - (end (match-string 2 index))) - (cons (unless (string-empty-p begin) (string-to-number begin)) - (unless (string-empty-p end) (string-to-number end))))) - (t - index)))) + (cond + ((eshell--numeric-string-p index) + (string-to-number index)) + ((eshell--range-string-p index) + (eshell--string-to-range index)) + (t + index))) (defun eshell-eval-indices (indices) "Evaluate INDICES, a list of index-lists generated by `eshell-parse-indices'." @@ -678,7 +665,7 @@ INDICES is a list of index-lists generated by `eshell-parse-indices'." "Get the value for the variable NAME. INDICES is a list of index-lists (see `eshell-parse-indices'). If QUOTED is non-nil, this was invoked inside double-quotes." - (if-let ((alias (assoc name eshell-variable-aliases-list))) + (if-let* ((alias (assoc name eshell-variable-aliases-list))) (let ((target (nth 1 alias))) (when (and (not (functionp target)) (consp target)) @@ -717,7 +704,7 @@ If QUOTED is non-nil, this was invoked inside double-quotes." NAME can be a string (in which case it refers to an environment variable or variable alias) or a symbol (in which case it refers to a Lisp variable)." - (if-let ((alias (assoc name eshell-variable-aliases-list))) + (if-let* ((alias (assoc name eshell-variable-aliases-list))) (let ((target (nth 1 alias))) (cond ((functionp target) @@ -765,11 +752,10 @@ Otherwise, each INT-OR-NAME refers to an element of the list value. Integers imply a direct index, and names, an associate lookup using `assoc'. -If QUOTED is non-nil, this was invoked inside double-quotes. -This affects the behavior of splitting strings: without quoting, -the split values are converted to numbers via -`eshell-convert-to-number' if possible; with quoting, they're -left as strings. +If QUOTED is non-nil, this was invoked inside double-quotes. This +affects the behavior of splitting strings: without quoting, the split +values are marked as numbers via `eshell-mark-numeric-string' if +possible; with quoting, they're left as plain strings. For example, to retrieve the second element of a user's record in '/etc/passwd', the variable reference would look like: @@ -785,7 +771,7 @@ For example, to retrieve the second element of a user's record in refs (cdr refs))) (setq value (split-string value separator)) (unless quoted - (setq value (mapcar #'eshell-convert-to-number value))))) + (setq value (mapcar #'eshell-mark-numeric-string value))))) (cond ((< (length refs) 0) (error "Invalid array variable index: %s" @@ -798,14 +784,6 @@ For example, to retrieve the second element of a user's record in (push (eshell-index-value value ref) new-value)) (setq value (nreverse new-value))))))) -(pcase-defmacro eshell-index-range (start end) - "A pattern that matches an Eshell index range. -EXPVAL should be a cons cell, with each slot containing either an -integer or nil. If this matches, bind the values of the sltos to -START and END." - (list '\` (cons (list '\, `(and (or (pred integerp) (pred null)) ,start)) - (list '\, `(and (or (pred integerp) (pred null)) ,end))))) - (defun eshell-index-value (value index) "Reference VALUE using the given INDEX." (let ((parsed-index (eshell-parse-index index))) @@ -813,15 +791,17 @@ START and END." (pcase parsed-index ((pred integerp) (ring-ref value parsed-index)) - ((eshell-index-range start end) + ((pred eshell-range-p) (let* ((len (ring-length value)) - (real-start (mod (or start 0) len)) + (begin (eshell-range-begin parsed-index)) + (end (eshell-range-end parsed-index)) + (real-begin (mod (or begin 0) len)) (real-end (mod (or end len) len))) (when (and (eq real-end 0) (not (eq end 0))) (setq real-end len)) (ring-convert-sequence-to-ring - (seq-subseq (ring-elements value) real-start real-end)))) + (seq-subseq (ring-elements value) real-begin real-end)))) (_ (error "Invalid index for ring: %s" index))) (pcase parsed-index @@ -829,8 +809,9 @@ START and END." (when (< parsed-index 0) (setq parsed-index (+ parsed-index (length value)))) (seq-elt value parsed-index)) - ((eshell-index-range start end) - (seq-subseq value (or start 0) end)) + ((pred eshell-range-p) + (seq-subseq value (or (eshell-range-begin parsed-index) 0) + (eshell-range-end parsed-index))) (_ ;; INDEX is some non-integer value, so treat VALUE as an alist. (cdr (assoc parsed-index value))))))) diff --git a/lisp/faces.el b/lisp/faces.el index 21c3e663c6e..de4f3a9f92b 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2097,7 +2097,7 @@ do that, use `get-text-property' and `get-char-property'." (let (faces) (when text ;; Try to get a face name from the buffer. - (when-let ((face (thing-at-point 'face))) + (when-let* ((face (thing-at-point 'face))) (push face faces))) ;; Add the named faces that the `read-face-name' or `face' property uses. (let ((faceprop (or (get-char-property (point) 'read-face-name) diff --git a/lisp/ffap.el b/lisp/ffap.el index e431aeed8b1..6a4915fb5a3 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -805,7 +805,7 @@ to extract substrings.") (declare-function project-root "project" (project)) (defun ffap-in-project (name) - (when-let (project (project-current)) + (when-let* ((project (project-current))) (file-name-concat (project-root project) name))) (defun ffap-home (name) (ffap-locate-file name t '("~"))) diff --git a/lisp/filenotify.el b/lisp/filenotify.el index 4e289d564c9..89711e6ca8a 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -76,7 +76,7 @@ struct.") "Remove DESCRIPTOR from `file-notify-descriptors'. DESCRIPTOR should be an object returned by `file-notify-add-watch'. If it is registered in `file-notify-descriptors', a `stopped' event is sent." - (when-let ((watch (gethash descriptor file-notify-descriptors))) + (when-let* ((watch (gethash descriptor file-notify-descriptors))) (unwind-protect ;; Send `stopped' event. (file-notify-handle-event diff --git a/lisp/files-x.el b/lisp/files-x.el index f70be5f7ff3..24a14144a69 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -239,18 +239,23 @@ This command deletes all existing settings of VARIABLE (except `mode' and `eval') and adds a new file-local VARIABLE with VALUE to the Local Variables list. -If there is no Local Variables list in the current file buffer -then this function adds the first line containing the string -`Local Variables:' and the last line containing the string `End:'." +If there is no Local Variables list in the current file buffer, +then this function adds it at the end of the file, with the first +line containing the string `Local Variables:' and the last line +containing the string `End:'. + +For adding local variables on the first line of a file, for example +for settings like `lexical-binding, which must be specified there, +use the `add-file-local-variable-prop-line' command instead." (interactive (let ((variable (read-file-local-variable "Add file-local variable"))) ;; Error before reading value. (if (equal variable 'lexical-binding) - (user-error "The `%s' variable must be set at the start of the file" + (user-error "Use `add-file-local-variable-prop-line' to add the `%s' variable" variable)) (list variable (read-file-local-variable-value variable) t))) (if (equal variable 'lexical-binding) - (user-error "The `%s' variable must be set at the start of the file" + (user-error "Use `add-file-local-variable-prop-line' to add the `%s' variable" variable)) (modify-file-local-variable variable value 'add-or-replace interactive)) @@ -394,10 +399,13 @@ from the -*- line ignoring the input argument VALUE." This command deletes all existing settings of VARIABLE (except `mode' and `eval') and adds a new file-local VARIABLE with VALUE to -the -*- line. +the -*- line at the beginning of the file. If there is no -*- line at the beginning of the current file buffer -then this function adds it." +then this function adds it. + +To add variables to the Local Variables list at the end of the file, +use the `add-file-local-variable' command instead." (interactive (let ((variable (read-file-local-variable "Add -*- file-local variable"))) (list variable (read-file-local-variable-value variable) t))) @@ -552,7 +560,7 @@ Returns the filename, expanded." (read-file-name "File: " (cond (dir) - ((when-let ((proj (and (featurep 'project) (project-current)))) + ((when-let* ((proj (and (featurep 'project) (project-current)))) (project-root proj)))) nil (lambda (fname) @@ -784,8 +792,8 @@ whose elements are of the form (VAR . VALUE). Unlike `connection-local-set-profile-variables' (which see), this function preserves the values of any existing variable definitions that aren't listed in VARIABLES." - (when-let ((existing-variables - (nreverse (connection-local-get-profile-variables profile)))) + (when-let* ((existing-variables + (nreverse (connection-local-get-profile-variables profile)))) (dolist (var variables) (setf (alist-get (car var) existing-variables) (cdr var))) (setq variables (nreverse existing-variables))) @@ -959,7 +967,7 @@ value is the default binding of the variable." (if (not criteria) ,variable (hack-connection-local-variables criteria) - (if-let ((result (assq ',variable connection-local-variables-alist))) + (if-let* ((result (assq ',variable connection-local-variables-alist))) (cdr result) ,variable)))) diff --git a/lisp/files.el b/lisp/files.el index a5c34f1f88e..db1e46b1ba4 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1274,23 +1274,42 @@ NOERROR is equal to `reload'), or otherwise emit a warning." (res (require feature filename (if (eq noerror 'reload) nil noerror)))) ;; If the `feature' was not yet provided, `require' just loaded the right ;; file, so we're done. - (when (eq lh load-history) + (when (and res (eq lh load-history)) ;; If `require' did nothing, we need to make sure that was warranted. - (let ((fn (locate-file (or filename (symbol-name feature)) - load-path (get-load-suffixes)))) + (let* ((fn (locate-file (or filename (symbol-name feature)) + load-path (get-load-suffixes) nil + )) ;; load-prefer-newer + ;; We used to look for `fn' in `load-history' with `assoc' + ;; which works in most cases, but in some cases (e.g. when + ;; `load-prefer-newer' is set) `locate-file' can return a + ;; different file than the file that `require' would load, + ;; so the file won't be found in `load-history' even though + ;; we did load "it". (bug#74040) + ;; So use a "permissive" search which doesn't pay attention to + ;; differences between file extensions. + (prefix (if (string-match + (concat (regexp-opt (get-load-suffixes)) "\\'") fn) + (concat (substring fn 0 (match-beginning 0)) ".") + fn)) + (lh load-history)) + (while (and lh (let ((file (car-safe (car lh)))) + (not (and file (string-prefix-p prefix file))))) + (setq lh (cdr lh))) (cond - ((assoc fn load-history) nil) ;We loaded the right file. + (lh nil) ;We loaded the right file. ((eq noerror 'reload) (load fn nil 'nomessage)) ((and fn (memq feature features)) - (funcall (if noerror #'warn #'error) - "Feature `%S' is now provided by a different file %s" - feature fn)) + (let ((oldfile (symbol-file feature 'provide))) + (funcall (if noerror #'warn #'error) + "Feature `%S' loaded from %S is now provided by %S" + feature (if oldfile (abbreviate-file-name oldfile)) + (abbreviate-file-name fn)))) (fn (funcall (if noerror #'warn #'error) - "Could not load file %s" fn)) + "Could not load file: %s" fn)) (t (funcall (if noerror #'warn #'error) - "Could not locate file %s in load path" + "Could not locate file in load path: %s" (or filename (symbol-name feature))))))) res)) @@ -1338,7 +1357,7 @@ Tip: You can use this expansion of remote identifier components returns a remote file name for file \"/bin/sh\" that has the same remote identifier as FILE but expanded; a name such as \"/sudo:root@myhost:/bin/sh\"." - (when-let ((handler (find-file-name-handler file 'file-remote-p))) + (when-let* ((handler (find-file-name-handler file 'file-remote-p))) (funcall handler 'file-remote-p file identification connected))) ;; Probably this entire variable should be obsolete now, in favor of @@ -2194,7 +2213,7 @@ if you want to permanently change your home directory after having started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; Get rid of the prefixes added by the automounter. (save-match-data ;FIXME: Why? - (if-let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (if-let* ((handler (find-file-name-handler filename 'abbreviate-file-name))) (funcall handler 'abbreviate-file-name filename) ;; Avoid treating /home/foo as /home/Foo during `~' substitution. (let ((case-fold-search (file-name-case-insensitive-p filename))) @@ -3033,8 +3052,6 @@ since only a single case-insensitive search through the alist is made." ;; Anyway, the following extensions are supported by gfortran. ("\\.f9[05]\\'" . f90-mode) ("\\.f0[38]\\'" . f90-mode) - ("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode - ("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode) ("\\.srt\\'" . srecode-template-mode) ("\\.prolog\\'" . prolog-mode) ("\\.tar\\'" . tar-mode) @@ -3529,7 +3546,7 @@ we don't actually set it to the same mode the buffer already has." ;; If we didn't, look for an interpreter specified in the first line. ;; As a special case, allow for things like "#!/bin/env perl", which ;; finds the interpreter anywhere in $PATH. - (when-let + (when-let* ((interp (save-excursion (goto-char (point-min)) (if (looking-at auto-mode-interpreter-regexp) @@ -4158,7 +4175,7 @@ all the specified local variables, but ignores any settings of \"mode:\"." ;; Handle `lexical-binding' and other special local ;; variables. (dolist (variable permanently-enabled-local-variables) - (when-let ((elem (assq variable result))) + (when-let* ((elem (assq variable result))) (push elem file-local-variables-alist))) (hack-local-variables-apply)))))) @@ -4416,7 +4433,7 @@ already the major mode." (pcase var ('mode (let ((mode (intern (concat (downcase (symbol-name val)) - "-mode")))) + "-mode")))) (set-auto-mode-0 mode t))) ('eval (pcase val @@ -6936,8 +6953,8 @@ buffer read-only, or keeping minor modes, etc.") (defun revert-buffer-restore-read-only () "Preserve read-only state for `revert-buffer'." - (when-let ((state (and (boundp 'read-only-mode--state) - (list read-only-mode--state)))) + (when-let* ((state (and (boundp 'read-only-mode--state) + (list read-only-mode--state)))) (lambda () (setq buffer-read-only (car state)) (setq-local read-only-mode--state (car state))))) @@ -8488,7 +8505,8 @@ If RESTART, restart Emacs after killing the current Emacs process." ;; Query the user for other things, perhaps. (run-hook-with-args-until-failure 'kill-emacs-query-functions) (or (null confirm) - (funcall confirm "Really exit Emacs? ")) + (funcall confirm (format "Really %s Emacs? " + (if restart "restart" "exit")))) (kill-emacs nil restart)))) (defun save-buffers-kill-terminal (&optional arg) diff --git a/lisp/find-dired.el b/lisp/find-dired.el index 5b4ee0d70aa..13c8bf722c3 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -431,9 +431,9 @@ specifies what to use in place of \"-ls\" as the final argument." "Sort entries in *Find* buffer by file name lexicographically." (sort-subr nil 'forward-line 'end-of-line (lambda () - (when-let ((start - (next-single-property-change - (point) 'dired-filename))) + (when-let* ((start + (next-single-property-change + (point) 'dired-filename))) (buffer-substring-no-properties start (line-end-position)))))) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 7b077a826bf..d2232f72c55 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -1846,11 +1846,11 @@ See `font-lock-ignore' for the possible rules." (defun font-lock--filter-keywords (keywords) "Filter a list of KEYWORDS using `font-lock-ignore'." - (if-let ((rules (mapcan (pcase-lambda (`(,mode . ,rules)) - (when (or (and (boundp mode) mode) - (derived-mode-p mode)) - (copy-sequence rules))) - font-lock-ignore))) + (if-let* ((rules (mapcan (pcase-lambda (`(,mode . ,rules)) + (when (or (and (boundp mode) mode) + (derived-mode-p mode)) + (copy-sequence rules))) + font-lock-ignore))) (seq-filter (lambda (keyword) (not (font-lock--match-keyword `(or ,@rules) keyword))) keywords) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 5151ad1c1b8..8243e4e632b 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -2419,8 +2419,8 @@ fill width." (defun article-emojize-symbols () "Display symbols (that have an emoji version) as emojis." (interactive nil gnus-article-mode) - (when-let ((font (and (display-multi-font-p) - (car (internal-char-font nil ?😀))))) + (when-let* ((font (and (display-multi-font-p) + (car (internal-char-font nil ?😀))))) (save-excursion (let ((inhibit-read-only t)) (goto-char (point-min)) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 71bfaa639fa..788de46efda 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3852,6 +3852,7 @@ If given numerical prefix, toggle the N next groups." (gnus-group-next-group 1)) (defun gnus-group-toggle-subscription (group &optional silent) + "Prompt for group, and toggle its subscription." (interactive (list (gnus-group-completing-read nil nil (gnus-read-active-file-p))) gnus-group-mode) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index 558ad8648ca..b73fa268da2 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -357,7 +357,7 @@ If it is down, start it up (again)." (funcall (gnus-get-function gnus-command-method 'close-server) (nth 1 gnus-command-method) (nthcdr 2 gnus-command-method)) - (when-let ((elem (assoc gnus-command-method gnus-opened-servers))) + (when-let* ((elem (assoc gnus-command-method gnus-opened-servers))) (setf (nth 1 elem) 'closed))))) (defun gnus-request-list (command-method) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index c25163ac770..ca82546ef82 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -1012,7 +1012,7 @@ Responsible for handling and, or, and parenthetical expressions.") (let (clauses) (mapc (lambda (item) - (when-let ((expr (gnus-search-transform-expression engine item))) + (when-let* ((expr (gnus-search-transform-expression engine item))) (push expr clauses))) query) (mapconcat #'identity (reverse clauses) " "))) @@ -1486,7 +1486,7 @@ Returns a list of [group article score] vectors." (push (list f-name article group score) artlist))))) ;; Are we running an additional grep query? - (when-let ((grep-reg (alist-get 'grep query))) + (when-let* ((grep-reg (alist-get 'grep query))) (setq artlist (gnus-search-grep-search engine artlist grep-reg))) (when (>= gnus-verbose 7) @@ -1717,9 +1717,9 @@ cross our fingers for the rest of it." (let (clauses) (mapc (lambda (item) - (when-let ((expr (if (consp (car-safe item)) - (gnus-search-transform engine item) - (gnus-search-transform-expression engine item)))) + (when-let* ((expr (if (consp (car-safe item)) + (gnus-search-transform engine item) + (gnus-search-transform-expression engine item)))) (push expr clauses))) query) (mapconcat #'identity (reverse clauses) " "))) @@ -2141,8 +2141,8 @@ remaining string, then adds all that to the top-level spec." (assoc-string srv gnus-search-engine-instance-alist t)) (nth 1 engine-config) (cdr-safe (assoc (car method) gnus-search-default-engines)) - (when-let ((old (assoc 'nnir-search-engine - (cddr method)))) + (when-let* ((old (assoc 'nnir-search-engine + (cddr method)))) (nnheader-message 8 "\"nnir-search-engine\" is no longer a valid parameter") (nth 1 old)))) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 33582ce5dbf..cebeb6d4c37 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -9374,9 +9374,9 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (let ((pt (point)) urls primary) (while (forward-button 1 nil nil t) (setq pt (point)) - (when-let ((w (button-at pt)) - (u (or (button-get w 'shr-url) - (get-text-property pt 'gnus-string)))) + (when-let* ((w (button-at pt)) + (u (or (button-get w 'shr-url) + (get-text-property pt 'gnus-string)))) (when (string-match-p "\\`[[:alpha:]]+://" u) (if (and gnus-collect-urls-primary-text (null primary) (string= gnus-collect-urls-primary-text (button-label w))) @@ -9404,7 +9404,7 @@ See `gnus-collect-urls'." (let* ((parsed (url-generic-parse-url url)) (host (url-host parsed)) (rest (concat (url-filename parsed) - (when-let ((target (url-target parsed))) + (when-let* ((target (url-target parsed))) (concat "#" target))))) (concat host (string-truncate-left rest (- max (length host))))))) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index f1fc129a505..62a090bd9df 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -3119,9 +3119,9 @@ g -- Group name." "Check whether GROUP supports function FUNC. GROUP can either be a string (a group name) or a select method." (ignore-errors - (when-let ((method (if (stringp group) - (car (gnus-find-method-for-group group)) - group))) + (when-let* ((method (if (stringp group) + (car (gnus-find-method-for-group group)) + group))) (unless (featurep method) (require method)) (fboundp (intern (format "%s-%s" method func)))))) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index d52ed9662a7..b49e3f9d9ca 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4934,8 +4934,8 @@ If you always want Gnus to send messages in one piece, set (let ((addr (message-fetch-field hdr))) (when (stringp addr) (dolist (address (mail-header-parse-addresses addr t)) - (when-let ((warning (textsec-suspicious-p - address 'email-address-header))) + (when-let* ((warning (textsec-suspicious-p + address 'email-address-header))) (unless (y-or-n-p (format "Suspicious address: %s; send anyway?" warning)) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index e3bc3932529..70cefe5bb49 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -507,7 +507,7 @@ type detected." (when (and (consp (car cont)) (= (length cont) 1) content-type) - (when-let ((spec (assq 'type (cdr (car cont))))) + (when-let* ((spec (assq 'type (cdr (car cont))))) (setcdr spec content-type))) (when (fboundp 'libxml-parse-html-region) (setq cont (mapcar #'mml-expand-all-html-into-multipart-related cont))) @@ -943,7 +943,7 @@ type detected." (when parameters (let ((cont (copy-sequence cont))) ;; Set the file name to what's specified by the user. - (when-let ((recipient-filename (cdr (assq 'recipient-filename cont)))) + (when-let* ((recipient-filename (cdr (assq 'recipient-filename cont)))) (setcdr cont (cons (cons 'filename recipient-filename) (cdr cont)))) @@ -1039,6 +1039,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (message-remove-header "Content-Transfer-Encoding"))) (autoload 'message-encode-message-body "message") +(autoload 'message-narrow-to-headers-or-head "message") (declare-function message-narrow-to-headers-or-head "message" ()) ;;;###autoload diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el index f6885abb634..a9f6b9179de 100644 --- a/lisp/gnus/nnatom.el +++ b/lisp/gnus/nnatom.el @@ -56,12 +56,12 @@ (insert-file-contents feed) (mm-url-insert-file-contents (concat "https://" feed))) (file-error (nnheader-report nnatom-backend (cdr e))) - (:success (when-let ((data (if (libxml-available-p) - (libxml-parse-xml-region - (point-min) (point-max)) - (car (xml-parse-region - (point-min) (point-max))))) - (authors (list 'authors))) + (:success (when-let* ((data (if (libxml-available-p) + (libxml-parse-xml-region + (point-min) (point-max)) + (car (xml-parse-region + (point-min) (point-max))))) + (authors (list 'authors))) (when (eq (car data) 'top) (setq data (assq 'feed data))) (dom-add-child-before data authors) @@ -93,8 +93,8 @@ (when (eq (car data) 'feed) (setq data (dom-children data))) ;; Discard any children between/after entries. (while (and data (not (eq (car-safe (car data)) 'entry))) (pop data)) - (when-let ((article (car data)) - (auths (list 'authors)) (links (list 'links))) + (when-let* ((article (car data)) + (auths (list 'authors)) (links (list 'links))) (dom-add-child-before article links) (dom-add-child-before article auths) (dolist (child (cddddr article) `(,article . ,(cdr data))) @@ -126,7 +126,7 @@ (defun nnatom--read-article-or-group-authors (article-or-group) "Return the authors of ARTICLE-OR-GROUP, or nil." - (when-let + (when-let* ((a (mapconcat (lambda (author) (let* ((name (nnatom--dom-line (dom-child-by-tag author 'name))) @@ -161,14 +161,14 @@ return the subject. Otherwise, return nil." (defun nnatom--read-publish (article) "Return the date and time ARTICLE was published, or nil." - (when-let (d (dom-child-by-tag article 'published)) + (when-let* ((d (dom-child-by-tag article 'published))) (date-to-time (nnatom--dom-line d)))) (defvoo nnatom-read-publish-date-function #'nnatom--read-publish nil nnfeed-read-publish-date-function) (defun nnatom--read-update (article) "Return the date and time of the last update to ARTICLE, or nil." - (when-let (d (dom-child-by-tag article 'updated)) + (when-let* ((d (dom-child-by-tag article 'updated))) (date-to-time (nnatom--dom-line d)))) (defvoo nnatom-read-update-date-function #'nnatom--read-update nil nnfeed-read-update-date-function) @@ -178,56 +178,56 @@ return the subject. Otherwise, return nil." (let ((alt 0) (rel 0) (sel 0) (enc 0) (via 0) (aut 0)) (mapcan (lambda (link) - (when-let ((l (car-safe link))) + (when-let* ((l (car-safe link))) (or - (when-let (((eq l 'content)) - (src (dom-attr link 'src)) - (label (concat "Link" - (and (< 1 (cl-incf alt)) - (format " %s" alt))))) + (when-let* (((eq l 'content)) + (src (dom-attr link 'src)) + (label (concat "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt))))) `(((("text/plain") . ,(format "%s: %s\n" label src)) (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " src label))))) - (when-let (((or (eq l 'author) (eq l 'contributor))) - (name (nnatom--dom-line (dom-child-by-tag link 'name))) - (name (if (string-blank-p name) - (concat "Author" - (and (< 1 (cl-incf aut)) - (format " %s" aut))) - name)) - (uri (nnatom--dom-line (dom-child-by-tag link 'uri))) - ((not (string-blank-p uri)))) + (when-let* (((or (eq l 'author) (eq l 'contributor))) + (name (nnatom--dom-line (dom-child-by-tag link 'name))) + (name (if (string-blank-p name) + (concat "Author" + (and (< 1 (cl-incf aut)) + (format " %s" aut))) + name)) + (uri (nnatom--dom-line (dom-child-by-tag link 'uri))) + ((not (string-blank-p uri)))) `(((("text/plain") . ,(format "%s: %s\n" name uri)) (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " uri name))))) - (when-let (((eq l 'link)) - (attrs (dom-attributes link)) - (label (or (cdr (assq 'title attrs)) - (pcase (cdr (assq 'rel attrs)) - ("related" - (concat "Related" - (and (< 1 (cl-incf rel)) - (format " %s" rel)))) - ("self" - (concat "More" - (and (< 1 (cl-incf sel)) - (format " %s" sel)))) - ("enclosure" - (concat "Enclosure" - (and (< 1 (cl-incf enc)) - (format " %s" enc)))) - ("via" - (concat "Source" - (and (< 1 (cl-incf via)) - (format " %s" via)))) - (_ (if-let - ((lang (cdr (assq 'hreflang link)))) - (format "Link (%s)" lang) - (concat - "Link" - (and (< 1 (cl-incf alt)) - (format " %s" alt)))))))) - (link (cdr (assq 'href attrs)))) + (when-let* (((eq l 'link)) + (attrs (dom-attributes link)) + (label (or (cdr (assq 'title attrs)) + (pcase (cdr (assq 'rel attrs)) + ("related" + (concat "Related" + (and (< 1 (cl-incf rel)) + (format " %s" rel)))) + ("self" + (concat "More" + (and (< 1 (cl-incf sel)) + (format " %s" sel)))) + ("enclosure" + (concat "Enclosure" + (and (< 1 (cl-incf enc)) + (format " %s" enc)))) + ("via" + (concat "Source" + (and (< 1 (cl-incf via)) + (format " %s" via)))) + (_ (if-let* + ((lang (cdr (assq 'hreflang link)))) + (format "Link (%s)" lang) + (concat + "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt)))))))) + (link (cdr (assq 'href attrs)))) `(((("text/plain") . ,(format "%s: %s\n" label link)) (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " link label)))))))) diff --git a/lisp/gnus/nnfeed.el b/lisp/gnus/nnfeed.el index 2d33d4c813b..e8c1fdb8e2b 100644 --- a/lisp/gnus/nnfeed.el +++ b/lisp/gnus/nnfeed.el @@ -277,8 +277,8 @@ group names to their data, which should be a vector of the form (defun nnfeed--read-server (server) "Read SERVER's information from storage." - (if-let ((f (nnfeed--server-file server)) - ((file-readable-p f))) + (if-let* ((f (nnfeed--server-file server)) + ((file-readable-p f))) (with-temp-buffer (insert-file-contents f) (goto-char (point-min)) @@ -287,10 +287,10 @@ group names to their data, which should be a vector of the form (defun nnfeed--write-server (server) "Write SERVER's information to storage." - (if-let ((f (nnfeed--server-file server)) - ((file-writable-p f))) - (if-let ((s (gethash server nnfeed-servers)) - ((hash-table-p s))) + (if-let* ((f (nnfeed--server-file server)) + ((file-writable-p f))) + (if-let* ((s (gethash server nnfeed-servers)) + ((hash-table-p s))) (with-temp-file f (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n") (prin1 s (current-buffer)) @@ -346,8 +346,8 @@ If GROUP is omitted or nil, parse the entire FEED." (and desc (aset g 5 desc)) (while-let ((article (funcall nnfeed-read-article-function cg stale)) (article (prog1 (car article) (setq cg (cdr article))))) - (when-let ((id (funcall nnfeed-read-id-function article)) - (id (format "<%s@%s.%s>" id name nnfeed-backend))) + (when-let* ((id (funcall nnfeed-read-id-function article)) + (id (format "<%s@%s.%s>" id name nnfeed-backend))) (let* ((num (gethash id ids)) (update (funcall nnfeed-read-update-date-function article)) (prev-update (aref (gethash num articles @@ -423,14 +423,14 @@ Each value in this table should be a vector of the form (defun nnfeed--group-data (group server) "Get parsed data for GROUP from SERVER." - (when-let ((server (nnfeed--server-address server)) - (s (gethash server nnfeed-servers)) - ((hash-table-p s))) + (when-let* ((server (nnfeed--server-address server)) + (s (gethash server nnfeed-servers)) + ((hash-table-p s))) (gethash group s))) (defun nnfeed-retrieve-article (article group) "Retrieve headers for ARTICLE from GROUP." - (if-let ((a (gethash article (aref group 2)))) + (if-let* ((a (gethash article (aref group 2)))) (insert (format "221 %s Article retrieved. From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n" article @@ -441,10 +441,10 @@ From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n" (insert "404 Article not found.\n.\n"))) (deffoo nnfeed-retrieve-headers (articles &optional group server _fetch-old) - (if-let ((server (or server (nnfeed--current-server-no-prefix))) - (g (or (nnfeed--group-data group server) - `[ nil ,nnfeed-group-article-ids ,nnfeed-group-articles - nil nil nil]))) + (if-let* ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + `[ nil ,nnfeed-group-article-ids ,nnfeed-group-articles + nil nil nil]))) (with-current-buffer nntp-server-buffer (erase-buffer) (or (and (stringp (car articles)) @@ -513,27 +513,27 @@ by `nnfeed-read-parts-function'), and links (as returned by Only HEADERS of a type included in MIME are considered." (concat (mapconcat (lambda (header) - (when-let ((m (car-safe header)) - ((member m mime))) + (when-let* ((m (car-safe header)) + ((member m mime))) (format "%s: %s\n" m (cdr header)))) headers) "\n" (funcall nnfeed-print-content-function content headers links))) (deffoo nnfeed-request-article (article &optional group server to-buffer) - (if-let ((server (or server (nnfeed--current-server-no-prefix))) - (g (or (nnfeed--group-data group server) - (and (setq group nnfeed-group) - `[ nil ,nnfeed-group-article-ids - ,nnfeed-group-articles - ,nnfeed-group-article-max-num - ,nnfeed-group-article-min-num nil]))) - (num (or (and (stringp article) - (gethash article (aref g 1))) - (and (numberp article) article))) - ((and (<= num (aref g 3)) - (>= num (aref g 4)))) - (a (gethash num (aref g 2)))) + (if-let* ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + (and (setq group nnfeed-group) + `[ nil ,nnfeed-group-article-ids + ,nnfeed-group-articles + ,nnfeed-group-article-max-num + ,nnfeed-group-article-min-num nil]))) + (num (or (and (stringp article) + (gethash article (aref g 1))) + (and (numberp article) article))) + ((and (<= num (aref g 3)) + (>= num (aref g 4)))) + (a (gethash num (aref g 2)))) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) (let* ((links (aref a 5)) @@ -575,12 +575,12 @@ Only HEADERS of a type included in MIME are considered." (deffoo nnfeed-request-group (group &optional server fast _info) (with-current-buffer nntp-server-buffer (erase-buffer) - (if-let ((server (or server (nnfeed--current-server-no-prefix))) - (g (or (if fast (nnfeed--group-data group server) - (setq server (nnfeed--parse-feed server group)) - (and (hash-table-p server) (gethash group server))) - `[ ,group ,(make-hash-table :test 'equal) - ,(make-hash-table :test 'eql) 0 1 ""]))) + (if-let* ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (if fast (nnfeed--group-data group server) + (setq server (nnfeed--parse-feed server group)) + (and (hash-table-p server) (gethash group server))) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) 0 1 ""]))) (progn (setq nnfeed-group group nnfeed-group-article-ids (aref g 1) @@ -608,10 +608,10 @@ Only HEADERS of a type included in MIME are considered." (deffoo nnfeed-request-list (&optional server) (with-current-buffer nntp-server-buffer (erase-buffer) - (when-let ((p (point)) - (s (nnfeed--parse-feed - (or server (nnfeed--current-server-no-prefix)))) - ((hash-table-p s))) + (when-let* ((p (point)) + (s (nnfeed--parse-feed + (or server (nnfeed--current-server-no-prefix)))) + ((hash-table-p s))) (maphash (lambda (group g) (insert (format "\"%s\" %s %s y\n" group (aref g 3) (aref g 4)))) @@ -634,12 +634,12 @@ Only HEADERS of a type included in MIME are considered." ;; separates the group name from the description with either a tab or a space. (defun nnfeed--group-description (name group) "Return a description line for a GROUP called NAME." - (when-let ((desc (aref group 5)) - ((not (string-blank-p desc)))) + (when-let* ((desc (aref group 5)) + ((not (string-blank-p desc)))) (insert name "\t" desc "\n"))) (deffoo nnfeed-request-group-description (group &optional server) - (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (when-let* ((server (or server (nnfeed--current-server-no-prefix))) (g (nnfeed--group-data group server))) (with-current-buffer nntp-server-buffer (erase-buffer) @@ -647,38 +647,38 @@ Only HEADERS of a type included in MIME are considered." t))) (deffoo nnfeed-request-list-newsgroups (&optional server) - (when-let ((server (or server (nnfeed--current-server-no-prefix))) - (s (gethash (nnfeed--server-address server) nnfeed-servers)) - ((hash-table-p s))) + (when-let* ((server (or server (nnfeed--current-server-no-prefix))) + (s (gethash (nnfeed--server-address server) nnfeed-servers)) + ((hash-table-p s))) (with-current-buffer nntp-server-buffer (erase-buffer) (maphash #'nnfeed--group-description s) t))) (deffoo nnfeed-request-rename-group (group new-name &optional server) - (when-let ((server (or server (nnfeed--current-server-no-prefix))) - (a (nnfeed--server-address server)) - (s (or (gethash a nnfeed-servers) - (and ; Open the server to add it to `nnfeed-servers' - (save-match-data - (nnfeed-open-server - server - (cdr ; Get defs and backend. - (assoc a (cdr (assq nnfeed-backend nnoo-state-alist)) - (lambda (car key) - (and (stringp car) - (string-match - (concat - "\\`\\(\\(nn[[:alpha:]]+\\)\\+\\)?" - (regexp-quote key) "\\'") - car) - (setq server car))))) - (if (match-string 1 server) - (intern (match-string 2 server)) 'nnfeed))) - (gethash a nnfeed-servers)))) - (g (or (nnfeed--group-data group a) - `[ ,group ,(make-hash-table :test 'equal) - ,(make-hash-table :test 'eql) nil 1 ""]))) + (when-let* ((server (or server (nnfeed--current-server-no-prefix))) + (a (nnfeed--server-address server)) + (s (or (gethash a nnfeed-servers) + (and ; Open the server to add it to `nnfeed-servers' + (save-match-data + (nnfeed-open-server + server + (cdr ; Get defs and backend. + (assoc a (cdr (assq nnfeed-backend nnoo-state-alist)) + (lambda (car key) + (and (stringp car) + (string-match + (concat + "\\`\\(\\(nn[[:alpha:]]+\\)\\+\\)?" + (regexp-quote key) "\\'") + car) + (setq server car))))) + (if (match-string 1 server) + (intern (match-string 2 server)) 'nnfeed))) + (gethash a nnfeed-servers)))) + (g (or (nnfeed--group-data group a) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) nil 1 ""]))) (puthash new-name g s) (puthash group new-name nnfeed-group-names) (remhash group s) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index e11d063f6ee..dbe0aba176f 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -554,10 +554,10 @@ as unread by Gnus.") (mapcar (lambda (art) (cons art - (when-let ((modtime - (file-attribute-modification-time - (file-attributes - (concat dir (int-to-string art)))))) + (when-let* ((modtime + (file-attribute-modification-time + (file-attributes + (concat dir (int-to-string art)))))) (time-convert modtime 'list)))) new))) ;; Make Gnus mark all new articles as unread. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index eb2c822aa30..c87c86bae84 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -325,7 +325,7 @@ handling of autoloaded functions." (defun help-find-source () "Switch to a buffer visiting the source of what is being described in *Help*." (interactive) - (if-let ((help-buffer (get-buffer "*Help*"))) + (if-let* ((help-buffer (get-buffer "*Help*"))) (with-current-buffer help-buffer (help-view-source)) (error "No *Help* buffer found"))) @@ -649,7 +649,7 @@ the C sources, too." (lambda (entry level) (when (symbolp map) (setq map (symbol-function map))) - (when-let ((elem (assq entry (cdr map)))) + (when-let* ((elem (assq entry (cdr map)))) (when (> level 0) (push sep string)) (if (eq (nth 1 elem) 'menu-item) @@ -1003,8 +1003,8 @@ TYPE indicates the namespace and is `fun' or `var'." (defun help-fns--mention-first-release (object type) (when (symbolp object) - (when-let ((first (or (help-fns--first-release-override object type) - (help-fns--first-release object)))) + (when-let* ((first (or (help-fns--first-release-override object type) + (help-fns--first-release object)))) (with-current-buffer standard-output (insert (format " Probably introduced at or before Emacs version %s.\n" first)))))) @@ -1016,8 +1016,8 @@ TYPE indicates the namespace and is `fun' or `var'." #'help-fns--mention-shortdoc-groups) (defun help-fns--mention-shortdoc-groups (object) (require 'shortdoc) - (when-let ((groups (and (symbolp object) - (shortdoc-function-groups object)))) + (when-let* ((groups (and (symbolp object) + (shortdoc-function-groups object)))) (let ((start (point)) (times 0)) (with-current-buffer standard-output @@ -1618,7 +1618,7 @@ it is displayed along with the global value." (defun help-fns--customize-variable-version (variable) (when (custom-variable-p variable) ;; Note variable's version or package version. - (when-let ((output (describe-variable-custom-version-info variable))) + (when-let* ((output (describe-variable-custom-version-info variable))) (princ output)))) (add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local) @@ -1864,7 +1864,7 @@ If FRAME is omitted or nil, use the selected frame." (add-hook 'help-fns-describe-face-functions #'help-fns--face-custom-version-info) (defun help-fns--face-custom-version-info (face _frame) - (when-let ((version-info (describe-variable-custom-version-info face 'face))) + (when-let* ((version-info (describe-variable-custom-version-info face 'face))) (insert version-info) (terpri))) @@ -2223,7 +2223,7 @@ is enabled in the Help buffer." (lambda (_) (describe-function major)))) (insert " mode") - (when-let ((file-name (find-lisp-object-file-name major nil))) + (when-let* ((file-name (find-lisp-object-file-name major nil))) (insert (format " defined in %s:\n\n" (buttonize (help-fns-short-filename file-name) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 6a808088cec..33b8eccab2c 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -646,7 +646,7 @@ that." ;; Quoted symbols (save-excursion (while (re-search-forward help-xref-symbol-regexp nil t) - (when-let ((sym (intern-soft (match-string 9)))) + (when-let* ((sym (intern-soft (match-string 9)))) (if (match-string 8) (delete-region (match-beginning 8) (match-end 8)) diff --git a/lisp/help.el b/lisp/help.el index 5efe207c624..ef0b7ffc01d 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -883,8 +883,8 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (let ((otherstring (help--key-description-fontified untranslated))) (if (equal string otherstring) string - (if-let ((char-name (and (length= string 1) - (char-to-name (aref string 0))))) + (if-let* ((char-name (and (length= string 1) + (char-to-name (aref string 0))))) (format "%s '%s' (translated from %s)" string char-name otherstring) (format "%s (translated from %s)" string otherstring))))))) @@ -1668,7 +1668,7 @@ Return nil if the key sequence is too long." (cond ((or (stringp definition) (vectorp definition)) (if translation (insert (concat (key-description definition nil) - (when-let ((char-name (char-to-name (aref definition 0)))) + (when-let* ((char-name (char-to-name (aref definition 0)))) (format "\t%s" char-name)) "\n")) ;; These should be rare nowadays, replaced by `kmacro's. @@ -1884,79 +1884,6 @@ in `help--describe-map-tree'." (- width (car elem)) (mod width tab-width)))))) -;;;; This Lisp version is 100 times slower than its C equivalent: -;; -;; (defun help--describe-vector -;; (vector prefix transl partial shadow entire-map mention-shadow) -;; "Insert in the current buffer a description of the contents of VECTOR. -;; -;; PREFIX a prefix key which leads to the keymap that this vector is -;; in. -;; -;; If PARTIAL, it means do not mention suppressed commands -;; (that assumes the vector is in a keymap). -;; -;; SHADOW is a list of keymaps that shadow this map. If it is -;; non-nil, look up the key in those maps and don't mention it if it -;; is defined by any of them. -;; -;; ENTIRE-MAP is the vector in which this vector appears. -;; If the definition in effect in the whole map does not match -;; the one in this vector, we ignore this one." -;; ;; Converted from describe_vector in keymap.c. -;; (let* ((first t) -;; (idx 0)) -;; (while (< idx (length vector)) -;; (let* ((val (aref vector idx)) -;; (definition (keymap--get-keyelt val nil)) -;; (start-idx idx) -;; this-shadowed -;; found-range) -;; (when (and definition -;; ;; Don't mention suppressed commands. -;; (not (and partial -;; (symbolp definition) -;; (get definition 'suppress-keymap))) -;; ;; If this binding is shadowed by some other map, -;; ;; ignore it. -;; (not (and shadow -;; (help--shadow-lookup shadow (vector start-idx) t nil) -;; (if mention-shadow -;; (prog1 nil (setq this-shadowed t)) -;; t))) -;; ;; Ignore this definition if it is shadowed by an earlier -;; ;; one in the same keymap. -;; (not (and entire-map -;; (not (eq (lookup-key entire-map (vector start-idx) t) -;; definition))))) -;; (when first -;; (insert "\n") -;; (setq first nil)) -;; (when (and prefix (> (length prefix) 0)) -;; (insert (format "%s" prefix))) -;; (insert (help--key-description-fontified (vector start-idx) prefix)) -;; ;; Find all consecutive characters or rows that have the -;; ;; same definition. -;; (while (equal (keymap--get-keyelt (aref vector (1+ idx)) nil) -;; definition) -;; (setq found-range t) -;; (setq idx (1+ idx))) -;; ;; If we have a range of more than one character, -;; ;; print where the range reaches to. -;; (when found-range -;; (insert " .. ") -;; (when (and prefix (> (length prefix) 0)) -;; (insert (format "%s" prefix))) -;; (insert (help--key-description-fontified (vector idx) prefix))) -;; (if transl -;; (help--describe-translation definition) -;; (help--describe-command definition)) -;; (when this-shadowed -;; (goto-char (1- (point))) -;; (insert " (binding currently shadowed)") -;; (goto-char (1+ (point)))))) -;; (setq idx (1+ idx))))) - (declare-function x-display-pixel-height "xfns.c" (&optional terminal)) (declare-function x-display-pixel-width "xfns.c" (&optional terminal)) diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el index e9956222e9c..b500c664ff1 100644 --- a/lisp/hfy-cmap.el +++ b/lisp/hfy-cmap.el @@ -835,7 +835,7 @@ Loads the variable `hfy-rgb-txt-color-map', which is used by (when (and rgb-txt (file-readable-p rgb-txt)) (setq rgb-buffer (find-file-noselect rgb-txt 'nowarn)) - (when-let ((result (hfy-cmap--parse-buffer rgb-buffer))) + (when-let* ((result (hfy-cmap--parse-buffer rgb-buffer))) (setq hfy-rgb-txt-color-map result)) (kill-buffer rgb-buffer)))) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 33b68b96ff2..4cbe3c4ba15 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -857,7 +857,7 @@ specification, with the same structure as an element of the list "Move point to the filter group whose name is NAME." (interactive (list (ibuffer-read-filter-group-name "Jump to filter group: "))) - (if-let ((it (assoc name (ibuffer-current-filter-groups-with-position)))) + (if-let* ((it (assoc name (ibuffer-current-filter-groups-with-position)))) (goto-char (cdr it)) (error "No filter group with name %s" name))) @@ -868,7 +868,7 @@ The group will be added to `ibuffer-filter-group-kill-ring'." (interactive (list (ibuffer-read-filter-group-name "Kill filter group: " t))) (when (equal name "Default") (error "Can't kill default filter group")) - (if-let ((it (assoc name ibuffer-filter-groups))) + (if-let* ((it (assoc name ibuffer-filter-groups))) (progn (push (copy-tree it) ibuffer-filter-group-kill-ring) (setq ibuffer-filter-groups (ibuffer-remove-alist @@ -883,9 +883,9 @@ The group will be added to `ibuffer-filter-group-kill-ring'." "Kill the filter group at point. See also `ibuffer-kill-filter-group'." (interactive "P\np") - (if-let ((it (save-excursion - (ibuffer-forward-line 0) - (get-text-property (point) 'ibuffer-filter-group-name)))) + (if-let* ((it (save-excursion + (ibuffer-forward-line 0) + (get-text-property (point) 'ibuffer-filter-group-name)))) (ibuffer-kill-filter-group it) (funcall (if interactive-p #'call-interactively #'funcall) #'kill-line arg))) @@ -944,7 +944,7 @@ prompt for NAME, and use the current filters." (list (read-from-minibuffer "Save current filter groups as: ") ibuffer-filter-groups))) - (if-let ((it (assoc name ibuffer-saved-filter-groups))) + (if-let* ((it (assoc name ibuffer-saved-filter-groups))) (setcdr it groups) (push (cons name groups) ibuffer-saved-filter-groups)) (ibuffer-maybe-save-stuff)) @@ -1116,7 +1116,7 @@ Interactively, prompt for NAME, and use the current filters." (list (read-from-minibuffer "Save current filters as: ") ibuffer-filtering-qualifiers))) - (if-let ((it (assoc name ibuffer-saved-filters))) + (if-let* ((it (assoc name ibuffer-saved-filters))) (setcdr it filters) (push (cons name filters) ibuffer-saved-filters)) (ibuffer-maybe-save-stuff)) @@ -1296,7 +1296,7 @@ For example, for a buffer associated with file '/a/b/c.d', this matches against '/a/b/c.d'." (:description "full file name" :reader (read-from-minibuffer "Filter by full file name (regexp): ")) - (when-let ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) (string-match qualifier it))) ;;;###autoload (autoload 'ibuffer-filter-by-basename "ibuf-ext") @@ -1308,7 +1308,7 @@ matches against `c.d'." (:description "file basename" :reader (read-from-minibuffer "Filter by file name, without directory part (regex): ")) - (when-let ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) (string-match qualifier (file-name-nondirectory it)))) ;;;###autoload (autoload 'ibuffer-filter-by-file-extension "ibuf-ext") @@ -1321,7 +1321,7 @@ pattern. For example, for a buffer associated with file (:description "filename extension" :reader (read-from-minibuffer "Filter by filename extension without separator (regex): ")) - (when-let ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) (string-match qualifier (or (file-name-extension it) "")))) ;;;###autoload (autoload 'ibuffer-filter-by-directory "ibuf-ext") @@ -1656,7 +1656,7 @@ a prefix argument reverses the meaning of that variable." "Compare BUFFER with its associated file, if any. Unlike `diff-no-select', insert output into current buffer without erasing it." - (when-let ((old (buffer-file-name buffer))) + (when-let* ((old (buffer-file-name buffer))) (defvar diff-use-labels) (let* ((new buffer) (oldtmp (diff-file-local-copy old)) @@ -1822,7 +1822,7 @@ When BUF nil, default to the buffer at current line." (interactive (list (read-regexp "Mark by file name (regexp)"))) (ibuffer-mark-on-buffer (lambda (buf) - (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((name (with-current-buffer buf (ibuffer-buffer-file-name)))) ;; Match on the displayed file name (which is abbreviated). (string-match-p regexp (ibuffer--abbreviate-file-name name)))))) @@ -1843,7 +1843,7 @@ Otherwise buffers whose name matches an element of (or (memq mode ibuffer-never-search-content-mode) (cl-dolist (x ibuffer-never-search-content-name nil) - (when-let ((found (string-match x (buffer-name buf)))) + (when-let* ((found (string-match x (buffer-name buf)))) (cl-return found))))) (setq res nil)) (t diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index 1fd94967836..f04c436f6e2 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -35,7 +35,7 @@ If TEST returns non-nil, bind `it' to the value, and evaluate TRUE-BODY. Otherwise, evaluate forms in FALSE-BODY as if in `progn'. Compare with `if'." - (declare (obsolete if-let "29.1") (indent 2)) + (declare (obsolete if-let* "29.1") (indent 2)) (let ((sym (make-symbol "ibuffer-aif-sym"))) `(let ((,sym ,test)) (if ,sym @@ -47,8 +47,8 @@ Compare with `if'." (defmacro ibuffer-awhen (test &rest body) "Evaluate BODY if TEST returns non-nil. During evaluation of body, bind `it' to the value returned by TEST." - (declare (indent 1) (obsolete when-let "29.1")) - `(when-let ((it ,test)) + (declare (indent 1) (obsolete when-let* "29.1")) + `(when-let* ((it ,test)) ,@body)) (defmacro ibuffer-save-marks (&rest body) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index c1e7788d2e8..405fb98d4d4 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -832,7 +832,7 @@ width and the longest string in LIST." (let ((pt (save-excursion (mouse-set-point event) (point)))) - (if-let ((it (get-text-property (point) 'ibuffer-filter-group-name))) + (if-let* ((it (get-text-property (point) 'ibuffer-filter-group-name))) (ibuffer-toggle-marks it) (goto-char pt) (let ((mark (ibuffer-current-mark))) @@ -1263,7 +1263,7 @@ become unmarked. If point is on a group name, then this function operates on that group." (interactive) - (when-let ((it (get-text-property (point) 'ibuffer-filter-group-name))) + (when-let* ((it (get-text-property (point) 'ibuffer-filter-group-name))) (setq group it)) (let ((count (ibuffer-map-lines @@ -1336,7 +1336,7 @@ If point is on a group name, this function operates on that group." (when (and movement (< movement 0)) (setq arg (- arg))) (ibuffer-forward-line 0) - (if-let ((it (get-text-property (point) 'ibuffer-filter-group-name))) + (if-let* ((it (get-text-property (point) 'ibuffer-filter-group-name))) (progn (require 'ibuf-ext) (ibuffer-mark-on-buffer #'identity mark it)) @@ -1540,7 +1540,7 @@ If point is on a group name, this function operates on that group." ;; `ibuffer-inline-columns' alist and insert it ;; into our generated code. Otherwise, we just ;; generate a call to the column function. - (if-let ((it (assq sym ibuffer-inline-columns))) + (if-let* ((it (assq sym ibuffer-inline-columns))) (nth 1 it) `(or (,sym buffer mark) ""))) ;; You're not expected to understand this. Hell, I @@ -1737,7 +1737,7 @@ If point is on a group name, this function operates on that group." (cond ((zerop total) "No processes") ((= 1 total) "1 process") (t (format "%d processes" total)))))) - (if-let ((it (get-buffer-process buffer))) + (if-let* ((it (get-buffer-process buffer))) (format "(%s %s)" it (process-status it)) "")) @@ -1872,8 +1872,8 @@ the buffer object itself and the current mark symbol." (let ((result (if (buffer-live-p (ibuffer-current-buffer)) (when (or (null group) - (when-let ((it (get-text-property - (point) 'ibuffer-filter-group))) + (when-let* ((it (get-text-property + (point) 'ibuffer-filter-group))) (equal group it))) (save-excursion (funcall function diff --git a/lisp/image.el b/lisp/image.el index 3d60b485c6b..ce97eeb3ca1 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -1434,7 +1434,7 @@ Also return nil if rotation is not a multiples of 90 degrees (0, 90, Return a copy of :original-map transformed based on IMAGE's :scale, :rotation, and :flip. When IMAGE's :original-map is nil, return nil. When :rotation is not a multiple of 90, return copy of :original-map." - (when-let ((map (image-property image :original-map))) + (when-let* ((map (image-property image :original-map))) (setq map (copy-tree map t)) (let* ((size (image-size image t)) ;; The image can be scaled for many reasons (:scale, @@ -1469,7 +1469,7 @@ When :rotation is not a multiple of 90, return copy of :original-map." "Return original map for IMAGE. If IMAGE lacks :map property, return nil. When there is no transformation, return copy of :map." - (when-let ((original-map (image-property image :map))) + (when-let* ((original-map (image-property image :map))) (setq original-map (copy-tree original-map t)) (let* ((size (image-size image t)) ;; The image can be scaled for many reasons (:scale, diff --git a/lisp/image/exif.el b/lisp/image/exif.el index 2c1c4850bef..86e47da8bcc 100644 --- a/lisp/image/exif.el +++ b/lisp/image/exif.el @@ -127,10 +127,10 @@ from the return value of this function." (encode-coding-region (point-min) (point-max) buffer-file-coding-system dest)) - (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) + (when-let* ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) (exif--parse-exif-chunk app1)))) (save-excursion - (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) + (when-let* ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) (exif--parse-exif-chunk app1)))))) (defun exif-field (field data) diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index 2e2010e06f0..10f1598912a 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -85,7 +85,7 @@ like \"image/gif\"." (image-converter-initialize) ;; When image-converter was customized (when (and image-converter (not image-converter-regexp)) - (when-let ((formats (image-converter--probe image-converter))) + (when-let* ((formats (image-converter--probe image-converter))) (setq image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")) (setq image-converter-file-name-extensions formats))) @@ -136,8 +136,8 @@ converted image data as a string." (extra-converter (gethash type image-converter--extra-converters))) (if extra-converter (funcall extra-converter source format) - (when-let ((err (image-converter--convert - image-converter source format))) + (when-let* ((err (image-converter--convert + image-converter source format))) (error "%s" err)))) (if (listp image) ;; Return an image object that's the same as we were passed, @@ -217,8 +217,8 @@ converted image data as a string." "Find an installed image converter Emacs can use." (catch 'done (dolist (elem image-converter--converters) - (when-let ((formats (image-converter--filter-formats - (image-converter--probe (car elem))))) + (when-let* ((formats (image-converter--filter-formats + (image-converter--probe (car elem))))) (setq image-converter (car elem) image-converter-regexp (concat "\\." (regexp-opt formats) "\\'") image-converter-file-name-extensions formats) diff --git a/lisp/image/image-dired-util.el b/lisp/image/image-dired-util.el index e9048e157cd..e620c688b1b 100644 --- a/lisp/image/image-dired-util.el +++ b/lisp/image/image-dired-util.el @@ -125,7 +125,7 @@ See also `image-dired-thumbnail-storage' and (defun image-dired-file-name-at-point () "Get abbreviated file name for thumbnail or display image at point." - (when-let ((f (image-dired-original-file-name))) + (when-let* ((f (image-dired-original-file-name))) (abbreviate-file-name f))) (defun image-dired-associated-dired-buffer () diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index 1928b0a2955..83745e88f09 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -663,7 +663,7 @@ only useful if `image-dired-track-movement' is nil." (image-dired--with-dired-buffer (if (not (dired-goto-file file-name)) (message "Could not find image in Dired buffer for tracking") - (when-let (window (image-dired-get-buffer-window (current-buffer))) + (when-let* ((window (image-dired-get-buffer-window (current-buffer)))) (set-window-point window (point))))))) (defun image-dired-toggle-movement-tracking () @@ -863,7 +863,7 @@ for. The default is to look for `dired-marker-char'." "Run BODY in associated Dired buffer with point on current file's line. Should be called from commands in `image-dired-thumbnail-mode'." (declare (indent defun) (debug t)) - `(if-let ((file-name (image-dired-original-file-name))) + `(if-let* ((file-name (image-dired-original-file-name))) (image-dired--with-dired-buffer (when (dired-goto-file file-name) ,@body)) @@ -871,9 +871,9 @@ Should be called from commands in `image-dired-thumbnail-mode'." (defmacro image-dired--with-thumbnail-buffer (&rest body) (declare (indent defun) (debug t)) - `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + `(if-let* ((buf (get-buffer image-dired-thumbnail-buffer))) (with-current-buffer buf - (if-let ((win (get-buffer-window buf))) + (if-let* ((win (get-buffer-window buf))) (with-selected-window win ,@body) ,@body)) @@ -932,7 +932,7 @@ You probably want to use this together with `image-dired-track-original-file'." (interactive nil image-dired-thumbnail-mode) (image-dired--with-dired-buffer - (if-let ((window (image-dired-get-buffer-window (current-buffer)))) + (if-let* ((window (image-dired-get-buffer-window (current-buffer)))) (progn (if (not (equal (selected-frame) (window-frame window))) (select-frame-set-input-focus (window-frame window))) @@ -1090,7 +1090,7 @@ This is used by `image-dired-slideshow-start'." (defun image-dired--slideshow-step () "Step to the next image in a slideshow." - (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (if-let* ((buf (get-buffer image-dired-thumbnail-buffer))) (with-current-buffer buf (image-dired-display-next)) (image-dired--slideshow-stop))) @@ -1272,7 +1272,7 @@ which is based on `image-mode'." (cur-win (selected-window))) (when buf (kill-buffer buf)) - (when-let ((buf (find-file-noselect file nil t))) + (when-let* ((buf (find-file-noselect file nil t))) (pop-to-buffer buf) (rename-buffer image-dired-display-image-buffer) (if (string-match (image-file-name-regexp) file) diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 79682e921b0..399971b5ac0 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -131,14 +131,14 @@ continue running even after exiting Emacs." The returned function kills any process named PROCESS-NAME owned by the current effective user id." (lambda () - (when-let ((procs - (seq-filter (lambda (p) (let-alist p - (and (= .euid (user-uid)) - (equal .comm process-name)))) - (mapcar (lambda (pid) - (cons (cons 'pid pid) - (process-attributes pid))) - (list-system-processes))))) + (when-let* ((procs + (seq-filter (lambda (p) (let-alist p + (and (= .euid (user-uid)) + (equal .comm process-name)))) + (mapcar (lambda (pid) + (cons (cons 'pid pid) + (process-attributes pid))) + (list-system-processes))))) (dolist (proc procs) (let-alist proc (when (y-or-n-p (format "Kill \"%s\" process with PID %d?" .comm .pid)) @@ -297,7 +297,7 @@ order in which they appear.") (dolist (setter wallpaper--default-setters) (wallpaper-debug "Testing setter %s" (wallpaper-setter-name setter)) (when (and (executable-find (wallpaper-setter-command setter)) - (if-let ((pred (wallpaper-setter-predicate setter))) + (if-let* ((pred (wallpaper-setter-predicate setter))) (funcall pred) t)) (wallpaper-debug "Found setter %s" (wallpaper-setter-name setter)) @@ -305,12 +305,12 @@ order in which they appear.") (defun wallpaper--find-command () "Return the appropriate command to set the wallpaper." - (when-let ((setter (wallpaper--find-setter))) + (when-let* ((setter (wallpaper--find-setter))) (wallpaper-setter-command setter))) (defun wallpaper--find-command-args () "Return command line arguments matching `wallpaper-command'." - (when-let ((setter (wallpaper--find-setter))) + (when-let* ((setter (wallpaper--find-setter))) (wallpaper-setter-args setter))) @@ -449,23 +449,23 @@ This function is meaningful only on X and is used only there." (if (and .name (member .source '("XRandr" "XRandR 1.5" "Gdk"))) .name "0")) - (if-let ((name - (and (getenv "DISPLAY") - (or - (cdr (assq 'name - (progn - (x-open-connection (getenv "DISPLAY")) - (car (display-monitor-attributes-list - (car (last (terminal-list)))))))) - (and (executable-find "xrandr") - (with-temp-buffer - (call-process "xrandr" nil t nil) - (goto-char (point-min)) - (re-search-forward (rx bol - (group (+ (not (in " \n")))) - " connected") - nil t) - (match-string 1))))))) + (if-let* ((name + (and (getenv "DISPLAY") + (or + (cdr (assq 'name + (progn + (x-open-connection (getenv "DISPLAY")) + (car (display-monitor-attributes-list + (car (last (terminal-list)))))))) + (and (executable-find "xrandr") + (with-temp-buffer + (call-process "xrandr" nil t nil) + (goto-char (point-min)) + (re-search-forward (rx bol + (group (+ (not (in " \n")))) + " connected") + nil t) + (match-string 1))))))) ;; Prefer "0" to "default" as that works in XFCE. (if (equal name "default") "0" name) (read-string (format-prompt "Monitor name" nil))))) diff --git a/lisp/info-look.el b/lisp/info-look.el index a84026ac8b9..b3db9bfdecc 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -327,7 +327,7 @@ string of `info-lookup-alist'. If optional argument QUERY is non-nil, query for the help mode." (let* ((mode (cond (query (info-lookup-change-mode topic)) - ((when-let + ((when-let* ((info (info-lookup->mode-value topic (info-lookup-select-mode)))) (info-lookup--expand-info info)) @@ -791,7 +791,7 @@ Return nil if there is nothing appropriate in the buffer near point." (defun info-complete (topic mode) "Try to complete a help item." (barf-if-buffer-read-only) - (when-let ((info (info-lookup->mode-value topic mode))) + (when-let* ((info (info-lookup->mode-value topic mode))) (info-lookup--expand-info info)) (let ((data (info-lookup-completions-at-point topic mode))) (if (null data) @@ -1226,7 +1226,7 @@ Return nil if there is nothing appropriate in the buffer near point." :ignore-case t :regexp "[^][()`'‘’,:\" \t\n]+" :parse-rule (lambda () - (when-let ((symbol (get-text-property (point) 'custom-data))) + (when-let* ((symbol (get-text-property (point) 'custom-data))) (symbol-name symbol))) :other-modes '(emacs-lisp-mode)) diff --git a/lisp/info.el b/lisp/info.el index 6e386207afe..9025fd13363 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -667,7 +667,7 @@ in `Info-file-supports-index-cookies-list'." (goto-char (point-min)) (condition-case () (if (and (re-search-forward - "makeinfo[ \n]version[ \n]\\([0-9]+.[0-9]+\\)" + "\\(?:makeinfo\\|texi2any\\)[ \n]version[ \n]\\([0-9]+.[0-9]+\\)" (line-beginning-position 4) t) (not (version< (match-string 1) "4.7"))) (setq found t)) @@ -823,10 +823,10 @@ Select the window used, if it has been made." ;; If we just created the Info buffer, go to the directory. (Info-directory)))) - (when-let ((window (display-buffer buffer - (if other-window - '(nil (inhibit-same-window . t)) - '(display-buffer-same-window))))) + (when-let* ((window (display-buffer buffer + (if other-window + '(nil (inhibit-same-window . t)) + '(display-buffer-same-window))))) (select-window window)))) @@ -2020,7 +2020,7 @@ See `completing-read' for a description of arguments and usage." (lambda (string pred action) (complete-with-action action - (when-let ((file2 (Info-find-file file1 'noerror t))) + (when-let* ((file2 (Info-find-file file1 'noerror t))) (Info-build-node-completions file2)) string pred)) nodename predicate code)))) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el index e8cd869a571..7ede6ac8058 100644 --- a/lisp/international/emoji.el +++ b/lisp/international/emoji.el @@ -328,14 +328,14 @@ the name is not known." (let ((glyph (cadr alist))) ;; Store all the emojis for later retrieval by ;; the search feature. - (when-let ((name (emoji--name glyph))) + (when-let* ((name (emoji--name glyph))) (setf (gethash (downcase name) emoji--all-bases) glyph)) (if (display-graphic-p) ;; Remove glyphs we don't have in graphical displays. (if (let ((char (elt glyph 0))) (if emoji--font (font-has-char-p emoji--font char) - (when-let ((font (car (internal-char-font nil char)))) + (when-let* ((font (car (internal-char-font nil char)))) (setq emoji--font font)))) (setq alist (cdr alist)) ;; Remove the element. @@ -575,7 +575,7 @@ the name is not known." (setq recent (delete glyph recent)) (push glyph recent) ;; Shorten the list. - (when-let ((tail (nthcdr 30 recent))) + (when-let* ((tail (nthcdr 30 recent))) (setcdr tail nil)) (setf (multisession-value emoji--recent) recent))) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 77efcf0b590..19d1c92196f 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -658,7 +658,7 @@ and delete the network process." (defun jsonrpc--call-deferred (connection) "Call CONNECTION's deferred actions, who may again defer themselves." - (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) + (when-let* ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) (jsonrpc--event connection 'internal :log-text (format "re-attempting deferred requests %s" @@ -689,7 +689,7 @@ and delete the network process." (jsonrpc--continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) - (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) + (when-let* ((p (slot-value connection '-autoport-inferior))) (delete-process p)) (funcall (jsonrpc--on-shutdown connection) connection))))) (defvar jsonrpc--in-process-filter nil @@ -807,7 +807,7 @@ Also cancel \"deferred actions\" if DEFERRED-SPEC. Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" (with-slots ((conts -continuations) (defs -deferred-actions)) conn (if deferred-spec (remhash deferred-spec defs)) - (when-let ((ass (assq id conts))) + (when-let* ((ass (assq id conts))) (cl-destructuring-bind (_ _ _ _ timer) ass (when timer (cancel-timer timer))) (setf conts (delete ass conts)) diff --git a/lisp/keymap.el b/lisp/keymap.el index 7a19621441c..9b133e1ca82 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -528,7 +528,7 @@ If optional argument ACCEPT-DEFAULT is non-nil, recognize default bindings; see the description of `keymap-lookup' for more details about this." (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) - (when-let ((map (current-local-map))) + (when-let* ((map (current-local-map))) (keymap-lookup map keys accept-default))) (defun keymap-global-lookup (keys &optional accept-default message) diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 6320af1e79f..38df2a23cac 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -24112,7 +24112,7 @@ If PACKAGE is a string, it specifies the URL of the package repository. In this case, optional argument BACKEND specifies the VC backend to use for cloning the repository; if it's nil, this function tries to infer which backend to use according to -the value of `package-vc-heuristic-alist' and if that fails it +the value of `vc-clone-heuristic-alist' and if that fails it uses `package-vc-default-backend'. Optional argument NAME specifies the package name in this case; if it's nil, this package uses `file-name-base' on the URL to obtain the package diff --git a/lisp/leim/quail/greek.el b/lisp/leim/quail/greek.el index 7cf839f2f58..ff335558a2e 100644 --- a/lisp/leim/quail/greek.el +++ b/lisp/leim/quail/greek.el @@ -1245,6 +1245,8 @@ e.g. ("K" ?Κ) ("L" ?Λ) (":" ?¨) + (";:" ?΅) + (":;" ?΅) ("\"" ?\") ("|" ?|) ("Z" ?Ζ) @@ -1281,7 +1283,9 @@ e.g. (";:y" ?ΰ) (":;y" ?ΰ) (";<" ?«) - (";>" ?»)) + (";>" ?») + ("<<" ?«) + (">>" ?»)) (quail-define-package "greek-postfix" "GreekPost" "Ψ" nil @@ -1429,4 +1433,717 @@ e.g. (">>" ?»)) +(quail-define-package + "greek-polytonic" "Greek" "ῶ" t + "Ἑλληνικά: Greek input method, with support for polytonic & archaic +Greek letters." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("1" ?1) + ("2" ?2) + ("3" ?3) + ("4" ?4) + ("5" ?5) + ("6" ?6) + ("7" ?7) + ("8" ?8) + ("9" ?9) + ("0" ?0) + ("-" ?-) + ("=" ?=) + ("[" ?\[) + ("]" ?\]) + ;; Changed punction from greek.el + ("`" ?·) + ("~" ?:) + ;; tonoi + (";" ?΄) ;; U+1FFD (oxia) + ("q" ?`) ;; U+1FEF (varia) + ("'" ?῀) ;; U+1FC0 (perispomeni) + ("\"" ?ι) ;; U+1FBE (ypogegrammeni) + ;; pneumata + (":" ?᾿) ;; U+1FBF (psili) + ("Q" ?῾) ;; U+1FFE (dasia) + ("W" ?¨) ;; U+00A8 (dialytika) + ;; apostrophe combinations + ("; " ["’ "]) ;; U+2019 (apostrophe) + (";g" ["’γ"]) + (";d" ["’δ"]) + (";z" ["’ζ"]) + (";u" ["’θ"]) + (";k" ["’κ"]) + (";l" ["’λ"]) + (";m" ["’μ"]) + (";n" ["’ν"]) + (";j" ["’ξ"]) + (";p" ["’π"]) + (";ρ" ["’r"]) + (";s" ["’σ"]) + (";t" ["’τ"]) + (";f" ["’φ"]) + (";x" ["’χ"]) + (";c" ["’ψ"]) + ;; + (";G" ["’Γ"]) + (";D" ["’Δ"]) + (";Z" ["’Ζ"]) + (";U" ["’Θ"]) + (";K" ["’Κ"]) + (";L" ["’Λ"]) + (";M" ["’Μ"]) + (";N" ["’Ν"]) + (";J" ["’Ξ"]) + (";P" ["’Π"]) + (";Ρ" ["’R"]) + (";S" ["’Σ"]) + (";T" ["’Τ"]) + (";F" ["’Φ"]) + (";X" ["’Χ"]) + (";C" ["’Ψ"]) + ;; Combinations + ("W;" ?΅) ;; U+1FEE + (";W" ?΅) ;; U+1FEE + ("Wq" ?῭) ;; U+1FED + ("qW" ?῭) ;; U+1FED + (":;" ?῎) ;; U+1FCE + (";:" ?῎) ;; U+1FCE + ("qQ" ?῝) ;; U+1FDD + ("Qq" ?῝) ;; U+1FDD + ("q:" ?῍) ;; U+1FCD + (":q" ?῍) ;; U+1FCD + ("Q;" ?῞) ;; U+1FDE + (";Q" ?῞) ;; U+1FDE + ("':" ?῏) ;; U+1FCF + (":'" ?῏) ;; U+1FCF + ("'Q" ?῟) ;; U+1FDF + ("Q'" ?῟) ;; U+1FDF + ("'W" ?῁) ;; U+1FC1 + ("W'" ?῁) ;; U+1FC1 + ;; perispomeni combinations, used for vrachy and macron + ("''" ["῀῀"]) + ("'''" ["῀῀῀"]) + ;; ypogegrammeni combinations + ("\"'" ["῀ι"]) + ("'\"" ["῀ι"]) + ("\";" ["΄ι"]) + (";\"" ["ι΄"]) + ("\":" ["ι᾿"]) + (":\"" ["ι᾿"]) + ("\"q" ["ι`"]) + ("q\"" ["ι`"]) + ("\"Q" ["ι῾"]) + ("Q\"" ["ι῾"]) + ("Q\"'" ["ι῟"]) + ("\"Q'" ["ι῟"]) + + ("Q'\"" ["ι῟"]) + ("'Q\"" ["ι῟"]) + (":q\"" ["῍ι"]) + ("q:\"" ["῍ι"]) + ("\"q:" ["῍ι"]) + ("\":q" ["῍ι"]) + + (":;\"" ["῎ι"]) + (";:\"" ["῎ι"]) + ("\";:" ["῎ι"]) + ("\":;" ["῎ι"]) + ("Qq\"" ["῝ι"]) + ("qQ\"" ["῝ι"]) + ("\"Qq" ["῝ι"]) + ("\"qQ" ["῝ι"]) + + ("Q;\"" ["῞ι"]) + (";Q\"" ["῞ι"]) + ("\";Q" ["῞ι"]) + ("\"Q;" ["῞ι"]) + + (":'\"" ["῏ι"]) + ("':\"" ["῏ι"]) + ("\"':" ["῏ι"]) + ("\":'" ["῏ι"]) + ;; Misc characters + ("~" ?:) + ("``" "~") + ;; + ("W" ?¨) + ("," ?,) + ("." ?.) + ("/" ?/) + ("!" ?!) + ("@" ?@) + ("#" ?#) + ("$" ?€) + ("%" ?%) + ("^" ?^) + ("&" ?&) + ("*" ?*) + ("(" ?\() + (")" ?\)) + ("_" ?_) + ("+" ?+) + ("{" ?{) + ("}" ?}) + (";;" "\"") + ("<" ?<) + (">" ?>) + ("?" ?;) ;; U+037E (Greek Question Mark) + (">>" ?») ;; U+00BB + ("<<" ?«) ;; U+00AB + ;; Alpha + ("A" ?Α) ;; U+0391 + (":A" ?Ἀ) ;; U+1F08 + ("QA" ?Ἁ) ;; U+1F09 + (":qA" ?Ἂ) ;; U+1F0A + ("q:A" ?Ἂ) ;; U+1F0A + ("qQA" ?Ἃ) ;; U+1F0B + ("QqA" ?Ἃ) ;; U+1F0B + (":;A" ?Ἄ) ;; U+1F0C + ("Q;A" ?Ἅ) ;; U+1F0D + (";QA" ?Ἅ) ;; U+1F0D + (":'A" ?Ἆ) ;; U+1F0E + ("':A" ?Ἆ) ;; U+1F0E + ("Q'A" ?Ἇ) ;; U+1F0F + ("'QA" ?Ἇ) ;; U+1F0F + (":\"A" ?ᾈ) ;; U+1F88 + ("Q\"A" ?ᾉ) ;; U+1F89 + (":q\"A" ?ᾊ) ;; U+1F8A + ("q:\"A" ?ᾊ) ;; U+1F8A + ("q\":A" ?ᾊ) ;; U+1F8A + ("\"q:A" ?ᾊ) ;; U+1F8A + ("Qq\"A" ?ᾋ) ;; U+1F8B + ("qQ\"A" ?ᾋ) ;; U+1F8B + ("q\"QA" ?ᾋ) ;; U+1F8B + ("\"qQA" ?ᾋ) ;; U+1F8B + (":;\"A" ?ᾌ) ;; U+1F8C + (";:\"A" ?ᾌ) ;; U+1F8C + (";\":A" ?ᾌ) ;; U+1F8C + ("\";:A" ?ᾌ) ;; U+1F8C + ("Q;\"A" ?ᾍ) ;; U+1F8D + ("Q\";A" ?ᾍ) ;; U+1F8D + ("\"Q;A" ?ᾍ) ;; U+1F8D + ("\";QA" ?ᾍ) ;; U+1F8D + (":'\"A" ?ᾎ) ;; U+1F8E + (":\"'A" ?ᾎ) ;; U+1F8E + ("\":'A" ?ᾎ) ;; U+1F8E + ("\"':A" ?ᾎ) ;; U+1F8E + ("Q'\"A" ?ᾏ) ;; U+1F8F + ("'Q\"A" ?ᾏ) ;; U+1F8F + ("'\"QA" ?ᾏ) ;; U+1F8F + ("\"'QA" ?ᾏ) ;; U+1F8F + ("''A" ?Ᾰ) ;; U+1FB8 + ("'''A" ?Ᾱ) ;; U+1FB9 + ("qA" ?Ὰ) ;; U+1FBA + (";A" ?Ά) ;; U+1FBB + ("\"A" ?ᾼ) ;; U+1FBC + ("a" ?α) ;; U+03B1 + (":a" ?ἀ) ;; U+1F00 + ("Qa" ?ἁ) ;; U+1F01 + (":qa" ?ἂ) ;; U+1F02 + ("q:a" ?ἂ) ;; U+1F02 + ("Qqa" ?ἃ) ;; U+1F03 + ("qQa" ?ἃ) ;; U+1F03 + (":;a" ?ἄ) ;; U+1F04 + (";:a" ?ἄ) ;; U+1F04 + ("Q;a" ?ἅ) ;; U+1F05 + (";Qa" ?ἅ) ;; U+1F05 + (":'a" ?ἆ) ;; U+1F06 + ("':a" ?ἆ) ;; U+1F06 + ("Q'a" ?ἇ) ;; U+1F07 + ("'Qa" ?ἇ) ;; U+1F07 + ("qa" ?ὰ) ;; U+1F70 + (";a" ?ά) ;; U+1F71 + (":\"a" ?ᾀ) ;; U+1F80 + ("\":a" ?ᾀ) ;; U+1F80 + ("Q\"a" ?ᾁ) ;; U+1F81 + (":q\"a" ?ᾂ) ;; U+1F82 + (":\"qa" ?ᾂ) ;; U+1F82 + ("\":qa" ?ᾂ) ;; U+1F82 + ("\"q:a" ?ᾂ) ;; U+1F82 + ("Qq\"a" ?ᾃ) ;; U+1F83 + ("Q\"qa" ?ᾃ) ;; U+1F83 + ("\"qQa" ?ᾃ) ;; U+1F83 + ("\"Qqa" ?ᾃ) ;; U+1F83 + (":;\"a" ?ᾄ) ;; U+1F84 + (";\":a" ?ᾄ) ;; U+1F84 + ("\";:a" ?ᾄ) ;; U+1F84 + (";:\"a" ?ᾄ) ;; U+1F84 + (":;\"a" ?ᾄ) ;; U+1F84 + ("Q;\"a" ?ᾅ) ;; U+1F85 + ("Q\";a" ?ᾅ) ;; U+1F85 + ("\"Q;a" ?ᾅ) ;; U+1F85 + ("\";Qa" ?ᾅ) ;; U+1F85 + (";\"Qa" ?ᾅ) ;; U+1F85 + (":'\"a" ?ᾆ) ;; U+1F86 + ("':\"a" ?ᾆ) ;; U+1F86 + ("'\":a" ?ᾆ) ;; U+1F86 + ("\"':a" ?ᾆ) ;; U+1F86 + ("\":'a" ?ᾆ) ;; U+1F86 + ("Q'\"a" ?ᾇ) ;; U+1F87 + ("'Q\"a" ?ᾇ) ;; U+1F87 + ("'\"Qa" ?ᾇ) ;; U+1F87 + ("\"'Qa" ?ᾇ) ;; U+1F87 + ("\"Q'a" ?ᾇ) ;; U+1F87 + ("''a" ?ᾰ) ;; U+1FB0 + ("'''a" ?ᾱ) ;; U+1FB1 + ("q\"a" ?ᾲ) ;;U+1FB2 + ("\"qa" ?ᾲ) ;;U+1FB2 + ("\"a" ?ᾳ) ;; U+1FB3 + (";\"a" ?ᾴ) ;; U+1FB4 + ("'a" ?ᾶ) ;; U+1FB6 + ("'\"a" ?ᾷ) ;; U+1FB7 + ("\"'a" ?ᾷ) ;; U+1FB7 + ;; Beta + ("B" ?Β) ;; U+0392 + ("b" ?β) ;; U+03B2 + ;; Gamma + ("G" ?Γ) ;; U+0393 + ("g" ?γ) ;; U+03B3 + ;; Delta + ("D" ?Δ) ;; U+0394 + ("d" ?δ) ;; U+03B4 + ;; Epsilon + ("E" ?Ε) ;; U+0395 + (":E" ?Ἐ) ;; U+1F18 + ("QE" ?Ἑ) ;; U+1F19 + (":qE" ?Ἒ) ;; U+1F1A + ("q:E" ?Ἒ) ;; U+1F1A + ("QqE" ?Ἓ) ;; U+1F1B + ("qQE" ?Ἓ) ;; U+1F1B + (":;E" ?Ἔ) ;; U+1F1C + (";:E" ?Ἔ) ;; U+1F1C + ("Q;E" ?Ἕ) ;; U+1F1D + (";QE" ?Ἕ) ;; U+1F1D + ("qE" ?Ὲ) ;; U+1FC8 + (";E" ?Έ) ;; U+1FC9 + ("e" ?ε) ;; U+03B5 + ("qe" ?ὲ) ;; U+1F72 + (";e" ?έ) ;; U+1F73 + (":e" ?ἐ) ;; U+1F10 + ("Qe" ?ἑ) ;; U+1F11 + (":qe" ?ἒ) ;; U+1F12 + ("q:e" ?ἒ) ;; U+1F12 + ("Qqe" ?ἓ) ;; U+1F13 + ("qQe" ?ἓ) ;; U+1F13 + (":;e" ?ἔ) ;; U+1F14 + (";:e" ?ἔ) ;; U+1F14 + ("Q;e" ?ἕ) ;; U+1F15 + (";Qe" ?ἕ) ;; U+1F15 + ;; Zeta + ("Z" ?Ζ) ;; U+0396 + ("z" ?ζ) ;; U+03B6 + ;; Eta + ("H" ?Η) ;; U+0397 + (":H" ?Ἠ) ;; U+1F28 + ("QH" ?Ἡ) ;; U+1F29 + (":qH" ?Ἢ) ;; U+1F2A + ("q:H" ?Ἢ) ;; U+1F2A + ("QqH" ?Ἣ) ;; U+1F2B + ("qQH" ?Ἣ) ;; U+1F2B + (":;H" ?Ἤ) ;; U+1F2C + (";:H" ?Ἤ) ;; U+1F2C + ("Q;H" ?Ἥ) ;; U+1F2D + (";QH" ?Ἥ) ;; U+1F2D + (":'H" ?Ἦ) ;; U+1F2E + ("':H" ?Ἦ) ;; U+1F2E + ("Q'H" ?Ἧ) ;; U+1F2F + ("'QH" ?Ἧ) ;; U+1F2F + (":\"H" ?ᾘ) ;; U+1F98 + ("\":H" ?ᾘ) ;; U+1F98 + ("Q\"H" ?ᾙ) ;; U+1F99 + ("\"QH" ?ᾙ) ;; U+1F99 + (":q\"H" ?ᾚ) ;; U+1F9A + (":\"qH" ?ᾚ) ;; U+1F9A + ("\":qH" ?ᾚ) ;; U+1F9A + ("\"q:H" ?ᾚ) ;; U+1F9A + ("q\":H" ?ᾚ) ;; U+1F9A + ("Qq\"H" ?ᾛ) ;; U+1F9B + ("Q\"qH" ?ᾛ) ;; U+1F9B + ("\"QqH" ?ᾛ) ;; U+1F9B + ("\"qQH" ?ᾛ) ;; U+1F9B + ("q\"QH" ?ᾛ) ;; U+1F9B + (":;\"H" ?ᾜ) ;; U+1F9C + (":\";H" ?ᾜ) ;; U+1F9C + ("\":;H" ?ᾜ) ;; U+1F9C + ("\";:H" ?ᾜ) ;; U+1F9C + (";\":H" ?ᾜ) ;; U+1F9C + ("Q;\"H" ?ᾝ) ;; U+1F9D + ("Q\";H" ?ᾝ) ;; U+1F9D + ("\"Q;H" ?ᾝ) ;; U+1F9D + ("\";QH" ?ᾝ) ;; U+1F9D + (";\"QH" ?ᾝ) ;; U+1F9D + (":'\"H" ?ᾞ) ;; U+1F9E + (":\"'H" ?ᾞ) ;; U+1F9E + ("\":'H" ?ᾞ) ;; U+1F9E + ("\"':H" ?ᾞ) ;; U+1F9E + ("'\":H" ?ᾞ) ;; U+1F9E + ("Q'\"H" ?ᾟ) ;; U+1F9F + ("Q\"'H" ?ᾟ) ;; U+1F9F + ("\"Q'H" ?ᾟ) ;; U+1F9F + ("\"'QH" ?ᾟ) ;; U+1F9F + ("'\"QH" ?ᾟ) ;; U+1F9F + ("qH" ?Ὴ) ;; U+1FCA + (";H" ?Ή) ;; U+1FCB + ("\"H" ?ῌ) ;; U+1FCC + ;; + ("h" ?η) ;; U+03B7 + ("qh" ?ὴ) ;; U+1F74 + (";h" ?ή) ;; U+1F75 + (":h" ?ἠ) ;; U+1F20 + ("Qh" ?ἡ) ;; U+1F21 + (":qh" ?ἢ) ;; U+1F22 + ("q:h" ?ἢ) ;; U+1F22 + ("Qqh" ?ἣ) ;; U+1F23 + ("qQh" ?ἣ) ;; U+1F23 + (":;h" ?ἤ) ;; U+1F24 + (";:h" ?ἤ) ;; U+1F24 + ("Q;h" ?ἥ) ;; U+1F25 + (";Qh" ?ἥ) ;; U+1F25 + (":'h" ?ἦ) ;; U+1F26 + ("':h" ?ἦ) ;; U+1F26 + ("Q'h" ?ἧ) ;; U+1F27 + ("'Qh" ?ἧ) ;; U+1F27 + (":\"h" ?ᾐ) ;; U+1F90 + ("\":h" ?ᾐ) ;; U+1F90 + ("Q\"h" ?ᾑ) ;; U+1F91 + ("\"Qh" ?ᾑ) ;; U+1F91 + (":q\"h" ?ᾒ) ;; U+1F92 + (":\"qh" ?ᾒ) ;; U+1F92 + ("\":qh" ?ᾒ) ;; U+1F92 + ("\"q:h" ?ᾒ) ;; U+1F92 + ("q\":h" ?ᾒ) ;; U+1F92 + ("Qq\"h" ?ᾓ) ;; U+1F93 + ("Q\"qh" ?ᾓ) ;; U+1F93 + ("\"Qqh" ?ᾓ) ;; U+1F93 + ("\"qQh" ?ᾓ) ;; U+1F93 + ("q\"Qh" ?ᾓ) ;; U+1F93 + (":;\"h" ?ᾔ) ;; U+1F94 + (":\";h" ?ᾔ) ;; U+1F94 + ("\":;h" ?ᾔ) ;; U+1F94 + ("\";:h" ?ᾔ) ;; U+1F94 + (";\":h" ?ᾔ) ;; U+1F94 + ("Q;\"h" ?ᾕ) ;; U+1F95 + ("Q\";h" ?ᾕ) ;; U+1F95 + ("\"Q;h" ?ᾕ) ;; U+1F95 + ("\";Qh" ?ᾕ) ;; U+1F95 + (";\"Qh" ?ᾕ) ;; U+1F95 + (":'\"h" ?ᾖ) ;; U+1F96 + (":\"'h" ?ᾖ) ;; U+1F96 + ("\":'h" ?ᾖ) ;; U+1F96 + ("\"':h" ?ᾖ) ;; U+1F96 + ("'\":h" ?ᾖ) ;; U+1F96 + ("Q'\"h" ?ᾗ) ;; U+1F97 + ("Q\"'h" ?ᾗ) ;; U+1F97 + ("\"Q'h" ?ᾗ) ;; U+1F97 + ("\"'Qh" ?ᾗ) ;; U+1F97 + ("'\"Qh" ?ᾗ) ;; U+1F97 + ("q\"h" ?ῂ) ;; U+1FC2 + ("\"qh" ?ῂ) ;; U+1FC2 + ("\"h" ?ῃ) ;; U+1FC3 + (";\"h" ?ῄ) ;; U+1FC4 + ("\";h" ?ῄ) ;; U+1FC4 + ("'h" ?ῆ) ;; U+1FC6 + ("\"'h" ?ῇ) ;; U+1FC7 + ("'\"h" ?ῇ) ;; U+1FC7 + ;; Theta + ("U" ?Θ) ;; U+0398 + ("u" ?θ) ;; U+03B8 + ;; Iota + ("I" ?Ι) ;; U+0399 + ("WI" ?Ϊ) ;; U+03AA + (":I" ?Ἰ) ;; U+1F38 + ("QI" ?Ἱ) ;; U+1F39 + (":qI" ?Ἲ) ;; U+1F3A + ("q:I" ?Ἲ) ;; U+1F3A + ("QqI" ?Ἳ) ;; U+1F3B + ("qQI" ?Ἳ) ;; U+1F3B + (":;I" ?Ἴ) ;; U+1F3C + (";:I" ?Ἴ) ;; U+1F3C + ("Q;I" ?Ἵ) ;; U+1F3D + (";QI" ?Ἵ) ;; U+1F3D + (":'I" ?Ἶ) ;; U+1F3E + ("':I" ?Ἶ) ;; U+1F3E + ("Q'I" ?Ἷ) ;; U+1F3F + ("''I" ?Ῐ) ;; U+1FD8 + ("'''I" ?Ῑ) ;; U+1FD9 + ("qI" ?Ὶ) ;; U+1FDA + (";I" ?Ί) ;; U+1FDB + ("i" ?ι) ;; U+03B9 + ("Wi" ?ϊ) ;; U+03CA + ("qi" ?ὶ) ;; U+1F76 + (";i" ?ί) ;; U+1F77 + (":i" ?ἰ) ;; U+1F30 + ("Qi" ?ἱ) ;; U+1F31 + (":qi" ?ἲ) ;; U+1F32 + ("q:i" ?ἲ) ;; U+1F32 + ("Qqi" ?ἳ) ;; U+1F33 + ("qQi" ?ἳ) ;; U+1F33 + (":;i" ?ἴ) ;; U+1F34 + (";:i" ?ἴ) ;; U+1F34 + ("Q;i" ?ἵ) ;; U+1F35 + (";Qi" ?ἵ) ;; U+1F35 + (":'i" ?ἶ) ;; U+1F36 + ("':i" ?ἶ) ;; U+1F36 + ("Q'i" ?ἷ) ;; U+1F37 + ("'Qi" ?ἷ) ;; U+1F37 + ("''i" ?ῐ) ;; U+1FD0 + ("'''i" ?ῑ) ;; U+1FD1 + ("Wqi" ?ῒ) ;; U+1FD2 + ("qWi" ?ῒ) ;; U+1FD2 + (";Wi" ?ΐ) ;; U+1FD3 + ("W;i" ?ΐ) ;; U+1FD3 + ("'i" ?ῖ) ;; U+1FD6 + ("W'i" ?ῗ) ;; U+1FD7 + ("'Wi" ?ῗ) ;; U+1FD7 + ;; Kappa + ("K" ?Κ) ;; U+039A + ("k" ?κ) ;; U+03BA + ;; Lambda + ("L" ?Λ) ;; U+039B + ("l" ?λ) ;; U+03BB + ;; Mu + ("M" ?Μ) ;; U+039C + ("m" ?μ) ;; U+03BC + ;; Nu + ("N" ?Ν) ;; U+039D + ("n" ?ν) ;; U+03BD + ;; Xi + ("J" ?Ξ) ;; U+039E + ("j" ?ξ) ;; U+03BE + ;; Omicron + ("O" ?Ο) ;; U+039F + (":O" ?Ὀ) ;; U+1F48 + ("QO" ?Ὁ) ;; U+1F49 + (":qO" ?Ὂ) ;; U+1F4A + ("q:O" ?Ὂ) ;; U+1F4A + ("QqO" ?Ὃ) ;; U+1F4B + (":;O" ?Ὄ) ;; U+1F4C + ("Q;O" ?Ὅ) ;; U+1F4D + ("qO" ?Ὸ) ;; U+1FF8 + (";O" ?Ό) ;; U+1FF9 + ("o" ?ο) ;; U+03BF + ("qo" ?ὸ) ;; U+1F78 + (";o" ?ό) ;; U+1F79 + (":o" ?ὀ) ;; U+1F40 + ("Qo" ?ὁ) ;; U+1F41 + (":qo" ?ὂ) ;; U+1F42 + ("q:o" ?ὂ) ;; U+1F42 + ("Qqo" ?ὃ) ;; U+1F43 + ("qQo" ?ὃ) ;; U+1F43 + (":;o" ?ὄ) ;; U+1F44 + (";:o" ?ὄ) ;; U+1F44 + ("Q;o" ?ὅ) ;; U+1F45 + ;; Pi + ("P" ?Π) ;; U+03A0 + ("p" ?π) ;; U+03C0 + ;; Rho + ("R" ?Ρ) ;; U+03A1 + ("QR" ?Ῥ) ;; U+1FEC + ("r" ?ρ) ;; U+03C1 + (":r" ?ῤ) ;; U+1FE4 + ("Qr" ?ῥ) ;; U+1FE5 + ;; Sigma + ("S" ?Σ) ;; U+03A3 + ("s" ?σ) ;; U+03C3 + ("w" ?ς) ;; U+03C2 + ;; Tau + ("T" ?Τ) ;; U+03A4 + ("t" ?τ) ;; U+03C4 + ;; Upsilon + ("Y" ?Υ) ;; U+03A5 + ("WY" ?Ϋ) ;; U+03AB + ("QY" ?Ὑ) ;; U+1F59 + ("QqY" ?Ὓ) ;; U+1F5B + ("qQY" ?Ὓ) ;; U+1F5B + ("Q;Y" ?Ὕ) ;; U+1F5D + (";QY" ?Ὕ) ;; U+1F5D + ("Q'Y" ?Ὗ) ;; U+1F5F + ("'QY" ?Ὗ) ;; U+1F5F + ("y" ?υ) ;; U+03C5 + ("Wy" ?ϋ) ;; U+03CB + ("qy" ?ὺ) ;; U+1F7A + (";y" ?ύ) ;; U+1F7B + (":y" ?ὐ) ;; U+1F50 + ("Qy" ?ὑ) ;; U+1F51 + (":qy" ?ὒ) ;; U+1F52 + ("q:y" ?ὒ) ;; U+1F52 + ("Qqy" ?ὓ) ;; U+1F53 + ("qQy" ?ὓ) ;; U+1F53 + (":;y" ?ὔ) ;; U+1F54 + (";:y" ?ὔ) ;; U+1F54 + ("Q;y" ?ὕ) ;; U+1F55 + (";Qy" ?ὕ) ;; U+1F55 + (":'y" ?ὖ) ;; U+1F56 + ("':y" ?ὖ) ;; U+1F56 + ("Q'y" ?ὗ) ;; U+1F57 + ("'Qy" ?ὗ) ;; U+1F57 + ("''y" ?ῠ) ;; U+1FE0 + ("'''y" ?ῡ) ;; U+1FE1 + ("Wqy" ?ῢ) ;; U+1FE2 + ("qWy" ?ῢ) ;; U+1FE2 + ("W;y" ?ΰ) ;; U+1FE3 + (";Wy" ?ΰ) ;; U+1FE3 + ("'y" ?ῦ) ;; U+1FE6 + ("W'y" ?ῧ) ;; U+1FE7 + ("'Wy" ?ῧ) ;; U+1FE7 + ("''Y" ?Ῠ) ;; U+1FE8 + ("'''Y" ?Ῡ) ;; U+1FE8 + ("qY" ?Ὺ) ;; U+1FEA + (";Y" ?Ύ) ;; U+1FEB + ;; Phi + ("F" ?Φ) ;; U+03A6 + ("f" ?φ) ;; U+03C6 + ;; Chi + ("X" ?Χ) ;; U+03A7 + ("x" ?χ) ;; U+03C7 + ;; Chi + ("C" ?Ψ) ;; U+03A8 + ("c" ?ψ) ;; U+03C8 + ;; Omega + ("V" ?Ω) ;; U+03A9 + (":V" ?Ὠ) ;; U+1F68 + ("QV" ?Ὡ) ;; U+1F69 + (":qV" ?Ὢ) ;; U+1F6A + ("q:V" ?Ὢ) ;; U+1F6A + ("QqV" ?Ὣ) ;; U+1F6B + ("qQV" ?Ὣ) ;; U+1F6B + (":;V" ?Ὤ) ;; U+1F6C + (";:V" ?Ὤ) ;; U+1F6C + ("Q;V" ?Ὥ) ;; U+1F6D + (";QV" ?Ὥ) ;; U+1F6D + (":'V" ?Ὦ) ;; U+1F6E + ("':V" ?Ὦ) ;; U+1F6E + ("Q'V" ?Ὧ) ;; U+1F6F + (":\"V" ?ᾨ) ;; U+1FA8 + ("\":V" ?ᾨ) ;; U+1FA8 + ("Q\"V" ?ᾩ) ;; U+1FA9 + ("\"QV" ?ᾩ) ;; U+1FA9 + + (":q\"V" ?ᾪ) ;; U+1FAA + (":\"qV" ?ᾪ) ;; U+1FAA + ("\":qV" ?ᾪ) ;; U+1FAA + ("\"q:V" ?ᾪ) ;; U+1FAA + ("q\":V" ?ᾪ) ;; U+1FAA + ("q:\"V" ?ᾪ) ;; U+1FAA + + ("Qq\"V" ?ᾫ) ;; U+1FAB + ("qQ\"V" ?ᾫ) ;; U+1FAB + ("q\"QV" ?ᾫ) ;; U+1FAB + ("\"qQV" ?ᾫ) ;; U+1FAB + ("\"QqV" ?ᾫ) ;; U+1FAB + + (":\"qV" ?ᾫ) ;; U+1FAB + (":;\"V" ?ᾬ) ;; U+1FAC + (":\";V" ?ᾬ) ;; U+1FAC + ("\":;V" ?ᾬ) ;; U+1FAC + ("\";:V" ?ᾬ) ;; U+1FAC + (";\":V" ?ᾬ) ;; U+1FAC + ("Q;\"V" ?ᾭ) ;; U+1FAD + ("Q\";V" ?ᾭ) ;; U+1FAD + ("\"Q;V" ?ᾭ) ;; U+1FAD + ("\";QV" ?ᾭ) ;; U+1FAD + (";\"QV" ?ᾭ) ;; U+1FAD + (":'\"V" ?ᾮ) ;; U+1FAE + (":\"'V" ?ᾮ) ;; U+1FAE + ("\":'V" ?ᾮ) ;; U+1FAE + ("\"':V" ?ᾮ) ;; U+1FAE + ("'\":V" ?ᾮ) ;; U+1FAE + + ("Q'\"V" ?ᾯ) ;; U+1FAF + ("'Q\"V" ?ᾯ) ;; U+1FAF + ("Q\"'V" ?ᾯ) ;; U+1FAF + ("\"Q'V" ?ᾯ) ;; U+1FAF + ("\"'QV" ?ᾯ) ;; U+1FAF + ("'\"QV" ?ᾯ) ;; U+1FAF + + ("qV" ?Ὼ) ;; U+1FFA + (";V" ?Ώ) ;; U+1FFB + ("\"V" ?ῼ) ;; U+1FFC + ("v" ?ω) ;; U+03C9 + ("qv" ?ὼ) ;; U+1F7C + (";v" ?ώ) ;; U+1F7D + (":v" ?ὠ) ;; U+1F60 + ("Qv" ?ὡ) ;; U+1F61 + (":qv" ?ὢ) ;; U+1F62 + ("q:v" ?ὢ) ;; U+1F62 + ("Qqv" ?ὣ) ;; U+1F63 + ("qQv" ?ὣ) ;; U+1F63 + (":;v" ?ὤ) ;; U+1F64 + (";:v" ?ὤ) ;; U+1F64 + ("Q;v" ?ὥ) ;; U+1F65 + (";Qv" ?ὥ) ;; U+1F65 + (":'v" ?ὦ) ;; U+1F66 + ("':v" ?ὦ) ;; U+1F66 + ("Q'v" ?ὧ) ;; U+1F67 + ("'Qv" ?ὧ) ;; U+1F67 + (":\"v" ?ᾠ) ;; U+1FA0 + ("\":v" ?ᾠ) ;; U+1FA0 + ("Q\"v" ?ᾡ) ;; U+1FA1 + ("\"Qv" ?ᾡ) ;; U+1FA1 + (":q\"v" ?ᾢ) ;; U+1FA2 + (":\"qv" ?ᾢ) ;; U+1FA2 + ("\":qv" ?ᾢ) ;; U+1FA2 + ("\"q:v" ?ᾢ) ;; U+1FA2 + ("q\":v" ?ᾢ) ;; U+1FA2 + + ("Qq\"v" ?ᾣ) ;; U+1FA3 + ("q\"Qv" ?ᾣ) ;; U+1FA3 + ("\"qQv" ?ᾣ) ;; U+1FA3 + ("\"Qqv" ?ᾣ) ;; U+1FA3 + ("Q\"qv" ?ᾣ) ;; U+1FA3 + + (":;\"v" ?ᾤ) ;; U+1FA4 + (":\";v" ?ᾤ) ;; U+1FA4 + ("\":;v" ?ᾤ) ;; U+1FA4 + ("\";:v" ?ᾤ) ;; U+1FA4 + (";\":v" ?ᾤ) ;; U+1FA4 + (";:\"v" ?ᾤ) ;; U+1FA4 + + ("Q;\"v" ?ᾥ) ;; U+1FA5 + ("Q\";v" ?ᾥ) ;; U+1FA5 + ("\"Q;v" ?ᾥ) ;; U+1FA5 + ("\";Qv" ?ᾥ) ;; U+1FA5 + (";\"Qv" ?ᾥ) ;; U+1FA5 + (";Q\"v" ?ᾥ) ;; U+1FA5 + + (":'\"v" ?ᾦ) ;; U+1FA6 + (":\"'v" ?ᾦ) ;; U+1FA6 + ("\":'v" ?ᾦ) ;; U+1FA6 + ("\"':v" ?ᾦ) ;; U+1FA6 + ("'\":v" ?ᾦ) ;; U+1FA6 + ("':\"v" ?ᾦ) ;; U+1FA6 + + ("Q'\"v" ?ᾧ) ;; U+1FA7 + ("Q\"'v" ?ᾧ) ;; U+1FA7 + ("\"Q'v" ?ᾧ) ;; U+1FA7 + ("\"'Qv" ?ᾧ) ;; U+1FA7 + ("'\"Qv" ?ᾧ) ;; U+1FA7 + ("'Q\"v" ?ᾧ) ;; U+1FA7 + + ("q\"v" ?ῲ) ;; U+1FF2 + ("\"qv" ?ῲ) ;; U+1FF2 + ("\"v" ?ῳ) ;; U+1FF3 + (";\"v" ?ῴ) ;; U+1FF4 + ("'v" ?ῶ) ;; U+1FF6 + ("'\"v" ?ῷ) ;; U+1FF7 + ("\"'v" ?ῷ) ;; U+1FF7 + ;;; Archaic Letters ;;; + ;; Stigma + ("ww" ?ϛ) ;; U+03DB Note that capital stigma (U+03DA) is an invalid letter. + ;; Digamma + ("wF" ?Ϝ) ;; U+03DC + ("wf" ?ϝ) ;; U+03DD + ;; Koppa + ("wK" ?Ϟ) ;; U+03DE + ("wk" ?ϟ) ;; U+03DF + ;; Sampi + ("wP" ?Ϡ) ;; U+03E0 + ("wp" ?ϡ) ;; U+03E1 + ;; Koppa + ("wO" ?Ϙ) ;; U+03D8 + ("wo" ?ϙ) ;; U+03D9 + ) + +(provide 'greek-polytonic) + ;;; greek.el ends here diff --git a/lisp/leim/quail/iroquoian.el b/lisp/leim/quail/iroquoian.el new file mode 100644 index 00000000000..3b4fdad62c2 --- /dev/null +++ b/lisp/leim/quail/iroquoian.el @@ -0,0 +1,1051 @@ +;;; iroquoian.el --- Quail packages for inputting Iroquoian languages -*- lexical-binding: t; coding: utf-8; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Kierin Bell <fernseed@fernseed.me> +;; Keywords: i18n + +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file implements input methods for Northern Iroquoian languages. + +;; Input methods are implemented for all Five Nations Iroquois +;; languages: + +;; - Mohawk (Kanien’kéha / Onkwehonwehnéha) +;; - Oneida (Onʌyota:ká: / Ukwehuwehnéha) +;; - Onondaga (Onųdaʔgegáʔ) +;; - Cayuga (Gayogo̱ho:nǫhnéha:ˀ) +;; - Seneca (Onödowá’ga:’) + +;; A composite input method for all of the languages above is also +;; defined: `haudenosaunee-postfix'. + +;; Input methods are not yet implemented for the remaining Northern +;; Iroquoian languages, including: + +;; - Tuscarora (Skarù:ręʔ) +;; - Wendat (Huron) / Wyandot + +;;; Code: + +(require 'quail) +(require 'seq) +(require 'pcase) + + +;;; Mohawk + +;; +;; There are several orthographies used today to write Mohawk in +;; different communities, but differences are small and mainly involve +;; differences in representation of the palatal glide [j] (written <i> +;; in Eastern/Central dialects and <y> in Western dialects). The +;; following input method should work for all of variants. +;; +;; Reference work for orthographies used by speakers of Eastern +;; (Kahnawà:ke, Kanehsatà:ke, Wáhta) and Central (Ahkwesahsne) dialects +;; of Mohawk: +;; +;; Lazore, Dorothy Karihwénhawe. 1993. The Mohawk language +;; Standardisation Project, Conference Report. Ontario: Literacy +;; Ontario. +;; +;; Reference work for the orthography commonly used by speakers of +;; Western dialects of Mohawk (Tyendinaga, Ohswé:ken): +;; +;; Brian Maracle. 2021. 1st Year Adult Immersion Program 2020-21. +;; Ohsweken, ON, Canada: Onkwawenna Kentyohkwa. Unpublished curriculum +;; document written by staff for the Okwawenna Kentyohkwa adult +;; immersion program. +;; + +(defconst iroquoian-mohawk-modifier-alist nil + "Alist of rules for modifier letters in Mohawk input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-mohawk-vowel-alist + '(("a'" ?á) + ("a`" ?à) + ("A'" ?Á) + ("A`" ?À) + ("e'" ?é) + ("e`" ?è) + ("E'" ?É) + ("E`" ?È) + ("i'" ?í) + ("i`" ?ì) + ("I'" ?Í) + ("I`" ?Ì) + ("o'" ?ó) + ("o`" ?ò) + ("O'" ?Ó) + ("O`" ?Ò) + + ("a''" ["a'"]) + ("a``" ["a`"]) + ("A''" ["A'"]) + ("A``" ["A`"]) + ("e''" ["e'"]) + ("e``" ["e`"]) + ("E''" ["E'"]) + ("E``" ["E`"]) + ("i''" ["i'"]) + ("i``" ["i`"]) + ("I''" ["I'"]) + ("I``" ["I`"]) + ("o''" ["o'"]) + ("o``" ["o`"]) + ("O''" ["O'"]) + ("O``" ["O`"])) + "Alist of rules for vowel letters in Mohawk input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-mohawk-consonant-alist + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK})) + "Alist of rules for consonant letters in Mohawk input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "mohawk-postfix" "Mohawk" "MOH<" t + "Mohawk (Kanien’kéha) input method with postfix modifiers + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | +| \\=` | Grave accent | a` -> à | + +Doubling any of these postfixes separates the letter and the postfix. + +Vowels: + +a, e, i, and o are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-----+-------------+--------------| +| ;; | \\=’ | Glottal stop | + +h, k, n, r, s, t, w, and y are bound to a single key. + +b, m, and p are used rarely in ideophones and loan words. They are also +each bound to a single key. + +All Haudenosaunee languages, including Mohawk, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-mohawk-modifier-alist + iroquoian-mohawk-consonant-alist + iroquoian-mohawk-vowel-alist)) + (quail-defrule key trans)) + + +;;; Oneida + +;; +;; There are slight variations in the orthographies used today to write +;; Oneida. The differences mainly involve in representation of vowel +;; length and glottal stops. +;; +;; Reference work for Oneida orthography: +;; +;; Michelson, K., Doxtator, M. and Doxtator, M.A.. 2002. +;; Oneida-English/English-Oneida dictionary. Toronto: University of +;; Toronto Press. +;; +;; Orthographic variation from personal familiarity with community +;; language programs and curricula. +;; + +(defconst iroquoian-oneida-modifier-alist + '(("::" ?\N{MIDDLE DOT})) + "Alist of rules for modifier letters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-oneida-vowel-alist + '(("a'" ?á) + ("A'" ?Á) + ("e'" ?é) + ("E'" ?É) + ("i'" ?í) + ("I'" ?Í) + ("o'" ?ó) + ("O'" ?Ó) + ("u'" ?ú) + ("U'" ?Ú) + ("e/" ?ʌ) + ("e/'" ["ʌ́"]) + ("E/" ?Ʌ) + ("E/'" ["Ʌ́"]) + + ("a''" ["a'"]) + ("A''" ["A'"]) + ("e''" ["e'"]) + ("E''" ["E'"]) + ("i''" ["i'"]) + ("I''" ["I'"]) + ("o''" ["o'"]) + ("O''" ["O'"]) + ("u''" ["u'"]) + ("U''" ["U'"]) + ("e//" ["e/"]) + ("e/''" ["ʌ'"]) + ("E//" ["E/"]) + ("E/''" ["Ʌ'"])) + "Alist of rules for vowel letters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-oneida-consonant-alist + '((";;" ?\N{MODIFIER LETTER GLOTTAL STOP}) + (";'" ?\N{RIGHT SINGLE QUOTATION MARK})) + "Alist of rules for consonant letters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-oneida-devoicing-alist + '(("_" ?\N{COMBINING LOW LINE}) + ("__" ?_)) + "Alist of rules for devoicing characters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "oneida-postfix" "Oneida" "ONE<" t + "Oneida (Onʌyota:ká:) input method with postfix modifiers + +Modifiers: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| :: | · | Vowel length | + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | + +Doubling the postfix separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+-----------------------------------| +| e/ | ʌ | Mid central nasal vowel | +| E/ | Ʌ | Mid central nasal vowel (capital) | + +a, e, i, o, and u are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| ;; | ˀ | Glottal stop | +| ;\\=' | \\=’ | Glottal stop (alternate) | + +h, k, l, n, s, t, w, and y are bound to a single key. + +Devoicing: + +| Key | Description | Example | +|-----+--------------------+----------| +| _ | Combining low line | a_ -> a̲ | + +Note: Not all fonts can properly display a combining low line on all +letters. + +Underlining is commonly used in Oneida to indicate devoiced syllables on +pre-pausal forms (also called utterance-final forms). Alternatively, +markup or other methods can be used to create an underlining effect. + +To enter a plain underscore, type the underscore twice. + +All Haudenosaunee languages, including Oneida, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-oneida-modifier-alist + iroquoian-oneida-consonant-alist + iroquoian-oneida-vowel-alist + iroquoian-oneida-devoicing-alist)) + (quail-defrule key trans)) + + +;;; Onondaga + +;; +;; There are three main orthographies for Onondaga in contemporary use: +;; the community orthography used at Six Nations of the Grand River, the +;; community orthography used at Onondaga Nation in New York, and the +;; orthography used by Hanni Woodbury in her 2003 dictionary (see +;; below). The latter is included because of its adoption in academia +;; and also by some contemporary second-language learners. +;; Additionally, Woodbury's dictionary provides a helpful description of +;; the community orthographies that is still applicable today. +;; +;; The differences between the orthographies are small, involving +;; representation of nasal vowels (ęand ǫat Six Nations of the Grand +;; River, eñ and oñ at Onondaga in New York, and ęand ųfollowing +;; Woodbury's dictionary), the low front rounded vowel (äat Six Nations +;; and Onondaga Nation and æ following Woodbury), vowel length (: +;; [colon] after a vowel in community orthographies and · [middle dot] +;; following Woodbury), and glottal stops (’ [right single quotation +;; mark] in community orthographies and ʔ [latin letter glottal stop] +;; following Woodbury). The input method here aims to accommodate all +;; three of these orthographies. +;; +;; Reference work for Onondaga orthography: +;; +;; Hanni Woodbury. 2003. Onondaga-English/English-Onondaga +;; Dictionary. Toronto: University of Toronto Press. +;; + +(defconst iroquoian-onondaga-modifier-alist + '(("::" ?\N{MIDDLE DOT})) + "Alist of rules for modifier letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-onondaga-vowel-alist + '(("a'" ?á) + ("A'" ?Á) + ("e'" ?é) + ("E'" ?É) + ("i'" ?í) + ("I'" ?Í) + ("o'" ?ó) + ("O'" ?Ó) + ("e," ?ę) + ("e,'" ["ę́"]) + ("E," ?Ę) + ("E,'" ["Ę́"]) + ("o," ?ǫ) + ("o,'" ["ǫ́"]) + ("O," ?Ǫ) + ("O,'" ["Ǫ́"]) + ("a\"" ?ä) + ("a\"'" ["ä́"]) + ("A\"" ?Ä) + ("A\"'" ["Ä́"]) + ;; From Woodbury (2003) orthography: + ("a/" ?æ) + ("a/'" ["ǽ"]) + ("A/" ?Æ) + ("A/'" ["Ǽ"]) + ("u," ?ų) + ("u,'" ["ų́"]) + ("U," ?Ų) + ("U,'" ["Ų́"]) + + ("a''" ["a'"]) + ("A''" ["A'"]) + ("e''" ["e'"]) + ("E''" ["E'"]) + ("i''" ["i'"]) + ("I''" ["I'"]) + ("o''" ["o'"]) + ("O''" ["O'"]) + ("e,," ["e,"]) + ("e,''" ["ę'"]) + ("E,," ["E,"]) + ("E,''" ["Ę'"]) + ("o,," ["o,"]) + ("o,''" ["ǫ'"]) + ("O,," ["O,"]) + ("O,''" ["Ǫ'"]) + ("a\"\"" ["a\""]) + ("a\"''" ["ä'"]) + ("A\"\"" ["A\""]) + ("A\"''" ["Ä'"]) + ("a//" ["a/"]) + ("a/''" ["æ'"]) + ("A//" ["A/"]) + ("A/''" ["Æ'"]) + ("u,," ["u,"]) + ("u,''" ["ų'"]) + ("U,," ["U,"]) + ("U,''" ["Ų'"])) + "Alist of rules for vowel letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-onondaga-consonant-alist + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK}) + (";:" ?\N{LATIN LETTER GLOTTAL STOP})) + "Alist of rules for consonant letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-onondaga-nasal-alist + '(("n-" ?ñ) + ("n--" ["n-"]) + ("N-" ?Ñ) + ("N--" ["N-"])) + "Alist of rules for nasal modifier letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "onondaga-postfix" "Onondaga" "ONO<" t + "Onondaga (Onųdaʔgegáʔ) input method with postfix modifiers + +Modifiers: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| :: | · | Vowel length (alternate) | + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | + +Doubling the postfix separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+---------------------------------------| +| Six Nations of the Grand River orthography | +|-----------------------------------------------------------| +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Back high nasal vowel | +| O, | Ǫ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +|-----------------------------------------------------------| +| Onondaga Nation, New York orthography | +|-----------------------------------------------------------| +| en- | eñ | Mid front nasal vowel | +| EN- | EÑ | Mid front nasal vowel (capital) | +| on- | oñ | Back high nasal vowel | +| ON- | OÑ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +|-----------------------------------------------------------| +| Dictionary orthography (Hanni Woodbury, 2003) | +|-----------------------------------------------------------| +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| u, | ų | Back high nasal vowel | +| U, | Ų | Back high nasal vowel (capital) | +| a/ | æ | Low front rounded vowel | +| A/ | Æ | Low front rounded vowel (capital) | + +a, e, i, and o are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| ;; | \\=’ | Glottal stop | +| ;: | ʔ | Glottal stop (alternate) | + +c, d, g, h, j, k, n, s, t, w, and y are bound to a single key. + +All Haudenosaunee languages, including Onondaga, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-onondaga-modifier-alist + iroquoian-onondaga-consonant-alist + iroquoian-onondaga-nasal-alist + iroquoian-onondaga-vowel-alist)) + (quail-defrule key trans)) + + +;;; Cayuga + +;; +;; The primary community orthography used for the Cayuga language is +;; called the Henry orthography, after important language revitalist +;; Reginald Henry. There are slight variations, particularly in which +;; letter is used to represent the glottal stop. While the most common +;; seems to be <ˀ> [modifier letter glottal stop], this input method +;; provides mappings for other glottal stop letters in common use. +;; Other common orthographies should be covered by this input method as +;; well. +;; +;; Reference work for Cayuga orthography: +;; +;; Carrie Dyck, Frances Froman, Alfred Keye & Lottie Keye. 2024. A +;; grammar and dictionary of Gayogo̱hó:nǫˀ (Cayuga) (Estudios de +;; Lingüística Amerindia 1). Berlin: Language Science Press. +;; + +(defconst iroquoian-cayuga-modifier-alist nil + "Alist of rules for modifier letters in Cayuga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-cayuga-vowel-alist + '(("a'" ?á) + ("a-" ["a̱"]) + ("A'" ?Á) + ("A-" ["A̱"]) + ("e'" ?é) + ("e-" ["e̱"]) + ("E'" ?É) + ("E-" ["E̱"]) + ("i'" ?í) + ("i-" ["i̱"]) + ("I'" ?Í) + ("I-" ["I̱"]) + ("o'" ?ó) + ("o-" ["o̱"]) + ("O'" ?Ó) + ("O-" ["O̱"]) + ("u'" ?ú) + ("u-" ["u̱"]) + ("U'" ?Ú) + ("U-" ["U̱"]) + ("e," ?ę) + ("e,'" ["ę́"]) + ("e,-" ["ę̱"]) + ("E," ?Ę) + ("E,'" ["Ę́"]) + ("E,-" ["Ę̱"]) + ("o," ?ǫ) + ("o,'" ["ǫ́"]) + ("o,-" ["ǫ̱"]) + ("O," ?Ǫ) + ("O,'" ["Ǫ́"]) + ("O,-" ["Ǫ̱"]) + + ("a''" ["a'"]) + ("a--" ["a-"]) + ("A''" ["A'"]) + ("A--" ["A-"]) + ("e''" ["e'"]) + ("e--" ["e-"]) + ("E''" ["E'"]) + ("E--" ["E-"]) + ("i''" ["i'"]) + ("i--" ["i-"]) + ("I''" ["I'"]) + ("I--" ["I-"]) + ("o''" ["o'"]) + ("o--" ["o-"]) + ("O''" ["O'"]) + ("O--" ["O-"]) + ("u''" ["u'"]) + ("u--" ["u-"]) + ("U''" ["U'"]) + ("U--" ["U-"]) + ("e,," ["e,"]) + ("e,''" ["ę'"]) + ("e,--" ["ę-"]) + ("E,," ["E,"]) + ("E,''" ["Ę'"]) + ("E,--" ["Ę-"]) + ("o,," ["o,"]) + ("o,''" ["ǫ'"]) + ("o,--" ["ǫ-"]) + ("O,," ["O,"]) + ("O,''" ["Ǫ'"]) + ("O,--" ["Ǫ-"])) + "Alist of rules for vowel letters in Cayuga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-cayuga-consonant-alist + '((";;" ?\N{MODIFIER LETTER GLOTTAL STOP}) + (";'" ?\N{RIGHT SINGLE QUOTATION MARK})) + "Alist of rules for consonant letters in Cayuga input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "cayuga-postfix" "Cayuga" "CAY<" t + "Cayuga (Gayogo̱ho:nǫhnéha:ˀ) input method with postfix modifiers + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | + +Doubling the postfix separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+---------------------------------| +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Mid back nasal vowel | +| O, | Ǫ | Mid back nasal vowel (capital) | + +a, e, i, o, and u are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-------+-------------+--------------------------| +| ;; | ˀ | Glottal stop | +| ;\\=' | \\=’ | Glottal stop (alternate) | + +d, g, h, j, k, n, r, s, t, w, y, and f are bound to a single key. + +Devoicing: + +| Key | Description | Example | +|-----+------------------------+----------| +| - | Combining macron below | a- -> a̱ | + +Note: Not all fonts can properly display a combining macron low on all +vowels. + +To enter a plain hyphen after a vowel, simply type the hyphen twice. + +All Haudenosaunee languages, including Cayuga, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-cayuga-modifier-alist + iroquoian-cayuga-consonant-alist + iroquoian-cayuga-vowel-alist)) + (quail-defrule key trans)) + + +;;; Seneca + +;; +;; The orthography for the Seneca language is fairly stable with only +;; minor variations, for example, <sy> vs. <š> (currently preferred in +;; community orthography) for the voiceless postalveolar fricative. +;; +;; In the common community orthography, I'm told that acute and grave +;; accents occur rarely and only on nasal vowels (personal +;; communication). However, in works by Wallace Chafe, stress is +;; indicated on non-nasal vowels, as well. The maximal set of letters +;; with accent diacritics is included for the input method, even though +;; many of them apparently don't occur in community orthographies. +;; +;; Reference works for Seneca orthography: +;; +;; Phyllis E. Wms. Bardeau. 2002. Onondowa'ga:' Gawe:no': New Reference +;; Edition. Salamanca, NY: The Seneca Nation of Indians Allegany +;; Education Department. +;; +;; Wallace Chafe. 2015. A Grammar of the Seneca Language. Oakland, CA: +;; University of California Press. +;; + +(defconst iroquoian-seneca-modifier-alist nil + "Alist of rules for modifier letters in Seneca input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-seneca-vowel-alist + '(("a'" ?á) + ("a`" ?à) + ("A'" ?Á) + ("A`" ?À) + ("e'" ?é) + ("e`" ?è) + ("E'" ?É) + ("E`" ?È) + ("i'" ?í) + ("i`" ?ì) + ("I'" ?Í) + ("I`" ?Ì) + ("o'" ?ó) + ("o`" ?ò) + ("O'" ?Ó) + ("O`" ?Ò) + ("a\"" ?ä) + ("a\"'" ["ä́"]) + ("a\"`" ["ä̀"]) + ("A\"" ?Ä) + ("A\"'" ["Ä́"]) + ("A\"`" ["Ä̀"]) + ("e\"" ?ë) + ("e\"'" ["ë́"]) + ("e\"`" ["ë̀"]) + ("E\"" ?Ë) + ("E\"'" ["Ë́"]) + ("E\"`" ["Ë̀"]) + ("o\"" ?ö) + ("o\"'" ["ö́"]) + ("o\"`" ["ö̀"]) + ("O\"" ?Ö) + ("O\"'" ["Ö́"]) + ("O\"`" ["Ö̀"]) + ;; Rare (e.g., niwú’u:h 'it is tiny' [Chafe 2015]): + ("u'" ?ú) + ("u`" ?ù) + ("U'" ?Ú) + ("U`" ?Ù) + + ("a''" ["a'"]) + ("a``" ["a`"]) + ("A''" ["A'"]) + ("A``" ["A`"]) + ("e''" ["e'"]) + ("e``" ["e`"]) + ("E''" ["E'"]) + ("E``" ["E`"]) + ("i''" ["i'"]) + ("i``" ["i`"]) + ("I''" ["I'"]) + ("I``" ["I`"]) + ("o''" ["o'"]) + ("o``" ["o`"]) + ("O''" ["O'"]) + ("O``" ["O`"]) + ("a\"\"" ["a\""]) + ("a\"''" ["ä'"]) + ("a\"``" ["ä`"]) + ("A\"\"" ["A\""]) + ("A\"''" ["Ä'"]) + ("A\"``" ["Ä`"]) + ("e\"\"" ["e\""]) + ("e\"''" ["ë'"]) + ("e\"``" ["ë`"]) + ("E\"\"" ["E\""]) + ("E\"''" ["Ë'"]) + ("E\"``" ["Ë`"]) + ("o\"\"" ["o\""]) + ("o\"''" ["ö'"]) + ("o\"``" ["ö`"]) + ("O\"\"" ["O\""]) + ("O\"''" ["Ö'"]) + ("O\"``" ["Ö`"]) + ("u''" ["u'"]) + ("u``" ["u`"]) + ("U''" ["U'"]) + ("U``" ["U`"])) + "Alist of rules for vowel letters in Seneca input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-seneca-consonant-alist + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK}) + ("s/" ?š) + ("s//" ["s/"]) + ("S/" ?Š) + ("S//" ["S/"])) + "Alist of rules for consonant letters in Seneca input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "seneca-postfix" "Seneca" "SEE<" t + "Seneca (Onödowá’ga:’) input method with postfix modifiers + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á| +| \\=` | Grave accent | a` -> à| + +Doubling any of these postfixes separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+------------------------------------| +| e\" | ë | Mid front nasal vowel | +| E\" | Ë | Mid front nasal vowel (capital) | +| o\" | ö | Low-mid back nasal vowel | +| O\" | Ö | Low-mid back nasal vowel (capital) | +| a\" | ä | Low front vowel | +| A\" | Ä | Low front vowel (capital) | + +a, e, i, o, and u are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-------+-------------+--------------------------------------------| +| ;; | \\=’ | Glottal stop | +| s/ | š | Voiceless postalveolar fricative | +| S/ | Š | Voiceless postalveolar fricative (capital) | + +d, g, h, j, k, n, s, t, w, y, and z are bound to a single key. + +b, m, and p are used rarely in ideophones and nicknames. They are also +each bound to a single key. + +All Haudenosaunee languages, including Seneca, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-seneca-modifier-alist + iroquoian-seneca-consonant-alist + iroquoian-seneca-vowel-alist)) + (quail-defrule key trans)) + + +;;; Haudenosaunee (composite Northern Iroquoian) + +;; +;; This input method represents a composite input method for all of the +;; Northern Iroquoian languages included above. +;; +;; Although the "Iroquoian languages" is a standard term employed by +;; linguists and scholars, some believe the term "Iroquois" to be of +;; derogatory origin (see Dyck 2024). Hence, some prefer to refer to +;; what are collectively termed by linguists the "Five Nations Iroquois" +;; languages (Mohawk, Oneida, Onondaga, Cayuga, Seneca) by the autonym +;; "Haudenosaunee" (e.g., "Haudenosaunee languages"). +;; +;; However, it should be noted that the term "Haudenosaunee" is itself +;; an Anglicized form, probably from Seneca Hodínöhsö:ni:h 'they make +;; houses' or Hodínöhšo:ni:h 'People of the Long House'. Speakers of +;; Cayuga may prefer the word Hodinǫhsǫ:nih, and speakers of Mohawk may +;; prefer Rotinonhsón:ni or Rotinonhsíón:ni. These terms themselves +;; collectively relate to the confederacy of Indigenous nations that has +;; existed in what is now known as New York State in Northeastern North +;; America for many centuries, the founding of which is retold in oral +;; tradition in the story of The Peacemaker. +;; +;; It should also be noted that while Tuscarora and Wendat languages are +;; both sometimes included under the "Haudenosaunee languages" umbrella +;; (and by implication, those groups as a part of the Haudenosaunee +;; Confederacy), the exact extent of what defines "Haudenosaunee" has +;; occasionally caused controversy. +;; +;; Additionally, some prefer to collectively refer to the "Haudenosaunee +;; languages" using the terms Onkwehonwehnéha (Mohawk), Ukwehuwehnéha +;; (Oneida), Ǫgwehǫwekhá’ (Onondaga), Ǫgwehǫwéhneha:ˀ (Cayuga), and +;; Ögwé’öwe:ka:’ (Seneca), which all mean 'in the manner of the Original +;; People'. +;; +;; Bearing all of this in mind, I have opted to retain the term +;; "Iroquoian" in the name of this file (`iroquoian.el') (and hence, in +;; the symbol names in its namespace), while using "Haudenosaunee" in +;; the name of the input method that encompasses all of the languages so +;; far implemented: "haudenosaunee-postfix" --- this is the name shown +;; as a completion candidate after users enter M-x set-input-method RET. +;; Note that those searching for input methods for the individual +;; languages should have no problem finding them knowing only their +;; Anglicized names (e.g., Mohawk, Oneida, etc.), as these have been +;; retained in the names of the corresponding input methods. +;; +;; Above all, I hope that these decisions help those who wish to speak, +;; read, and write Onkwehonwehnéha. +;; +;; Iorihowá:nen ne aiónhnheke’ ne raotiwén:na’! +;; It is important that the language continues to live! +;; + +(defconst iroquoian-haudenosaunee-modifier-alist + (seq-uniq (append iroquoian-mohawk-modifier-alist + iroquoian-oneida-modifier-alist + iroquoian-onondaga-modifier-alist + iroquoian-cayuga-modifier-alist + iroquoian-seneca-modifier-alist)) + "Alist of rules for modifier letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-vowel-alist + (seq-uniq (append iroquoian-mohawk-vowel-alist + iroquoian-oneida-vowel-alist + iroquoian-onondaga-vowel-alist + iroquoian-cayuga-vowel-alist + iroquoian-seneca-vowel-alist)) + "Alist of rules for vowel letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-consonant-alist + (seq-uniq (append + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK}) + (";'" ?\N{MODIFIER LETTER GLOTTAL STOP}) + (";:" ?\N{LATIN LETTER GLOTTAL STOP})) + iroquoian-mohawk-consonant-alist + iroquoian-oneida-consonant-alist + iroquoian-onondaga-consonant-alist + iroquoian-cayuga-consonant-alist + iroquoian-seneca-consonant-alist) + (lambda (c1 c2) + (equal (car c1) (car c2)))) + "Alist of rules for consonant letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-devoicing-alist + '(("_" ?\N{COMBINING LOW LINE}) + ("__" ?_)) + "Alist of rules for devoicing characters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-nasal-alist iroquoian-onondaga-nasal-alist + "Alist of rules for nasal modifier letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "haudenosaunee-postfix" "Haudenosaunee" "HOD<" t + "Composite input method for Haudenosaunee (Northern Iroquoian) languages + +This input method can be used to enter the following languages: + +- Mohawk (Kanien’kéha / Onkwehonwehnéha) +- Oneida (Onʌyota:ká: / Ukwehuwehnéha) +- Cayuga (Gayogo̱ho:nǫhnéha:ˀ) +- Onondaga (Onųdaʔgegáʔ) +- Seneca (Onödowá’ga:’) + +Modifiers: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| :: | · | Vowel length (alternate) | + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | +| \\=` | Grave accent | a` -> à | + +Doubling any of these postfixes separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|----------------------------------------------------------------------| +| Mohawk | +| -------------------------------------------------------------------- | +| Single-key vowels: a e i o | +|----------------------------------------------------------------------| +| Oneida | +| -------------------------------------------------------------------- | +| e/ | ʌ | Mid central nasal vowel | +| E/ | Ʌ | Mid central nasal vowel (capital) | +| Single-key vowels: a e i o u | +|----------------------------------------------------------------------| +| Onondaga | +| (Six Nations of the Grand River) | +| -------------------------------------------------------------------- | +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Back high nasal vowel | +| O, | Ǫ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +| -------------------------------------------------------------------- | +| (Onondaga Nation, New York) | +| -------------------------------------------------------------------- | +| en~ | eñ | Mid front nasal vowel | +| EN~ | EÑ | Mid front nasal vowel (capital) | +| on~ | oñ | Back high nasal vowel | +| ON~ | OÑ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +| -------------------------------------------------------------------- | +| (Hanni Woodbury, 2003) | +| -------------------------------------------------------------------- | +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| u, | ų | Back high nasal vowel | +| U, | Ų | Back high nasal vowel (capital) | +| a/ | æ | Low front rounded vowel | +| A/ | Æ | Low front rounded vowel (capital) | +| -------------------------------------------------------------------- | +| (all) | +| -------------------------------------------------------------------- | +| Single-key vowels: a e i o | +|----------------------------------------------------------------------| +| Cayuga | +| -------------------------------------------------------------------- | +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Mid back nasal vowel | +| O, | Ǫ | Mid back nasal vowel (capital) | +| Single-key vowels: a e i o u | +|----------------------------------------------------------------------| +| Seneca | +| -------------------------------------------------------------------- | +| e\" | ë | Mid front nasal vowel | +| E\" | Ë | Mid front nasal vowel (capital) | +| o\" | ö | Low-mid back nasal vowel | +| O\" | Ö | Low-mid back nasal vowel (capital) | +| a\" | ä | Low front vowel | +| A\" | Ä | Low front vowel (capital) | +| Single-key vowels: a e i o u | + +Consonants: + +| Key | Translation | Description | +|----------------------------------------------------------------------| +| Mohawk | +| -------------------------------------------------------------------- | +| ;; | \\=’ | Glottal stop | +| Single-key consonants: h k n r s t w y (b m p) | +|----------------------------------------------------------------------| +| Oneida | +| -------------------------------------------------------------------- | +| ;\\=' | ˀ | Glottal stop | +| ;; | \\=’ | Glottal stop (alternate) | +| Single-key consonants: h k l n s t w y | +|----------------------------------------------------------------------| +| Onondaga | +| -------------------------------------------------------------------- | +| ;; | \\=’ | Glottal stop | +| ;: | ʔ | Glottal stop (alternate) | +| Single-key consonants: c d g h j k n s t w y | +|----------------------------------------------------------------------| +| Cayuga | +| -------------------------------------------------------------------- | +| ;\\=' | ˀ | Glottal stop | +| ;; | \\=’ | Glottal stop (alternate) | +| Single-key consonants: d g h j k n r s t w y (f) | +|----------------------------------------------------------------------| +| Seneca | +| -------------------------------------------------------------------- | +| ;; | \\=’ | Glottal stop | +| s/ | š | Voiceless postalveolar fricative | +| S/ | Š | Voiceless postalveolar fricative (capital) | +| Single-key consonants: d g h j k n s t w y z (b m p) | + +Devoicing: + +| Key | Description | Examples | +|-----+------------------------+------------------------------| +| _ | Combining low line | a_ -> a̲, · -> ·̲ | +| - | Combining macron below | a- -> a̱(after vowels only) | + +Note: Not all fonts can properly display a combining low line on all +letters and a combining macron below on all vowels. + +Underlining is commonly used in Oneida to indicate devoiced syllables on +pre-pausal forms (also called utterance-final forms). Alternatively, +markup or other methods can be used to create an underlining effect. + +To enter a plain underscore, the underscore twice. + +Macron below is commonly used in Cayuga to indicate devoiced vowels. + +To enter a plain hyphen after a vowel, simply type the hyphen twice. + +There are individual input methods for each of the languages that can be +entered with this input method: `mohawk-postfix', `oneida-postfix', +`onondaga-postfix', `cayuga-postfix', `seneca-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-haudenosaunee-modifier-alist + iroquoian-haudenosaunee-consonant-alist + iroquoian-haudenosaunee-nasal-alist + iroquoian-haudenosaunee-vowel-alist + iroquoian-haudenosaunee-devoicing-alist)) + (quail-defrule key trans)) + +(provide 'iroquoian) +;;; iroquoian.el ends here diff --git a/lisp/loadup.el b/lisp/loadup.el index 6d1e13f44bf..bd74a9d6aff 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -1,4 +1,4 @@ -;;; loadup.el --- load up standardly loaded Lisp files for Emacs -*- lexical-binding: t; -*- +;;; loadup.el --- load up always-loaded Lisp files for Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 1985-1986, 1992, 1994, 2001-2024 Free Software ;; Foundation, Inc. diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index a58be4dccf0..285095f9264 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -493,7 +493,7 @@ and send the mail again%s." (re-search-forward "^From: " nil t) (error "Please edit the From address and try again")))) ;; Bury the help buffer (if it's shown). - (when-let ((help (get-buffer "*Bug Help*"))) + (when-let* ((help (get-buffer "*Bug Help*"))) (when (get-buffer-window help) (quit-window nil (get-buffer-window help))))) @@ -549,7 +549,7 @@ Message buffer where you can explain more about the patch." (message-add-action (lambda () ;; Bury the help buffer (if it's shown). - (when-let ((help (get-buffer "*Patch Help*"))) + (when-let* ((help (get-buffer "*Patch Help*"))) (when (get-buffer-window help) (quit-window nil (get-buffer-window help))))) 'send)) diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index eaccbff0b13..e314b3d13ae 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -275,11 +275,11 @@ a list of address strings." ((eq c ?:) (setq beg (1+ (point))) (skip-chars-forward "^;") - (when-let ((address - (condition-case nil - (ietf-drums-parse-addresses - (buffer-substring beg (point)) rawp) - (error nil)))) + (when-let* ((address + (condition-case nil + (ietf-drums-parse-addresses + (buffer-substring beg (point)) rawp) + (error nil)))) (if (listp address) (setq pairs (append address pairs)) (push address pairs))) diff --git a/lisp/mail/mailclient.el b/lisp/mail/mailclient.el index 1233d9ace95..fe4e49d0e1b 100644 --- a/lisp/mail/mailclient.el +++ b/lisp/mail/mailclient.el @@ -143,7 +143,7 @@ The mail client is taken to be the handler of mailto URLs." (narrow-to-region (point-min) delimline) ;; We can't send multipart/* messages (i. e. with ;; attachments or the like) via this method. - (when-let ((type (mail-fetch-field "content-type"))) + (when-let* ((type (mail-fetch-field "content-type"))) (when (and (string-match "multipart" (car (mail-header-parse-content-type type))) diff --git a/lisp/mail/rfc6068.el b/lisp/mail/rfc6068.el index 06fe92f0ca7..562e2312f3f 100644 --- a/lisp/mail/rfc6068.el +++ b/lisp/mail/rfc6068.el @@ -72,7 +72,7 @@ calling this function." (when address (setq address (rfc6068-unhexify-string address)) ;; Deal with multiple 'To' recipients. - (if-let ((elem (assoc "To" headers-alist))) + (if-let* ((elem (assoc "To" headers-alist))) (setcdr elem (concat address ", " (cdr elem))) (push (cons "To" address) headers-alist))) diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el index 98ac17a99ed..c70880b0632 100644 --- a/lisp/mail/undigest.el +++ b/lisp/mail/undigest.el @@ -65,7 +65,7 @@ each undigestified message as markers.") (defun rmail-digest-parse-mixed-mime () "Like `rmail-digest-parse-mime', but for multipart/mixed messages." - (when-let ((boundary (rmail-content-type-boundary "multipart/mixed"))) + (when-let* ((boundary (rmail-content-type-boundary "multipart/mixed"))) (let ((global-sep (concat "\n--" boundary)) (digest (concat "^Content-type: multipart/digest;" "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]")) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 804afe9cb43..9b498615926 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -168,9 +168,9 @@ specify the property, the `completion-extra-properties' plist is consulted. Note that the keys of the `completion-extra-properties' plist are keyword symbols, not plain symbols." - (if-let (((not (eq prop 'category))) - (cat (completion--metadata-get-1 metadata 'category)) - (over (completion--category-override cat prop))) + (if-let* (((not (eq prop 'category))) + (cat (completion--metadata-get-1 metadata 'category)) + (over (completion--category-override cat prop))) (cdr over) (completion--metadata-get-1 metadata prop))) @@ -2564,7 +2564,7 @@ The candidate will still be chosen by `choose-completion' unless (defun completions--after-change (_start _end _old-len) "Update displayed *Completions* buffer after change in buffer contents." (when completion-auto-deselect - (when-let (window (get-buffer-window "*Completions*" 0)) + (when-let* ((window (get-buffer-window "*Completions*" 0))) (with-selected-window window (completions--deselect))))) @@ -2624,6 +2624,12 @@ The candidate will still be chosen by `choose-completion' unless (sort-fun (completion-metadata-get all-md 'display-sort-function)) (group-fun (completion-metadata-get all-md 'group-function)) (mainbuf (current-buffer)) + (current-candidate-and-offset + (when-let* ((buffer (get-buffer "*Completions*")) + (window (get-buffer-window buffer 0))) + (with-current-buffer buffer + (when-let* ((beg (completions--start-of-candidate-at (window-point window)))) + (cons (get-text-property beg 'completion--string) (- (point) beg)))))) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in ;; minibuffer-hide-completions will know whether to @@ -2647,7 +2653,7 @@ The candidate will still be chosen by `choose-completion' unless ,(when temp-buffer-resize-mode '(preserve-size . (nil . t))) (body-function - . ,#'(lambda (_window) + . ,#'(lambda (window) (with-current-buffer mainbuf (when completion-auto-deselect (add-hook 'after-change-functions #'completions--after-change nil t)) @@ -2737,7 +2743,16 @@ The candidate will still be chosen by `choose-completion' unless (if (eq (car bounds) (length result)) 'exact 'finished)))))) - (display-completion-list completions nil group-fun))))) + (display-completion-list completions nil group-fun) + (when current-candidate-and-offset + (with-current-buffer standard-output + (when-let* ((match (text-property-search-forward + 'completion--string (car current-candidate-and-offset) t))) + (goto-char (prop-match-beginning match)) + ;; Preserve the exact offset for the sake of + ;; `choose-completion-deselect-if-after'. + (forward-char (cdr current-candidate-and-offset)) + (set-window-point window (point))))))))) nil))) nil)) @@ -2746,8 +2761,12 @@ The candidate will still be chosen by `choose-completion' unless ;; FIXME: We could/should use minibuffer-scroll-window here, but it ;; can also point to the minibuffer-parent-window, so it's a bit tricky. (interactive) - (let ((win (get-buffer-window "*Completions*" 0))) - (if win (with-selected-window win (bury-buffer))))) + (when-let* ((win (get-buffer-window "*Completions*" 0))) + (with-selected-window win + ;; Move point off any completions, so we don't move point there + ;; again the next time `minibuffer-completion-help' is called. + (goto-char (point-min)) + (bury-buffer)))) (defun exit-minibuffer () "Terminate this minibuffer argument." @@ -3192,7 +3211,7 @@ and `RET' accepts the input typed into the minibuffer." "Return CMD if `minibuffer-visible-completions' bindings should be active." (if minibuffer-visible-completions--always-bind cmd - (when-let ((window (get-buffer-window "*Completions*" 0))) + (when-let* ((window (get-buffer-window "*Completions*" 0))) (when (and (eq (buffer-local-value 'completion-reference-buffer (window-buffer window)) (window-buffer (active-minibuffer-window))) @@ -4905,8 +4924,6 @@ insert the selected completion candidate to the minibuffer." (interactive "p") (let ((auto-choose minibuffer-completion-auto-choose)) (with-minibuffer-completions-window - (when completions-highlight-face - (setq-local cursor-face-highlight-nonselected-window t)) (if vertical (next-line-completion (or n 1)) (next-completion (or n 1))) diff --git a/lisp/mpc.el b/lisp/mpc.el index 9905e3aa554..a0ecb21e454 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -63,7 +63,7 @@ ;; e.g. filename regexp -> compilation flag ;; - window/buffer management. ;; - menubar, tooltips, ... -;; - add mpc-describe-song, mpc-describe-album, ... +;; - add mpc-describe-album, ... ;; - add import/export commands (especially export to an MP3 player). ;; - add a real notion of album (as opposed to just album-name): ;; if all songs with same album-name have same artist -> it's an album @@ -95,6 +95,8 @@ (require 'notifications) +(require 'vtable) + (defgroup mpc () "Client for the Music Player Daemon (mpd)." :prefix "mpc-" @@ -918,6 +920,16 @@ If PLAYLIST is t or nil or missing, use the main playlist." "Directory where MPC.el stores auxiliary data." :type 'directory) +(defcustom mpc-crossfade-time 3 + "Number of seconds to crossfade between songs." + :version "31.1" + :type 'natnum) + +(defun mpc-cmd-crossfade (&optional arg) + "Set duration of crossfade to `mpc-crossfade-time' or ARG seconds." + (mpc-proc-cmd (list "crossfade" (or arg mpc-crossfade-time)) + #'mpc-status-refresh)) + (defun mpc-data-directory () (unless (file-directory-p mpc-data-directory) (make-directory mpc-data-directory)) @@ -968,11 +980,15 @@ If PLAYLIST is t or nil or missing, use the main playlist." :version "28.1") (defun mpc-secs-to-time (secs) + "Convert SECS from a string, integer or float value to a time string." ;; We could use `format-seconds', but it doesn't seem worth the trouble ;; because we'd still need to check (>= secs (* 60 100)) since the special ;; %z only allows us to drop the large units for small values but ;; not to drop the small units for large values. (if (stringp secs) (setq secs (string-to-number secs))) + ;; Ensure secs is an integer. The Time tag has been deprecated by MPD + ;; and its replacement (the duration tag) includes fractional seconds. + (if (floatp secs) (setq secs (round secs))) (if (>= secs (* 60 100)) ;More than 100 minutes. (format "%dh%02d" ;"%d:%02d:%02d" (/ secs 3600) (% (/ secs 60) 60)) ;; (% secs 60) @@ -1170,7 +1186,8 @@ string POST." ">" #'mpc-next "<" #'mpc-prev "g" #'mpc-seek-current - "o" #'mpc-goto-playing-song) + "o" #'mpc-goto-playing-song + "d" #'mpc-describe-song) (easy-menu-define mpc-mode-menu mpc-mode-map "Menu for MPC mode." @@ -1179,6 +1196,7 @@ string POST." ["Next Track" mpc-next] ;FIXME: Add ⇥ there? ["Previous Track" mpc-prev] ;FIXME: Add ⇤ there? ["Seek Within Track" mpc-seek-current] + ["Song Details" mpc-describe-song] "--" ["Repeat Playlist" mpc-toggle-repeat :style toggle :selected (member '(repeat . "1") mpc-status)] @@ -1188,6 +1206,8 @@ string POST." :selected (member '(single . "1") mpc-status)] ["Consume Mode" mpc-toggle-consume :style toggle :selected (member '(consume . "1") mpc-status)] + ["Crossfade Songs" mpc-toggle-crossfade :style toggle + :selected (alist-get 'xfade mpc-status)] "--" ["Add new browser" mpc-tagbrowser] ["Update DB" mpc-update] @@ -2428,6 +2448,12 @@ This is used so that they can be compared with `eq', which is needed for (mpc-cmd-random (if (string= "0" (cdr (assq 'random (mpc-cmd-status)))) "1" "0"))) +(defun mpc-toggle-crossfade () + "Toggle crossfading between songs." + (interactive) + (mpc-cmd-crossfade + (if (alist-get 'xfade mpc-status) "0" mpc-crossfade-time))) + (defun mpc-stop () "Stop playing the current queue of songs." (interactive) @@ -2844,6 +2870,98 @@ will be used. See `mpc-format' for the definition of FORMAT-SPEC." :app-icon icon :replaces-id mpc--notifications-id)))) +;;; Song Viewer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defface mpc-song-viewer-value + '((t (:inherit vtable))) + "Face for tag values in the MPC song viewer.") + +(defface mpc-song-viewer-tag + '((t (:inherit (mpc-song-viewer-value bold)))) + "Face for tag types in the MPC song viewer.") + +(defface mpc-song-viewer-empty + '((t (:inherit (mpc-song-viewer-value italic shadow)))) + "Face for empty tag values in the MPC song viewer.") + +(defcustom mpc-song-viewer-tags + '("Title" "Artist" "Album" "Performer" "Composer" + "Date" "Duration" "Disc" "Track" "Genre" "File") + "The list of tags to display with `mpc-describe-song'. + +The list of supported tags are available by evaluating +`mpc-cmd-tagtypes'. In addition to the standard MPD tags: Bitrate, +Duration, File, and Format are also supported." + :version "31.1" + :type '(repeat string)) + +(defun mpc-describe-song (file) + "Show details of the selected song or FILE in the MPC song viewer. + +If there is no song at point then information about the currently +playing song is displayed." + (interactive + ;; Handle being called from the context menu. In that case you want + ;; to see details for the song you clicked on to invoke the menu not + ;; whatever `point' happens to be on at that time. + (list (when-let* ((event last-nonmenu-event) + ((listp event)) + (position (nth 1 (event-start event)))) + (get-text-property position 'mpc-file)))) + (let ((tags (or (when (and file (stringp file)) + (mpc-proc-cmd-to-alist (list "search" "file" file))) + (when-let* (((string= (buffer-name) "*MPC-Songs*")) + (file (get-text-property (point) 'mpc-file))) + (mpc-proc-cmd-to-alist (list "search" "file" file))) + (when (assoc 'file mpc-status) mpc-status))) + (buffer "*MPC Song Viewer*")) + (when tags + (with-current-buffer (get-buffer-create buffer) + (special-mode) + (visual-line-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (make-vtable + :columns '(( :name "Tag" + :align right + :min-width 3 + :displayer + (lambda (tag &rest _) + (propertize tag 'face 'mpc-song-viewer-tag))) + ( :name "Value" + :align left + :min-width 5 + :displayer + (lambda (value &rest _) + (if (and value (not (string-blank-p value))) + (propertize value 'face 'mpc-song-viewer-value) + (propertize "empty" 'face 'mpc-song-viewer-empty))))) + :objects (mapcar + (lambda (tag) + (pcase tag + ("Bitrate" + (list tag (let ((bitrate (alist-get 'bitrate tags))) + (when bitrate + (format "%s kpbs" bitrate))))) + ("Duration" (list tag (mpc-secs-to-time + (alist-get 'duration tags)))) + ("File" (list tag (alist-get 'file tags))) + ;; Concatenate all the values of tags which may + ;; occur multiple times. + ((or "Composer" "Genre" "Performer") + (list tag (mapconcat + (lambda (val) (cdr val)) + (seq-filter + (lambda (val) (eq (car val) (intern tag))) + tags) + "; "))) + (_ (list tag (alist-get (intern tag) tags))))) + mpc-song-viewer-tags)) + (goto-char (point-min)))) + (pop-to-buffer buffer '((display-buffer-reuse-window + display-buffer-same-window) + (reusable-frames . t)))))) + ;;; Toplevel ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom mpc-frame-alist '((name . "MPC") (tool-bar-lines . 1) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index e7912a2a4a7..c10bc671a88 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -689,7 +689,7 @@ websites are increasingly rare, but they do still exist." (defun browse-url-url-at-point () (or (thing-at-point 'url t) ;; assume that the user is pointing at something like gnu.org/gnu - (when-let ((f (thing-at-point 'filename t))) + (when-let* ((f (thing-at-point 'filename t))) (if (string-match-p browse-url-button-regexp f) f (concat browse-url-default-scheme "://" f))))) @@ -764,7 +764,7 @@ interactively. Turn the filename into a URL with function (defun browse-url-file-url (file) "Return the URL corresponding to FILE. Use variable `browse-url-filename-alist' to map filenames to URLs." - (when-let ((coding (browse-url--file-name-coding-system))) + (when-let* ((coding (browse-url--file-name-coding-system))) (setq file (encode-coding-string file coding))) (if (and (file-remote-p file) ;; We're applying special rules for FTP URLs for historical @@ -1361,7 +1361,7 @@ currently selected window instead." (if (equal (url-type parsed) "file") ;; It's a file; just open it. (let ((file (url-unhex-string (url-filename parsed)))) - (when-let ((coding (browse-url--file-name-coding-system))) + (when-let* ((coding (browse-url--file-name-coding-system))) (setq file (decode-coding-string file 'utf-8))) ;; The local-part of file: URLs on Windows is supposed to ;; start with an extra slash. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 8426d04fefd..ed1fc00f541 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -1035,8 +1035,8 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array', and the individual bytes must be a valid UTF-8 byte sequence." (declare (advertised-calling-convention (byte-array) "30.1")) - (if-let ((bytes (seq-filter #'characterp byte-array)) - (string (apply #'unibyte-string bytes))) + (if-let* ((bytes (seq-filter #'characterp byte-array)) + (string (apply #'unibyte-string bytes))) (let (last-coding-system-used) (decode-coding-string string 'utf-8 'nocopy)) "")) @@ -2100,7 +2100,7 @@ either a method name, a signal name, or an error name." "Goto D-Bus message with the same serial number." (interactive) (when (mouse-event-p last-input-event) (mouse-set-point last-input-event)) - (when-let ((point (get-text-property (point) 'dbus-serial))) + (when-let* ((point (get-text-property (point) 'dbus-serial))) (goto-char point))) (defun dbus-monitor-handler (&rest _args) diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index 50e23727c61..58c2e9771ba 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -1278,7 +1278,7 @@ prompt for DICTIONARY." (unless dictionary (setq dictionary dictionary-default-dictionary)) (if dictionary-display-definition-function - (if-let ((definition (dictionary-define-word word dictionary))) + (if-let* ((definition (dictionary-define-word word dictionary))) (funcall dictionary-display-definition-function word dictionary definition) (user-error "No definition found for \"%s\"" word)) ;; if called by pressing the button diff --git a/lisp/net/eww.el b/lisp/net/eww.el index b5d2f20781a..4d4d4d6beac 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -33,6 +33,7 @@ (require 'url) (require 'url-queue) (require 'url-file) +(require 'vtable) (require 'xdg) (eval-when-compile (require 'subr-x)) @@ -78,7 +79,7 @@ if that directory doesn't exist and the DOWNLOAD XDG user directory is defined, use the latter instead." (or (and (file-exists-p eww-default-download-directory) eww-default-download-directory) - (when-let ((dir (xdg-user-dir "DOWNLOAD"))) + (when-let* ((dir (xdg-user-dir "DOWNLOAD"))) (file-name-as-directory dir)) eww-default-download-directory)) @@ -108,6 +109,20 @@ duplicate entries (if any) removed." eww-current-url eww-bookmark-urls)) +(defcustom eww-guess-content-type-functions + '(eww--html-if-doctype) + "List of functions used by EWW to guess the content-type of Web pages. +These are only used when the page does not have a valid Content-Type +header. Functions are called in order, until one of them returns a +non-nil value to be used as Content-Type. The functions receive two +arguments: an alist of page's headers, and the buffer that holds the +complete response of the server from which the page was requested. +If the list of the functions is exhausted without any non-nil value, +EWW assumes content-type is \"application/octet-stream\", per RFC-9110." + :version "31.1" + :group 'eww + :type '(repeat function)) + (defcustom eww-bookmarks-directory user-emacs-directory "Directory where bookmark files will be stored." :version "25.1" @@ -229,8 +244,8 @@ determine the renaming scheme, as follows: (defun my-eww-rename-buffer () (when (eq major-mode \\='eww-mode) - (when-let ((string (or (plist-get eww-data :title) - (plist-get eww-data :url)))) + (when-let* ((string (or (plist-get eww-data :title) + (plist-get eww-data :url)))) (format \"*%s*\" string)))) The string of `title' and `url' is always truncated to the value @@ -610,7 +625,7 @@ for the search engine used." NO-SELECT non-nil means do not make the new buffer the current buffer." (interactive "P") - (if-let ((url (or url (eww-suggested-uris)))) + (if-let* ((url (or url (eww-suggested-uris)))) (if (or (eq eww-browse-url-new-window-is-tab t) (and (eq eww-browse-url-new-window-is-tab 'tab-bar) tab-bar-mode)) @@ -630,6 +645,30 @@ Currently this means either text/html or application/xhtml+xml." (member content-type '("text/html" "application/xhtml+xml"))) +(defun eww--guess-content-type (headers response-buffer) + "Use HEADERS and RESPONSE-BUFFER to guess the Content-Type. +Will call each function in `eww-guess-content-type-functions', until one +of them returns a value. This mechanism is used only if there isn't a +valid Content-Type header. If none of the functions can guess, return +\"application/octet-stream\"." + (save-excursion + (or (run-hook-with-args-until-success + 'eww-guess-content-type-functions headers response-buffer) + "application/octet-stream"))) + +(defun eww--html-if-doctype (_headers response-buffer) + "Return \"text/html\" if RESPONSE-BUFFER has an HTML doctype declaration. +HEADERS is unused." + ;; https://html.spec.whatwg.org/multipage/syntax.html#the-doctype + (with-current-buffer response-buffer + (let ((case-fold-search t)) + (save-excursion + (goto-char (point-min)) + ;; Match basic "<!doctype html>" and also legacy variants as + ;; specified in link above -- being purposely lax about it. + (when (search-forward "<!doctype html" nil t) + "text/html"))))) + (defun eww--rename-buffer () "Rename the current EWW buffer. The renaming scheme is performed in accordance with @@ -659,7 +698,7 @@ The renaming scheme is performed in accordance with (content-type (mail-header-parse-content-type (if (zerop (length (cdr (assoc "content-type" headers)))) - "text/plain" + (eww--guess-content-type headers (current-buffer)) (cdr (assoc "content-type" headers))))) (charset (intern (downcase @@ -2030,14 +2069,19 @@ Interactively, EVENT is the value of `last-nonmenu-event'." (push (cons name (or (plist-get input :value) "on")) values))) ((equal (plist-get input :type) "file") - (when-let ((file (plist-get input :filename))) + (when-let* ((file (plist-get input :filename))) (push (list "file" (cons "filedata" (with-temp-buffer (insert-file-contents file) (buffer-string))) (cons "name" name) - (cons "filename" file)) + ;; RFC 2183 declares that recipients should + ;; only respect the basename of the filename + ;; parameter, and the leading directories + ;; might divulge private information, so we + ;; only send the basename in our request. + (cons "filename" (file-name-nondirectory file))) values))) ((equal (plist-get input :type) "submit") ;; We want the values from buttons if we hit a button if @@ -2146,7 +2190,7 @@ If EXTERNAL is double prefix, browse in new buffer." (eww--before-browse) (plist-put eww-data :url url) (goto-char (point-min)) - (if-let ((match (text-property-search-forward 'shr-target-id target #'member))) + (if-let* ((match (text-property-search-forward 'shr-target-id target #'member))) (goto-char (prop-match-beginning match)) (goto-char (if (equal target "top") (point-min) @@ -2604,58 +2648,47 @@ see)." ;;; eww buffers list +(defun eww-buffer-list () + "Return a list of all live eww buffers." + (match-buffers '(derived-mode . eww-mode))) + (defun eww-list-buffers () - "Enlist eww buffers." + "Pop a buffer with a list of eww buffers." (interactive) - (let (buffers-info - (current (current-buffer))) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (derived-mode-p 'eww-mode) - (push (vector buffer (plist-get eww-data :title) - (plist-get eww-data :url)) - buffers-info)))) - (unless buffers-info - (error "No eww buffers")) - (setq buffers-info (nreverse buffers-info)) ;more recent on top - (set-buffer (get-buffer-create "*eww buffers*")) + (with-current-buffer (get-buffer-create "*eww buffers*") (eww-buffers-mode) - (let ((inhibit-read-only t) - (domain-length 0) - (title-length 0) - url title format start) - (erase-buffer) - (dolist (buffer-info buffers-info) - (setq title-length (max title-length - (length (elt buffer-info 1))) - domain-length (max domain-length - (length (elt buffer-info 2))))) - (setq format (format "%%-%ds %%-%ds" title-length domain-length) - header-line-format - (concat " " (format format "Title" "URL"))) - (let ((line 0) - (current-buffer-line 1)) - (dolist (buffer-info buffers-info) - (setq start (point) - title (elt buffer-info 1) - url (elt buffer-info 2) - line (1+ line)) - (insert (format format title url)) - (insert "\n") - (let ((buffer (elt buffer-info 0))) - (put-text-property start (1+ start) 'eww-buffer - buffer) - (when (eq current buffer) - (setq current-buffer-line line)))) - (goto-char (point-min)) - (forward-line (1- current-buffer-line))))) + (eww--list-buffers-display-table)) (pop-to-buffer "*eww buffers*")) +(defun eww--list-buffers-display-table (&optional _ignore-auto _noconfirm) + "Display a table with the list of eww buffers. +Will remove all buffer contents first. The parameters IGNORE-AUTO and +NOCONFIRM are ignored, they are for compatibility with +`revert-buffer-function'." + (let ((inhibit-read-only t)) + (erase-buffer) + (make-vtable + :columns '((:name "Title" :min-width "25%" :max-width "50%") + (:name "URL")) + :objects-function #'eww--list-buffers-get-data + ;; use fixed-font face + :face 'default))) + +(defun eww--list-buffers-get-data () + "Return the eww-data of BUF, assumed to be a eww buffer. +The format of the data is (title url buffer), for use in of +`eww-buffers-mode'." + (mapcar (lambda (buf) + (let ((buf-eww-data (buffer-local-value 'eww-data buf))) + (list (plist-get buf-eww-data :title) + (plist-get buf-eww-data :url) + buf))) + (eww-buffer-list))) + (defun eww-buffer-select () "Switch to eww buffer." (interactive nil eww-buffers-mode) - (let ((buffer (get-text-property (line-beginning-position) - 'eww-buffer))) + (let ((buffer (nth 2 (vtable-current-object)))) (unless buffer (error "No buffer on current line")) (quit-window) @@ -2663,8 +2696,7 @@ see)." (defun eww-buffer-show () "Display buffer under point in eww buffer list." - (let ((buffer (get-text-property (line-beginning-position) - 'eww-buffer))) + (let ((buffer (nth 2 (vtable-current-object)))) (unless buffer (error "No buffer on current line")) (other-window -1) @@ -2692,7 +2724,7 @@ see)." "Kill buffer from eww list." (interactive nil eww-buffers-mode) (let* ((start (line-beginning-position)) - (buffer (get-text-property start 'eww-buffer)) + (buffer (nth 2 (vtable-current-object))) (inhibit-read-only t)) (unless buffer (user-error "No buffer on the current line")) @@ -2711,10 +2743,9 @@ see)." :menu '("Eww Buffers" ["Exit" quit-window t] ["Select" eww-buffer-select - :active (get-text-property (line-beginning-position) 'eww-buffer)] + :active (nth 2 (vtable-current-object))] ["Kill" eww-buffer-kill - :active (get-text-property (line-beginning-position) - 'eww-buffer)])) + :active (nth 2 (vtable-current-object))])) (define-derived-mode eww-buffers-mode special-mode "eww buffers" "Mode for listing buffers. @@ -2722,7 +2753,10 @@ see)." \\{eww-buffers-mode-map}" :interactive nil (buffer-disable-undo) - (setq truncate-lines t)) + (setq truncate-lines t + ;; This is set so that pressing "g" with point just below the + ;; table will still update the listing. + revert-buffer-function #'eww--list-buffers-display-table)) ;;; Desktop support @@ -2876,9 +2910,9 @@ these attributes is absent, the corresponding element is nil." If there is just one alternate link, return its URL. If there are multiple alternate links, prompt for one in the minibuffer with completion. If there are none, return nil." - (when-let ((alternates (eww--alternate-urls - (plist-get eww-data :dom) - (plist-get eww-data :url)))) + (when-let* ((alternates (eww--alternate-urls + (plist-get eww-data :dom) + (plist-get eww-data :url)))) (let ((url-max-width (seq-max (mapcar #'string-pixel-width (mapcar #'car alternates)))) @@ -2922,7 +2956,7 @@ Alternate links are references that an HTML page may include to point to its alternative representations, such as a translated version or an RSS feed." (interactive nil eww-mode) - (if-let ((url (eww-read-alternate-url))) + (if-let* ((url (eww-read-alternate-url))) (progn (kill-new url) (message "Copied %s to kill ring" url)) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 7c72c67f187..ac36bfe05ce 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -241,7 +241,7 @@ using `browse-url-secondary-browser-function' instead." (line-beginning-position))) (not (looking-at goto-address-url-regexp)))) (compose-mail address) - (if-let ((url (browse-url-url-at-point))) + (if-let* ((url (browse-url-url-at-point))) (browse-url-button-open-url url) (error "No e-mail address or URL found")))))) diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 5ff75deb4e6..d3ca899216a 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -856,10 +856,10 @@ If NO-DECODE is non-nil, don't decode STRING." ;; ~/.mailcap file, then we filter out the system entries ;; and see whether we have anything left. (when mailcap-prefer-mailcap-viewers - (when-let ((user-entries - (seq-filter (lambda (elem) - (eq (cdr (assq 'source elem)) 'user)) - passed))) + (when-let* ((user-entries + (seq-filter (lambda (elem) + (eq (cdr (assq 'source elem)) 'user)) + passed))) (setq passed user-entries))) (setq viewer (car passed)))) (when (and (stringp (cdr (assq 'viewer viewer))) @@ -1084,10 +1084,17 @@ For instance, \"foo.png\" will result in \"image/png\"." (defun mailcap-mime-type-to-extension (mime-type) "Return a file name extension based on a MIME-TYPE. For instance, `image/png' will result in `png'." - (intern (cadr (split-string (if (symbolp mime-type) - (symbol-name mime-type) - mime-type) - "/")))) + (intern + (let ((e (cadr (split-string (if (symbolp mime-type) + (symbol-name mime-type) + mime-type) + "/")))) + ;; Usually, the normal extension is the same as the MIME subtype. + ;; But for SVG files, the extension is "svg" and the MIME type is + ;; "svg+xml". + (if (string= e "svg+xml") + "svg" + e)))) (defun mailcap-mime-types () "Return a list of MIME media types." diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index dcb3ad61f6d..89d3e4f19c1 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -117,15 +117,18 @@ values: used to decode and encode the data which the process reads and writes. See `make-network-process' for details. -:return-list specifies this function's return value. - If omitted or nil, return a process object. A non-nil means to - return (PROC . PROPS), where PROC is a process object and PROPS - is a plist of connection properties, with these keywords: +:return-list controls the form of the function's return value. + If omitted or nil, return a process object. Anything else means to + return (PROC . PROPS), where PROC is a process object, and PROPS is a + plist of connection properties, which may include the following + keywords: :greeting -- the greeting returned by HOST (a string), or nil. :capabilities -- a string representing HOST's capabilities, or nil if none could be found. :type -- the resulting connection type; `plain' (unencrypted) or `tls' (TLS-encrypted). + :error -- A string describing any error when attempting + to negotiate STARTTLS. :end-of-command specifies a regexp matching the end of a command. @@ -164,8 +167,9 @@ writes. See `make-network-process' for details. :use-starttls-if-possible is a boolean that says to do opportunistic STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality. -:warn-unless-encrypted is a boolean which, if :return-list is -non-nil, is used warn the user if the connection isn't encrypted. +:warn-unless-encrypted, if non-nil, warn the user if the connection +isn't encrypted (i.e. STARTTLS failed). Additionally, setting +:return-list non-nil allows capturing any error response. :nogreeting is a boolean that can be used to inhibit waiting for a greeting from the server. diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 0ff7985f0dc..4122777ac8c 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -805,6 +805,7 @@ not get changed." (widen) (put-text-property (point) pos 'nt-age 'old) (newsticker--buffer-set-faces (point) pos))) + (newsticker--cache-save-feed (newsticker--cache-get-feed feed)) (set-buffer-modified-p nil))))))) (defun newsticker-mark-item-at-point-as-immortal () @@ -1279,7 +1280,7 @@ FEED-NAME-SYMBOL tells to which feed this item belongs." (let ((img (newsticker--image-read feed-name-symbol disabled))) (when img - (newsticker--insert-image img (car item))))) + (newsticker--insert-image img (format "[logo: %s]" (car item)))))) (setq format (substring format 2))) ((string= "%L" prefix) ;; logo or title @@ -1292,7 +1293,7 @@ FEED-NAME-SYMBOL tells to which feed this item belongs." (let ((img (newsticker--image-read feed-name-symbol disabled))) (if img - (newsticker--insert-image img (car item)) + (newsticker--insert-image img (format "[logo: %s]" (car item))) (when (car item) (setq pos-text-start (point-marker)) (if (eq (newsticker--age item) 'feed) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 2a713de83c2..c41e2ec153f 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -576,11 +576,11 @@ If ARG is non-nil, instead prompt for connection parameters." 'certfp) (rcirc-get-server-cert (car c)))) contact) - (when-let (((not password)) - (auth (auth-source-search :host server - :user user-name - :port port)) - (pwd (auth-info-password (car auth)))) + (when-let* (((not password)) + (auth (auth-source-search :host server + :user user-name + :port port)) + (pwd (auth-info-password (car auth)))) (setq password pwd)) (when server (let (connected) @@ -709,7 +709,7 @@ that are joined after authentication." process) ;; Ensure any previous process is killed - (when-let ((old-process (get-process (or server-alias server)))) + (when-let* ((old-process (get-process (or server-alias server)))) (set-process-sentinel old-process #'ignore) (delete-process process)) @@ -1158,7 +1158,7 @@ element in PARTS is a list, append it to PARTS." (let ((last (car (last parts)))) (when (listp last) (setf parts (append (butlast parts) last)))) - (when-let (message (memq : parts)) + (when-let* ((message (memq : parts))) (cl-check-type (cadr message) string) (setf (cadr message) (concat ":" (cadr message)) parts (remq : parts))) @@ -1630,7 +1630,7 @@ with it." rcirc-log-directory) (rcirc-log-write)) (rcirc-clean-up-buffer "Killed buffer") - (when-let ((process (get-buffer-process (current-buffer)))) + (when-let* ((process (get-buffer-process (current-buffer)))) (delete-process process)) (when (and rcirc-buffer-alist ;; it's a server buffer rcirc-kill-channel-buffers) @@ -2041,7 +2041,7 @@ connection." ;; do not ignore if we sent the message (not (string= sender (rcirc-nick process)))) (let* ((buffer (rcirc-target-buffer process sender response target text)) - (time (if-let ((time (rcirc-get-tag "time"))) + (time (if-let* ((time (rcirc-get-tag "time"))) (parse-iso8601-time-string time t) (current-time))) (inhibit-read-only t)) @@ -2178,7 +2178,7 @@ connection." (defun rcirc-when () "Show the time of reception of the message at point." (interactive) - (if-let (time (get-text-property (point) 'rcirc-time)) + (if-let* ((time (get-text-property (point) 'rcirc-time))) (message (format-time-string "%c" time)) (message "No time information at point."))) @@ -3133,13 +3133,13 @@ indicated by RESPONSE)." (or #x03 #x0f eol)) nil t) (let (foreground background) - (when-let ((fg-raw (match-string 1)) - (fg (string-to-number fg-raw)) - ((<= 0 fg (1- (length rcirc-color-codes))))) + (when-let* ((fg-raw (match-string 1)) + (fg (string-to-number fg-raw)) + ((<= 0 fg (1- (length rcirc-color-codes))))) (setq foreground (aref rcirc-color-codes fg))) - (when-let ((bg-raw (match-string 2)) - (bg (string-to-number bg-raw)) - ((<= 0 bg (1- (length rcirc-color-codes))))) + (when-let* ((bg-raw (match-string 2)) + (bg (string-to-number bg-raw)) + ((<= 0 bg (1- (length rcirc-color-codes))))) (setq background (aref rcirc-color-codes bg))) (rcirc-add-face (match-beginning 0) (match-end 0) `(face (,@(and foreground (list :foreground foreground)) @@ -3475,7 +3475,7 @@ PROCESS is the process object for the current connection." (dolist (target channels) (rcirc-print process sender "NICK" target new-nick)) ;; update chat buffer, if it exists - (when-let ((chat-buffer (rcirc-get-buffer process old-nick))) + (when-let* ((chat-buffer (rcirc-get-buffer process old-nick))) (with-current-buffer chat-buffer (rcirc-print process sender "NICK" old-nick new-nick) (setq rcirc-target new-nick) @@ -3799,8 +3799,8 @@ is the process object for the current connection." "Handle a empty tag message from SENDER. PROCESS is the process object for the current connection." (dolist (tag rcirc-message-tags) - (when-let ((handler (intern-soft (concat "rcirc-tag-handler-" (car tag)))) - ((fboundp handler))) + (when-let* ((handler (intern-soft (concat "rcirc-tag-handler-" (car tag)))) + ((fboundp handler))) (funcall handler process sender (cdr tag))))) (defun rcirc-handler-BATCH (process _sender args _text) @@ -3837,7 +3837,7 @@ object for the current connection." (args (nth 3 message)) (text (nth 4 message)) (rcirc-message-tags (nth 5 message))) - (if-let (handler (intern-soft (concat "rcirc-handler-" cmd))) + (if-let* ((handler (intern-soft (concat "rcirc-handler-" cmd)))) (funcall handler process sender args text) (rcirc-handler-generic process cmd sender args text)))))))) (setq rcirc-batch-attributes diff --git a/lisp/net/shr.el b/lisp/net/shr.el index f1062acf7e4..6d8b235a2b8 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -751,7 +751,7 @@ full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when-let ((id (dom-attr dom 'id))) + (when-let* ((id (dom-attr dom 'id))) (push (cons id (set-marker (make-marker) start)) shr--link-targets)) ;; If style is set, then this node has set the color. (when style @@ -940,7 +940,7 @@ When `shr-fill-text' is nil, only indent." (defun shr-adaptive-fill-function () "Return a fill prefix for the paragraph at point." - (when-let ((prefix (get-text-property (point) 'shr-prefix-length))) + (when-let* ((prefix (get-text-property (point) 'shr-prefix-length))) (buffer-substring (point) (+ (point) prefix)))) (defun shr-parse-base (url) @@ -1615,7 +1615,7 @@ Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-infore (defun shr-correct-dom-case (dom) "Correct the case for SVG segments." (dolist (attr (dom-attributes dom)) - (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case))) + (when-let* ((rep (assoc-default (car attr) shr-correct-attribute-case))) (setcar attr rep))) (dolist (child (dom-children dom)) (when (consp child) @@ -1756,13 +1756,13 @@ Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-infore (funcall shr-url-transformer (shr-expand-url url)) title) ;; Check whether the URL is suspicious. - (when-let ((warning (or (textsec-suspicious-p - (shr-expand-url url) 'url) - (textsec-suspicious-p - (cons (shr-expand-url url) - (buffer-substring (or shr-start start) - (point))) - 'link)))) + (when-let* ((warning (or (textsec-suspicious-p + (shr-expand-url url) 'url) + (textsec-suspicious-p + (cons (shr-expand-url url) + (buffer-substring (or shr-start start) + (point))) + 'link)))) (add-text-properties (or shr-start start) (point) (list 'face '(shr-link textsec-suspicious))) (insert (propertize "⚠️" 'help-echo warning)))))) @@ -2264,6 +2264,18 @@ BASE is the URL of the HTML being rendered." (shr-generic dom) (insert ?\N{POP DIRECTIONAL ISOLATE})) +(defun shr-tag-math (dom) + ;; Sometimes a math element contains a plain text annotation + ;; (typically TeX notation) in addition to MathML markup. If we pass + ;; that to `dom-generic', the formula is printed twice. So we select + ;; only the annotation if available. + (shr-generic + (thread-first + dom + (dom-child-by-tag 'semantics) + (dom-child-by-tag 'annotation) + (or dom)))) + ;;; 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. diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index a6ba556e7ae..68426ff91ec 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -152,7 +152,7 @@ require \"fileinto\"; (interactive) (sieve-manage-close sieve-manage-buffer) (kill-buffer sieve-manage-buffer) - (when-let ((buffer (get-buffer sieve-buffer))) + (when-let* ((buffer (get-buffer sieve-buffer))) (kill-buffer buffer))) (defun sieve-bury-buffer () diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 4fba731509b..7fbb2332e89 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -205,15 +205,15 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defsubst tramp-adb-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for ADB." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-adb-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-adb-method))))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) "Invoke the ADB handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-adb-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-adb-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -620,7 +620,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-shell-quote-argument l2)) "Error copying %s to %s" filename newname)) - (if-let ((tmpfile (file-local-copy filename))) + (if-let* ((tmpfile (file-local-copy filename))) ;; Remote filename. (condition-case err (rename-file tmpfile newname ok-if-already-exists) @@ -811,10 +811,10 @@ will be used." v 'file-error "Cannot apply multibyte command `%s'" command)) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) + (tramp-set-connection-property v " process-name" name) + (tramp-set-connection-property v " process-buffer" buffer) (with-current-buffer (tramp-get-connection-buffer v) (unwind-protect ;; We catch this event. Otherwise, `make-process' @@ -857,8 +857,8 @@ will be used." ;; We must flush them here already; ;; otherwise `rename-file', `delete-file' ;; or `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + (tramp-flush-connection-property v " process-name") + (tramp-flush-connection-property v " process-buffer") ;; Copy tmpstderr file. (when (and (stringp stderr) (not (tramp-tramp-file-p stderr))) @@ -1106,7 +1106,8 @@ connection if a previous connection has died for some reason." ;; Maybe we know already that "su" is not supported. We cannot ;; use a connection property, because we have not checked yet ;; whether it is still the same device. - (when (and user (not (tramp-get-file-property vec "/" "su-command-p" t))) + (when + (and user (not (tramp-get-connection-property vec " su-command-p" t))) (tramp-error vec 'file-error "Cannot switch to user `%s'" user)) (unless (process-live-p p) @@ -1126,6 +1127,11 @@ connection if a previous connection has died for some reason." tramp-adb-program args))) (prompt (md5 (concat (prin1-to-string process-environment) (current-time-string))))) + + ;; Set sentinel. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (tramp-post-process-creation p vec) + ;; Wait for initial prompt. On some devices, it needs ;; an initial RET, in order to get it. (sleep-for 0.1) @@ -1134,10 +1140,6 @@ connection if a previous connection has died for some reason." (unless (process-live-p p) (tramp-error vec 'file-error "Terminated!")) - ;; Set sentinel. Initialize variables. - (set-process-sentinel p #'tramp-process-sentinel) - (tramp-post-process-creation p vec) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) @@ -1190,7 +1192,7 @@ connection if a previous connection has died for some reason." (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) ;; Do not flush, we need the nil value. - (tramp-set-file-property vec "/" "su-command-p" nil) + (tramp-set-connection-property vec " su-command-p" nil) (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) diff --git a/lisp/net/tramp-androidsu.el b/lisp/net/tramp-androidsu.el index 473cecf7a1b..9b45b416ff9 100644 --- a/lisp/net/tramp-androidsu.el +++ b/lisp/net/tramp-androidsu.el @@ -111,7 +111,7 @@ multibyte mode and waits for the shell prompt to appear." (with-tramp-debug-message vec "Opening connection" (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name")) + (process-name (tramp-get-connection-property vec " process-name")) (process-environment (copy-sequence process-environment))) ;; Open a new connection. (condition-case err @@ -502,15 +502,15 @@ FUNCTION." ;;;###tramp-autoload (defsubst tramp-androidsu-file-name-p (vec-or-filename) "Check whether VEC-OR-FILENAME is for the `androidsu' method." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (equal (tramp-file-name-method vec) tramp-androidsu-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((equal (tramp-file-name-method vec) tramp-androidsu-method))))) ;;;###tramp-autoload (defun tramp-androidsu-file-name-handler (operation &rest args) "Invoke the `androidsu' handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-androidsu-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-androidsu-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index a5bdacb4d91..9cbd20c21cb 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -68,7 +68,7 @@ ;; Some properties are handled special: ;; -;; - "process-name", "process-buffer" and "first-password-request" are +;; - Properties which start with a space, like " process-name", are ;; not saved in the file `tramp-persistency-file-name', although ;; being connection properties related to a `tramp-file-name' ;; structure. @@ -243,8 +243,8 @@ Return VALUE." "Remove some properties of FILE's upper directory." (when (file-name-absolute-p file) ;; `file-name-directory' can return nil, for example for "~". - (when-let ((file (file-name-directory file)) - (file (directory-file-name file))) + (when-let* ((file (file-name-directory file)) + (file (directory-file-name file))) (setq key (tramp-file-name-unify key file)) (unless (eq key tramp-cache-undefined) (dolist (property (hash-table-keys (tramp-get-hash-table key))) @@ -396,7 +396,8 @@ the connection, return DEFAULT." (not (and (processp key) (not (process-live-p key))))) (setq value cached cache-used t)) - (tramp-message key 7 "%s %s; cache used: %s" property value cache-used) + (unless (eq key tramp-cache-version) + (tramp-message key 7 "%s %s; cache used: %s" property value cache-used)) value)) ;;;###tramp-autoload @@ -409,11 +410,12 @@ is `tramp-cache-undefined', nothing is set. PROPERTY is set persistent when KEY is a `tramp-file-name' structure. Return VALUE." (setq key (tramp-file-name-unify key)) - (when-let ((hash (tramp-get-hash-table key))) + (when-let* ((hash (tramp-get-hash-table key))) (puthash property value hash)) (setq tramp-cache-data-changed (or tramp-cache-data-changed (tramp-file-name-p key))) - (tramp-message key 7 "%s %s" property value) + (unless (eq key tramp-cache-version) + (tramp-message key 7 "%s %s" property value)) value) ;;;###tramp-autoload @@ -433,7 +435,7 @@ KEY identifies the connection, it is either a process or a used to cache connection properties of the local machine. PROPERTY is set persistent when KEY is a `tramp-file-name' structure." (setq key (tramp-file-name-unify key)) - (when-let ((hash (tramp-get-hash-table key))) + (when-let* ((hash (tramp-get-hash-table key))) (remhash property hash)) (setq tramp-cache-data-changed (or tramp-cache-data-changed (tramp-file-name-p key))) @@ -448,7 +450,7 @@ used to cache connection properties of the local machine." (setq key (tramp-file-name-unify key)) (tramp-message key 7 "%s %s" key - (when-let ((hash (gethash key tramp-cache-data))) + (when-let* ((hash (gethash key tramp-cache-data))) (hash-table-keys hash))) (setq tramp-cache-data-changed (or tramp-cache-data-changed (tramp-file-name-p key))) @@ -552,7 +554,7 @@ PROPERTIES is a list of file properties (strings)." (lambda (key) (and (tramp-file-name-p key) (null (tramp-file-name-localname key)) - (tramp-connection-property-p key "process-buffer") + (tramp-connection-property-p key " process-buffer") key)) (hash-table-keys tramp-cache-data)))) @@ -584,10 +586,9 @@ PROPERTIES is a list of file properties (strings)." (not (tramp-file-name-localname key)) (not (gethash "login-as" value)) (not (gethash "started" value))) - (progn - (remhash "process-name" value) - (remhash "process-buffer" value) - (remhash "first-password-request" value)) + (dolist (k (hash-table-keys value)) + (when (string-prefix-p " " k) + (remhash k value))) (remhash key cache))) cache) ;; Dump it. diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index e7ce017e678..3a66030c9d0 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -65,24 +65,24 @@ SYNTAX can be one of the symbols `default' (default), "method: " (tramp-compat-seq-keep (lambda (x) - (when-let ((name (symbol-name x)) - ;; It must match `tramp-enable-METHOD-method'. - ((string-match - (rx "tramp-enable-" - (group (regexp tramp-method-regexp)) - "-method") - name)) - (method (match-string 1 name)) - ;; It must not be enabled yet. - ((not (assoc method tramp-methods)))) + (when-let* ((name (symbol-name x)) + ;; It must match `tramp-enable-METHOD-method'. + ((string-match + (rx "tramp-enable-" + (group (regexp tramp-method-regexp)) + "-method") + name)) + (method (match-string 1 name)) + ;; It must not be enabled yet. + ((not (assoc method tramp-methods)))) method)) ;; All method enabling functions. (mapcar #'intern (all-completions "tramp-enable-" obarray #'functionp)))))) - (when-let (((not (assoc method tramp-methods))) - (fn (intern (format "tramp-enable-%s-method" method))) - ((functionp fn))) + (when-let* (((not (assoc method tramp-methods))) + (fn (intern (format "tramp-enable-%s-method" method))) + ((functionp fn))) (funcall fn) (message "Tramp method \"%s\" enabled" method))) @@ -118,11 +118,11 @@ Each function is called with the current vector as argument.") (defun tramp-cleanup-connection (vec &optional keep-debug keep-password keep-processes) "Flush all connection related objects. -This includes password cache, file cache, connection cache, -buffers, processes. KEEP-DEBUG non-nil preserves the debug -buffer. KEEP-PASSWORD non-nil preserves the password cache. -KEEP-PROCESSES non-nil preserves the asynchronous processes. -When called interactively, a Tramp connection has to be selected." +This includes password cache, file cache, connection cache, buffers, +processes. KEEP-DEBUG non-nil preserves the debug and trace buffer. +KEEP-PASSWORD non-nil preserves the password cache. KEEP-PROCESSES +non-nil preserves the asynchronous processes. When called +interactively, a Tramp connection has to be selected." (declare (completion tramp-active-command-completion-p)) (interactive ;; When interactive, select the Tramp remote identification. @@ -173,7 +173,7 @@ When called interactively, a Tramp connection has to be selected." (get-buffer (tramp-debug-buffer-name vec))) (unless keep-debug (get-buffer (tramp-trace-buffer-name vec))) - (tramp-get-connection-property vec "process-buffer"))) + (tramp-get-connection-property vec " process-buffer"))) (when (bufferp buf) (kill-buffer buf))) ;; Flush file cache. @@ -672,7 +672,7 @@ This is needed if there are compatibility problems." (declare (completion tramp-recompile-elpa-command-completion-p)) (interactive) ;; We expect just one Tramp package is installed. - (when-let + (when-let* ((dir (tramp-compat-funcall 'package-desc-dir (car (alist-get 'tramp (bound-and-true-p package-alist)))))) @@ -763,8 +763,8 @@ buffer in your bug report. (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." - (when-let ((reporter-eval-buffer reporter-eval-buffer) - (val (buffer-local-value varsym reporter-eval-buffer))) + (when-let* ((reporter-eval-buffer reporter-eval-buffer) + (val (buffer-local-value varsym reporter-eval-buffer))) (if (hash-table-p val) ;; Pretty print the cache. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index ec74d9bb76e..b58930a7957 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -76,9 +76,9 @@ ;; an infloop. We try to follow the XDG specification, for security reasons. (defconst tramp-compat-temporary-file-directory (file-name-as-directory - (if-let ((xdg (xdg-cache-home)) - ((file-directory-p xdg)) - ((file-writable-p xdg))) + (if-let* ((xdg (xdg-cache-home)) + ((file-directory-p xdg)) + ((file-writable-p xdg))) (prog1 (setq xdg (file-name-concat xdg "emacs")) (make-directory xdg t)) (eval (car (get 'temporary-file-directory 'standard-value)) t))) @@ -221,7 +221,7 @@ value is the default binding of the variable." (if (not criteria) ,variable (hack-connection-local-variables criteria) - (if-let ((result (assq ',variable connection-local-variables-alist))) + (if-let* ((result (assq ',variable connection-local-variables-alist))) (cdr result) ,variable))))) diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el index 62b49445da4..c76bf5af696 100644 --- a/lisp/net/tramp-container.el +++ b/lisp/net/tramp-container.el @@ -288,19 +288,19 @@ or `tramp-podmancp-method'. This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string - (concat program " ps --format '{{.ID}}\t{{.Names}}'"))) - (lines (split-string raw-list "\n" 'omit)) - (names - (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (group (1+ nonl)) - "\t" (? (group (1+ nonl))) eol) - line) - (or (match-string 2 line) (match-string 1 line)))) - lines))) + (when-let* ((raw-list + (shell-command-to-string + (concat program " ps --format '{{.ID}}\t{{.Names}}'"))) + (lines (split-string raw-list "\n" 'omit)) + (names + (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (group (1+ nonl)) + "\t" (? (group (1+ nonl))) eol) + line) + (or (match-string 2 line) (match-string 1 line)))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -310,19 +310,19 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string - (concat - program " " - (tramp-kubernetes--context-namespace vec) - " get pods --no-headers" - ;; We separate pods by "|". Inside a pod, its name - ;; is separated from the containers by ":". - ;; Containers are separated by ",". - " -o jsonpath='{range .items[*]}{\"|\"}{.metadata.name}" - "{\":\"}{range .spec.containers[*]}{.name}{\",\"}" - "{end}{end}'"))) - (lines (split-string raw-list "|" 'omit))) + (when-let* ((raw-list + (shell-command-to-string + (concat + program " " + (tramp-kubernetes--context-namespace vec) + " get pods --no-headers" + ;; We separate pods by "|". Inside a pod, its name + ;; is separated from the containers by ":". + ;; Containers are separated by ",". + " -o jsonpath='{range .items[*]}{\"|\"}{.metadata.name}" + "{\":\"}{range .spec.containers[*]}{.name}{\",\"}" + "{end}{end}'"))) + (lines (split-string raw-list "|" 'omit))) (let (names) (dolist (line lines) (setq line (split-string line ":" 'omit)) @@ -349,16 +349,16 @@ see its function help for a description of the format." ;;;###tramp-autoload (defun tramp-kubernetes--container (vec) "Extract the container name from a kubernetes host name in VEC." - (or (when-let ((host (and vec (tramp-file-name-host vec))) - ((string-match tramp-kubernetes--host-name-regexp host))) + (or (when-let* ((host (and vec (tramp-file-name-host vec))) + ((string-match tramp-kubernetes--host-name-regexp host))) (match-string 1 host)) "")) ;;;###tramp-autoload (defun tramp-kubernetes--pod (vec) "Extract the pod name from a kubernetes host name in VEC." - (or (when-let ((host (and vec (tramp-file-name-host vec))) - ((string-match tramp-kubernetes--host-name-regexp host))) + (or (when-let* ((host (and vec (tramp-file-name-host vec))) + ((string-match tramp-kubernetes--host-name-regexp host))) (match-string 2 host)) "")) @@ -366,8 +366,8 @@ see its function help for a description of the format." (defun tramp-kubernetes--namespace (vec) "Extract the namespace from a kubernetes host name in VEC. Use `tramp-kubernetes-namespace' otherwise." - (or (when-let ((host (and vec (tramp-file-name-host vec))) - ((string-match tramp-kubernetes--host-name-regexp host))) + (or (when-let* ((host (and vec (tramp-file-name-host vec))) + ((string-match tramp-kubernetes--host-name-regexp host))) (match-string 3 host)) tramp-kubernetes-namespace)) @@ -413,7 +413,7 @@ Obey `tramp-kubernetes-context'" (defun tramp-kubernetes--current-context-data (vec) "Return Kubernetes current context data as JSON string." - (when-let ((current-context (tramp-kubernetes--current-context vec))) + (when-let* ((current-context (tramp-kubernetes--current-context vec))) (tramp-skeleton-kubernetes-vector vec (with-temp-buffer (when (zerop @@ -430,9 +430,9 @@ Obey `tramp-kubernetes-context'" (mapconcat #'identity (delq nil - `(,(when-let ((context (tramp-kubernetes--current-context vec))) + `(,(when-let* ((context (tramp-kubernetes--current-context vec))) (format "--context=%s" context)) - ,(when-let ((namespace (tramp-kubernetes--namespace vec))) + ,(when-let* ((namespace (tramp-kubernetes--namespace vec))) (format "--namespace=%s" namespace)))) " ")) @@ -443,18 +443,18 @@ Obey `tramp-kubernetes-context'" This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list (shell-command-to-string (concat program " list -c"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n" 'omit))) - ;; We do not show container IDs. - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (1+ (not space)) - (1+ space) (group (1+ (not space))) space) - line) - (match-string 1 line))) - lines))) + (when-let* ((raw-list (shell-command-to-string (concat program " list -c"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + ;; We do not show container IDs. + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (1+ (not space)) + (1+ space) (group (1+ (not space))) space) + line) + (match-string 1 line))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -464,19 +464,19 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list (shell-command-to-string (concat program " list"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n" 'omit))) - ;; We do not show container IDs. - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (1+ (not space)) - (1+ space) "|" (1+ space) - (group (1+ (not space))) space) - line) - (match-string 1 line))) - lines))) + (when-let* ((raw-list (shell-command-to-string (concat program " list"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + ;; We do not show container IDs. + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (1+ (not space)) + (1+ space) "|" (1+ space) + (group (1+ (not space))) space) + line) + (match-string 1 line))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -488,19 +488,19 @@ ID, instance IDs. This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string - ;; Ignore header line. - (concat program " ps --columns=instance,application | cat -"))) - (lines (split-string raw-list "\n" 'omit)) - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (* space) (group (+ (not space))) - (? (+ space) (group (+ (not space)))) eol) - line) - (or (match-string 2 line) (match-string 1 line)))) - lines))) + (when-let* ((raw-list + (shell-command-to-string + ;; Ignore header line. + (concat program " ps --columns=instance,application | cat -"))) + (lines (split-string raw-list "\n" 'omit)) + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (* space) (group (+ (not space))) + (? (+ space) (group (+ (not space)))) eol) + line) + (or (match-string 2 line) (match-string 1 line)))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -510,19 +510,19 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string (concat program " instance list"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n" 'omit))) - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (group (1+ (not space))) - (1+ space) (1+ (not space)) - (1+ space) (1+ (not space))) - line) - (match-string 1 line))) - lines))) + (when-let* ((raw-list + (shell-command-to-string (concat program " instance list"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (group (1+ (not space))) + (1+ space) (1+ (not space)) + (1+ space) (1+ (not space))) + line) + (match-string 1 line))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) (defun tramp-nspawn--completion-function (method) @@ -531,13 +531,13 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string (concat program " list --all -q"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n"))) - (first-words (mapcar (lambda (line) (car (split-string line))) - lines)) - (machines (seq-take-while (lambda (name) name) first-words))) + (when-let* ((raw-list + (shell-command-to-string (concat program " list --all -q"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n"))) + (first-words + (mapcar (lambda (line) (car (split-string line))) lines)) + (machines (seq-take-while (lambda (name) name) first-words))) (mapcar (lambda (m) (list nil m)) machines)))) ;;;###tramp-autoload diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 321d040a4d4..059b49714ab 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -281,10 +281,10 @@ arguments to pass to the OPERATION." "Invoke the encrypted remote file related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((filename - (apply #'tramp-crypt-file-name-for-operation operation args)) - (fn (and (tramp-crypt-file-name-p filename) - (assoc operation tramp-crypt-file-name-handler-alist)))) + (if-let* ((filename + (apply #'tramp-crypt-file-name-for-operation operation args)) + ((tramp-crypt-file-name-p filename)) + (fn (assoc operation tramp-crypt-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-crypt-run-real-handler operation args) @@ -352,7 +352,7 @@ connection if a previous connection has died for some reason." (tramp-compat-make-temp-file " .nocrypt" 'dir-flag)))) ;; Enable `auth-source', unless "emacs -Q" has been called. (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) + vec " first-password-request" tramp-cache-read-persistent-data) (with-temp-buffer (insert (tramp-read-passwd @@ -408,7 +408,7 @@ ARGS are the arguments. It returns t if ran successful, and nil otherwise." (args (delq nil args))) ;; Enable `auth-source', unless "emacs -Q" has been called. (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) + vec " first-password-request" tramp-cache-read-persistent-data) (insert (tramp-read-passwd (tramp-get-connection-process vec) @@ -429,11 +429,11 @@ ARGS are the arguments. It returns t if ran successful, and nil otherwise." "Return encrypted / decrypted NAME if NAME belongs to an encrypted directory. OP must be `encrypt' or `decrypt'. Raise an error if this fails. Otherwise, return NAME." - (if-let ((tramp-crypt-enabled t) - (dir (tramp-crypt-file-name-p name)) - ;; It must be absolute for the cache. - (localname (substring name (1- (length dir)))) - (crypt-vec (tramp-crypt-dissect-file-name dir))) + (if-let* ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p name)) + ;; It must be absolute for the cache. + (localname (substring name (1- (length dir)))) + (crypt-vec (tramp-crypt-dissect-file-name dir))) ;; Preserve trailing "/". (funcall (if (directory-name-p name) #'file-name-as-directory #'identity) @@ -469,9 +469,9 @@ Otherwise, return NAME." Both files must be local files. OP must be `encrypt' or `decrypt'. If OP is `decrypt', the basename of INFILE must be an encrypted file name. Raise an error if this fails." - (when-let ((tramp-crypt-enabled t) - (dir (tramp-crypt-file-name-p root)) - (crypt-vec (tramp-crypt-dissect-file-name dir))) + (when-let* ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p root)) + (crypt-vec (tramp-crypt-dissect-file-name dir))) (let ((coding-system-for-read (if (eq op 'decrypt) 'binary coding-system-for-read)) (coding-system-for-write @@ -546,7 +546,7 @@ The structure consists of the `tramp-crypt-method' method, the local user name, the hexlified directory NAME as host, and the localname." (save-match-data - (if-let ((dir (tramp-crypt-file-name-p name))) + (if-let* ((dir (tramp-crypt-file-name-p name))) (make-tramp-file-name :method tramp-crypt-method :user (user-login-name) :host (url-hexify-string dir)) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 28ef8c67777..824ea0ee653 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -186,8 +186,8 @@ pass to the OPERATION." ;;;###tramp-autoload (defsubst tramp-ftp-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-ftp-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-ftp-method))))) ;;;###tramp-autoload (tramp--with-startup diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 7054a7691b2..e34f735fa00 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -128,8 +128,8 @@ (defun tramp-fuse-mount-spec (vec) "Return local mount spec of VEC." - (if-let ((host (tramp-file-name-host vec)) - (user (tramp-file-name-user vec))) + (if-let* ((host (tramp-file-name-host vec)) + (user (tramp-file-name-user vec))) (format "%s@%s:/" user host) (format "%s:/" host))) @@ -138,13 +138,17 @@ "Time period to check whether the mount point still exists. It has the same meaning as `remote-file-name-inhibit-cache'.") +;;;###tramp-autoload +(defconst tramp-fuse-name-prefix "tramp-" + "Prefix to use for temporary FUSE mount points.") + (defun tramp-fuse-mount-point (vec) "Return local mount point of VEC." (let ((remote-file-name-inhibit-cache tramp-fuse-mount-timeout)) (or (tramp-get-file-property vec "/" "mount-point") (expand-file-name (concat - tramp-temp-name-prefix + tramp-fuse-name-prefix (tramp-file-name-method vec) "." (when (tramp-file-name-user vec) (concat (tramp-file-name-user-domain vec) "@")) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 5888a223b78..683f8cc12bd 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -881,9 +881,9 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;;;###tramp-autoload (defsubst tramp-gvfs-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (let ((method (tramp-file-name-method vec))) - (and (stringp method) (member method tramp-gvfs-methods))))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + (method (tramp-file-name-method vec)) + ((member method tramp-gvfs-methods))))) ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) @@ -893,11 +893,11 @@ arguments to pass to the OPERATION." ;; `file-remote-p' must not return an error. (Bug#68976) (unless (or tramp-gvfs-enabled (eq operation 'file-remote-p)) (tramp-user-error nil "Package `tramp-gvfs' not supported")) - (if-let ((filename (apply #'tramp-file-name-for-operation operation args)) - (tramp-gvfs-dbus-event-vector - (and (tramp-tramp-file-p filename) - (tramp-dissect-file-name filename))) - (fn (assoc operation tramp-gvfs-file-name-handler-alist))) + (if-let* ((filename (apply #'tramp-file-name-for-operation operation args)) + (tramp-gvfs-dbus-event-vector + (and (tramp-tramp-file-p filename) + (tramp-dissect-file-name filename))) + (fn (assoc operation tramp-gvfs-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -930,9 +930,9 @@ arguments to pass to the OPERATION." "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists. Return nil for null BYTE-ARRAY." ;; The byte array could be a variant. Take care. - (when-let ((byte-array - (if (and (consp byte-array) (atom (car byte-array))) - byte-array (car byte-array)))) + (when-let* ((byte-array + (if (and (consp byte-array) (atom (car byte-array))) + byte-array (car byte-array)))) (dbus-byte-array-to-string (if (and (consp byte-array) (zerop (car (last byte-array)))) (butlast byte-array) byte-array)))) @@ -1405,7 +1405,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (or (cdr (assoc "standard::size" attributes)) "0"))) ;; ... file mode flags (setq res-filemodes - (if-let ((n (cdr (assoc "unix::mode" attributes)))) + (if-let* ((n (cdr (assoc "unix::mode" attributes)))) (tramp-file-mode-from-int (string-to-number n)) (format "%s%s%s%s------" @@ -1421,11 +1421,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." "-" "x")))) ;; ... inode and device (setq res-inode - (if-let ((n (cdr (assoc "unix::inode" attributes)))) + (if-let* ((n (cdr (assoc "unix::inode" attributes)))) (string-to-number n) (tramp-get-inode (tramp-dissect-file-name filename)))) (setq res-device - (if-let ((n (cdr (assoc "unix::device" attributes)))) + (if-let* ((n (cdr (assoc "unix::device" attributes)))) (string-to-number n) (tramp-get-device (tramp-dissect-file-name filename)))) @@ -1675,19 +1675,21 @@ ID-FORMAT valid values are `string' and `integer'." ;; The result is cached in `tramp-get-remote-uid'. (if (equal id-format 'string) (tramp-file-name-user vec) - (when-let ((localname - (tramp-get-connection-property (tramp-get-process vec) "share"))) - (file-attribute-user-id - (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) + (and-let* ((localname + (tramp-get-connection-property (tramp-get-process vec) "share")) + ((file-attribute-user-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format))))))) (defun tramp-gvfs-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." ;; The result is cached in `tramp-get-remote-gid'. - (when-let ((localname - (tramp-get-connection-property (tramp-get-process vec) "share"))) - (file-attribute-group-id - (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) + (and-let* ((localname + (tramp-get-connection-property (tramp-get-process vec) "share")) + ((file-attribute-group-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format)))))) (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1720,12 +1722,12 @@ ID-FORMAT valid values are `string' and `integer'." (setq method "davs" localname (concat (tramp-gvfs-get-remote-prefix v) localname))) - (when (string-equal "mtp" method) - (when-let - ((media (tramp-get-connection-property v "media-device"))) - (setq method (tramp-media-device-method media) - host (tramp-media-device-host media) - port (tramp-media-device-port media)))) + (when-let* + (((string-equal "mtp" method)) + (media (tramp-get-connection-property v "media-device"))) + (setq method (tramp-media-device-method media) + host (tramp-media-device-host media) + port (tramp-media-device-port media))) (when (and user domain) (setq user (concat domain ";" user))) (url-recreate-url @@ -1799,7 +1801,7 @@ a downcased host name only." (setq domain (read-string "Domain name: "))) (tramp-message l 6 "%S %S %S %d" message user domain flags) - (unless (tramp-get-connection-property l "first-password-request") + (unless (tramp-get-connection-property l " first-password-request") (tramp-clear-passwd l)) (setq password (tramp-read-passwd @@ -1922,10 +1924,10 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (when (member method tramp-media-methods) ;; Ensure that media devices are cached. (tramp-get-media-devices nil) - (when-let ((v (tramp-get-connection-property - (make-tramp-media-device - :method method :host host :port port) - "vector" nil))) + (when-let* ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) (setq method (tramp-file-name-method v) host (tramp-file-name-host v) port (tramp-file-name-port v)))) @@ -2022,10 +2024,10 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (when (member method tramp-media-methods) ;; Ensure that media devices are cached. (tramp-get-media-devices vec) - (when-let ((v (tramp-get-connection-property - (make-tramp-media-device - :method method :host host :port port) - "vector"))) + (when-let* ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector"))) (setq method (tramp-file-name-method v) host (tramp-file-name-host v) port (tramp-file-name-port v)))) @@ -2250,7 +2252,7 @@ connection if a previous connection has died for some reason." ;; Enable `auth-source'. (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) + vec " first-password-request" tramp-cache-read-persistent-data) ;; There will be a callback of "askPassword" when a password is needed. (dbus-register-method @@ -2440,8 +2442,8 @@ It checks for registered GNOME Online Accounts." (defun tramp-get-media-device (vec) "Transform VEC into a `tramp-media-device' structure. Check, that respective cache values do exist." - (if-let ((media (tramp-get-connection-property vec "media-device")) - (prop (tramp-get-connection-property media "vector"))) + (if-let* ((media (tramp-get-connection-property vec "media-device")) + (prop (tramp-get-connection-property media "vector"))) media (tramp-get-media-devices vec) (tramp-get-connection-property vec "media-device"))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 0a99711d222..a06e4b50677 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -578,11 +578,11 @@ See `tramp-process-attributes-ps-format'.") ;; Preset default "ps" profile for local hosts, based on system type. -(when-let ((local-profile - (cond ((eq system-type 'darwin) - 'tramp-connection-local-darwin-ps-profile) - ;; ... Add other system types here. - ))) +(when-let* ((local-profile + (cond ((eq system-type 'darwin) + 'tramp-connection-local-darwin-ps-profile) + ;; ... Add other system types here. + ))) (connection-local-set-profiles `(:application tramp :machine ,(system-name)) local-profile) diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el index 622914074dd..c9bb9648fdb 100644 --- a/lisp/net/tramp-message.el +++ b/lisp/net/tramp-message.el @@ -485,7 +485,7 @@ to `tramp-message'." "Goto the linked message in debug buffer at place." (declare (tramp-suppress-trace t)) (when (mouse-event-p last-input-event) (mouse-set-point last-input-event)) - (when-let ((point (button-get button 'position))) + (when-let* ((point (button-get button 'position))) (goto-char point))) (define-button-type 'tramp-debug-button-type diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 951a2a41817..dbbe6680fe2 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -167,15 +167,15 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;;;###tramp-autoload (defsubst tramp-rclone-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for rclone." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-rclone-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-rclone-method))))) ;;;###tramp-autoload (defun tramp-rclone-file-name-handler (operation &rest args) "Invoke the rclone handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-rclone-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 9e813ecc628..0182c8f8eb8 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1812,7 +1812,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; be expected that this is always a directory. (or (tramp-string-empty-or-nil-p localname) (with-tramp-file-property v localname "file-directory-p" - (if-let + (if-let* ((truename (tramp-get-file-property v localname "file-truename")) ((tramp-file-property-p v (tramp-file-local-name truename) "file-attributes"))) @@ -2231,8 +2231,8 @@ file names." ;; Handle `preserve-extended-attributes'. We ignore ;; possible errors, because ACL strings could be ;; incompatible. - (when-let ((attributes (and preserve-extended-attributes - (file-extended-attributes filename)))) + (when-let* ((attributes (and preserve-extended-attributes + (file-extended-attributes filename)))) (ignore-errors (set-file-extended-attributes newname attributes))) @@ -2558,16 +2558,16 @@ The method used must be an out-of-band method." (with-temp-buffer (unwind-protect (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; The default directory must be remote. (let ((default-directory (file-name-directory (if v1 filename newname))) (process-environment (copy-sequence process-environment))) ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) (when copy-env (tramp-message v 6 "%s=\"%s\"" @@ -2868,7 +2868,7 @@ The method used must be an out-of-band method." (rx bol (group (* blank) "total")) nil t) ;; Emacs 29.1 or later. (not (fboundp 'dired--insert-disk-space))) - (when-let ((available (get-free-disk-space "."))) + (when-let* ((available (get-free-disk-space "."))) ;; Replace "total" with "total used", to avoid confusion. (replace-match "\\1 used in directory") (end-of-line) @@ -3075,10 +3075,10 @@ will be used." :file-handler t)) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) + (tramp-set-connection-property v " process-name" name) + (tramp-set-connection-property v " process-buffer" buffer) (with-current-buffer (tramp-get-connection-buffer v) (unwind-protect ;; We catch this event. Otherwise, `make-process' @@ -3160,8 +3160,8 @@ will be used." (set-marker (process-mark p) (point))) ;; We must flush them here already; otherwise ;; `delete-file' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + (tramp-flush-connection-property v " process-name") + (tramp-flush-connection-property v " process-buffer") ;; Kill stderr process and delete named pipe. (when (bufferp stderr) (add-function @@ -3313,7 +3313,7 @@ will be used." (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (tramp-skeleton-file-local-copy filename - (if-let ((size (file-attribute-size (file-attributes filename)))) + (if-let* ((size (file-attribute-size (file-attributes filename)))) (let (rem-enc loc-dec) (condition-case err @@ -3627,14 +3627,14 @@ filled are described in `tramp-bundle-read-file-names'." ;; requires a remote command (the file cache must be invalidated). ;; Therefore, we apply a kind of optimization. We install the file ;; name handler `tramp-vc-file-name-handler', which does nothing but -;; remembers all file names for which `file-exists-p' or -;; `file-readable-p' has been applied. A first run of `vc-registered' -;; is performed. Afterwards, a script is applied for all collected -;; file names, using just one remote command. The result of this -;; script is used to fill the file cache with actual values. Now we -;; can reset the file name handlers, and we make a second run of -;; `vc-registered', which returns the expected result without sending -;; any other remote command. +;; remembers all file names for which `file-exists-p', +;; `file-readable-p' or `file-directory-p' has been applied. A first +;; run of `vc-registered' is performed. Afterwards, a script is +;; applied for all collected file names, using just one remote +;; command. The result of this script is used to fill the file cache +;; with actual values. Now we can reset the file name handlers, and +;; we make a second run of `vc-registered', which returns the expected +;; result without sending any other remote command. ;; When called during `revert-buffer', it shouldn't spam the echo area ;; and the *Messages* buffer. (defun tramp-sh-handle-vc-registered (file) @@ -3666,10 +3666,11 @@ filled are described in `tramp-bundle-read-file-names'." ;; Send just one command, in order to fill the cache. (tramp-bundle-read-file-names v tramp-vc-registered-file-names)) - ;; Second run. Now all `file-exists-p' or `file-readable-p' - ;; calls shall be answered from the file cache. We unset - ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' - ;; in order to keep the cache. + ;; Second run. Now all `file-exists-p', `file-readable-p' + ;; or `file-directory-p' calls shall be answered from the + ;; file cache. We unset `process-file-side-effects' and + ;; `remote-file-name-inhibit-cache' in order to keep the + ;; cache. (let ((vc-handled-backends (copy-sequence vc-handled-backends)) remote-file-name-inhibit-cache process-file-side-effects) ;; Reduce `vc-handled-backends' in order to minimize @@ -3704,7 +3705,7 @@ filled are described in `tramp-bundle-read-file-names'." (defun tramp-sh-file-name-handler (operation &rest args) "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." - (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-sh-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -3726,33 +3727,35 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-vc-file-name-handler (operation &rest args) "Invoke special file name handler, which collects files to be handled." (save-match-data - (let ((filename - (tramp-replace-environment-variables - (apply #'tramp-file-name-for-operation operation args))) - (fn (assoc operation tramp-sh-file-name-handler-alist))) - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (cond - ;; That's what we want: file names, for which checks are - ;; applied. We assume that VC uses only `file-exists-p' - ;; and `file-readable-p' checks; otherwise we must extend - ;; the list. We do not perform any action, but return - ;; nil, in order to keep `vc-registered' running. - ((and fn (memq operation '(file-exists-p file-readable-p))) - (add-to-list 'tramp-vc-registered-file-names localname 'append) - nil) - ;; `process-file' and `start-file-process' shall be ignored. - ((and fn (eq operation 'process-file) 0)) - ((and fn (eq operation 'start-file-process) nil)) - ;; Tramp file name handlers like `expand-file-name'. They - ;; must still work. - (fn (save-match-data (apply (cdr fn) args))) - ;; Default file name handlers, we don't care. - (t (tramp-run-real-handler operation args)))) - - ;; When `tramp-mode' is not enabled, or the file name is - ;; quoted, we don't do anything. - (tramp-run-real-handler operation args))))) + (if-let* ((filename + (tramp-replace-environment-variables + (apply #'tramp-file-name-for-operation operation args))) + ((tramp-tramp-file-p filename)) + (fn (assoc operation tramp-sh-file-name-handler-alist))) + (with-parsed-tramp-file-name filename nil + (cond + ;; That's what we want: file names, for which checks are + ;; applied. We assume that VC uses only `file-exists-p', + ;; `file-readable-p' and `file-directory-p' checks; + ;; otherwise we must extend the list. The respective cache + ;; value must be set for these functions in + ;; `tramp-bundle-read-file-names'. + ;; We do not perform any action, but return nil, in order + ;; to keep `vc-registered' running. + ((memq operation '(file-exists-p file-readable-p file-directory-p)) + (add-to-list 'tramp-vc-registered-file-names localname 'append) + nil) + ;; `process-file' and `start-file-process' shall be ignored. + ((eq operation 'process-file) 0) + ((eq operation 'start-file-process) nil) + ;; Tramp file name handlers like `expand-file-name'. They + ;; must still work. + (t (save-match-data (apply (cdr fn) args))))) + + ;; When `tramp-mode' is not enabled, or the file name is not a + ;; remote file name, we don't do anything. Same for default + ;; file namne handlers. + (tramp-run-real-handler operation args)))) (defun tramp-sh-handle-file-notify-add-watch (file-name flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -4316,7 +4319,7 @@ file exists and nonzero exit status otherwise." (defun tramp-find-shell (vec) "Open a shell on the remote host which groks tilde expansion." ;; If we are in `make-process', we don't need another shell. - (unless (tramp-get-connection-property vec "process-name") + (unless (tramp-get-connection-property vec " process-name") (with-current-buffer (tramp-get-buffer vec) (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) shell) @@ -4421,7 +4424,7 @@ process to set up. VEC specifies the connection." (let* ((old-uname (tramp-get-connection-property vec "uname")) (uname ;; If we are in `make-process', we don't need to recompute. - (if (and old-uname (tramp-get-connection-property vec "process-name")) + (if (and old-uname (tramp-get-connection-property vec " process-name")) old-uname (tramp-set-connection-property vec "uname" @@ -4435,7 +4438,7 @@ process to set up. VEC specifies the connection." (and config-check-function ;; If we are in `make-process', we don't need to recompute. (if (and old-config-check - (tramp-get-connection-property vec "process-name")) + (tramp-get-connection-property vec " process-name")) old-config-check (tramp-set-connection-property vec "config-check-data" @@ -5103,7 +5106,7 @@ connection if a previous connection has died for some reason." (with-tramp-debug-message vec "Opening connection" (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name")) + (process-name (tramp-get-connection-property vec " process-name")) (process-environment (copy-sequence process-environment)) (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) @@ -5243,9 +5246,10 @@ connection if a previous connection has died for some reason." (setq r-shell t))) (setq current-host l-host) - ;; Set password prompt vector. + ;; Set hop and password prompt vector. + (tramp-set-connection-property p "hop-vector" hop) (tramp-set-connection-property - p "password-vector" + p "pw-vector" (if (tramp-get-method-parameter hop 'tramp-password-previous-hop) (let ((pv (copy-tramp-file-name previous-hop))) @@ -5256,9 +5260,9 @@ connection if a previous connection has died for some reason." :host l-host :port l-port))) ;; Set session timeout. - (when-let ((timeout - (tramp-get-method-parameter - hop 'tramp-session-timeout))) + (when-let* ((timeout + (tramp-get-method-parameter + hop 'tramp-session-timeout))) (tramp-set-connection-property p "session-timeout" timeout)) @@ -5301,6 +5305,8 @@ connection if a previous connection has died for some reason." tramp-actions-before-shell connection-timeout)) ;; Next hop. + (tramp-flush-connection-property p "hop-vector") + (tramp-flush-connection-property p "pw-vector") (setq options "" target-alist (cdr target-alist) previous-hop hop))) @@ -5906,37 +5912,37 @@ Nonexistent directories are removed from spec." (with-tramp-connection-property vec "awk" (tramp-message vec 5 "Finding a suitable `awk' command") (or (tramp-find-executable vec "awk" (tramp-get-remote-path vec)) - (let* ((busybox (tramp-get-remote-busybox vec)) - (command (format "%s %s" busybox "awk"))) - (and busybox - (tramp-send-command-and-check - vec (concat command " {} <" (tramp-get-remote-null-device vec))) - command))))) + (when-let* + ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "awk")) + ((tramp-send-command-and-check + vec (concat command " {} <" (tramp-get-remote-null-device vec))))) + command)))) (defun tramp-get-remote-hexdump (vec) "Determine remote `hexdump' command." (with-tramp-connection-property vec "hexdump" (tramp-message vec 5 "Finding a suitable `hexdump' command") (or (tramp-find-executable vec "hexdump" (tramp-get-remote-path vec)) - (let* ((busybox (tramp-get-remote-busybox vec)) - (command (format "%s %s" busybox "hexdump"))) - (and busybox - (tramp-send-command-and-check - vec (concat command " <" (tramp-get-remote-null-device vec))) - command))))) + (when-let* + ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "hexdump")) + ((tramp-send-command-and-check + vec (concat command " <" (tramp-get-remote-null-device vec))))) + command)))) (defun tramp-get-remote-od (vec) "Determine remote `od' command." (with-tramp-connection-property vec "od" (tramp-message vec 5 "Finding a suitable `od' command") (or (tramp-find-executable vec "od" (tramp-get-remote-path vec)) - (let* ((busybox (tramp-get-remote-busybox vec)) - (command (format "%s %s" busybox "od"))) - (and busybox - (tramp-send-command-and-check - vec - (concat command " -A n <" (tramp-get-remote-null-device vec))) - command))))) + (when-let* + ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "od")) + ((tramp-send-command-and-check + vec + (concat command " -A n <" (tramp-get-remote-null-device vec))))) + command)))) (defun tramp-get-remote-chmod-h (vec) "Check whether remote `chmod' supports nofollow argument." diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 2699dc13043..8d090a6969f 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -340,15 +340,15 @@ This can be used to disable echo etc." ;;;###tramp-autoload (defsubst tramp-smb-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for SMB servers." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-smb-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-smb-method))))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) "Invoke the SMB related OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-smb-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -526,13 +526,13 @@ arguments to pass to the OPERATION." (unwind-protect (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (with-temp-buffer ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) (when t1 ;; The smbclient tar command creates @@ -613,8 +613,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; `file-local-copy' returns a file name also for a local file ;; with `jka-compr-handler', so we cannot trust its result as ;; indication for a remote file name. - (if-let ((tmpfile - (and (tramp-tramp-file-p filename) (file-local-copy filename)))) + (if-let* ((tmpfile + (and (tramp-tramp-file-p filename) (file-local-copy filename)))) ;; Remote filename. (condition-case err (rename-file tmpfile newname ok-if-already-exists) @@ -765,7 +765,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (forward-line) (delete-region (point-min) (point))) (while (and (not (eobp)) (looking-at-p (rx bol (+ nonl) ":" (+ nonl)))) - (forward-line)) + (forward-line)) (delete-region (point) (point-max)) (throw 'tramp-action 'ok)))) @@ -799,13 +799,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (concat "2>" (tramp-get-remote-null-device v))))) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (with-temp-buffer ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) ;; Use an asynchronous process. By this, password ;; can be handled. @@ -860,7 +860,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Implement `file-attributes' for Tramp files using `stat' command." (tramp-message vec 5 "file attributes with stat: %s" (tramp-file-name-localname vec)) - (let* (size id link uid gid atime mtime ctime mode inode) + (let (size id link uid gid atime mtime ctime mode inode) (when (tramp-smb-send-command vec (format "stat %s" (tramp-smb-shell-quote-localname vec))) @@ -1247,11 +1247,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Call it. (condition-case nil (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property v " process-name" name1) (tramp-set-connection-property - v "process-buffer" + v " process-buffer" (or outbuf (generate-new-buffer tramp-temp-buffer-name))) (with-current-buffer (tramp-get-connection-buffer v) ;; Preserve buffer contents. @@ -1287,9 +1287,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - ;; FIXME: Does connection-property "process-buffer" still exist? + ;; FIXME: Does connection-property " process-buffer" still exist? (unless outbuf - (kill-buffer (tramp-get-connection-property v "process-buffer"))) + (kill-buffer (tramp-get-connection-property v " process-buffer"))) (when process-file-side-effects (tramp-flush-directory-properties v "/")) @@ -1388,13 +1388,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "||" "echo" "tramp_exit_status" "1"))) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (with-temp-buffer ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) ;; Use an asynchronous process. By this, password ;; can be handled. @@ -1450,7 +1450,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." p) (unwind-protect (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (save-excursion (save-restriction (while (get-process name1) @@ -1458,8 +1458,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq i (1+ i) name1 (format "%s<%d>" name i))) ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) - (tramp-set-connection-property v "process-buffer" buffer) + (tramp-set-connection-property v " process-name" name1) + (tramp-set-connection-property v " process-buffer" buffer) ;; Activate narrowing in order to save BUFFER contents. (with-current-buffer (tramp-get-connection-buffer v) (let ((buffer-undo-list t)) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 33b0543a8f5..43fb718bc82 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -170,15 +170,15 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;;;###tramp-autoload (defsubst tramp-sshfs-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for sshfs." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-sshfs-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-sshfs-method))))) ;;;###tramp-autoload (defun tramp-sshfs-file-name-handler (operation &rest args) "Invoke the sshfs handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-sshfs-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 1ffe789746a..bd10a0eb922 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -161,15 +161,15 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defsubst tramp-sudoedit-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for SUDOEDIT." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-sudoedit-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-sudoedit-method))))) ;;;###tramp-autoload (defun tramp-sudoedit-file-name-handler (operation &rest args) "Invoke the SUDOEDIT handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -785,7 +785,7 @@ in case of error, t otherwise." ;; Avoid process status message in output buffer. (set-process-sentinel p #'ignore) (tramp-post-process-creation p vec) - (tramp-set-connection-property p "password-vector" tramp-sudoedit-null-hop) + (tramp-set-connection-property p "pw-vector" tramp-sudoedit-null-hop) (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions) (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string)) (prog1 diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 181bba01304..6d384d97db6 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1610,9 +1610,9 @@ entry does not exist, return DEFAULT." ;; We use the cached property. (tramp-get-connection-property vec hash-entry) ;; Use the static value from `tramp-methods'. - (if-let ((methods-entry - (assoc - param (assoc (tramp-file-name-method vec) tramp-methods)))) + (if-let* ((methods-entry + (assoc + param (assoc (tramp-file-name-method vec) tramp-methods)))) (cadr methods-entry) ;; Return the default value. default)))) @@ -1886,7 +1886,8 @@ expected to be a string, which will be used." ;; Assure that the hops are in `tramp-default-proxies-alist'. ;; In tramp-archive.el, the slot `hop' is used for the archive ;; file name. - (unless (string-equal method tramp-archive-method) + (unless (or minibuffer-completing-file-name + (string-equal method tramp-archive-method)) (tramp-add-hops (car args))))) (t (setq method (nth 0 args) @@ -1955,11 +1956,11 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." (or (get-buffer (tramp-buffer-name vec)) (unless dont-create (with-current-buffer (get-buffer-create (tramp-buffer-name vec)) - ;; We use the existence of connection property "process-buffer" + ;; We use the existence of connection property " process-buffer" ;; as indication, whether a connection is active. (tramp-set-connection-property - vec "process-buffer" - (tramp-get-connection-property vec "process-buffer")) + vec " process-buffer" + (tramp-get-connection-property vec " process-buffer")) (setq buffer-undo-list t default-directory (tramp-make-tramp-file-name vec 'noloc)) @@ -1971,14 +1972,14 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." Unless DONT-CREATE, the buffer is created when it doesn't exist yet. In case a second asynchronous communication has been started, it is different from `tramp-get-buffer'." - (or (tramp-get-connection-property vec "process-buffer") + (or (tramp-get-connection-property vec " process-buffer") (tramp-get-buffer vec dont-create))) (defun tramp-get-connection-name (vec) "Get the connection name to be used for VEC. In case a second asynchronous communication has been started, it is different from the default one." - (or (tramp-get-connection-property vec "process-name") + (or (tramp-get-connection-property vec " process-name") (tramp-buffer-name vec))) (defun tramp-get-unique-process-name (name) @@ -2128,9 +2129,9 @@ without a visible progress reporter." ;; We start a pulsing progress reporter after 3 seconds. ;; Start only when there is no other progress reporter ;; running, and when there is a minimum level. - (when-let ((pr (and (null tramp-inhibit-progress-reporter) - (<= ,level (min tramp-verbose 3)) - (make-progress-reporter ,message)))) + (when-let* ((pr (and (null tramp-inhibit-progress-reporter) + (<= ,level (min tramp-verbose 3)) + (make-progress-reporter ,message)))) (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) (unwind-protect ;; Execute the body. @@ -2152,8 +2153,8 @@ without a visible progress reporter." (let ((seconds (car list)) (timeout-forms (cdr list))) ;; If non-nil, `seconds' must be a positive number. - `(if-let (((natnump ,seconds)) - ((not (zerop timeout)))) + `(if-let* (((natnump ,seconds)) + ((not (zerop timeout)))) (with-timeout (,seconds ,@timeout-forms) ,@body) ,@body))) @@ -2476,7 +2477,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (with-tramp-debug-message v (format "Running `%S'" (cons operation args)) ;; We flush connection properties - ;; "process-name" and "process-buffer", + ;; " process-name" and " process-buffer", ;; because the operations shall be applied ;; in the main connection process. In order ;; to avoid superfluous debug buffers during @@ -2491,12 +2492,12 @@ Fall back to normal file name handler if no Tramp file name handler exists." ;; a short time frame. ;; In both cases, we try the default handler then. (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (let ((tramp-verbose (if minibuffer-completing-file-name 0 tramp-verbose))) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")) + (tramp-flush-connection-property v " process-name") + (tramp-flush-connection-property v " process-buffer")) (setq result (catch 'non-essential (catch 'suppress @@ -2538,7 +2539,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler for OPERATION and ARGS. Falls back to normal file name handler if no Tramp file name handler exists." - (if-let + (if-let* ((fn (and tramp-mode minibuffer-completing-file-name (assoc operation tramp-completion-file-name-handler-alist)))) (save-match-data (apply (cdr fn) args)) @@ -2634,7 +2635,7 @@ remote file names." ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) - (when-let ((entry (rassoc fnh file-name-handler-alist))) + (when-let* ((entry (rassoc fnh file-name-handler-alist))) (setq file-name-handler-alist (cons entry (delete entry file-name-handler-alist)))))) @@ -3870,7 +3871,7 @@ BODY is the backend specific code." (let (last-coding-system-used (need-chown t)) ;; Set file modification time. (when (or (eq ,visit t) (stringp ,visit)) - (when-let ((file-attr (file-attributes filename 'integer))) + (when-let* ((file-attr (file-attributes filename 'integer))) (set-visited-file-modtime ;; We must pass modtime explicitly, because FILENAME ;; can be different from (buffer-file-name), f.e. if @@ -3983,9 +3984,9 @@ Let-bind it when necessary.") (tramp-dont-suspend-timers t)) (with-tramp-timeout (timeout - (unless (when-let ((p (tramp-get-connection-process v))) - (and (process-live-p p) - (tramp-get-connection-property p "connected"))) + (unless (and-let* ((p (tramp-get-connection-process v)) + ((process-live-p p)) + ((tramp-get-connection-property p "connected")))) (tramp-cleanup-connection v 'keep-debug 'keep-password)) (tramp-error v 'file-error @@ -4164,8 +4165,8 @@ Let-bind it when necessary.") (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." - (when-let ((attrs (file-attributes filename)) - (mode-string (file-attribute-modes attrs))) + (when-let* ((attrs (file-attributes filename)) + (mode-string (file-attribute-modes attrs))) (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) (file-modes (file-truename filename)) (tramp-mode-string-to-int mode-string)))) @@ -4177,7 +4178,7 @@ Let-bind it when necessary.") ;; the empty string. Suppress adding a hop to ;; `tramp-default-proxies-alist' due to non-expanded default values. (let ((v (tramp-dissect-file-name file t)) - tramp-default-proxies-alist) + (tramp-default-proxies-alist tramp-cache-undefined)) ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name @@ -4271,7 +4272,7 @@ Let-bind it when necessary.") ;; the remote file name parts. Suppress adding a hop to ;; `tramp-default-proxies-alist' due to non-expanded default values. (let ((v (tramp-dissect-file-name file t)) - tramp-default-proxies-alist) + (tramp-default-proxies-alist tramp-cache-undefined)) ;; Run the command on the localname portion only. If this returns ;; nil, mark also the localname part of `v' as nil. (tramp-make-tramp-file-name @@ -4304,10 +4305,10 @@ Let-bind it when necessary.") (or (tramp-check-cached-permissions v ?r) ;; `tramp-check-cached-permissions' doesn't handle symbolic ;; links. - (when-let ((symlink (file-symlink-p filename))) - (and (stringp symlink) - (file-readable-p - (concat (file-remote-p filename) symlink)))))))) + (and-let* ((symlink (file-symlink-p filename)) + ((stringp symlink)) + ((file-readable-p + (concat (file-remote-p filename) symlink))))))))) (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." @@ -4317,7 +4318,7 @@ Let-bind it when necessary.") ;; because `file-truename' could raise an error for cyclic ;; symlinks. (ignore-errors - (when-let ((attr (file-attributes filename))) + (when-let* ((attr (file-attributes filename))) (cond ((eq ?- (aref (file-attribute-modes attr) 0))) ((eq ?l (aref (file-attribute-modes attr) 0)) @@ -4706,7 +4707,7 @@ Parsing the remote \"ps\" output is controlled by It is not guaranteed, that all process attributes as described in `process-attributes' are returned. The additional attribute `pid' shall be returned always." - (with-tramp-file-property vec "/" "process-attributes" + (with-tramp-connection-property vec " process-attributes" (ignore-errors (with-temp-buffer (hack-connection-local-variables-apply @@ -4753,13 +4754,13 @@ It is not guaranteed, that all process attributes as described in (defun tramp-handle-list-system-processes () "Like `list-system-processes' for Tramp files." (let ((v (tramp-dissect-file-name default-directory))) - (tramp-flush-file-property v "/" "process-attributes") + (tramp-flush-connection-property v " process-attributes") (mapcar (lambda (x) (cdr (assq 'pid x))) (tramp-get-process-attributes v)))) (defun tramp-get-lock-file (file) "Read lockfile info of FILE. Return nil when there is no lockfile." - (when-let ((lockname (make-lock-file-name file))) + (when-let* ((lockname (make-lock-file-name file))) (or (file-symlink-p lockname) (and (file-readable-p lockname) (with-temp-buffer @@ -4790,8 +4791,8 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (defun tramp-handle-file-locked-p (file) "Like `file-locked-p' for Tramp files." - (when-let ((info (tramp-get-lock-file file)) - (match (string-match tramp-lock-file-info-regexp info))) + (when-let* ((info (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-info-regexp info))) (or ; Locked by me. (and (string-equal (match-string 1 info) (user-login-name)) (string-equal (match-string 2 info) tramp-system-name) @@ -4813,20 +4814,20 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") ;; for remote files. (ask-user-about-supersession-threat file)) - (when-let ((info (tramp-get-lock-file file)) - (match (string-match tramp-lock-file-info-regexp info))) + (when-let* ((info (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-info-regexp info))) (unless (ask-user-about-lock file (format "%s@%s (pid %s)" (match-string 1 info) (match-string 2 info) (match-string 3 info))) (throw 'dont-lock nil))) - (when-let ((lockname (make-lock-file-name file)) - ;; USER@HOST.PID[:BOOT_TIME] - (info - (format - "%s@%s.%s" (user-login-name) tramp-system-name - (tramp-get-lock-pid file)))) + (when-let* ((lockname (make-lock-file-name file)) + ;; USER@HOST.PID[:BOOT_TIME] + (info + (format + "%s@%s.%s" (user-login-name) tramp-system-name + (tramp-get-lock-pid file)))) ;; Protect against security hole. (with-parsed-tramp-file-name file nil @@ -4866,9 +4867,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") ;; When there is no connection, we don't do it. Otherwise, ;; functions like `kill-buffer' would try to reestablish the ;; connection. See Bug#61663. - (if-let ((v (tramp-dissect-file-name file)) - ((process-live-p (tramp-get-process v))) - (lockname (make-lock-file-name file))) + (if-let* ((v (tramp-dissect-file-name file)) + ((process-live-p (tramp-get-process v))) + (lockname (make-lock-file-name file))) (delete-file lockname) ;; Trigger the unlock error. Be quiet if user isn't ;; interested in lock files. See Bug#70900. @@ -4912,21 +4913,37 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (defun tramp-add-hops (vec) "Add ad-hoc proxy definitions to `tramp-default-proxies-alist'." - (when-let ((hops (tramp-file-name-hop vec)) - (item vec)) + ;; `tramp-default-proxies-alist' is bound to `tramp-cache-undefined' + ;; in `tramp-handle-file-name-as-directory' and + ;; `tramp-handle-file-name-directory' suppressing to add a hop. + (when-let* (((not (eq tramp-default-proxies-alist tramp-cache-undefined))) + (hops (tramp-file-name-hop vec)) + (item vec)) (let (signal-hook-function changed) (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) (let* ((host-port (tramp-file-name-host-port item)) + (host-port (and (stringp host-port) + (rx bol (literal host-port) eol))) (user-domain (tramp-file-name-user-domain item)) + (user-domain (and (stringp user-domain) + (rx bol (literal user-domain) eol))) (proxy (concat tramp-prefix-format proxy tramp-postfix-host-format)) (entry - (list (and (stringp host-port) - (rx bol (literal host-port) eol)) - (and (stringp user-domain) - (rx bol (literal user-domain) eol)) - (propertize proxy 'tramp-ad-hoc t)))) + (list host-port user-domain (propertize proxy 'tramp-ad-hoc t)))) + ;; Remove superfluous entries. + (when tramp-show-ad-hoc-proxies + (dolist (entry1 tramp-default-proxies-alist) + (when (and (equal host-port (car entry1)) + (equal user-domain (cadr entry1)) + (not (equal proxy (caddr entry1)))) + (tramp-message + vec 5 "Remove %S from `tramp-default-proxies-alist'" entry1) + (tramp-cleanup-connection + vec 'keep-debug 'keep-password 'keep-processes) + (setq tramp-default-proxies-alist + (delete entry1 tramp-default-proxies-alist))))) ;; Add the hop. (unless (member entry tramp-default-proxies-alist) (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) @@ -4945,74 +4962,74 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (item vec) choices proxy) - ;; Ad-hoc proxy definitions. - (tramp-add-hops vec) - - ;; Look for proxy hosts to be passed. - (setq choices tramp-default-proxies-alist) - (while choices - (setq item (pop choices) - proxy (eval (nth 2 item) t)) - (when (and - ;; Host. - (string-match-p - (or (eval (nth 0 item) t) "") - (or (tramp-file-name-host-port (car target-alist)) "")) - ;; User. - (string-match-p - (or (eval (nth 1 item) t) "") - (or (tramp-file-name-user-domain (car target-alist)) ""))) - (if (null proxy) - ;; No more hops needed. - (setq choices nil) - ;; Replace placeholders. The proxy could contain "%" which - ;; is not intended as format character, for example in - ;; USER%DOMAIN or POD%NAMESPACE. - (setq proxy - (replace-regexp-in-string - (rx "%" (group (= 2 alnum))) "%%\\1" proxy) - proxy - (format-spec - proxy - (format-spec-make - ?u (or (tramp-file-name-user (car target-alist)) "") - ?h (or (tramp-file-name-host (car target-alist)) "")))) - (with-parsed-tramp-file-name proxy l - ;; Add the hop. - (push l target-alist) - ;; Start next search. - (setq choices tramp-default-proxies-alist))))) - - ;; Foreign and out-of-band methods are not supported for multi-hops. - (when (cdr target-alist) - (setq choices target-alist) - (while (setq item (pop choices)) - (unless (tramp-multi-hop-p item) - (setq tramp-default-proxies-alist saved-tdpa) - (tramp-user-error - vec "Method `%s' is not supported for multi-hops" - (tramp-file-name-method item))))) - - ;; Some methods ("su", "sg", "sudo", "doas", "run0", "ksu") do not - ;; use the host name in their command template. In this case, the - ;; remote file name must use either a local host name (first hop), - ;; or a host name matching the previous hop. - (let ((previous-host (or tramp-local-host-regexp ""))) - (setq choices target-alist) - (while (setq item (pop choices)) - (let ((host (tramp-file-name-host item))) - (unless - (or - ;; The host name is used for the remote shell command. - (member - "%h" (flatten-tree - (tramp-get-method-parameter item 'tramp-login-args))) - ;; The host name must match previous hop. - (string-match-p previous-host host)) + ;; `tramp-compute-multi-hops' could be called also for other file + ;; name handlers, for example in `tramp-clear-passwd'. + (when (tramp-sh-file-name-handler-p vec) + + ;; Ad-hoc proxy definitions. + (tramp-add-hops vec) + + ;; Look for proxy hosts to be passed. + (setq choices tramp-default-proxies-alist) + (while choices + (setq item (pop choices) + proxy (eval (nth 2 item) t)) + (when (and + ;; Host. + (string-match-p + (or (eval (nth 0 item) t) "") + (or (tramp-file-name-host-port (car target-alist)) "")) + ;; User. + (string-match-p + (or (eval (nth 1 item) t) "") + (or (tramp-file-name-user-domain (car target-alist)) ""))) + (if (null proxy) + ;; No more hops needed. + (setq choices nil) + ;; Replace placeholders. + (setq proxy + (format-spec + proxy + (format-spec-make + ?u (or (tramp-file-name-user (car target-alist)) "") + ?h (or (tramp-file-name-host (car target-alist)) "")))) + (with-parsed-tramp-file-name proxy l + ;; Add the hop. + (push l target-alist) + ;; Start next search. + (setq choices tramp-default-proxies-alist))))) + + ;; Foreign and out-of-band methods are not supported for + ;; multi-hops. + (when (cdr target-alist) + (setq choices target-alist) + (while (setq item (pop choices)) + (unless (tramp-multi-hop-p item) (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error - vec "Host name `%s' does not match `%s'" host previous-host)) - (setq previous-host (rx bol (literal host) eol))))) + vec "Method `%s' is not supported for multi-hops" + (tramp-file-name-method item))))) + + ;; Some methods ("su", "sg", "sudo", "doas", "run0", "ksu") do + ;; not use the host name in their command template. In this + ;; case, the remote file name must use either a local host name + ;; (first hop), or a host name matching the previous hop. + (let ((previous-host (or tramp-local-host-regexp ""))) + (setq choices target-alist) + (while (setq item (pop choices)) + (let ((host (tramp-file-name-host item))) + (unless + (or + ;; The host name is used for the remote shell command. + (member + "%h" (flatten-tree + (tramp-get-method-parameter item 'tramp-login-args))) + ;; The host name must match previous hop. + (string-match-p previous-host host)) + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Host name `%s' does not match `%s'" host previous-host)) + (setq previous-host (rx bol (literal host) eol)))))) ;; Result. target-alist)) @@ -5126,13 +5143,13 @@ should be set connection-local.") elt (default-toplevel-value 'process-environment)))) (setq env (cons elt env))))) ;; Add remote path if exists. - (env (if-let ((sh-file-name-handler-p) - (remote-path - (string-join (tramp-get-remote-path v) ":"))) + (env (if-let* ((sh-file-name-handler-p) + (remote-path + (string-join (tramp-get-remote-path v) ":"))) (setenv-internal env "PATH" remote-path 'keep) env)) ;; Add HISTFILE if indicated. - (env (if-let ((sh-file-name-handler-p)) + (env (if sh-file-name-handler-p (cond ((stringp tramp-histfile-override) (setenv-internal @@ -5677,7 +5694,11 @@ of." ;; Sometimes, the process returns a new password request ;; immediately after rejecting the previous (wrong) one. (unless (or tramp-password-prompt-not-unique - (tramp-get-connection-property vec "first-password-request")) + (tramp-get-connection-property + (tramp-get-connection-property + proc "hop-vector" + (process-get proc 'tramp-vector)) + " first-password-request")) (tramp-clear-passwd vec)) (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) @@ -5880,11 +5901,11 @@ because the shell prompt has been detected), it shall throw a result. The symbol `ok' means that all ACTIONs have been performed successfully. Any other value means an error." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use the "password-vector" property in case we have several hops. + ;; use the "hop-vector" property in case we have several hops. (tramp-set-connection-property (tramp-get-connection-property - proc "password-vector" (process-get proc 'tramp-vector)) - "first-password-request" tramp-cache-read-persistent-data) + proc "hop-vector" (process-get proc 'tramp-vector)) + " first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter proc 3 "Waiting for prompts from remote shell" @@ -5964,8 +5985,8 @@ If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." ;; communication. This could block the output for the current ;; process. Read such output first. (Bug#61350) ;; The process property isn't set anymore due to Bug#62194. - (when-let (((process-get proc 'tramp-shared-socket)) - (v (process-get proc 'tramp-vector))) + (when-let* (((process-get proc 'tramp-shared-socket)) + (v (process-get proc 'tramp-vector))) (dolist (p (delq proc (process-list))) (when (tramp-file-name-equal-p v (process-get p 'tramp-vector)) (with-tramp-suspended-timers @@ -6277,10 +6298,10 @@ depending whether FILENAME is remote or local. Both parameters must be non-negative integers. The setgid bit of the upper directory is respected. If FILENAME is remote, a file name handler is called." - (let* ((dir (file-name-directory filename)) - (modes (file-modes dir))) - (when (and modes (not (zerop (logand modes #o2000)))) - (setq gid (file-attribute-group-id (file-attributes dir))))) + (when-let* ((dir (file-name-directory filename)) + (modes (file-modes dir)) + ((not (zerop (logand modes #o2000))))) + (setq gid (file-attribute-group-id (file-attributes dir)))) (if (tramp-tramp-file-p filename) (funcall (if (tramp-crypt-file-name-p filename) @@ -6338,14 +6359,14 @@ VEC is used for tracing." "Check `file-attributes' caches for VEC. Return t if according to the cache access type ACCESS is known to be granted." - (when-let ((offset (cond - ((eq ?r access) 1) - ((eq ?w access) 2) - ((eq ?x access) 3) - ((eq ?s access) 3))) - (file-attr (file-attributes (tramp-make-tramp-file-name vec))) - (remote-uid (tramp-get-remote-uid vec 'integer)) - (remote-gid (tramp-get-remote-gid vec 'integer))) + (when-let* ((offset (cond + ((eq ?r access) 1) + ((eq ?w access) 2) + ((eq ?x access) 3) + ((eq ?s access) 3))) + (file-attr (file-attributes (tramp-make-tramp-file-name vec))) + (remote-uid (tramp-get-remote-uid vec 'integer)) + (remote-gid (tramp-get-remote-gid vec 'integer))) (or ;; Not a symlink. (eq t (file-attribute-type file-attr)) @@ -6382,112 +6403,110 @@ Convert file mode bits to string and set virtual device number. Set file uid and gid according to ID-FORMAT. LOCALNAME is used to cache the result. Return the modified ATTR." (declare (indent 3) (debug t)) - `(with-tramp-file-property - ,vec ,localname (format "file-attributes-%s" (or ,id-format 'integer)) - (when-let - ((result - (with-tramp-file-property ,vec ,localname "file-attributes" - (when-let ((attr ,attr)) - (save-match-data - ;; Remove ANSI control escape sequences from symlink. + `(when-let* + ((result + (with-tramp-file-property ,vec ,localname "file-attributes" + (when-let* ((attr ,attr)) + (save-match-data + ;; Remove ANSI control escape sequences from symlink. + (when (stringp (car attr)) + (while (string-match ansi-color-control-seq-regexp (car attr)) + (setcar attr (replace-match "" nil nil (car attr))))) + ;; Convert uid and gid. Use `tramp-unknown-id-integer' + ;; as indication of unusable value. + (when (consp (nth 2 attr)) + (when (and (numberp (cdr (nth 2 attr))) + (< (cdr (nth 2 attr)) 0)) + (setcdr (car (nthcdr 2 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 2 attr))) + (<= (cdr (nth 2 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 2 attr)) (round (cdr (nth 2 attr)))))) + (when (consp (nth 3 attr)) + (when (and (numberp (cdr (nth 3 attr))) + (< (cdr (nth 3 attr)) 0)) + (setcdr (car (nthcdr 3 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 3 attr))) + (<= (cdr (nth 3 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 3 attr)) (round (cdr (nth 3 attr)))))) + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) most-positive-fixnum)) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) + (tramp-file-mode-from-int (nth 8 attr))) (when (stringp (car attr)) - (while (string-match ansi-color-control-seq-regexp (car attr)) - (setcar attr (replace-match "" nil nil (car attr))))) - ;; Convert uid and gid. Use `tramp-unknown-id-integer' - ;; as indication of unusable value. - (when (consp (nth 2 attr)) - (when (and (numberp (cdr (nth 2 attr))) - (< (cdr (nth 2 attr)) 0)) - (setcdr (car (nthcdr 2 attr)) tramp-unknown-id-integer)) - (when (and (floatp (cdr (nth 2 attr))) - (<= (cdr (nth 2 attr)) most-positive-fixnum)) - (setcdr (car (nthcdr 2 attr)) (round (cdr (nth 2 attr)))))) - (when (consp (nth 3 attr)) - (when (and (numberp (cdr (nth 3 attr))) - (< (cdr (nth 3 attr)) 0)) - (setcdr (car (nthcdr 3 attr)) tramp-unknown-id-integer)) - (when (and (floatp (cdr (nth 3 attr))) - (<= (cdr (nth 3 attr)) most-positive-fixnum)) - (setcdr (car (nthcdr 3 attr)) (round (cdr (nth 3 attr)))))) - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) most-positive-fixnum)) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) - (tramp-file-mode-from-int (nth 8 attr))) - (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-prefix-p "d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - ;; Decode also multibyte string. - (when (consp (car attr)) - (setcar attr - (and (stringp (caar attr)) - (string-match - (rx (+ nonl) " -> " nonl (group (+ nonl)) nonl) - (caar attr)) - (decode-coding-string - (match-string 1 (caar attr)) 'utf-8)))) - ;; Set file's gid change bit. - (setcar - (nthcdr 9 attr) - (not (= (cdr (nth 3 attr)) - (or (tramp-get-remote-gid ,vec 'integer) - tramp-unknown-id-integer)))) - ;; Convert inode. - (when (floatp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (let ((high (nth 10 attr)) - middle low) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-prefix-p "d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. + (when (consp (car attr)) + (setcar attr + (and (stringp (caar attr)) + (string-match + (rx (+ nonl) " -> " nonl (group (+ nonl)) nonl) + (caar attr)) + (decode-coding-string + (match-string 1 (caar attr)) 'utf-8)))) + ;; Set file's gid change bit. + (setcar + (nthcdr 9 attr) + (not (= (cdr (nth 3 attr)) + (or (tramp-get-remote-gid ,vec 'integer) + tramp-unknown-id-integer)))) + ;; Convert inode. + (when (floatp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (let ((high (nth 10 attr)) + middle low) + (if (<= high most-positive-fixnum) + (floor high) + ;; The low 16 bits. + (setq low (mod high #x10000) + high (/ high #x10000)) (if (<= high most-positive-fixnum) - (floor high) - ;; The low 16 bits. - (setq low (mod high #x10000) - high (/ high #x10000)) - (if (<= high most-positive-fixnum) - (cons (floor high) (floor low)) - ;; The middle 24 bits. - (setq middle (mod high #x1000000) - high (/ high #x1000000)) - (cons (floor high) - (cons (floor middle) (floor low)))))) - ;; Inodes can be incredible huge. We - ;; must hide this. - (error (tramp-get-inode ,vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device ,vec)) - ;; Set SELinux context. - (when (stringp (nth 12 attr)) - (tramp-set-file-property - ,vec ,localname "file-selinux-context" - (split-string (nth 12 attr) ":" 'omit))) - ;; Remove optional entries. - (setcdr (nthcdr 11 attr) nil) - attr))))) - - ;; Return normalized result. - (append (tramp-compat-take 2 result) - (if (eq ,id-format 'string) - (list (car (nth 2 result)) (car (nth 3 result))) - (list (cdr (nth 2 result)) (cdr (nth 3 result)))) - (nthcdr 4 result))))) + (cons (floor high) (floor low)) + ;; The middle 24 bits. + (setq middle (mod high #x1000000) + high (/ high #x1000000)) + (cons (floor high) + (cons (floor middle) (floor low)))))) + ;; Inodes can be incredible huge. We must + ;; hide this. + (error (tramp-get-inode ,vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device ,vec)) + ;; Set SELinux context. + (when (stringp (nth 12 attr)) + (tramp-set-file-property + ,vec ,localname "file-selinux-context" + (split-string (nth 12 attr) ":" 'omit))) + ;; Remove optional entries. + (setcdr (nthcdr 11 attr) nil) + attr))))) + + ;; Return normalized result. + (append (tramp-compat-take 2 result) + (if (eq ,id-format 'string) + (list (car (nth 2 result)) (car (nth 3 result))) + (list (cdr (nth 2 result)) (cdr (nth 3 result)))) + (nthcdr 4 result)))) (defun tramp-get-home-directory (vec &optional user) "The remote home directory for connection VEC as local file name. @@ -6805,13 +6824,15 @@ verbosity of 6." (catch 'result (let ((default-directory temporary-file-directory)) (dolist (pid (list-system-processes)) - (when-let ((attributes (process-attributes pid)) - (comm (cdr (assoc 'comm attributes)))) - (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) - ;; The returned command name could be truncated to 15 - ;; characters. Therefore, we cannot check for `string-equal'. - (string-prefix-p comm process-name) - (throw 'result t)))))))) + (and-let* ((attributes (process-attributes pid)) + (comm (cdr (assoc 'comm attributes))) + ((string-equal + (cdr (assoc 'user attributes)) (user-login-name))) + ;; The returned command name could be truncated + ;; to 15 characters. Therefore, we cannot check + ;; for `string-equal'. + ((string-prefix-p comm process-name)) + ((throw 'result t))))))))) ;; When calling "emacs -Q", `auth-source-search' won't be called. If ;; you want to debug exactly this case, call "emacs -Q --eval '(setq @@ -6826,15 +6847,16 @@ Consults the auth-source package." ;; adapt `default-directory'. (Bug#39389, Bug#39489) (default-directory tramp-compat-temporary-file-directory) (case-fold-search t) - ;; In tramp-sh.el, we must use "password-vector" due to - ;; multi-hop. - (vec (tramp-get-connection-property - proc "password-vector" (process-get proc 'tramp-vector))) - (key (tramp-make-tramp-file-name vec 'noloc)) - (method (tramp-file-name-method vec)) - (user-domain (or (tramp-file-name-user-domain vec) - (tramp-get-connection-property key "login-as"))) - (host-port (tramp-file-name-host-port vec)) + ;; In tramp-sh.el, we must use "hop-vector" and "pw-vector" + ;; due to multi-hop. + (vec (process-get proc 'tramp-vector)) + (hop-vec (tramp-get-connection-property proc "hop-vector" vec)) + (pw-vec (tramp-get-connection-property proc "pw-vector" hop-vec)) + (key (tramp-make-tramp-file-name pw-vec 'noloc)) + (method (tramp-file-name-method pw-vec)) + (user-domain (or (tramp-file-name-user-domain pw-vec) + (tramp-get-connection-property pw-vec "login-as"))) + (host-port (tramp-file-name-host-port pw-vec)) (pw-prompt (string-trim-left (or prompt @@ -6843,28 +6865,23 @@ Consults the auth-source package." (if (string-match-p "passphrase" (match-string 1)) (match-string 0) (format "%s for %s " (capitalize (match-string 1)) key)))))) + ;; If there is no user name, `:create' triggers to ask for. + ;; We suppress it. + (pw-spec (list :max 1 :user user-domain :host host-port :port method + :require (cons :secret (and user-domain '(:user))) + :create (and user-domain t))) (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; Use connection-local value. (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) auth-info auth-passwd tramp-dont-suspend-timers) (unwind-protect - ;; We cannot use `with-parsed-tramp-file-name', because it - ;; expands the file name. (or (setq tramp-password-save-function nil) - ;; See if auth-sources contains something useful. + ;; See if `auth-sources' contains something useful. (ignore-errors - (and (tramp-get-connection-property vec "first-password-request") - ;; Try with Tramp's current method. If there is no - ;; user name, `:create' triggers to ask for. We - ;; suppress it. - (setq auth-info - (car - (auth-source-search - :max 1 :user user-domain :host host-port :port method - :require (cons :secret (and user-domain '(:user))) - :create (and user-domain t))) + (and (tramp-get-connection-property hop-vec " first-password-request") + (setq auth-info (car (apply #'auth-source-search pw-spec)) tramp-password-save-function (plist-get auth-info :save-function) auth-passwd @@ -6872,12 +6889,19 @@ Consults the auth-source package." ;; Try the password cache. (with-tramp-suspended-timers - (setq auth-passwd (password-read pw-prompt key) + (setq auth-passwd + (password-read + pw-prompt (auth-source-format-cache-entry pw-spec)) tramp-password-save-function - (lambda () (password-cache-add key auth-passwd))) + (when auth-source-do-cache + (lambda () + (password-cache-add + (auth-source-format-cache-entry pw-spec) auth-passwd)))) auth-passwd)) - (tramp-set-connection-property vec "first-password-request" nil)))) + ;; Remember the values. + (tramp-set-connection-property hop-vec " pw-spec" pw-spec) + (tramp-set-connection-property hop-vec " first-password-request" nil)))) (defun tramp-read-passwd-without-cache (proc &optional prompt) "Read a password from user (compat function)." @@ -6894,17 +6918,11 @@ Consults the auth-source package." (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (declare (tramp-suppress-trace t)) - (let ((method (tramp-file-name-method vec)) - (user-domain (tramp-file-name-user-domain vec)) - (host-port (tramp-file-name-host-port vec)) - (hop (tramp-file-name-hop vec))) - (when hop - ;; Clear also the passwords of the hops. - (tramp-clear-passwd (tramp-dissect-hop-name hop))) - (auth-source-forget - `(:max 1 ,(and user-domain :user) ,user-domain - :host ,host-port :port ,method)) - (password-cache-remove (tramp-make-tramp-file-name vec 'noloc)))) + (when-let* ((hop (cadr (reverse (tramp-compute-multi-hops vec))))) + ;; Clear also the passwords of the hops. + (tramp-clear-passwd hop)) + (when-let* ((pw-spec (tramp-get-connection-property vec " pw-spec"))) + (auth-source-forget pw-spec))) (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/obsolete/idlw-complete-structtag.el index bcc2ee2f005..b1e8a891c18 100644 --- a/lisp/progmodes/idlw-complete-structtag.el +++ b/lisp/obsolete/idlw-complete-structtag.el @@ -7,6 +7,7 @@ ;; Old-Version: 1.2 ;; Keywords: languages ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -25,6 +26,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x package-list' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; Completion of structure tags can be done automatically in the ;; shell, since the list of tags can be determined dynamically through ;; interaction with IDL. diff --git a/lisp/progmodes/idlw-help.el b/lisp/obsolete/idlw-help.el index c311e1c5377..3fc654407b3 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/obsolete/idlw-help.el @@ -6,6 +6,7 @@ ;; Carsten Dominik <dominik@science.uva.nl> ;; Maintainer: emacs-devel@gnu.org ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -24,6 +25,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x package-list' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; The help link information for IDLWAVE's online help feature for ;; system routines is extracted automatically from the IDL ;; documentation, and is available, along with general routine diff --git a/lisp/progmodes/idlw-shell.el b/lisp/obsolete/idlw-shell.el index b5d91f46b17..2abf4b5e6dc 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/obsolete/idlw-shell.el @@ -8,6 +8,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Keywords: processes ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -25,7 +26,12 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; + +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x package-list' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; This mode is for IDL version 5 or later. ;; ;; Runs IDL as an inferior process of Emacs, much like the Emacs diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/obsolete/idlw-toolbar.el index c6cb47baa40..4e7d336ec31 100644 --- a/lisp/progmodes/idlw-toolbar.el +++ b/lisp/obsolete/idlw-toolbar.el @@ -6,6 +6,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Keywords: processes ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -24,6 +25,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x package-list' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; This file implements a debugging toolbar for IDLWAVE. ;; It requires toolbar and xpm support. diff --git a/lisp/progmodes/idlwave.el b/lisp/obsolete/idlwave.el index b3e9eb58196..b456a542d35 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/obsolete/idlwave.el @@ -8,6 +8,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Version: 6.1.22 ;; Keywords: languages +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -26,6 +27,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x package-list' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; IDLWAVE enables feature-rich development and interaction with IDL, ;; the Interactive Data Language. It provides a compelling, ;; full-featured alternative to the IDLDE development environment @@ -3900,7 +3906,7 @@ you specify /." "sh" nil errbuf nil "-c" (concat cmd append item))) 0 - 1))) + 1))) ;; ;; Append additional tags (setq append " --append ") @@ -4610,7 +4616,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.") (if (setq master-elt (assoc master-link linkfiles)) (if (eq (car linkfiles) master-elt) linkfiles - (cons master-elt (delq master-elt linkfiles))) + (cons master-elt (delq master-elt linkfiles))) (push (list master-link) linkfiles)))) (defun idlwave-convert-xml-clean-statement-aliases (aliases) @@ -6326,7 +6332,7 @@ ARROW: Location of the arrow" (idlwave-routines) (let* (;(bos (save-excursion (idlwave-beginning-of-statement) (point))) (bos (save-excursion (idlwave-start-of-substatement 'pre) (point))) - (func-entry (idlwave-what-function bos)) + (func-entry (idlwave-what-function bos)) (func (car func-entry)) (func-class (nth 1 func-entry)) (func-arrow (nth 2 func-entry)) diff --git a/lisp/org/ob-R.el b/lisp/org/ob-R.el index de2d27a9a70..8074496f881 100644 --- a/lisp/org/ob-R.el +++ b/lisp/org/ob-R.el @@ -288,7 +288,7 @@ Use PARAMS to set default directory when creating a new session." "Associate R code buffer with an R session. Make SESSION be the inferior ESS process associated with the current code buffer." - (when-let ((process (get-buffer-process session))) + (when-let* ((process (get-buffer-process session))) (setq ess-local-process-name (process-name process)) (ess-make-buffer-current)) (setq-local ess-gen-proc-buffer-name-function (lambda (_) session))) diff --git a/lisp/org/ob-clojure.el b/lisp/org/ob-clojure.el index c7ebbbb95e9..eb2d8c34cac 100644 --- a/lisp/org/ob-clojure.el +++ b/lisp/org/ob-clojure.el @@ -120,14 +120,14 @@ :package-version '(Org . "9.6")) (defcustom ob-clojure-nbb-command (or (executable-find "nbb") - (when-let (npx (executable-find "npx")) + (when-let* ((npx (executable-find "npx"))) (concat npx " nbb"))) "Nbb command used by the ClojureScript `nbb' backend." :type '(choice string (const nil)) :group 'org-babel :package-version '(Org . "9.7")) -(defcustom ob-clojure-cli-command (when-let (cmd (executable-find "clojure")) +(defcustom ob-clojure-cli-command (when-let* ((cmd (executable-find "clojure"))) (concat cmd " -M")) "Clojure CLI command used by the Clojure `clojure-cli' backend." :type '(choice string (const nil)) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 7b4ca9b5ea3..b657a93dab3 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -870,7 +870,7 @@ guess will be made." (default-directory (cond ((not dir) default-directory) - ((when-let ((session (org-babel-session-buffer info))) + ((when-let* ((session (org-babel-session-buffer info))) (buffer-local-value 'default-directory (get-buffer session)))) ((member mkdirp '("no" "nil" nil)) (file-name-as-directory (expand-file-name dir))) diff --git a/lisp/org/ob-exp.el b/lisp/org/ob-exp.el index 30b2a42a6c4..b9d5f288ac1 100644 --- a/lisp/org/ob-exp.el +++ b/lisp/org/ob-exp.el @@ -441,7 +441,7 @@ replaced with its value." ("header-args" . ,(org-babel-exp--at-source - (when-let ((params (org-element-property :parameters (org-element-context)))) + (when-let* ((params (org-element-property :parameters (org-element-context)))) (concat " " params)))) ,@(mapcar (lambda (pair) (cons (substring (symbol-name (car pair)) 1) diff --git a/lisp/org/ob-julia.el b/lisp/org/ob-julia.el index 10a331e54d5..224a8ec75e8 100644 --- a/lisp/org/ob-julia.el +++ b/lisp/org/ob-julia.el @@ -75,7 +75,7 @@ "Associate R code buffer with an R session. Make SESSION be the inferior ESS process associated with the current code buffer." - (when-let ((process (get-buffer-process session))) + (when-let* ((process (get-buffer-process session))) (setq ess-local-process-name (process-name process)) (ess-make-buffer-current)) (setq-local ess-gen-proc-buffer-name-function (lambda (_) session))) diff --git a/lisp/org/ob-python.el b/lisp/org/ob-python.el index 8a3c24f7038..f881918c75c 100644 --- a/lisp/org/ob-python.el +++ b/lisp/org/ob-python.el @@ -269,7 +269,7 @@ results as a string." "Return non-nil if the last prompt matches input prompt. Backport of `python-util-comint-end-of-output-p' to emacs28. To be removed after minimum supported version reaches emacs29." - (when-let ((prompt (python-util-comint-last-prompt))) + (when-let* ((prompt (python-util-comint-last-prompt))) (python-shell-comint-end-of-output-p (buffer-substring-no-properties (car prompt) (cdr prompt))))) diff --git a/lisp/org/ol.el b/lisp/org/ol.el index a16f27c2e30..c3101254f70 100644 --- a/lisp/org/ol.el +++ b/lisp/org/ol.el @@ -2028,7 +2028,7 @@ non-interactively, don't allow editing the default description." (setq link (substring link 0 -1)))) (setq link (with-current-buffer origbuf (org-link--try-special-completion link))))) - (when-let ((window (get-buffer-window "*Org Links*" t))) + (when-let* ((window (get-buffer-window "*Org Links*" t))) (quit-window 'kill window)) (set-window-configuration wcf) (when (get-buffer "*Org Links*") diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el index fc7f50a08e7..a441971238a 100644 --- a/lisp/org/org-attach.el +++ b/lisp/org/org-attach.el @@ -357,7 +357,7 @@ Shows a list of commands and prompts for another key to execute a command." (while (and (setq c (read-char-exclusive)) (memq c '(?\C-n ?\C-p ?\C-v ?\M-v))) (org-scroll c t))) - (when-let ((window (get-buffer-window "*Org Attach*" t))) + (when-let* ((window (get-buffer-window "*Org Attach*" t))) (quit-window 'kill window)) (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*"))))) (let ((command (cl-some (lambda (entry) diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 316cd7eee4b..7ac4f27ad80 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -698,7 +698,7 @@ there is no recent clock to choose from." (fit-window-to-buffer nil nil (if (< chl 10) chl (+ 5 chl))) (message (or prompt "Select task for clocking:")) (unwind-protect (setq cursor-type nil rpl (read-char-exclusive)) - (when-let ((window (get-buffer-window "*Clock Task Select*" t))) + (when-let* ((window (get-buffer-window "*Clock Task Select*" t))) (quit-window 'kill window)) (when (get-buffer "*Clock Task Select*") (kill-buffer "*Clock Task Select*"))) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index 41c26ad72fe..e92b8d718c8 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -115,10 +115,10 @@ This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be called only by `display-buffer' or a function directly or indirectly called by the latter." - (when-let ((window (or (display-buffer-reuse-window buffer alist) - (display-buffer-same-window buffer alist) - (display-buffer-pop-up-window buffer alist) - (display-buffer-use-some-window buffer alist)))) + (when-let* ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) (delete-other-windows window) window))) diff --git a/lisp/org/org-element-ast.el b/lisp/org/org-element-ast.el index f3f74928004..e96b129f1fc 100644 --- a/lisp/org/org-element-ast.el +++ b/lisp/org/org-element-ast.el @@ -410,7 +410,7 @@ If PROPERTY is not present, return DFLT." (let ((idx (org-element--property-idx (inline-const-val property)))) (inline-quote (let ((idx (or ,idx (org-element--property-idx ,property)))) - (if-let ((parray (and idx (org-element--parray ,node)))) + (if-let* ((parray (and idx (org-element--parray ,node)))) (pcase (aref parray idx) (`org-element-ast--nil ,dflt) (val val)) @@ -456,7 +456,7 @@ Return modified NODE." (inline-quote (let ((idx (org-element--property-idx ,property))) (if (and idx (not (org-element-type-p ,node 'plain-text))) - (when-let + (when-let* ((parray (or (org-element--parray ,node) (org-element--put-parray ,node)))) @@ -796,7 +796,7 @@ When DATUM is `plain-text', all the properties are removed." (type (let ((node-copy (append (list type (copy-sequence (cadr datum))) (copy-sequence (cddr datum))))) ;; Copy `:standard-properties' - (when-let ((parray (org-element-property-raw :standard-properties node-copy))) + (when-let* ((parray (org-element-property-raw :standard-properties node-copy))) (org-element-put-property node-copy :standard-properties (copy-sequence parray))) ;; Clear `:parent'. (org-element-put-property node-copy :parent nil) @@ -810,7 +810,7 @@ When DATUM is `plain-text', all the properties are removed." ;; properties. So, we need to reassign inner `:parent' ;; properties to the DATUM copy explicitly. (dolist (secondary-prop (org-element-property :secondary node-copy)) - (when-let ((secondary-value (org-element-property secondary-prop node-copy))) + (when-let* ((secondary-value (org-element-property secondary-prop node-copy))) (setq secondary-value (org-element-copy secondary-value t)) (if (org-element-type secondary-value) (org-element-put-property secondary-value :parent node-copy) diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index a3fe427403a..d184165f6cb 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -4455,10 +4455,10 @@ Assume point is at the beginning of the timestamp." (and val (number-to-string val))) (pcase (org-element-property :repeater-unit timestamp) (`hour "h") (`day "d") (`week "w") (`month "m") (`year "y")) - (when-let ((repeater-deadline-value - (org-element-property :repeater-deadline-value timestamp)) - (repeater-deadline-unit - (org-element-property :repeater-deadline-unit timestamp))) + (when-let* ((repeater-deadline-value + (org-element-property :repeater-deadline-value timestamp)) + (repeater-deadline-unit + (org-element-property :repeater-deadline-unit timestamp))) (concat "/" (number-to-string repeater-deadline-value) @@ -6012,7 +6012,7 @@ cache during the synchronization get a new key generated with Such keys are stored inside the element property `:org-element--cache-sync-key'. The property is a cons containing current `org-element--cache-sync-keys-value' and the element key." - (or (when-let ((key-cons (org-element-property :org-element--cache-sync-key element))) + (or (when-let* ((key-cons (org-element-property :org-element--cache-sync-key element))) (when (eq org-element--cache-sync-keys-value (car key-cons)) (cdr key-cons))) (let* ((begin (org-element-begin element)) diff --git a/lisp/org/org-goto.el b/lisp/org/org-goto.el index cb74942a5e7..f75cc9ed85a 100644 --- a/lisp/org/org-goto.el +++ b/lisp/org/org-goto.el @@ -241,7 +241,7 @@ position or nil." (message "Select location and press RET") (use-local-map org-goto-map) (unwind-protect (recursive-edit) - (when-let ((window (get-buffer-window "*Org Help*" t))) + (when-let* ((window (get-buffer-window "*Org Help*" t))) (quit-window 'kill window))))) (when (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) (cons org-goto-selected-point org-goto-exit-command))) diff --git a/lisp/org/org-lint.el b/lisp/org/org-lint.el index 2d87ae270c4..0f96134587c 100644 --- a/lisp/org/org-lint.el +++ b/lisp/org/org-lint.el @@ -551,7 +551,7 @@ Use :header-args: instead" (defun org-lint-suspicious-language-in-src-block (ast) (org-element-map ast 'src-block (lambda (b) - (when-let ((lang (org-element-property :language b))) + (when-let* ((lang (org-element-property :language b))) (unless (or (functionp (intern (format "org-babel-execute:%s" lang))) ;; No babel backend, but there is corresponding ;; major mode. @@ -859,9 +859,9 @@ Use \"export %s\" instead" (when (member prop common-options) "global ") prop - (if-let ((backends - (and (not (member prop common-options)) - (cdr (assoc-string prop options-alist))))) + (if-let* ((backends + (and (not (member prop common-options)) + (cdr (assoc-string prop options-alist))))) (format " in %S export %s" (if (= 1 (length backends)) (car backends) backends) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index a6ff0e54512..4071b632fcb 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -573,7 +573,7 @@ is selected, only the bare key is returned." ((assoc current specials) (throw 'exit current)) (t (error "No entry available"))))))) (when buffer - (when-let ((window (get-buffer-window buffer t))) + (when-let* ((window (get-buffer-window buffer t))) (quit-window 'kill window)) (kill-buffer buffer)))))) diff --git a/lisp/org/org-persist.el b/lisp/org/org-persist.el index 7fa836d0d7a..cd66a0a57a8 100644 --- a/lisp/org/org-persist.el +++ b/lisp/org/org-persist.el @@ -810,8 +810,8 @@ COLLECTION is the plist holding data collection." (let ((scope (nth 2 container))) (pcase scope ((pred stringp) - (when-let ((buf (or (get-buffer scope) - (get-file-buffer scope)))) + (when-let* ((buf (or (get-buffer scope) + (get-file-buffer scope)))) ;; FIXME: There is `buffer-local-boundp' introduced in Emacs 28. ;; Not using it yet to keep backward compatibility. (condition-case nil @@ -821,8 +821,8 @@ COLLECTION is the plist holding data collection." (when (boundp (cadr container)) (symbol-value (cadr container)))) (`nil - (if-let ((buf (and (plist-get (plist-get collection :associated) :file) - (get-file-buffer (plist-get (plist-get collection :associated) :file))))) + (if-let* ((buf (and (plist-get (plist-get collection :associated) :file) + (get-file-buffer (plist-get (plist-get collection :associated) :file))))) ;; FIXME: There is `buffer-local-boundp' introduced in Emacs 28. ;; Not using it yet to keep backward compatibility. (condition-case nil diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 8a0943a48b9..222bc7d9658 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -3709,7 +3709,7 @@ With prefix ARG, apply the new formulas to the table." (org-table-store-formulas eql) (set-marker pos nil) (set-marker source nil) - (when-let ((window (get-buffer-window "*Edit Formulas*" t))) + (when-let* ((window (get-buffer-window "*Edit Formulas*" t))) (quit-window 'kill window)) (when (get-buffer "*Edit Formulas*") (kill-buffer "*Edit Formulas*")) (if arg diff --git a/lisp/org/org.el b/lisp/org/org.el index 5bee96fb0b5..4166738c162 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -13219,8 +13219,8 @@ However, if LITERAL-NIL is set, return the string value \"nil\" instead." ;; Consider global properties, if we found no PROPERTY (or maybe ;; only PROPERTY+). (unless found-inherited? - (when-let ((global (org--property-global-or-keyword-value - property t))) + (when-let* ((global (org--property-global-or-keyword-value + property t))) (setq values (cons global values)))) (when values (setq values (mapconcat diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 446698758c4..4eb3a511b00 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -1732,7 +1732,7 @@ targets and targets." (and (memq type '(radio-target target)) (org-element-property :value datum)) (org-element-property :name datum) - (when-let ((id (org-element-property :ID datum))) + (when-let* ((id (org-element-property :ID datum))) (concat org-html--id-attr-prefix id))))) (cond @@ -2052,7 +2052,7 @@ INFO is a plist used as a communication channel." (when value (pcase symbol (`font - (when-let + (when-let* ((value-new (pcase value ("TeX" "mathjax-tex") @@ -2697,7 +2697,7 @@ information." (let ((attributes (org-export-read-attribute :attr_html example-block))) (if (plist-get attributes :textarea) (org-html--textarea-block example-block) - (if-let ((class-val (plist-get attributes :class))) + (if-let* ((class-val (plist-get attributes :class))) (setq attributes (plist-put attributes :class (concat "example " class-val))) (setq attributes (plist-put attributes :class "example"))) (format "<pre%s>\n%s</pre>" diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el index 79df1fe119e..4d0935b073d 100644 --- a/lisp/org/ox-latex.el +++ b/lisp/org/ox-latex.el @@ -4097,7 +4097,7 @@ a communication channel." (unless (hash-table-p table-head-cache) (setq table-head-cache (make-hash-table :test #'eq)) (plist-put info :org-latex-table-head-cache table-head-cache)) - (if-let ((head-contents (gethash (org-element-parent table-row) table-head-cache))) + (if-let* ((head-contents (gethash (org-element-parent table-row) table-head-cache))) (puthash (org-element-parent table-row) (concat head-contents "\\\\\n" contents) table-head-cache) (puthash (org-element-parent table-row) contents table-head-cache)))) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 7cdf622ec44..fd8bfa1114a 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -2672,7 +2672,7 @@ from tree." (let ((type (org-element-type data))) (if (org-export--skip-p data info selected excluded) (if (memq type '(table-cell table-row)) (push data ignore) - (if-let ((keep-spaces (org-export--keep-spaces data info))) + (if-let* ((keep-spaces (org-export--keep-spaces data info))) ;; Keep spaces in place of removed ;; element, if necessary. ;; Example: "Foo.[10%] Bar" would become @@ -3456,7 +3456,7 @@ file." (with-temp-buffer (let ((org-inhibit-startup t) (lines - (if-let ((location (plist-get parameters :location))) + (if-let* ((location (plist-get parameters :location))) (org-export--inclusion-absolute-lines file location (plist-get parameters :only-contents) diff --git a/lisp/outline.el b/lisp/outline.el index 4d72b17e623..3a021a9d1e6 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1856,8 +1856,8 @@ With a prefix argument, show headings up to that LEVEL." (save-excursion (goto-char (point-min)) (while (not (or (eq top-level 1) (eobp))) - (when-let ((level (and (outline-on-heading-p t) - (funcall outline-level)))) + (when-let* ((level (and (outline-on-heading-p t) + (funcall outline-level)))) (when (< level (or top-level most-positive-fixnum)) (setq top-level (max level 1)))) (outline-next-heading))) diff --git a/lisp/pcmpl-git.el b/lisp/pcmpl-git.el index 95b6859dd23..c282e3eb4a8 100644 --- a/lisp/pcmpl-git.el +++ b/lisp/pcmpl-git.el @@ -39,10 +39,10 @@ (defun pcmpl-git--tracked-file-predicate (&rest args) "Return a predicate function determining the Git status of a file. Files listed by `git ls-files ARGS' satisfy the predicate." - (when-let ((files (mapcar #'expand-file-name - (ignore-errors - (apply #'process-lines - vc-git-program "ls-files" args))))) + (when-let* ((files (mapcar #'expand-file-name + (ignore-errors + (apply #'process-lines + vc-git-program "ls-files" args))))) (lambda (file) (setq file (expand-file-name file)) (if (string-suffix-p "/" file) diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el index 237e3d62526..2b48255f3f1 100644 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@ -354,7 +354,7 @@ Return the new list." (while (pcomplete-here '("-amin" "-anewer" "-atime" "-cmin" "-cnewer" "-context" "-ctime" "-daystart" "-delete" "-depth" "-empty" "-exec" - "-execdir" "-executable" "-false" "-fls" "-follow" + "-execdir" "-executable" "-false" "-files0-from" "-fls" "-follow" "-fprint" "-fprint0" "-fprintf" "-fstype" "-gid" "-group" "-help" "-ignore_readdir_race" "-ilname" "-iname" "-inum" "-ipath" "-iregex" "-iwholename" diff --git a/lisp/proced.el b/lisp/proced.el index f99a6f74909..da9212f6802 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -955,11 +955,11 @@ Proced buffers." "Auto-update Proced buffers using `run-at-time'. If there are no proced buffers, cancel the timer." - (if-let (buffers (match-buffers '(derived-mode . proced-mode))) + (if-let* ((buffers (match-buffers '(derived-mode . proced-mode)))) (dolist (buf buffers) - (when-let ((flag (buffer-local-value 'proced-auto-update-flag buf)) - ((or (not (eq flag 'visible)) - (get-buffer-window buf 'visible)))) + (when-let* ((flag (buffer-local-value 'proced-auto-update-flag buf)) + ((or (not (eq flag 'visible)) + (get-buffer-window buf 'visible)))) (with-current-buffer buf (proced-update t t)))) (cancel-timer proced-auto-update-timer) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 3bcfc213fc6..a2cb65f2c71 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -380,15 +380,15 @@ URL-REGEXP against the VCS URL and returns the value to be set as Test each configuration in `bug-reference-setup-from-vc-alist' and `bug-reference--setup-from-vc-alist' and apply it if applicable." - (when-let ((file-or-dir (or buffer-file-name - ;; Catches modes such as vc-dir and Magit. - default-directory)) - (backend (vc-responsible-backend file-or-dir t)) - (url (seq-some (lambda (remote) - (ignore-errors - (vc-call-backend backend 'repository-url - file-or-dir remote))) - '("upstream" nil)))) + (when-let* ((file-or-dir (or buffer-file-name + ;; Catches modes such as vc-dir and Magit. + default-directory)) + (backend (vc-responsible-backend file-or-dir t)) + (url (seq-some (lambda (remote) + (ignore-errors + (vc-call-backend backend 'repository-url + file-or-dir remote))) + '("upstream" nil)))) (seq-some (lambda (config) (apply #'bug-reference-maybe-setup-from-vc url config)) (append bug-reference-setup-from-vc-alist diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index f68a6dc108d..d05b5248cc2 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -128,8 +128,8 @@ ARG is passed to `fill-paragraph'." (looking-at "//")) ;; In rust, NODE will be the body of a comment, and the ;; parent will be the whole comment. - (if-let ((start (treesit-node-start - (treesit-node-parent node)))) + (if-let* ((start (treesit-node-start + (treesit-node-parent node)))) (save-excursion (goto-char start) (looking-at "//")))) @@ -331,55 +331,61 @@ and /* */ comments. SOFT works the same as in ;; is a // comment, insert a newline and a // prefix; if the current ;; line is in a /* comment, insert a newline and a * prefix. No ;; auto-fill or other smart features. - (cond - ;; Line starts with //, or ///, or ////... - ;; Or //! (used in rust). - ((save-excursion - (beginning-of-line) - (re-search-forward - (rx "//" (group (* (any "/!")) (* " "))) - (line-end-position) - t nil)) - (let ((offset (- (match-beginning 0) (line-beginning-position))) - (whitespaces (match-string 1))) - (if soft (insert-and-inherit ?\n) (newline 1)) - (delete-region (line-beginning-position) (point)) - (insert (make-string offset ?\s) "//" whitespaces))) - - ;; Line starts with /* or /**. - ((save-excursion - (beginning-of-line) - (re-search-forward - (rx "/*" (group (? "*") (* " "))) - (line-end-position) - t nil)) - (let ((offset (- (match-beginning 0) (line-beginning-position))) - (whitespace-and-star-len (length (match-string 1)))) - (if soft (insert-and-inherit ?\n) (newline 1)) - (delete-region (line-beginning-position) (point)) - (insert - (make-string offset ?\s) - " *" - (make-string whitespace-and-star-len ?\s)))) - - ;; Line starts with *. - ((save-excursion - (beginning-of-line) - (looking-at (rx (group (* " ") (any "*|") (* " "))))) - (let ((prefix (match-string 1))) - (if soft (insert-and-inherit ?\n) (newline 1)) - (delete-region (line-beginning-position) (point)) - (insert prefix))) - - ;; Line starts with whitespaces or no space. This is basically the - ;; default case since (rx (* " ")) matches anything. - ((save-excursion - (beginning-of-line) - (looking-at (rx (* " ")))) - (let ((whitespaces (match-string 0))) - (if soft (insert-and-inherit ?\n) (newline 1)) - (delete-region (line-beginning-position) (point)) - (insert whitespaces))))) + (let ((insert-line-break + (lambda () + (delete-horizontal-space) + (if soft + (insert-and-inherit ?\n) + (newline 1))))) + (cond + ;; Line starts with //, or ///, or ////... + ;; Or //! (used in rust). + ((save-excursion + (beginning-of-line) + (re-search-forward + (rx "//" (group (* (any "/!")) (* " "))) + (line-end-position) + t nil)) + (let ((offset (- (match-beginning 0) (line-beginning-position))) + (whitespaces (match-string 1))) + (funcall insert-line-break) + (delete-region (line-beginning-position) (point)) + (insert (make-string offset ?\s) "//" whitespaces))) + + ;; Line starts with /* or /**. + ((save-excursion + (beginning-of-line) + (re-search-forward + (rx "/*" (group (? "*") (* " "))) + (line-end-position) + t nil)) + (let ((offset (- (match-beginning 0) (line-beginning-position))) + (whitespace-and-star-len (length (match-string 1)))) + (funcall insert-line-break) + (delete-region (line-beginning-position) (point)) + (insert + (make-string offset ?\s) + " *" + (make-string whitespace-and-star-len ?\s)))) + + ;; Line starts with *. + ((save-excursion + (beginning-of-line) + (looking-at (rx (group (* " ") (any "*|") (* " "))))) + (let ((prefix (match-string 1))) + (funcall insert-line-break) + (delete-region (line-beginning-position) (point)) + (insert prefix))) + + ;; Line starts with whitespaces or no space. This is basically the + ;; default case since (rx (* " ")) matches anything. + ((save-excursion + (beginning-of-line) + (looking-at (rx (* " ")))) + (let ((whitespaces (match-string 0))) + (funcall insert-line-break) + (delete-region (line-beginning-position) (point)) + (insert whitespaces)))))) ;; Font locking using doxygen parser (defvar c-ts-mode-doxygen-comment-font-lock-settings diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 0c2da768833..3823c553fda 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -287,7 +287,7 @@ one step according to the great-grand-parent indent level. The reason there is a difference between grand-parent and great-grand-parent here is that the node containing the newline is actually the parent of point at the moment of indentation." - (when-let ((node (treesit-node-on (point) (point)))) + (when-let* ((node (treesit-node-on (point) (point)))) (if (string-equal "translation_unit" (treesit-node-type (treesit-node-parent @@ -315,12 +315,12 @@ doesn't have a child. PARENT is NODE's parent, BOL is the beginning of non-whitespace characters of the current line." - (when-let ((prev-sibling - (or (treesit-node-prev-sibling node t) - (treesit-node-prev-sibling - (treesit-node-first-child-for-pos parent bol) t) - (treesit-node-child parent -1 t))) - (continue t)) + (when-let* ((prev-sibling + (or (treesit-node-prev-sibling node t) + (treesit-node-prev-sibling + (treesit-node-first-child-for-pos parent bol) t) + (treesit-node-child parent -1 t))) + (continue t)) (save-excursion (while (and prev-sibling continue) (pcase (treesit-node-type prev-sibling) @@ -1103,8 +1103,8 @@ is required, not just the declaration part for DEFUN." `treesit-defun-type-regexp' defines what constructs to indent." (interactive "*") - (when-let ((orig-point (point-marker)) - (range (c-ts-mode--emacs-defun-at-point t))) + (when-let* ((orig-point (point-marker)) + (range (c-ts-mode--emacs-defun-at-point t))) (indent-region (car range) (cdr range)) (goto-char orig-point))) @@ -1488,9 +1488,9 @@ recommended to enable `electric-pair-mode' with this mode." :help "Toggle C/C++ comment style between block and line comments"]) "--" ("Toggle..." - ["SubWord Mode" subword-mode + ["Subword Mode" subword-mode :style toggle :selected subword-mode - :help "Toggle sub-word movement and editing mode"]))) + :help "Toggle subword movement and editing mode"]))) ;; We could alternatively use parsers, but if this works well, I don't ;; see the need to change. This is copied verbatim from cc-guess.el. diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 0f086f8e812..83afe081b85 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -556,34 +556,23 @@ stuff. Used on level 1 and higher." ;; Fontify filenames in #include <...> as strings. ,@(when (c-lang-const c-cpp-include-directives) - (let* ((re (c-make-keywords-re nil - (c-lang-const c-cpp-include-directives))) - (re-depth (regexp-opt-depth re))) - ;; We used to use a font-lock "anchored matcher" here for - ;; the paren syntax. This failed when the ">" was at EOL, - ;; since `font-lock-fontify-anchored-keywords' terminated - ;; its loop at EOL without executing our lambda form at - ;; all. - `((,(c-make-font-lock-search-function - (concat noncontinued-line-end - (c-lang-const c-opt-cpp-prefix) - re - (c-lang-const c-syntactic-ws) - "\\(<\\([^>\n\r]*\\)>?\\)") - `(,(+ ncle-depth re-depth sws-depth - (if (featurep 'xemacs) 2 1) - ) - font-lock-string-face t) - `((let ((beg (match-beginning - ,(+ ncle-depth re-depth sws-depth 1))) - (end (1- (match-end ,(+ ncle-depth re-depth - sws-depth 1))))) - (if (eq (char-after end) ?>) - (progn - (c-mark-<-as-paren beg) - (c-mark->-as-paren end)) - (c-unmark-<->-as-paren beg))) - nil)))))) + ;; We used to use a font-lock "anchored matcher" here for + ;; the paren syntax. This failed when the ">" was at EOL, + ;; since `font-lock-fontify-anchored-keywords' terminated + ;; its loop at EOL without executing our lambda form at all. + ;; (2024-10): The paren syntax is now handled in + ;; before/after-change functions. + `((,(concat noncontinued-line-end + "\\(" ; To make the next ^ special. + (c-lang-const c-cpp-include-key) + "\\)" + (c-lang-const c-syntactic-ws) + "\\(<\\([^>\n\r]*\\)>?\\)") + ,(+ ncle-depth 1 + (regexp-opt-depth (c-lang-const c-cpp-include-key)) + sws-depth + (if (featurep 'xemacs) 2 1)) + font-lock-string-face t))) ;; #define. ,@(when (c-lang-const c-opt-cpp-macro-define) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 010b0ed6b04..a256371f850 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -451,7 +451,8 @@ so that all identifiers are recognized as words.") (c-lang-defconst c-get-state-before-change-functions ;; For documentation see the following c-lang-defvar of the same name. ;; The value here may be a list of functions or a single function. - t 'c-before-change-check-unbalanced-strings + t '(c-before-change-include-<> + c-before-change-check-unbalanced-strings) c++ '(c-extend-region-for-CPP c-depropertize-CPP c-before-change-check-ml-strings @@ -463,6 +464,7 @@ so that all identifiers are recognized as words.") c-parse-quotes-before-change c-before-change-fix-comment-escapes) c '(c-extend-region-for-CPP + c-before-change-include-<> c-depropertize-CPP c-truncate-bs-cache c-before-change-check-unbalanced-strings @@ -480,7 +482,8 @@ so that all identifiers are recognized as words.") c-unmark-<>-around-region c-before-change-check-unbalanced-strings c-before-change-check-<>-operators) - pike '(c-before-change-check-ml-strings + pike '(c-before-change-include-<> + c-before-change-check-ml-strings c-before-change-check-unbalanced-strings) awk 'c-awk-record-region-clear-NL) (c-lang-defvar c-get-state-before-change-functions @@ -511,6 +514,7 @@ parameters \(point-min) and \(point-max).") t '(c-depropertize-new-text c-after-change-escape-NL-in-string c-after-change-mark-abnormal-strings + c-after-change-include-<> c-change-expand-fl-region) c '(c-depropertize-new-text c-after-change-fix-comment-escapes @@ -518,6 +522,7 @@ parameters \(point-min) and \(point-max).") c-parse-quotes-after-change c-after-change-mark-abnormal-strings c-extend-font-lock-region-for-macros + c-after-change-include-<> c-neutralize-syntax-in-CPP c-change-expand-fl-region) objc '(c-depropertize-new-text @@ -553,6 +558,7 @@ parameters \(point-min) and \(point-max).") c-after-change-escape-NL-in-string c-after-change-unmark-ml-strings c-after-change-mark-abnormal-strings + c-after-change-include-<> c-change-expand-fl-region) awk '(c-depropertize-new-text c-awk-extend-and-syntax-tablify-region)) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 71fafeca59f..c5bb075c7f6 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -186,8 +186,7 @@ (with-current-buffer b c-buffer-is-cc-mode)) (throw 'found nil))) - (remove-hook 'post-command-hook 'c-post-command) - (remove-hook 'post-gc-hook 'c-post-gc-hook))) + (remove-hook 'post-command-hook 'c-post-command t))) (c-save-buffer-state () (c-clear-char-properties (point-min) (point-max) 'category) (c-clear-char-properties (point-min) (point-max) 'syntax-table) @@ -761,7 +760,7 @@ that requires a literal mode spec at compile time." ;; would do since font-lock uses a(n implicit) depth of 0) so we don't need ;; c-after-font-lock-init. (add-hook 'after-change-functions 'c-after-change nil t) - (add-hook 'post-command-hook 'c-post-command) + (add-hook 'post-command-hook 'c-post-command nil t) (when (boundp 'font-lock-extend-after-change-region-function) (set (make-local-variable 'font-lock-extend-after-change-region-function) @@ -2009,6 +2008,70 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (defvar c-new-id-is-type nil) (make-variable-buffer-local 'c-new-id-is-type) +(defun c-before-change-include-<> (beg end) + "Remove category/syntax-table properties from each #include <..>. +In particular, from the < and > characters which have been marked as parens +using these properties. This is done on every such #include <..> with a +portion between BEG and END. + +This function is used solely as a member of +`c-get-state-before-change-functions' where it should appear early, before +`c-depropertize-CPP'. It should be used only together with +`c-after-change-include-<>'." + (c-save-buffer-state ((search-end (progn (goto-char end) + (c-end-of-macro) + (point))) + hash-pos) + (goto-char beg) + (c-beginning-of-macro) + (while (and (< (point) search-end) + (search-forward-regexp c-cpp-include-key search-end 'bound) + (setq hash-pos (match-beginning 0))) + (save-restriction + (narrow-to-region (point-min) (c-point 'eoll)) + (c-forward-comments)) + (when (and (< (point) search-end) + (looking-at "\\s(") + (looking-at "\\(<\\)[^>\n\r]*\\(>\\)?") + (not (cdr (c-semi-pp-to-literal hash-pos)))) + (c-unmark-<->-as-paren (match-beginning 1)) + (when (< hash-pos c-new-BEG) + (setq c-new-BEG hash-pos)) + (when (match-beginning 2) + (c-unmark-<->-as-paren (match-beginning 2)) + (when (> (match-end 2) c-new-END) + (setq c-new-END (match-end 2)))))))) + +(defun c-after-change-include-<> (beg end _old-len) + "Apply category/syntax-table properties to each #include <..>. +In particular, to the < and > characters to mark them as matching parens +using these properties. This is done on every such #include <..> with a +portion between BEG and END. + +This function is used solely as a member of +`c-before-font-lock-functions' where is should appear late, but before +`c-neutralize-syntax-in-CPP'. It should be used only together with +`c-before-change-include-<>'." + (c-save-buffer-state ((search-end (progn (goto-char end) + (c-end-of-macro) + (point))) + hash-pos) + (goto-char beg) + (c-beginning-of-macro) + (while (and (< (point) search-end) + (search-forward-regexp c-cpp-include-key search-end 'bound) + (setq hash-pos (match-beginning 0))) + (save-restriction + (narrow-to-region (point-min) (c-point 'eoll)) + (c-forward-comments)) + (when (and (< (point) search-end) + (looking-at "\\(<\\)[^>\n\r]*\\(>\\)") + (not (cdr (c-semi-pp-to-literal (match-beginning 0))))) + (c-mark-<-as-paren (match-beginning 1)) + (when (< hash-pos c-new-BEG) (setq c-new-BEG hash-pos)) + (c-mark->-as-paren (match-beginning 2)) + (when (> (match-end 2) c-new-END) (setq c-new-END (match-end 2))))))) + (defun c-before-change-fix-comment-escapes (beg end) "Remove punctuation syntax-table text properties from C/C++ comment markers. This is to handle the rare case of two or more backslashes at an diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 03e6ee4021b..2b9d355795e 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1405,12 +1405,12 @@ POS and RES.") 2))) ;; Remove matches like /bin/sh and do other file name transforms. (save-match-data - (when-let ((file-name - (and (consp file) - (not (bufferp (car file))) - (if (cdr file) - (expand-file-name (car file) (cdr file)) - (car file))))) + (when-let* ((file-name + (and (consp file) + (not (bufferp (car file))) + (if (cdr file) + (expand-file-name (car file) (cdr file)) + (car file))))) (cl-loop for (regexp replacement) in compilation-transform-file-match-alist when (string-match regexp file-name) @@ -3231,7 +3231,7 @@ we try to avoid if possible." (with-current-buffer (marker-buffer marker) (save-excursion (goto-char (marker-position marker)) - (when-let ((prev (compilation--previous-directory (point)))) + (when-let* ((prev (compilation--previous-directory (point)))) (goto-char prev)) (setq dirs (cdr (or (get-text-property (1- (point)) 'compilation-directory) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 0a1f9ee4481..e5c27de81fc 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -710,14 +710,14 @@ compile time if an undeclared LSP interface is used.")) (cl-destructuring-bind (&key types required-keys optional-keys &allow-other-keys) (eglot--interface interface-name) - (when-let ((missing (and enforce-required - (cl-set-difference required-keys - (eglot--plist-keys object))))) + (when-let* ((missing (and enforce-required + (cl-set-difference required-keys + (eglot--plist-keys object))))) (eglot--error "A `%s' must have %s" interface-name missing)) - (when-let ((excess (and disallow-non-standard - (cl-set-difference - (eglot--plist-keys object) - (append required-keys optional-keys))))) + (when-let* ((excess (and disallow-non-standard + (cl-set-difference + (eglot--plist-keys object) + (append required-keys optional-keys))))) (eglot--error "A `%s' mustn't have %s" interface-name excess)) (when check-types (cl-loop @@ -1914,7 +1914,7 @@ and just return it. PROMPT shouldn't end with a question mark." (cond ((null servers) (eglot--error "No servers!")) ((or (cdr servers) (not dont-if-just-the-one)) - (let* ((default (when-let ((current (eglot-current-server))) + (let* ((default (when-let* ((current (eglot-current-server))) (funcall name current))) (read (completing-read (if default @@ -2164,7 +2164,7 @@ If it is activated, also signal textDocument/didOpen." (with-no-warnings (require 'package) (unless package-archive-contents (package-refresh-contents)) - (when-let ((existing (cadr (assoc 'eglot package-alist)))) + (when-let* ((existing (cadr (assoc 'eglot package-alist)))) (package-delete existing t)) (package-install (cadr (assoc 'eglot package-archive-contents))))) @@ -2457,10 +2457,10 @@ expensive cached value of `file-truename'.") (current-buffer) beg end (eglot--diag-type severity) message `((eglot-lsp-diag . ,diag-spec)) - (when-let ((faces - (cl-loop for tag across tags - when (alist-get tag eglot--tag-faces) - collect it))) + (when-let* ((faces + (cl-loop for tag across tags + when (alist-get tag eglot--tag-faces) + collect it))) `((face . ,faces)))))) into diags finally (cond ((and @@ -2619,12 +2619,12 @@ buffer." (append (eglot--TextDocumentPositionParams) `(:context - ,(if-let (trigger (and (characterp eglot--last-inserted-char) - (cl-find eglot--last-inserted-char - (eglot-server-capable :completionProvider - :triggerCharacters) - :key (lambda (str) (aref str 0)) - :test #'char-equal))) + ,(if-let* ((trigger (and (characterp eglot--last-inserted-char) + (cl-find eglot--last-inserted-char + (eglot-server-capable :completionProvider + :triggerCharacters) + :key (lambda (str) (aref str 0)) + :test #'char-equal)))) `(:triggerKind 2 :triggerCharacter ,trigger) `(:triggerKind 1))))) (defvar-local eglot--recent-changes nil @@ -3167,7 +3167,7 @@ for which LSP on-type-formatting should be requested." (defun eglot-completion-at-point () "Eglot's `completion-at-point' function." ;; Commit logs for this function help understand what's going on. - (when-let (completion-capability (eglot-server-capable :completionProvider)) + (when-let* ((completion-capability (eglot-server-capable :completionProvider))) (let* ((server (eglot--current-server-or-lose)) (bounds (or (bounds-of-thing-at-point 'symbol) (cons (point) (point)))) @@ -3296,7 +3296,7 @@ for which LSP on-type-formatting should be requested." (_ (intern (downcase kind)))))) :company-deprecated (lambda (proxy) - (when-let ((lsp-item (get-text-property 0 'eglot--lsp-item proxy))) + (when-let* ((lsp-item (get-text-property 0 'eglot--lsp-item proxy))) (or (seq-contains-p (plist-get lsp-item :tags) 1) (eq t (plist-get lsp-item :deprecated))))) @@ -3390,7 +3390,7 @@ for which LSP on-type-formatting should be requested." (with-temp-buffer (insert siglabel) ;; Add documentation, indented so we can distinguish multiple signatures - (when-let (doc (and (not briefp) sigdoc (eglot--format-markup sigdoc))) + (when-let* ((doc (and (not briefp) sigdoc (eglot--format-markup sigdoc)))) (goto-char (point-max)) (insert "\n" (replace-regexp-in-string "^" " " doc))) ;; Try to highlight function name only @@ -3850,12 +3850,12 @@ at point. With prefix argument, prompt for ACTION-KIND." (handle-event `(,desc 'deleted ,file)) (handle-event `(,desc 'created ,file1)))))) (watch-dir (dir) - (when-let ((probe - (and (file-readable-p dir) - (or (gethash dir (eglot--file-watches server)) - (puthash dir (list (file-notify-add-watch - dir '(change) #'handle-event)) - (eglot--file-watches server)))))) + (when-let* ((probe + (and (file-readable-p dir) + (or (gethash dir (eglot--file-watches server)) + (puthash dir (list (file-notify-add-watch + dir '(change) #'handle-event)) + (eglot--file-watches server)))))) (push id (cdr probe))))) (unwind-protect (progn diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 2f931daedc7..2b6d9d2b8bb 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -246,7 +246,7 @@ Use `emacs-lisp-byte-compile-and-load' in combination with `native-comp-jit-compilation' set to t to achieve asynchronous native compilation of the current buffer's file." (interactive nil emacs-lisp-mode) - (when-let ((byte-file (emacs-lisp-native-compile))) + (when-let* ((byte-file (emacs-lisp-native-compile))) (load (file-name-sans-extension byte-file)))) (defun emacs-lisp-macroexpand () @@ -789,7 +789,7 @@ functions are annotated with \"<f>\" via the (goto-char (1- beg)) (when (eq parent ?\() (up-list -1)) - (forward-symbol -1) + (skip-syntax-backward " w_") (or (looking-at "\\_<\\(let\\*?\\|bind\\*\\)\\_>") @@ -1851,7 +1851,7 @@ Also see `elisp-eldoc-var-docstring-with-value'." Intended for `eldoc-documentation-functions' (which see). Compared to `elisp-eldoc-var-docstring', this also includes the current variable value and a bigger chunk of the docstring." - (when-let ((cs (elisp--current-symbol))) + (when-let* ((cs (elisp--current-symbol))) (when (and (boundp cs) ;; nil and t are boundp! (not (null cs)) diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el index 0cb77b30a75..41904e8bd0d 100644 --- a/lisp/progmodes/erts-mode.el +++ b/lisp/progmodes/erts-mode.el @@ -209,8 +209,8 @@ expected results and the actual results in a separate buffer." (re-search-backward "^=-=\n" nil t) (let ((potential-start (match-end 0))) ;; See if we're in a two-clause ("before" and "after") test or not. - (if-let ((start (and (save-excursion (re-search-backward "^=-=\n" nil t)) - (match-end 0)))) + (if-let* ((start (and (save-excursion (re-search-backward "^=-=\n" nil t)) + (match-end 0)))) (let ((end (save-excursion (re-search-backward "^=-=-=\n" nil t)))) (if (or (not end) (> start end)) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 35dc0215046..ca69817953e 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -1915,7 +1915,7 @@ If no file is associated with the current buffer, this function returns nil." (defun list-tags (file &optional _next-match) "Display list of tags in file FILE. Interactively, prompt for FILE, with completion, offering the current -buffer's file name as the defaul. +buffer's file name as the default. This command searches only the first table in the list of tags tables, and does not search included tables. FILE should be as it was submitted to the `etags' command, which usually diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 9a6b62ca254..3dee1a58e44 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -845,7 +845,7 @@ Return to original margin width if ORIG-WIDTH is non-nil." (widen) (dolist (o (overlays-in (point-min) (point-max))) (when (overlay-get o 'flymake--eol-overlay) - (if-let ((src-ovs (overlay-get o 'flymake-eol-source-overlays))) + (if-let* ((src-ovs (overlay-get o 'flymake-eol-source-overlays))) (overlay-put o 'before-string (flymake--eol-overlay-summary src-ovs)) (delete-overlay o)))))) @@ -1533,7 +1533,7 @@ START and STOP and LEN are as in `after-change-functions'." (defun flymake-eldoc-function (report-doc &rest _) "Document diagnostics at point. Intended for `eldoc-documentation-functions' (which see)." - (when-let ((diags (flymake-diagnostics (point)))) + (when-let* ((diags (flymake-diagnostics (point)))) (funcall report-doc (mapconcat #'flymake-diagnostic-text diags "\n") :echo (mapconcat #'flymake-diagnostic-oneliner diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 6a9735fbc25..b60e21ff0ae 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -3242,7 +3242,7 @@ See `def-gdb-auto-update-handler'." ;; Add the breakpoint/header row to the table. (gdb-breakpoints--add-breakpoint-row table breakpoint) ;; If this breakpoint has multiple locations, add them as well. - (when-let ((locations (gdb-mi--field breakpoint 'locations))) + (when-let* ((locations (gdb-mi--field breakpoint 'locations))) (dolist (loc locations) (add-to-list 'gdb-breakpoints-list (cons (gdb-mi--field loc 'number) loc)) @@ -4830,7 +4830,7 @@ overlay arrow in source buffer." (when frame (setq gdb-selected-frame (gdb-mi--field frame 'func)) (setq gdb-selected-file - (when-let ((full (gdb-mi--field frame 'fullname))) + (when-let* ((full (gdb-mi--field frame 'fullname))) (file-local-name full))) (setq gdb-frame-number (gdb-mi--field frame 'level)) (setq gdb-frame-address (gdb-mi--field frame 'addr)) diff --git a/lisp/progmodes/go-ts-mode.el b/lisp/progmodes/go-ts-mode.el index 6fa8049e5e7..86e74ad58a8 100644 --- a/lisp/progmodes/go-ts-mode.el +++ b/lisp/progmodes/go-ts-mode.el @@ -363,7 +363,7 @@ Methods are prefixed with the receiver name, unless SKIP-PREFIX is t." The added docstring is prefilled with the defun's name. If the comment already exists, jump to it." (interactive) - (when-let ((defun-node (treesit-defun-at-point))) + (when-let* ((defun-node (treesit-defun-at-point))) (goto-char (treesit-node-start defun-node)) (if (go-ts-mode--comment-on-previous-line-p) ;; go to top comment line @@ -375,9 +375,9 @@ comment already exists, jump to it." (defun go-ts-mode--comment-on-previous-line-p () "Return t if the previous line is a comment." - (when-let ((point (- (pos-bol) 1)) - ((> point 0)) - (node (treesit-node-at point))) + (when-let* ((point (- (pos-bol) 1)) + ((> point 0)) + (node (treesit-node-at point))) (and ;; check point is actually inside the found node ;; treesit-node-at can return nodes after point @@ -432,10 +432,10 @@ specifying build tags." "Return a regular expression for the tests at point. If region is active, the regexp will include all the functions under the region." - (if-let ((range (if (region-active-p) - (list (region-beginning) (region-end)) - (list (point) (point)))) - (funcs (apply #'go-ts-mode--get-functions-in-range range))) + (if-let* ((range (if (region-active-p) + (list (region-beginning) (region-end)) + (list (point) (point)))) + (funcs (apply #'go-ts-mode--get-functions-in-range range))) (string-join funcs "|") (error "No test function found"))) @@ -450,7 +450,7 @@ be run." (defun go-ts-mode-test-this-file () "Run all the unit tests in the current file." (interactive) - (if-let ((defuns (go-ts-mode--get-functions-in-range (point-min) (point-max)))) + (if-let* ((defuns (go-ts-mode--get-functions-in-range (point-min) (point-max)))) (go-ts-mode--compile-test (string-join defuns "|")) (error "No test functions found in the current file"))) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index b453ac60ed2..ed8d6e9e0d9 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -1357,7 +1357,7 @@ command before it's run." regexp files nil - (when-let ((ignores (grep-find-ignored-files dir))) + (when-let* ((ignores (grep-find-ignored-files dir))) (concat " --exclude=" (mapconcat (lambda (ignore) @@ -1474,7 +1474,7 @@ to indicate whether the grep should be case sensitive or not." "Compute the command for \\[rgrep] to use by default." (require 'find-dired) ; for `find-name-arg' (let ((ignored-files-arg - (when-let ((ignored-files (grep-find-ignored-files dir))) + (when-let* ((ignored-files (grep-find-ignored-files dir))) (concat (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here " -name " @@ -1498,7 +1498,7 @@ to indicate whether the grep should be case sensitive or not." (concat " " (shell-quote-argument "!" grep-quoting-style) " " ignored-files-arg))) dir (concat - (when-let ((ignored-dirs (rgrep-find-ignored-directories dir))) + (when-let* ((ignored-dirs (rgrep-find-ignored-directories dir))) (concat "-type d " (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here @@ -1578,8 +1578,8 @@ command before it's run." (defun grep-file-at-point (point) "Return the name of the file at POINT a `grep-mode' buffer. The returned file name is relative." - (when-let ((msg (get-text-property point 'compilation-message)) - (loc (compilation--message->loc msg))) + (when-let* ((msg (get-text-property point 'compilation-message)) + (loc (compilation--message->loc msg))) (caar (compilation--loc->file-struct loc)))) ;;;###autoload diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 9bcac0d8dc5..27a02e9805f 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -400,7 +400,7 @@ If there is a marked region from START to END it only shows the symbols within." (end-of-line 2))) (defun hif-merge-ifdef-region (start end) - "This function merges nearby ifdef regions to form a bigger overlay. + "Merge nearby ifdef regions to form a bigger overlay. The region is defined by START and END. This will decrease the number of overlays created." ;; Generally there is no need to call itself recursively since there should diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el index 20bc1f3e158..f88fe0e49af 100644 --- a/lisp/progmodes/lua-ts-mode.el +++ b/lisp/progmodes/lua-ts-mode.el @@ -72,7 +72,7 @@ (defcustom lua-ts-luacheck-program "luacheck" "Location of the Luacheck program." - :type '(choice (const :tag "None" nil) string) + :type 'file :version "30.1") (defcustom lua-ts-inferior-buffer "*Lua*" @@ -83,7 +83,7 @@ (defcustom lua-ts-inferior-program "lua" "Program to run in the inferior Lua process." - :type '(choice (const :tag "None" nil) string) + :type 'file :version "30.1") (defcustom lua-ts-inferior-options '("-i") @@ -289,7 +289,8 @@ values of OVERRIDE." (defvar lua-ts--simple-indent-rules `((lua - ((or (node-is "comment") + ((or (and (node-is "comment") (parent-is "chunk")) + lua-ts--multi-line-comment-start (parent-is "comment_content") (parent-is "string_content") (node-is "]]")) @@ -473,9 +474,10 @@ values of OVERRIDE." (= 1 (length (cadr sparse-tree))))) (defun lua-ts--comment-first-sibling-matcher (node &rest _) - "Matches if NODE if it's previous sibling is a comment." + "Matches NODE if its previous sibling is a comment." (let ((sibling (treesit-node-prev-sibling node))) - (equal "comment" (treesit-node-type sibling)))) + (and (= 0 (treesit-node-index sibling t)) + (equal "comment" (treesit-node-type sibling))))) (defun lua-ts--top-level-function-call-matcher (node &rest _) "Matches if NODE is within a top-level function call." @@ -508,6 +510,15 @@ values of OVERRIDE." (line-beginning-position)) (point)))) +(defun lua-ts--multi-line-comment-start (node &rest _) + "Matches if NODE is the beginning of a multi-line comment." + (and node + (equal "comment" (treesit-node-type node)) + (save-excursion + (goto-char (treesit-node-start node)) + (forward-char 2) ; Skip the -- part. + (looking-at "\\[\\[")))) + (defvar lua-ts--syntax-table (let ((table (make-syntax-table))) (modify-syntax-entry ?+ "." table) @@ -632,47 +643,49 @@ Calls REPORT-FN directly." (defun lua-ts-inferior-lua () "Run a Lua interpreter in an inferior process." (interactive) - (unless (comint-check-proc lua-ts-inferior-buffer) - (apply #'make-comint-in-buffer - (string-replace "*" "" lua-ts-inferior-buffer) - lua-ts-inferior-buffer - lua-ts-inferior-program - lua-ts-inferior-startfile - lua-ts-inferior-options) - (when lua-ts-inferior-history + (if (not lua-ts-inferior-program) + (user-error "You must set `lua-ts-inferior-program' to use this command") + (unless (comint-check-proc lua-ts-inferior-buffer) + (apply #'make-comint-in-buffer + (string-replace "*" "" lua-ts-inferior-buffer) + lua-ts-inferior-buffer + lua-ts-inferior-program + lua-ts-inferior-startfile + lua-ts-inferior-options) + (when lua-ts-inferior-history (set-process-sentinel (get-buffer-process lua-ts-inferior-buffer) 'lua-ts-inferior--write-history)) - (with-current-buffer lua-ts-inferior-buffer - (setq-local comint-input-ignoredups t - comint-input-ring-file-name lua-ts-inferior-history - comint-prompt-read-only t - comint-prompt-regexp (rx-to-string `(: bol - ,lua-ts-inferior-prompt - (1+ space)))) - (comint-read-input-ring t) - (add-hook 'comint-preoutput-filter-functions - (lambda (string) - (if (equal string (concat lua-ts-inferior-prompt-continue " ")) - string - (concat - ;; Filter out the extra prompt characters that - ;; accumulate in the output when sending regions - ;; to the inferior process. - (replace-regexp-in-string (rx-to-string - `(: bol - (* ,lua-ts-inferior-prompt - (? ,lua-ts-inferior-prompt) - (1+ space)) - (group (* nonl)))) - "\\1" string) - ;; Re-add the prompt for the next line. - lua-ts-inferior-prompt " "))) - nil t))) - (select-window (display-buffer lua-ts-inferior-buffer - '((display-buffer-reuse-window - display-buffer-pop-up-window) - (reusable-frames . t)))) - (get-buffer-process (current-buffer))) + (with-current-buffer lua-ts-inferior-buffer + (setq-local comint-input-ignoredups t + comint-input-ring-file-name lua-ts-inferior-history + comint-prompt-read-only t + comint-prompt-regexp (rx-to-string `(: bol + ,lua-ts-inferior-prompt + (1+ space)))) + (comint-read-input-ring t) + (add-hook 'comint-preoutput-filter-functions + (lambda (string) + (if (equal string (concat lua-ts-inferior-prompt-continue " ")) + string + (concat + ;; Filter out the extra prompt characters that + ;; accumulate in the output when sending regions + ;; to the inferior process. + (replace-regexp-in-string + (rx-to-string `(: bol + (* ,lua-ts-inferior-prompt + (? ,lua-ts-inferior-prompt) + (1+ space)) + (group (* nonl)))) + "\\1" string) + ;; Re-add the prompt for the next line. + lua-ts-inferior-prompt " "))) + nil t))) + (select-window (display-buffer lua-ts-inferior-buffer + '((display-buffer-reuse-window + display-buffer-pop-up-window) + (reusable-frames . t)))) + (get-buffer-process (current-buffer)))) (defun lua-ts-send-buffer () "Send current buffer to the inferior Lua process." diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 60b87142850..5441903738d 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -704,7 +704,7 @@ The function must satisfy this calling convention: ;; Each "ARG" is used as a prompt for a required argument. (defconst makefile-gnumake-functions-alist '( - ;; Text functions + ;; Functions for String Substitution and Analysis ("subst" "From" "To" "In") ("patsubst" "Pattern" "Replacement" "In") ("strip" "Text") @@ -712,22 +712,42 @@ The function must satisfy this calling convention: ("filter" "Pattern" "Text") ("filter-out" "Pattern" "Text") ("sort" "List") - ;; Filename functions + ("word" "Index" "Text") + ("wordlist" "S" "E" "Text") + ("words" "Text") + ("firstword" "Text") + ("lastword" "Names") + ;; Functions for File Names ("dir" "Names") ("notdir" "Names") ("suffix" "Names") ("basename" "Names") - ("addprefix" "Prefix" "Names") ("addsuffix" "Suffix" "Names") + ("addprefix" "Prefix" "Names") ("join" "List 1" "List 2") - ("word" "Index" "Text") - ("words" "Text") - ("firstword" "Text") ("wildcard" "Pattern") + ("realpath" "Names") + ("abspath" "Names") + ;; Functions for Conditionals + ("if" "Condition" "Then-part" "Else-part") + ("or" "Condition 1" "Condition 2" "Condition 3" "Condition 4") + ("and" "Condition 1" "Condition 2" "Condition 3" "Condition 4") ;; Misc functions ("foreach" "Variable" "List" "Text") + ("file" "Op" "Filename" "Text") + ("call" "Variable" "Param 1" "Param 2" "Param 3" "Param 4" "Param 5") + ("value" "Variable") + ("eval" "statement") ("origin" "Variable") - ("shell" "Command"))) + ("flavor" "Variable") + ("shell" "Command") + ("guile" "Program") + ;; Functions that control make + ("error" "Text") + ("warning" "Text") + ("info" "Text") + ) + "Alist of GNU Make functions and their arguments.") ;;; ------------------------------------------------------------ diff --git a/lisp/progmodes/peg.el b/lisp/progmodes/peg.el index 96334162195..115f692a030 100644 --- a/lisp/progmodes/peg.el +++ b/lisp/progmodes/peg.el @@ -412,6 +412,7 @@ sequencing `and' operator of PEG grammars." (full-rname (format "%s %s" name rname))) (push `(define-peg-rule ,full-rname . ,(cdr rule)) defs) (push `(,(peg--rule-id rname) #',(peg--rule-id full-rname)) aliases))) + (require 'cl-lib) `(cl-flet ,aliases ,@defs (eval-and-compile (put ',name 'peg--rules ',aliases))))) @@ -432,18 +433,27 @@ rulesets defined previously with `define-peg-ruleset'." (progn (push rule rulesets) nil) (cons (car rule) (peg-normalize `(and . ,(cdr rule)))))) rules))) - (ctx (assq :peg-rules macroexpand-all-environment))) + (ctx (assq :peg-rules macroexpand-all-environment)) + (body (macroexpand-all `(cl-labels ,(mapcar (lambda (rule) - ;; FIXME: Use `peg--lambda' as well. `(,(peg--rule-id (car rule)) - () - ,(peg--translate-rule-body (car rule) (cdr rule)))) + (peg--lambda ',(cdr rule) () + ,(peg--translate-rule-body (car rule) (cdr rule))))) rules) ,@body) `((:peg-rules ,@(append rules (cdr ctx))) ,@macroexpand-all-environment)))) + (if (null rulesets) + body + `(cl-flet ,(mapcan (lambda (ruleset) + (let ((aliases (get ruleset 'peg--rules))) + (unless aliases + (message "Unknown PEG ruleset: %S" ruleset)) + (copy-sequence aliases))) + rulesets) + ,body)))) ;;;;; Old entry points @@ -645,7 +655,7 @@ rulesets defined previously with `define-peg-ruleset'." (code (peg-translate-exp exp))) (cond ((null msg) code) - (t (macroexp-warn-and-return msg code))))) + (t (macroexp-warn-and-return msg code 'peg nil exp))))) ;; This is the main translation function. (defun peg-translate-exp (exp) diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 13d5d7f9451..3c32fac3f42 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -963,8 +963,8 @@ changed by, or (parse-state) if line starts in a quoted string." (save-excursion (skip-chars-backward " \t\n") (beginning-of-line) - (when-let ((comm (and (looking-at "^\\.$") - (nth 8 (syntax-ppss))))) + (when-let* ((comm (and (looking-at "^\\.$") + (nth 8 (syntax-ppss))))) (goto-char comm) (beginning-of-line) (looking-at perl--format-regexp)))) diff --git a/lisp/progmodes/php-ts-mode.el b/lisp/progmodes/php-ts-mode.el index 2a8f3455402..b0271c4ea6a 100644 --- a/lisp/progmodes/php-ts-mode.el +++ b/lisp/progmodes/php-ts-mode.el @@ -84,7 +84,7 @@ ;;; Install treesitter language parsers (defvar php-ts-mode--language-source-alist - '((php . ("https://github.com/tree-sitter/tree-sitter-php" "v0.23.0" "php/src")) + '((php . ("https://github.com/tree-sitter/tree-sitter-php" "v0.23.5" "php/src")) (phpdoc . ("https://github.com/claytonrcarter/tree-sitter-phpdoc")) (html . ("https://github.com/tree-sitter/tree-sitter-html" "v0.23.0")) (javascript . ("https://github.com/tree-sitter/tree-sitter-javascript" "v0.23.0")) @@ -428,6 +428,27 @@ Useful for debugging." ;;; Indent +(defconst php-ts-mode--possibly-braceless-keyword-re + (regexp-opt '("if" "for" "foreach" "while" "do") 'symbols) + "Regexp matching keywords optionally followed by an opening brace.") + +(defun php-ts-mode--open-statement-group-heuristic (node _parent bol &rest _) + "Heuristic matcher for statement-group without closing bracket. + +Return `php-ts-mode-indent-offset' plus 1 when BOL is after +`php-ts-mode--possibly-braceless-keyword-re', otherwise return 0. It's +useful for matching incomplete compound_statement or colon_block. +PARENT is NODE's parent, BOL is the beginning of non-whitespace +characters of the current line." + (and (null node) + (save-excursion + (forward-line -1) + (if (re-search-forward + php-ts-mode--possibly-braceless-keyword-re + bol t) + (+ 1 php-ts-mode-indent-offset) + 0)))) + ;; taken from c-ts-mode (defun php-ts-mode--else-heuristic (node parent bol &rest _) "Heuristic matcher for when \"else\" is followed by a closing bracket. @@ -475,43 +496,50 @@ NODE is the node to match and PARENT is its parent." (goto-char (treesit-node-start parent)) (line-end-position))) -(defun php-ts-mode--parent-html-bol (node parent _bol &rest _) +(defun php-ts-mode--parent-html-bol (node parent bol &rest _) "Find the first non-space characters of the HTML tags before NODE. +When NODE is nil call `php-ts-mode--open-statement-group-heuristic'. PARENT is NODE's parent, BOL is the beginning of non-whitespace characters of the current line." - (save-excursion - (let ((html-node (treesit-search-forward node "text" t))) - (if html-node - (let ((end-html (treesit-node-end html-node))) - (goto-char end-html) - (backward-word) - (back-to-indentation) - (point)) - (treesit-node-start parent))))) - -(defun php-ts-mode--parent-html-heuristic (node parent _bol &rest _) + (if (null node) + ;; If NODE is nil it could be an open statement-group. + (php-ts-mode--open-statement-group-heuristic node parent bol) + (save-excursion + (let ((html-node (treesit-search-forward node "text" t))) + (if html-node + (let ((end-html (treesit-node-end html-node))) + (goto-char end-html) + (backward-word) + (back-to-indentation) + (point)) + (treesit-node-start parent)))))) + +(defun php-ts-mode--parent-html-heuristic (node parent bol &rest _) "Return position based on html indentation. Returns 0 if the NODE is after the </html>, otherwise returns the -indentation point of the last word before the NODE, plus the -indentation offset. If there is no HTML tag, it returns the beginning -of the parent. +indentation point of the last word before the NODE, plus the indentation +offset. If there is no HTML tag, it returns the beginning of the +parent. When NODE is nil call `php-ts-mode--open-statement-group-heuristic'. It can be used when you want to indent PHP code relative to the HTML. PARENT is NODE's parent, BOL is the beginning of non-whitespace characters of the current line." - (let ((html-node (treesit-search-forward node "text" t))) - (if html-node - (let ((end-html (treesit-node-end html-node))) - (save-excursion - (goto-char end-html) - (backward-word) - (back-to-indentation) - (if (search-forward "</html>" end-html t 1) - 0 - (+ (point) php-ts-mode-indent-offset)))) - ;; Maybe it's better to use bol? - (treesit-node-start parent)))) + (if (null node) + ;; If NODE is nil it could be an open statement-group. + (php-ts-mode--open-statement-group-heuristic node parent bol) + (let ((html-node (treesit-search-forward node "text" t))) + (if html-node + (let ((end-html (treesit-node-end html-node))) + (save-excursion + (goto-char end-html) + (backward-word) + (back-to-indentation) + (if (search-forward "</html>" end-html t 1) + 0 + (+ (point) php-ts-mode-indent-offset)))) + ;; Maybe it's better to use bol? + (treesit-node-start parent))))) (defun php-ts-mode--array-element-heuristic (_node parent _bol &rest _) "Return of the position of the first element of the array. @@ -563,12 +591,12 @@ doesn't have a child. PARENT is NODE's parent, BOL is the beginning of non-whitespace characters of the current line." - (when-let ((prev-sibling - (or (treesit-node-prev-sibling node t) - (treesit-node-prev-sibling - (treesit-node-first-child-for-pos parent bol) t) - (treesit-node-child parent -1 t))) - (continue t)) + (when-let* ((prev-sibling + (or (treesit-node-prev-sibling node t) + (treesit-node-prev-sibling + (treesit-node-first-child-for-pos parent bol) t) + (treesit-node-child parent -1 t))) + (continue t)) (save-excursion (while (and prev-sibling continue) (goto-char (treesit-node-start prev-sibling)) @@ -612,6 +640,7 @@ characters of the current line." ((query "(class_interface_clause (qualified_name) @indent)") parent-bol php-ts-mode-indent-offset) ((parent-is "class_declaration") parent-bol 0) + ((parent-is "namespace_use_declaration") parent-bol php-ts-mode-indent-offset) ((parent-is "namespace_use_group") parent-bol php-ts-mode-indent-offset) ((parent-is "function_definition") parent-bol 0) ((parent-is "member_call_expression") first-sibling php-ts-mode-indent-offset) @@ -648,16 +677,22 @@ characters of the current line." ((parent-is "initializer_list") parent-bol php-ts-mode-indent-offset) ;; Statement in {} blocks. - ((or (and (parent-is "compound_statement") + ((or (and (or (parent-is "compound_statement") + (parent-is "colon_block")) ;; If the previous sibling(s) are not on their ;; own line, indent as if this node is the first ;; sibling php-ts-mode--first-sibling) - (match null "compound_statement")) + (or (match null "compound_statement") + (match null "colon_block"))) standalone-parent php-ts-mode-indent-offset) - ((parent-is "compound_statement") parent-bol php-ts-mode-indent-offset) + ((or (parent-is "compound_statement") + (parent-is "colon_block")) + parent-bol php-ts-mode-indent-offset) ;; Opening bracket. - ((node-is "compound_statement") standalone-parent php-ts-mode-indent-offset) + ((or (node-is "compound_statement") + (node-is "colon_block")) + standalone-parent php-ts-mode-indent-offset) ((parent-is "match_block") parent-bol php-ts-mode-indent-offset) ((parent-is "switch_block") parent-bol 0) @@ -667,6 +702,7 @@ characters of the current line." ;; rule for PHP alternative syntax ((or (node-is "else_if_clause") (node-is "endif") + (node-is "endfor") (node-is "endforeach") (node-is "endwhile")) parent-bol 0) @@ -679,9 +715,13 @@ characters of the current line." (parent-is "switch_statement") (parent-is "case_statement") (parent-is "empty_statement")) - parent-bol php-ts-mode-indent-offset)))) + parent-bol php-ts-mode-indent-offset) + + ;; Workaround: handle "for" open statement group. Currently + ;; the grammar handles it differently than other control structures. + (no-node php-ts-mode--open-statement-group-heuristic 0)))) `((psr2 - ((parent-is "program") parent-bol 0) + ((parent-is "program") php-ts-mode--open-statement-group-heuristic 0) ((parent-is "text_interpolation") column-0 0) ((parent-is "function_call_expression") parent-bol php-ts-mode-indent-offset) ,@common) @@ -742,7 +782,7 @@ characters of the current line." '("--" "**=" "*=" "/=" "%=" "+=" "-=" ".=" "<<=" ">>=" "&=" "^=" "|=" "??" "??=" "||" "&&" "|" "^" "&" "==" "!=" "<>" "===" "!==" "<" ">" "<=" ">=" "<=>" "<<" ">>" "+" "-" "." "*" "**" "/" "%" - "->" "?->") + "->" "?->" "...") "PHP operators for tree-sitter font-locking.") (defconst php-ts-mode--predefined-constant @@ -774,21 +814,32 @@ characters of the current line." "__FUNCTION__" "__LINE__" "__METHOD__" "__NAMESPACE__" "__TRAIT__") "PHP predefined constant.") -(defun php-ts-mode--test-namespace-name-as-prefix-p () - "Return t if namespace_name_as_prefix keyword is a named node, nil otherwise." +(defconst php-ts-mode--class-magic-methods + '("__construct" "__destruct" "__call" "__callStatic" "__get" "__set" + "__isset" "__unset" "__sleep" "__wakeup" "__serialize" "__unserialize" + "__toString" "__invoke" "__set_state" "__clone" "__debugInfo") + "PHP predefined magic methods.") + +(defun php-ts-mode--test-namespace-name-as-prefix-p () + "Return t if namespace_name_as_prefix is a named node, nil otherwise." (ignore-errors (progn (treesit-query-compile 'php "(namespace_name_as_prefix)" t) t))) -(defun php-ts-mode--test-namespace-aliasing-clause-p () - "Return t if namespace_name_as_prefix keyword is named node, nil otherwise." +(defun php-ts-mode--test-namespace-aliasing-clause-p () + "Return t if namespace_aliasing_clause is a named node, nil otherwise." (ignore-errors - (progn (treesit-query-compile 'php "(namespace_name_as_prefix)" t) t))) + (progn (treesit-query-compile 'php "(namespace_aliasing_clause)" t) t))) (defun php-ts-mode--test-namespace-use-group-clause-p () - "Return t if namespace_use_group_clause keyword is named node, nil otherwise." + "Return t if namespace_use_group_clause is a named node, nil otherwise." (ignore-errors (progn (treesit-query-compile 'php "(namespace_use_group_clause)" t) t))) +(defun php-ts-mode--test-visibility-modifier-operation-clause-p () + "Return t if (visibility_modifier (operation)) is defined, nil otherwise." + (ignore-errors + (progn (treesit-query-compile 'php "(visibility_modifier (operation))" t) t))) + (defun php-ts-mode--font-lock-settings () "Tree-sitter font-lock settings." (treesit-font-lock-rules @@ -796,7 +847,10 @@ characters of the current line." :language 'php :feature 'keyword :override t - `([,@php-ts-mode--keywords] @font-lock-keyword-face) + `([,@php-ts-mode--keywords] @font-lock-keyword-face + ,@(when (php-ts-mode--test-visibility-modifier-operation-clause-p) + '((visibility_modifier (operation) @font-lock-builtin-face))) + (var_modifier) @font-lock-builtin-face) :language 'php :feature 'comment @@ -826,7 +880,6 @@ characters of the current line." (named_label_statement (name) @font-lock-constant-face)) :language 'php - ;;:override t :feature 'delimiter `((["," ":" ";" "\\"]) @font-lock-delimiter-face) @@ -850,7 +903,6 @@ characters of the current line." :language 'php :feature 'string - ;;:override t `(("\"") @font-lock-string-face (encapsed_string) @font-lock-string-face (string_content) @font-lock-string-face @@ -892,32 +944,38 @@ characters of the current line." name: (_) @font-lock-type-face) (trait_declaration name: (_) @font-lock-type-face) - (property_declaration - (visibility_modifier) @font-lock-keyword-face) - (property_declaration - (var_modifier) @font-lock-keyword-face) (enum_declaration name: (_) @font-lock-type-face) (function_definition name: (_) @font-lock-function-name-face) (method_declaration name: (_) @font-lock-function-name-face) + (method_declaration + name: (name) @font-lock-builtin-face + (:match ,(rx-to-string + `(: bos (or ,@php-ts-mode--class-magic-methods) eos)) + @font-lock-builtin-face)) ("=>") @font-lock-keyword-face (object_creation_expression (name) @font-lock-type-face) ,@(when (php-ts-mode--test-namespace-name-as-prefix-p) - '((namespace_name_as_prefix "\\" @font-lock-delimiter-face) - (namespace_name_as_prefix - (namespace_name (name)) @font-lock-type-face))) + '((namespace_name_as_prefix "\\" @font-lock-delimiter-face) + (namespace_name_as_prefix + (namespace_name (name)) @font-lock-type-face))) ,@(if (php-ts-mode--test-namespace-aliasing-clause-p) - '((namespace_aliasing_clause (name) @font-lock-type-face)) - '((namespace_use_clause alias: (name) @font-lock-type-face))) + '((namespace_aliasing_clause (name) @font-lock-type-face)) + '((namespace_use_clause alias: (name) @font-lock-type-face))) ,@(when (not (php-ts-mode--test-namespace-use-group-clause-p)) - '((namespace_use_group - (namespace_use_clause (name) @font-lock-type-face)))) + '((namespace_use_group + (namespace_use_clause (name) @font-lock-type-face)))) + (namespace_use_clause (name) @font-lock-type-face) (namespace_name "\\" @font-lock-delimiter-face) (namespace_name (name) @font-lock-type-face) - (use_declaration (name) @font-lock-property-use-face)) + (use_declaration (name) @font-lock-property-use-face) + (use_instead_of_clause (name) @font-lock-type-face) + (binary_expression + operator: "instanceof" + right: (name) @font-lock-type-face)) :language 'php :feature 'function-scope @@ -932,11 +990,11 @@ characters of the current line." '((function_call_expression function: (name) @font-lock-function-call-face) (scoped_call_expression - name: (_) @font-lock-function-name-face) + name: (_) @font-lock-function-call-face) (member_call_expression - name: (_) @font-lock-function-name-face) + name: (_) @font-lock-function-call-face) (nullsafe_member_call_expression - name: (_) @font-lock-constant-face)) + name: (_) @font-lock-function-call-face)) :language 'php :feature 'argument @@ -1168,8 +1226,8 @@ Return nil if the NODE has no field “name” or if NODE is not a defun node." "Indent the current top-level declaration syntactically. `treesit-defun-type-regexp' defines what constructs to indent." (interactive "*") - (when-let ((orig-point (point-marker)) - (node (treesit-defun-at-point))) + (when-let* ((orig-point (point-marker)) + (node (treesit-defun-at-point))) (indent-region (treesit-node-start node) (treesit-node-end node)) (goto-char orig-point))) @@ -1209,8 +1267,14 @@ less common PHP-style # comment. SOFT works the same as in (line-end-position) t nil)) (let ((offset (- (match-beginning 0) (line-beginning-position))) - (comment-prefix (match-string 0))) - (if soft (insert-and-inherit ?\n) (newline 1)) + (comment-prefix (match-string 0)) + (insert-line-break + (lambda () + (delete-horizontal-space) + (if soft + (insert-and-inherit ?\n) + (newline 1))))) + (funcall insert-line-break) (delete-region (line-beginning-position) (point)) (insert (make-string offset ?\s) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 3cdaa7c2a76..cf1c94a6d20 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -199,7 +199,9 @@ When it is non-nil, `project-current' will always skip prompting too.") (defcustom project-prompter #'project-prompt-project-dir "Function to call to prompt for a project. -Called with no arguments and should return a project root dir." +The function is either called with no arguments or with one argument, +which is the prompt string to use. It should return a project root +directory." :type '(choice (const :tag "Prompt for a project directory" project-prompt-project-dir) (const :tag "Prompt for a project name" @@ -546,61 +548,64 @@ project backend implementation of `project-external-roots'.") See `project-vc-extra-root-markers' for the marker value format.") (defun project-try-vc (dir) - ;; FIXME: Learn to invalidate when the value of - ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers' - ;; changes. + ;; FIXME: Learn to invalidate when the value changes: + ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'. (or (vc-file-getprop dir 'project-vc) - (let* ((backend-markers - (delete - nil - (mapcar - (lambda (b) (assoc-default b project-vc-backend-markers-alist)) - vc-handled-backends))) - (marker-re - (concat - "\\`" - (mapconcat - (lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m))) - (append backend-markers - (project--value-in-dir 'project-vc-extra-root-markers dir)) - "\\|") - "\\'")) - (locate-dominating-stop-dir-regexp - (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)) - last-matches - (root - (locate-dominating-file - dir - (lambda (d) - ;; Maybe limit count to 100 when we can drop Emacs < 28. - (setq last-matches - (condition-case nil - (directory-files d nil marker-re t) - (file-missing nil)))))) - (backend - (cl-find-if - (lambda (b) - (member (assoc-default b project-vc-backend-markers-alist) - last-matches)) - vc-handled-backends)) - project) - (when (and - (eq backend 'Git) - (project--vc-merge-submodules-p root) - (project--submodule-p root)) - (let* ((parent (file-name-directory (directory-file-name root)))) - (setq root (vc-call-backend 'Git 'root parent)))) - (when root - (when (not backend) - (let* ((project-vc-extra-root-markers nil) - ;; Avoid submodules scan. - (enable-dir-local-variables nil) - (parent (project-try-vc root))) - (and parent (setq backend (nth 1 parent))))) - (setq project (list 'vc backend root)) - ;; FIXME: Cache for a shorter time. - (vc-file-setprop dir 'project-vc project) - project)))) + ;; FIXME: Cache for a shorter time. + (let ((res (project-try-vc--search dir))) + (and res (vc-file-setprop dir 'project-vc res)) + res))) + +(defun project-try-vc--search (dir) + (let* ((backend-markers + (delete + nil + (mapcar + (lambda (b) (assoc-default b project-vc-backend-markers-alist)) + vc-handled-backends))) + (marker-re + (concat + "\\`" + (mapconcat + (lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m))) + (append backend-markers + (project--value-in-dir 'project-vc-extra-root-markers dir)) + "\\|") + "\\'")) + (locate-dominating-stop-dir-regexp + (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)) + last-matches + (root + (locate-dominating-file + dir + (lambda (d) + ;; Maybe limit count to 100 when we can drop Emacs < 28. + (setq last-matches + (condition-case nil + (directory-files d nil marker-re t) + (file-missing nil)))))) + (backend + (cl-find-if + (lambda (b) + (member (assoc-default b project-vc-backend-markers-alist) + last-matches)) + vc-handled-backends)) + project) + (when (and + (eq backend 'Git) + (project--vc-merge-submodules-p root) + (project--submodule-p root)) + (let* ((parent (file-name-directory (directory-file-name root)))) + (setq root (vc-call-backend 'Git 'root parent)))) + (when root + (when (not backend) + (let* ((project-vc-extra-root-markers nil) + ;; Avoid submodules scan. + (enable-dir-local-variables nil) + (parent (project-try-vc--search root))) + (and parent (setq backend (nth 1 parent))))) + (setq project (list 'vc backend root)) + project))) (defun project--submodule-p (root) ;; XXX: We only support Git submodules for now. @@ -924,7 +929,7 @@ DIRS must contain directory names." (generic-cmd (lookup-key project-prefix-map key)) (switch-to-buffer-obey-display-actions t) (display-buffer-overriding-action (unless place-cmd action))) - (if-let ((cmd (or place-cmd generic-cmd))) + (if-let* ((cmd (or place-cmd generic-cmd))) (call-interactively cmd) (user-error "%s is undefined" (key-description key))))) @@ -1073,8 +1078,8 @@ relative to PROJECT instead. This supports using a relative file name from the current buffer when switching projects with `project-switch-project' and then using a command like `project-find-file'." - (if-let (filename-proj (and project-current-directory-override - (project-current nil default-directory))) + (if-let* ((filename-proj (and project-current-directory-override + (project-current nil default-directory)))) ;; file-name-concat requires Emacs 28+ (concat (file-name-as-directory (project-root project)) (file-relative-name filename (project-root filename-proj))) @@ -1141,9 +1146,9 @@ for VCS directories listed in `vc-directory-exclusion-list'." (defcustom project-read-file-name-function #'project--read-file-cpd-relative "Function to call to read a file name from a list. For the arguments list, see `project--read-file-cpd-relative'." - :type '(choice (const :tag "Read with completion from relative names" + :type '(choice (const :tag "Read with completion from relative file names" project--read-file-cpd-relative) - (const :tag "Read with completion from absolute names" + (const :tag "Read with completion from file names" project--read-file-absolute) (function :tag "Custom function" nil)) :group 'project @@ -1165,7 +1170,7 @@ This has the effect of sharing more history between projects." :version "30.1") (defun project--transplant-file-name (filename project) - (when-let ((old-root (get-text-property 0 'project filename))) + (when-let* ((old-root (get-text-property 0 'project filename))) (expand-file-name (file-relative-name filename old-root) (project-root project)))) @@ -1193,53 +1198,34 @@ by the user at will." (file-name-absolute-p (car all-files))) prompt (concat prompt (format " in %s" common-parent-directory)))) - (included-cpd (when (member common-parent-directory all-files) - (setq all-files - (delete common-parent-directory all-files)) - t)) - (mb-default (mapcar (lambda (mb-default) - (if (and common-parent-directory - mb-default - (file-name-absolute-p mb-default)) - (file-relative-name - mb-default common-parent-directory) - mb-default)) - (if (listp mb-default) mb-default (list mb-default)))) (substrings (mapcar (lambda (s) (substring s cpd-length)) all-files)) - (_ (when included-cpd - (setq substrings (cons "./" substrings)))) (new-collection (project--file-completion-table substrings)) - (abs-cpd (expand-file-name common-parent-directory)) - (abs-cpd-length (length abs-cpd)) - (relname (cl-letf* ((non-essential t) ;Avoid new Tramp connections. - ((symbol-value hist) - (mapcan - (lambda (s) - (setq s (expand-file-name s)) - (and (string-prefix-p abs-cpd s) - (not (eq abs-cpd-length (length s))) - (list (substring s abs-cpd-length)))) - (symbol-value hist)))) - (project--completing-read-strict prompt - new-collection - predicate - hist mb-default))) + (relname (project--completing-read-strict prompt + new-collection + predicate + hist mb-default + (unless (equal common-parent-directory "") + common-parent-directory))) (absname (expand-file-name relname common-parent-directory))) absname)) (defun project--read-file-absolute (prompt all-files &optional predicate hist mb-default) - (let* ((new-prompt (if (file-name-absolute-p (car all-files)) + (let* ((names-absolute (file-name-absolute-p (car all-files))) + (new-prompt (if names-absolute prompt (concat prompt " in " default-directory))) - ;; FIXME: Map relative names to absolute? + ;; TODO: The names are intentionally not absolute in many cases. + ;; Probably better to rename this function. (ct (project--file-completion-table all-files)) (file (project--completing-read-strict new-prompt ct predicate - hist mb-default))) + hist mb-default + (unless names-absolute + default-directory)))) (unless (file-name-absolute-p file) (setq file (expand-file-name file))) file)) @@ -1298,17 +1284,39 @@ directories listed in `vc-directory-exclusion-list'." (defun project--completing-read-strict (prompt collection &optional predicate - hist mb-default) - (minibuffer-with-setup-hook - (lambda () - (setq-local minibuffer-default-add-function - (lambda () - (let ((minibuffer-default mb-default)) - (minibuffer-default-add-completions))))) - (completing-read (format "%s: " prompt) - collection predicate 'confirm - nil - hist))) + hist mb-default + common-parent-directory) + (cl-letf* ((mb-default (mapcar (lambda (mb-default) + (if (and common-parent-directory + mb-default + (file-name-absolute-p mb-default)) + (file-relative-name + mb-default common-parent-directory) + mb-default)) + (if (listp mb-default) mb-default (list mb-default)))) + (abs-cpd (expand-file-name (or common-parent-directory ""))) + (abs-cpd-length (length abs-cpd)) + (non-essential t) ;Avoid new Tramp connections. + ((symbol-value hist) + (if common-parent-directory + (mapcan + (lambda (s) + (setq s (expand-file-name s)) + (and (string-prefix-p abs-cpd s) + (not (eq abs-cpd-length (length s))) + (list (substring s abs-cpd-length)))) + (symbol-value hist)) + (symbol-value hist)))) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-default-add-function + (lambda () + (let ((minibuffer-default mb-default)) + (minibuffer-default-add-completions))))) + (completing-read (format "%s: " prompt) + collection predicate 'confirm + nil + hist)))) ;;;###autoload (defun project-find-dir () @@ -1318,6 +1326,7 @@ The current buffer's `default-directory' is available as part of \"future history\"." (interactive) (let* ((project (project-current t)) + (project-files-relative-names t) (all-files (project-files project)) (completion-ignore-case read-file-name-completion-ignore-case) ;; FIXME: This misses directories without any files directly @@ -1325,11 +1334,15 @@ The current buffer's `default-directory' is available as part of ;; `project-files-filtered', and see ;; https://stackoverflow.com/a/50685235/615245 for possible ;; implementation. - (all-dirs (mapcar #'file-name-directory all-files)) + (all-dirs (cons "./" + (delq nil + ;; Some completion UIs show duplicates. + (delete-dups + (mapcar #'file-name-directory all-files))))) + (default-directory (project-root project)) (dir (project--read-file-name project "Dired" - ;; Some completion UIs show duplicates. - (delete-dups all-dirs) + all-dirs nil 'file-name-history (and default-directory (project--find-default-from default-directory project))))) @@ -1441,7 +1454,7 @@ If you exit the `query-replace', you can later continue the (defun project-prefixed-buffer-name (mode) (concat "*" - (if-let ((proj (project-current nil))) + (if-let* ((proj (project-current nil))) (project-name proj) (file-name-nondirectory (directory-file-name default-directory))) @@ -1868,7 +1881,7 @@ result in `project-list-file'. Announce the project's removal from the list using REPORT-MESSAGE, which is a format string passed to `message' as its first argument." (project--ensure-read-project-list) - (when-let ((ent (assoc (abbreviate-file-name project-root) project--list))) + (when-let* ((ent (assoc (abbreviate-file-name project-root) project--list))) (setq project--list (delq ent project--list)) (message report-message project-root) (project--write-project-list))) @@ -1929,8 +1942,8 @@ When PROMPT is non-nil, use it as the prompt string." (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. - (when-let ((proj (project--find-in-directory dir)) - (name (project-name proj))) + (when-let* ((proj (project--find-in-directory dir)) + (name (project-name proj))) (push name project--name-history) (push (cons name proj) ret))) (reverse ret))) @@ -2027,10 +2040,10 @@ projects." (dolist (project (mapcar #'car project--list)) (puthash project t known)) (dolist (subdir dirs) - (when-let (((file-directory-p subdir)) - (project (project--find-in-directory subdir)) - (project-root (project-root project)) - ((not (gethash project-root known)))) + (when-let* (((file-directory-p subdir)) + (project (project--find-in-directory subdir)) + (project-root (project-root project)) + ((not (gethash project-root known)))) (project-remember-project project t) (puthash project-root t known) (message "Found %s..." project-root) @@ -2178,8 +2191,8 @@ Otherwise, use the face `help-key-binding' in the prompt." (let ((temp-map (make-sparse-keymap))) (set-keymap-parent temp-map project-prefix-map) (dolist (row commands-menu temp-map) - (when-let ((cmd (nth 0 row)) - (keychar (nth 2 row))) + (when-let* ((cmd (nth 0 row)) + (keychar (nth 2 row))) (define-key temp-map (vector keychar) cmd))))) command choice) @@ -2236,7 +2249,7 @@ If you set `uniquify-dirname-transform' to this function, slash-separated components from `project-name' will be appended to the buffer's directory name when buffers from two different projects would otherwise have the same name." - (if-let (proj (project-current nil dirname)) + (if-let* ((proj (project-current nil dirname))) (let ((root (project-root proj))) (expand-file-name (file-name-concat @@ -2271,7 +2284,7 @@ is part of the default mode line beginning with Emacs 30." (defun project-mode-line-format () "Compose the project mode-line." - (when-let ((project (project-current))) + (when-let* ((project (project-current))) ;; Preserve the global value of 'last-coding-system-used' ;; that 'write-region' needs to set for 'basic-save-buffer', ;; but updating the mode line might occur at the same time diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 6d57517cd25..2438029bfdd 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -718,10 +718,11 @@ class declarations.") "aiter" "anext" "ascii" "breakpoint" "bytearray" "bytes" "exec" ;; Special attributes: ;; https://docs.python.org/3/reference/datamodel.html - "__annotations__" "__closure__" "__code__" - "__defaults__" "__dict__" "__doc__" "__globals__" - "__kwdefaults__" "__name__" "__module__" "__package__" - "__qualname__" + "__annotations__" "__bases__" "__closure__" "__code__" + "__defaults__" "__dict__" "__doc__" "__firstlineno__" + "__globals__" "__kwdefaults__" "__name__" "__module__" + "__mro__" "__package__" "__qualname__" + "__static_attributes__" "__type_params__" ;; Extras: "__all__") symbol-end) . font-lock-builtin-face)) @@ -808,7 +809,7 @@ sign in chained assignment." (3 'font-lock-operator-face) (,(python-rx symbol-name) (progn - (when-let ((type-start (match-beginning 2))) + (when-let* ((type-start (match-beginning 2))) (goto-char type-start)) (match-end 0)) nil @@ -1034,10 +1035,12 @@ It makes underscores and dots word constituent chars.") ">>" ">>=" "|" "|=" "~" "@" "@=")) (defvar python--treesit-special-attributes - '("__annotations__" "__closure__" "__code__" - "__defaults__" "__dict__" "__doc__" "__globals__" - "__kwdefaults__" "__name__" "__module__" "__package__" - "__qualname__" "__all__")) + '("__annotations__" "__bases__" "__closure__" "__code__" + "__defaults__" "__dict__" "__doc__" "__firstlineno__" + "__globals__" "__kwdefaults__" "__name__" "__module__" + "__mro__" "__package__" "__qualname__" + "__static_attributes__" "__type_params__" + "__all__")) (defvar python--treesit-exceptions '(;; Python 2 and 3: @@ -1153,7 +1156,7 @@ fontified." ((or "identifier" "none") (setq font-node child)) ("attribute" - (when-let ((type-node (treesit-node-child-by-field-name child "attribute"))) + (when-let* ((type-node (treesit-node-child-by-field-name child "attribute"))) (setq font-node type-node))) ((or "binary_operator" "subscript") (python--treesit-fontify-union-types child override start end type-regex))) @@ -3264,8 +3267,8 @@ name respectively the current project name." (pcase dedicated ('nil python-shell-buffer-name) ('project - (if-let ((proj (and (featurep 'project) - (project-current)))) + (if-let* ((proj (and (featurep 'project) + (project-current)))) (format "%s[%s]" python-shell-buffer-name (file-name-nondirectory (directory-file-name (project-root proj)))) @@ -3788,7 +3791,7 @@ non-nil, means also display the Python shell buffer." dedicated)))) '(buffer project nil)) (user-error "No Python shell")) - (when-let ((proc (get-buffer-process (current-buffer)))) + (when-let* ((proc (get-buffer-process (current-buffer)))) (kill-process proc) (while (accept-process-output proc))) (python-shell-make-comint (python-shell-calculate-command) @@ -4845,9 +4848,9 @@ using that one instead of current buffer's process." ((stringp (car cands)) (if no-delims ;; Reduce completion candidates due to long prefix. - (if-let ((Lp (length prefix)) - ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix)) - (L (match-beginning 0))) + (if-let* ((Lp (length prefix)) + ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix)) + (L (match-beginning 0))) ;; If extra-offset is not zero: ;; start end ;; o------------------o---------o-------o @@ -5521,14 +5524,14 @@ def __FFAP_get_module_path(objstr): (defun python-ffap-module-path (module) "Function for `ffap-alist' to return path for MODULE." - (when-let ((process (python-shell-get-process)) - (ready (python-shell-with-shell-buffer + (when-let* ((process (python-shell-get-process)) + (ready (python-shell-with-shell-buffer (python-util-comint-end-of-output-p))) - (module-file - (python-shell-send-string-no-output - (format "%s\nprint(__FFAP_get_module_path(%s))" - python-ffap-setup-code - (python-shell--encode-string module))))) + (module-file + (python-shell-send-string-no-output + (format "%s\nprint(__FFAP_get_module_path(%s))" + python-ffap-setup-code + (python-shell--encode-string module))))) (unless (string-empty-p module-file) (python-util-strip-string module-file)))) @@ -6537,7 +6540,7 @@ This is for compatibility with Emacs < 24.4." (defun python-util-comint-end-of-output-p () "Return non-nil if the last prompt matches input prompt." - (when-let ((prompt (python-util-comint-last-prompt))) + (when-let* ((prompt (python-util-comint-last-prompt))) (python-shell-comint-end-of-output-p (buffer-substring-no-properties (car prompt) (cdr prompt))))) @@ -6817,8 +6820,8 @@ for key in sorted(result): (defun python--import-sources () "List files containing Python imports that may be useful in the current buffer." - (if-let (((featurep 'project)) ;For compatibility with Emacs < 26 - (proj (project-current))) + (if-let* (((featurep 'project)) ;For compatibility with Emacs < 26 + (proj (project-current))) (seq-filter (lambda (s) (string-match-p "\\.py[iwx]?\\'" s)) (project-files proj)) (list default-directory))) @@ -6930,9 +6933,9 @@ asking. When calling from Lisp, use a non-nil NAME to restrict the suggestions to imports defining NAME." (interactive (list (when current-prefix-arg (thing-at-point 'symbol)))) - (when-let ((statement (python--query-import name - (python--import-sources) - "Add import: "))) + (when-let* ((statement (python--query-import name + (python--import-sources) + "Add import: "))) (if (python--do-isort "--add" statement) (message "Added `%s'" statement) (message "(No changes in Python imports needed)")))) @@ -6955,8 +6958,8 @@ argument, restrict the suggestions to imports defining the symbol at point. If there is only one such suggestion, act without asking." (interactive (list (when current-prefix-arg (thing-at-point 'symbol)))) - (when-let ((statement (python--query-import name (current-buffer) - "Remove import: "))) + (when-let* ((statement (python--query-import name (current-buffer) + "Remove import: "))) (if (python--do-isort "--rm" statement) (message "Removed `%s'" statement) (message "(No changes in Python imports needed)")))) @@ -6998,11 +7001,11 @@ asking." (forward-line 1)))) ;; Compute imports to be added (dolist (name (seq-uniq undefined)) - (when-let ((statement (python--query-import name - (python--import-sources) - (format "\ + (when-let* ((statement (python--query-import name + (python--import-sources) + (format "\ Add import for undefined name `%s' (empty to skip): " - name)))) + name)))) (push statement add))) ;; Compute imports to be removed (dolist (name (seq-uniq unused)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 28bd42aebde..cf061a18ee0 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1050,7 +1050,7 @@ beginning of the line." "Return the string used to group a set of locations. This function is used as a value for `add-log-current-defun-function'." (xref--group-name-for-display - (if-let (item (xref--item-at-point)) + (if-let* ((item (xref--item-at-point))) (xref-location-group (xref-match-item-location item)) (xref--imenu-extract-index-name)) (xref--project-root (project-current)))) @@ -1139,6 +1139,7 @@ XREF-ALIST is of the form ((GROUP . (XREF ...)) ...), where GROUP is a string for decoration purposes and XREF is an `xref-item' object." (require 'compile) ; For the compilation faces. + (setq xref-num-matches-found 0) (cl-loop for (group . xrefs) in xref-alist for max-line = (cl-loop for xref in xrefs maximize (xref-location-line @@ -1158,6 +1159,7 @@ GROUP is a string for decoration purposes and XREF is an (xref--insert-propertized '(face xref-file-header xref-group t) group "\n") (dolist (xref xrefs) + (cl-incf xref-num-matches-found) (pcase-let (((cl-struct xref-item summary location) xref)) (let* ((line (xref-location-line location)) (prefix @@ -1247,7 +1249,6 @@ Return an alist of the form ((GROUP . (XREF ...)) ...)." (xref--ensure-default-directory dd (current-buffer)) (xref--xref-buffer-mode) (xref--show-common-initialize xref-alist fetcher alist) - (setq xref-num-matches-found (length xrefs)) (setq mode-line-process (list xref-mode-line-matches)) (pop-to-buffer (current-buffer)) (setq buf (current-buffer))) diff --git a/lisp/repeat.el b/lisp/repeat.el index 1de26826ea1..f13fa489cae 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -560,8 +560,8 @@ This function can be used to force exit of repetition while it's active." (mapconcat (lambda (key-cmd) (let ((key (car key-cmd)) (cmd (cdr key-cmd))) - (if-let ((hint (and (symbolp cmd) - (get cmd 'repeat-hint)))) + (if-let* ((hint (and (symbolp cmd) + (get cmd 'repeat-hint)))) ;; Reuse `read-multiple-choice' formatting. (cdr (rmc--add-key-description (list key hint))) (propertize (key-description (vector key)) diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 012e305f7f4..e2b7b4c9f06 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -416,22 +416,22 @@ It runs the hook `save-place-after-find-file-hook'." "Position point in a Dired buffer according to its saved place. This is run via `dired-initial-position-hook', which see." (or save-place-loaded (save-place-load-alist-from-file)) - (when-let ((directory (and (derived-mode-p 'dired-mode) - (boundp 'dired-subdir-alist) - dired-subdir-alist - (dired-current-directory))) - (item (expand-file-name (if (consp directory) - (car directory) - directory))) - (cell (assoc (if save-place-abbreviate-file-names - (abbreviate-file-name item) item) - save-place-alist))) + (when-let* ((directory (and (derived-mode-p 'dired-mode) + (boundp 'dired-subdir-alist) + dired-subdir-alist + (dired-current-directory))) + (item (expand-file-name (if (consp directory) + (car directory) + directory))) + (cell (assoc (if save-place-abbreviate-file-names + (abbreviate-file-name item) item) + save-place-alist))) (or revert-buffer-in-progress-p (cond ((integerp (cdr cell)) (goto-char (cdr cell))) ((listp (cdr cell)) - (when-let ((elt (assq 'dired-filename (cdr cell)))) + (when-let* ((elt (assq 'dired-filename (cdr cell)))) (dired-goto-file (expand-file-name (cdr elt))))))) ;; and make sure it will be saved again for later (setq save-place-mode t))) diff --git a/lisp/server.el b/lisp/server.el index abfd3d4d753..d45fb2b25ab 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1904,7 +1904,7 @@ if there are no other active clients." (length> server-clients 1) (seq-some (lambda (frame) - (when-let ((p (frame-parameter frame 'client))) + (when-let* ((p (frame-parameter frame 'client))) (not (eq proc p)))) (frame-list))) ;; If `server-stop-automatically' is not enabled, there diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el index 877b2c8b5ee..5eaa94b4633 100644 --- a/lisp/shadowfile.el +++ b/lisp/shadowfile.el @@ -294,7 +294,7 @@ Argument can be a simple name, remote file name, or already a (defsubst shadow-make-fullname (hup &optional host name) "Make a Tramp style fullname out of HUP, a `tramp-file-name' structure. Replace HOST, and NAME when non-nil. HOST can also be a remote file name." - (when-let ((hup (copy-tramp-file-name hup))) + (when-let* ((hup (copy-tramp-file-name hup))) (when host (if (file-remote-p host) (setq name (or name (and hup (tramp-file-name-localname hup))) @@ -364,7 +364,7 @@ Will return the name bare if it is a local file." Do so by replacing (when possible) home directory with ~/, and hostname with cluster name that includes it. Filename should be absolute and true." - (when-let ((hup (shadow-parse-name file))) + (when-let* ((hup (shadow-parse-name file))) (let* ((homedir (if (shadow-local-file hup) shadow-homedir (file-name-as-directory @@ -464,8 +464,8 @@ It may have different filenames on each site. When this file is edited, the new version will be copied to each of the other locations. Sites can be specific hostnames, or names of clusters (see `shadow-define-cluster')." (interactive) - (when-let ((hup (shadow-parse-name - (shadow-contract-file-name (buffer-file-name))))) + (when-let* ((hup (shadow-parse-name + (shadow-contract-file-name (buffer-file-name))))) (let* ((name (tramp-file-name-localname hup)) site group) (while (setq site (shadow-read-site)) diff --git a/lisp/shell.el b/lisp/shell.el index 965e6edcb37..6cfae470cd7 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -1802,7 +1802,7 @@ works better if `comint-fontify-input-mode' is enabled." (progn (remove-hook 'comint-indirect-setup-hook shell--highlight-undef-indirect t) (setq shell--highlight-undef-indirect nil) - (when-let ((buf (comint-indirect-buffer t))) + (when-let* ((buf (comint-indirect-buffer t))) (with-current-buffer buf (font-lock-remove-keywords nil shell-highlight-undef-keywords)))) (font-lock-remove-keywords nil shell-highlight-undef-keywords)) @@ -1842,7 +1842,7 @@ works better if `comint-fontify-input-mode' is enabled." (font-lock-add-keywords nil shell-highlight-undef-keywords t)))) (cond (comint-fontify-input-mode (setq shell--highlight-undef-indirect setup) - (if-let ((buf (comint-indirect-buffer t))) + (if-let* ((buf (comint-indirect-buffer t))) (with-current-buffer buf (funcall setup)) (add-hook 'comint-indirect-setup-hook setup nil t))) diff --git a/lisp/simple.el b/lisp/simple.el index e35cfe0479b..3a142ef14b3 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2399,7 +2399,7 @@ mode when reading the command name." (defun command-completion-using-modes-p (symbol buffer) "Say whether SYMBOL has been marked as a mode-specific command in BUFFER." ;; Check the modes. - (when-let ((modes (command-modes symbol))) + (when-let* ((modes (command-modes symbol))) ;; Common fast case: Just a single mode. (if (null (cdr modes)) (or (provided-mode-derived-p @@ -2801,10 +2801,10 @@ don't clear it." (t ;; Pass `cmd' rather than `final', for the backtrace's sake. (prog1 (call-interactively cmd record-flag keys) - (when-let ((info - (and (symbolp cmd) - (not (get cmd 'command-execute-obsolete-warned)) - (get cmd 'byte-obsolete-info)))) + (when-let* ((info + (and (symbolp cmd) + (not (get cmd 'command-execute-obsolete-warned)) + (get cmd 'byte-obsolete-info)))) (put cmd 'command-execute-obsolete-warned t) (message "%s" (macroexp--obsolete-warning cmd info "command" @@ -4779,7 +4779,7 @@ Names'. If a file name handler is unable to retrieve the effective uid, this function will instead return -1." - (if-let ((handler (find-file-name-handler default-directory 'file-user-uid))) + (if-let* ((handler (find-file-name-handler default-directory 'file-user-uid))) (funcall handler 'file-user-uid) (user-uid))) @@ -4791,7 +4791,7 @@ Names'. If a file name handler is unable to retrieve the effective gid, this function will instead return -1." - (if-let ((handler (find-file-name-handler default-directory 'file-group-gid))) + (if-let* ((handler (find-file-name-handler default-directory 'file-group-gid))) (funcall handler 'file-group-gid) (group-gid))) @@ -10054,7 +10054,7 @@ the completions is popped up and down." (let ((inhibit-read-only t)) (add-text-properties (point) (min (1+ (point)) (point-max)) '(first-completion t)))) - (when-let ((pos (next-single-property-change (point) 'mouse-face))) + (when-let* ((pos (next-single-property-change (point) 'mouse-face))) (goto-char pos)))) (defun last-completion () @@ -10064,7 +10064,7 @@ the completions is popped up and down." (point-max) 'mouse-face nil (point-min))) ;; Move to the start of last one. (unless (get-text-property (point) 'mouse-face) - (when-let ((pos (previous-single-property-change (point) 'mouse-face))) + (when-let* ((pos (previous-single-property-change (point) 'mouse-face))) (goto-char pos)))) (defun previous-completion (n) @@ -10246,6 +10246,23 @@ Also see the `completion-auto-wrap' variable." This makes `completions--deselect' effective.") +(defun completions--start-of-candidate-at (position) + "Return the start position of the completion candidate at POSITION." + (save-excursion + (goto-char position) + (let (beg) + (cond + ((and (not (eobp)) + (get-text-property (point) 'completion--string)) + (setq beg (1+ (point)))) + ((and (not (bobp)) + (get-text-property (1- (point)) 'completion--string)) + (setq beg (point)))) + (when beg + (or (previous-single-property-change + beg 'completion--string) + beg))))) + (defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. If EVENT, use EVENT's position to determine the starting position. @@ -10269,21 +10286,11 @@ minibuffer, but don't quit the completions window." (or (get-text-property (posn-point (event-start event)) 'completion--string) (error "No completion here")) - (save-excursion - (goto-char (posn-point (event-start event))) - (let (beg) - (cond - ((and (not (eobp)) - (get-text-property (point) 'completion--string)) - (setq beg (1+ (point)))) - ((and (not (bobp)) - (get-text-property (1- (point)) 'completion--string)) - (setq beg (point))) - (t (error "No completion here"))) - (setq beg (or (previous-single-property-change - beg 'completion--string) - beg)) - (get-text-property beg 'completion--string)))))) + (if-let* ((candidate-start + (completions--start-of-candidate-at + (posn-point (event-start event))))) + (get-text-property candidate-start 'completion--string) + (error "No completion here"))))) (unless (buffer-live-p buffer) (error "Destination buffer is dead")) @@ -10451,6 +10458,8 @@ Called from `temp-buffer-show-hook'." (let ((base-position completion-base-position) (insert-fun completion-list-insert-choice-function)) (completion-list-mode) + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) (setq-local completion-base-position base-position) (setq-local completion-list-insert-choice-function insert-fun)) (setq-local completion-reference-buffer mainbuf) @@ -10491,10 +10500,10 @@ to move point between completions.\n\n"))))))) (defun switch-to-completions () "Select the completion list window." (interactive) - (when-let ((window (or (get-buffer-window "*Completions*" 0) - ;; Make sure we have a completions window. - (progn (minibuffer-completion-help) - (get-buffer-window "*Completions*" 0))))) + (when-let* ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) (select-window window) (when (bobp) (cond diff --git a/lisp/speedbar.el b/lisp/speedbar.el index c13c977938b..38fb641acf7 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -3168,25 +3168,32 @@ With universal argument ARG, flush cached data." (speedbar-do-function-pointer)) (error (speedbar-position-cursor-on-line)))) +(defun speedbar--get-line-indent-level () + "Return the indentation level of the current line." + (save-excursion + (beginning-of-line) + (if (looking-at "[0-9]+:") + (string-to-number (match-string 0)) + 0))) + (defun speedbar-expand-line-descendants (&optional arg) "Expand the line under the cursor and all descendants. Optional argument ARG indicates that any cache should be flushed." (interactive "P") - (save-restriction - (narrow-to-region (line-beginning-position) - (line-beginning-position 2)) - (speedbar-expand-line arg) - ;; Now, inside the area expanded here, expand all subnodes of - ;; the same descendant type. - (save-excursion - (speedbar-next 1) ;; Move into the list. - (let ((err nil)) - (while (not err) - (condition-case nil - (progn - (speedbar-expand-line-descendants arg) - (speedbar-restricted-next 1)) - (error (setq err t)))))))) + (dframe-message "Expanding all descendants...") + (save-excursion + (let ((top-depth (speedbar--get-line-indent-level))) + ;; Attempt to expand the top-level item. + (speedbar-expand-line arg) + ;; Move forwards, either into the newly expanded list, onto an + ;; already expanded list, onto a sibling item, or to the end of + ;; the buffer. + (while (and (zerop (forward-line 1)) + (not (eobp)) + (> (speedbar--get-line-indent-level) top-depth) + (speedbar-expand-line arg))))) + (dframe-message "Expanding all descendants...done") + (speedbar-position-cursor-on-line)) (defun speedbar-contract-line-descendants () "Expand the line under the cursor and all descendants." diff --git a/lisp/startup.el b/lisp/startup.el index 738eec772ec..3436409a35e 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1106,9 +1106,9 @@ init-file, or to a default value if loading is not possible." ;; The next test is for builds without native ;; compilation support or builds with unexec. (boundp 'comp-eln-to-el-h)) - (if-let (source (gethash (file-name-nondirectory - user-init-file) - comp-eln-to-el-h)) + (if-let* ((source (gethash (file-name-nondirectory + user-init-file) + comp-eln-to-el-h))) ;; source exists or the .eln file would not load (setq user-init-file source) (message "Warning: unknown source file for init file %S" diff --git a/lisp/subr.el b/lisp/subr.el index 8f0b6c5939c..648e6f0f38f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -299,7 +299,7 @@ value of last one, or nil if there are none." (if body (list 'if cond (cons 'progn body)) (macroexp-warn-and-return (format-message "`when' with empty body") - cond '(empty-body when) t))) + (list 'progn cond nil) '(empty-body when) t))) (defmacro unless (cond &rest body) "If COND yields nil, do BODY, else return nil. @@ -309,7 +309,7 @@ value of last one, or nil if there are none." (if body (cons 'if (cons cond (cons nil body))) (macroexp-warn-and-return (format-message "`unless' with empty body") - cond '(empty-body unless) t))) + (list 'progn cond nil) '(empty-body unless) t))) (defsubst subr-primitive-p (object) "Return t if OBJECT is a built-in primitive written in C. @@ -2622,8 +2622,17 @@ Affects only hooks run in the current buffer." (defmacro if-let* (varlist then &rest else) "Bind variables according to VARLIST and evaluate THEN or ELSE. -This is like `if-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." +Evaluate each binding in turn, as in `let*', stopping if a +binding value is nil. If all are non-nil return the value of +THEN, otherwise the value of the last form in ELSE, or nil if +there are none. + +Each element of VARLIST is a list (SYMBOL VALUEFORM) that binds +SYMBOL to the value of VALUEFORM. An element can additionally be +of the form (VALUEFORM), which is evaluated and checked for nil; +i.e. SYMBOL can be omitted if only the test result is of +interest. It can also be of the form SYMBOL, then the binding of +SYMBOL is checked for nil." (declare (indent 2) (debug ((&rest [&or symbolp (symbolp form) (form)]) body))) @@ -2636,15 +2645,26 @@ This is like `if-let' but doesn't handle a VARLIST of the form (defmacro when-let* (varlist &rest body) "Bind variables according to VARLIST and conditionally evaluate BODY. -This is like `when-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." +Evaluate each binding in turn, stopping if a binding value is nil. +If all are non-nil, return the value of the last form in BODY. + +The variable list VARLIST is the same as in `if-let*'. + +See also `and-let*'." (declare (indent 1) (debug if-let*)) (list 'if-let* varlist (macroexp-progn body))) (defmacro and-let* (varlist &rest body) "Bind variables according to VARLIST and conditionally evaluate BODY. Like `when-let*', except if BODY is empty and all the bindings -are non-nil, then the result is the value of the last binding." +are non-nil, then the result is the value of the last binding. + +Some Lisp programmers follow the convention that `and' and `and-let*' +are for forms evaluated for return value, and `when' and `when-let*' are +for forms evaluated for side-effect with returned values ignored." + ;; ^ Document this convention here because it explains why we have + ;; both `when-let*' and `and-let*' (in addition to the additional + ;; feature of `and-let*' when BODY is empty). (declare (indent 1) (debug if-let*)) (let (res) (if varlist @@ -2655,21 +2675,10 @@ are non-nil, then the result is the value of the last binding." (defmacro if-let (spec then &rest else) "Bind variables according to SPEC and evaluate THEN or ELSE. -Evaluate each binding in turn, as in `let*', stopping if a -binding value is nil. If all are non-nil return the value of -THEN, otherwise the value of the last form in ELSE, or nil if -there are none. - -Each element of SPEC is a list (SYMBOL VALUEFORM) that binds -SYMBOL to the value of VALUEFORM. An element can additionally be -of the form (VALUEFORM), which is evaluated and checked for nil; -i.e. SYMBOL can be omitted if only the test result is of -interest. It can also be of the form SYMBOL, then the binding of -SYMBOL is checked for nil. - -As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) -like \((SYMBOL SOMETHING)). This exists for backward compatibility -with an old syntax that accepted only one binding." +This is like `if-let*' except, as a special case, interpret a SPEC of +the form \(SYMBOL SOMETHING) like \((SYMBOL SOMETHING)). This exists +for backward compatibility with an old syntax that accepted only one +binding." (declare (indent 2) (debug ([&or (symbolp form) ; must be first, Bug#48489 (&rest [&or symbolp (symbolp form) (form)])] @@ -2689,6 +2698,10 @@ The variable list SPEC is the same as in `if-let'." (declare (indent 1) (debug if-let)) (list 'if-let spec (macroexp-progn body))) +(make-obsolete 'if-let 'if-let* "31.1") +(make-obsolete 'when-let "use `when-let*' or `and-let*' instead." + "31.1") + (defmacro while-let (spec &rest body) "Bind variables according to SPEC and conditionally evaluate BODY. Evaluate each binding in turn, stopping if a binding value is nil. @@ -3410,9 +3423,10 @@ with Emacs. Do not call it directly in your own packages." (defun read-number (prompt &optional default hist) "Read a numeric value in the minibuffer, prompting with PROMPT. DEFAULT specifies a default value to return if the user just types RET. -The value of DEFAULT is inserted into PROMPT. -HIST specifies a history list variable. See `read-from-minibuffer' -for details of the HIST argument. +For historical reasons, the value of DEFAULT is always inserted into +PROMPT, so it's recommended to use `format' instead of `format-prompt' +to generate PROMPT. HIST specifies a history list variable. See +`read-from-minibuffer' for details of the HIST argument. This function is used by the `interactive' code letter \"n\"." (let ((n nil) diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 2efc2b8f85b..faf5df541e0 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -298,7 +298,7 @@ For any other value of KEY, the value is t." (defvar tab-bar--dragging-in-progress) (defun tab-bar--event-to-item (posn) - "This function extracts extra info from the mouse event at position POSN. + "Extract extra info from the mouse event at position POSN. It returns a list of the form (KEY KEY-BINDING CLOSE-P), where: KEY is a symbol representing a tab, such as \\='tab-1 or \\='current-tab; KEY-BINDING is the binding of KEY; @@ -803,7 +803,9 @@ Return its existing value or a new value." (funcall tab-bar-tab-name-function)))) ;; Create default tabs (setq tabs (list (tab-bar--current-tab-make))) - (tab-bar-tabs-set tabs frame)) + (tab-bar-tabs-set tabs frame) + (run-hook-with-args 'tab-bar-tab-post-open-functions + (car tabs))) tabs)) (defun tab-bar-tabs-set (tabs &optional frame) diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 92b52b6936c..3c83a02739a 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -461,7 +461,7 @@ named the same as the mode.") (defun tab-line-tabs-buffer-group-by-project (&optional buffer) "Group tab buffers by project name." (with-current-buffer buffer - (if-let ((project (project-current))) + (if-let* ((project (project-current))) (project-name project) "No project"))) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 7278bee48d4..a0366374d34 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -1049,7 +1049,7 @@ return nil. Otherwise point is returned." (while (and (not found) (not (eobp))) (forward-line 1) - (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (when-let* ((descriptor (ignore-errors (tar-get-descriptor)))) (when (equal (tar-header-name descriptor) file) (setq found t)))) (if (not found) @@ -1074,7 +1074,7 @@ return nil. Otherwise point is returned." (beginning-of-line) (bobp))))) (tar-next-line n) - (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (when-let* ((descriptor (ignore-errors (tar-get-descriptor)))) (let ((candidate (tar-header-name descriptor)) (buffer (current-buffer))) (when (and candidate diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index df1cdc5143e..5ecf789e364 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -159,7 +159,7 @@ two markers or an overlay. Otherwise, it is nil." VALUE should be something suitable for passing to `gui-set-selection'." (unless (stringp value) - (when-let ((bounds (android-selection-bounds value))) + (when-let* ((bounds (android-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) @@ -204,7 +204,7 @@ VALUE should be something suitable for passing to &context (window-system android)) ;; First, try to turn value into a string. ;; Don't set anything if that did not work. - (when-let ((string (android-encode-select-string value))) + (when-let* ((string (android-encode-select-string value))) (cond ((eq type 'CLIPBOARD) (android-set-clipboard string)) ((eq type 'PRIMARY) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index efc0a129062..c6091669adc 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -142,7 +142,7 @@ two markers or an overlay. Otherwise, it is nil." Return a list of the appropriate MIME type, and UTF-8 data of VALUE as a unibyte string, or nil if VALUE was not a string." (unless (stringp value) - (when-let ((bounds (haiku-selection-bounds value))) + (when-let* ((bounds (haiku-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) @@ -260,7 +260,7 @@ CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or VALUE will be encoded as Latin-1 (like on X Windows) and stored under the type `text/plain;charset=iso-8859-1'." (unless (stringp value) - (when-let ((bounds (haiku-selection-bounds value))) + (when-let* ((bounds (haiku-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) @@ -274,7 +274,7 @@ under the type `text/plain;charset=iso-8859-1'." VALUE will be encoded as UTF-8 and stored under the type `text/plain'." (unless (stringp value) - (when-let ((bounds (haiku-selection-bounds value))) + (when-let* ((bounds (haiku-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 541fef2ced3..911bd72184d 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -137,35 +137,40 @@ buffers, and switch to the buffer that visits the last dropped file. If EVENT is for text, insert that text at point into the buffer shown in the window that is the target of the drop; if that buffer is read-only, add the dropped text to kill-ring. +If EVENT payload is nil, then this is a drag event. If the optional argument NEW-FRAME is non-nil, perform the drag-n-drop action in a newly-created frame using its selected-window and that window's buffer." (interactive "e") - (save-excursion - ;; Make sure the drop target has positive co-ords - ;; before setting the selected frame - otherwise it - ;; won't work. <skx@tardis.ed.ac.uk> - (let* ((window (posn-window (event-start event))) - (coords (posn-x-y (event-start event))) - (arg (car (cdr (cdr event)))) - (x (car coords)) - (y (cdr coords))) - (if (and (> x 0) (> y 0)) - (set-frame-selected-window nil window)) - - (when new-frame - (select-frame (make-frame))) - (raise-frame) - (setq window (selected-window)) - - ;; arg (the payload of the event) is a string when the drop is - ;; text, and a list of strings when the drop is one or more files. - (if (stringp arg) - (dnd-insert-text window 'copy arg) - (dnd-handle-multiple-urls - window - (mapcar #'w32-dropped-file-to-url arg) - 'private))))) + ;; Make sure the drop target has positive co-ords + ;; before setting the selected frame - otherwise it + ;; won't work. <skx@tardis.ed.ac.uk> + (let* ((window (posn-window (event-start event))) + (coords (posn-x-y (event-start event))) + (arg (car (cdr (cdr event)))) + (x (car coords)) + (y (cdr coords))) + + (if (and (> x 0) (> y 0) (window-live-p window)) + (set-frame-selected-window nil window)) + ;; Don't create new frame if we are just dragging + (and arg new-frame + (select-frame (make-frame))) + (raise-frame) + (setq window (selected-window)) + + ;; arg (the payload of the event) is a string when the drop is + ;; text, and a list of strings when the drop is one or more files. + ;; It is nil if the event is a drag event. + (if arg + (save-excursion + (if (stringp arg) + (dnd-insert-text window 'copy arg) + (dnd-handle-multiple-urls + window + (mapcar #'w32-dropped-file-to-url arg) + 'private))) + (dnd-handle-movement (event-start event))))) (defun w32-drag-n-drop-other-frame (event) "Edit the files listed in the drag-n-drop EVENT, in other frames. @@ -437,15 +442,84 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (w32-set-clipboard-data (string-replace "\0" "\\0" value)) (put 'x-selections (or type 'PRIMARY) value))) -(defun w32--get-selection (&optional type data-type) +(defvar w32--selection-target-translations + '((PNG . image/png) + (DIBV5 . image/png) + (HTML\ Format . text/html))) + +(defun w32--translate-selection-target (target) + (let ((xlat (assoc target w32--selection-target-translations))) + (if xlat + (cdr xlat) + target))) + +(defun w32--translate-reverse-selection-target (target) + (append + (mapcar #'car + (seq-filter + (lambda (x) + (eq target + (w32--translate-selection-target (car x)))) + w32--selection-target-translations)) + (list target))) + +(defvar w32--textual-mime-types + '("application/xml" + "application/json" + "application/yaml" + "application/json-seq" + "\\`text/" + "\\+xml\\'" + "\\+json\\'" + "\\+yaml\\'" + "\\+json-seq\\'")) + +(defun w32--mime-type-textual-p (mime-type) + "Returns t if MIME-TYPE, a symbol, names a textual MIME type. + +This function is intended to classify clipboard data. All MIME subtypes +of text/ are considered textual. Also those with suffixes +xml, +json, ++yaml, +json-seq. And application/xml, application/json, +application/yaml, application/json-seq. + +This classification is not exhaustive. Some MIME types not listed may +also be textual." + (string-match-p + (mapconcat #'identity w32--textual-mime-types "\\|") + (symbol-name mime-type))) + +(declare-function w32--get-clipboard-data-media "w32select.c") + +(defun w32--get-selection (&optional type data-type) (cond ((and (eq type 'CLIPBOARD) (eq data-type 'STRING)) (with-demoted-errors "w32-get-clipboard-data:%S" (w32-get-clipboard-data))) ((eq data-type 'TARGETS) (if (eq type 'CLIPBOARD) - (w32-selection-targets type) + (vconcat + (delete-dups + (seq-map #'w32--translate-selection-target + (w32-selection-targets type)))) (if (get 'x-selections (or type 'PRIMARY)) '[STRING]))) + ((eq type 'CLIPBOARD) + (let ((tmp-file (make-temp-file "emacs-clipboard")) + (is-textual (w32--mime-type-textual-p data-type))) + (unwind-protect + (let* ((data-types (w32--translate-reverse-selection-target data-type)) + (data (w32--get-clipboard-data-media data-types tmp-file is-textual))) + (cond + ;; data is in the file + ((eq data t) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally tmp-file) + (buffer-string))) + ;; data is in data var + ((stringp data) data) + ;; No data + (t nil))) + (delete-file tmp-file)))) (t (get 'x-selections (or type 'PRIMARY))))) (defun w32--selection-owner-p (selection) diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index c736f694083..eadf0988805 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -1997,7 +1997,7 @@ With optional argument SEE-THRU set to non-nil, text in the buffer (aset artist-rb-save-data 6 0))) (defun artist-no-rb-unset-point2 () - "This function unsets point 2 when not rubber-banding." + "Unset point 2 when not rubber-banding." (if (= (aref artist-rb-save-data 6) 1) (let ((x-now (artist-current-column)) (y-now (artist-current-line)) @@ -2020,7 +2020,7 @@ With optional argument SEE-THRU set to non-nil, text in the buffer (aset artist-rb-save-data 6 1))) (defun artist-no-rb-unset-points () - "This function unsets point 1 and 2 when not rubber-banding." + "Unset point 1 and 2 when not rubber-banding." (artist-no-rb-unset-point1) (artist-no-rb-unset-point2)) diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index cbcea8af012..99a97c9bb8d 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -1377,6 +1377,12 @@ and must return a string (the key to use)." :version "28.1" :type 'function) +(defcustom bibtex-entry-ask-for-key t + "If non-nil, `bibtex-entry' asks for a key." + :group 'bibtex + :version "31.1" + :type 'boolean) + (defcustom bibtex-entry-offset 0 "Offset for BibTeX entries. Added to the value of all other variables which determine columns." @@ -3852,7 +3858,8 @@ is non-nil." (let ((completion-ignore-case t)) (list (completing-read "Entry Type: " bibtex-entry-alist nil t nil 'bibtex-entry-type-history)))) - (let ((key (if bibtex-maintain-sorted-entries + (let ((key (if (and bibtex-maintain-sorted-entries + bibtex-entry-ask-for-key) (bibtex-read-key (format "%s key: " entry-type)))) (field-list (bibtex-field-list entry-type))) (unless (bibtex-prepare-new-entry (list key nil entry-type)) diff --git a/lisp/textmodes/emacs-news-mode.el b/lisp/textmodes/emacs-news-mode.el index 6321bd8efad..bb514f462ea 100644 --- a/lisp/textmodes/emacs-news-mode.el +++ b/lisp/textmodes/emacs-news-mode.el @@ -247,7 +247,7 @@ untagged NEWS entry." (while (re-search-forward "'\\([^-][^ \t\n]+\\)'" nil t) ;; Filter out references to key sequences. (let ((string (match-string 1))) - (when-let ((symbol (intern-soft string))) + (when-let* ((symbol (intern-soft string))) (when (or (boundp symbol) (fboundp symbol)) (buttonize-region (match-beginning 1) (match-end 1) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 35550d1bbc4..404f682d379 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -3723,7 +3723,7 @@ If APPEND is non-nil, don't erase previous debugging output." (while cur (unless (string-prefix-p word (car cur)) (setcar cur (concat word (substring (car cur) len)))) - (while (when-let ((next (cadr cur))) + (while (when-let* ((next (cadr cur))) (not (string-prefix-p word next t))) (setcdr cur (cddr cur))) (setq cur (cdr cur))) diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el index adb06cb6a29..1435ea2c4e2 100644 --- a/lisp/textmodes/picture.el +++ b/lisp/textmodes/picture.el @@ -257,16 +257,23 @@ Use \"\\[command-apropos] picture-movement\" to see commands which control motio (> width 1) (< (abs picture-horizontal-step) 2)) (* picture-horizontal-step 2) - picture-horizontal-step))) + picture-horizontal-step)) + actual-col) (while (> arg 0) (setq arg (1- arg)) (if (/= picture-desired-column (current-column)) - (move-to-column picture-desired-column t)) - (let ((col (+ picture-desired-column width))) + (setq actual-col (move-to-column picture-desired-column t)) + (setq actual-col picture-desired-column)) + (let ((col (+ actual-col width))) (or (eolp) - (let ((pos (point))) - (move-to-column col t) - (let ((old-width (string-width (buffer-substring pos (point))))) + (let ((pos (point)) + (col0 (current-column)) + col1) + (setq col1 (move-to-column col t)) + ;; We count columns, not width, because move-to-column + ;; could insert TABs, which width depends on horizontal + ;; position. + (let ((old-width (- (max col0 col1) (min col0 col1)))) (delete-region pos (point)) (when (> old-width width) (insert-char ? (- old-width width)) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index 791b10412c9..aac735dc771 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -382,9 +382,6 @@ See also `reftex-toc-split-windows-horizontally'." :group 'reftex-table-of-contents-browser :type 'number) -(defvar reftex-toc-split-windows-horizontally-fraction 0.5 - "This variable is obsolete, use `reftex-toc-split-windows-fraction' instead.") - (defcustom reftex-toc-keep-other-windows t "Non-nil means, split the selected window to display the *toc* buffer. This helps to keep the window configuration, but makes the *toc* small. @@ -2112,6 +2109,9 @@ the following construct: \\bbb [xxx] {aaa}." :group 'reftex-miscellaneous-configurations :type 'hook) +(defvar reftex-toc-split-windows-horizontally-fraction 0.5) +(make-obsolete-variable 'reftex-toc-split-windows-horizontally-fraction + 'reftex-toc-split-windows-fraction "31.1") (provide 'reftex-vars) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index f126df8955a..fad7008adc0 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -533,6 +533,7 @@ an optional alist of possible values." "Add \"face\" tags with `facemenu-keymap' commands." (let ((tag-face (ensure-list (cdr (assq face sgml-face-tag-alist))))) (cond (tag-face + (require 'skeleton) (setq tag-face (funcall skeleton-transformation-function tag-face)) (setq facemenu-end-add-face (mapconcat (lambda (f) (concat "</" f ">")) (reverse tag-face))) @@ -851,6 +852,7 @@ If QUIET, do not print a message when there are no attributes for TAG." (setq alist (cons '("class") alist))) (unless (assoc-string "id" alist) (setq alist (cons '("id") alist)))) + (require 'skeleton) (if (stringp (car alist)) (progn (insert (if (eq (preceding-char) ?\s) "" ?\s) @@ -1203,7 +1205,7 @@ and move to the line in the SGML document that caused it." (or sgml-saved-validate-command (concat sgml-validate-command " " - (when-let ((name (buffer-file-name))) + (when-let* ((name (buffer-file-name))) (shell-quote-argument (file-name-nondirectory name)))))))) (setq sgml-saved-validate-command command) @@ -2434,14 +2436,14 @@ To work around that, do: (defun html-mode--complete-at-point () ;; Complete a tag like <colg etc. (or - (when-let ((tag (save-excursion - (and (looking-back "<\\([^ \t\n]*\\)" - (line-beginning-position)) - (match-string 1))))) + (when-let* ((tag (save-excursion + (and (looking-back "<\\([^ \t\n]*\\)" + (line-beginning-position)) + (match-string 1))))) (list (match-beginning 1) (point) (mapcar #'car html-tag-alist))) ;; Complete params like <colgroup ali etc. - (when-let ((tag (save-excursion (sgml-beginning-of-tag))) + (when-let* ((tag (save-excursion (sgml-beginning-of-tag))) (params (seq-filter #'consp (cdr (assoc tag html-tag-alist)))) (param (save-excursion (and (looking-back "[ \t\n]\\([^= \t\n]*\\)" @@ -2450,14 +2452,14 @@ To work around that, do: (list (match-beginning 1) (point) (mapcar #'car params))) ;; Complete param values like <colgroup align=mi etc. - (when-let ((tag (save-excursion (sgml-beginning-of-tag))) - (params (seq-filter #'consp (cdr (assoc tag html-tag-alist)))) - (param (save-excursion - (and (looking-back - "[ \t\n]\\([^= \t\n]+\\)=\\([^= \t\n]*\\)" - (line-beginning-position)) - (match-string 1)))) - (values (cdr (assoc param params)))) + (when-let* ((tag (save-excursion (sgml-beginning-of-tag))) + (params (seq-filter #'consp (cdr (assoc tag html-tag-alist)))) + (param (save-excursion + (and (looking-back + "[ \t\n]\\([^= \t\n]+\\)=\\([^= \t\n]*\\)" + (line-beginning-position)) + (match-string 1)))) + (values (cdr (assoc param params)))) (list (match-beginning 2) (point) (mapcar #'car values))))) @@ -2474,10 +2476,9 @@ To work around that, do: (when (and (file-exists-p file) (not (yes-or-no-p (format "%s exists; overwrite?" file)))) (user-error "%s exists" file)) - (with-temp-buffer - (set-buffer-multibyte nil) - (insert image) - (write-region (point-min) (point-max) file)) + (let ((coding-system-for-write 'emacs-internal)) + (with-temp-file file + (insert image))) (insert (format "<img src=%S>\n" (file-relative-name file))) (insert-image (create-image file (mailcap-mime-type-to-extension type) nil diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 6fc49800018..9cb95f59da4 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -310,7 +310,7 @@ Should be a simple file name with no extension or directory specification.") (defvar tex-print-file nil "File name that \\[tex-print] prints. -Set by \\[tex-region], \\[tex-buffer], and \\[tex-file].") +Set by \\[tex-region], \\[tex-buffer], \\[tex-file] and \\[tex-compile].") (defvar tex-mode-syntax-table (let ((st (make-syntax-table))) @@ -2212,6 +2212,8 @@ If NOT-ALL is non-nil, save the `.dvi' file." t "%r.dvi") ("xdvi %r &" "%r.dvi") ("\\doc-view \"%r.pdf\"" "%r.pdf") + ("evince %r.pdf &" "%r.pdf") + ("mupdf %r.pdf &" "%r.pdf") ("xpdf %r.pdf &" "%r.pdf") ("gv %r.ps &" "%r.ps") ("yap %r &" "%r.dvi") @@ -2530,6 +2532,7 @@ Only applies the FSPEC to the args part of FORMAT." (if (tex-shell-running) (tex-kill-job) (tex-start-shell)) + (setq tex-print-file (expand-file-name (tex-main-file))) (tex-send-tex-command cmd dir)))) (defun tex-start-tex (command file &optional dir) @@ -2749,9 +2752,9 @@ line LINE of the window, or centered if LINE is nil." (let ((tex-shell (get-buffer "*tex-shell*"))) (if (null tex-shell) (message "No TeX output buffer") - (when-let ((window - (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) - (display-buffer tex-shell display-tex-shell-buffer-action)))) + (when-let* ((window + (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) + (display-buffer tex-shell display-tex-shell-buffer-action)))) (with-selected-window window (bury-buffer tex-shell) (goto-char (point-max)) @@ -4003,12 +4006,12 @@ There might be text before point." (seq-union amalist extlist #'string-match-p)))) (setq tex--buffers-list bufs) (dolist (buf bufs) - (when-let ((fbuf (buffer-file-name buf)) - (ext (file-name-extension fbuf)) - (finext (concat "*." ext)) - ((not (seq-find (lambda (elt) (string-match-p elt finext)) - extlist-new))) - ((push finext extlist-new))))) + (when-let* ((fbuf (buffer-file-name buf)) + (ext (file-name-extension fbuf)) + (finext (concat "*." ext)) + ((not (seq-find (lambda (elt) (string-match-p elt finext)) + extlist-new))) + ((push finext extlist-new))))) (unless (seq-set-equal-p extlist-new extlist) (setf (alist-get mode semantic-symref-filepattern-alist) extlist-new)))) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 3cfd3905701..51b59ca50f4 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -408,7 +408,7 @@ E.g.: (defun thing-at-point-file-at-point (&optional _lax _bounds) "Return the name of the existing file at point." - (when-let ((filename (thing-at-point 'filename))) + (when-let* ((filename (thing-at-point 'filename))) (setq filename (expand-file-name filename)) (and (file-exists-p filename) filename))) @@ -423,7 +423,7 @@ E.g.: (defun thing-at-point-face-at-point (&optional _lax _bounds) "Return the name of the face at point as a symbol." - (when-let ((face (thing-at-point 'symbol))) + (when-let* ((face (thing-at-point 'symbol))) (and (facep face) (intern face)))) (put 'face 'thing-at-point 'thing-at-point-face-at-point) diff --git a/lisp/thread.el b/lisp/thread.el index 4c428f30f71..b1edf3e4678 100644 --- a/lisp/thread.el +++ b/lisp/thread.el @@ -126,7 +126,7 @@ other describing THREAD's blocker, if any." (cond ((not (thread-live-p thread)) '("Finished" "")) ((eq thread (current-thread)) '("Running" "")) - (t (if-let ((blocker (thread--blocker thread))) + (t (if-let* ((blocker (thread--blocker thread))) `("Blocked" ,(prin1-to-string blocker)) '("Yielded" ""))))) diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el index 8c28920d219..a02c1d4532d 100644 --- a/lisp/time-stamp.el +++ b/lisp/time-stamp.el @@ -5,8 +5,8 @@ ;; This file is part of GNU Emacs. -;; Maintainer: Stephen Gildea <stepheng+emacs@gildea.com> -;; Keywords: tools +;; Author: Stephen Gildea <stepheng+emacs@gildea.com> +;; Keywords: files, tools ;; 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 @@ -25,20 +25,19 @@ ;; A template in a file can be updated with a new time stamp when ;; you save the file. For example: -;; static char *ts = "sdmain.c Time-stamp: <2020-04-18 14:10:21 gildea>"; +;; static char *ts = "sdmain.c Time-stamp: <2024-04-18 14:10:21 gildea>"; ;; To use time-stamping, add this line to your init file: ;; (add-hook 'before-save-hook 'time-stamp) ;; Now any time-stamp templates in your files will be updated automatically. -;; See the documentation for the functions `time-stamp' -;; and `time-stamp-toggle-active' for details. +;; See the documentation for the function `time-stamp' for details. ;;; Code: (defgroup time-stamp nil "Maintain last change time stamps in files edited by Emacs." - :group 'data + :group 'files :group 'extensions) @@ -47,34 +46,34 @@ This is a string, used verbatim except for character sequences beginning with %, as follows. -%:A weekday name: `Monday' %#A gives uppercase: `MONDAY' -%3a abbreviated weekday: `Mon' %#a gives uppercase: `MON' -%:B month name: `January' %#B gives uppercase: `JANUARY' -%3b abbreviated month: `Jan' %#b gives uppercase: `JAN' -%02d day of month -%02H 24-hour clock hour -%02I 12-hour clock hour -%02m month number -%02M minute -%#p `am' or `pm' %P gives uppercase: `AM' or `PM' -%02S seconds -%w day number of week, Sunday is 0 -%02y 2-digit year %Y 4-digit year -%Z time zone name: `EST' %#Z gives lowercase: `est' -%5z time zone offset: `-0500' (since Emacs 27; see note below) +%:A weekday name: `Monday' %#A gives uppercase: `MONDAY' +%3a abbreviated weekday: `Mon' %#a gives uppercase: `MON' +%:B month name: `January' %#B gives uppercase: `JANUARY' +%3b abbreviated month: `Jan' %#b gives uppercase: `JAN' +%02d day of month +%02H 24-hour clock hour +%02I 12-hour clock hour +%02m month number +%02M minute +%#p `am' or `pm' %P gives uppercase: `AM' or `PM' +%02S seconds +%w day number of week, Sunday is 0 +%02y 2-digit year %Y 4-digit year +%Z time zone name: `EST' %#Z gives lowercase: `est' +%5z time zone offset: `-0500' (since Emacs 27; see note below) Non-date items: -%% a literal percent character: `%' -%f file name without directory %F absolute file name -%l login name %L full name of logged-in user -%q unqualified host name %Q fully-qualified host name -%h mail host name +%% a literal percent character: `%' +%f file name without directory %F absolute file name +%l login name %L full name of logged-in user +%q unqualified host name %Q fully-qualified host name +%h mail host name Decimal digits between the % and the type character specify the field width. Strings are truncated on the right. A leading zero in the field width zero-fills a number. -For example, to get the format used by the `date' command, +For example, to get a common format used by the `date' command, use \"%3a %3b %2d %02H:%02M:%02S %Z %Y\". The values of non-numeric formatted items depend on the locale @@ -224,7 +223,7 @@ for generating repeated time stamps. These variables are best changed with file-local variables. If you were to change `time-stamp-end' or `time-stamp-inserts-lines' in your init file, you would be incompatible with other people's files.") -;;;###autoload(put 'time-stamp-inserts-lines 'safe-local-variable 'symbolp) +;;;###autoload(put 'time-stamp-inserts-lines 'safe-local-variable 'booleanp) (defvar time-stamp-count 1 ;Do not change! @@ -266,20 +265,22 @@ If you were to change `time-stamp-pattern', `time-stamp-line-limit', `time-stamp-start', or `time-stamp-end' in your init file, you would be incompatible with other people's files. -See also `time-stamp-count' and `time-stamp-inserts-lines'. - Examples: -\"-10/\" (sets only `time-stamp-line-limit') +;; time-stamp-pattern: \"-10/\" + (sets only `time-stamp-line-limit') + +// time-stamp-pattern: \"-9/^Last modified: %%$\" + (sets `time-stamp-line-limit', `time-stamp-start' and `time-stamp-end') -\"-9/^Last modified: %%$\" (sets `time-stamp-line-limit', -`time-stamp-start' and `time-stamp-end') +@c time-stamp-pattern: \"@set Time-stamp: %:B %1d, %Y$\" + (sets `time-stamp-start', `time-stamp-format' and `time-stamp-end') -\"@set Time-stamp: %:B %1d, %Y$\" (sets `time-stamp-start', -`time-stamp-format' and `time-stamp-end') +%% time-stamp-pattern: \"newcommand{\\\\\\\\timestamp}{%%}\" + (sets `time-stamp-start'and `time-stamp-end') -\"newcommand{\\\\\\\\timestamp}{%%}\" (sets `time-stamp-start' -and `time-stamp-end')") + +See also `time-stamp-count' and `time-stamp-inserts-lines'.") ;;;###autoload(put 'time-stamp-pattern 'safe-local-variable 'stringp) @@ -287,8 +288,8 @@ and `time-stamp-end')") ;;;###autoload (defun time-stamp () "Update any time stamp string(s) in the buffer. -This function looks for a time stamp template and updates it with -the current date, time, and/or other info. +Look for a time stamp template and update it with the current date, +time, and/or other info. The template, which you manually create on one of the first 8 lines of the file before running this function, by default can look like @@ -297,7 +298,7 @@ one of the following (your choice): Time-stamp: \" \" This function writes the current time between the brackets or quotes, by default formatted like this: - Time-stamp: <2020-08-07 17:10:21 gildea> + Time-stamp: <2024-08-07 17:10:21 gildea> Although you can run this function manually to update a time stamp once, usually you want automatic time stamp updating. @@ -311,7 +312,7 @@ To enable automatic time-stamping for only a specific file, add this line to a local variables list near the end of the file: eval: (add-hook \\='before-save-hook \\='time-stamp nil t) -If the file has no time-stamp template, this function does nothing. +If the file has no time stamp template, this function does nothing. You can set `time-stamp-pattern' in a file's local variables list to customize the information in the time stamp and where it is written. @@ -419,7 +420,7 @@ Returns the end point, which is where `time-stamp' begins the next search." (cond ((not time-stamp-active) (if time-stamp-warn-inactive - ;; don't signal an error in a write-file-hook + ;; don't signal an error in a hook (progn (message "Warning: time-stamp-active is off; did not time-stamp buffer.") (sit-for 1)))) @@ -518,7 +519,8 @@ and all `time-stamp-format' compatibility." (setq cur-char (if (< ind fmt-len) (aref format ind) ?\0)) - (or (eq ?. cur-char) + (or (eq ?. cur-char) (eq ?* cur-char) + (eq ?E cur-char) (eq ?O cur-char) (eq ?, cur-char) (eq ?: cur-char) (eq ?@ cur-char) (eq ?- cur-char) (eq ?+ cur-char) (eq ?_ cur-char) (eq ?\s cur-char) (eq ?# cur-char) (eq ?^ cur-char) @@ -601,12 +603,18 @@ and all `time-stamp-format' compatibility." (time-stamp-do-number cur-char alt-form field-width time)) ((eq cur-char ?M) ;minute, 0-59 (time-stamp-do-number cur-char alt-form field-width time)) - ((eq cur-char ?p) ;am or pm + ((eq cur-char ?p) ;AM or PM (if change-case - (time-stamp--format "%#p" time) - (time-stamp--format "%p" time))) + (time-stamp--format "%#p" time) + (if upcase + (time-stamp--format "%^p" time) + (time-stamp--format "%p" time)))) ((eq cur-char ?P) ;AM or PM - (time-stamp--format "%p" time)) + (if change-case + (time-stamp--format "%#p" time) + (if upcase + "" ;discourage inconsistent "%^P" + (time-stamp--format "%p" time)))) ((eq cur-char ?S) ;seconds, 00-60 (time-stamp-do-number cur-char alt-form field-width time)) ((eq cur-char ?w) ;weekday number, Sunday is 0 @@ -801,6 +809,8 @@ Suggests replacing OLD-FORM with NEW-FORM." ;; - The %_z format always outputs seconds, allowing all added padding ;; to be spaces. Without this rule, there would be no way to ;; request seconds that worked for both 2- and 3-digit hours. +;; (We consider 3-digit hours not because such offsets are in use but +;; instead to guide our design toward consistency and extensibility.) ;; - Conflicting options are rejected, lest users depend ;; on incidental behavior. ;; @@ -843,7 +853,7 @@ Suggests replacing OLD-FORM with NEW-FORM." colon-count field-width offset-secs) - "Formats a time offset according to a %z variation. + "Format a time offset according to a %z variation. With no flags, the output includes hours and minutes: +-HHMM unless there is a non-zero seconds part, in which case the seconds diff --git a/lisp/time.el b/lisp/time.el index 47d6b4a705d..3bb34657e07 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -548,7 +548,7 @@ If the value is t instead of an alist, use the value of (defun world-clock-copy-time-as-kill () "Copy current line into the kill ring." (interactive nil world-clock-mode) - (when-let ((str (buffer-substring-no-properties (pos-bol) (pos-eol)))) + (when-let* ((str (buffer-substring-no-properties (pos-bol) (pos-eol)))) (kill-new str) (message str))) @@ -598,7 +598,7 @@ See `world-clock'." The variable `world-clock-list' specifies which time zones to use. To turn off the world time display, go to the window and type \\[quit-window]." (interactive) - (if-let ((buffer (get-buffer world-clock-buffer-name))) + (if-let* ((buffer (get-buffer world-clock-buffer-name))) (pop-to-buffer buffer) (pop-to-buffer world-clock-buffer-name) (when world-clock-timer-enable diff --git a/lisp/tmm.el b/lisp/tmm.el index ed74c307009..632e55e47a8 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -82,15 +82,12 @@ or else the correct item might not be found in the `*Completions*' buffer." :type '(choice (const :tag "No shortcuts" nil) string)) -(defvar tmm-mb-map nil - "A place to store minibuffer map.") - (defcustom tmm-completion-prompt - "Press PageUp key to reach this buffer from the minibuffer. -Alternatively, you can use Up/Down keys (or your History keys) to change + "Press M-v/PageUp key to reach this buffer from the minibuffer. +Alternatively, You can use Up/Down keys (or your History keys) to change the item in the minibuffer, and press RET when you are done, or press -the marked letters to pick up your choice. Type ^ to go to the parent -menu. Type C-g or ESC ESC ESC to cancel. +the %s to pick up your choice. +Type ^ to go to the parent menu. Type C-g or ESC ESC ESC to cancel. " "Help text to insert on the top of the completion buffer. To save space, you can set this to nil, @@ -111,6 +108,13 @@ If you use only one of `downcase' or `upcase' for `tmm-shortcut-style', specify nil for this variable." :type '(choice integer (const nil))) +(defcustom tmm-shortcut-inside-entry nil + "Highlight the shortcut character in the menu entry's string. +When non-nil, the first menu-entry's character that acts as a shortcut +is displayed with the `highlight' face to help identify it. The +`tmm-mid-prompt' string is not used then." + :type 'boolean) + (defface tmm-inactive '((t :inherit shadow)) "Face used for inactive menu items.") @@ -201,7 +205,8 @@ is used to go back through those sub-menus." (setq tail (cdr tail))))) (let ((prompt (concat "^" - (if (stringp tmm-mid-prompt) + (if (and (stringp tmm-mid-prompt) + (not tmm-shortcut-inside-entry)) (concat "." (regexp-quote tmm-mid-prompt)))))) (setq tmm--history @@ -286,7 +291,7 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (t (let* ((str (car elt)) (paren (string-search "(" str)) - (pos 0) (word 0) char) + (word 0) pos char) (catch 'done ; ??? is this slow? (while (and (or (not tmm-shortcut-words) ; no limit on words (< word tmm-shortcut-words)) ; try n words @@ -302,17 +307,40 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (if (not (memq char tmm-short-cuts)) (throw 'done char)))) (setq word (1+ word)) (setq pos (match-end 0))) + ;; A nil value for pos means that the shortcut is not inside the + ;; string of the menu entry. + (setq pos nil) (while (<= tmm-next-shortcut-digit ?9) ; no letter shortcut, pick a digit (setq char tmm-next-shortcut-digit) (setq tmm-next-shortcut-digit (1+ tmm-next-shortcut-digit)) (if (not (memq char tmm-short-cuts)) (throw 'done char))) (setq char nil)) (if char (setq tmm-short-cuts (cons char tmm-short-cuts))) - (cons (concat (if char (concat (char-to-string char) tmm-mid-prompt) - ;; keep them lined up in columns - (make-string (1+ (length tmm-mid-prompt)) ?\s)) - str) - (cdr elt)))))) + (cons + (if tmm-shortcut-inside-entry + (if char + (if pos + ;; A character inside the menu entry. + (let ((res (copy-sequence str))) + (aset res pos char) + (add-text-properties pos (1+ pos) '(face highlight) res) + res) + ;; A fallback digit character: place it in front of the + ;; menu entry. + (concat (propertize (char-to-string char) 'face 'highlight) + " " str)) + (make-string 2 ?\s)) + (concat (if char (concat (char-to-string char) tmm-mid-prompt) + ;; Keep them lined up in columns. + (make-string (1+ (length tmm-mid-prompt)) ?\s)) + str)) + (cdr elt)))))) + +(defun tmm-clear-self-insert-and-exit () + "Clear the minibuffer contents then self insert and exit." + (interactive) + (delete-minibuffer-contents) + (self-insert-and-exit)) ;; This returns the old map. (defun tmm-define-keys (minibuffer) @@ -325,14 +353,14 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." ;; downcase input to the same (define-key map (char-to-string (downcase c)) 'tmm-shortcut) (define-key map (char-to-string (upcase c)) 'tmm-shortcut))) - (if minibuffer - (progn - (define-key map [pageup] 'tmm-goto-completions) - (define-key map [prior] 'tmm-goto-completions) - (define-key map "\ev" 'tmm-goto-completions) - (define-key map "\C-n" 'next-history-element) - (define-key map "\C-p" 'previous-history-element) - (define-key map "^" 'self-insert-and-exit))) + (when minibuffer + (define-key map [pageup] 'tmm-goto-completions) + (define-key map [prior] 'tmm-goto-completions) + (define-key map "\ev" 'tmm-goto-completions) + (define-key map "\C-n" 'next-history-element) + (define-key map "\C-p" 'previous-history-element) + ;; Previous menu shortcut (see `tmm-prompt'). + (define-key map "^" 'tmm-clear-self-insert-and-exit)) (prog1 (current-local-map) (use-local-map (append map (current-local-map)))))) @@ -387,7 +415,12 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (let ((inhibit-read-only t) (window (get-buffer-window "*Completions*"))) (goto-char (point-min)) - (insert tmm-completion-prompt) + (insert + (if tmm-shortcut-inside-entry + (format tmm-completion-prompt + (concat (propertize "highlighted" 'face 'highlight) " character")) + (format tmm-completion-prompt + (concat "character right before '" tmm-mid-prompt "' ")))) (when window ;; Try to show everything just inserted and preserve height of ;; *Completions* window. This should fix a behavior described @@ -409,23 +442,26 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (choose-completion)) ;; In minibuffer (delete-region (minibuffer-prompt-end) (point-max)) - (dolist (elt tmm-km-list) - (if (string= - (substring (car elt) 0 - (min (1+ (length tmm-mid-prompt)) - (length (car elt)))) - (concat (char-to-string c) tmm-mid-prompt)) - (setq s (car elt)))) + (dolist (elt tmm-km-list) + (let ((str (car elt)) + (index 0)) + (when tmm-shortcut-inside-entry + (if (get-char-property 0 'face str) + (setq index 0) + (let ((next (next-single-char-property-change 0 'face str))) + (setq index (if (= (length str) next) 0 next))))) + (if (= (aref str index) c) + (setq s str)))) (insert s) (exit-minibuffer))))) (defun tmm-goto-completions () "Jump to the completions buffer." (interactive) - (let ((prompt-end (minibuffer-prompt-end))) - (setq tmm-c-prompt (buffer-substring prompt-end (point-max))) - ;; FIXME: Why? - (delete-region prompt-end (point-max))) + (setq tmm-c-prompt (buffer-substring (minibuffer-prompt-end) (point-max))) + ;; Clear minibuffer old contents before using *Completions* buffer for + ;; selection. + (delete-minibuffer-contents) (switch-to-buffer-other-window "*Completions*") (search-forward tmm-c-prompt) (search-backward tmm-c-prompt)) @@ -487,13 +523,20 @@ It uses the free variable `tmm-table-undef' to keep undefined keys." (when binding (setq binding (key-description binding)) ;; Try to align the keybindings. - (let ((colwidth (min 30 (- (/ (window-width) 2) 10)))) + (let* ((window (get-buffer-window "*Completions*")) + (colwidth (min 30 (- (/ (if window + (window-width window) + (frame-width)) + 2) + 10))) + (nspaces (max 2 (- colwidth + (string-width str) + (string-width binding))))) (setq str (concat str - (make-string (max 2 (- colwidth - (string-width str) - (string-width binding))) - ?\s) + (propertize (make-string nspaces ?\s) + 'display + (cons 'space (list :width nspaces))) binding))))))) (and km (stringp km) (setq str km)) ;; Verify that the command is enabled; diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index d8e9dc2d791..677360b2ed4 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -1759,8 +1759,8 @@ functions undertaking event management themselves to call ;; The positions of tools currently pressed against the screen ;; have changed. If there is a tool being tracked as part of a ;; gesture, look it up in the list of tools. - (if-let ((new-point (assq (car touch-screen-current-tool) - (cadr event)))) + (if-let* ((new-point (assq (car touch-screen-current-tool) + (cadr event)))) (if touch-screen-aux-tool (touch-screen-handle-aux-point-update (cdr new-point) (car new-point)) diff --git a/lisp/transient.el b/lisp/transient.el index 41515f6616e..0f53fee3c0e 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -1060,7 +1060,7 @@ commands are aliases for." (when (eq (car-safe (car args)) 'declare) (setq declare (car args)) (setq args (cdr args)) - (when-let ((int (assq 'interactive-only declare))) + (when-let* ((int (assq 'interactive-only declare))) (setq interactive-only (cadr int)) (delq int declare)) (unless (cdr declare) @@ -1184,7 +1184,7 @@ commands are aliases for." (setq args (plist-put args :argument (cadr arg))) (setq arg (cadr arg))) (string - (when-let ((shortarg (transient--derive-shortarg arg))) + (when-let* ((shortarg (transient--derive-shortarg arg))) (setq args (plist-put args :shortarg shortarg))) (setq args (plist-put args :argument arg)))) (setq sym (intern (format "transient:%s:%s" prefix arg))) @@ -1221,7 +1221,7 @@ commands are aliases for." (setq args (plist-put args key (macroexp-quote val)))) ((setq args (plist-put args key val))))))) (unless (plist-get args :key) - (when-let ((shortarg (plist-get args :shortarg))) + (when-let* ((shortarg (plist-get args :shortarg))) (setq args (plist-put args :key shortarg)))) (list 'list (or level transient--default-child-level) @@ -1371,7 +1371,7 @@ LOC is a command, a key vector, a key description (a string as returned by `key-description'), or a coordination list (whose last element may also be a command or key). See info node `(transient)Modifying Existing Transients'." - (if-let ((mem (transient--layout-member loc prefix))) + (if-let* ((mem (transient--layout-member loc prefix))) (car mem) (error "%s not found in %s" loc prefix))) @@ -1907,9 +1907,9 @@ of the corresponding object." (error "Cannot bind %S to %s and also %s" (string-trim key) cmd alt)) ((define-key map kbd cmd)))))) - (when-let ((b (keymap-lookup map "-"))) (keymap-set map "<kp-subtract>" b)) - (when-let ((b (keymap-lookup map "="))) (keymap-set map "<kp-equal>" b)) - (when-let ((b (keymap-lookup map "+"))) (keymap-set map "<kp-add>" b)) + (when-let* ((b (keymap-lookup map "-"))) (keymap-set map "<kp-subtract>" b)) + (when-let* ((b (keymap-lookup map "="))) (keymap-set map "<kp-equal>" b)) + (when-let* ((b (keymap-lookup map "+"))) (keymap-set map "<kp-add>" b)) (when transient-enable-popup-navigation ;; `transient--make-redisplay-map' maps only over bindings that are ;; directly in the base keymap, so that cannot be a composed keymap. @@ -2135,7 +2135,7 @@ value. Otherwise return CHILDREN as is." (apply class :level level args) (unless (and cmd (symbolp cmd)) (error "BUG: Non-symbolic suffix command: %s" cmd)) - (if-let ((proto (and cmd (transient--suffix-prototype cmd)))) + (if-let* ((proto (and cmd (transient--suffix-prototype cmd)))) (apply #'clone proto :level level args) (apply class :command cmd :level level args))))) (cond ((not cmd)) @@ -2166,7 +2166,7 @@ value. Otherwise return CHILDREN as is." (if (transient-switches--eieio-childp obj) (cl-call-next-method obj) (unless (slot-boundp obj 'shortarg) - (when-let ((shortarg (transient--derive-shortarg (oref obj argument)))) + (when-let* ((shortarg (transient--derive-shortarg (oref obj argument)))) (oset obj shortarg shortarg))) (unless (slot-boundp obj 'key) (if (slot-boundp obj 'shortarg) @@ -2367,7 +2367,7 @@ value. Otherwise return CHILDREN as is." ((and transient--prefix transient--redisplay-key) (setq transient--redisplay-key nil) (when transient--showp - (if-let ((win (minibuffer-selected-window))) + (if-let* ((win (minibuffer-selected-window))) (with-selected-window win (transient--show)) (transient--show))))) @@ -2439,7 +2439,7 @@ value. Otherwise return CHILDREN as is." (advice-eval-interactive-spec spec)) (setq abort nil)) (when abort - (when-let ((unwind (oref prefix unwind-suffix))) + (when-let* ((unwind (oref prefix unwind-suffix))) (transient--debug 'unwind-interactive) (funcall unwind suffix)) (advice-remove suffix advice) @@ -2447,7 +2447,7 @@ value. Otherwise return CHILDREN as is." (unwind-protect (let ((debugger #'transient--exit-and-debug)) (apply fn args)) - (when-let ((unwind (oref prefix unwind-suffix))) + (when-let* ((unwind (oref prefix unwind-suffix))) (transient--debug 'unwind-command) (funcall unwind suffix)) (advice-remove suffix advice) @@ -2622,7 +2622,7 @@ exit." ;;; Pre-Commands (defun transient--call-pre-command () - (if-let ((fn (transient--get-pre-command this-command))) + (if-let* ((fn (transient--get-pre-command this-command))) (let ((action (funcall fn))) (when (eq action transient--exit) (setq transient--exitp (or transient--exitp t))) @@ -2718,7 +2718,7 @@ If there is no parent prefix, then just call the command." (defun transient--setup-recursion (prefix-obj) (when transient--stack (let ((command (oref prefix-obj command))) - (when-let ((suffix-obj (transient-suffix-object command))) + (when-let* ((suffix-obj (transient-suffix-object command))) (when (memq (if (slot-boundp suffix-obj 'transient) (oref suffix-obj transient) (oref transient-current-prefix transient-suffix)) @@ -2827,8 +2827,8 @@ prefix argument and pivot to `transient-update'." ;; `this-command' is `transient-undefined' or `transient-inapt'. ;; Show the command (`this-original-command') the user actually ;; tried to invoke. - (if-let ((cmd (or (ignore-errors (symbol-name this-original-command)) - (ignore-errors (symbol-name this-command))))) + (if-let* ((cmd (or (ignore-errors (symbol-name this-original-command)) + (ignore-errors (symbol-name this-command))))) (format " [%s]" (propertize cmd 'face 'font-lock-warning-face)) "")) (unless (and transient--transient-map @@ -3125,7 +3125,7 @@ Otherwise call the primary method according to object's class." (if (slot-boundp obj 'value) (oref obj value) (oset obj value - (if-let ((saved (assq (oref obj command) transient-values))) + (if-let* ((saved (assq (oref obj command) transient-values))) (cdr saved) (transient-default-value obj))))) @@ -3161,8 +3161,8 @@ Otherwise call the primary method according to object's class." nil) (cl-defmethod transient-default-value ((obj transient-prefix)) - (if-let ((default (and (slot-boundp obj 'default-value) - (oref obj default-value)))) + (if-let* ((default (and (slot-boundp obj 'default-value) + (oref obj default-value)))) (if (functionp default) (funcall default) default) @@ -3267,7 +3267,7 @@ it\", in which case it is pointless to preserve history.)" The last value is \"don't use any of these switches\"." (let ((choices (mapcar (apply-partially #'format (oref obj argument-format)) (oref obj choices)))) - (if-let ((value (oref obj value))) + (if-let* ((value (oref obj value))) (cadr (member value choices)) (car choices)))) @@ -3275,7 +3275,7 @@ The last value is \"don't use any of these switches\"." "Elsewhere use the reader of the infix command COMMAND. Use this if you want to share an infix's history with a regular stand-alone command." - (if-let ((obj (transient--suffix-prototype command))) + (if-let* ((obj (transient--suffix-prototype command))) (cl-letf (((symbol-function #'transient--show) #'ignore)) (transient-infix-read obj)) (error "Not a suffix command: `%s'" command))) @@ -3351,7 +3351,7 @@ command-line option) or \": \". Finally fall through to using \"(BUG: no prompt): \" as the prompt." - (if-let ((prompt (oref obj prompt))) + (if-let* ((prompt (oref obj prompt))) (let ((prompt (if (functionp prompt) (funcall prompt obj) prompt))) @@ -3644,7 +3644,7 @@ have a history of their own.") (transient--insert-groups) (when (or transient--helpp transient--editp) (transient--insert-help)) - (when-let ((line (transient--separator-line))) + (when-let* ((line (transient--separator-line))) (insert line))) (unless (window-live-p transient--window) (setq transient--window @@ -3705,8 +3705,8 @@ have a history of their own.") (cl-defmethod transient--insert-group :around ((group transient-group)) "Insert GROUP's description, if any." - (when-let ((desc (transient-with-shadowed-buffer - (transient-format-description group)))) + (when-let* ((desc (transient-with-shadowed-buffer + (transient-format-description group)))) (insert desc ?\n)) (let ((transient--max-group-level (max (oref group level) transient--max-group-level)) @@ -3839,7 +3839,7 @@ as a button." "Format OBJ's `key' for display and return the result." (let ((key (if (slot-boundp obj 'key) (oref obj key) "")) (cmd (and (slot-boundp obj 'command) (oref obj command)))) - (when-let ((width (oref transient--pending-group pad-keys))) + (when-let* ((width (oref transient--pending-group pad-keys))) (setq key (truncate-string-to-width key width nil ?\s))) (if transient--redisplay-key (let ((len (length transient--redisplay-key)) @@ -3937,7 +3937,7 @@ apply the face `transient-unreachable' to the complete string." (funcall (oref transient--prefix suffix-description) obj))))) (if desc - (when-let ((face (transient--get-face obj 'face))) + (when-let* ((face (transient--get-face obj 'face))) (setq desc (transient--add-face desc face t))) (setq desc (propertize "(BUG: no description)" 'face 'error))) (when (if transient--all-levels-p @@ -3946,8 +3946,8 @@ apply the face `transient-unreachable' to the complete string." (> (max (oref obj level) transient--max-group-level) transient--default-prefix-level))) (setq desc (transient--add-face desc 'transient-higher-level))) - (when-let ((inapt-face (and (oref obj inapt) - (transient--get-face obj 'inapt-face)))) + (when-let* ((inapt-face (and (oref obj inapt) + (transient--get-face obj 'inapt-face)))) (setq desc (transient--add-face desc inapt-face))) (when (and (slot-boundp obj 'key) (transient--key-unreachable-p obj)) @@ -3965,7 +3965,7 @@ apply the face `transient-unreachable' to the complete string." (cl-defmethod transient-format-value ((obj transient-option)) (let ((argument (oref obj argument))) - (if-let ((value (oref obj value))) + (if-let* ((value (oref obj value))) (pcase-exhaustive (oref obj multi-value) ('nil (concat (propertize argument 'face 'transient-argument) @@ -4047,8 +4047,8 @@ apply the face `transient-unreachable' to the complete string." (and val (not (integerp val)) val))) (defun transient--maybe-pad-keys (group &optional parent) - (when-let ((pad (or (oref group pad-keys) - (and parent (oref parent pad-keys))))) + (when-let* ((pad (or (oref group pad-keys) + (and parent (oref parent pad-keys))))) (oset group pad-keys (apply #'max (if (integerp pad) pad 0) @@ -4098,7 +4098,7 @@ that, else its name. Intended to be temporarily used as the `:suffix-description' of a prefix command, while porting a regular keymap to a transient." (let ((command (oref obj command))) - (if-let ((doc (documentation command))) + (if-let* ((doc (documentation command))) (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face) (propertize (symbol-name command) 'face 'font-lock-function-name-face)))) @@ -4129,7 +4129,7 @@ prefix method." 'transient--prefix))) (and prefix (not (eq (oref transient--prefix command) this-command)) (prog1 t (transient-show-help prefix))))) - ((if-let ((show-help (oref obj show-help))) + ((if-let* ((show-help (oref obj show-help))) (funcall show-help obj) (transient--describe-function this-command))))) @@ -4137,11 +4137,11 @@ prefix method." "Call `show-help' if non-nil, else show the `man-page' if non-nil, else use `describe-function'. When showing the manpage, then try to jump to the correct location." - (if-let ((show-help (oref obj show-help))) + (if-let* ((show-help (oref obj show-help))) (funcall show-help obj) - (if-let ((man-page (oref transient--prefix man-page)) - (argument (and (slot-boundp obj 'argument) - (oref obj argument)))) + (if-let* ((man-page (oref transient--prefix man-page)) + (argument (and (slot-boundp obj 'argument) + (oref obj argument)))) (transient--show-manpage man-page argument) (transient--describe-function this-command)))) diff --git a/lisp/treesit.el b/lisp/treesit.el index 6046563ae3e..6f5d065cc24 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -150,7 +150,7 @@ In a multi-language buffer, make sure `treesit-language-at' wouldn't return the correct result." (if treesit-language-at-point-function (funcall treesit-language-at-point-function position) - (when-let ((parser (car (treesit-parser-list)))) + (when-let* ((parser (car (treesit-parser-list)))) (treesit-parser-language parser)))) ;;; Node API supplement @@ -198,9 +198,9 @@ unless PARSER-OR-LANG is a parser, or PARSER-OR-LANG is a language and doesn't match the language of the local parser." (let* ((root (if (treesit-parser-p parser-or-lang) (treesit-parser-root-node parser-or-lang) - (or (when-let ((parser - (car (treesit-local-parsers-at - pos parser-or-lang)))) + (or (when-let* ((parser + (car (treesit-local-parsers-at + pos parser-or-lang)))) (treesit-parser-root-node parser)) (treesit-buffer-root-node (or parser-or-lang @@ -256,10 +256,10 @@ parser first." (let* ((lang-at-point (treesit-language-at beg)) (root (if (treesit-parser-p parser-or-lang) (treesit-parser-root-node parser-or-lang) - (or (when-let ((parser - (car (treesit-local-parsers-on - beg end (or parser-or-lang - lang-at-point))))) + (or (when-let* ((parser + (car (treesit-local-parsers-on + beg end (or parser-or-lang + lang-at-point))))) (treesit-parser-root-node parser)) (treesit-buffer-root-node (or parser-or-lang lang-at-point)))))) @@ -294,11 +294,11 @@ Use the first parser in the parser list if LANGUAGE is omitted. If LANGUAGE is non-nil, use the first parser for LANGUAGE with TAG in the parser list, or create one if none exists. TAG defaults to nil." - (if-let ((parser - (if language - (treesit-parser-create language nil nil tag) - (or (car (treesit-parser-list)) - (signal 'treesit-no-parser (list (current-buffer))))))) + (if-let* ((parser + (if language + (treesit-parser-create language nil nil tag) + (or (car (treesit-parser-list)) + (signal 'treesit-no-parser (list (current-buffer))))))) (treesit-parser-root-node parser))) (defun treesit-filter-child (node pred &optional named) @@ -382,8 +382,8 @@ If NAMED is non-nil, count named child only." (defun treesit-node-field-name (node) "Return the field name of NODE as a child of its parent." - (when-let ((parent (treesit-node-parent node)) - (idx (treesit-node-index node))) + (when-let* ((parent (treesit-node-parent node)) + (idx (treesit-node-index node))) (treesit-node-field-name-for-child parent idx))) (defun treesit-node-get (node instructions) @@ -678,8 +678,8 @@ instead. HOST-PARSER is the host parser which created the local PARSER." (let ((res nil)) (dolist (ov (overlays-at (or pos (point)))) - (when-let ((parser (overlay-get ov 'treesit-parser)) - (host-parser (overlay-get ov 'treesit-host-parser))) + (when-let* ((parser (overlay-get ov 'treesit-parser)) + (host-parser (overlay-get ov 'treesit-host-parser))) (when (or (null language) (eq (treesit-parser-language parser) language)) @@ -700,8 +700,8 @@ instead. HOST-PARSER is the host parser which created the local PARSER." (let ((res nil)) (dolist (ov (overlays-in (or beg (point-min)) (or end (point-max)))) - (when-let ((parser (overlay-get ov 'treesit-parser)) - (host-parser (overlay-get ov 'treesit-host-parser))) + (when-let* ((parser (overlay-get ov 'treesit-parser)) + (host-parser (overlay-get ov 'treesit-host-parser))) (when (or (null language) (eq (treesit-parser-language parser) language)) @@ -715,10 +715,10 @@ For every local parser overlay between BEG and END, if its `treesit-parser-ov-timestamp' is smaller than MODIFIED-TICK, delete it." (dolist (ov (overlays-in beg end)) - (when-let ((ov-timestamp - (overlay-get ov 'treesit-parser-ov-timestamp))) + (when-let* ((ov-timestamp + (overlay-get ov 'treesit-parser-ov-timestamp))) (when (< ov-timestamp modified-tick) - (when-let ((local-parser (overlay-get ov 'treesit-parser))) + (when-let* ((local-parser (overlay-get ov 'treesit-parser))) (treesit-parser-delete local-parser)) (delete-overlay ov))))) @@ -1143,7 +1143,7 @@ signals the `treesit-font-lock-error' error if that happens. If LANGUAGE is non-nil, only compute features for that language, and leave settings for other languages unchanged." - (when-let ((intersection (cl-intersection add-list remove-list))) + (when-let* ((intersection (cl-intersection add-list remove-list))) (signal 'treesit-font-lock-error (list "ADD-LIST and REMOVE-LIST contain the same feature" intersection))) @@ -1392,7 +1392,7 @@ If LOUDLY is non-nil, display some debugging information." (setq treesit--font-lock-fast-mode nil)))) ;; Only activate if ENABLE flag is t. - (when-let + (when-let* ((activate (eq t enable)) (nodes (if (eq t treesit--font-lock-fast-mode) (mapcan @@ -2335,8 +2335,8 @@ friends." (if (= arg -1) (cons (treesit-node-start prev) (treesit-node-end prev)) - (when-let ((n (treesit-node-child - parent (+ arg (treesit-node-index prev t)) t))) + (when-let* ((n (treesit-node-child + parent (+ arg (treesit-node-index prev t)) t))) (cons (treesit-node-end n) (treesit-node-start n)))) (loop (treesit-node-next-sibling prev t) @@ -2834,7 +2834,9 @@ is `nested'. Return nil if `treesit-defun-type-regexp' isn't set and `defun' isn't defined in `treesit-thing-settings'." - (when (or treesit-defun-type-regexp (treesit-thing-defined-p 'defun)) + (when (or treesit-defun-type-regexp + (treesit-thing-defined-p + 'defun (treesit-language-at (point)))) (treesit-thing-at-point (or treesit-defun-type-regexp 'defun) treesit-defun-tactic))) @@ -2858,7 +2860,7 @@ The delimiter between nested defun names is controlled by (let ((node (treesit-defun-at-point)) (name nil)) (while node - (when-let ((new-name (treesit-defun-name node))) + (when-let* ((new-name (treesit-defun-name node))) (if name (setq name (concat new-name treesit-add-log-defun-delimiter @@ -3091,7 +3093,7 @@ If `treesit-defun-name-function' is non-nil, set up If `treesit-simple-imenu-settings' is non-nil, set up Imenu. If either `treesit-outline-predicate' or `treesit-simple-imenu-settings' -are non-nil, and Outline minor mode settings don't alreay exist, setup +are non-nil, and Outline minor mode settings don't already exist, setup Outline minor mode. If `sexp', `sentence' are defined in `treesit-thing-settings', @@ -3175,7 +3177,7 @@ before calling this function." ;; Remove existing local parsers. (dolist (ov (overlays-in (point-min) (point-max))) - (when-let ((parser (overlay-get ov 'treesit-parser))) + (when-let* ((parser (overlay-get ov 'treesit-parser))) (treesit-parser-delete parser) (delete-overlay ov)))) @@ -3397,9 +3399,9 @@ in the region." (when (and top-level (not highlight-only)) (erase-buffer) (treesit--explorer-draw-node top-level)) - (when-let ((pos (treesit--explorer-highlight-node nodes-hl)) - (window (get-buffer-window - treesit--explorer-buffer))) + (when-let* ((pos (treesit--explorer-highlight-node nodes-hl)) + (window (get-buffer-window + treesit--explorer-buffer))) (if highlight-only (goto-char pos) ;; If HIGHLIGHT-ONLY is nil, we erased the buffer and @@ -3700,26 +3702,26 @@ nil, the grammar is installed to the standard location, the "Language: " (mapcar #'car treesit-language-source-alist))) 'interactive)) - (when-let ((recipe - (or (assoc lang treesit-language-source-alist) - (if (eq out-dir 'interactive) - (treesit--install-language-grammar-build-recipe - lang) - (signal 'treesit-error `("Cannot find recipe for this language" ,lang))))) - (default-out-dir - (or (car treesit--install-language-grammar-out-dir-history) - (locate-user-emacs-file "tree-sitter"))) - (out-dir - (if (eq out-dir 'interactive) - (read-string - (format "Install to (default: %s): " - default-out-dir) - nil - 'treesit--install-language-grammar-out-dir-history - default-out-dir) - ;; When called non-interactively, OUT-DIR should - ;; default to DEFAULT-OUT-DIR. - (or out-dir default-out-dir)))) + (when-let* ((recipe + (or (assoc lang treesit-language-source-alist) + (if (eq out-dir 'interactive) + (treesit--install-language-grammar-build-recipe + lang) + (signal 'treesit-error `("Cannot find recipe for this language" ,lang))))) + (default-out-dir + (or (car treesit--install-language-grammar-out-dir-history) + (locate-user-emacs-file "tree-sitter"))) + (out-dir + (if (eq out-dir 'interactive) + (read-string + (format "Install to (default: %s): " + default-out-dir) + nil + 'treesit--install-language-grammar-out-dir-history + default-out-dir) + ;; When called non-interactively, OUT-DIR should + ;; default to DEFAULT-OUT-DIR. + (or out-dir default-out-dir)))) (condition-case err (progn (apply #'treesit--install-language-grammar-1 diff --git a/lisp/url/url.el b/lisp/url/url.el index 2bf62d7cfbb..253d2ecfe72 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -259,9 +259,9 @@ how long to wait for a response before giving up." (url-debug 'retrieval "Spinning in url-retrieve-synchronously: nil (%S)" proc-buffer) - (when-let ((redirect-buffer - (buffer-local-value 'url-redirect-buffer - proc-buffer))) + (when-let* ((redirect-buffer + (buffer-local-value 'url-redirect-buffer + proc-buffer))) (unless (eq redirect-buffer proc-buffer) (url-debug 'retrieval "Redirect in url-retrieve-synchronously: %S -> %S" @@ -270,7 +270,7 @@ how long to wait for a response before giving up." (kill-buffer proc-buffer)) ;; Accommodate hack in commit 55d1d8b. (setq proc-buffer redirect-buffer))) - (when-let ((proc (get-buffer-process proc-buffer))) + (when-let* ((proc (get-buffer-process proc-buffer))) (when (memq (process-status proc) '(closed exit signal failed)) ;; Process sentinel vagaries occasionally cause diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 7ec394a263d..9dcc8c89526 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -246,7 +246,11 @@ when this variable is set to nil.") (defvar log-edit-initial-files nil) (defvar log-edit-callback nil) (defvar log-edit-diff-function - (lambda () (error "Diff functionality has not been setup"))) + (lambda () (error "Diff functionality has not been set up")) + "Function to display an appropriate `diff-mode' buffer for the change. +Called by the `log-edit-show-diff' command. +Should not leave the `diff-mode' buffer's window selected; that is, the +Log Edit buffer's window should be selected when the function returns.") (defvar log-edit-listfun nil) (defvar log-edit-parent-buffer nil) diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 647a7dc569f..a54854a7016 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -550,6 +550,21 @@ If called interactively, visit the version at point." (rev (log-view-current-tag)) ;; `log-view-extract-comment' is the legacy code for this; the ;; `get-change-comment' backend action is the new way to do it. + ;; + ;; FIXME: Eventually the older backends should have + ;; implementations of `get-change-comment' because that ought + ;; to be more robust than the approach taken by + ;; `log-view-extract-comment'. Then we can delete the latter. + ;; See discussion in bug#64055. --spwhitton + ;; + ;; FIXME: We should implement backend actions + ;; `get-change-comment' and `modify-change-comment' for bzr and + ;; Hg, so that this command works for those backends. + ;; As discussed in bug#64055, `get-change-comment' is required, + ;; and parsing the old comment out of the Log View buffer will + ;; not do. This is because for these backends there are + ;; `vc-*-log-switches' variables which can change what gets put + ;; in the Log View buffers and break any Lisp parsing attempt. (comment (condition-case _ (vc-call-backend log-view-vc-backend 'get-change-comment files rev) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index aad3e302826..09d9ebda21b 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -168,6 +168,10 @@ Used in `smerge-diff-base-upper' and related functions." (const :tag "none" "") string)) +;; Make it so `C-c ^ n' doesn't insert `n' but just signals an error +;; when SMerge mode is not enabled (bug#73544). +;;;###autoload (global-set-key "\C-c^" (make-sparse-keymap)) + (defvar-keymap smerge-mode-map (key-description smerge-command-prefix) smerge-basic-map) @@ -1240,7 +1244,7 @@ spacing of the \"Lower\" chunk." (write-region beg2 end2 file2 nil 'nomessage) (unwind-protect (save-current-buffer - (if-let (buffer (get-buffer smerge-diff-buffer-name)) + (if-let* ((buffer (get-buffer smerge-diff-buffer-name))) (set-buffer buffer) (set-buffer (get-buffer-create smerge-diff-buffer-name)) (setq buffer-read-only t)) diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index d733b36f8ff..4e1b1831389 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1456,9 +1456,9 @@ These are the commands available for use in the file status buffer: (let ((use-vc-backend backend)) (vc-dir-mode) ;; Activate the backend-specific minor mode, if any. - (when-let ((minor-mode - (intern-soft (format "vc-dir-%s-mode" - (downcase (symbol-name backend)))))) + (when-let* ((minor-mode + (intern-soft (format "vc-dir-%s-mode" + (downcase (symbol-name backend)))))) (funcall minor-mode 1))))) (defun vc-default-dir-extra-headers (_backend _dir) diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 36456fdb2e2..c4a2b252cb0 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -460,7 +460,7 @@ Display the buffer in some window, but don't select it." args)))) (setq proc (apply #'vc-do-command t 'async command nil args)))) (unless vc--inhibit-async-window - (when-let ((window (display-buffer buffer))) + (when-let* ((window (display-buffer buffer))) (set-window-start window new-window-start))) proc)) @@ -685,10 +685,12 @@ NOT-URGENT means it is ok to continue if the user says not to save." ;; Set up key bindings for use while editing log messages (declare-function log-edit-empty-buffer-p "log-edit" ()) +(declare-function log-edit-diff-fileset "log-edit" ()) +(declare-function log-edit-diff-patch "log-edit" ()) (defvar vc-patch-string) -(defun vc-log-edit (fileset mode backend) +(defun vc-log-edit (fileset mode backend &optional diff-function) "Set up `log-edit' for use on FILE." (setq default-directory (buffer-local-value 'default-directory vc-parent-buffer)) @@ -718,7 +720,9 @@ NOT-URGENT means it is ok to continue if the user says not to save." (lambda (file) (file-relative-name file root)) fileset)))) (log-edit-diff-function - . ,(if vc-patch-string 'log-edit-diff-patch 'log-edit-diff-fileset)) + . ,(cond (diff-function) + (vc-patch-string #'log-edit-diff-patch) + (t #'log-edit-diff-fileset))) (log-edit-vc-backend . ,backend) (vc-log-fileset . ,fileset) (vc-patch-string . ,vc-patch-string)) @@ -727,7 +731,7 @@ NOT-URGENT means it is ok to continue if the user says not to save." (set-buffer-modified-p nil) (setq buffer-file-name nil)) -(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook backend patch-string) +(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook backend patch-string diff-function) "Accept a comment for an operation on FILES. If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the action on close to ACTION. If COMMENT is a string and @@ -740,7 +744,8 @@ empty comment. Remember the file's buffer in `vc-parent-buffer' MODE, defaulting to `log-edit-mode' if MODE is nil. AFTER-HOOK specifies the local value for `vc-log-after-operation-hook'. BACKEND, if non-nil, specifies a VC backend for the Log Edit buffer. -PATCH-STRING is a patch to check in." +PATCH-STRING is a patch to check in. +DIFF-FUNCTION is `log-edit-diff-function' for the Log Edit buffer." (let ((parent (if (and (length= files 1) (not (vc-dispatcher-browsing))) (get-file-buffer (car files)) @@ -755,7 +760,7 @@ PATCH-STRING is a patch to check in." (concat " from " (buffer-name vc-parent-buffer))) (when patch-string (setq-local vc-patch-string patch-string)) - (vc-log-edit files mode backend) + (vc-log-edit files mode backend diff-function) (make-local-variable 'vc-log-after-operation-hook) (when after-hook (setq vc-log-after-operation-hook after-hook)) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index f77bf0cc5ff..c3a9fb0f99a 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -168,10 +168,10 @@ uses a full scan)." (defcustom vc-git-resolve-conflicts t "When non-nil, mark conflicted file as resolved upon saving. -That is performed after all conflict markers in it have been -removed. If the value is `unstage-maybe', and no merge is in -progress, then after the last conflict is resolved, also clear -the staging area." +That is performed after all conflict markers in it have been removed. +If the value is `unstage-maybe', and no merge, rebase or similar +operation is in progress, then after the last conflict is resolved, also +clear the staging area." :type '(choice (const :tag "Don't resolve" nil) (const :tag "Resolve" t) (const :tag "Resolve and maybe unstage all files" @@ -728,21 +728,23 @@ or an empty string if none." :files files :update-function update-function))) +(defun vc-git--current-branch () + (vc-git--out-match '("symbolic-ref" "HEAD") + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + (defun vc-git-dir--branch-headers () "Return headers for branch-related information." - (let ((branch (vc-git--out-match - '("symbolic-ref" "HEAD") - "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + (let ((branch (vc-git--current-branch)) tracking remote-url) (if branch - (when-let ((branch-merge - (vc-git--out-match - `("config" ,(concat "branch." branch ".merge")) - "^\\(refs/heads/\\)?\\(.+\\)$" 2)) - (branch-remote - (vc-git--out-match - `("config" ,(concat "branch." branch ".remote")) - "\\([^\n]+\\)" 1))) + (when-let* ((branch-merge + (vc-git--out-match + `("config" ,(concat "branch." branch ".merge")) + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + (branch-remote + (vc-git--out-match + `("config" ,(concat "branch." branch ".remote")) + "\\([^\n]+\\)" 1))) (if (string= branch-remote ".") (setq tracking branch-merge remote-url "none (tracking local branch)") @@ -764,6 +766,10 @@ or an empty string if none." (let ((gitdir (vc-git--git-path)) cmds) ;; See contrib/completion/git-prompt.sh in git.git. + (when (file-exists-p (expand-file-name "REVERT_HEAD" gitdir)) + (push 'revert cmds)) + (when (file-exists-p (expand-file-name "CHERRY_PICK_HEAD" gitdir)) + (push 'cherry-pick cmds)) (when (or (file-directory-p (expand-file-name "rebase-merge" gitdir)) (file-exists-p @@ -875,7 +881,7 @@ or an empty string if none." (list (concat (propertize "Stash : " 'face 'vc-dir-header) - (if-let ((stash-list (vc-git-stash-list))) + (if-let* ((stash-list (vc-git-stash-list))) (let* ((len (length stash-list)) (limit (if (integerp vc-git-show-stash) @@ -1038,6 +1044,7 @@ See `vc-git-log-edit-summary-max-len'.") "Toggle whether this will amend the previous commit. If toggling on, also insert its message into the buffer." (interactive) + (vc-git--assert-allowed-rewrite (vc-git--rev-parse "HEAD")) (log-edit--toggle-amend (lambda () (vc-git-get-change-comment nil "HEAD")))) @@ -1049,19 +1056,19 @@ If toggling on, also insert its message into the buffer." (defun vc-git--log-edit-summary-check (limit) (and (re-search-forward "^Summary: " limit t) - (when-let ((regex - (cond ((and (natnump vc-git-log-edit-summary-max-len) - (natnump vc-git-log-edit-summary-target-len)) - (format ".\\{,%d\\}\\(.\\{,%d\\}\\)\\(.*\\)" - vc-git-log-edit-summary-target-len - (- vc-git-log-edit-summary-max-len - vc-git-log-edit-summary-target-len))) - ((natnump vc-git-log-edit-summary-max-len) - (format ".\\{,%d\\}\\(?2:.*\\)" - vc-git-log-edit-summary-max-len)) - ((natnump vc-git-log-edit-summary-target-len) - (format ".\\{,%d\\}\\(.*\\)" - vc-git-log-edit-summary-target-len))))) + (when-let* ((regex + (cond ((and (natnump vc-git-log-edit-summary-max-len) + (natnump vc-git-log-edit-summary-target-len)) + (format ".\\{,%d\\}\\(.\\{,%d\\}\\)\\(.*\\)" + vc-git-log-edit-summary-target-len + (- vc-git-log-edit-summary-max-len + vc-git-log-edit-summary-target-len))) + ((natnump vc-git-log-edit-summary-max-len) + (format ".\\{,%d\\}\\(?2:.*\\)" + vc-git-log-edit-summary-max-len)) + ((natnump vc-git-log-edit-summary-target-len) + (format ".\\{,%d\\}\\(.*\\)" + vc-git-log-edit-summary-target-len))))) (re-search-forward regex limit t)))) (define-derived-mode vc-git-log-edit-mode log-edit-mode "Log-Edit/git" @@ -1082,6 +1089,17 @@ It is based on `log-edit-mode', and has Git-specific extensions." (autoload 'vc-switches "vc") +(defun vc-git--log-edit-extract-headers (comment) + (cl-flet ((boolean-arg-fn (argument) + (lambda (v) (and (equal v "yes") (list argument))))) + (log-edit-extract-headers + `(("Author" . "--author") + ("Date" . "--date") + ("Amend" . ,(boolean-arg-fn "--amend")) + ("No-Verify" . ,(boolean-arg-fn "--no-verify")) + ("Sign-Off" . ,(boolean-arg-fn "--signoff"))) + comment))) + (defun vc-git-checkin (files comment &optional _rev) (let* ((file1 (or (car files) default-directory)) (root (vc-git-root file1)) @@ -1180,31 +1198,23 @@ It is based on `log-edit-mode', and has Git-specific extensions." (vc-git-command nil 0 patch-file "apply" "--cached") (delete-file patch-file)))) (when to-stash (vc-git--stash-staged-changes files))) - (cl-flet ((boolean-arg-fn - (argument) - (lambda (value) (when (equal value "yes") (list argument))))) - ;; When operating on the whole tree, better pass "-a" than ".", since "." - ;; fails when we're committing a merge. - (apply #'vc-git-command nil 0 (if (and only (not vc-git-patch-string)) files) - (nconc (if msg-file (list "commit" "-F" - (file-local-name msg-file)) - (list "commit" "-m")) - (let ((args - (log-edit-extract-headers - `(("Author" . "--author") - ("Date" . "--date") - ("Amend" . ,(boolean-arg-fn "--amend")) - ("No-Verify" . ,(boolean-arg-fn "--no-verify")) - ("Sign-Off" . ,(boolean-arg-fn "--signoff"))) - comment))) - (when msg-file - (let ((coding-system-for-write - (or pcsw vc-git-commits-coding-system))) - (write-region (car args) nil msg-file)) - (setq args (cdr args))) - args) - (unless vc-git-patch-string - (if only (list "--only" "--") '("-a")))))) + ;; When operating on the whole tree, better pass "-a" than ".", + ;; since "." fails when we're committing a merge. + (apply #'vc-git-command nil 0 + (if (and only (not vc-git-patch-string)) files) + (nconc (if msg-file (list "commit" "-F" + (file-local-name msg-file)) + (list "commit" "-m")) + (let ((args + (vc-git--log-edit-extract-headers comment))) + (when msg-file + (let ((coding-system-for-write + (or pcsw vc-git-commits-coding-system))) + (write-region (car args) nil msg-file)) + (setq args (cdr args))) + args) + (unless vc-git-patch-string + (if only (list "--only" "--") '("-a"))))) (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)) (when to-stash (let ((cached (make-nearby-temp-file "git-cached"))) @@ -1413,8 +1423,14 @@ This prompts for a branch to merge from." (vc-git-command nil 0 buffer-file-name "add") (unless (or (not (eq vc-git-resolve-conflicts 'unstage-maybe)) - ;; Doing a merge, so bug#20292 doesn't apply. - (file-exists-p (vc-git--git-path "MERGE_HEAD")) + ;; Doing a merge or rebase-like operation, so bug#20292 + ;; doesn't apply. + ;; + ;; If we were to 'git reset' in the middle of a + ;; cherry-pick, for example, it would effectively abort + ;; the cherry-pick, losing the user's progress. + (cl-intersection '(merge rebase am revert cherry-pick) + (vc-git--cmds-in-progress)) (vc-git-conflicted-files (vc-git-root buffer-file-name))) (vc-git-command nil 0 nil "reset")) (vc-resynch-buffer buffer-file-name t t) @@ -1960,6 +1976,90 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (vc-git-command standard-output 1 nil "log" "--max-count=1" "--pretty=format:%B" rev))) +(defun vc-git--assert-allowed-rewrite (rev) + (when (and (not (and vc-allow-rewriting-published-history + (not (eq vc-allow-rewriting-published-history 'ask)))) + ;; Check there is an upstream. + (with-temp-buffer + (vc-git--out-ok "config" "--get" + (format "branch.%s.merge" + (vc-git--current-branch))))) + (let ((outgoing (split-string + (with-output-to-string + (vc-git-command standard-output 0 nil "log" + "--pretty=format:%H" + "@{upstream}..HEAD"))))) + (unless (or (cl-member rev outgoing :test #'string-prefix-p) + (and (eq vc-allow-rewriting-published-history 'ask) + (yes-or-no-p + (format "\ +Commit %s appears published; allow rewriting history?" + rev)))) + (user-error "\ +Will not rewrite likely-public history; see option `vc-allow-rewriting-published-history'"))))) + +(defun vc-git-modify-change-comment (files rev comment) + (vc-git--assert-allowed-rewrite rev) + (let* ((args (delete "--amend" + (vc-git--log-edit-extract-headers comment))) + (message (format "amend! %s\n\n%s" rev (pop args))) + (msg-file + ;; On MS-Windows, pass the message through a file, to work + ;; around how command line arguments must be in the system + ;; codepage, and therefore might not support non-ASCII. + ;; + ;; As our other arguments are static, we need not be concerned + ;; about the encoding of command line arguments in general. + ;; See `vc-git-checkin' for the more complex case. + (and (eq system-type 'windows-nt) + (let ((default-directory + (or (file-name-directory (or (car files) + default-directory)) + default-directory))) + (make-nearby-temp-file "git-msg"))))) + (unwind-protect + (progn + (when (cl-intersection '("--author" "--date") args + :test #'string=) + ;; 'git rebase --autosquash' cannot alter authorship. + ;; See the description of --fixup in git-commit(1). + (error +"Author: and Date: not supported when modifying existing commits")) + + ;; Check that a rebase with --autosquash won't make changes + ;; other than to REV's change comment. With the prompt here + ;; it's okay to assume the user knows what --autosquash is + ;; because they've made some squash!/fixup!/amend! commits. + (when + (and (split-string + (with-output-to-string + (vc-git-command standard-output 0 nil + "log" "--oneline" "-E" + "--grep" "^(squash|fixup|amend)! " + (format "%s~1.." rev)))) + (not (yes-or-no-p "\ +Rebase may --autosquash your other squash!/fixup!/amend!; proceed?"))) + (user-error "Aborted")) + + (when msg-file + (let ((coding-system-for-write + (or coding-system-for-write + vc-git-commits-coding-system))) + (write-region message nil msg-file))) + ;; Regardless of the state of the index and working tree, this + ;; will always create an empty commit, thanks to --only. + (apply #'vc-git-command nil 0 nil + "commit" "--only" "--allow-empty" + (nconc (if msg-file + (list "-F" (file-local-name msg-file)) + (list "-m" message)) + args))) + (when (and msg-file (file-exists-p msg-file)) + (delete-file msg-file)))) + (with-environment-variables (("GIT_SEQUENCE_EDITOR" "true")) + (vc-git-command nil 0 nil "rebase" "--autostash" "--autosquash" "-i" + (format "%s~1" rev)))) + (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] @@ -2077,36 +2177,60 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir)))))) +(declare-function vc-deduce-fileset "vc" + (&optional observer allow-unregistered + state-model-only-files)) + (autoload 'vc-dir-marked-files "vc-dir") +(defun vc-git--deduce-files-for-stash () + ;; In *vc-dir*, if nothing is marked, act on the whole working tree + ;; regardless of the position of point. This preserves historical + ;; behavior and is also probably more useful. + (if (derived-mode-p 'vc-dir-mode) + (vc-dir-marked-files) + (cadr (vc-deduce-fileset)))) + (defun vc-git-stash (name) - "Create a stash given the name NAME." + "Create a stash named NAME. +In `vc-dir-mode', if there are files marked, stash the changes to those. +If no files are marked, stash all uncommitted changes to tracked files. +In other modes, call `vc-deduce-fileset' to determine files to stash." (interactive "sStash name: ") (let ((root (vc-git-root default-directory))) (when root (apply #'vc-git--call nil "stash" "push" "-m" name - (when (derived-mode-p 'vc-dir-mode) - (vc-dir-marked-files))) + (vc-git--deduce-files-for-stash)) (vc-resynch-buffer root t t)))) (defvar vc-git-stash-read-history nil "History for `vc-git-stash-read'.") -(defun vc-git-stash-read (prompt) - "Read a Git stash. PROMPT is a string to prompt with." - (let ((stash (completing-read - prompt - (split-string - (or (vc-git--run-command-string nil "stash" "list") "") "\n" t) - nil :require-match nil 'vc-git-stash-read-history))) - (if (string-equal stash "") - (user-error "Not a stash") - (string-match "^stash@{[[:digit:]]+}" stash) - (match-string 0 stash)))) +(cl-defun vc-git-stash-read (prompt &key default-most-recent) + "Prompt the user, with PROMPT, to select a git stash. +PROMPT is passed to `format-prompt'. If DEFAULT-MOST-RECENT is non-nil, +then the most recently pushed stash is the default selection." + (if-let* ((stashes + (split-string (vc-git--run-command-string nil + "stash" "list") + "\n" t))) + (let* ((default (and default-most-recent (car stashes))) + (prompt (format-prompt prompt + (and default-most-recent + "most recent, stash@{0}"))) + (stash (completing-read prompt stashes + nil :require-match nil + 'vc-git-stash-read-history + default))) + (if (string-empty-p stash) + (user-error "Not a stash") + (string-match "^stash@{[[:digit:]]+}" stash) + (match-string 0 stash))) + (user-error "No stashes"))) (defun vc-git-stash-show (name) "Show the contents of stash NAME." - (interactive (list (vc-git-stash-read "Show stash: "))) + (interactive (list (vc-git-stash-read "Show stash"))) (vc-setup-buffer "*vc-git-stash*") (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "--color=never" "-p" name) @@ -2117,32 +2241,39 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (defun vc-git-stash-apply (name) "Apply stash NAME." - (interactive (list (vc-git-stash-read "Apply stash: "))) + (interactive (list (vc-git-stash-read "Apply stash"))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-pop (name) "Pop stash NAME." - (interactive (list (vc-git-stash-read "Pop stash: "))) + ;; Stashes are commonly popped off in reverse order, so pass non-nil + ;; DEFAULT-MOST-RECENT to `vc-git-stash-read'. + (interactive (list (vc-git-stash-read "Pop stash" + :default-most-recent t))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-delete (name) "Delete stash NAME." - (interactive (list (vc-git-stash-read "Delete stash: "))) + (interactive (list (vc-git-stash-read "Delete stash"))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "drop" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-snapshot () - "Create a stash with the current tree state." + "Create a stash with the current uncommitted changes. +In `vc-dir-mode', if there are files marked, stash the changes to those. +If no files are marked, stash all uncommitted changes to tracked files. +In other modes, call `vc-deduce-fileset' to determine files to stash." (interactive) - (vc-git--call nil "stash" "save" - (format-time-string "Snapshot on %Y-%m-%d at %H:%M")) + (apply #'vc-git--call nil "stash" "push" "-m" + (format-time-string "Snapshot on %Y-%m-%d at %H:%M") + (vc-git--deduce-files-for-stash)) (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}") (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-list () - (when-let ((out (vc-git--run-command-string nil "stash" "list"))) + (when-let* ((out (vc-git--run-command-string nil "stash" "list"))) (split-string (replace-regexp-in-string "^stash@" " " out) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 9fb1fc6c4a4..dd6079d22ab 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -914,6 +914,91 @@ is sensitive to blank lines." :type 'boolean :version "27.1") +;; The default is nil because only a VC user who also possesses a lot of +;; knowledge specific to the VCS in use can know when it is okay to +;; rewrite history, and we can't convey to a user who is relatively +;; naïve regarding the VCS in use the potential risks in only the space +;; of a minibuffer yes/no prompt. +;; +;; See `vc-git--assert-allowed-rewrite' for an example of how to use +;; this variable in VCS backend code. +(defcustom vc-allow-rewriting-published-history nil + "When non-nil, permit VCS operations that may rewrite published history. + +Many VCS commands can change your copy of published change history +without warning. If this occurs, you won't be able to pull and push in +the ordinary way until you take special action. For example, for Git, +see \"Recovering from Upstream Rebase\" in the Man page git-rebase(1). + +Normally, Emacs refuses to run VCS commands that it thinks will rewrite +published history. If you customize this variable to `ask', Emacs will +instead prompt you to confirm that you really want to perform the +rewrite. Any other non-nil value means to proceed with no prompting. + +We recommend customizing this variable to `ask' or leaving it nil, +because if published history is rewritten unexpectedly it can be fairly +time-consuming to recover. Only customize this variable to a non-nil +value other than `ask' if you have a strong grasp of the VCS in use." + :type '(choice (const :tag "Don't allow" nil) + (const :tag "Prompt to allow" ask) + (const :tag "Allow without prompting" t)) + :version "31.1") + +(defconst vc-cloneable-backends-custom-type + `(choice :convert-widget + ,(lambda (widget) + (let (opts) + (dolist (be vc-handled-backends) + (when (or (vc-find-backend-function be 'clone) + (alist-get 'clone (get be 'vc-functions))) + (push (widget-convert (list 'const be)) opts))) + (widget-put widget :args opts)) + widget)) + "The type of VC backends that support cloning VCS repositories.") + +(defcustom vc-clone-heuristic-alist + `((,(rx bos "http" (? "s") "://" + (or (: (? "www.") "github.com" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "codeberg.org" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: (? "www.") "gitlab" (+ "." (+ alnum)) + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" + (or "r" "git") "/" + (+ (or alnum "-" "." "_")) (? "/"))) + (or (? "/") ".git") eos) + . Git) + (,(rx bos "http" (? "s") "://" + (or (: "hg.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Hg) + (,(rx bos "http" (? "s") "://" + (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Bzr)) + "Alist mapping repository URLs to VC backends. +`vc-clone' consults this alist to determine the VC +backend from the repository URL when you call it without +specifying a backend. Each element of the alist has the form +\(URL-REGEXP . BACKEND). `vc-clone' will use BACKEND of +the first association for which the URL of the repository matches +the URL-REGEXP of the association." + :type `(alist :key-type (regexp :tag "Regular expression matching URLs") + :value-type ,vc-cloneable-backends-custom-type) + :version "31.1") + ;; File property caching @@ -1003,6 +1088,13 @@ use." (vc-call-backend bk 'create-repo)) (throw 'found bk)))) +(defun vc-guess-url-backend (url) + "Guess the VC backend for URL. +This function will internally query `vc-clone-heuristic-alist' +and return nil if it cannot reasonably guess." + (and url (alist-get url vc-clone-heuristic-alist + nil nil #'string-match-p))) + ;;;###autoload (defun vc-responsible-backend (file &optional no-error) "Return the name of a backend system that is responsible for FILE. @@ -1028,8 +1120,8 @@ responsible for the given file." (dirs (delq nil (mapcar (lambda (backend) - (when-let ((dir (vc-call-backend - backend 'responsible-p file))) + (when-let* ((dir (vc-call-backend + backend 'responsible-p file))) ;; We run DIR through `expand-file-name' ;; so that abbreviated directories, such ;; as "~/", wouldn't look "less specific" @@ -1646,6 +1738,8 @@ Type \\[vc-next-action] to check in changes.") (format "%d files" (length files)) "this file")))) +(declare-function mail-text "sendmail" ()) +(declare-function message-goto-body "message" (&optional interactive)) (defun vc-steal-lock (file rev owner) "Steal the lock on FILE." (let (file-description) @@ -1666,7 +1760,10 @@ Type \\[vc-next-action] to check in changes.") ;; goes wrong, we don't want to send any mail. (compose-mail owner (format "Stolen lock on %s" file-description)) (setq default-directory (expand-file-name "~/")) - (goto-char (point-max)) + (cond + ((eq mail-user-agent 'sendmail-user-agent) + (mail-text)) + ((message-goto-body))) (insert (format "I stole the lock on %s, " file-description) (current-time-string) @@ -1904,7 +2001,7 @@ in the output buffer." (setq-local revert-buffer-function (lambda (_ _) (vc-diff-patch-string patch-string))) (setq-local vc-patch-string patch-string) - (pop-to-buffer (current-buffer)) + (display-buffer (current-buffer)) (vc-run-delayed (vc-diff-finish (current-buffer) nil)))) (defun vc-diff-internal (async vc-fileset rev1 rev2 &optional verbose buffer) @@ -2144,7 +2241,7 @@ deduced fileset." (defun vc-buffer-sync-fileset (fileset not-urgent) (dolist (filename (cadr fileset)) - (when-let ((buffer (find-buffer-visiting filename))) + (when-let* ((buffer (find-buffer-visiting filename))) (with-current-buffer buffer (vc-buffer-sync not-urgent))))) @@ -2425,8 +2522,30 @@ the variable `vc-BACKEND-header'." (lambda () (vc-call-backend backend 'log-edit-mode)) (lambda (files comment) (vc-call-backend backend - 'modify-change-comment files rev comment)) - nil backend))) + 'modify-change-comment files rev comment) + ;; We are now back in `vc-parent-buffer'. + ;; If this is Log View, then revision IDs might now be + ;; out-of-date, which could be hazardous if the user immediately + ;; tries to use `log-view-modify-change-comment' a second time. + ;; E.g. with Git, `vc-git-modify-change-comment' could create an + ;; "amend!" commit referring to a commit which no longer exists + ;; on the branch, such that it wouldn't be autosquashed. + ;; So refresh the view. + (when (derived-mode-p 'log-view-mode) + (revert-buffer))) + nil backend nil + (lambda () + ;; Here we want the root diff for REV, even if we were called + ;; from a buffer generated by C-x v l, because the change comment + ;; we will edit applies to the whole revision. + (let* ((rootdir + (vc-call-backend backend 'root default-directory)) + (prevrev + (vc-call-backend backend + 'previous-revision rootdir rev))) + (save-selected-window + (vc-diff-internal nil (list backend (list rootdir)) + prevrev rev))))))) ;;;###autoload (defun vc-merge () @@ -3784,30 +3903,54 @@ to provide the `find-revision' operation instead." (interactive) (vc-call-backend (vc-backend buffer-file-name) 'check-headers)) -(defun vc-clone (remote &optional backend directory rev) +(defvar vc--remotes-history) + +(defun vc-clone (remote &optional backend directory rev open-dir) "Clone repository REMOTE using version-control BACKEND, into DIRECTORY. If successful, return the string with the directory of the checkout; otherwise return nil. REMOTE should be a string, the URL of the remote repository or the name of a directory (if the repository is local). + +When called interactively, prompt for REMOTE, BACKEND and DIRECTORY, +except attempt to determine BACKEND automatically based on REMOTE. + If DIRECTORY is nil or omitted, it defaults to `default-directory'. If BACKEND is nil or omitted, the function iterates through every known backend in `vc-handled-backends' until one succeeds to clone REMOTE. If REV is non-nil, it indicates a specific revision to check out after -cloning; the syntax of REV depends on what BACKEND accepts." - (setq directory (expand-file-name (or directory default-directory))) - (if backend - (progn - (unless (memq backend vc-handled-backends) - (error "Unknown VC backend %s" backend)) - (vc-call-backend backend 'clone remote directory rev)) - (catch 'ok - (dolist (backend vc-handled-backends) - (ignore-error vc-not-supported - (when-let ((res (vc-call-backend - backend 'clone - remote directory rev))) - (throw 'ok res))))))) +cloning; the syntax of REV depends on what BACKEND accepts. +If OPEN-DIR is non-nil, as it is interactively, also switches to a +buffer visiting DIRECTORY." + (interactive + (let* ((url (read-string "Remote: " nil 'vc--remotes-history)) + (backend (or (vc-guess-url-backend url) + (intern (completing-read + "Backend: " vc-handled-backends nil t))))) + (list url backend + (read-directory-name + "Clone into new or empty directory: " nil nil + (lambda (dir) (or (not (file-exists-p dir)) + (directory-empty-p dir)))) + nil t))) + (let* ((directory (expand-file-name (or directory default-directory))) + (backend (or backend (vc-guess-url-backend remote))) + (directory (if backend + (progn + (unless (memq backend vc-handled-backends) + (error "Unknown VC backend %s" backend)) + (vc-call-backend backend 'clone remote directory rev)) + (catch 'ok + (dolist (backend vc-handled-backends) + (ignore-error vc-not-supported + (when-let* ((res (vc-call-backend + backend 'clone + remote directory rev))) + (throw 'ok res)))))))) + (when (file-directory-p directory) + (when open-dir + (find-file directory)) + directory))) (declare-function log-view-current-tag "log-view" (&optional pos)) (defun vc-default-last-change (_backend file line) diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el index 76276c0f474..b6117960bf7 100644 --- a/lisp/visual-wrap.el +++ b/lisp/visual-wrap.el @@ -117,9 +117,9 @@ extra indent = 2 "Apply visual-wrapping properties to the logical line starting at POSITION." (save-excursion (goto-char position) - (when-let ((first-line-prefix (fill-match-adaptive-prefix)) - (next-line-prefix (visual-wrap--content-prefix - first-line-prefix position))) + (when-let* ((first-line-prefix (fill-match-adaptive-prefix)) + (next-line-prefix (visual-wrap--content-prefix + first-line-prefix position))) (when (numberp next-line-prefix) ;; Set a minimum width for the prefix so it lines up correctly ;; with subsequent lines. Make sure not to do this past the end @@ -165,9 +165,12 @@ PREFIX was empty." ;; first-line prefix. (let ((avg-space (propertize (buffer-substring position (1+ position)) 'display '(space :width 1)))) - (max (string-width prefix) - (ceiling (string-pixel-width prefix (current-buffer)) - (string-pixel-width avg-space (current-buffer)))))))) + ;; Remove any `min-width' display specs since we'll replace with + ;; our own later in `visual-wrap--apply-to-line' (bug#73882). + (add-display-text-property 0 (length prefix) 'min-width nil prefix) + (max (string-width prefix) + (ceiling (string-pixel-width prefix (current-buffer)) + (string-pixel-width avg-space (current-buffer)))))))) (defun visual-wrap-fill-context-prefix (beg end) "Compute visual wrap prefix from text between BEG and END. diff --git a/lisp/wdired.el b/lisp/wdired.el index 8ce115eb142..0a858864d2d 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -93,8 +93,7 @@ is not nil." That is, always move the point to the beginning of the filename at line. If `sometimes', only move to the beginning of filename if the point is -before it, and `track-eol' is non-nil. This behavior is very handy -when editing several filenames. +before it. This behavior is very handy when editing several filenames. If nil, \"up\" and \"down\" movement is done as in any other buffer." :type '(choice (const :tag "As in any other mode" nil) diff --git a/lisp/which-key.el b/lisp/which-key.el index 232145f7fb5..1039f2427df 100644 --- a/lisp/which-key.el +++ b/lisp/which-key.el @@ -1219,7 +1219,7 @@ total height." ;;; Show/hide which-key buffer (defun which-key--hide-popup () - "This function is called to hide the which-key buffer." + "Hide the `which-key' buffer." (unless (or which-key-persistent-popup (member real-this-command which-key--paging-functions)) (setq which-key--last-try-2-loc nil) @@ -2346,10 +2346,7 @@ enough space based on your settings and frame size." prefix-keys) (when (cdr page-echo) (funcall (cdr page-echo))) (which-key--show-popup (cons height width))))) ;; used for paging at top-level - (if (fboundp 'set-transient-map) - (set-transient-map (which-key--get-popup-map)) - (with-no-warnings - (set-temporary-overlay-map (which-key--get-popup-map)))))) + (set-transient-map (which-key--get-popup-map)))) ;;; Paging functions diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 1d47f80b0dd..ba99847f488 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -56,7 +56,6 @@ ;;; Code: (require 'cl-lib) -(eval-when-compile (require 'subr-x)) ; when-let ;; The `string' widget completion uses this. (declare-function ispell-get-word "ispell" @@ -1042,8 +1041,8 @@ button end points." (defun widget-text (widget) "Get the text representation of the widget." - (when-let ((from (widget-get widget :from)) - (to (widget-get widget :to))) + (when-let* ((from (widget-get widget :from)) + (to (widget-get widget :to))) (when (eq (marker-buffer from) (marker-buffer to)) ; is this check necessary? (buffer-substring-no-properties from to)))) @@ -2942,7 +2941,7 @@ Otherwise, the new widget is the default child of WIDGET. The new widget gets inserted at the position of the BEFORE child." (save-excursion (let ((children (widget-get widget :children)) - (last-deleted (when-let ((lst (widget-get widget :last-deleted))) + (last-deleted (when-let* ((lst (widget-get widget :last-deleted))) (prog1 (pop lst) (widget-put widget :last-deleted lst))))) diff --git a/lisp/window-tool-bar.el b/lisp/window-tool-bar.el index 63484da3255..2f16addfb33 100644 --- a/lisp/window-tool-bar.el +++ b/lisp/window-tool-bar.el @@ -305,8 +305,8 @@ MENU-ITEM is a menu item to convert. See info node `(elisp)Tool Bar'." 'face 'window-tool-bar-button-disabled str)) - (when-let ((spec (and (window-tool-bar--use-images) - (plist-get menu-item :image)))) + (when-let* ((spec (and (window-tool-bar--use-images) + (plist-get menu-item :image)))) (put-text-property 0 len 'display (append spec diff --git a/lisp/window.el b/lisp/window.el index b50770cbd7e..c790118c5e0 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -8094,7 +8094,7 @@ specified by the ACTION argument." (while (and functions (not window)) (setq window (funcall (car functions) buffer alist) functions (cdr functions))) - (when-let ((select (assq 'post-command-select-window alist))) + (when-let* ((select (assq 'post-command-select-window alist))) (letrec ((old-selected-window (selected-window)) (postfun (lambda () @@ -8187,10 +8187,10 @@ This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be called only by `display-buffer' or a function directly or indirectly called by the latter." - (when-let ((window (or (display-buffer-reuse-window buffer alist) - (display-buffer-same-window buffer alist) - (display-buffer-pop-up-window buffer alist) - (display-buffer-use-some-window buffer alist)))) + (when-let* ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) (delete-other-windows window) window)) @@ -11071,10 +11071,10 @@ that can be later used as argument for `window-point-context-use-function'. Remember the returned context in the window parameter `context'." (walk-windows (lambda (w) - (when-let ((fn (buffer-local-value 'window-point-context-set-function - (window-buffer w))) - ((functionp fn)) - (context (funcall fn w))) + (when-let* ((fn (buffer-local-value 'window-point-context-set-function + (window-buffer w))) + ((functionp fn)) + (context (funcall fn w))) (set-window-parameter w 'context (cons (buffer-name (window-buffer w)) context)))) 'nomini)) @@ -11090,11 +11090,11 @@ The function called is supposed to set the window point to the location found by the provided context." (walk-windows (lambda (w) - (when-let ((fn (buffer-local-value 'window-point-context-use-function - (window-buffer w))) - ((functionp fn)) - (context (window-parameter w 'context)) - ((equal (buffer-name (window-buffer w)) (car context)))) + (when-let* ((fn (buffer-local-value 'window-point-context-use-function + (window-buffer w))) + ((functionp fn)) + (context (window-parameter w 'context)) + ((equal (buffer-name (window-buffer w)) (car context)))) (funcall fn w (cdr context)) (set-window-parameter w 'context nil))) 'nomini)) @@ -11119,11 +11119,11 @@ found by the provided context." (let ((point (window-point w))) (save-excursion (goto-char point) - (when-let ((f (alist-get 'front-context-string context)) - ((search-forward f (point-max) t))) + (when-let* ((f (alist-get 'front-context-string context)) + ((search-forward f (point-max) t))) (goto-char (match-beginning 0)) - (when-let ((r (alist-get 'rear-context-string context)) - ((search-backward r (point-min) t))) + (when-let* ((r (alist-get 'rear-context-string context)) + ((search-backward r (point-min) t))) (goto-char (match-end 0)) (setq point (point))))) (set-window-point w point)))) diff --git a/lisp/xdg.el b/lisp/xdg.el index 4c675489400..dc04fa88b03 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -291,7 +291,7 @@ According to the XDG Desktop Entry Specification version 0.5: colon-separated list of strings ... $XDG_CURRENT_DESKTOP should have been set by the login manager, according to the value of the DesktopNames found in the session file." - (when-let ((ret (getenv "XDG_CURRENT_DESKTOP"))) + (when-let* ((ret (getenv "XDG_CURRENT_DESKTOP"))) (string-split ret ":"))) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index c5a84db6d4a..04581a75bc0 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -439,7 +439,7 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (cond ((eq xwidget-event-type 'load-changed) (let ((title (xwidget-webkit-title xwidget)) (uri (xwidget-webkit-uri xwidget))) - (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) + (when-let* ((buffer (get-buffer "*Xwidget WebKit History*"))) (with-current-buffer buffer (revert-buffer))) (with-current-buffer (xwidget-buffer xwidget) diff --git a/lisp/yank-media.el b/lisp/yank-media.el index 563aae85419..17981c37c0e 100644 --- a/lisp/yank-media.el +++ b/lisp/yank-media.el @@ -67,7 +67,12 @@ all the different selection types." (lambda (type) (pcase-let ((`(,major ,minor) (split-string (symbol-name type) "/"))) (if (and (equal major "image") - (not (image-type-available-p (intern minor)))) + (not (image-type-available-p + ;; Usually, MIME subtype is the same as Emacs' + ;; identifier for an image type. But for SVG, the + ;; identifier is 'svg, while the MIME type is + ;; image/svg+xml. So we make the exception here. + (intern (if (string= minor "svg+xml") "svg" minor))))) ;; Just filter out all the image types that Emacs doesn't ;; support, because the clipboard is full of things like ;; `image/x-win-bitmap'. @@ -81,7 +86,7 @@ all the different selection types." (gui-get-selection 'CLIPBOARD 'TARGETS))) (defun yank-media--get-selection (data-type) - (when-let ((data (gui-get-selection 'CLIPBOARD data-type))) + (when-let* ((data (gui-get-selection 'CLIPBOARD data-type))) (if (string-match-p "\\`text/" (symbol-name data-type)) (yank-media-types--format data-type data) data))) @@ -116,7 +121,7 @@ non-supported selection data types." (let ((elements nil)) ;; First gather all the data. (dolist (type '(PRIMARY CLIPBOARD)) - (when-let ((data-types (gui-get-selection type 'TARGETS))) + (when-let* ((data-types (gui-get-selection type 'TARGETS))) (when (vectorp data-types) (seq-do (lambda (data-type) (unless (memq data-type '( TARGETS MULTIPLE diff --git a/src/buffer.c b/src/buffer.c index 90c5efdfbf7..2955ee6399b 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -111,7 +111,7 @@ static int last_per_buffer_idx; static void call_overlay_mod_hooks (Lisp_Object list, Lisp_Object overlay, bool after, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3); -static void reset_buffer_local_variables (struct buffer *, bool); +static void reset_buffer_local_variables (struct buffer *, int); /* Alist of all buffer names vs the buffers. This used to be a Lisp-visible variable, but is no longer, to prevent lossage @@ -1110,10 +1110,11 @@ reset_buffer (register struct buffer *b) Instead, use Fkill_all_local_variables. If PERMANENT_TOO, reset permanent buffer-local variables. - If not, preserve those. */ + If not, preserve those. PERMANENT_TOO = 2 means ignore + the permanent-local property of non-builtin variables. */ static void -reset_buffer_local_variables (struct buffer *b, bool permanent_too) +reset_buffer_local_variables (struct buffer *b, int permanent_too) { int offset, i; @@ -1139,7 +1140,7 @@ reset_buffer_local_variables (struct buffer *b, bool permanent_too) bset_invisibility_spec (b, Qt); /* Reset all (or most) per-buffer variables to their defaults. */ - if (permanent_too) + if (permanent_too == 1) bset_local_var_alist (b, Qnil); else { @@ -1168,7 +1169,7 @@ reset_buffer_local_variables (struct buffer *b, bool permanent_too) swap_in_global_binding (XSYMBOL (sym)); } - if (!NILP (prop)) + if (!NILP (prop) && !permanent_too) { /* If permanent-local, keep it. */ last = tmp; @@ -3006,7 +3007,7 @@ the normal hook `change-major-mode-hook'. */) /* Actually eliminate all local bindings of this buffer. */ - reset_buffer_local_variables (current_buffer, !NILP (kill_permanent)); + reset_buffer_local_variables (current_buffer, !NILP (kill_permanent) ? 2 : 0); /* Force mode-line redisplay. Useful here because all major mode commands call this function. */ diff --git a/src/charset.c b/src/charset.c index e8d0826f4c2..f7d80cc3f3e 100644 --- a/src/charset.c +++ b/src/charset.c @@ -1007,7 +1007,8 @@ usage: (define-charset-internal ...) */) i = CODE_POINT_TO_INDEX (&charset, charset.max_code); if (MAX_CHAR - charset.code_offset < i) - error ("Unsupported max char: %d", charset.max_char); + error ("Unsupported max char: %d + %ud > MAX_CHAR (%d)", + i, charset.max_code, MAX_CHAR); charset.max_char = i + charset.code_offset; i = CODE_POINT_TO_INDEX (&charset, charset.min_code); charset.min_char = i + charset.code_offset; diff --git a/src/data.c b/src/data.c index fd2d9705642..66cf34c1e60 100644 --- a/src/data.c +++ b/src/data.c @@ -756,7 +756,7 @@ global value outside of any lexical scope. */) breaking backward compatibility, as some users of fboundp may expect t in particular, rather than any true value. */ DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, - doc: /* Return t if SYMBOL's function definition is not void. */) + doc: /* Return t if SYMBOL's function definition is not nil. */) (Lisp_Object symbol) { CHECK_SYMBOL (symbol); @@ -782,12 +782,12 @@ See also `fmakunbound'. */) } DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, - doc: /* Make SYMBOL's function definition be void. + doc: /* Make SYMBOL's function definition be nil. Return SYMBOL. -If a function definition is void, trying to call a function by that -name will cause a `void-function' error. For more details, see Info -node `(elisp) Function Cells'. +If a function definition is nil, trying to call a function by +that name will cause a `void-function' error. For more details, see +Info node `(elisp) Function Cells'. See also `makunbound'. */) (register Lisp_Object symbol) @@ -800,7 +800,7 @@ See also `makunbound'. */) } DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, - doc: /* Return SYMBOL's function definition, or nil if that is void. */) + doc: /* Return SYMBOL's function definition. */) (Lisp_Object symbol) { CHECK_SYMBOL (symbol); diff --git a/src/dispextern.h b/src/dispextern.h index 4a013236432..47afc48bb60 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3177,6 +3177,7 @@ struct image #endif /* HAVE_ANDROID */ #ifdef HAVE_NTGUI XFORM xform; + bool smoothing; #endif #ifdef HAVE_HAIKU /* The affine transformation to apply to this image. */ diff --git a/src/emacs.c b/src/emacs.c index b0d1f2f53e8..bdd9eee10c4 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2472,6 +2472,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #ifdef HAVE_W32NOTIFY syms_of_w32notify (); #endif /* HAVE_W32NOTIFY */ + syms_of_w32dwrite (); #endif /* WINDOWSNT */ syms_of_xwidget (); diff --git a/src/fns.c b/src/fns.c index 2de04d06519..ef6922c137b 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2823,8 +2823,8 @@ static ptrdiff_t hash_lookup_with_hash (struct Lisp_Hash_Table *h, if EQUAL_KIND == EQUAL_NO_QUIT. */ static bool -internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, - int depth, Lisp_Object ht) +internal_equal_1 (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, + int depth, Lisp_Object *ht) { tail_recurse: if (depth > 10) @@ -2832,13 +2832,13 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, eassert (equal_kind != EQUAL_NO_QUIT); if (depth > 200) error ("Stack overflow in equal"); - if (NILP (ht)) - ht = CALLN (Fmake_hash_table, QCtest, Qeq); + if (NILP (*ht)) + *ht = CALLN (Fmake_hash_table, QCtest, Qeq); switch (XTYPE (o1)) { case Lisp_Cons: case Lisp_Vectorlike: { - struct Lisp_Hash_Table *h = XHASH_TABLE (ht); + struct Lisp_Hash_Table *h = XHASH_TABLE (*ht); hash_hash_t hash = hash_from_key (h, o1); ptrdiff_t i = hash_lookup_with_hash (h, o1, hash); if (i >= 0) @@ -2888,8 +2888,8 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, { if (! CONSP (o2)) return false; - if (! internal_equal (XCAR (o1), XCAR (o2), - equal_kind, depth + 1, ht)) + if (! internal_equal_1 (XCAR (o1), XCAR (o2), + equal_kind, depth + 1, ht)) return false; o2 = XCDR (o2); if (EQ (XCDR (o1), o2)) @@ -2964,7 +2964,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, Lisp_Object v1, v2; v1 = AREF (o1, i); v2 = AREF (o2, i); - if (!internal_equal (v1, v2, equal_kind, depth + 1, ht)) + if (!internal_equal_1 (v1, v2, equal_kind, depth + 1, ht)) return false; } return true; @@ -2985,6 +2985,13 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, return false; } +static bool +internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, + int depth, Lisp_Object ht) +{ + return internal_equal_1 (o1, o2, equal_kind, depth, &ht); +} + /* Return -1/0/1 for the </=/> lexicographic relation between bool-vectors. */ static int bool_vector_cmp (Lisp_Object a, Lisp_Object b) diff --git a/src/ftcrfont.c b/src/ftcrfont.c index 3700154e44a..2ef85d4d566 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -708,6 +708,17 @@ ftcrhbfont_end_hb_font (struct font *font, hb_font_t *hb_font) struct font_info *ftcrfont_info = (struct font_info *) font; cairo_scaled_font_t *scaled_font = ftcrfont_info->cr_scaled_font; + eassert (hb_font == ftcrfont_info->hb_font); + /* ftcrfont_info->hb_font holds a reference to the FT_Face returned by + cairo_ft_scaled_font_lock_face. Keeping it around after the matching + unlock call would violate the API contract, and cause corrupted + display of composed characters (Bug#73752). We destroy and NULLify + hb_font here, which will then cause fthbfont_begin_hb_font, called by + ftcrhbfont_begin_hb_font, to recreate hb_font anew, taking into + consideration any scale changes in FT_Face. */ + hb_font_destroy (ftcrfont_info->hb_font); + ftcrfont_info->hb_font = NULL; + cairo_ft_scaled_font_unlock_face (scaled_font); ftcrfont_info->ft_size = NULL; } diff --git a/src/image.c b/src/image.c index 34936977a40..db7f6acd171 100644 --- a/src/image.c +++ b/src/image.c @@ -3049,12 +3049,10 @@ image_set_transform (struct frame *f, struct image *img) flip = !NILP (image_spec_value (img->spec, QCflip, NULL)); # if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS || defined HAVE_HAIKU \ - || defined HAVE_ANDROID + || defined HAVE_ANDROID || defined HAVE_NTGUI /* We want scale up operations to use a nearest neighbor filter to show real pixels instead of munging them, but scale down - operations to use a blended filter, to avoid aliasing and the like. - - TODO: implement for Windows. */ + operations to use a blended filter, to avoid aliasing and the like. */ bool smoothing; Lisp_Object s = image_spec_value (img->spec, QCtransform_smoothing, NULL); if (NILP (s)) @@ -3067,6 +3065,10 @@ image_set_transform (struct frame *f, struct image *img) img->use_bilinear_filtering = smoothing; #endif +#ifdef HAVE_NTGUI + img->smoothing = smoothing; +#endif + /* Perform scale transformation. */ matrix3x3 matrix diff --git a/src/itree.c b/src/itree.c index 749e65c2eed..f35226ad226 100644 --- a/src/itree.c +++ b/src/itree.c @@ -378,9 +378,9 @@ itree_inherit_offset (uintmax_t otick, struct itree_node *node) node->right->offset += node->offset; node->offset = 0; } - /* The only thing that matters about `otick` is whether it's equal to + /* The only thing that matters about 'otick' is whether it's equal to that of the tree. We could also "blindly" inherit from parent->otick, - but we need to tree's `otick` anyway for when there's no parent. */ + but we need to tree's 'otick' anyway for when there's no parent. */ if (node->parent == NULL || node->parent->otick == otick) node->otick = otick; } @@ -683,7 +683,7 @@ itree_insert_node (struct itree_tree *tree, struct itree_node *node) struct itree_node *parent = NULL; struct itree_node *child = tree->root; uintmax_t otick = tree->otick; - /* It's the responsibility of the caller to set `otick` on the node, + /* It's the responsibility of the caller to set 'otick' on the node, to "confirm" that the begin/end fields are up to date. */ eassert (node->otick == otick); @@ -913,8 +913,8 @@ itree_total_offset (struct itree_node *node) link the tree root. Warning: DEST is left unmodified. SOURCE's child links are - unchanged. Caller is responsible for recalculation of `limit`. - Requires both nodes to be using the same effective `offset`. */ + unchanged. Caller is responsible for recalculation of 'limit'. + Requires both nodes to be using the same effective 'offset'. */ static void itree_replace_child (struct itree_tree *tree, struct itree_node *source, @@ -939,8 +939,8 @@ itree_replace_child (struct itree_tree *tree, parent, left and right in surrounding nodes to point to SOURCE. Warning: DEST is left unmodified. Caller is responsible for - recalculation of `limit`. Requires both nodes to be using the same - effective `offset`. */ + recalculation of 'limit'. Requires both nodes to be using the same + effective 'offset'. */ static void itree_transplant (struct itree_tree *tree, struct itree_node *source, @@ -964,38 +964,38 @@ itree_remove (struct itree_tree *tree, struct itree_node *node) eassert (itree_contains (tree, node)); eassert (check_tree (tree, true)); /* FIXME: Too expensive. */ - /* Find `splice`, the leaf node to splice out of the tree. When - `node` has at most one child this is `node` itself. Otherwise, - it is the in order successor of `node`. */ + /* Find 'splice', the leaf node to splice out of the tree. When + 'node' has at most one child this is 'node' itself. Otherwise, + it is the in order successor of 'node'. */ itree_inherit_offset (tree->otick, node); struct itree_node *splice = (node->left == NULL || node->right == NULL) ? node : itree_subtree_min (tree->otick, node->right); - /* Find `subtree`, the only child of `splice` (may be NULL). Note: - `subtree` will not be modified other than changing its parent to - `splice`. */ + /* Find 'subtree', the only child of 'splice' (may be NULL). Note: + 'subtree' will not be modified other than changing its parent to + 'splice'. */ eassert (splice->left == NULL || splice->right == NULL); struct itree_node *subtree = (splice->left != NULL) ? splice->left : splice->right; - /* Save a pointer to the parent of where `subtree` will eventually - be in `subtree_parent`. */ + /* Save a pointer to the parent of where 'subtree' will eventually + be in 'subtree_parent'. */ struct itree_node *subtree_parent = (splice->parent != node) ? splice->parent : splice; - /* If `splice` is black removing it may violate Red-Black + /* If 'splice' is black removing it may violate Red-Black invariants, so note this for later. */ - /* Replace `splice` with `subtree` under subtree's parent. If - `splice` is black, this creates a red-red violation, so remember + /* Replace 'splice' with 'subtree' under subtree's parent. If + 'splice' is black, this creates a red-red violation, so remember this now as the field can be overwritten when splice is transplanted below. */ itree_replace_child (tree, subtree, splice); bool removed_black = !splice->red; - /* Replace `node` with `splice` in the tree and propagate limit + /* Replace 'node' with 'splice' in the tree and propagate limit upwards, if necessary. Note: Limit propagation can stabilize at any point, so we must call from bottom to top for every node that has a new child. */ @@ -1054,8 +1054,8 @@ itree_insert_gap (struct itree_tree *tree, /* Nodes with front_advance starting at pos may mess up the tree order, so we need to remove them first. This doesn't apply for - `before_markers` since in that case, all positions move identically - regardless of `front_advance` or `rear_advance`. */ + 'before_markers' since in that case, all positions move identically + regardless of 'front_advance' or 'rear_advance'. */ struct itree_stack *saved = itree_stack_create (0); struct itree_node *node = NULL; if (!before_markers) @@ -1208,7 +1208,7 @@ itree_node_intersects (const struct itree_node *node, Note that this should return all the nodes that we need to traverse in order to traverse the nodes selected by the current narrowing (i.e. - `ITER->begin..ITER->end`) so it will also return some nodes which aren't in + 'ITER->begin..ITER->end') so it will also return some nodes which aren't in that narrowing simply because they may have children which are. The code itself is very unsatisfactory because the code of each one @@ -1221,8 +1221,8 @@ itree_iter_next_in_subtree (struct itree_node *node, struct itree_iterator *iter) { /* FIXME: Like in the previous version of the iterator, we - prune based on `limit` only when moving to a left child, - but `limit` can also get smaller when moving to a right child + prune based on 'limit' only when moving to a left child, + but 'limit' can also get smaller when moving to a right child It's actually fairly common, so maybe it would be worthwhile to prune a bit more aggressively here. */ struct itree_node *next; @@ -1387,10 +1387,10 @@ itree_iterator_start (struct itree_iterator *iter, iter->end = end; iter->otick = tree->otick; iter->order = order; - /* Beware: the `node` field always holds "the next" node to consider. + /* Beware: the 'node' field always holds "the next" node to consider. so it's always "one node ahead" of what the iterator loop sees. In most respects this makes no difference, but we depend on this - detail in `delete_all_overlays` where this allows us to modify + detail in 'delete_all_overlays' where this allows us to modify the current node knowing that the iterator will not need it to find the next. */ iter->node = itree_iterator_first_node (tree, iter); diff --git a/src/itree.h b/src/itree.h index f54dbd7f07e..23e1105a05d 100644 --- a/src/itree.h +++ b/src/itree.h @@ -41,7 +41,7 @@ INLINE_HEADER_BEGIN struct itree_node { /* The normal parent, left and right links found in binary trees. - See also `red`, below, which completes the Red-Black tree + See also 'red', below, which completes the Red-Black tree representation. */ struct itree_node *parent; struct itree_node *left; @@ -147,13 +147,13 @@ struct itree_iterator struct itree_node *node; ptrdiff_t begin; ptrdiff_t end; - uintmax_t otick; /* A copy of the tree's `otick`. */ + uintmax_t otick; /* A copy of the tree's 'otick'. */ enum itree_order order; }; /* Iterate over the intervals between BEG and END in the tree T. - N will hold successive nodes. ORDER can be one of : `ASCENDING`, - `DESCENDING`, `POST_ORDER`, or `PRE_ORDER`. + N will hold successive nodes. ORDER can be one of : 'ASCENDING', + 'DESCENDING', 'POST_ORDER', or 'PRE_ORDER'. It should be used as: ITREE_FOREACH (n, t, beg, end, order) @@ -167,12 +167,12 @@ struct itree_iterator - Don't modify the tree during the iteration. */ #define ITREE_FOREACH(n, t, beg, end, order) \ - /* FIXME: We'd want to declare `n` right here, but I can't figure out - how to make that work here: the `for` syntax only allows a single + /* FIXME: We'd want to declare 'n' right here, but I can't figure out + how to make that work here: the 'for' syntax only allows a single clause for the var declarations where we need 2 different types. - We could use the `struct {foo x; bar y; } p;` trick to declare two - vars `p.x` and `p.y` of unrelated types, but then none of the names - of the vars matches the `n` we receive :-(. */ \ + We could use the 'struct {foo x; bar y; } p;' trick to declare two + vars 'p.x' and 'p.y' of unrelated types, but then none of the names + of the vars matches the 'n' we receive :-(. */ \ if (!t) \ { } \ else \ diff --git a/src/lread.c b/src/lread.c index 95c6891c205..ea0398196e3 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3911,6 +3911,8 @@ read_stack_reset (intmax_t sp) #define READ_AND_BUFFER(c) \ c = READCHAR; \ + if (c < 0) \ + INVALID_SYNTAX_WITH_BUFFER (); \ if (multibyte) \ p += CHAR_STRING (c, (unsigned char *) p); \ else \ diff --git a/src/nsterm.m b/src/nsterm.m index 7ad794b6bdb..ffc0693ab98 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -2961,24 +2961,28 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row, NSTRACE_MSG ("which:%d cursor:%d overlay:%d width:%d height:%d period:%d", p->which, p->cursor_p, p->overlay_p, p->wd, p->h, p->dh); - /* Work out the rectangle we will need to clear. */ - clearRect = NSMakeRect (p->x, p->y, p->wd, p->h); + /* Clear screen unless overlay. */ + if (!p->overlay_p) + { + /* Work out the rectangle we will need to clear. */ + clearRect = NSMakeRect (p->x, p->y, p->wd, p->h); - if (p->bx >= 0 && !p->overlay_p) - clearRect = NSUnionRect (clearRect, NSMakeRect (p->bx, p->by, p->nx, p->ny)); + if (p->bx >= 0) + clearRect = NSUnionRect (clearRect, NSMakeRect (p->bx, p->by, p->nx, p->ny)); - /* Handle partially visible rows. */ - clearRect = NSIntersectionRect (clearRect, rowRect); + /* Handle partially visible rows. */ + clearRect = NSIntersectionRect (clearRect, rowRect); - /* The visible portion of imageRect will always be contained within - clearRect. */ - ns_focus (f, &clearRect, 1); - if (! NSIsEmptyRect (clearRect)) - { - NSTRACE_RECT ("clearRect", clearRect); + /* The visible portion of imageRect will always be contained + within clearRect. */ + ns_focus (f, &clearRect, 1); + if (!NSIsEmptyRect (clearRect)) + { + NSTRACE_RECT ("clearRect", clearRect); - [[NSColor colorWithUnsignedLong:face->background] set]; - NSRectFill (clearRect); + [[NSColor colorWithUnsignedLong:face->background] set]; + NSRectFill (clearRect); + } } NSBezierPath *bmp = [fringe_bmp objectForKey:[NSNumber numberWithInt:p->which]]; @@ -7895,6 +7899,9 @@ ns_in_echo_area (void) NSTRACE_RETURN_SIZE (frameSize); + /* Trigger `move-frame-functions' (Bug#74074). */ + [self windowDidMove:(NSNotification *)sender]; + return frameSize; } diff --git a/src/pdumper.c b/src/pdumper.c index c888b659dde..c0b36b1ca44 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -4853,11 +4853,14 @@ struct dump_memory_map_heap_control_block static void dump_mm_heap_cb_release (struct dump_memory_map_heap_control_block *cb) { - eassert (cb->refcount > 0); - if (--cb->refcount == 0) + if (cb) { - free (cb->mem); - free (cb); + eassert (cb->refcount > 0); + if (--cb->refcount == 0) + { + free (cb->mem); + free (cb); + } } } diff --git a/src/w32dwrite.c b/src/w32dwrite.c new file mode 100644 index 00000000000..29f9d5f1fed --- /dev/null +++ b/src/w32dwrite.c @@ -0,0 +1,1110 @@ +/* Support for using DirectWrite on MS-Windows to draw text. This + allows for color fonts. + Copyright (C) 2024 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +/* This requires the HarfBuzz font backend to be available. + + It works by modifying the HarfBuzz backend to use DirectWrite at + some points, if it is available: + + - When encoding characters: w32hb_encode_char + - When measuring text: w32font_text_extents + - When drawing text: w32font_draw + + DirectWrite is setup by calling w32_initialize_direct_write. From + that point, the function w32_use_direct_write will return true if + DirectWrite is to be used. + + DirectWrite is available since Windows 7, but we don't activate it on + versions before 8.1, because color fonts are only available since that. */ + +#include <config.h> +#include <math.h> +#include <windows.h> + +#if !defined MINGW_W64 && !defined CYGWIN +# define INITGUID +#endif +#include <initguid.h> +#include <ole2.h> +#include <unknwn.h> + +#include "frame.h" +#include "w32font.h" +#include "w32common.h" +#include "w32term.h" + +#ifndef MINGW_W64 + +/* The following definitions would be included from dwrite_3.h, but it + is not available when building with mingw.org's MinGW. Methods that + we don't use are declared with the EMACS_DWRITE_UNUSED macro, to + avoid bringing in more types that would need to be declared. */ + +#define EMACS_DWRITE_UNUSED(name) void (STDMETHODCALLTYPE *name) (void) + +#define DWRITE_E_NOCOLOR _HRESULT_TYPEDEF_(0x8898500CL) + +typedef enum DWRITE_PIXEL_GEOMETRY { + DWRITE_PIXEL_GEOMETRY_FLAT = 0, + DWRITE_PIXEL_GEOMETRY_RGB = 1, + DWRITE_PIXEL_GEOMETRY_BGR = 2 +} DWRITE_PIXEL_GEOMETRY; + +typedef enum DWRITE_RENDERING_MODE { + DWRITE_RENDERING_MODE_DEFAULT = 0, + DWRITE_RENDERING_MODE_ALIASED = 1, + DWRITE_RENDERING_MODE_GDI_CLASSIC = 2, + DWRITE_RENDERING_MODE_GDI_NATURAL = 3, + DWRITE_RENDERING_MODE_NATURAL = 4, + DWRITE_RENDERING_MODE_NATURAL_SYMMETRIC = 5, + DWRITE_RENDERING_MODE_OUTLINE = 6 +} DWRITE_RENDERING_MODE; + +typedef enum DWRITE_MEASURING_MODE { + DWRITE_MEASURING_MODE_NATURAL = 0, + DWRITE_MEASURING_MODE_GDI_CLASSIC = 1, + DWRITE_MEASURING_MODE_GDI_NATURAL = 2 +} DWRITE_MEASURING_MODE; + +typedef enum DWRITE_TEXT_ANTIALIAS_MODE { + DWRITE_TEXT_ANTIALIAS_MODE_CLEARTYPE = 0, + DWRITE_TEXT_ANTIALIAS_MODE_GRAYSCALE = 1 +} DWRITE_TEXT_ANTIALIAS_MODE; + +typedef enum DWRITE_FACTORY_TYPE { + DWRITE_FACTORY_TYPE_SHARED = 0, + DWRITE_FACTORY_TYPE_ISOLATED = 1 +} DWRITE_FACTORY_TYPE; + +typedef struct DWRITE_FONT_METRICS { + UINT16 designUnitsPerEm; + UINT16 ascent; + UINT16 descent; + INT16 lineGap; + UINT16 capHeight; + UINT16 xHeight; + INT16 underlinePosition; + UINT16 underlineThickness; + INT16 strikethroughPosition; + UINT16 strikethroughThickness; +} DWRITE_FONT_METRICS; + +typedef struct DWRITE_GLYPH_METRICS { + INT32 leftSideBearing; + UINT32 advanceWidth; + INT32 rightSideBearing; + INT32 topSideBearing; + UINT32 advanceHeight; + INT32 bottomSideBearing; + INT32 verticalOriginY; +} DWRITE_GLYPH_METRICS; + +typedef interface IDWriteRenderingParams IDWriteRenderingParams; +typedef interface IDWriteFont IDWriteFont; +typedef interface IDWriteGdiInterop IDWriteGdiInterop; +typedef interface IDWriteFactory IDWriteFactory; +typedef interface IDWriteFactory2 IDWriteFactory2; +typedef interface IDWriteFontFace IDWriteFontFace; +typedef interface IDWriteBitmapRenderTarget IDWriteBitmapRenderTarget; +typedef interface IDWriteBitmapRenderTarget1 IDWriteBitmapRenderTarget1; +typedef interface IDWriteColorGlyphRunEnumerator IDWriteColorGlyphRunEnumerator; + +DEFINE_GUID (IID_IDWriteBitmapRenderTarget1, 0x791e8298, 0x3ef3, 0x4230, 0x98, + 0x80, 0xc9, 0xbd, 0xec, 0xc4, 0x20, 0x64); +DEFINE_GUID (IID_IDWriteFactory2, 0x0439fc60, 0xca44, 0x4994, 0x8d, 0xee, + 0x3a, 0x9a, 0xf7, 0xb7, 0x32, 0xec); +DEFINE_GUID (IID_IDWriteFactory, 0xb859ee5a, 0xd838, 0x4b5b, 0xa2, 0xe8, 0x1a, + 0xdc, 0x7d, 0x93, 0xdb, 0x48); + +typedef struct DWRITE_GLYPH_OFFSET { + FLOAT advanceOffset; + FLOAT ascenderOffset; +} DWRITE_GLYPH_OFFSET; + +typedef struct DWRITE_GLYPH_RUN { + IDWriteFontFace *fontFace; + FLOAT fontEmSize; + UINT32 glyphCount; + const UINT16 *glyphIndices; + const FLOAT *glyphAdvances; + const DWRITE_GLYPH_OFFSET *glyphOffsets; + WINBOOL isSideways; + UINT32 bidiLevel; +} DWRITE_GLYPH_RUN; + +typedef struct _D3DCOLORVALUE { + float r; + float g; + float b; + float a; +} D3DCOLORVALUE; + +typedef D3DCOLORVALUE DWRITE_COLOR_F; + +typedef struct DWRITE_COLOR_GLYPH_RUN { + DWRITE_GLYPH_RUN glyphRun; + void *glyphRunDescription; + FLOAT baselineOriginX; + FLOAT baselineOriginY; + DWRITE_COLOR_F runColor; + UINT16 paletteIndex; +} DWRITE_COLOR_GLYPH_RUN; + +typedef struct IDWriteFontFaceVtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteFontFace *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteFontFace *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteFontFace *This); + + EMACS_DWRITE_UNUSED (GetType); + EMACS_DWRITE_UNUSED (GetFiles); + EMACS_DWRITE_UNUSED (GetIndex); + EMACS_DWRITE_UNUSED (GetSimulations); + EMACS_DWRITE_UNUSED (IsSymbolFont); + + void (STDMETHODCALLTYPE *GetMetrics) + (IDWriteFontFace *This, DWRITE_FONT_METRICS *metrics); + + EMACS_DWRITE_UNUSED (GetGlyphCount); + EMACS_DWRITE_UNUSED (GetDesignGlyphMetrics); + + HRESULT (STDMETHODCALLTYPE *GetGlyphIndices) + (IDWriteFontFace *This, const UINT32 *codepoints, UINT32 count, + UINT16 *glyph_indices); + + EMACS_DWRITE_UNUSED (TryGetFontTable); + EMACS_DWRITE_UNUSED (ReleaseFontTable); + EMACS_DWRITE_UNUSED (GetGlyphRunOutline); + EMACS_DWRITE_UNUSED (GetRecommendedRenderingMode); + EMACS_DWRITE_UNUSED (GetGdiCompatibleMetrics); + + HRESULT (STDMETHODCALLTYPE *GetGdiCompatibleGlyphMetrics) + (IDWriteFontFace *This, + FLOAT emSize, + FLOAT pixels_per_dip, + void *transform, + WINBOOL use_gdi_natural, + const UINT16 *glyph_indices, + UINT32 glyph_count, + DWRITE_GLYPH_METRICS *metrics, + WINBOOL is_sideways); + END_INTERFACE +} IDWriteFontFaceVtbl; + +interface IDWriteFontFace { + CONST_VTBL IDWriteFontFaceVtbl *lpVtbl; +}; + +typedef struct IDWriteRenderingParamsVtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteRenderingParams *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteRenderingParams *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteRenderingParams *This); + + FLOAT (STDMETHODCALLTYPE *GetGamma) + (IDWriteRenderingParams *This); + FLOAT (STDMETHODCALLTYPE *GetEnhancedContrast) + (IDWriteRenderingParams *This); + FLOAT (STDMETHODCALLTYPE *GetClearTypeLevel) + (IDWriteRenderingParams *This); + int (STDMETHODCALLTYPE *GetPixelGeometry) + (IDWriteRenderingParams *This); + END_INTERFACE +} IDWriteRenderingParamsVtbl; + +interface IDWriteRenderingParams { + CONST_VTBL IDWriteRenderingParamsVtbl *lpVtbl; +}; + +typedef struct IDWriteFontVtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteFont *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteFont *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteFont *This); + + EMACS_DWRITE_UNUSED (GetFontFamily); + EMACS_DWRITE_UNUSED (GetWeight); + EMACS_DWRITE_UNUSED (GetStretch); + EMACS_DWRITE_UNUSED (GetStyle); + EMACS_DWRITE_UNUSED (IsSymbolFont); + EMACS_DWRITE_UNUSED (GetFaceNames); + EMACS_DWRITE_UNUSED (GetInformationalStrings); + EMACS_DWRITE_UNUSED (GetSimulations); + + void (STDMETHODCALLTYPE *GetMetrics) + (IDWriteFont *This, DWRITE_FONT_METRICS *metrics); + + EMACS_DWRITE_UNUSED (HasCharacter); + + HRESULT (STDMETHODCALLTYPE *CreateFontFace) + (IDWriteFont *This, IDWriteFontFace **face); + + END_INTERFACE +} IDWriteFontVtbl; + +interface IDWriteFont { + CONST_VTBL IDWriteFontVtbl *lpVtbl; +}; + +typedef struct IDWriteBitmapRenderTargetVtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteBitmapRenderTarget *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteBitmapRenderTarget *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteBitmapRenderTarget *This); + + HRESULT (STDMETHODCALLTYPE *DrawGlyphRun) + (IDWriteBitmapRenderTarget *This, + FLOAT baselineOriginX, + FLOAT baselineOriginY, + DWRITE_MEASURING_MODE measuring_mode, + const DWRITE_GLYPH_RUN *glyph_run, + IDWriteRenderingParams *params, + COLORREF textColor, + RECT *blackbox_rect); + + HDC (STDMETHODCALLTYPE *GetMemoryDC) (IDWriteBitmapRenderTarget *This); + + EMACS_DWRITE_UNUSED (GetPixelsPerDip); + + HRESULT (STDMETHODCALLTYPE *SetPixelsPerDip) + (IDWriteBitmapRenderTarget *This, FLOAT pixels_per_dip); + + EMACS_DWRITE_UNUSED (GetCurrentTransform); + EMACS_DWRITE_UNUSED (SetCurrentTransform); + EMACS_DWRITE_UNUSED (GetSize); + EMACS_DWRITE_UNUSED (Resize); + END_INTERFACE +} IDWriteBitmapRenderTargetVtbl; + +interface IDWriteBitmapRenderTarget { + CONST_VTBL IDWriteBitmapRenderTargetVtbl *lpVtbl; +}; + +typedef struct IDWriteBitmapRenderTarget1Vtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteBitmapRenderTarget1 *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteBitmapRenderTarget1 *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteBitmapRenderTarget1 *This); + + EMACS_DWRITE_UNUSED (DrawGlyphRun); + EMACS_DWRITE_UNUSED (GetMemoryDC); + EMACS_DWRITE_UNUSED (GetPixelsPerDip); + EMACS_DWRITE_UNUSED (SetPixelsPerDip); + EMACS_DWRITE_UNUSED (GetCurrentTransform); + EMACS_DWRITE_UNUSED (SetCurrentTransform); + EMACS_DWRITE_UNUSED (GetSize); + EMACS_DWRITE_UNUSED (Resize); + EMACS_DWRITE_UNUSED (GetTextAntialiasMode); + + HRESULT (STDMETHODCALLTYPE *SetTextAntialiasMode) + (IDWriteBitmapRenderTarget1 *This, DWRITE_TEXT_ANTIALIAS_MODE mode); + + END_INTERFACE +} IDWriteBitmapRenderTarget1Vtbl; + +interface IDWriteBitmapRenderTarget1 { + CONST_VTBL IDWriteBitmapRenderTarget1Vtbl *lpVtbl; +}; + +typedef struct IDWriteGdiInteropVtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteGdiInterop *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteGdiInterop *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteGdiInterop *This); + + HRESULT (STDMETHODCALLTYPE *CreateFontFromLOGFONT) + (IDWriteGdiInterop *This, const LOGFONTW *logfont, + IDWriteFont **font); + + EMACS_DWRITE_UNUSED (ConvertFontToLOGFONT); + EMACS_DWRITE_UNUSED (ConvertFontFaceToLOGFONT); + EMACS_DWRITE_UNUSED (CreateFontFaceFromHdc); + + HRESULT (STDMETHODCALLTYPE *CreateBitmapRenderTarget) + (IDWriteGdiInterop *This, HDC hdc, UINT32 width, UINT32 height, + IDWriteBitmapRenderTarget **target); + END_INTERFACE +} IDWriteGdiInteropVtbl; + +interface IDWriteGdiInterop { + CONST_VTBL IDWriteGdiInteropVtbl *lpVtbl; +}; + +typedef struct IDWriteFactoryVtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteFactory *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteFactory *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteFactory *This); + + EMACS_DWRITE_UNUSED (GetSystemFontCollection); + EMACS_DWRITE_UNUSED (CreateCustomFontCollection); + EMACS_DWRITE_UNUSED (RegisterFontCollectionLoader); + EMACS_DWRITE_UNUSED (UnregisterFontCollectionLoader); + EMACS_DWRITE_UNUSED (CreateFontFileReference); + EMACS_DWRITE_UNUSED (CreateCustomFontFileReference); + EMACS_DWRITE_UNUSED (CreateFontFace); + HRESULT (STDMETHODCALLTYPE *CreateRenderingParams) + (IDWriteFactory *This, IDWriteRenderingParams **params); + EMACS_DWRITE_UNUSED (CreateMonitorRenderingParams); + HRESULT (STDMETHODCALLTYPE *CreateCustomRenderingParams) + (IDWriteFactory *This, FLOAT gamma, FLOAT enhancedContrast, + FLOAT cleartype_level, DWRITE_PIXEL_GEOMETRY geometry, + DWRITE_RENDERING_MODE mode, IDWriteRenderingParams **params); + EMACS_DWRITE_UNUSED (RegisterFontFileLoader); + EMACS_DWRITE_UNUSED (UnregisterFontFileLoader); + EMACS_DWRITE_UNUSED (CreateTextFormat); + EMACS_DWRITE_UNUSED (CreateTypography); + HRESULT (STDMETHODCALLTYPE *GetGdiInterop) + (IDWriteFactory *This, IDWriteGdiInterop **gdi_interop); + EMACS_DWRITE_UNUSED (CreateTextLayout); + EMACS_DWRITE_UNUSED (CreateGdiCompatibleTextLayout); + EMACS_DWRITE_UNUSED (CreateEllipsisTrimmingSign); + EMACS_DWRITE_UNUSED (CreateTextAnalyzer); + EMACS_DWRITE_UNUSED (CreateNumberSubstitution); + EMACS_DWRITE_UNUSED (CreateGlyphRunAnalysis); + END_INTERFACE +} IDWriteFactoryVtbl; + +interface IDWriteFactory { CONST_VTBL IDWriteFactoryVtbl *lpVtbl; }; + +typedef struct IDWriteColorGlyphRunEnumeratorVtbl { + BEGIN_INTERFACE + + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteColorGlyphRunEnumerator *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteColorGlyphRunEnumerator *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteColorGlyphRunEnumerator *This); + + HRESULT (STDMETHODCALLTYPE *MoveNext) (IDWriteColorGlyphRunEnumerator *This, + WINBOOL *hasRun); + + HRESULT (STDMETHODCALLTYPE *GetCurrentRun) (IDWriteColorGlyphRunEnumerator *This, + const DWRITE_COLOR_GLYPH_RUN **run); + + END_INTERFACE +} IDWriteColorGlyphRunEnumeratorVtbl; + +interface IDWriteColorGlyphRunEnumerator { + CONST_VTBL IDWriteColorGlyphRunEnumeratorVtbl *lpVtbl; +}; + +typedef struct IDWriteFactory2Vtbl { + BEGIN_INTERFACE + HRESULT (STDMETHODCALLTYPE *QueryInterface) + (IDWriteFactory2 *This, REFIID riid, void **ppvObject); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteFactory2 *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteFactory2 *This); + EMACS_DWRITE_UNUSED (GetSystemFontCollection); + EMACS_DWRITE_UNUSED (CreateCustomFontCollection); + EMACS_DWRITE_UNUSED (RegisterFontCollectionLoader); + EMACS_DWRITE_UNUSED (UnregisterFontCollectionLoader); + EMACS_DWRITE_UNUSED (CreateFontFileReference); + EMACS_DWRITE_UNUSED (CreateCustomFontFileReference); + EMACS_DWRITE_UNUSED (CreateFontFace); + EMACS_DWRITE_UNUSED (CreateRenderingParams); + EMACS_DWRITE_UNUSED (CreateMonitorRenderingParams); + EMACS_DWRITE_UNUSED (CreateCustomRenderingParams); + EMACS_DWRITE_UNUSED (RegisterFontFileLoader); + EMACS_DWRITE_UNUSED (UnregisterFontFileLoader); + EMACS_DWRITE_UNUSED (CreateTextFormat); + EMACS_DWRITE_UNUSED (CreateTypography); + EMACS_DWRITE_UNUSED (GetGdiInterop); + EMACS_DWRITE_UNUSED (CreateTextLayout); + EMACS_DWRITE_UNUSED (CreateGdiCompatibleTextLayout); + EMACS_DWRITE_UNUSED (CreateEllipsisTrimmingSign); + EMACS_DWRITE_UNUSED (CreateTextAnalyzer); + EMACS_DWRITE_UNUSED (CreateNumberSubstitution); + EMACS_DWRITE_UNUSED (CreateGlyphRunAnalysis); + + EMACS_DWRITE_UNUSED (GetEudcFontCollection); + EMACS_DWRITE_UNUSED (IDWriteFactory1_CreateCustomRenderingParams); + + EMACS_DWRITE_UNUSED (GetSystemFontFallback); + EMACS_DWRITE_UNUSED (CreateFontFallbackBuilder); + HRESULT (STDMETHODCALLTYPE *TranslateColorGlyphRun) + (IDWriteFactory2 *This, + FLOAT originX, + FLOAT originY, + const DWRITE_GLYPH_RUN *run, + void *rundescr, + DWRITE_MEASURING_MODE mode, + void *transform, + UINT32 palette_index, + IDWriteColorGlyphRunEnumerator **colorlayers); + + EMACS_DWRITE_UNUSED (IDWriteFactory2_CreateCustomRenderingParams); + EMACS_DWRITE_UNUSED (IDWriteFactory2_CreateGlyphRunAnalysis); + END_INTERFACE +} IDWriteFactory2Vtbl; + +interface IDWriteFactory2 { + CONST_VTBL IDWriteFactory2Vtbl *lpVtbl; +}; +#else /* MINGW_W64 */ +# include <dwrite_3.h> +#endif + +/* User configurable variables. If they are smaller than 0, use + DirectWrite's defaults, or our defaults. To set them, the user calls + 'w32-dwrite-reinit' */ +static float config_enhanced_contrast = -1.0f; +static float config_clear_type_level = -1.0f; +static float config_gamma = -1.0f; + +/* Values to use for DirectWrite rendering. */ +#define MEASURING_MODE DWRITE_MEASURING_MODE_NATURAL +#define RENDERING_MODE DWRITE_RENDERING_MODE_NATURAL_SYMMETRIC +#define ANTIALIAS_MODE DWRITE_TEXT_ANTIALIAS_MODE_CLEARTYPE + +static void +release_com (IUnknown **i) +{ + if ( *i ) + { + ((IUnknown *) (*i))->lpVtbl->Release (*i); + *i = NULL; + } +} + +#define RELEASE_COM(i) release_com ((IUnknown **) &i) + +/* Global variables for DirectWrite. */ +static bool direct_write_available = false; +static IDWriteFactory *dwrite_factory = NULL; +static IDWriteFactory2 *dwrite_factory2 = NULL; +static IDWriteGdiInterop *gdi_interop = NULL; +static IDWriteRenderingParams *rendering_params = NULL; + +static bool +verify_hr (HRESULT hr, const char *msg) +{ + if (FAILED (hr)) + { + DebPrint (("DirectWrite HRESULT failed: (%d) %s\n", hr, msg)); + eassert (SUCCEEDED (hr)); + return false; + } + return true; +} + +/* Gets a IDWriteFontFace from a struct font (its HFONT). Returns the + font size in points. It may fail to get a DirectWrite font, and face + will be NULL on return. This happens for some fonts like Courier. + + Never call Release on the result, as it is cached for reuse on the + struct font. */ +static float +get_font_face (struct font *infont, IDWriteFontFace **face) +{ + HRESULT hr; + LOGFONTW logfont; + IDWriteFont *font; + + struct uniscribe_font_info *uniscribe_font + = (struct uniscribe_font_info *) infont; + + /* Check the cache. */ + *face = uniscribe_font->dwrite_cache; + if (*face) + return uniscribe_font->dwrite_font_size; + + GetObjectW (FONT_HANDLE (infont), sizeof (LOGFONTW), &logfont); + + hr = gdi_interop->lpVtbl->CreateFontFromLOGFONT (gdi_interop, + (const LOGFONTW *) &logfont, + &font); + + if (!verify_hr (hr, "Failed to CreateFontFromLOGFONT")) + { + uniscribe_font->dwrite_skip_font = true; + *face = NULL; + return 0.0; + } + + hr = font->lpVtbl->CreateFontFace (font, face); + RELEASE_COM (font); + if (!verify_hr (hr, "Failed to create DWriteFontFace")) + { + uniscribe_font->dwrite_skip_font = true; + *face = NULL; + return 0.0; + } + + /* Cache this FontFace. */ + uniscribe_font->dwrite_font_size = eabs (logfont.lfHeight); + uniscribe_font->dwrite_cache = *face; + + return eabs (logfont.lfHeight); +} + +void +w32_dwrite_free_cached_face (void *cache) +{ + if (cache) + RELEASE_COM (cache); +} + +static float +convert_metrics_sz (int sz, float font_size, int units_per_em) +{ + return (float) sz * font_size / units_per_em; +} + +/* Does not fill in the ascent and descent fields of metrics. */ +static bool +text_extents_internal (IDWriteFontFace *dwrite_font_face, + float font_size, const unsigned *code, + int nglyphs, struct font_metrics *metrics) +{ + HRESULT hr; + + USE_SAFE_ALLOCA; + + DWRITE_FONT_METRICS dwrite_font_metrics; + dwrite_font_face->lpVtbl->GetMetrics (dwrite_font_face, + &dwrite_font_metrics); + + UINT16 *indices = SAFE_ALLOCA (nglyphs * sizeof (UINT16)); + for (int i = 0; i < nglyphs; i++) + indices[i] = code[i]; + + DWRITE_GLYPH_METRICS *gmetrics + = SAFE_ALLOCA (nglyphs * sizeof (DWRITE_GLYPH_METRICS)); + + hr = dwrite_font_face->lpVtbl->GetGdiCompatibleGlyphMetrics (dwrite_font_face, + font_size, + 1.0, + NULL, + TRUE, + indices, + nglyphs, + gmetrics, + false); + if (!verify_hr (hr, "Failed to GetGdiCompatibleGlyphMetrics")) + { + SAFE_FREE (); + return false; + } + + float width = 0; + int du_per_em = dwrite_font_metrics.designUnitsPerEm; + + for (int i = 0; i < nglyphs; i++) + { + float advance + = convert_metrics_sz (gmetrics[i].advanceWidth, font_size, du_per_em); + + width += advance; + + float lbearing + = round (convert_metrics_sz (gmetrics[i].leftSideBearing, font_size, + du_per_em)); + float rbearing + = round (advance - + convert_metrics_sz (gmetrics[i].rightSideBearing, + font_size, du_per_em)); + if (i == 0) + { + metrics->lbearing = lbearing; + metrics->rbearing = rbearing; + } + if (metrics->lbearing > lbearing) + metrics->lbearing = lbearing; + if (metrics->rbearing < rbearing) + metrics->rbearing = rbearing; + } + metrics->width = round (width); + SAFE_FREE (); + return true; +} + +unsigned +w32_dwrite_encode_char (struct font *font, int c) +{ + HRESULT hr; + IDWriteFontFace *dwrite_font_face; + UINT16 index; + + get_font_face (font, &dwrite_font_face); + if (dwrite_font_face == NULL) + return FONT_INVALID_CODE; + hr = dwrite_font_face->lpVtbl->GetGlyphIndices (dwrite_font_face, + (UINT32 *) &c, 1, &index); + if (verify_hr (hr, "Failed to GetGlyphIndices")) + { + if (index == 0) + return FONT_INVALID_CODE; + return index; + } + ((struct uniscribe_font_info *) font)->dwrite_skip_font = true; + return FONT_INVALID_CODE; +} + +bool +w32_dwrite_text_extents (struct font *font, const unsigned *code, int nglyphs, + struct font_metrics *metrics) +{ + IDWriteFontFace *dwrite_font_face; + + float font_size = get_font_face (font, &dwrite_font_face); + + if (dwrite_font_face == NULL) + return false; + + /* We can get fonts with a size of 0. GDI handles this by using a default + size. We do the same. */ + if (font_size <= 0.0f) + font_size = FRAME_LINE_HEIGHT (SELECTED_FRAME ()); + + metrics->ascent = font->ascent; + metrics->descent = font->descent; + + return text_extents_internal (dwrite_font_face, font_size, code, nglyphs, + metrics); +} + +/* Never call Release on the value returned by this function, as it is + reused. */ +static IDWriteBitmapRenderTarget * +get_bitmap_render_target (HDC hdc, int width, int height) +{ + HRESULT hr; + static IDWriteBitmapRenderTarget *brt = NULL; + static SIZE size = {0, 0}; + + if (brt) + { + /* Check if we need to make a bigger one. */ + if (width <= size.cx && height <= size.cy) + return brt; + RELEASE_COM (brt); + } + + if (width > size.cx) + size.cx = width; + if (height > size.cy) + size.cy = height; + + hr = gdi_interop->lpVtbl->CreateBitmapRenderTarget (gdi_interop, + hdc, + size.cx, size.cy, + &brt); + if (!verify_hr (hr, "Failed to CreateBitmapRenderTarget")) + return NULL; + + /* We handle high dpi displays by incresing font size, so override + PixelsPerDip. */ + brt->lpVtbl->SetPixelsPerDip (brt, 1.0); + + /* The SetTextAntialiasMode method is only available in + IDWriteBitmapRenderTarget1. */ + IDWriteBitmapRenderTarget1 *brt1; + hr = brt->lpVtbl->QueryInterface (brt, + &IID_IDWriteBitmapRenderTarget1, + (void **) &brt1); + /* This error should not happen, but is not catastrofic */ + if (verify_hr (hr, "Failed to QueryInterface for IDWriteBitmapRenderTarget1")) + { + brt1->lpVtbl->SetTextAntialiasMode (brt1, ANTIALIAS_MODE); + RELEASE_COM (brt1); + } + + return brt; +} + +void +w32_initialize_direct_write (void) +{ + direct_write_available = false; + + if (dwrite_factory) + { + RELEASE_COM (dwrite_factory); + RELEASE_COM (dwrite_factory2); + RELEASE_COM (gdi_interop); + RELEASE_COM (rendering_params); + } + + HMODULE direct_write = LoadLibrary ("dwrite.dll"); + if (!direct_write) + return; + + /* This is only used here, no need to define it globally. */ + typedef HRESULT (WINAPI *DWCreateFactory) (DWRITE_FACTORY_TYPE, + REFIID, IUnknown **); + + DWCreateFactory dw_create_factory + = (DWCreateFactory) get_proc_addr (direct_write, + "DWriteCreateFactory"); + + if (!dw_create_factory) + { + FreeLibrary (direct_write); + return; + } + + HRESULT hr = dw_create_factory (DWRITE_FACTORY_TYPE_SHARED, + &IID_IDWriteFactory, + (IUnknown **) &dwrite_factory); + if (FAILED (hr)) + { + DebPrint (("DirectWrite HRESULT failed: (%d) CreateFactory\n", hr)); + FreeLibrary (direct_write); + eassert (SUCCEEDED (hr)); + return; + } + + /* IDWriteFactory2 is only available on Windows 8.1 and later. + Without this, we can't use color fonts. So we disable DirectWrite + if it is not available. */ + hr = dwrite_factory->lpVtbl->QueryInterface (dwrite_factory, + &IID_IDWriteFactory2, + (void **) &dwrite_factory2); + + if (FAILED (hr)) + { + DebPrint (("DirectWrite HRESULT failed: (%d) QueryInterface IDWriteFactory2\n", hr)); + RELEASE_COM (dwrite_factory); + FreeLibrary (direct_write); + return; + } + + hr = dwrite_factory->lpVtbl->GetGdiInterop (dwrite_factory, + &gdi_interop); + if (FAILED (hr)) + { + DebPrint (("DirectWrite HRESULT failed: (%d) GetGdiInterop\n", hr)); + RELEASE_COM (dwrite_factory); + RELEASE_COM (dwrite_factory2); + FreeLibrary (direct_write); + eassert (SUCCEEDED (hr)); + return; + } + + IDWriteRenderingParams *def; + + hr = dwrite_factory->lpVtbl->CreateRenderingParams (dwrite_factory, + &def); + if (FAILED (hr)) + { + DebPrint (("DirectWrite HRESULT failed: (%d) CreateRenderingParams\n", hr)); + RELEASE_COM (dwrite_factory); + RELEASE_COM (dwrite_factory2); + RELEASE_COM (gdi_interop); + FreeLibrary (direct_write); + eassert (SUCCEEDED (hr)); + return; + } + + /* range: [0.0, 1.0] */ + if (config_enhanced_contrast < 0.0f || config_enhanced_contrast > 1.0f) + config_enhanced_contrast = def->lpVtbl->GetEnhancedContrast (def); + + /* range: [0.0, 1.0] */ + if (config_clear_type_level < 0.0f || config_clear_type_level > 1.0f) + config_clear_type_level = def->lpVtbl->GetClearTypeLevel (def); + + /* range: (0.0, 256.0] */ + /* We change the default value of 2.2 for gamma to 1.4, that looks + very similar to GDI. The default looks too dim for emacs, + subjectively. */ + if (config_gamma <= 0.0f || config_gamma > 256.0f) + config_gamma = 1.4; /* def->lpVtbl->GetGamma (def); */ + + hr = dwrite_factory->lpVtbl->CreateCustomRenderingParams (dwrite_factory, + config_gamma, + config_enhanced_contrast, + config_clear_type_level, + def->lpVtbl->GetPixelGeometry (def), + RENDERING_MODE, + &rendering_params); + + RELEASE_COM (def); + + if (FAILED (hr)) + { + DebPrint (("DirectWrite HRESULT failed: (%d)" + " CreateCustomRenderingParams\n", hr)); + RELEASE_COM (dwrite_factory); + RELEASE_COM (dwrite_factory2); + RELEASE_COM (gdi_interop); + FreeLibrary (direct_write); + eassert (SUCCEEDED (hr)); + return; + } + + direct_write_available = true; + + w32_inhibit_dwrite = false; +} + +bool +w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, + COLORREF color, struct font *font) +{ + HRESULT hr; + IDWriteFontFace *dwrite_font_face; + + USE_SAFE_ALLOCA; + + struct uniscribe_font_info *uniscribe_font + = (struct uniscribe_font_info *) font; + + /* What we get as y is the baseline position. */ + y -= font->ascent; + + float font_size = get_font_face (font, &dwrite_font_face); + if (dwrite_font_face == NULL) + return false; + + struct font_metrics metrics; + if (!text_extents_internal (dwrite_font_face, font_size, glyphs, len, + &metrics)) + { + uniscribe_font->dwrite_skip_font = true; + return false; + } + + int left_margin = metrics.lbearing < 0 ? -metrics.lbearing : 0; + + int bitmap_width = left_margin + metrics.width + metrics.rbearing; + int bitmap_height = font->ascent + font->descent; + + /* We never release this, get_bitmap_render_target reuses it. */ + IDWriteBitmapRenderTarget *bitmap_render_target = + get_bitmap_render_target (hdc, bitmap_width, bitmap_height); + + /* If this fails, completely disable DirectWrite. */ + if (bitmap_render_target == NULL) + { + direct_write_available = false; + return false; + } + + /* This DC can't be released. */ + HDC text_dc + = bitmap_render_target->lpVtbl->GetMemoryDC (bitmap_render_target); + + /* Copy the background pixel to the render target bitmap. */ + BitBlt (text_dc, 0, 0, bitmap_width, bitmap_height, hdc, x - left_margin, y, SRCCOPY); + + UINT16 *indices = SAFE_ALLOCA (len * sizeof (UINT16)); + + for (int i = 0; i < len; i++) + indices[i] = glyphs[i]; + + FLOAT *advances = SAFE_ALLOCA (len * sizeof (FLOAT)); + + for (int i = 0; i < len; i++) + { + if (!text_extents_internal (dwrite_font_face, font_size, glyphs + i, 1, + &metrics)) + { + uniscribe_font->dwrite_skip_font = true; + SAFE_FREE (); + return false; + } + advances[i] = metrics.width; + } + + DWRITE_GLYPH_RUN glyph_run; + glyph_run.fontFace = dwrite_font_face; + glyph_run.fontEmSize = font_size; + glyph_run.glyphIndices = indices; + glyph_run.glyphCount = len; + glyph_run.isSideways = false; + glyph_run.bidiLevel = 0; /* we reorder bidi text ourselves */ + glyph_run.glyphOffsets = NULL; + glyph_run.glyphAdvances = advances; + + IDWriteColorGlyphRunEnumerator *layers; + /* This call will tell us if we have to handle any color glyphs. */ + hr = dwrite_factory2->lpVtbl->TranslateColorGlyphRun (dwrite_factory2, + left_margin, font->ascent, + &glyph_run, + NULL, + MEASURING_MODE, + NULL, + 0, + &layers); + + /* No color. Just draw the GlyphRun. */ + if (hr == DWRITE_E_NOCOLOR) + bitmap_render_target->lpVtbl->DrawGlyphRun (bitmap_render_target, + left_margin, font->ascent, + MEASURING_MODE, + &glyph_run, + rendering_params, + color, + NULL); + else + { + /* If there were color glyphs, 'layers' contains a list of + GlyphRun with a color and a position for each. We draw them + individually. */ + if (!verify_hr (hr, "Failed at TranslateColorGlyphRun")) + { + uniscribe_font->dwrite_skip_font = true; + RELEASE_COM (layers); + SAFE_FREE (); + return false; + } + for (;;) + { + HRESULT hr; + BOOL more_layers; + const DWRITE_COLOR_GLYPH_RUN *layer; + + hr = layers->lpVtbl->MoveNext (layers, &more_layers); + if (!verify_hr (hr, "Failed at MoveNext")) + { + uniscribe_font->dwrite_skip_font = true; + RELEASE_COM (layers); + SAFE_FREE (); + return false; + } + if (!more_layers) + break; + hr = layers->lpVtbl->GetCurrentRun (layers, &layer); + if (!verify_hr (hr, "Failed at GetCurrentRun")) + { + uniscribe_font->dwrite_skip_font = true; + RELEASE_COM (layers); + SAFE_FREE (); + return false; + } + hr = bitmap_render_target->lpVtbl->DrawGlyphRun + (bitmap_render_target, + layer->baselineOriginX, + layer->baselineOriginY, + MEASURING_MODE, + &layer->glyphRun, + rendering_params, + RGB (layer->runColor.r * 255, + layer->runColor.g * 255, + layer->runColor.b * 255), + NULL); + if (!verify_hr (hr, "Failed at GetCurrentRun")) + { + uniscribe_font->dwrite_skip_font = true; + RELEASE_COM (layers); + SAFE_FREE (); + return false; + } + } + RELEASE_COM (layers); + } + + /* Finally, copy the rendered text back to the original DC. */ + BitBlt (hdc, x - left_margin, y, bitmap_width, bitmap_height, text_dc, 0, 0, SRCCOPY); + SAFE_FREE (); + return true; +} + +/* Returns true if DirectWrite is to be used: + - It is available. + - The font is handled by HarfBuzz. + - w32-inhibit-dwrite is false. + - The font has not been marked after a failed DirectWrite operation. +*/ +bool +w32_use_direct_write (struct w32font_info *w32font) +{ +#ifdef HAVE_HARFBUZZ + return (direct_write_available + && w32font->font.driver == &harfbuzz_font_driver + && !w32_inhibit_dwrite + && !((struct uniscribe_font_info *) w32font)->dwrite_skip_font); +#else + return false; +#endif +} + +DEFUN ("w32-dwrite-available", Fw32_dwrite_available, Sw32_dwrite_available, 0, 0, 0, + doc: /* Returns t if DirectWrite is available. +DirectWrite will be used if it is available and 'w32-inhibit-dwrite' is nil. */) + (void) +{ + return direct_write_available ? Qt : Qnil; +} + +DEFUN ("w32-dwrite-reinit", Fw32_dwrite_reinit, Sw32_dwrite_reinit, 0, 3, 0, + doc: /* Reinitialize DirectWrite with the given parameters. +If a parameter is not specified, or is out of range, it will take a default +value. + +Return value is nil. + +ENHANCED_CONTRAST is in the range [0.0, 1.0], and defaults to 0.5. +CLEAR_TYPE_LEVEL is in the range [0.0, 1.0], and defaults to 1.0. +GAMMA is in the range (0.0, 256.0], and defaults to a system-dependent value + around 2.0 (sometimes 1.8, sometimes 2.2). */) + (Lisp_Object enhanced_contrast, Lisp_Object clear_type_level, + Lisp_Object gamma) +{ + config_enhanced_contrast = -1.0f; + if (FLOATP (enhanced_contrast)) + config_enhanced_contrast = XFLOAT_DATA (enhanced_contrast); + if (FIXNUMP (enhanced_contrast)) + config_enhanced_contrast = XFIXNUM (enhanced_contrast); + + config_clear_type_level = -1.0f; + if (FLOATP (clear_type_level)) + config_clear_type_level = XFLOAT_DATA (clear_type_level); + if (FIXNUMP (clear_type_level)) + config_clear_type_level = XFIXNUM (clear_type_level); + + config_gamma = -1.0f; + if (FLOATP (gamma)) + config_gamma = XFLOAT_DATA (gamma); + if (FIXNUMP (gamma)) + config_gamma = XFIXNUM (gamma); + + w32_initialize_direct_write (); + + return Qnil; +} + +void +syms_of_w32dwrite (void) +{ + DEFVAR_BOOL ("w32-inhibit-dwrite", w32_inhibit_dwrite, + doc: /* If t, don't use DirectWrite. */); + /* The actual value is determined at startup in + w32_initialize_direct_write, which is called from + syms_of_w32uniscribe_for_pdumper. */ + w32_inhibit_dwrite = false; + + defsubr (&Sw32_dwrite_reinit); + defsubr (&Sw32_dwrite_available); +} diff --git a/src/w32fns.c b/src/w32fns.c index 3ee13dcbbdd..e2455b9271e 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -2479,9 +2479,22 @@ static Lisp_Object process_dropfiles (DROPFILES *files) { char *start_of_files = (char *) files + files->pFiles; +#ifndef NTGUI_UNICODE char filename[MAX_UTF8_PATH]; +#endif Lisp_Object lisp_files = Qnil; +#ifdef NTGUI_UNICODE + WCHAR *p = (WCHAR *) start_of_files; + for (; *p; p += wcslen (p) + 1) + { + Lisp_Object fn = from_unicode_buffer (p); +#ifdef CYGWIN + fn = Fcygwin_convert_file_name_to_windows (fn, Qt); +#endif + lisp_files = Fcons (fn, lisp_files); + } +#else if (files->fWide) { WCHAR *p = (WCHAR *) start_of_files; @@ -2502,10 +2515,10 @@ process_dropfiles (DROPFILES *files) lisp_files); } } +#endif return lisp_files; } - /* This function can be called ONLY between calls to block_input/unblock_input. It is used in w32_read_socket. */ Lisp_Object @@ -2549,6 +2562,7 @@ struct w32_drop_target { /* i_drop_target must be the first member. */ IDropTarget i_drop_target; HWND hwnd; + int ref_count; }; static HRESULT STDMETHODCALLTYPE @@ -2560,18 +2574,34 @@ w32_drop_target_QueryInterface (IDropTarget *t, REFIID ri, void **r) static ULONG STDMETHODCALLTYPE w32_drop_target_AddRef (IDropTarget *This) { - return 1; + struct w32_drop_target *target = (struct w32_drop_target *) This; + return ++target->ref_count; } static ULONG STDMETHODCALLTYPE w32_drop_target_Release (IDropTarget *This) { struct w32_drop_target *target = (struct w32_drop_target *) This; + if (--target->ref_count > 0) + return target->ref_count; free (target->i_drop_target.lpVtbl); free (target); return 0; } +static void +w32_handle_drag_movement (IDropTarget *This, POINTL pt) +{ + struct w32_drop_target *target = (struct w32_drop_target *)This; + + W32Msg msg = {0}; + msg.dwModifiers = w32_get_modifiers (); + msg.msg.time = GetMessageTime (); + msg.msg.pt.x = pt.x; + msg.msg.pt.y = pt.y; + my_post_msg (&msg, target->hwnd, WM_EMACS_DRAGOVER, 0, 0 ); +} + static HRESULT STDMETHODCALLTYPE w32_drop_target_DragEnter (IDropTarget *This, IDataObject *pDataObj, DWORD grfKeyState, POINTL pt, DWORD *pdwEffect) @@ -2581,6 +2611,7 @@ w32_drop_target_DragEnter (IDropTarget *This, IDataObject *pDataObj, happen on drop. We send COPY because our use cases don't modify or link to the original data. */ *pdwEffect = DROPEFFECT_COPY; + w32_handle_drag_movement (This, pt); return S_OK; } @@ -2590,6 +2621,7 @@ w32_drop_target_DragOver (IDropTarget *This, DWORD grfKeyState, POINTL pt, { /* See comment in w32_drop_target_DragEnter. */ *pdwEffect = DROPEFFECT_COPY; + w32_handle_drag_movement (This, pt); return S_OK; } @@ -2742,6 +2774,7 @@ w32_createwindow (struct frame *f, int *coords) if (vtbl != NULL) { drop_target->hwnd = hwnd; + drop_target->ref_count = 0; drop_target->i_drop_target.lpVtbl = vtbl; vtbl->QueryInterface = w32_drop_target_QueryInterface; vtbl->AddRef = w32_drop_target_AddRef; @@ -3607,6 +3640,7 @@ w32_name_of_message (UINT msg) M (WM_EMACS_PAINT), M (WM_EMACS_IME_STATUS), M (WM_CHAR), + M (WM_EMACS_DRAGOVER), M (WM_EMACS_DROP), #undef M { 0, 0 } diff --git a/src/w32font.c b/src/w32font.c index efb42d80336..48968a28fbd 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -452,6 +452,10 @@ w32font_text_extents (struct font *font, const unsigned *code, memset (metrics, 0, sizeof (struct font_metrics)); + if (w32_use_direct_write (w32_font) + && w32_dwrite_text_extents (font, code, nglyphs, metrics)) + return; + for (i = 0, first = true; i < nglyphs; i++) { struct w32_metric_cache *char_metric; @@ -706,22 +710,31 @@ w32font_draw (struct glyph_string *s, int from, int to, int i; for (i = 0; i < len; i++) - { - WCHAR c = s->char2b[from + i] & 0xFFFF; - ExtTextOutW (s->hdc, x + i, y, options, NULL, &c, 1, NULL); - } + if (!w32_use_direct_write (w32font) + || !w32_dwrite_draw (s->hdc, x, y, s->char2b + from, 1, + GetTextColor (s->hdc), s->font)) + { + WCHAR c = s->char2b[from + i] & 0xFFFF; + ExtTextOutW (s->hdc, x + i, y, options, NULL, &c, 1, NULL); + } } else { - /* The number of glyphs in a glyph_string cannot be larger than - the maximum value of the 'used' member of a glyph_row, so we - are OK using alloca here. */ - eassert (len <= SHRT_MAX); - WCHAR *chars = alloca (len * sizeof (WCHAR)); - int j; - for (j = 0; j < len; j++) - chars[j] = s->char2b[from + j] & 0xFFFF; - ExtTextOutW (s->hdc, x, y, options, NULL, chars, len, NULL); + if (!w32_use_direct_write (w32font) + || !w32_dwrite_draw (s->hdc, x, y, + s->char2b + from, len, GetTextColor (s->hdc), + s->font)) + { + /* The number of glyphs in a glyph_string cannot be larger than + the maximum value of the 'used' member of a glyph_row, so we + are OK using alloca here. */ + eassert (len <= SHRT_MAX); + WCHAR *chars = alloca (len * sizeof (WCHAR)); + int j; + for (j = 0; j < len; j++) + chars[j] = s->char2b[from + j] & 0xFFFF; + ExtTextOutW (s->hdc, x, y, options, NULL, chars, len, NULL); + } } /* Restore clip region. */ diff --git a/src/w32font.h b/src/w32font.h index 3f780c1d866..74552a5bee5 100644 --- a/src/w32font.h +++ b/src/w32font.h @@ -57,6 +57,26 @@ struct w32font_info HFONT hfont; }; +/* Extension of w32font_info used by Uniscribe and HarfBuzz backends. */ +struct uniscribe_font_info +{ + struct w32font_info w32_font; + /* This is used by the Uniscribe backend as a pointer to the script + cache, and by the HarfBuzz backend as a pointer to a hb_font_t + object. */ + void *cache; + /* This is used by the HarfBuzz backend to store the font scale. */ + double scale; + /* This is used by DirectWrite to store the FontFace object. + DirectWrite works on top of the HarfBuzz backend, modifying some + calls. If there are problems manipulating this font, + dwrite_skip_font is set to true. Future operations will not use + DirectWrite and fall back to the HarfBuzz backend. */ + void *dwrite_cache; + float dwrite_font_size; + bool dwrite_skip_font; +}; + /* Macros for getting OS specific information from a font struct. */ #define FONT_HANDLE(f) (((struct w32font_info *)(f))->hfont) #define FONT_TEXTMETRIC(f) (((struct w32font_info *)(f))->metrics) @@ -84,6 +104,17 @@ int uniscribe_check_otf (LOGFONT *font, Lisp_Object otf_spec); Lisp_Object intern_font_name (char *); +/* Function prototypes for DirectWrite. */ +void w32_initialize_direct_write (void); +bool w32_use_direct_write (struct w32font_info *w32font); +bool w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, + COLORREF color, struct font *font ); +bool w32_dwrite_text_extents (struct font *font, const unsigned *code, + int nglyphs, struct font_metrics *metrics); +unsigned w32_dwrite_encode_char (struct font *font, int c); +void w32_dwrite_free_cached_face (void *cache); +void syms_of_w32dwrite (void); + extern void globals_of_w32font (void); #endif diff --git a/src/w32gdiplus.h b/src/w32gdiplus.h new file mode 100644 index 00000000000..b438b1a64f8 --- /dev/null +++ b/src/w32gdiplus.h @@ -0,0 +1,139 @@ +#ifdef WINDOWSNT +typedef GpStatus (WINGDIPAPI *GdiplusStartup_Proc) + (ULONG_PTR *, GdiplusStartupInput *, GdiplusStartupOutput *); +typedef VOID (WINGDIPAPI *GdiplusShutdown_Proc) (ULONG_PTR); +typedef GpStatus (WINGDIPAPI *GdipCreateFromHDC_Proc) + (HDC hdc, GpGraphics **graphics); +typedef GpStatus (WINGDIPAPI *GdipDeleteGraphics_Proc) (GpGraphics *graphics); +typedef GpStatus (WINGDIPAPI *GdipGetPropertyItemSize_Proc) + (GpImage *, PROPID, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetPropertyItem_Proc) + (GpImage *, PROPID, UINT, PropertyItem *); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsCount_Proc) + (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsList_Proc) + (GpImage *, GUID *, UINT); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameCount_Proc) + (GpImage *, GDIPCONST GUID *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipImageSelectActiveFrame_Proc) + (GpImage*, GDIPCONST GUID *, UINT); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromFile_Proc) + (WCHAR *, GpBitmap **); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromStream_Proc) + (IStream *, GpBitmap **); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromScan0_Proc) + (INT, INT, INT, PixelFormat, BYTE*, GpBitmap**); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromHBITMAP_Proc) + (HBITMAP hbm, HPALETTE hpal, GpBitmap** bitmap); +typedef GpStatus (WINGDIPAPI *GdipSetInterpolationMode_Proc) + (GpGraphics *graphics, InterpolationMode interpolationMode); +typedef GpStatus (WINGDIPAPI *GdipDrawImageRectRectI_Proc) + (GpGraphics *graphics, GpImage *image, INT dstx, INT dsty, INT dstwidth, + INT dstheight, INT srcx, INT srcy, INT srcwidth, INT srcheight, + GpUnit srcUnit, GDIPCONST GpImageAttributes* imageAttributes, + DrawImageAbort callback, VOID * callbackData); +typedef IStream * (WINAPI *SHCreateMemStream_Proc) (const BYTE *, UINT); +typedef GpStatus (WINGDIPAPI *GdipCreateHBITMAPFromBitmap_Proc) + (GpBitmap *, HBITMAP *, ARGB); +typedef GpStatus (WINGDIPAPI *GdipDisposeImage_Proc) (GpImage *); +typedef GpStatus (WINGDIPAPI *GdipGetImageHeight_Proc) (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetImageWidth_Proc) (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetImageEncodersSize_Proc) (UINT *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetImageEncoders_Proc) + (UINT, UINT, ImageCodecInfo *); +typedef GpStatus (WINGDIPAPI *GdipLoadImageFromFile_Proc) + (GDIPCONST WCHAR *,GpImage **); +typedef GpStatus (WINGDIPAPI *GdipGetImageThumbnail_Proc) + (GpImage *, UINT, UINT, GpImage**, GetThumbnailImageAbort, VOID *); +typedef GpStatus (WINGDIPAPI *GdipSaveImageToFile_Proc) + (GpImage *, GDIPCONST WCHAR *, GDIPCONST CLSID *, + GDIPCONST EncoderParameters *); +typedef GpStatus (WINGDIPAPI *GdipImageRotateFlip_Proc) + (GpImage *image, RotateFlipType rfType); + +extern GdiplusStartup_Proc fn_GdiplusStartup; +extern GdiplusShutdown_Proc fn_GdiplusShutdown; +extern GdipCreateFromHDC_Proc fn_GdipCreateFromHDC; +extern GdipDeleteGraphics_Proc fn_GdipDeleteGraphics; +extern GdipGetPropertyItemSize_Proc fn_GdipGetPropertyItemSize; +extern GdipGetPropertyItem_Proc fn_GdipGetPropertyItem; +extern GdipImageGetFrameDimensionsCount_Proc fn_GdipImageGetFrameDimensionsCount; +extern GdipImageGetFrameDimensionsList_Proc fn_GdipImageGetFrameDimensionsList; +extern GdipImageGetFrameCount_Proc fn_GdipImageGetFrameCount; +extern GdipImageSelectActiveFrame_Proc fn_GdipImageSelectActiveFrame; +extern GdipCreateBitmapFromFile_Proc fn_GdipCreateBitmapFromFile; +extern GdipCreateBitmapFromStream_Proc fn_GdipCreateBitmapFromStream; +extern GdipCreateBitmapFromHBITMAP_Proc fn_GdipCreateBitmapFromHBITMAP; +extern GdipDrawImageRectRectI_Proc fn_GdipDrawImageRectRectI; +extern GdipSetInterpolationMode_Proc fn_GdipSetInterpolationMode; +extern GdipCreateBitmapFromScan0_Proc fn_GdipCreateBitmapFromScan0; +extern SHCreateMemStream_Proc fn_SHCreateMemStream; +extern GdipCreateHBITMAPFromBitmap_Proc fn_GdipCreateHBITMAPFromBitmap; +extern GdipDisposeImage_Proc fn_GdipDisposeImage; +extern GdipGetImageHeight_Proc fn_GdipGetImageHeight; +extern GdipGetImageWidth_Proc fn_GdipGetImageWidth; +extern GdipGetImageEncodersSize_Proc fn_GdipGetImageEncodersSize; +extern GdipGetImageEncoders_Proc fn_GdipGetImageEncoders; +extern GdipLoadImageFromFile_Proc fn_GdipLoadImageFromFile; +extern GdipGetImageThumbnail_Proc fn_GdipGetImageThumbnail; +extern GdipSaveImageToFile_Proc fn_GdipSaveImageToFile; +extern GdipImageRotateFlip_Proc fn_GdipImageRotateFlip; + +# undef GdiplusStartup +# undef GdiplusShutdown +# undef GdipGetPropertyItemSize +# undef GdipGetPropertyItem +# undef GdipImageGetFrameDimensionsCount +# undef GdipImageGetFrameDimensionsList +# undef GdipImageGetFrameCount +# undef GdipImageSelectActiveFrame +# undef GdipCreateBitmapFromFile +# undef GdipCreateBitmapFromStream +# undef GdipCreateBitmapFromScan0 +# undef GdipCreateBitmapFromHBITMAP +# undef GdipCreateFromHDC +# undef GdipDrawImageRectRectI +# undef GdipSetInterpolationMode +# undef GdipDeleteGraphics +# undef SHCreateMemStream +# undef GdipCreateHBITMAPFromBitmap +# undef GdipDisposeImage +# undef GdipGetImageHeight +# undef GdipGetImageWidth +# undef GdipGetImageEncodersSize +# undef GdipGetImageEncoders +# undef GdipLoadImageFromFile +# undef GdipGetImageThumbnail +# undef GdipSaveImageToFile +# undef GdipSaveImageRotateFlip + +# define GdiplusStartup fn_GdiplusStartup +# define GdiplusShutdown fn_GdiplusShutdown +# define GdipGetPropertyItemSize fn_GdipGetPropertyItemSize +# define GdipGetPropertyItem fn_GdipGetPropertyItem +# define GdipImageGetFrameDimensionsCount fn_GdipImageGetFrameDimensionsCount +# define GdipImageGetFrameDimensionsList fn_GdipImageGetFrameDimensionsList +# define GdipImageGetFrameCount fn_GdipImageGetFrameCount +# define GdipImageSelectActiveFrame fn_GdipImageSelectActiveFrame +# define GdipCreateBitmapFromFile fn_GdipCreateBitmapFromFile +# define GdipCreateBitmapFromStream fn_GdipCreateBitmapFromStream +# define GdipCreateBitmapFromScan0 fn_GdipCreateBitmapFromScan0 +# define GdipCreateBitmapFromHBITMAP fn_GdipCreateBitmapFromHBITMAP +# define GdipCreateFromHDC fn_GdipCreateFromHDC +# define GdipDrawImageRectRectI fn_GdipDrawImageRectRectI +# define GdipSetInterpolationMode fn_GdipSetInterpolationMode +# define GdipDeleteGraphics fn_GdipDeleteGraphics +# define SHCreateMemStream fn_SHCreateMemStream +# define GdipCreateHBITMAPFromBitmap fn_GdipCreateHBITMAPFromBitmap +# define GdipDisposeImage fn_GdipDisposeImage +# define GdipGetImageHeight fn_GdipGetImageHeight +# define GdipGetImageWidth fn_GdipGetImageWidth +# define GdipGetImageEncodersSize fn_GdipGetImageEncodersSize +# define GdipGetImageEncoders fn_GdipGetImageEncoders +# define GdipLoadImageFromFile fn_GdipLoadImageFromFile +# define GdipGetImageThumbnail fn_GdipGetImageThumbnail +# define GdipSaveImageToFile fn_GdipSaveImageToFile +# define GdipImageRotateFlip fn_GdipImageRotateFlip +#endif + +int w32_gdip_get_encoder_clsid (const char *type, CLSID *clsid); diff --git a/src/w32gui.h b/src/w32gui.h index 739a790911e..26565dcae6b 100644 --- a/src/w32gui.h +++ b/src/w32gui.h @@ -45,7 +45,9 @@ struct image; extern int w32_load_image (struct frame *f, struct image *img, Lisp_Object spec_file, Lisp_Object spec_data); extern bool w32_can_use_native_image_api (Lisp_Object); +extern bool w32_gdiplus_startup (void); extern void w32_gdiplus_shutdown (void); + extern size_t w32_image_size (Emacs_Pixmap); #define FACE_DEFAULT (~0) diff --git a/src/w32image.c b/src/w32image.c index 359a4fa3a72..da4d6843ba9 100644 --- a/src/w32image.c +++ b/src/w32image.c @@ -38,46 +38,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "frame.h" #include "coding.h" +#include "w32gdiplus.h" #ifdef WINDOWSNT - -typedef GpStatus (WINGDIPAPI *GdiplusStartup_Proc) - (ULONG_PTR *, GdiplusStartupInput *, GdiplusStartupOutput *); -typedef VOID (WINGDIPAPI *GdiplusShutdown_Proc) (ULONG_PTR); -typedef GpStatus (WINGDIPAPI *GdipGetPropertyItemSize_Proc) - (GpImage *, PROPID, UINT *); -typedef GpStatus (WINGDIPAPI *GdipGetPropertyItem_Proc) - (GpImage *, PROPID, UINT, PropertyItem *); -typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsCount_Proc) - (GpImage *, UINT *); -typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsList_Proc) - (GpImage *, GUID *, UINT); -typedef GpStatus (WINGDIPAPI *GdipImageGetFrameCount_Proc) - (GpImage *, GDIPCONST GUID *, UINT *); -typedef GpStatus (WINGDIPAPI *GdipImageSelectActiveFrame_Proc) - (GpImage*, GDIPCONST GUID *, UINT); -typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromFile_Proc) - (WCHAR *, GpBitmap **); -typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromStream_Proc) - (IStream *, GpBitmap **); -typedef IStream * (WINAPI *SHCreateMemStream_Proc) (const BYTE *, UINT); -typedef GpStatus (WINGDIPAPI *GdipCreateHBITMAPFromBitmap_Proc) - (GpBitmap *, HBITMAP *, ARGB); -typedef GpStatus (WINGDIPAPI *GdipDisposeImage_Proc) (GpImage *); -typedef GpStatus (WINGDIPAPI *GdipGetImageHeight_Proc) (GpImage *, UINT *); -typedef GpStatus (WINGDIPAPI *GdipGetImageWidth_Proc) (GpImage *, UINT *); -typedef GpStatus (WINGDIPAPI *GdipGetImageEncodersSize_Proc) (UINT *, UINT *); -typedef GpStatus (WINGDIPAPI *GdipGetImageEncoders_Proc) - (UINT, UINT, ImageCodecInfo *); -typedef GpStatus (WINGDIPAPI *GdipLoadImageFromFile_Proc) - (GDIPCONST WCHAR *,GpImage **); -typedef GpStatus (WINGDIPAPI *GdipGetImageThumbnail_Proc) - (GpImage *, UINT, UINT, GpImage**, GetThumbnailImageAbort, VOID *); -typedef GpStatus (WINGDIPAPI *GdipSaveImageToFile_Proc) - (GpImage *, GDIPCONST WCHAR *, GDIPCONST CLSID *, - GDIPCONST EncoderParameters *); - GdiplusStartup_Proc fn_GdiplusStartup; GdiplusShutdown_Proc fn_GdiplusShutdown; +GdipCreateFromHDC_Proc fn_GdipCreateFromHDC; +GdipDeleteGraphics_Proc fn_GdipDeleteGraphics; GdipGetPropertyItemSize_Proc fn_GdipGetPropertyItemSize; GdipGetPropertyItem_Proc fn_GdipGetPropertyItem; GdipImageGetFrameDimensionsCount_Proc fn_GdipImageGetFrameDimensionsCount; @@ -86,8 +52,12 @@ GdipImageGetFrameCount_Proc fn_GdipImageGetFrameCount; GdipImageSelectActiveFrame_Proc fn_GdipImageSelectActiveFrame; GdipCreateBitmapFromFile_Proc fn_GdipCreateBitmapFromFile; GdipCreateBitmapFromStream_Proc fn_GdipCreateBitmapFromStream; +GdipCreateBitmapFromScan0_Proc fn_GdipCreateBitmapFromScan0; SHCreateMemStream_Proc fn_SHCreateMemStream; GdipCreateHBITMAPFromBitmap_Proc fn_GdipCreateHBITMAPFromBitmap; +GdipCreateBitmapFromHBITMAP_Proc fn_GdipCreateBitmapFromHBITMAP; +GdipDrawImageRectRectI_Proc fn_GdipDrawImageRectRectI; +GdipSetInterpolationMode_Proc fn_GdipSetInterpolationMode; GdipDisposeImage_Proc fn_GdipDisposeImage; GdipGetImageHeight_Proc fn_GdipGetImageHeight; GdipGetImageWidth_Proc fn_GdipGetImageWidth; @@ -96,6 +66,7 @@ GdipGetImageEncoders_Proc fn_GdipGetImageEncoders; GdipLoadImageFromFile_Proc fn_GdipLoadImageFromFile; GdipGetImageThumbnail_Proc fn_GdipGetImageThumbnail; GdipSaveImageToFile_Proc fn_GdipSaveImageToFile; +GdipImageRotateFlip_Proc fn_GdipImageRotateFlip; static bool gdiplus_init (void) @@ -114,6 +85,14 @@ gdiplus_init (void) get_proc_addr (gdiplus_lib, "GdiplusShutdown"); if (!fn_GdiplusShutdown) return false; + fn_GdipCreateFromHDC = (GdipCreateFromHDC_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateFromHDC"); + if (!fn_GdipCreateFromHDC) + return false; + fn_GdipDeleteGraphics = (GdipDeleteGraphics_Proc) + get_proc_addr (gdiplus_lib, "GdipDeleteGraphics"); + if (!fn_GdipDeleteGraphics) + return false; fn_GdipGetPropertyItemSize = (GdipGetPropertyItemSize_Proc) get_proc_addr (gdiplus_lib, "GdipGetPropertyItemSize"); if (!fn_GdipGetPropertyItemSize) @@ -146,10 +125,26 @@ gdiplus_init (void) get_proc_addr (gdiplus_lib, "GdipCreateBitmapFromStream"); if (!fn_GdipCreateBitmapFromStream) return false; + fn_GdipCreateBitmapFromScan0 = (GdipCreateBitmapFromScan0_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateBitmapFromScan0"); + if (!fn_GdipCreateBitmapFromScan0) + return false; fn_GdipCreateHBITMAPFromBitmap = (GdipCreateHBITMAPFromBitmap_Proc) get_proc_addr (gdiplus_lib, "GdipCreateHBITMAPFromBitmap"); if (!fn_GdipCreateHBITMAPFromBitmap) return false; + fn_GdipCreateBitmapFromHBITMAP = (GdipCreateBitmapFromHBITMAP_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateBitmapFromHBITMAP"); + if (!fn_GdipCreateBitmapFromHBITMAP) + return false; + fn_GdipDrawImageRectRectI = (GdipDrawImageRectRectI_Proc) + get_proc_addr (gdiplus_lib, "GdipDrawImageRectRectI"); + if (!fn_GdipDrawImageRectRectI) + return false; + fn_GdipSetInterpolationMode = (GdipSetInterpolationMode_Proc) + get_proc_addr (gdiplus_lib, "GdipSetInterpolationMode"); + if (!fn_GdipSetInterpolationMode) + return false; fn_GdipDisposeImage = (GdipDisposeImage_Proc) get_proc_addr (gdiplus_lib, "GdipDisposeImage"); if (!fn_GdipDisposeImage) @@ -196,52 +191,14 @@ gdiplus_init (void) get_proc_addr (gdiplus_lib, "GdipSaveImageToFile"); if (!fn_GdipSaveImageToFile) return false; + fn_GdipImageRotateFlip = (GdipImageRotateFlip_Proc) + get_proc_addr (gdiplus_lib, "GdipImageRotateFlip"); + if (!fn_GdipImageRotateFlip) + return false; return true; } -# undef GdiplusStartup -# undef GdiplusShutdown -# undef GdipGetPropertyItemSize -# undef GdipGetPropertyItem -# undef GdipImageGetFrameDimensionsCount -# undef GdipImageGetFrameDimensionsList -# undef GdipImageGetFrameCount -# undef GdipImageSelectActiveFrame -# undef GdipCreateBitmapFromFile -# undef GdipCreateBitmapFromStream -# undef SHCreateMemStream -# undef GdipCreateHBITMAPFromBitmap -# undef GdipDisposeImage -# undef GdipGetImageHeight -# undef GdipGetImageWidth -# undef GdipGetImageEncodersSize -# undef GdipGetImageEncoders -# undef GdipLoadImageFromFile -# undef GdipGetImageThumbnail -# undef GdipSaveImageToFile - -# define GdiplusStartup fn_GdiplusStartup -# define GdiplusShutdown fn_GdiplusShutdown -# define GdipGetPropertyItemSize fn_GdipGetPropertyItemSize -# define GdipGetPropertyItem fn_GdipGetPropertyItem -# define GdipImageGetFrameDimensionsCount fn_GdipImageGetFrameDimensionsCount -# define GdipImageGetFrameDimensionsList fn_GdipImageGetFrameDimensionsList -# define GdipImageGetFrameCount fn_GdipImageGetFrameCount -# define GdipImageSelectActiveFrame fn_GdipImageSelectActiveFrame -# define GdipCreateBitmapFromFile fn_GdipCreateBitmapFromFile -# define GdipCreateBitmapFromStream fn_GdipCreateBitmapFromStream -# define SHCreateMemStream fn_SHCreateMemStream -# define GdipCreateHBITMAPFromBitmap fn_GdipCreateHBITMAPFromBitmap -# define GdipDisposeImage fn_GdipDisposeImage -# define GdipGetImageHeight fn_GdipGetImageHeight -# define GdipGetImageWidth fn_GdipGetImageWidth -# define GdipGetImageEncodersSize fn_GdipGetImageEncodersSize -# define GdipGetImageEncoders fn_GdipGetImageEncoders -# define GdipLoadImageFromFile fn_GdipLoadImageFromFile -# define GdipGetImageThumbnail fn_GdipGetImageThumbnail -# define GdipSaveImageToFile fn_GdipSaveImageToFile - #endif /* WINDOWSNT */ static int gdip_initialized; @@ -252,8 +209,8 @@ static GdiplusStartupOutput output; /* Initialize GDI+, return true if successful. */ -static bool -gdiplus_startup (void) +bool +w32_gdiplus_startup (void) { GpStatus status; @@ -305,7 +262,7 @@ w32_can_use_native_image_api (Lisp_Object type) But we don't yet support these in image.c. */ return false; } - return gdiplus_startup (); + return w32_gdiplus_startup (); } enum PropertyItem_type { @@ -549,8 +506,8 @@ static struct thumb_type_data thumb_types [] = }; -static int -get_encoder_clsid (const char *type, CLSID *clsid) +int +w32_gdip_get_encoder_clsid (const char *type, CLSID *clsid) { /* A simple cache based on the assumptions that many thumbnails will be generated using the same TYPE. */ @@ -625,7 +582,7 @@ Return non-nil if thumbnail creation succeeds, nil otherwise. */) if (!gdiplus_started) { - if (!gdiplus_startup ()) + if (!w32_gdiplus_startup ()) return Qnil; } @@ -649,7 +606,7 @@ Return non-nil if thumbnail creation succeeds, nil otherwise. */) CLSID thumb_clsid; if (status == Ok /* Get the GUID of the TYPE's encoder. */ - && get_encoder_clsid (SSDATA (type), &thumb_clsid) >= 0) + && w32_gdip_get_encoder_clsid (SSDATA (type), &thumb_clsid) >= 0) { /* Save the thumbnail image to a file of specified TYPE. */ wchar_t thumb_file_w[MAX_PATH]; diff --git a/src/w32menu.c b/src/w32menu.c index c3d147841b6..92b4b9c6d3c 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -186,6 +186,11 @@ task_dialog_callback (HWND hwnd, UINT msg, WPARAM wParam, Lisp_Object w32_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) { +#ifdef NTGUI_UNICODE + typedef int (WINAPI *MultiByteToWideChar_Proc)(UINT,DWORD,LPCSTR,int, + LPWSTR, int); + static MultiByteToWideChar_Proc pMultiByteToWideChar = MultiByteToWideChar; +#endif /* NTGUI_UNICODE */ check_window_system (f); if (task_dialog_indirect) diff --git a/src/w32select.c b/src/w32select.c index 006bf408b47..646c8faf634 100644 --- a/src/w32select.c +++ b/src/w32select.c @@ -73,12 +73,22 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ */ #include <config.h> +#include <windows.h> +#include <wingdi.h> +#include <wtypes.h> +#include <gdiplus.h> +#ifndef CF_DIBV5 +# define CF_DIBV5 17 +# undef CF_MAX +# define CF_MAX 18 +#endif #include "lisp.h" #include "w32common.h" /* os_subtype */ #include "w32term.h" /* for all of the w32 includes */ #include "w32select.h" #include "blockinput.h" #include "coding.h" +#include "w32gdiplus.h" #ifdef CYGWIN #include <string.h> @@ -787,6 +797,170 @@ DEFUN ("w32-set-clipboard-data", Fw32_set_clipboard_data, return (ok ? string : Qnil); } +/* Xlib-like names for standard Windows clipboard data formats. + They are in upper-case to mimic xselect.c. A couple of the names + were changed to be more like their X counterparts. */ +static const char *stdfmt_name[] = { + "UNDEFINED", + "STRING", + "BITMAP", + "METAFILE", + "SYMLINK", + "DIF", + "TIFF", + "OEM_STRING", + "DIB", + "PALETTE", + "PENDATA", + "RIFF", + "WAVE", + "UTF8_STRING", + "ENHMETAFILE", + "FILE_NAMES", /* DND */ + "LOCALE", /* not used */ + "DIBV5" +}; + +/* Must be called with block_input() active. */ +static bool +convert_dibv5_to_png (char *data, int size, char *temp_file) +{ +#ifdef HAVE_NATIVE_IMAGE_API + CLSID clsid_png; + + if (!w32_gdiplus_startup () + || !w32_gdip_get_encoder_clsid ("png", &clsid_png)) + return false; + + BITMAPV5HEADER *bmi = (void *) data; + int stride = bmi->bV5SizeImage / bmi->bV5Height; + long offset = bmi->bV5Size + bmi->bV5ClrUsed * sizeof (RGBQUAD); + if (bmi->bV5Compression == BI_BITFIELDS) + offset += 12; + BYTE *scan0 = data + offset; + + GpBitmap *bitmap = NULL; + + GpStatus status + = GdipCreateBitmapFromScan0 (bmi->bV5Width, bmi->bV5Height, stride, + PixelFormat32bppARGB, scan0, &bitmap); + + if (status != Ok) + return false; + + /* The bitmap comes upside down. */ + GdipImageRotateFlip (bitmap, RotateNoneFlipY); + + WCHAR wide_filename[MAX_PATH]; + filename_to_utf16 (temp_file, wide_filename); + + status = GdipSaveImageToFile (bitmap, wide_filename, &clsid_png, NULL); + GdipDisposeImage (bitmap); + if (status != Ok) + return false; + return true; +#else /* !HAVE_NATIVE_IMAGE_API */ + return false; +#endif +} + +static int +get_clipboard_format_name (int format_index, char *name) +{ + *name = 0; + format_index = EnumClipboardFormats (format_index); + if (format_index == 0) + return 0; + if (format_index < CF_MAX) + strcpy (name, stdfmt_name[format_index]); + GetClipboardFormatName (format_index, name, 256); + return format_index; +} + +DEFUN ("w32--get-clipboard-data-media", Fw32__get_clipboard_data_media, + Sw32__get_clipboard_data_media, 3, 3, 0, + doc: /* Gets media (not plain text) clipboard data in one of the given formats. + +FORMATS is a list of formats. +TEMP-FILE-IN is the name of the file to store the data. + +Elements in FORMATS are symbols naming a format, such a image/png, or +image/jpeg. For compatibility with X systems, some conventional +format names are translated to equivalent MIME types, as configured with +the variable 'w32--selection-target-translations'. + +The file named in TEMP-FILE-IN must be created by the caller, and also +deleted if required. + +Returns nil it there is no such format, or something failed. +If it returns t, then the caller should read the file to get the data. +If it returns a string, then that is the data and the file is not used. + +When returning a string, it will be unibyte if IS-TEXTUAL is nil (the +content is binary data). */) + (Lisp_Object formats, Lisp_Object temp_file_in, Lisp_Object is_textual) +{ + CHECK_LIST (formats); + CHECK_STRING (temp_file_in); + + temp_file_in = Fexpand_file_name (temp_file_in, Qnil); + char *temp_file = SSDATA (ENCODE_FILE (temp_file_in)); + + Lisp_Object result = Qnil; + + block_input(); + if (!OpenClipboard (NULL)) + { + unblock_input(); + return Qnil; + } + + for (int format_index = 0;;) + { + static char name[256]; + format_index = get_clipboard_format_name (format_index, name); + if (format_index == 0) + break; + + /* If name doesn't match any of the formats, try the next format. */ + bool match = false; + for (Lisp_Object tail = formats; CONSP (tail); tail = XCDR (tail)) + if (strcmp (name, SSDATA (SYMBOL_NAME (XCAR (tail)))) == 0) + match = true; + if (!match) + continue; + + /* Of the standard formats, only DIBV5 is supported. */ + if (format_index < CF_MAX && format_index != CF_DIBV5) + continue; + + /* Found the format. */ + HANDLE d = GetClipboardData (format_index); + if (!d) + break; + int size = GlobalSize (d); + char *data = GlobalLock (d); + if (!data) + break; + if (strcmp (name, "DIBV5") == 0) + { + if (convert_dibv5_to_png (data, size, temp_file)) + result = Qt; + } + else + { + if (NILP (is_textual)) + result = make_unibyte_string (data, size); + else + result = make_string (data, size); + } + GlobalUnlock (d); + break; + } + CloseClipboard (); + unblock_input (); + return result; +} DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data, Sw32_get_clipboard_data, 0, 1, 0, @@ -1069,29 +1243,6 @@ for `CLIPBOARD'. The return value is a vector of symbols, each symbol representing a data format that is currently available in the clipboard. */) (Lisp_Object selection, Lisp_Object terminal) { - /* Xlib-like names for standard Windows clipboard data formats. - They are in upper-case to mimic xselect.c. A couple of the names - were changed to be more like their X counterparts. */ - static const char *stdfmt_name[] = { - "UNDEFINED", - "STRING", - "BITMAP", - "METAFILE", - "SYMLINK", - "DIF", - "TIFF", - "OEM_STRING", - "DIB", - "PALETTE", - "PENDATA", - "RIFF", - "WAVE", - "UTF8_STRING", - "ENHMETAFILE", - "FILE_NAMES", /* DND */ - "LOCALE", /* not used */ - "DIBV5" - }; CHECK_SYMBOL (selection); /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check @@ -1166,6 +1317,7 @@ syms_of_w32select (void) { defsubr (&Sw32_set_clipboard_data); defsubr (&Sw32_get_clipboard_data); + defsubr (&Sw32__get_clipboard_data_media); defsubr (&Sw32_selection_exists_p); defsubr (&Sw32_selection_targets); diff --git a/src/w32term.c b/src/w32term.c index e41d2fa3c34..aceb721f92b 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -24,6 +24,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "blockinput.h" #include "w32term.h" #include "w32common.h" /* for OS version info */ +#include <wtypes.h> +#include <gdiplus.h> +#include "w32gdiplus.h" #include <ctype.h> #include <errno.h> @@ -2106,16 +2109,53 @@ w32_draw_image_foreground (struct glyph_string *s) compat_hdc, s->slice.x, s->slice.y, SRCCOPY); else { - int pmode = 0; - /* Windows 9X doesn't support HALFTONE. */ - if (os_subtype == OS_SUBTYPE_NT - && (pmode = SetStretchBltMode (s->hdc, HALFTONE)) != 0) - SetBrushOrgEx (s->hdc, 0, 0, NULL); - StretchBlt (s->hdc, x, y, s->slice.width, s->slice.height, - compat_hdc, orig_slice_x, orig_slice_y, - orig_slice_width, orig_slice_height, SRCCOPY); - if (pmode) - SetStretchBltMode (s->hdc, pmode); +#ifdef HAVE_NATIVE_IMAGE_API + if (s->img->smoothing && w32_gdiplus_startup ()) + { + GpGraphics *graphics; + if (GdipCreateFromHDC (s->hdc, &graphics) == Ok) + { + GpBitmap *gp_bitmap; + /* Can't create a GpBitmap from a HBITMAP that was + ever selected into a DC, so we need to copy. */ + HBITMAP copy + = CopyImage (GetCurrentObject (compat_hdc, OBJ_BITMAP), + IMAGE_BITMAP, 0, 0, 0); + if (GdipCreateBitmapFromHBITMAP (copy, NULL, + &gp_bitmap) == Ok) + { + GdipSetInterpolationMode (graphics, + InterpolationModeHighQualityBilinear); + GdipDrawImageRectRectI (graphics, + gp_bitmap, x, y, + s->slice.width, + s->slice.height, + orig_slice_x, + orig_slice_y, + orig_slice_width, + orig_slice_height, + UnitPixel, + NULL, NULL, NULL); + GdipDisposeImage (gp_bitmap); + } + DeleteObject (copy); + GdipDeleteGraphics (graphics); + } + } + else +#endif + { + int pmode = 0; + /* Windows 9X doesn't support HALFTONE. */ + if (os_subtype == OS_SUBTYPE_NT + && (pmode = SetStretchBltMode (s->hdc, HALFTONE)) != 0) + SetBrushOrgEx (s->hdc, 0, 0, NULL); + StretchBlt (s->hdc, x, y, s->slice.width, s->slice.height, + compat_hdc, orig_slice_x, orig_slice_y, + orig_slice_width, orig_slice_height, SRCCOPY); + if (pmode) + SetStretchBltMode (s->hdc, pmode); + } } /* When the image has a mask, we can expect that at @@ -5629,6 +5669,24 @@ w32_read_socket (struct terminal *terminal, } break; + case WM_EMACS_DRAGOVER: + { + f = w32_window_to_frame (dpyinfo, msg.msg.hwnd); + if (!f) + break; + XSETFRAME (inev.frame_or_window, f); + inev.kind = DRAG_N_DROP_EVENT; + inev.code = 0; + inev.timestamp = msg.msg.time; + inev.modifiers = msg.dwModifiers; + ScreenToClient (msg.msg.hwnd, &msg.msg.pt); + XSETINT (inev.x, msg.msg.pt.x); + XSETINT (inev.y, msg.msg.pt.y); + /* This is a drag movement. */ + inev.arg = Qnil; + break; + } + case WM_HSCROLL: { struct scroll_bar *bar = diff --git a/src/w32term.h b/src/w32term.h index 39e2262e2a8..cad9fcf8cb1 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -711,8 +711,9 @@ do { \ #define WM_EMACS_INPUT_READY (WM_EMACS_START + 24) #define WM_EMACS_FILENOTIFY (WM_EMACS_START + 25) #define WM_EMACS_IME_STATUS (WM_EMACS_START + 26) -#define WM_EMACS_DROP (WM_EMACS_START + 27) -#define WM_EMACS_END (WM_EMACS_START + 28) +#define WM_EMACS_DRAGOVER (WM_EMACS_START + 27) +#define WM_EMACS_DROP (WM_EMACS_START + 28) +#define WM_EMACS_END (WM_EMACS_START + 29) #define WND_FONTWIDTH_INDEX (0) #define WND_LINEHEIGHT_INDEX (4) diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c index b77bf56b8cf..66d27b81b9e 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -44,18 +44,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "pdumper.h" #include "w32common.h" -/* Extension of w32font_info used by Uniscribe and HarfBuzz backends. */ -struct uniscribe_font_info -{ - struct w32font_info w32_font; - /* This is used by the Uniscribe backend as a pointer to the script - cache, and by the HarfBuzz backend as a pointer to a hb_font_t - object. */ - void *cache; - /* This is used by the HarfBuzz backend to store the font scale. */ - double scale; -}; - int uniscribe_available = 0; /* EnumFontFamiliesEx callback. */ @@ -200,6 +188,8 @@ uniscribe_open (struct frame *f, Lisp_Object font_entity, int pixel_size) /* Initialize the cache for this font. */ uniscribe_font->cache = NULL; + uniscribe_font->dwrite_cache = NULL; + uniscribe_font->dwrite_skip_font = false; /* Uniscribe and HarfBuzz backends use glyph indices. */ uniscribe_font->w32_font.glyph_idx = ETO_GLYPH_INDEX; @@ -221,6 +211,7 @@ uniscribe_close (struct font *font) = (struct uniscribe_font_info *) font; #ifdef HAVE_HARFBUZZ + w32_dwrite_free_cached_face (uniscribe_font->dwrite_cache); if (uniscribe_font->w32_font.font.driver == &harfbuzz_font_driver && uniscribe_font->cache) hb_font_destroy ((hb_font_t *) uniscribe_font->cache); @@ -1372,6 +1363,17 @@ w32hb_encode_char (struct font *font, int c) struct uniscribe_font_info *uniscribe_font = (struct uniscribe_font_info *) font; eassert (uniscribe_font->w32_font.font.driver == &harfbuzz_font_driver); + + if (w32_use_direct_write (&uniscribe_font->w32_font)) + { + unsigned encoded = w32_dwrite_encode_char (font, c); + + /* The call to w32_dwrite_encode_char may fail, disabling + DirectWrite for this font. So check again. */ + if (w32_use_direct_write (&uniscribe_font->w32_font)) + return encoded; + } + hb_font_t *hb_font = uniscribe_font->cache; /* First time we use this font with HarfBuzz, create the hb_font_t @@ -1624,5 +1626,8 @@ syms_of_w32uniscribe_for_pdumper (void) harfbuzz_font_driver.combining_capability = hbfont_combining_capability; harfbuzz_font_driver.begin_hb_font = w32hb_begin_font; register_font_driver (&harfbuzz_font_driver, NULL); + + w32_initialize_direct_write (); + #endif /* HAVE_HARFBUZZ */ } diff --git a/src/window.c b/src/window.c index 34968ac824f..7f157911685 100644 --- a/src/window.c +++ b/src/window.c @@ -6140,7 +6140,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) /* The last line was only partially visible, make it fully visible. */ w->vscroll = (it.last_visible_y - - it.current_y + it.max_ascent + it.max_descent); + - (it.current_y + it.max_ascent + it.max_descent)); adjust_frame_glyphs (it.f); } else diff --git a/src/xdisp.c b/src/xdisp.c index 7d9dd6e8e85..3364c6870cf 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -4993,7 +4993,7 @@ face_before_or_after_it_pos (struct it *it, bool before_p) /* For composition, we must check the position after the composition. */ pos.charpos += it->cmp_it.nchars; - pos.bytepos += it->len; + pos.bytepos += it->cmp_it.nbytes; } else INC_TEXT_POS (pos, it->multibyte_p); diff --git a/test/Makefile.in b/test/Makefile.in index 3cbdbec4414..7a3178546a1 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -170,7 +170,7 @@ WRITE_LOG = > $@ 2>&1 || { STAT=$$?; cat $@; exit $$STAT; } endif ## On Emba, always show logs for certain problematic tests. ifdef EMACS_EMBA_CI -lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.log \ +lisp/filenotify-tests.log lisp/net/tramp-tests.log \ : WRITE_LOG = 2>&1 | tee $@ endif diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 4763994c5d4..7e176df6803 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -132,12 +132,15 @@ This expects `auto-revert--messages' to be bound by (error (message "%s" err) (signal (car err) (cdr err))))))) (defmacro with-auto-revert-test (&rest body) - `(let ((auto-revert-interval-orig auto-revert-interval)) + `(let ((auto-revert-interval-orig auto-revert-interval) + (auto-revert--lockout-interval-orig auto-revert--lockout-interval)) (unwind-protect (progn (customize-set-variable 'auto-revert-interval 0.1) + (setq auto-revert--lockout-interval 0.05) ,@body) - (customize-set-variable 'auto-revert-interval auto-revert-interval-orig)))) + (customize-set-variable 'auto-revert-interval auto-revert-interval-orig) + (setq auto-revert--lockout-interval auto-revert--lockout-interval-orig)))) (defun auto-revert-tests--write-file (text file time-delta &optional append) (write-region text nil file append 'no-message) diff --git a/test/lisp/color-tests.el b/test/lisp/color-tests.el index 0f53e4332a4..3f7483a97c6 100644 --- a/test/lisp/color-tests.el +++ b/test/lisp/color-tests.el @@ -62,6 +62,12 @@ (should (equal (color-complement "#ffffffffffff") '(0.0 0.0 0.0))) (should (equal (color-complement "red") '(0.0 1.0 1.0)))) +(ert-deftest color-tests-blend () + (should (equal (color-blend '(1.0 0.0 0.0) '(0.0 1.0 0.0)) '(0.5 0.5 0.0))) + (should (equal (color-blend '(1.0 1.0 1.0) '(0.0 1.0 0.0)) '(0.5 1.0 0.5))) + (should (equal (color-blend '(0.0 0.39215686274509803 0.0) '(0.9607843137254902 0.8705882352941177 0.7019607843137254)) + '(0.4803921568627451 0.6313725490196078 0.3509803921568627)))) + (ert-deftest color-tests-gradient () (should-not (color-gradient '(0 0 0) '(255 255 255) 0)) (should @@ -222,14 +228,11 @@ (should (equal (color-lighten-hsl 360 0.5 0.5 0) '(360 0.5 0.5))) (should (equal (color-lighten-hsl 360 0.5 0.5 -10) '(360 0.5 0.45))) (should (equal (color-lighten-hsl 360 0.5 0.5 -500) '(360 0.5 0.0))) - (should - (color-tests--approx-equal - (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.84))) - (should - (equal (color-lighten-hsl 120 0.5 0.8 500) '(120 0.5 1.0)))) + (should (equal (color-lighten-hsl 120 0.5 0.8 5) '(120 0.5 0.81))) + (should (equal (color-lighten-hsl 120 0.5 0.8 500) '(120 0.5 1.0)))) (ert-deftest color-tests-lighten-name () - (should (equal (color-lighten-name "black" 100) "#000000000000")) + (should (equal (color-lighten-name "black" 100) "#ffffffffffff")) (should (equal (color-lighten-name "white" 100) "#ffffffffffff")) (should (equal (color-lighten-name "red" 0) "#ffff00000000")) (should (equal (color-lighten-name "red" 10) "#ffff19991999"))) diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 10a4ff34239..0d6fc701eec 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -73,9 +73,9 @@ happen to lurk on PATH when running the test suite." (defun comint-tests/test-password-function (password-function) "PASSWORD-FUNCTION can return nil or a string." - (when-let ((cat (if (eq system-type 'windows-nt) - (w32-native-executable-find "cat") - (executable-find "cat")))) + (when-let* ((cat (if (eq system-type 'windows-nt) + (w32-native-executable-find "cat") + (executable-find "cat")))) (let ((comint-password-function password-function)) (cl-letf (((symbol-function 'read-passwd) (lambda (&rest _args) "non-nil"))) diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el index b190ecb7020..cfbf6d101e2 100644 --- a/test/lisp/completion-preview-tests.el +++ b/test/lisp/completion-preview-tests.el @@ -24,7 +24,7 @@ (defun completion-preview-tests--capf (completions &rest props) (lambda () - (when-let ((bounds (bounds-of-thing-at-point 'symbol))) + (when-let* ((bounds (bounds-of-thing-at-point 'symbol))) (append (list (car bounds) (cdr bounds) completions) props)))) (defun completion-preview-tests--check-preview diff --git a/test/lisp/cus-edit-tests.el b/test/lisp/cus-edit-tests.el index ecef4c35b47..cfebcdc3551 100644 --- a/test/lisp/cus-edit-tests.el +++ b/test/lisp/cus-edit-tests.el @@ -31,7 +31,7 @@ `(save-window-excursion (unwind-protect (progn ,@body) - (when-let ((buf (get-buffer ,buffer))) + (when-let* ((buf (get-buffer ,buffer))) (kill-buffer buf))))) diff --git a/test/lisp/dabbrev-resources/INSTALL_BEGIN b/test/lisp/dabbrev-resources/INSTALL_BEGIN new file mode 100644 index 00000000000..6309419dccf --- /dev/null +++ b/test/lisp/dabbrev-resources/INSTALL_BEGIN @@ -0,0 +1,153 @@ +GNU Emacs Installation Guide +Copyright (C) 1992, 1994, 1996-1997, 2000-2024 Free Software Foundation, +Inc. +See the end of the file for license conditions. + + +This file contains general information on building GNU Emacs. If you +are building an Emacs release tarball on a Unix or a GNU system, the +instructions in this file should be sufficient. For other +configurations, we have additional specialized files: + + . INSTALL.REPO if you build from a Git checkout + . nt/INSTALL if you build for MS-Windows + . nextstep/INSTALL if you build for GNUstep/macOS + . java/INSTALL if you build for Android + . msdos/INSTALL if you build for MS-DOS + + +BASIC INSTALLATION + +On most Unix systems, you build Emacs by first running the 'configure' +shell script. This attempts to deduce the correct values for +various system-dependent variables and features, and find the +directories where certain system headers and libraries are kept. +In a few cases, you may need to explicitly tell configure where to +find some things, or what options to use. + +'configure' creates a 'Makefile' in several subdirectories, and a +'src/config.h' file containing system-dependent definitions. +Running the 'make' utility then builds the package for your system. + +Building Emacs requires GNU make, <https://www.gnu.org/software/make/>. +On most systems that Emacs supports, this is the default 'make' program. + +Here's the procedure to build Emacs using 'configure' on systems which +are supported by it. In some cases, if the simplified procedure fails, +you might need to use various non-default options, and maybe perform +some of the steps manually. The more detailed description in the other +sections of this guide will help you do that, so please refer to those +sections if you need to. + + 1. Obtain and unpack the Emacs release, with commands like this: + + wget https://ftp.gnu.org/gnu/emacs/emacs-VERSION.tar.xz + tar -xf emacs-VERSION.tar.xz + + where VERSION is the Emacs version number. + + 2a. 'cd' to the directory where you unpacked Emacs and invoke the + 'configure' script: + + ./configure + + 2b. Alternatively, create a separate directory, outside the source + directory, where you want to build Emacs, and invoke 'configure' + from there: + + SOURCE-DIR/configure + + where SOURCE-DIR is the top-level Emacs source directory. + + 2c. If you don't have write access to the default directory where + Emacs and its data files will be installed, specify an alternative + installation directory: + + ./configure --prefix=/SOME/OTHER/DIRECTORY + + where /SOME/OTHER/DIRECTORY is a directory writable by your user, + for example, a subdirectory of your home directory. + + 3. When 'configure' finishes, it prints several lines of details + about the system configuration. Read those details carefully + looking for anything suspicious, such as wrong CPU and operating + system names, wrong places for headers or libraries, missing + libraries that you know are installed on your system, etc. + + If you find anything wrong, you may have to pass to 'configure' + one or more options specifying the explicit machine configuration + name, where to find various headers and libraries, etc. + Refer to the section DETAILED BUILDING AND INSTALLATION below. + + If 'configure' didn't find some image support libraries, such as + Xpm and jpeg, refer to "Image support libraries" below. + + If the details printed by 'configure' don't make any sense to + you, but there are no obvious errors, assume that 'configure' did + its job and proceed. + + 4. Invoke the 'make' program: + + make + + 5. If 'make' succeeds, it will build an executable program 'emacs' + in the 'src' directory. You can try this program, to make sure + it works: + + src/emacs -Q + + To test Emacs further (intended mostly to help developers): + + make check + + 6. Assuming that the program 'src/emacs' starts and displays its + opening screen, you can install the program and its auxiliary + files into their installation directories: + + make install + + You are now ready to use Emacs. If you wish to conserve space, + you may remove the program binaries and object files from the + directory where you built Emacs: + + make clean + + You can delete the entire build directory if you do not plan to + build Emacs again, but it can be useful to keep for debugging. + If you want to build Emacs again with different configure options, + first clean the source directories: + + make distclean + + Note that the install automatically saves space by compressing + (provided you have the 'gzip' program) those installed Lisp source (.el) + files that have corresponding .elc versions, as well as the Info files. + + You can read a brief summary about common make targets: + + make help + + +ADDITIONAL DISTRIBUTION FILES + +* Complex Text Layout support libraries + +On GNU and Unix systems, Emacs needs optional libraries to correctly +display such complex scripts as Indic and Khmer, and also for scripts +that require Arabic shaping support (Arabic and Farsi). If the +HarfBuzz library is installed, Emacs will build with it and use it for +this purpose. HarfBuzz is the preferred shaping engine, both on Posix +hosts and on MS-Windows, so we recommend installing it before building +Emacs. The alternative for GNU/Linux and Posix systems is to use the +"m17n-db", "libm17n-flt", and "libotf" libraries. (On some systems, +particularly GNU/Linux, these libraries may be already present or +available as additional packages.) Note that if there is a separate +'dev' or 'devel' package, for use at compilation time rather than run +time, you will need that as well as the corresponding run time +package; typically the dev package will contain header files and a +library archive. On MS-Windows, if HarfBuzz is not available, Emacs +will use the Uniscribe shaping engine that is part of the OS. + +Note that Emacs cannot support complex scripts on a TTY, unless the +terminal includes such a support. However, most modern terminal +emulators, such as xterm, do support such scripts. diff --git a/test/lisp/dabbrev-resources/dabbrev-expand.el b/test/lisp/dabbrev-resources/dabbrev-expand.el new file mode 100644 index 00000000000..c986b0ed633 --- /dev/null +++ b/test/lisp/dabbrev-resources/dabbrev-expand.el @@ -0,0 +1,132 @@ +(defun dabbrev-expand (arg) + "Expand previous word \"dynamically\". + +Expands to the most recent, preceding word for which this is a prefix. +If no suitable preceding word is found, words following point are +considered. If still no suitable word is found, then look in the +buffers accepted by the function pointed out by variable +`dabbrev-friend-buffer-function', if `dabbrev-check-other-buffers' +says so. Then, if `dabbrev-check-all-buffers' is non-nil, look in +all the other buffers, subject to constraints specified +by `dabbrev-ignored-buffer-names' and `dabbrev-ignored-buffer-regexps'. + +A positive prefix argument, N, says to take the Nth backward *distinct* +possibility. A negative argument says search forward. + +If the cursor has not moved from the end of the previous expansion and +no argument is given, replace the previously-made expansion +with the next possible expansion not yet tried. + +The variable `dabbrev-backward-only' may be used to limit the +direction of search to backward if set non-nil. + +See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion]." + (interactive "*P") + (let (abbrev record-case-pattern + expansion old direction (orig-point (point))) + ;; abbrev -- the abbrev to expand + ;; expansion -- the expansion found (eventually) or nil until then + ;; old -- the text currently in the buffer + ;; (the abbrev, or the previously-made expansion) + (save-excursion + (if (and (null arg) + (markerp dabbrev--last-abbrev-location) + (marker-position dabbrev--last-abbrev-location) + (or (eq last-command this-command) + (and (window-minibuffer-p) + (= dabbrev--last-abbrev-location + (point))))) + ;; Find a different expansion for the same abbrev as last time. + (progn + (setq abbrev dabbrev--last-abbreviation) + (setq old dabbrev--last-expansion) + (setq direction dabbrev--last-direction)) + ;; If the user inserts a space after expanding + ;; and then asks to expand again, always fetch the next word. + (if (and (eq (preceding-char) ?\s) + (markerp dabbrev--last-abbrev-location) + (marker-position dabbrev--last-abbrev-location) + (= (point) (1+ dabbrev--last-abbrev-location))) + (progn + ;; The "abbrev" to expand is just the space. + (setq abbrev " ") + (save-excursion + (save-restriction + (widen) + (if (buffer-live-p dabbrev--last-buffer) + (set-buffer dabbrev--last-buffer)) + ;; Find the end of the last "expansion" word. + (if (or (eq dabbrev--last-direction 1) + (and (eq dabbrev--last-direction 0) + (< dabbrev--last-expansion-location (point)))) + (setq dabbrev--last-expansion-location + (+ dabbrev--last-expansion-location + (length dabbrev--last-expansion)))) + (goto-char dabbrev--last-expansion-location) + ;; Take the following word, with intermediate separators, + ;; as our expansion this time. + (re-search-forward + (concat "\\(?:" dabbrev--abbrev-char-regexp "\\)+")) + (setq expansion (buffer-substring-no-properties + dabbrev--last-expansion-location (point))) + + ;; Record the end of this expansion, in case we repeat this. + (setq dabbrev--last-expansion-location (point)))) + ;; Indicate that dabbrev--last-expansion-location is + ;; at the end of the expansion. + (setq dabbrev--last-direction -1)) + + ;; We have a different abbrev to expand. + (dabbrev--reset-global-variables) + (setq direction (if (null arg) + (if dabbrev-backward-only 1 0) + (prefix-numeric-value arg))) + (setq abbrev (dabbrev--abbrev-at-point)) + (setq record-case-pattern t) + (setq old nil))) + + ;;-------------------------------- + ;; Find the expansion + ;;-------------------------------- + (or expansion + (setq expansion + (dabbrev--find-expansion + abbrev direction + (dabbrev--ignore-case-p abbrev))))) + (cond + ((not expansion) + (dabbrev--reset-global-variables) + (if old + (save-excursion + (setq buffer-undo-list (cons orig-point buffer-undo-list)) + ;; Put back the original abbrev with its original case pattern. + (search-backward old) + (insert abbrev) + (delete-region (point) (+ (point) (length old))))) + (user-error "No%s dynamic expansion for `%s' found" + (if old " further" "") abbrev)) + (t + (if (not (or (eq dabbrev--last-buffer dabbrev--last-buffer-found) + (minibuffer-window-active-p (selected-window)))) + (progn + (when (buffer-name dabbrev--last-buffer) + (message "Expansion found in `%s'" + (buffer-name dabbrev--last-buffer))) + (setq dabbrev--last-buffer-found dabbrev--last-buffer)) + (message nil)) + (if (and (or (eq (current-buffer) dabbrev--last-buffer) + (null dabbrev--last-buffer) + (buffer-live-p dabbrev--last-buffer)) + (numberp dabbrev--last-expansion-location) + (and (> dabbrev--last-expansion-location (point)))) + (setq dabbrev--last-expansion-location + (copy-marker dabbrev--last-expansion-location))) + ;; Success: stick it in and return. + (setq buffer-undo-list (cons orig-point buffer-undo-list)) + (setq expansion (dabbrev--substitute-expansion old abbrev expansion + record-case-pattern)) + + ;; Save state for re-expand. + (setq dabbrev--last-expansion expansion) + (setq dabbrev--last-abbreviation abbrev) + (setq dabbrev--last-abbrev-location (point-marker)))))) diff --git a/test/lisp/dabbrev-tests.el b/test/lisp/dabbrev-tests.el index c7574403949..987106aa5af 100644 --- a/test/lisp/dabbrev-tests.el +++ b/test/lisp/dabbrev-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dabbrev) (ert-deftest dabbrev-expand-test () @@ -68,4 +69,210 @@ multiple expansions." (execute-kbd-macro (kbd "C-u C-u C-M-/"))) (should (string= (buffer-string) "abc\na"))))) +(defmacro with-dabbrev-test (&rest body) + "Set up an isolated `dabbrev' test environment." + (declare (debug (body))) + `(ert-with-temp-directory dabbrev-test-home + (let* (;; Since we change HOME, clear this to avoid a conflict + ;; e.g. if Emacs runs within the user's home directory. + (abbreviated-home-dir nil) + (process-environment (cons (format "HOME=%s" dabbrev-test-home) + process-environment)) + (dabbrev-directory (ert-resource-directory))) + (unwind-protect + (progn ,@body) + ;; Restore pre-test-run state of test files. + (dolist (f (directory-files dabbrev-directory)) + (let ((buf (get-file-buffer f))) + (when buf + (with-current-buffer buf + (restore-buffer-modified-p nil) + (kill-buffer))))) + (dabbrev--reset-global-variables))))) + +(ert-deftest dabbrev-expand-test-same-buffer-1 () + "Test expanding a string twice within a single buffer. +The first expansion should expand the input (a prefix-string) to a +string in the buffer containing no whitespace character, the second +expansion, after adding a space to the first expansion, should extend +the string with the following string in the buffer up to the next +whitespace character." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (goto-char (point-max)) + (terpri) + (execute-kbd-macro (kbd "Ind M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic and")))) + +(ert-deftest dabbrev-expand-test-same-buffer-2 () + "Test expanding a string plus space twice within a single buffer. +Each expansion should extend the string with the following string in the +buffer up to the next whitespace character." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (goto-char (point-max)) + (terpri) + (execute-kbd-macro (kbd "Indic SPC M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic and")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic and Khmer")))) + +(ert-deftest dabbrev-expand-test-same-buffer-3 () + "Test replacing an expansion within a single buffer." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (goto-char (point-max)) + (terpri) + (insert-file-contents (ert-resource-file "dabbrev-expand.el")) + (goto-char (point-max)) + (terpri) + (execute-kbd-macro (kbd "Ind M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indicate")) + (kill-whole-line) + (execute-kbd-macro (kbd "Ind M-/ M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic and")))) + +(ert-deftest dabbrev-expand-test-same-buffer-4 () + "Test expanding a string in a narrowed-region." + (with-dabbrev-test + (let (disabled-command-function) ; Enable narrow-to-region. + (find-file (ert-resource-file "INSTALL_BEGIN")) + (goto-char (point-min)) + (execute-kbd-macro (kbd "C-s Ind M-a C-SPC M-} C-x n n")) + (goto-char (point-max)) + (terpri) + (execute-kbd-macro (kbd "Ind M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-substring (pos-bol) (pos-eol)) "Indic and"))))) + +(ert-deftest dabbrev-expand-test-other-buffer-1 () + "Test expanding a prefix string to a string from another buffer." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (switch-to-buffer (get-buffer-create "a" t)) + (execute-kbd-macro (kbd "Ind M-/")) + (should (string= (buffer-string) "Indic")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-string) "Indic and")) + (kill-buffer "a"))) + +(ert-deftest dabbrev-expand-test-other-buffer-2 () + "Test expanding a string + space to a string from another buffer." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (switch-to-buffer (get-buffer-create "a" t)) + (execute-kbd-macro (kbd "Indic SPC M-/")) + (should (string= (buffer-string) "Indic and")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-string) "Indic and Khmer")) + (kill-buffer "a"))) + +(ert-deftest dabbrev-expand-test-other-buffer-3 () + "Test replacing an expansion with three different buffers. +A prefix string in a buffer should find the first expansion in a +different buffer and then find a replacement expansion is yet another +buffer." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (find-file (ert-resource-file "dabbrev-expand.el")) + (switch-to-buffer (get-buffer-create "a" t)) + (emacs-lisp-mode) + (execute-kbd-macro (kbd "Ind M-/")) + (should (string= (buffer-string) "Indicate")) + (erase-buffer) + (execute-kbd-macro (kbd "Ind M-/ M-/")) + (should (string= (buffer-string) "Indic")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-string) "Indic and")) + (kill-buffer "a"))) + +(ert-deftest dabbrev-expand-test-other-buffer-4 () + "Test expanding a string using another narrowed buffer." + (with-dabbrev-test + (let (disabled-command-function) ; Enable narrow-to-region. + (find-file (ert-resource-file "INSTALL_BEGIN")) + (goto-char (point-min)) + (execute-kbd-macro (kbd "C-s Ind M-a C-SPC M-} C-x n n")) + (switch-to-buffer (get-buffer-create "a" t)) + (execute-kbd-macro (kbd "Ind M-/")) + (should (string= (buffer-string) "Indic")) + (execute-kbd-macro (kbd "SPC M-/")) + (should (string= (buffer-string) "Indic and")) + (kill-buffer "a")))) + +(ert-deftest dabbrev-expand-test-minibuffer-1 () + "Test expanding a prefix string twice in the minibuffer. +Both expansions should come from the buffer from which the minibuffer +was entered." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (with-selected-window (minibuffer-window) + (insert "Ind") + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indic")) + (insert " ") + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indic and")) + (delete-minibuffer-contents)))) + +(ert-deftest dabbrev-expand-test-minibuffer-2 () + "Test expanding a string + space in the minibuffer. +The expansions should come from the buffer from which the minibuffer was +entered." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (with-selected-window (minibuffer-window) + (insert "Indic ") + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indic and")) + (insert " ") + (dabbrev-expand nil) + (should (string= (buffer-string) "Indic and Khmer")) + (delete-minibuffer-contents)))) + +;; FIXME: Why is dabbrev--reset-global-variables needed here? +(ert-deftest dabbrev-expand-test-minibuffer-3 () + "Test replacing an expansion in the minibuffer using two buffers. +The first expansion should befound in the buffer from which the +minibuffer was entered, the replacement should found in another buffer." + (with-dabbrev-test + (find-file (ert-resource-file "INSTALL_BEGIN")) + (find-file (ert-resource-file "dabbrev-expand.el")) + (with-selected-window (minibuffer-window) + (insert "Ind") + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indicate")) + (kill-whole-line) + (dabbrev--reset-global-variables) + (insert "Ind") + (dabbrev-expand nil) + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indic")) + (dabbrev--reset-global-variables) + (insert " ") + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indic and")) + (delete-minibuffer-contents)))) + +(ert-deftest dabbrev-expand-test-minibuffer-4 () + "Test expansion in the minibuffer using another narrowed buffer." + (with-dabbrev-test + (let (disabled-command-function) ; Enable narrow-to-region. + (find-file (ert-resource-file "INSTALL_BEGIN")) + (goto-char (point-min)) + (execute-kbd-macro (kbd "C-s Ind M-a C-SPC M-} C-x n n"))) + (with-selected-window (minibuffer-window) + (insert "Ind") + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indic")) + (insert " ") + (dabbrev-expand nil) + (should (string= (minibuffer-contents) "Indic and")) + (delete-minibuffer-contents)))) + ;;; dabbrev-tests.el ends here diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 3b1f80d3d3d..5a9ba14b402 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -524,6 +524,52 @@ (when (file-directory-p testdir) (delete-directory testdir t))))) +(ert-deftest dired-test-hide-absolute-location-enabled () + "Test for https://debbugs.gnu.org/72272 ." + (let* ((dired-hide-details-hide-absolute-location t) + (dir-name (expand-file-name "lisp" source-directory)) + (buffer (prog1 (dired (list dir-name "dired.el" "play")) + (dired-insert-subdir (file-name-concat default-directory + "play"))))) + (unwind-protect + (progn + (goto-char (point-min)) + (re-search-forward dired-subdir-regexp) + (goto-char (match-beginning 1)) + (should (equal "lisp" (file-name-nondirectory + (directory-file-name (dired-get-subdir))))) + (should (equal 'dired-hide-details-absolute-location + (get-text-property (match-beginning 1) 'invisible))) + (re-search-forward dired-subdir-regexp) + (goto-char (match-beginning 1)) + (should (equal "play" (file-name-nondirectory + (directory-file-name (dired-get-subdir))))) + (should (equal 'dired-hide-details-absolute-location + (get-text-property (match-beginning 1) 'invisible)))) + (kill-buffer buffer)))) + +(ert-deftest dired-test-hide-absolute-location-disabled () + "Test for https://debbugs.gnu.org/72272 ." + (let* ((dired-hide-details-hide-absolute-location nil) + (dir-name (expand-file-name "lisp" source-directory)) + (buffer (prog1 (dired (list dir-name "dired.el" "play")) + (dired-insert-subdir (file-name-concat default-directory + "play"))))) + (unwind-protect + (progn + (goto-char (point-min)) + (re-search-forward dired-subdir-regexp) + (goto-char (match-beginning 1)) + (should (equal "lisp" (file-name-nondirectory + (directory-file-name (dired-get-subdir))))) + (should-not (get-text-property (match-beginning 1) 'invisible)) + (re-search-forward dired-subdir-regexp) + (goto-char (match-beginning 1)) + (should (equal "play" (file-name-nondirectory + (directory-file-name (dired-get-subdir))))) + (should-not (get-text-property (match-beginning 1) 'invisible))) + (kill-buffer buffer)))) + ;; `dired-insert-directory' output tests. (let* ((data-dir "insert-directory") (test-dir (file-name-as-directory diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 3fabcbc50c9..4baf5428101 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -666,7 +666,15 @@ collection clause." (len4 (xs n) (cond (xs (cond (nil 'nevertrue) ((len4 (cdr xs) (1+ n))))) - (t n)))) + (t n))) + + ;; Tail calls through obstacles. + (len5 + (if (not (fboundp 'oclosure-lambda)) + #'ignore + (oclosure-lambda (accessor (type 'cl-macs-test) (slot 'length)) + (xs n) + (if xs (len5 (cdr xs) (1+ n)) n))))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) @@ -675,11 +683,13 @@ collection clause." (should (equal (len2 list-42 0) 42)) (should (equal (len3 list-42 0) 42)) (should (equal (len4 list-42 0) 42)) + (should (equal (len5 list-42 0) 42)) ;; Should not bump into stack depth limits. (should (equal (len list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000)) (should (equal (len3 list-42k 0) 42000)) - (should (equal (len4 list-42k 0) 42000)))) + (should (equal (len4 list-42k 0) 42000)) + (should (equal (len5 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) diff --git a/test/lisp/emacs-lisp/cond-star-tests.el b/test/lisp/emacs-lisp/cond-star-tests.el new file mode 100644 index 00000000000..7cf0a99f8db --- /dev/null +++ b/test/lisp/emacs-lisp/cond-star-tests.el @@ -0,0 +1,53 @@ +;;; cond-star-tests.el --- tests for emacs-lisp/cond-star.el -*- lexical-binding:t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'cond-star) +(require 'ert) + +(ert-deftest cond-star-test-1 () + (should (equal (cond* + ((pcase* `(,x . ,y) (cons 5 4)) (list x y)) + (t 6)) + '(5 4))) + (should (equal (cond* + ((pcase* `(,x . ,y) nil) (list x y)) + (t 6)) + 6)) + ;; FIXME: Not supported. + ;; (let* ((z nil) + ;; (res (cond* + ;; ((pcase* `(,x . ,y) (cons 5 4)) (setq z 6) :non-exit) + ;; (t `(,x ,y ,z))))) + ;; (should (equal res '(5 4 6)))) + (should (equal (cond* + ((pcase* `(,x . ,y) (cons 5 4))) + (t (list x y))) + '(5 4))) + (should (equal (cond* + ((pcase* `(,x . ,y) nil)) + (t (list x y))) + '(nil nil))) + ) + + +;;; cond-star-tests.el ends here diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el index e84cca68cdd..02c90f28c6c 100644 --- a/test/lisp/erc/erc-networks-tests.el +++ b/test/lisp/erc/erc-networks-tests.el @@ -76,6 +76,14 @@ :symbol 'fake.chat))))) (kill-buffer)))) +(ert-deftest erc-networks--id-string () + (should (equal (erc-networks--id-string (erc-networks--id-fixed-create 'foo)) + "foo")) + (should (equal (let* ((erc-network 'FooNet) + (erc-server-current-nick "Joe")) ; needs letstar + (erc-networks--id-string (erc-networks--id-create nil))) + "FooNet"))) + (ert-deftest erc-networks--id-create () (cl-letf (((symbol-function 'float-time) (lambda (&optional _) 0.0))) diff --git a/test/lisp/erc/erc-scenarios-base-local-modules.el b/test/lisp/erc/erc-scenarios-base-local-modules.el index 9604c6ea17c..e84671d35ed 100644 --- a/test/lisp/erc/erc-scenarios-base-local-modules.el +++ b/test/lisp/erc/erc-scenarios-base-local-modules.el @@ -153,7 +153,7 @@ (define-erc-module -phony-sblm- nil "Test module for `erc-scenarios-base-local-modules--var-persistence'." - ((when-let ((vars (or erc--server-reconnecting erc--target-priors))) + ((when-let* ((vars (or erc--server-reconnecting erc--target-priors))) (should (assq 'erc--phony-sblm--mode vars)) (setq erc-scenarios-base-local-modules--local-var (alist-get 'erc-scenarios-base-local-modules--local-var vars))) diff --git a/test/lisp/erc/erc-scenarios-stamp.el b/test/lisp/erc/erc-scenarios-stamp.el index 2e836e163bc..8aea091333b 100644 --- a/test/lisp/erc/erc-scenarios-stamp.el +++ b/test/lisp/erc/erc-scenarios-stamp.el @@ -29,7 +29,7 @@ (defvar erc-scenarios-stamp--user-marker nil) (defun erc-scenarios-stamp--on-post-modify () - (when-let (((erc--check-msg-prop 'erc--cmd 4))) + (when-let* (((erc--check-msg-prop 'erc--cmd 4))) (set-marker erc-scenarios-stamp--user-marker (point-max)) (ert-info ("User marker correctly placed at `erc-insert-marker'") (should (= ?\n (char-before erc-scenarios-stamp--user-marker))) diff --git a/test/lisp/erc/erc-services-tests.el b/test/lisp/erc/erc-services-tests.el index 126f6d7bbdd..a4420fbcbe2 100644 --- a/test/lisp/erc/erc-services-tests.el +++ b/test/lisp/erc/erc-services-tests.el @@ -485,7 +485,7 @@ ;; This function gives ^ (faked here to avoid gpg and file IO). See ;; `auth-source-pass--with-store' in ../auth-source-pass-tests.el (defun erc-services-tests--asp-parse-entry (store entry) - (when-let ((found (cl-find entry store :key #'car :test #'string=))) + (when-let* ((found (cl-find entry store :key #'car :test #'string=))) (list (assoc 'secret (cdr found))))) (defvar erc-join-tests--auth-source-pass-entries diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index eddb3a5b2c8..4c5521721f0 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -3444,8 +3444,8 @@ (ert-deftest erc-modules--internal-property () (let (ours) (mapatoms (lambda (s) - (when-let ((v (get s 'erc--module)) - ((eq v s))) + (when-let* ((v (get s 'erc--module)) + ((eq v s))) (push s ours)))) (should (equal (sort ours #'string-lessp) erc-tests--modules)))) @@ -3480,7 +3480,7 @@ (setq mods (sort mods (lambda (a b) (if (zerop (random 2)) a b)))) (dolist (mod mods) (unless (keywordp mod) - (push (if-let ((mode (erc--find-mode mod))) mod (list :missing mod)) + (push (if-let* ((mode (erc--find-mode mod))) mod (list :missing mod)) moded))) (message "%S" (sort moded (lambda (a b) @@ -3578,7 +3578,7 @@ (cl-letf (((symbol-function 'require) (lambda (s &rest _) ;; Simulate library being loaded, things defined. - (when-let ((h (alist-get s on-load))) (funcall h)) + (when-let* ((h (alist-get s on-load))) (funcall h)) (push (cons 'req s) calls))) ;; Spoof global module detection. diff --git a/test/lisp/erc/resources/erc-d/erc-d-i.el b/test/lisp/erc/resources/erc-d/erc-d-i.el index 97cd56408ce..89aacdd2ec3 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-i.el +++ b/test/lisp/erc/resources/erc-d/erc-d-i.el @@ -102,15 +102,15 @@ With DECODE, decode as UTF-8 text." (setq s (decode-coding-string s 'utf-8 t))) (let ((mes (make-erc-d-i-message :unparsed s :compat (not decode))) tokens) - (when-let (((not (string-empty-p s))) - ((eq ?@ (aref s 0))) - (m (string-match " " s)) - (u (substring s 1 m))) + (when-let* (((not (string-empty-p s))) + ((eq ?@ (aref s 0))) + (m (string-match " " s)) + (u (substring s 1 m))) (setf (erc-d-i-message.tags mes) (erc-d-i--validate-tags u) s (substring s (1+ m)))) - (if-let ((m (string-search " :" s)) - (other-toks (split-string (substring s 0 m) " " t)) - (rest (substring s (+ 2 m)))) + (if-let* ((m (string-search " :" s)) + (other-toks (split-string (substring s 0 m) " " t)) + (rest (substring s (+ 2 m)))) (setf (erc-d-i-message.contents mes) rest tokens (nconc other-toks (list rest))) (setf tokens (split-string s " " t " ") diff --git a/test/lisp/erc/resources/erc-d/erc-d-t.el b/test/lisp/erc/resources/erc-d/erc-d-t.el index 2dc8398198f..d0d48c6ce4d 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-t.el +++ b/test/lisp/erc/resources/erc-d/erc-d-t.el @@ -38,11 +38,11 @@ (when (and (boundp 'erc-server-flood-timer) (timerp erc-server-flood-timer)) (cancel-timer erc-server-flood-timer)) - (when-let ((proc (get-buffer-process buf))) + (when-let* ((proc (get-buffer-process buf))) (delete-process proc)) (when (buffer-live-p buf) (kill-buffer buf)))) - (while (when-let ((buf (pop erc-d-u--canned-buffers))) + (while (when-let* ((buf (pop erc-d-u--canned-buffers))) (kill-buffer buf)))) (defun erc-d-t-silence-around (orig &rest args) @@ -74,10 +74,10 @@ returning." (push o procs))) (dolist (proc procs) (delete-process proc) - (when-let ((buf (process-buffer proc))) + (when-let* ((buf (process-buffer proc))) (push buf bufs))) (dolist (buf bufs) - (when-let ((proc (get-buffer-process buf))) + (when-let* ((proc (get-buffer-process buf))) (delete-process proc)) (when (bufferp buf) (ignore-errors (kill-buffer buf))))) diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el index a626ddd8edc..22afe8454ee 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-tests.el +++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el @@ -318,23 +318,23 @@ m (erc-d-i--parse-message input)) (ert-info ("Parses tags correctly") (setq ours (erc-d-i-message.tags m)) - (if-let ((tags (assoc-default 'tags atoms))) + (if-let* ((tags (assoc-default 'tags atoms))) (pcase-dolist (`(,key . ,value) ours) (should (string= (cdr (assq key tags)) (or value "")))) (should-not ours))) (ert-info ("Parses verbs correctly") (setq ours (erc-d-i-message.command m)) - (if-let ((verbs (assoc-default 'verb atoms))) + (if-let* ((verbs (assoc-default 'verb atoms))) (should (string= (downcase verbs) (downcase ours))) (should (string-empty-p ours)))) (ert-info ("Parses sources correctly") (setq ours (erc-d-i-message.sender m)) - (if-let ((source (assoc-default 'source atoms))) + (if-let* ((source (assoc-default 'source atoms))) (should (string= source ours)) (should (string-empty-p ours)))) (ert-info ("Parses params correctly") (setq ours (erc-d-i-message.command-args m)) - (if-let ((params (assoc-default 'params atoms))) + (if-let* ((params (assoc-default 'params atoms))) (should (equal ours params)) (should-not ours)))))) diff --git a/test/lisp/erc/resources/erc-d/erc-d-u.el b/test/lisp/erc/resources/erc-d/erc-d-u.el index 11202f41112..8ba33fc9032 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-u.el +++ b/test/lisp/erc/resources/erc-d/erc-d-u.el @@ -150,7 +150,7 @@ of zero or more response specs." (erc-d-u--canned-read dialog)) (defun erc-d-u--read-exchange-slowly (num orig info) - (when-let ((spec (funcall orig info))) + (when-let* ((spec (funcall orig info))) (when (symbolp (car spec)) (setf spec (copy-sequence spec) (nth 1 spec) (cond ((functionp num) (funcall num (nth 1 spec))) diff --git a/test/lisp/erc/resources/erc-d/erc-d.el b/test/lisp/erc/resources/erc-d/erc-d.el index 89701442ff6..08c8a958c6b 100644 --- a/test/lisp/erc/resources/erc-d/erc-d.el +++ b/test/lisp/erc/resources/erc-d/erc-d.el @@ -382,7 +382,7 @@ Return associated server." "Raise timeout error for EXCHANGE. This will start the teardown for DIALOG." (setf (erc-d-exchange-spec exchange) nil) - (if-let ((finalizer (erc-d-dialog-finalizer dialog))) + (if-let* ((finalizer (erc-d-dialog-finalizer dialog))) (funcall finalizer dialog exchange) (erc-d--teardown 'erc-d-timeout "Timed out awaiting request: %s" (list :name (erc-d-exchange-tag exchange) @@ -801,7 +801,7 @@ with leading-tilde tags." (defun erc-d--finalize-done (dialog) ;; Linger logic for individual dialogs is handled elsewhere - (if-let ((finalizer (erc-d-dialog-finalizer dialog))) + (if-let* ((finalizer (erc-d-dialog-finalizer dialog))) (funcall finalizer dialog) (let ((d (process-get (erc-d-dialog-process dialog) :dialog-linger-secs))) (push (run-at-time d nil #'erc-d--teardown) @@ -876,7 +876,7 @@ back others indicating the lifecycle stage of the current dialog." (apply #'erc-d--teardown matched) (erc-d-on-match dialog matched) (setf (erc-d-dialog-matched dialog) matched) - (if-let ((s (erc-d--command-meter-replies dialog matched nil))) + (if-let* ((s (erc-d--command-meter-replies dialog matched nil))) (throw 'yield s) (setf (erc-d-dialog-matched dialog) nil)))) (erc-d--command-refresh dialog matched))))))) diff --git a/test/lisp/erc/resources/erc-scenarios-common.el b/test/lisp/erc/resources/erc-scenarios-common.el index 130b0aae109..1f663a90f78 100644 --- a/test/lisp/erc/resources/erc-scenarios-common.el +++ b/test/lisp/erc/resources/erc-scenarios-common.el @@ -185,8 +185,8 @@ Dialog resource directories are located by expanding the variable (ert-info ("Restore autojoin, etc., kill ERC buffers") (dolist (buf (buffer-list)) - (when-let ((erc-d-u--process-buffer) - (proc (get-buffer-process buf))) + (when-let* ((erc-d-u--process-buffer) + (proc (get-buffer-process buf))) (delete-process proc))) (erc-scenarios-common--remove-silence) diff --git a/test/lisp/erc/resources/erc-tests-common.el b/test/lisp/erc/resources/erc-tests-common.el index db0c5d626c9..a9495ecb28d 100644 --- a/test/lisp/erc/resources/erc-tests-common.el +++ b/test/lisp/erc/resources/erc-tests-common.el @@ -246,8 +246,8 @@ For simplicity, assume string evaluates to itself." (defvar erc-stamp--deferred-date-stamp) (let (erc-stamp--deferred-date-stamp) (prog1 (apply orig args) - (when-let ((inst erc-stamp--deferred-date-stamp) - (fn (erc-stamp--date-fn inst))) + (when-let* ((inst erc-stamp--deferred-date-stamp) + (fn (erc-stamp--date-fn inst))) (funcall fn))))) (defun erc-tests-common-display-message (&rest args) @@ -338,8 +338,8 @@ string." "Return subprocess for running CODE in an inferior Emacs. Include SWITCHES, like \"-batch\", as well as libs, after interspersing \"-l\" between members." - (let* ((package (if-let ((found (getenv "ERC_PACKAGE_NAME")) - ((string-prefix-p "erc-" found))) + (let* ((package (if-let* ((found (getenv "ERC_PACKAGE_NAME")) + ((string-prefix-p "erc-" found))) (intern found) 'erc)) ;; For integrations testing with managed configs that use a diff --git a/test/lisp/eshell/em-glob-tests.el b/test/lisp/eshell/em-glob-tests.el index 2efb3a9df69..57343eced6b 100644 --- a/test/lisp/eshell/em-glob-tests.el +++ b/test/lisp/eshell/em-glob-tests.el @@ -74,7 +74,13 @@ component ending in \"symlink\" is treated as a symbolic link." ;; Ensure the default expansion splices the glob. (eshell-command-result-equal "funcall list *.el" '("a.el" "b.el")) (eshell-command-result-equal "funcall list *.txt" '("c.txt")) - (eshell-command-result-equal "funcall list *.no" '("*.no"))))) + ;; When splitting, no-matches cases also return a list containing + ;; the original non-matching glob. + (eshell-command-result-equal "funcall list *.no" '("*.no")) + (when (eshell-tests-remote-accessible-p) + (let ((remote (file-remote-p ert-remote-temporary-file-directory))) + (eshell-command-result-equal (format "funcall list %s~/a.el" remote) + `(,(format "%s~/a.el" remote)))))))) (ert-deftest em-glob-test/expand/no-splice-results () "Test that globs are treated as lists when @@ -85,9 +91,13 @@ component ending in \"symlink\" is treated as a symbolic link." ;; Ensure the default expansion splices the glob. (eshell-command-result-equal "funcall list *.el" '(("a.el" "b.el"))) (eshell-command-result-equal "funcall list *.txt" '(("c.txt"))) - ;; The no-matches case is special here: the glob is just the + ;; The no-matches cases are special here: the glob is just the ;; string, not the list of results. - (eshell-command-result-equal "funcall list *.no" '("*.no"))))) + (eshell-command-result-equal "funcall list *.no" '("*.no")) + (when (eshell-tests-remote-accessible-p) + (let ((remote (file-remote-p ert-remote-temporary-file-directory))) + (eshell-command-result-equal (format "funcall list %s~/a.el" remote) + `(,(format "%s~/a.el" remote)))))))) (ert-deftest em-glob-test/expand/explicitly-splice-results () "Test explicitly splicing globs works the same no matter the @@ -124,17 +134,19 @@ value of `eshell-glob-splice-results'." (ert-deftest em-glob-test/convert/current-start-directory () "Test converting a glob starting in the current directory." - (should (equal (eshell-glob-convert "*.el") + (should (equal (eshell-glob-convert (eshell-parse-glob-string "*.el")) '("./" (("\\`.*\\.el\\'" . "\\`\\.")) nil)))) (ert-deftest em-glob-test/convert/relative-start-directory () "Test converting a glob starting in a relative directory." - (should (equal (eshell-glob-convert "some/where/*.el") + (should (equal (eshell-glob-convert + (eshell-parse-glob-string "some/where/*.el")) '("./some/where/" (("\\`.*\\.el\\'" . "\\`\\.")) nil)))) (ert-deftest em-glob-test/convert/absolute-start-directory () "Test converting a glob starting in an absolute directory." - (should (equal (eshell-glob-convert "/some/where/*.el") + (should (equal (eshell-glob-convert + (eshell-parse-glob-string "/some/where/*.el")) '("/some/where/" (("\\`.*\\.el\\'" . "\\`\\.")) nil)))) (ert-deftest em-glob-test/convert/remote-start-directory () @@ -142,16 +154,30 @@ value of `eshell-glob-splice-results'." (skip-unless (eshell-tests-remote-accessible-p)) (let* ((default-directory ert-remote-temporary-file-directory) (remote (file-remote-p default-directory))) - (should (equal (eshell-glob-convert (format "%s/some/where/*.el" remote)) + (should (equal (eshell-glob-convert + (format (eshell-parse-glob-string "%s/some/where/*.el") + remote)) `(,(format "%s/some/where/" remote) (("\\`.*\\.el\\'" . "\\`\\.")) nil))))) -(ert-deftest em-glob-test/convert/quoted-start-directory () - "Test converting a glob starting in a quoted directory name." +(ert-deftest em-glob-test/convert/start-directory-with-spaces () + "Test converting a glob starting in a directory with spaces in its name." (should (equal (eshell-glob-convert - (concat (eshell-escape-arg "some where/") "*.el")) + (eshell-parse-glob-string "some where/*.el")) '("./some where/" (("\\`.*\\.el\\'" . "\\`\\.")) nil)))) +(ert-deftest em-glob-test/convert/literal-characters () + "Test converting a \"glob\" with only literal characters." + (should (equal (eshell-glob-convert "*.el") '("./*.el" nil nil))) + (should (equal (eshell-glob-convert "**/") '("./**/" nil t)))) + +(ert-deftest em-glob-test/convert/mixed-literal-characters () + "Test converting a glob with some literal characters." + (should (equal (eshell-glob-convert (eshell-parse-glob-string "\\*\\*/*.el")) + '("./**/" (("\\`.*\\.el\\'" . "\\`\\.")) nil))) + (should (equal (eshell-glob-convert (eshell-parse-glob-string "**/\\*.el")) + '("./" (recurse ("\\`\\*\\.el\\'" . "\\`\\.")) nil)))) + ;; Glob matching @@ -252,11 +278,11 @@ value of `eshell-glob-splice-results'." (ert-deftest em-glob-test/match-n-or-more-groups () "Test that \"(x)#\" and \"(x)#\" match zero or more instances of \"(x)\"." - (with-fake-files '("h.el" "ha.el" "hi.el" "hii.el" "dir/hi.el") - (should (equal (eshell-extended-glob "hi#.el") - '("h.el" "hi.el" "hii.el"))) - (should (equal (eshell-extended-glob "hi##.el") - '("hi.el" "hii.el"))))) + (with-fake-files '("h.el" "ha.el" "hi.el" "hah.el" "hahah.el" "dir/hah.el") + (should (equal (eshell-extended-glob "h(ah)#.el") + '("h.el" "hah.el" "hahah.el"))) + (should (equal (eshell-extended-glob "h(ah)##.el") + '("hah.el" "hahah.el"))))) (ert-deftest em-glob-test/match-n-or-more-character-sets () "Test that \"[x]#\" and \"[x]#\" match zero or more instances of \"[x]\"." @@ -290,11 +316,11 @@ value of `eshell-glob-splice-results'." (ert-deftest em-glob-test/no-matches () "Test behavior when a glob fails to match any files." (with-fake-files '("foo.el" "bar.el") - (should (equal (eshell-extended-glob "*.txt") - "*.txt")) + (should (equal-including-properties (eshell-extended-glob "*.txt") + "*.txt")) (let ((eshell-glob-splice-results t)) - (should (equal (eshell-extended-glob "*.txt") - '("*.txt")))) + (should (equal-including-properties (eshell-extended-glob "*.txt") + '("*.txt")))) (let ((eshell-error-if-no-glob t)) (should-error (eshell-extended-glob "*.txt"))))) @@ -307,4 +333,15 @@ value of `eshell-glob-splice-results'." (should (equal (eshell-extended-glob (format "%s~/file.txt" remote)) (format "%s~/file.txt" remote))))) +;; Compatibility tests + + +(ert-deftest em-glob-test/test-command-without-pred () + "Test that the \"[\" command works when `eshell-pred' is disabled." + (skip-unless (executable-find "[")) + (let ((eshell-modules-list (remq 'eshell-pred eshell-modules-list))) + (with-temp-eshell + (eshell-match-command-output "[ foo = foo ]" "\\`\\'") + (should (= eshell-last-command-status 0))))) + ;; em-glob-tests.el ends here diff --git a/test/lisp/eshell/em-prompt-tests.el b/test/lisp/eshell/em-prompt-tests.el index fbadade061f..1c6e8e02293 100644 --- a/test/lisp/eshell/em-prompt-tests.el +++ b/test/lisp/eshell/em-prompt-tests.el @@ -57,8 +57,8 @@ 'read-only t 'field 'prompt 'font-lock-face 'eshell-prompt - 'front-sticky '(read-only field font-lock-face) - 'rear-nonsticky '(read-only field font-lock-face)))) + 'front-sticky '(read-only font-lock-face field) + 'rear-nonsticky '(read-only font-lock-face field)))) (should (equal last-input "echo hello\n")) (should (equal-including-properties last-output @@ -88,6 +88,33 @@ This tests the case when `eshell-highlight-prompt' is nil." (apply #'propertize "hello\n" eshell-command-output-properties))))))) +(ert-deftest em-prompt-test/field-properties/merge-stickiness () + "Check that stickiness properties are properly merged on Eshell prompts." + (let ((eshell-prompt-function + (lambda () + (concat (propertize (eshell/pwd) 'front-sticky '(front)) + (propertize "$ " 'rear-nonsticky '(rear)))))) + (with-temp-eshell + (eshell-insert-command "echo hello") + (let ((last-prompt (field-string (1- eshell-last-input-start)))) + (should (equal-including-properties + last-prompt + (concat + (propertize + (directory-file-name default-directory) + 'read-only t + 'field 'prompt + 'font-lock-face 'eshell-prompt + 'front-sticky '(front read-only font-lock-face field) + 'rear-nonsticky '(read-only font-lock-face field)) + (propertize + "$ " + 'read-only t + 'field 'prompt + 'font-lock-face 'eshell-prompt + 'front-sticky '(read-only font-lock-face field) + 'rear-nonsticky '(rear read-only font-lock-face field))))))))) + (ert-deftest em-prompt-test/after-failure () "Check that current prompt shows the exit code of the last failed command." (with-temp-eshell @@ -104,8 +131,8 @@ This tests the case when `eshell-highlight-prompt' is nil." 'read-only t 'field 'prompt 'font-lock-face 'eshell-prompt - 'front-sticky '(read-only field font-lock-face) - 'rear-nonsticky '(read-only field font-lock-face))))))) + 'front-sticky '(read-only font-lock-face field) + 'rear-nonsticky '(read-only font-lock-face field))))))) ;; Prompt navigation diff --git a/test/lisp/eshell/esh-cmd-tests.el b/test/lisp/eshell/esh-cmd-tests.el index 0f388a9eba4..3b1fbafe4d1 100644 --- a/test/lisp/eshell/esh-cmd-tests.el +++ b/test/lisp/eshell/esh-cmd-tests.el @@ -176,6 +176,21 @@ bug#59469." (eshell-match-command-output "[ foo = bar ] && echo hi" "\\`\\'"))) +(ert-deftest esh-cmd-test/and-operator/output () + "Test output with logical && operator." + (skip-unless (executable-find "sh")) + (with-temp-eshell + ;; Direct commands + (eshell-match-command-output "sh -c 'echo one; exit 1' && echo two" + "\\`one\n\\'") + (eshell-match-command-output "echo one && echo two" + "\\`one\ntwo\n\\'") + ;; Subcommands + (eshell-match-command-output "{ sh -c 'echo one; exit 1' } && echo two" + "\\`one\n\\'") + (eshell-match-command-output "{ echo one } && echo two" + "\\`one\ntwo\n\\'"))) + (ert-deftest esh-cmd-test/or-operator () "Test logical || operator." (skip-unless (executable-find "[")) @@ -185,6 +200,21 @@ bug#59469." (eshell-match-command-output "[ foo = bar ] || echo hi" "hi\n"))) +(ert-deftest esh-cmd-test/or-operator/output () + "Test output with logical || operator." + (skip-unless (executable-find "sh")) + (with-temp-eshell + ;; Direct commands + (eshell-match-command-output "sh -c 'echo one; exit 1' || echo two" + "\\`one\ntwo\n\\'") + (eshell-match-command-output "echo one || echo two" + "\\`one\n\\'") + ;; Subcommands + (eshell-match-command-output "{ sh -c 'echo one; exit 1' } || echo two" + "\\`one\ntwo\n\\'") + (eshell-match-command-output "{ echo one } || echo two" + "\\`one\n\\'"))) + ;; Pipelines @@ -289,8 +319,15 @@ processes correctly." (ert-deftest esh-cmd-test/for-loop () "Test invocation of a for loop." (with-temp-eshell - (eshell-match-command-output "for i in 5 { echo $i }" - "5\n"))) + (eshell-match-command-output "for i in 1 2 { echo $i }" + "1\n2\n"))) + +(ert-deftest esh-cmd-test/for-loop-string () + "Test invocation of a for loop with complex string arguments." + (let ((eshell-test-value "X")) + (with-temp-eshell + (eshell-match-command-output "for i in a b$eshell-test-value { echo $i }" + "a\nbX\n")))) (ert-deftest esh-cmd-test/for-loop-list () "Test invocation of a for loop iterating over a list." @@ -298,7 +335,28 @@ processes correctly." (eshell-match-command-output "for i in (list 1 2 (list 3 4)) { echo $i }" "1\n2\n(3 4)\n"))) -(ert-deftest esh-cmd-test/for-loop-multiple-args () +(ert-deftest esh-cmd-test/for-loop-vector () + "Test invocation of a for loop iterating over a vector." + (with-temp-eshell + (eshell-match-command-output "for i in `[1 2 3] { echo $i }" + "1\n2\n3\n"))) + +(ert-deftest esh-cmd-test/for-loop-range () + "Test invocation of a for loop iterating over a range." + (with-temp-eshell + (eshell-match-command-output "for i in 1..5 { echo $i }" + "1\n2\n3\n4\n") + (let ((eshell-test-value 2)) + (eshell-match-command-output "for i in $eshell-test-value..5 { echo $i }" + "2\n3\n4\n")) + ;; Make sure range syntax only work when it's part of the literal + ;; syntax; a variable expanding to something that looks like a range + ;; doesn't count. + (let ((eshell-test-value "1..5")) + (eshell-match-command-output "for i in $eshell-test-value { echo $i }" + "1..5\n")))) + +(ert-deftest esh-cmd-test/for-loop-mixed-args () "Test invocation of a for loop iterating over multiple arguments." (with-temp-eshell (eshell-match-command-output "for i in 1 2 (list 3 4) { echo $i }" @@ -318,13 +376,6 @@ processes correctly." "echo $name; for name in 3 { echo $name }; echo $name" "env-value\n3\nenv-value\n")))) -(ert-deftest esh-cmd-test/for-loop-for-items-shadow () - "Test that the variable `for-items' isn't shadowed inside for loops." - (with-temp-eshell - (with-no-warnings (setq-local for-items "hello")) - (eshell-match-command-output "for i in 1 { echo $for-items }" - "hello\n"))) - (ert-deftest esh-cmd-test/for-loop-lisp-body () "Test invocation of a for loop with a Lisp body form." (with-temp-eshell diff --git a/test/lisp/eshell/esh-mode-tests.el b/test/lisp/eshell/esh-mode-tests.el index 306e11ce445..28839eb65cf 100644 --- a/test/lisp/eshell/esh-mode-tests.el +++ b/test/lisp/eshell/esh-mode-tests.el @@ -26,6 +26,8 @@ (require 'ert) (require 'esh-mode) (require 'eshell) +(require 'em-banner) +(require 'em-prompt) (require 'eshell-tests-helpers (expand-file-name "eshell-tests-helpers" @@ -59,4 +61,44 @@ (eshell-match-command-output (format "(format \"hello%c%cp\")" ?\C-h ?\C-h) "\\`help\n"))) +(ert-deftest esh-mode-test/clear/eshell-command () + "Test that `eshell/clear' works as an Eshell command." + (let ((eshell-banner-message "") + (eshell-prompt-function (lambda () "$ "))) + (with-temp-eshell + (eshell-insert-command "echo hi") + (eshell-insert-command "clear") + (should (string-match "\\`\\$ echo hi\nhi\n\\$ clear\n+\\$ " + (buffer-string)))))) + +(ert-deftest esh-mode-test/clear/eshell-command/erase () + "Test that `eshell/clear' can erase the buffer." + (let ((eshell-banner-message "") + (eshell-prompt-function (lambda () "$ "))) + (with-temp-eshell + (eshell-insert-command "echo hi") + (eshell-insert-command "clear t") + (should (string-match "\\`\\$ " (buffer-string)))))) + +(ert-deftest esh-mode-test/clear/emacs-command () + "Test that `eshell-clear' works as an interactive Emacs command." + (let ((eshell-banner-message "") + (eshell-prompt-function (lambda () "$ "))) + (with-temp-eshell + (eshell-insert-command "echo hi") + (insert "echo b") + (eshell-clear) + (should (string-match "\\`\\$ echo hi\nhi\n\n+\\$ echo b" + (buffer-string)))))) + +(ert-deftest esh-mode-test/clear/emacs-command/erase () + "Test that `eshell-clear' can erase the buffer." + (let ((eshell-banner-message "") + (eshell-prompt-function (lambda () "$ "))) + (with-temp-eshell + (eshell-insert-command "echo hi") + (insert "echo b") + (eshell-clear t) + (should (string-match "\\`\\$ echo b" (buffer-string)))))) + ;; esh-mode-tests.el ends here diff --git a/test/lisp/eshell/esh-proc-tests.el b/test/lisp/eshell/esh-proc-tests.el index 3121e751006..973d9ccc213 100644 --- a/test/lisp/eshell/esh-proc-tests.el +++ b/test/lisp/eshell/esh-proc-tests.el @@ -135,16 +135,19 @@ (ert-deftest esh-proc-test/sentinel/change-buffer () "Check that changing the current buffer while running a command works. See bug#71778." - (eshell-with-temp-buffer bufname "" - (with-temp-eshell - (let (eshell-test-value) - (eshell-insert-command - (concat (format "for i in 1 2 {sleep 1; echo hello} > #<%s>; " bufname) - "setq eshell-test-value t")) - (with-current-buffer bufname - (eshell-wait-for (lambda () eshell-test-value)) - (should (equal (buffer-string) "hellohello"))) - (eshell-match-command-output "echo goodbye" "\\`goodbye\n"))))) + (let ((starting-process-list (process-list))) + (eshell-with-temp-buffer bufname "" + (with-temp-eshell + (let (eshell-test-value) + (eshell-insert-command + (concat (format "for i in 1 2 {sleep 1; echo hello} > #<%s>; " + bufname) + "setq eshell-test-value t")) + (with-current-buffer bufname + (eshell-wait-for (lambda () eshell-test-value)) + (should (equal (buffer-string) "hellohello"))) + (should (equal (process-list) starting-process-list)) + (eshell-match-command-output "echo goodbye" "\\`goodbye\n")))))) ;; Pipelines diff --git a/test/lisp/eshell/esh-util-tests.el b/test/lisp/eshell/esh-util-tests.el index 031de558d1f..b2fd01e0c29 100644 --- a/test/lisp/eshell/esh-util-tests.el +++ b/test/lisp/eshell/esh-util-tests.el @@ -66,70 +66,70 @@ "Test that `eshell-stringify' correctly stringifies complex objects." (should (equal (eshell-stringify (list 'quote 'hello)) "'hello"))) -(ert-deftest esh-util-test/eshell-convert-to-number/integer () - "Test that `eshell-convert-to-number' correctly converts integers." - (should (equal (eshell-convert-to-number "123") 123)) - (should (equal (eshell-convert-to-number "-123") -123)) +(ert-deftest esh-util-test/eshell-convertible-to-number-p/integer () + "Test that `eshell-convertible-to-number-p' matches integers." + (should (eshell-convertible-to-number-p "123")) + (should (eshell-convertible-to-number-p "-123")) ;; These are technially integers, since Emacs Lisp requires at least ;; one digit after the "." to be a float: - (should (equal (eshell-convert-to-number "123.") 123)) - (should (equal (eshell-convert-to-number "-123.") -123))) - -(ert-deftest esh-util-test/eshell-convert-to-number/floating-point () - "Test that `eshell-convert-to-number' correctly converts floats." - (should (equal (eshell-convert-to-number "1.23") 1.23)) - (should (equal (eshell-convert-to-number "-1.23") -1.23)) - (should (equal (eshell-convert-to-number ".1") 0.1)) - (should (equal (eshell-convert-to-number "-.1") -0.1))) - -(ert-deftest esh-util-test/eshell-convert-to-number/floating-point-exponent () - "Test that `eshell-convert-to-number' correctly converts exponent notation." + (should (eshell-convertible-to-number-p "123.")) + (should (eshell-convertible-to-number-p "-123."))) + +(ert-deftest esh-util-test/eshell-convertible-to-number-p/float () + "Test that `eshell-convertible-to-number-p' matches floats." + (should (eshell-convertible-to-number-p "1.23")) + (should (eshell-convertible-to-number-p "-1.23")) + (should (eshell-convertible-to-number-p ".1")) + (should (eshell-convertible-to-number-p "-.1"))) + +(ert-deftest esh-util-test/eshell-convertible-to-number-p/float-exponent () + "Test that `eshell-convertible-to-number-p' matches exponent notation." ;; Positive exponent: (dolist (exp '("e2" "e+2" "E2" "E+2")) - (should (equal (eshell-convert-to-number (concat "123" exp)) 12300.0)) - (should (equal (eshell-convert-to-number (concat "-123" exp)) -12300.0)) - (should (equal (eshell-convert-to-number (concat "1.23" exp)) 123.0)) - (should (equal (eshell-convert-to-number (concat "-1.23" exp)) -123.0)) - (should (equal (eshell-convert-to-number (concat "1." exp)) 100.0)) - (should (equal (eshell-convert-to-number (concat "-1." exp)) -100.0)) - (should (equal (eshell-convert-to-number (concat ".1" exp)) 10.0)) - (should (equal (eshell-convert-to-number (concat "-.1" exp)) -10.0))) + (should (eshell-convertible-to-number-p (concat "123" exp))) + (should (eshell-convertible-to-number-p (concat "-123" exp))) + (should (eshell-convertible-to-number-p (concat "1.23" exp))) + (should (eshell-convertible-to-number-p (concat "-1.23" exp))) + (should (eshell-convertible-to-number-p (concat "1." exp))) + (should (eshell-convertible-to-number-p (concat "-1." exp))) + (should (eshell-convertible-to-number-p (concat ".1" exp))) + (should (eshell-convertible-to-number-p (concat "-.1" exp)))) ;; Negative exponent: (dolist (exp '("e-2" "E-2")) - (should (equal (eshell-convert-to-number (concat "123" exp)) 1.23)) - (should (equal (eshell-convert-to-number (concat "-123" exp)) -1.23)) - (should (equal (eshell-convert-to-number (concat "1.23" exp)) 0.0123)) - (should (equal (eshell-convert-to-number (concat "-1.23" exp)) -0.0123)) - (should (equal (eshell-convert-to-number (concat "1." exp)) 0.01)) - (should (equal (eshell-convert-to-number (concat "-1." exp)) -0.01)) - (should (equal (eshell-convert-to-number (concat ".1" exp)) 0.001)) - (should (equal (eshell-convert-to-number (concat "-.1" exp)) -0.001)))) - -(ert-deftest esh-util-test/eshell-convert-to-number/floating-point/infinite () - "Test that `eshell-convert-to-number' correctly converts infinite floats." - (should (equal (eshell-convert-to-number "1.0e+INF") 1.0e+INF)) - (should (equal (eshell-convert-to-number "2.e+INF") 1.0e+INF)) - (should (equal (eshell-convert-to-number "-1.0e+INF") -1.0e+INF)) - (should (equal (eshell-convert-to-number "-2.e+INF") -1.0e+INF))) - -(ert-deftest esh-util-test/eshell-convert-to-number/floating-point/nan () - "Test that `eshell-convert-to-number' correctly converts NaNs." - (should (equal (eshell-convert-to-number "1.0e+NaN") 1.0e+NaN)) - (should (equal (eshell-convert-to-number "2.e+NaN") 2.0e+NaN)) - (should (equal (eshell-convert-to-number "-1.0e+NaN") -1.0e+NaN)) - (should (equal (eshell-convert-to-number "-2.e+NaN") -2.0e+NaN))) - -(ert-deftest esh-util-test/eshell-convert-to-number/non-numeric () - "Test that `eshell-convert-to-number' does nothing to non-numeric values." - (should (equal (eshell-convert-to-number "foo") "foo")) - (should (equal (eshell-convert-to-number "") "")) - (should (equal (eshell-convert-to-number "123foo") "123foo"))) - -(ert-deftest esh-util-test/eshell-convert-to-number/no-convert () - "Test that `eshell-convert-to-number' does nothing when disabled." + (should (eshell-convertible-to-number-p (concat "123" exp))) + (should (eshell-convertible-to-number-p (concat "-123" exp))) + (should (eshell-convertible-to-number-p (concat "1.23" exp))) + (should (eshell-convertible-to-number-p (concat "-1.23" exp))) + (should (eshell-convertible-to-number-p (concat "1." exp))) + (should (eshell-convertible-to-number-p (concat "-1." exp))) + (should (eshell-convertible-to-number-p (concat ".1" exp))) + (should (eshell-convertible-to-number-p (concat "-.1" exp))))) + +(ert-deftest esh-util-test/eshell-convertible-to-number-p/float/infinite () + "Test that `eshell-convertible-to-number-p' matches infinite floats." + (should (eshell-convertible-to-number-p "1.0e+INF")) + (should (eshell-convertible-to-number-p "2.e+INF")) + (should (eshell-convertible-to-number-p "-1.0e+INF")) + (should (eshell-convertible-to-number-p "-2.e+INF"))) + +(ert-deftest esh-util-test/eshell-convertible-to-number-p/float/nan () + "Test that `eshell-convertible-to-number-p' matches NaNs." + (should (eshell-convertible-to-number-p "1.0e+NaN")) + (should (eshell-convertible-to-number-p "2.e+NaN")) + (should (eshell-convertible-to-number-p "-1.0e+NaN")) + (should (eshell-convertible-to-number-p "-2.e+NaN"))) + +(ert-deftest esh-util-test/eshell-convertible-to-number-p/non-numeric () + "Test that `eshell-convertible-to-number-p' returns nil for non-numerics." + (should-not (eshell-convertible-to-number-p "foo")) + (should-not (eshell-convertible-to-number-p "")) + (should-not (eshell-convertible-to-number-p "123foo"))) + +(ert-deftest esh-util-test/eshell-convertible-to-number-p/no-convert () + "Test that `eshell-convertible-to-number-p' returns nil when disabled." (let ((eshell-convert-numeric-arguments nil)) - (should (equal (eshell-convert-to-number "123") "123")) - (should (equal (eshell-convert-to-number "1.23") "1.23")))) + (should-not (eshell-convertible-to-number-p "123")) + (should-not (eshell-convertible-to-number-p "1.23")))) (ert-deftest esh-util-test/eshell-printable-size () (should (equal (eshell-printable-size (expt 2 16)) "65536")) @@ -183,4 +183,44 @@ (should (equal (eshell-get-path 'literal) expected-path)))) +(ert-deftest esh-util-test/split-filename/absolute () + "Test splitting an absolute filename." + (should (equal (eshell-split-filename "/foo/bar/file.txt") + '("/" "foo/" "bar/" "file.txt")))) + +(ert-deftest esh-util-test/split-filename/relative () + "Test splitting a relative filename." + (should (equal (eshell-split-filename "foo/bar/file.txt") + '("foo/" "bar/" "file.txt")))) + +(ert-deftest esh-util-test/split-filename/user () + "Test splitting a user filename." + (should (equal (eshell-split-filename "~/file.txt") + '("~/" "file.txt"))) + (should (equal (eshell-split-filename "~user/file.txt") + '("~user/" "file.txt")))) + +(ert-deftest esh-util-test/split-filename/remote-absolute () + "Test splitting a remote absolute filename." + (skip-unless (eshell-tests-remote-accessible-p)) + (let ((remote (file-remote-p ert-remote-temporary-file-directory))) + (should (equal (eshell-split-filename (format "%s/foo/bar/file.txt" remote)) + `(,remote "/" "foo/" "bar/" "file.txt"))))) + +(ert-deftest esh-util-test/split-filename/remote-relative () + "Test splitting a remote relative filename." + (skip-unless (eshell-tests-remote-accessible-p)) + (let ((remote (file-remote-p ert-remote-temporary-file-directory))) + (should (equal (eshell-split-filename (format "%sfoo/bar/file.txt" remote)) + `(,remote "foo/" "bar/" "file.txt"))))) + +(ert-deftest esh-util-test/split-filename/remote-user () + "Test splitting a remote user filename." + (skip-unless (eshell-tests-remote-accessible-p)) + (let ((remote (file-remote-p ert-remote-temporary-file-directory))) + (should (equal (eshell-split-filename (format "%s~/file.txt" remote)) + `(,remote "~/" "file.txt"))) + (should (equal (eshell-split-filename (format "%s~user/file.txt" remote)) + `(,remote "~user/" "file.txt"))))) + ;;; esh-util-tests.el ends here diff --git a/test/lisp/eshell/esh-var-tests.el b/test/lisp/eshell/esh-var-tests.el index 7ac9807a1a7..2f8ac32b0b5 100644 --- a/test/lisp/eshell/esh-var-tests.el +++ b/test/lisp/eshell/esh-var-tests.el @@ -35,6 +35,8 @@ default-directory)))) (defvar eshell-test-value nil) +(defvar eshell-test-begin nil) +(defvar eshell-test-end nil) ;;; Tests: @@ -111,7 +113,11 @@ nil, use FUNCTION instead." (eshell-command-result-equal "echo $eshell-test-value[1..4 -2..]" (list (funcall range-function '("one" "two" "three")) - (funcall range-function '("three" "four")))))) + (funcall range-function '("three" "four")))) + (let ((eshell-test-begin 1) (eshell-test-end 4)) + (eshell-command-result-equal + "echo $eshell-test-value[$eshell-test-begin..$eshell-test-end]" + (funcall range-function '("one" "two" "three")))))) (ert-deftest esh-var-test/interp-var-indices/list () "Interpolate list variable with indices." @@ -217,7 +223,8 @@ nil, use FUNCTION instead." "Splice-interpolate list variable." (let ((eshell-test-value '(1 2 3))) (eshell-command-result-equal "echo a $@eshell-test-value z" - '("a" 1 2 3 "z")))) + '("a" 1 2 3 "z")) + (should (equal eshell-test-value '(1 2 3))))) (ert-deftest esh-var-test/interp-var-splice-concat () "Splice-interpolate and concat list variable." @@ -231,7 +238,7 @@ nil, use FUNCTION instead." ;; into the first value of the non-spliced list. (eshell-command-result-equal "echo it is $@'eshell-test-value'$eshell-test-value" - '("it" "is" 1 2 (31 2 3))))) + '("it" "is" 1 2 ("31" 2 3))))) (ert-deftest esh-var-test/interp-lisp () "Interpolate Lisp form evaluation." @@ -280,12 +287,16 @@ nil, use FUNCTION instead." (eshell-command-result-equal "+ ${+ 1 2}3 3" 36) (eshell-command-result-equal "echo ${*echo \"foo\nbar\"}-baz" '("foo" "bar-baz")) - ;; Concatenating to a number in a list should produce a number... + ;; Concatenating to a number in a list should produce a numeric value... (eshell-command-result-equal "echo ${*echo \"1\n2\"}3" + '("1" "23")) + (eshell-command-result-equal "echo $@{*echo \"1\n2\"}3" '(1 23)) ;; ... but concatenating to a string that looks like a number in a list ;; should produce a string. (eshell-command-result-equal "echo ${*echo \"hi\n2\"}3" + '("hi" "23")) + (eshell-command-result-equal "echo $@{*echo \"hi\n2\"}3" '("hi" "23"))) (ert-deftest esh-var-test/interp-concat-cmd2 () @@ -424,7 +435,8 @@ nil, use FUNCTION instead." "Splice-interpolate list variable inside double-quotes." (let ((eshell-test-value '(1 2 3))) (eshell-command-result-equal "echo a \"$@eshell-test-value\" z" - '("a" "1 2 3" "z")))) + '("a" "1 2 3" "z")) + (should (equal eshell-test-value '(1 2 3))))) (ert-deftest esh-var-test/quoted-interp-var-splice-concat () "Splice-interpolate and concat list variable inside double-quotes" @@ -491,11 +503,16 @@ nil, use FUNCTION instead." (ert-deftest esh-var-test/interp-convert-var-split-indices () "Interpolate and convert string variable with indices." - ;; Check that numeric forms are converted to numbers. + ;; Check that numeric forms are marked as numeric. (let ((eshell-test-value "000 010 020 030 040")) + ;; `eshell/echo' converts numeric strings to Lisp numbers... (eshell-command-result-equal "echo $eshell-test-value[0]" 0) + ;; ... but not lists of numeric strings... (eshell-command-result-equal "echo $eshell-test-value[0 2]" + '("000" "020")) + ;; ... unless each element is a separate argument to `eshell/echo'. + (eshell-command-result-equal "echo $@eshell-test-value[0 2]" '(0 20))) ;; Check that multiline forms are preserved as-is. (let ((eshell-test-value "foo\nbar:baz\n")) @@ -515,9 +532,14 @@ nil, use FUNCTION instead." (ert-deftest esh-var-test/interp-convert-quoted-var-split-indices () "Interpolate and convert quoted string variable with indices." (let ((eshell-test-value "000 010 020 030 040")) + ;; `eshell/echo' converts numeric strings to Lisp numbers... (eshell-command-result-equal "echo $'eshell-test-value'[0]" 0) + ;; ... but not lists of numeric strings... (eshell-command-result-equal "echo $'eshell-test-value'[0 2]" + '("000" "020")) + ;; ... unless each element is a separate argument to `eshell/echo'. + (eshell-command-result-equal "echo $@'eshell-test-value'[0 2]" '(0 20)))) (ert-deftest esh-var-test/interp-convert-cmd-string-newline () @@ -530,9 +552,13 @@ nil, use FUNCTION instead." '("foo" "bar")) ;; Numeric output should be converted to numbers... (eshell-command-result-equal "echo ${echo \"01\n02\n03\"}" + '("01" "02" "03")) + (eshell-command-result-equal "echo $@{echo \"01\n02\n03\"}" '(1 2 3)) ;; ... but only if every line is numeric. (eshell-command-result-equal "echo ${echo \"01\n02\nhi\"}" + '("01" "02" "hi")) + (eshell-command-result-equal "echo $@{echo \"01\n02\nhi\"}" '("01" "02" "hi"))) (ert-deftest esh-var-test/interp-convert-cmd-number () @@ -541,9 +567,14 @@ nil, use FUNCTION instead." (ert-deftest esh-var-test/interp-convert-cmd-split-indices () "Interpolate command result with indices." + ;; `eshell/echo' converts numeric strings to Lisp numbers... (eshell-command-result-equal "echo ${echo \"000 010 020\"}[0]" 0) + ;; ... but not lists of numeric strings... (eshell-command-result-equal "echo ${echo \"000 010 020\"}[0 2]" + '("000" "020")) + ;; ... unless each element is a separate argument to `eshell/echo'. + (eshell-command-result-equal "echo $@{echo \"000 010 020\"}[0 2]" '(0 20))) (ert-deftest esh-var-test/quoted-interp-convert-var-number () diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el index ea9e663b1ad..4422bbe6660 100644 --- a/test/lisp/ibuffer-tests.el +++ b/test/lisp/ibuffer-tests.el @@ -132,7 +132,7 @@ (ibuffer-switch-to-saved-filter-groups "saved-filters") (should (assoc "Elisp" (cdar ibuffer-saved-filter-groups)))) (setq ibuffer-saved-filter-groups orig-filters) - (when-let ((it (get-buffer "*Ibuffer*"))) + (when-let* ((it (get-buffer "*Ibuffer*"))) (and (buffer-live-p it) (kill-buffer it)))))) diff --git a/test/lisp/international/mule-tests.el b/test/lisp/international/mule-tests.el index 9c869cc8e6f..5bcb8f5a551 100644 --- a/test/lisp/international/mule-tests.el +++ b/test/lisp/international/mule-tests.el @@ -67,7 +67,7 @@ (ert-deftest mule-cmds-tests--ucs-names-missing-names () (let (code-points) (dotimes (u (1+ (max-char 'ucs))) - (when-let ((name (get-char-code-property u 'name))) + (when-let* ((name (get-char-code-property u 'name))) (when (and (not (<= #xD800 u #xDFFF)) (not (<= #x18800 u #x18AFF)) (not (char-from-name name))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 598fa49deb3..d658b061116 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -33,6 +33,14 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. +;; All temporary Tramp test files are removed prior test run. +;; Therefore, two test runs cannot be performed in parallel. + +;; The environment variable $TRAMP_TEST_CLEANUP_TEMP_FILES, when set, +;; forces the removal of all temporary Tramp files prior test run. +;; This shouldn't be set if the test suite runs in parallel using +;; Tramp on a production system. + ;; For slow remote connections, `tramp-test45-asynchronous-requests' ;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper ;; value less than 10 could help. @@ -128,7 +136,8 @@ (tramp-dissect-file-name ert-remote-temporary-file-directory)) "The used `tramp-file-name' structure.") -(setq auth-source-save-behavior nil +(setq auth-source-cache-expiry nil + auth-source-save-behavior nil password-cache-expiry nil remote-file-name-inhibit-cache nil tramp-allow-unsafe-temporary-files t @@ -138,38 +147,8 @@ tramp-persistency-file-name nil tramp-verbose 0) -(defvar tramp--test-enabled-checked nil - "Cached result of `tramp--test-enabled'. -If the function did run, the value is a cons cell, the `cdr' -being the result.") - -(defun tramp--test-enabled () - "Whether remote file access is enabled." - (unless (consp tramp--test-enabled-checked) - (setq - tramp--test-enabled-checked - (cons - t (ignore-errors - (and - (file-remote-p ert-remote-temporary-file-directory) - (file-directory-p ert-remote-temporary-file-directory) - (file-writable-p ert-remote-temporary-file-directory)))))) - - (when (cdr tramp--test-enabled-checked) - ;; Remove old test files. - (dolist (dir `(,temporary-file-directory - ,ert-remote-temporary-file-directory)) - (dolist (file (directory-files dir 'full (rx bos (? ".#") "tramp-test"))) - (ignore-errors - (if (file-directory-p file) - (delete-directory file 'recursive) - (delete-file file))))) - ;; Cleanup connection. - (ignore-errors - (tramp-cleanup-connection tramp-test-vec nil 'keep-password))) - - ;; Return result. - (cdr tramp--test-enabled-checked)) +(defconst tramp-test-name-prefix "tramp-test" + "Prefix to use for temporary test files.") (defun tramp--test-make-temp-name (&optional local quoted) "Return a temporary file name for test. @@ -179,7 +158,7 @@ The temporary file is not created." (funcall (if quoted #'file-name-quote #'identity) (expand-file-name - (make-temp-name "tramp-test") + (make-temp-name tramp-test-name-prefix) (if local temporary-file-directory ert-remote-temporary-file-directory)))) ;; Method "smb" supports `make-symbolic-link' only if the remote host @@ -247,6 +226,56 @@ is greater than 10. (tramp--test-message "%s %f sec" ,message (float-time (time-subtract nil start)))))) +(defvar tramp--test-enabled-checked nil + "Cached result of `tramp--test-enabled'. +If the function did run, the value is a cons cell, the `cdr' +being the result.") + +(defun tramp--test-enabled () + "Whether remote file access is enabled." + (unless (consp tramp--test-enabled-checked) + (setq + tramp--test-enabled-checked + (cons + t (ignore-errors + (and + (file-remote-p ert-remote-temporary-file-directory) + (file-directory-p ert-remote-temporary-file-directory) + (file-writable-p ert-remote-temporary-file-directory)))))) + + (when (cdr tramp--test-enabled-checked) + ;; Remove old test files. + (dolist (dir `(,temporary-file-directory + ,tramp-compat-temporary-file-directory + ,ert-remote-temporary-file-directory)) + (dolist + (file + (directory-files + dir 'full + (rx bos (? ".#") + (| (literal tramp-test-name-prefix) + (eval (if (getenv "TRAMP_TEST_CLEANUP_TEMP_FILES") + tramp-temp-name-prefix 'unmatchable)))))) + + ;; Exclude sockets and FUSE mount points. + (ignore-errors + (unless + (or (string-prefix-p + "srw" (file-attribute-modes (file-attributes file))) + (string-match-p (rx bos (literal tramp-fuse-name-prefix) + (regexp tramp-method-regexp) ".") + (file-name-nondirectory file))) + (tramp--test-message "Delete %s" file) + (if (file-directory-p file) + (delete-directory file 'recursive) + (delete-file file)))))) + ;; Cleanup connection. + (ignore-errors + (tramp-cleanup-connection tramp-test-vec nil 'keep-password))) + + ;; Return result. + (cdr tramp--test-enabled-checked)) + (ert-deftest tramp-test00-availability () "Test availability of Tramp functions." :expected-result (if (tramp--test-enabled) :passed :failed) @@ -1409,10 +1438,20 @@ is greater than 10. ;; Suppress check for multihops. (tramp-cache-data (make-hash-table :test #'equal)) (tramp-connection-properties '((nil "login-program" t))) - (syntax tramp-syntax)) + (syntax tramp-syntax) + ;; We must transform `tramp-crypt-directories'. + (tramp-crypt-directories + (mapcar #'tramp-dissect-file-name tramp-crypt-directories))) (unwind-protect (progn (tramp-change-syntax 'separate) + ;; We must transform `tramp-crypt-directories'. + (setq tramp-crypt-directories + (mapcar + (lambda (vec) + (tramp-make-tramp-file-name + vec (tramp-file-name-localname vec))) + tramp-crypt-directories)) ;; An unknown method shall raise an error. (let (non-essential) (should-error @@ -2125,7 +2164,7 @@ is greater than 10. (when (assoc m tramp-methods) (let (tramp-connection-properties tramp-default-proxies-alist) (ignore-errors - (tramp-cleanup-connection tramp-test-vec nil 'keep-password)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)) ;; Single hop. The host name must match `tramp-local-host-regexp'. (should-error (find-file (format "/%s:foo:" m)) @@ -3828,12 +3867,12 @@ The test is derived from TEST and COMMAND." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (tramp-get-remote-stat tramp-test-vec)) - (if-let ((default-directory ert-remote-temporary-file-directory) - (ert-test (ert-get-test ',test)) - (result (ert-test-most-recent-result ert-test)) - (tramp-connection-properties - (cons '(nil "perl" nil) - tramp-connection-properties))) + (if-let* ((default-directory ert-remote-temporary-file-directory) + (ert-test (ert-get-test ',test)) + (result (ert-test-most-recent-result ert-test)) + (tramp-connection-properties + (cons '(nil "perl" nil) + tramp-connection-properties))) (progn (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) @@ -3848,17 +3887,17 @@ The test is derived from TEST and COMMAND." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (tramp-get-remote-perl tramp-test-vec)) - (if-let ((default-directory ert-remote-temporary-file-directory) - (ert-test (ert-get-test ',test)) - (result (ert-test-most-recent-result ert-test)) - (tramp-connection-properties - (append - '((nil "stat" nil) - ;; See `tramp-sh-handle-file-truename'. - (nil "readlink" nil) - ;; See `tramp-sh-handle-get-remote-*'. - (nil "id" nil)) - tramp-connection-properties))) + (if-let* ((default-directory ert-remote-temporary-file-directory) + (ert-test (ert-get-test ',test)) + (result (ert-test-most-recent-result ert-test)) + (tramp-connection-properties + (append + '((nil "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (nil "readlink" nil) + ;; See `tramp-sh-handle-get-remote-*'. + (nil "id" nil)) + tramp-connection-properties))) (progn (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) @@ -3872,16 +3911,16 @@ The test is derived from TEST and COMMAND." (tramp--test-set-ert-test-documentation ',test "ls") (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (if-let ((default-directory ert-remote-temporary-file-directory) - (ert-test (ert-get-test ',test)) - (result (ert-test-most-recent-result ert-test)) - (tramp-connection-properties - (append - '((nil "perl" nil) - (nil "stat" nil) - ;; See `tramp-sh-handle-file-truename'. - (nil "readlink" nil)) - tramp-connection-properties))) + (if-let* ((default-directory ert-remote-temporary-file-directory) + (ert-test (ert-get-test ',test)) + (result (ert-test-most-recent-result ert-test)) + (tramp-connection-properties + (append + '((nil "perl" nil) + (nil "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (nil "readlink" nil)) + tramp-connection-properties))) (progn (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) @@ -3908,9 +3947,9 @@ The test is derived from TEST and COMMAND." (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sudoedit-p))) - (if-let ((default-directory ert-remote-temporary-file-directory) - (ert-test (ert-get-test ',test)) - (result (ert-test-most-recent-result ert-test))) + (if-let* ((default-directory ert-remote-temporary-file-directory) + (ert-test (ert-get-test ',test)) + (result (ert-test-most-recent-result ert-test))) (progn (skip-unless (< (ert-test-result-duration result) 300)) (let (tramp-use-file-attributes) @@ -4873,7 +4912,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ert-deftest tramp-test26-interactive-file-name-completion () "Check interactive completion with different `completion-styles'." ;; Method, user and host name in completion mode. - (tramp-cleanup-connection tramp-test-vec nil 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (let ((method (file-remote-p ert-remote-temporary-file-directory 'method)) (user (file-remote-p ert-remote-temporary-file-directory 'user)) @@ -5220,8 +5259,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Timeout handler, reporting a failed test." (interactive) (tramp--test-message "proc: %s" (get-buffer-process (current-buffer))) - (when-let ((proc (get-buffer-process (current-buffer))) - ((processp proc))) + (when-let* ((proc (get-buffer-process (current-buffer))) + ((processp proc))) (tramp--test-message "cmd: %s" (process-command proc))) (tramp--test-message "buf: %s\n%s\n---" (current-buffer) (buffer-string)) (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) @@ -5404,7 +5443,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." direct-async-process-profile) connection-local-criteria-alist))) (skip-unless (tramp-direct-async-process-p)) - (when-let ((result (ert-test-most-recent-result ert-test))) + (when-let* ((result (ert-test-most-recent-result ert-test))) (skip-unless (< (ert-test-result-duration result) 300))) ;; We do expect an established connection already, ;; `file-truename' does it by side-effect. Suppress @@ -5814,8 +5853,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (setq command '("sleep" "100") proc (apply #'start-file-process "test" nil command)) (while (accept-process-output proc 0)) - (when-let ((pid (process-get proc 'remote-pid)) - (attributes (process-attributes pid))) + (when-let* ((pid (process-get proc 'remote-pid)) + (attributes (process-attributes pid))) ;; (tramp--test-message "%s" attributes) (should (equal (cdr (assq 'comm attributes)) (car command))) (should (equal (cdr (assq 'args attributes)) @@ -5832,8 +5871,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; `memory-info' is supported since Emacs 29.1. (skip-unless (tramp--test-emacs29-p)) - (when-let ((default-directory ert-remote-temporary-file-directory) - (mi (memory-info))) + (when-let* ((default-directory ert-remote-temporary-file-directory) + (mi (memory-info))) (should (consp mi)) (should (length= mi 4)) (dotimes (i (length mi)) @@ -5944,7 +5983,9 @@ INPUT, if non-nil, is a string sent to the process." ;; Test `async-shell-command-width'. (when (and (tramp--test-asynchronous-processes-p) (tramp--test-sh-p)) - (let* ((async-shell-command-width 1024) + (let* (;; Since Fedora 41, this seems to be the upper limit. Used + ;; to be 1024 before. + (async-shell-command-width 512) (default-directory ert-remote-temporary-file-directory) (cols (ignore-errors (read (tramp--test-shell-command-to-string-asynchronously @@ -6464,6 +6505,7 @@ INPUT, if non-nil, is a string sent to the process." (tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1)) (tramp-remote-process-environment tramp-remote-process-environment) + ;; Suppress nasty messages. (inhibit-message t) (vc-handled-backends (cond @@ -6486,9 +6528,7 @@ INPUT, if non-nil, is a string sent to the process." (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) '(Bzr)) - (t nil))) - ;; Suppress nasty messages. - (inhibit-message t)) + (t nil)))) (skip-unless vc-handled-backends) (unless quoted (tramp--test-message "%s" vc-handled-backends)) @@ -7026,7 +7066,7 @@ INPUT, if non-nil, is a string sent to the process." (file-remote-p (temporary-file-directory)))) ;; The temporary file shall be located on the remote host. - (setq tmp-file (make-nearby-temp-file "tramp-test")) + (setq tmp-file (make-nearby-temp-file tramp-test-name-prefix)) (should (file-exists-p tmp-file)) (should (file-regular-p tmp-file)) (should @@ -7036,7 +7076,7 @@ INPUT, if non-nil, is a string sent to the process." (delete-file tmp-file) (should-not (file-exists-p tmp-file)) - (setq tmp-file (make-nearby-temp-file "tramp-test" 'dir)) + (setq tmp-file (make-nearby-temp-file tramp-test-name-prefix 'dir)) (should (file-exists-p tmp-file)) (should (file-directory-p tmp-file)) (delete-directory tmp-file) @@ -7356,7 +7396,7 @@ This requires restrictions of file name syntax." (setq buffer (dired-noselect tmp-name1 "--dired -al")) (goto-char (point-min)) (while (not (eobp)) - (when-let ((name (dired-get-filename 'no-dir 'no-error))) + (when-let* ((name (dired-get-filename 'no-dir 'no-error))) (unless (string-match-p name directory-files-no-dot-files-regexp) (should (member name files)))) @@ -7636,7 +7676,7 @@ This requires restrictions of file name syntax." "Check that `file-system-info' returns proper values." (skip-unless (tramp--test-enabled)) - (when-let ((fsi (file-system-info ert-remote-temporary-file-directory))) + (when-let* ((fsi (file-system-info ert-remote-temporary-file-directory))) (should (consp fsi)) (should (length= fsi 3)) (dotimes (i (length fsi)) @@ -7668,10 +7708,10 @@ should all return proper values." (should (or (stringp (tramp-get-remote-gid v 'string)) (null (tramp-get-remote-gid v 'string)))) - (when-let ((groups (tramp-get-remote-groups v 'integer))) + (when-let* ((groups (tramp-get-remote-groups v 'integer))) (should (consp groups)) (dolist (group groups) (should (integerp group)))) - (when-let ((groups (tramp-get-remote-groups v 'string))) + (when-let* ((groups (tramp-get-remote-groups v 'string))) (should (consp groups)) (dolist (group groups) (should (stringp group))))))) @@ -7820,9 +7860,9 @@ process sentinels. They shall not disturb each other." buf) (while buffers (setq buf (seq-random-elt buffers)) - (if-let ((proc (get-buffer-process buf)) - (file (process-get proc 'foo)) - (count (process-get proc 'bar))) + (if-let* ((proc (get-buffer-process buf)) + (file (process-get proc 'foo)) + (count (process-get proc 'bar))) (progn (tramp--test-message "Start action %d %s %s" count buf (current-time-string)) @@ -7935,7 +7975,7 @@ process sentinels. They shall not disturb each other." (let ((pass "secret") (mock-entry (copy-tree (assoc "mock" tramp-methods))) - mocked-input tramp-methods) + mocked-input tramp-methods auth-sources) ;; We must mock `read-string', in order to avoid interactive ;; arguments. (cl-letf* (((symbol-function #'read-string) @@ -7974,12 +8014,42 @@ process sentinels. They shall not disturb each other." (setq mocked-input nil) (auth-source-forget-all-cached) (ert-with-temp-file netrc-file - :prefix "tramp-test" :suffix "" + :prefix tramp-test-name-prefix :suffix "" :text (format "machine %s port mock password %s" (file-remote-p ert-remote-temporary-file-directory 'host) pass) (let ((auth-sources `(,netrc-file))) - (should (file-exists-p ert-remote-temporary-file-directory))))))))) + (should (file-exists-p ert-remote-temporary-file-directory)))))) + + ;; Checking session-timeout. + (with-no-warnings (when (symbol-plist 'ert-with-temp-file) + (tramp-cleanup-connection tramp-test-vec 'keep-debug) + (let ((tramp-connection-properties + (cons '(nil "session-timeout" 1) + tramp-connection-properties))) + (setq mocked-input nil) + (auth-source-forget-all-cached) + (ert-with-temp-file netrc-file + :prefix tramp-test-name-prefix :suffix "" + :text (format + "machine %s port mock password %s" + (file-remote-p ert-remote-temporary-file-directory 'host) + pass) + (let ((auth-sources `(,netrc-file))) + (should (file-exists-p ert-remote-temporary-file-directory)))) + ;; Session established, password cached. + (should + (password-in-cache-p + (auth-source-format-cache-entry + (tramp-get-connection-property tramp-test-vec " pw-spec")))) + ;; We want to see the timeout message. + (tramp--test-instrument-test-case 3 + (sleep-for 2)) + ;; Session cancelled, no password in cache. + (should-not + (password-in-cache-p + (auth-source-format-cache-entry + (tramp-get-connection-property tramp-test-vec " pw-spec")))))))))) (ert-deftest tramp-test47-read-otp-password () "Check Tramp one-time password handling." @@ -8031,7 +8101,7 @@ process sentinels. They shall not disturb each other." (setq mocked-input nil) (auth-source-forget-all-cached) (ert-with-temp-file netrc-file - :prefix "tramp-test" :suffix "" + :prefix tramp-test-name-prefix :suffix "" :text (format "machine %s port mock password %s" (file-remote-p ert-remote-temporary-file-directory 'host) @@ -8258,7 +8328,6 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p -;; * memory-info ;; * tramp-get-home-directory ;; * tramp-set-file-uid-gid diff --git a/test/lisp/proced-tests.el b/test/lisp/proced-tests.el index 6f16a241146..3dc7e065afa 100644 --- a/test/lisp/proced-tests.el +++ b/test/lisp/proced-tests.el @@ -43,18 +43,35 @@ (defun proced--move-to-column (attribute) "Move to the column under ATTRIBUTE in the current proced buffer." - (move-to-column (string-match attribute proced-header-line))) - -(defun proced--assert-process-valid-pid-refinement (pid) - "Fail unless the process at point could be present after a refinement using PID." - (proced--move-to-column "PID") - (let ((pid-equal (string= pid (word-at-point)))) - (should - (or pid-equal - ;; Guard against the unlikely event a platform doesn't support PPID - (when (string-match "PPID" proced-header-line) - (proced--move-to-column "PPID") - (string= pid (word-at-point))))))) + (move-to-column (string-match attribute proced-header-line)) + ;; Sometimes the column entry does not fill the whole column. + (while (= (char-after (point)) ?\s) (forward-char))) + +(defun proced--assert-process-valid-cpu-refinement (cpu) + "Fail unless the process at point could be present after a refinement using CPU." + (proced--move-to-column "%CPU") + (condition-case err + (>= (thing-at-point 'number) cpu) + (error + (ert-fail + (list err (proced--assert-process-valid-cpu-refinement-explainer cpu)))))) + +(defun proced--assert-process-valid-cpu-refinement-explainer (cpu) + "Explain the result of `proced--assert-process-valid-cpu-refinement'. + +CPU is as in `proced--assert-process-valid-cpu-refinement'." + `(unexpected-refinement + (header-line + ,(substring-no-properties + (string-replace "%%" "%" (cadr (proced-header-line))))) + (process ,(thing-at-point 'line t)) + (refined-value ,cpu) + (process-value + ,(save-excursion + (proced--move-to-column "%CPU") (thing-at-point 'number))))) + +(put #'proced--assert-process-valid-cpu-refinement 'ert-explainer + #'proced--assert-process-valid-cpu-refinement-explainer) (ert-deftest proced-format-test () (dolist (format '(short medium long verbose)) @@ -85,26 +102,24 @@ (proced--assert-emacs-pid-in-buffer)))) (ert-deftest proced-refine-test () - ;;(skip-unless (memq system-type '(gnu/linux gnu/kfreebsd darwin))) (proced--within-buffer 'verbose 'user - ;; When refining on PID for process A, a process is kept if and only - ;; if its PID is the same as process A, or its parent process is - ;; process A. - (proced--move-to-column "PID") - (let ((pid (word-at-point))) + ;; When refining on %CPU for process A, a process is kept if and only + ;; if its %CPU is greater than or equal to that of process A. + (proced--move-to-column "%CPU") + (let ((cpu (thing-at-point 'number))) (proced-refine) (while (not (eobp)) - (proced--assert-process-valid-pid-refinement pid) + (should (proced--assert-process-valid-cpu-refinement cpu)) (forward-line))))) (ert-deftest proced-refine-with-update-test () (proced--within-buffer 'verbose 'user - (proced--move-to-column "PID") - (let ((pid (word-at-point))) + (proced--move-to-column "%CPU") + (let ((cpu (thing-at-point 'number))) (proced-refine) ;; Don't use (proced-update t) since this will reset `proced-process-alist' ;; and it's possible the process refined on would have exited by that @@ -112,10 +127,13 @@ ;; processes again, causing the test to fail. (proced-update) (while (not (eobp)) - (proced--assert-process-valid-pid-refinement pid) + (should (proced--assert-process-valid-cpu-refinement cpu)) (forward-line))))) (ert-deftest proced-update-preserves-pid-at-point-test () + ;; FIXME: Occasionally the cursor inexplicably changes to the first line which + ;; causes the test to file when the line isn't the Emacs process. + :tags '(:unstable) (proced--within-buffer 'medium 'user @@ -128,7 +146,7 @@ (old-window (get-buffer-window))) (select-window new-window) (with-current-buffer "*Proced*" - (proced-update t t)) + (proced-update)) (select-window old-window) (should (= pid (proced-pid-at-point))))))) diff --git a/test/lisp/progmodes/c-ts-mode-resources/indent.erts b/test/lisp/progmodes/c-ts-mode-resources/indent.erts index f97ceac61f5..2f3540c3970 100644 --- a/test/lisp/progmodes/c-ts-mode-resources/indent.erts +++ b/test/lisp/progmodes/c-ts-mode-resources/indent.erts @@ -208,7 +208,7 @@ int main() } =-=-= -Name: Return Compund Literal +Name: Return Compound Literal =-= struct pair { int fst, snd; }; diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 591c32a8271..45714b3e7d9 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -109,6 +109,14 @@ (should (member "backup-inhibited" comps)) (should-not (member "backup-buffer" comps)))))) +(ert-deftest elisp-completes-functions-after-empty-let-bindings () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(let () (ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps))))) + (ert-deftest elisp-completes-functions-after-let-bindings-2 () (with-temp-buffer (emacs-lisp-mode) diff --git a/test/lisp/progmodes/lua-ts-mode-resources/indent.erts b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts index ba7bad1b452..b0ece4cc261 100644 --- a/test/lisp/progmodes/lua-ts-mode-resources/indent.erts +++ b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts @@ -360,6 +360,10 @@ multi-line ]] return true end + + --[[ +Long comment. + ]] =-= --[[ Multi-line @@ -373,6 +377,44 @@ multi-line ]] return true end + + --[[ +Long comment. + ]] +=-=-= + +Name: Comment Indent + +=-= +local fn1 = function (a, b) +-- comment +return a + b +end + +local tb1 = { + first = 1, +-- comment + second = 2, +} + +local tb9 = { one = 1, +-- comment + two = 2 } +=-= +local fn1 = function (a, b) + -- comment + return a + b +end + +local tb1 = { + first = 1, + -- comment + second = 2, +} + +local tb9 = { one = 1, + -- comment + two = 2 } =-=-= Name: Argument Indent diff --git a/test/lisp/progmodes/peg-tests.el b/test/lisp/progmodes/peg-tests.el index 8fab549bcab..b9e9c47ab7c 100644 --- a/test/lisp/progmodes/peg-tests.el +++ b/test/lisp/progmodes/peg-tests.el @@ -180,6 +180,20 @@ resp. succeeded instead of signaling an error." (should (eobp))) ) +(define-peg-ruleset peg-test-myrules + (sign () (or "+" "-" "")) + (digit () [0-9]) + (nat () digit (* digit)) + (int () sign digit (* digit)) + (float () int "." nat)) + +(ert-deftest peg-test-ruleset () + (with-peg-rules + (peg-test-myrules + (complex float "+i" float)) + (should (peg-parse-string nat "123" t)) + (should (not (peg-parse-string nat "home" t))))) + ;;; Examples: ;; peg-ex-recognize-int recognizes integers. An integer begins with a diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el index 93943cef43b..1583732016b 100644 --- a/test/lisp/progmodes/project-tests.el +++ b/test/lisp/progmodes/project-tests.el @@ -138,7 +138,11 @@ When `project-ignores' includes a name matching project dir." (project (project-current nil dir))) (should-not (null project)) (should (nth 1 project)) - (should (string-match-p "/test/lisp/\\'" (project-root project))))) + (should (string-match-p "/test/lisp/\\'" (project-root project))) + ;; bug#73801 + (should (equal + project + (project-current nil (project-root project)))))) (ert-deftest project-vc-supports-project-in-different-dir () "Check that it picks up dir-locals settings from somewhere else." diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 9eef82e9c90..4cc4040d0ff 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -3790,8 +3790,8 @@ condition is met. If env string EMACS_PYTHON_INTERPRETER exists, use it as preferred one." (unless python-tests-shell-interpreters (setq python-tests-shell-interpreters - (if-let ((interpreter (getenv "EMACS_PYTHON_INTERPRETER"))) - (if-let ((info (python-tests--get-interpreter-info interpreter))) + (if-let* ((interpreter (getenv "EMACS_PYTHON_INTERPRETER"))) + (if-let* ((info (python-tests--get-interpreter-info interpreter))) (list info) (error "Couldn't find EMACS_PYTHON_INTERPRETER(%s) in path" interpreter)) @@ -3805,7 +3805,7 @@ as preferred one." "Get Python interpreter information specified by NAME. The information returned is a cons cell consisting of the file path and the version string." - (when-let ((interpreter (executable-find name))) + (when-let* ((interpreter (executable-find name))) (with-temp-buffer (and (equal (call-process interpreter nil t nil "--version") 0) (goto-char (point-min)) diff --git a/test/lisp/progmodes/ruby-ts-mode-tests.el b/test/lisp/progmodes/ruby-ts-mode-tests.el index 05d98974acf..08620294ebe 100644 --- a/test/lisp/progmodes/ruby-ts-mode-tests.el +++ b/test/lisp/progmodes/ruby-ts-mode-tests.el @@ -275,8 +275,8 @@ The whitespace before and including \"|\" on each line is removed." expected)))))) (defmacro ruby-ts-resource-file (file) - `(when-let ((testfile ,(or (macroexp-file-name) - buffer-file-name))) + `(when-let* ((testfile ,(or (macroexp-file-name) + buffer-file-name))) (let ((default-directory (file-name-directory testfile))) (file-truename (expand-file-name (format "ruby-mode-resources/%s" ,file)))))) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 11260204750..5efb75b6d85 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -547,7 +547,7 @@ Return the last evalled form in BODY." (delq nil (mapcar (lambda (chr) - (when-let (it (alist-get chr char-nums)) + (when-let* ((it (alist-get chr char-nums))) (if (cdr it) `(,(cons 'or it) ,chr) `(,(car it) ,chr)))) diff --git a/test/lisp/speedbar-tests.el b/test/lisp/speedbar-tests.el new file mode 100644 index 00000000000..5450d211b1a --- /dev/null +++ b/test/lisp/speedbar-tests.el @@ -0,0 +1,318 @@ +;;; speedbar-tests.el --- Tests for speedbar.el -*- lexical-binding: t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'eieio-base) +(require 'eieio-speedbar) + +(defclass speedbar-tests-container (eieio-named eieio-speedbar-file-button) + ((child-items :initarg :child-items + :type list)) + "An expandable Speedbar item which can contain other items.") + +(cl-defmethod eieio-speedbar-object-children ((item speedbar-tests-container)) + "Return the list of child items for ITEM." + (slot-value item 'child-items)) + +(defclass speedbar-tests-item (eieio-named eieio-speedbar) + nil + "A Speedbar item which cannot contain other items.") + +(defun speedbar-tests--make-object (item-spec) + "Return an object representing a Speedbar item. + +The object is constructed based on the specification ITEM-SPEC which +should be a cons pair of the form (NAME . CHILD-ITEMS). NAME is a +string which will be used for display purposes. CHILD-ITEMS is a list +of additional ITEM-SPEC values which will be referenced as children." + (let ((name (car item-spec)) + (child-items (cdr item-spec))) + (unless (stringp name) + (error "Item name must be a string")) + (unless (listp child-items) + (error "Child-items must be a list")) + (if child-items + (speedbar-tests-container + :object-name name + :child-items (mapcar #'speedbar-tests--make-object + child-items)) + (speedbar-tests-item + :object-name name)))) + +(defvar speedbar-tests--setup-strings nil + "An alist of strings which represents a hierarchy of Speedbar items.") + +(defvar speedbar-tests--object-hierarchy nil + "The current object hierarchy for the Speedbar being tested.") + +(defun speedbar-tests--base-items (_directory) + "Return the list of top-level objects for the Speedbar." + (setq speedbar-tests--object-hierarchy + (mapcar #'speedbar-tests--make-object + speedbar-tests--setup-strings))) + +(eieio-speedbar-create #'eieio-speedbar-make-map + 'eieio-speedbar-key-map + 'eieio-speedbar-menu + "Test" + #'speedbar-tests--base-items) + +(defun speedbar-tests--clean-up () + "Clean-up after Speedbar test." + (when (framep speedbar-frame) + (delete-frame speedbar-frame))) + +(defun speedbar-tests--initialize () + "Initialize a Speedbar for testing." + (speedbar-get-focus) + (speedbar-change-initial-expansion-list "Test")) + +(defun speedbar-tests--object-name-expanded (object) + "Return the string name of OBJECT when it is expanded." + (let ((name (eieio-speedbar-object-buttonname object))) + (if (slot-value object 'expanded) + (concat name "+") + name))) + +(defvar speedbar-tests--object-name-function + #'eieio-speedbar-object-buttonname + "The function which returns the string representation of an object.") + +(defun speedbar-tests--objects-as-strings (object-list) + "Return the object hierarchy OBJECT-LIST as an alist of strings. + +The string used to represent the object is determined by the function +bound to `speedbar-tests--object-name-function' is a function, which +should accept the object as the only argument and return a string to use +as the name." + (mapcar (lambda (object) + (let ((name (funcall speedbar-tests--object-name-function + object)) + (child-items (eieio-speedbar-object-children + object))) + (cons name (speedbar-tests--objects-as-strings + child-items)))) + object-list)) + +(cl-defmacro speedbar-tests--state-test + ((&optional &key setup final name-function) &rest body) + "Evaluate BODY and verify the Speedbar is in an expected state. + +`:setup' specifies an alist of strings which will be used to create an +object hierarchy used for the Speedbar display. + +`:final' specifies an alist of strings which should represent the final +Speedbar state once BODY has been evaluated and the object hierarchy has +been converted back to an alist of strings. `:name-function' specifies +the function to use to generate a string from an object, which should +accept the object as an argument and return a string which represents +the object as well as its state." + (declare (indent 1)) + (let ((let-vars `((speedbar-tests--setup-strings ',setup)))) + (when name-function + (push `(speedbar-tests--object-name-function #',name-function) + let-vars)) + `(unwind-protect + (let ,let-vars + (speedbar-tests--initialize) + (should (equal (speedbar-tests--objects-as-strings + speedbar-tests--object-hierarchy) + ',setup)) + ,@body + (should (equal (speedbar-tests--objects-as-strings + speedbar-tests--object-hierarchy) + ',final))) + (speedbar-tests--clean-up)))) + +(ert-deftest speedbar-tests--expand-descendants-single () + "Expand the first item." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1")))) + :final (("A+" . (("A1")))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (should (string-equal "A" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache)))) + +(ert-deftest speedbar-tests--expand-descendants-nested () + "Expand the first item and its only child." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A")))))) + :final (("A+" . (("A1+" . (("A1A")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (should (string-equal "A" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache)))) + +(ert-deftest speedbar-tests--expand-descendants-nested-wide () + "Expand all descendants of first item which has multiple children." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A")))))) + :final (("A+" . (("A1+" . (("A1A"))) + ("A2+" . (("A2A")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (should (string-equal "A" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache)))) + +(ert-deftest speedbar-tests--expand-descendants-of-first () + "Expand the first item and all descendants." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B")))))) + :final (("A+" . (("A1+" . (("A1A"))) + ("A2+" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (should (string-equal "A" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache)))) + +(ert-deftest speedbar-tests--expand-descendants-of-first-expanded () + "Expand the already expanded first item and all descendants." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B")))))) + :final (("A+" . (("A1+" . (("A1A"))) + ("A2+" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (should (string-equal "A" (speedbar-line-text))) + (speedbar-expand-line 'nocache) + (speedbar-expand-line-descendants 'nocache)))) + +(ert-deftest speedbar-tests--expand-descendants-of-last () + "Expand the last item and all descendants." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B")))))) + :final (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B+" . (("B1+" . (("B1B"))) + ("B2+" . (("B2B")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (forward-line) + (should (string-equal "B" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache)))) + +(ert-deftest speedbar-tests--expand-descendants-of-last-expanded () + "Expand the already expanded last item and all descendants." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B")))))) + :final (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B+" . (("B1+" . (("B1B"))) + ("B2+" . (("B2B")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (save-excursion + (forward-line) + (should (string-equal "B" (speedbar-line-text))) + (speedbar-expand-line 'nocache)) + (save-excursion + (forward-line) + (should (string-equal "B" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache))))) + +(ert-deftest speedbar-tests--expand-descendants-of-middle () + "Expand the middle item and all descendants." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B"))))) + ("C" . (("C1" . (("C1C"))) + ("C2" . (("C2C")))))) + :final (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B+" . (("B1+" . (("B1B"))) + ("B2+" . (("B2B"))))) + ("C" . (("C1" . (("C1C"))) + ("C2" . (("C2C")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (goto-char (point-min)) + (forward-line) + (should (string-equal "B" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache)))) + +(ert-deftest speedbar-tests--expand-descendants-of-middle-expanded () + "Expand the already expanded middle item and all descendants." + (skip-when noninteractive) + (speedbar-tests--state-test + ( :setup (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B" . (("B1" . (("B1B"))) + ("B2" . (("B2B"))))) + ("C" . (("C1" . (("C1C"))) + ("C2" . (("C2C")))))) + :final (("A" . (("A1" . (("A1A"))) + ("A2" . (("A2A"))))) + ("B+" . (("B1+" . (("B1B"))) + ("B2+" . (("B2B"))))) + ("C" . (("C1" . (("C1C"))) + ("C2" . (("C2C")))))) + :name-function speedbar-tests--object-name-expanded) + (with-current-buffer speedbar-buffer + (goto-char (point-min)) + (save-excursion + (forward-line) + (should (string-equal "B" (speedbar-line-text))) + (speedbar-expand-line 'nocache)) + (save-excursion + (forward-line) + (should (string-equal "B" (speedbar-line-text))) + (speedbar-expand-line-descendants 'nocache))))) + +(provide 'speedbar-tests) +;;; speedbar-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 6f28e057342..e12e3c62e0c 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -454,7 +454,11 @@ x))) (should (= x 2))) (should (equal (macroexpand-all '(when a b c d)) - '(if a (progn b c d))))) + '(if a (progn b c d)))) + (with-suppressed-warnings ((empty-body when unless)) + (should (equal (when t) nil)) + (should (equal (unless t) nil)) + (should (equal (unless nil) nil)))) (ert-deftest subr-test-xor () "Test `xor'." diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index a4c30d64225..b05904ad017 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -504,18 +504,32 @@ (ert-deftest time-stamp-format-am-pm () "Test time-stamp formats for AM and PM strings." (with-time-stamp-test-env - (let ((pm (format-time-string "%#p" ref-time1 t)) - (am (format-time-string "%#p" ref-time3 t)) - (PM (format-time-string "%p" ref-time1 t)) - (AM (format-time-string "%p" ref-time3 t))) + (let ((pm (format-time-string "%P" ref-time1 t)) + (am (format-time-string "%P" ref-time3 t)) + (Pm (format-time-string "%p" ref-time1 t)) + (Am (format-time-string "%p" ref-time3 t)) + (PM (format-time-string "%^p" ref-time1 t)) + (AM (format-time-string "%^p" ref-time3 t))) ;; implemented and documented since 1997 (should (equal (time-stamp-string "%#p" ref-time1) pm)) (should (equal (time-stamp-string "%#p" ref-time3) am)) - (should (equal (time-stamp-string "%P" ref-time1) PM)) - (should (equal (time-stamp-string "%P" ref-time3) AM)) + (should (equal (time-stamp-string "%P" ref-time1) Pm)) + (should (equal (time-stamp-string "%P" ref-time3) Am)) + ;; implemented since 1997 + (should (equal (time-stamp-string "%^#p" ref-time1) pm)) + (should (equal (time-stamp-string "%^#p" ref-time3) am)) ;; warned 1997-2019, changed in 2019 - (should (equal (time-stamp-string "%p" ref-time1) PM)) - (should (equal (time-stamp-string "%p" ref-time3) AM))))) + (should (equal (time-stamp-string "%p" ref-time1) Pm)) + (should (equal (time-stamp-string "%p" ref-time3) Am)) + ;; changed in 2024 + (should (equal (time-stamp-string "%^p" ref-time1) PM)) + (should (equal (time-stamp-string "%^p" ref-time3) AM)) + (should (equal (time-stamp-string "%#P" ref-time1) pm)) + (should (equal (time-stamp-string "%#P" ref-time3) am)) + (should (equal (time-stamp-string "%^#P" ref-time1) pm)) + (should (equal (time-stamp-string "%^#P" ref-time3) am)) + (should (equal (time-stamp-string "%^P" ref-time1) "")) + (should (equal (time-stamp-string "%^P" ref-time3) ""))))) (ert-deftest time-stamp-format-day-number-in-week () "Test time-stamp formats for day number in week." @@ -528,14 +542,14 @@ "Test time-stamp format %Z." (with-time-stamp-test-env (let ((UTC-abbr (format-time-string "%Z" ref-time1 t)) - (utc-abbr (format-time-string "%#Z" ref-time1 t))) + (utc-abbr (format-time-string "%#Z" ref-time1 t))) ;; implemented and documented since 1995 (should (equal (time-stamp-string "%Z" ref-time1) UTC-abbr)) ;; implemented since 1997, documented since 2019 (should (equal (time-stamp-string "%#Z" ref-time1) utc-abbr))))) (ert-deftest time-stamp-format-time-zone-offset () - "Tests time-stamp legacy format %z and spot tests of new offset format %5z." + "Test time-stamp legacy format %z and spot-test new offset format %5z." (with-time-stamp-test-env (let ((utc-abbr (format-time-string "%#Z" ref-time1 t))) ;; documented 1995-2019, warned since 2019, will change @@ -596,7 +610,7 @@ (with-time-stamp-test-env (let ((May (format-time-string "%B" ref-time3 t))) ;; allowed modifiers - (should (equal (time-stamp-string "%.,@+ (stuff)B" ref-time3) May)) + (should (equal (time-stamp-string "%.,@+*EO (stuff)B" ref-time3) May)) ;; parens nest (should (equal (time-stamp-string "%(st(u)ff)B" ref-time3) May)) ;; escaped parens do not change the nesting level @@ -617,7 +631,7 @@ (should (equal (time-stamp-string "No percent" ref-time1) "No percent")))) (ert-deftest time-stamp-format-multiple-conversions () - "Tests that multiple %-conversions are independent." + "Test that multiple %-conversions are independent." (with-time-stamp-test-env (let ((Mon (format-time-string "%a" ref-time1 t)) (MON (format-time-string "%^a" ref-time1 t)) @@ -703,7 +717,7 @@ (should-not (safe-local-variable-p 'time-stamp-format '(a list))) (should (safe-local-variable-p 'time-stamp-time-zone "a string")) (should-not (safe-local-variable-p 'time-stamp-time-zone 0.5)) - (should (safe-local-variable-p 'time-stamp-line-limit 8)) + (should (safe-local-variable-p 'time-stamp-line-limit -10)) (should-not (safe-local-variable-p 'time-stamp-line-limit "a string")) (should (safe-local-variable-p 'time-stamp-start "a string")) (should-not (safe-local-variable-p 'time-stamp-start 17)) @@ -719,7 +733,7 @@ ;;;; Setup for tests of time offset formatting with %z (defun formatz (format zone) - "Uses FORMAT to format the offset of ZONE, returning the result. + "Use FORMAT to format the offset of ZONE, returning the result. FORMAT must be time format \"%z\" or some variation thereof. ZONE is as the ZONE argument of the `format-time-string' function. This function is called by 99% of the `time-stamp' \"%z\" unit tests." @@ -733,7 +747,7 @@ This function is called by 99% of the `time-stamp' \"%z\" unit tests." ))) (defun format-time-offset (format offset-secs) - "Uses FORMAT to format the time zone represented by OFFSET-SECS. + "Use FORMAT to format the time zone represented by OFFSET-SECS. FORMAT must be time format \"%z\" or some variation thereof. This function is a wrapper around `time-stamp-formatz-from-parsed-options' and is called by some low-level `time-stamp' \"%z\" unit tests." @@ -765,20 +779,20 @@ and is called by some low-level `time-stamp' \"%z\" unit tests." trailing-string))) (defun fz-make+zone (h &optional m s) - "Creates a non-negative offset." + "Create a non-negative offset." (declare (pure t)) (let ((m (or m 0)) (s (or s 0))) (+ (* 3600 h) (* 60 m) s))) (defun fz-make-zone (h &optional m s) - "Creates a negative offset. The arguments are all non-negative." + "Create a negative offset. The arguments are all non-negative." (declare (pure t)) (- (fz-make+zone h m s))) (defmacro formatz-should-equal (zone expect) - "Formats ZONE and compares it to EXPECT. -Uses the free variables `form-string' and `pattern-mod'. + "Format ZONE and compares it to EXPECT. +Use the free variables `form-string' and `pattern-mod'. The functions in `pattern-mod' are composed left to right." (declare (debug t)) `(let ((result ,expect)) @@ -790,7 +804,7 @@ The functions in `pattern-mod' are composed left to right." ;; for hours, minutes, and seconds. (defun formatz-hours-exact-helper (form-string pattern-mod) - "Tests format %z with whole hours." + "Test format %z with whole hours." (formatz-should-equal (fz-make+zone 0) "+00") ;0 sign always +, both digits (formatz-should-equal (fz-make+zone 10) "+10") (formatz-should-equal (fz-make-zone 10) "-10") @@ -801,7 +815,7 @@ The functions in `pattern-mod' are composed left to right." ) (defun formatz-nonzero-minutes-helper (form-string pattern-mod) - "Tests format %z with whole minutes." + "Test format %z with whole minutes." (formatz-should-equal (fz-make+zone 0 30) "+00:30") ;has hours even though 0 (formatz-should-equal (fz-make-zone 0 30) "-00:30") (formatz-should-equal (fz-make+zone 0 4) "+00:04") @@ -819,7 +833,7 @@ The functions in `pattern-mod' are composed left to right." ) (defun formatz-nonzero-seconds-helper (form-string pattern-mod) - "Tests format %z with non-0 seconds." + "Test format %z with non-0 seconds." ;; non-0 seconds are always included (formatz-should-equal (fz-make+zone 0 0 50) "+00:00:50") (formatz-should-equal (fz-make-zone 0 0 50) "-00:00:50") @@ -848,7 +862,7 @@ The functions in `pattern-mod' are composed left to right." ) (defun formatz-hours-big-helper (form-string pattern-mod) - "Tests format %z with hours that don't fit in two digits." + "Test format %z with hours that don't fit in two digits." (formatz-should-equal (fz-make+zone 101) "+101:00") (formatz-should-equal (fz-make+zone 123 10) "+123:10") (formatz-should-equal (fz-make-zone 123 10) "-123:10") @@ -857,7 +871,7 @@ The functions in `pattern-mod' are composed left to right." ) (defun formatz-seconds-big-helper (form-string pattern-mod) - "Tests format %z with hours greater than 99 and non-zero seconds." + "Test format %z with hours greater than 99 and non-zero seconds." (formatz-should-equal (fz-make+zone 123 0 30) "+123:00:30") (formatz-should-equal (fz-make-zone 123 0 30) "-123:00:30") (formatz-should-equal (fz-make+zone 120 0 4) "+120:00:04") @@ -868,30 +882,30 @@ The functions in `pattern-mod' are composed left to right." ;; use the above test cases for multiple formats. (defun formatz-mod-del-colons (string) - "Returns STRING with any colons removed." + "Return STRING with any colons removed." (string-replace ":" "" string)) (defun formatz-mod-add-00 (string) - "Returns STRING with \"00\" appended." + "Return STRING with \"00\" appended." (concat string "00")) (defun formatz-mod-add-colon00 (string) - "Returns STRING with \":00\" appended." + "Return STRING with \":00\" appended." (concat string ":00")) (defun formatz-mod-pad-r10 (string) - "Returns STRING padded on the right to 10 characters." + "Return STRING padded on the right to 10 characters." (concat string (make-string (- 10 (length string)) ?\s))) (defun formatz-mod-pad-r12 (string) - "Returns STRING padded on the right to 12 characters." + "Return STRING padded on the right to 12 characters." (concat string (make-string (- 12 (length string)) ?\s))) ;; Convenience macro for generating groups of test cases. (defmacro formatz-generate-tests (form-strings hour-mod mins-mod secs-mod big-mod secbig-mod) - "Defines tests for time formats FORM-STRINGS. + "Define tests for time formats FORM-STRINGS. FORM-STRINGS is a list of formats, each \"%z\" or some variation thereof. Each of the remaining arguments is an unquoted list of the form @@ -925,7 +939,7 @@ the other expected results for hours greater than 99 with non-zero seconds." ert-test-list (list `(ert-deftest ,(intern (concat "formatz-" form-string "-hhmm")) () - ,(concat "Tests time-stamp format " form-string + ,(concat "Test time-stamp format " form-string " with whole hours or minutes.") (should (equal (formatz ,form-string (fz-make+zone 0)) ,(car hour-mod))) @@ -934,13 +948,13 @@ the other expected results for hours greater than 99 with non-zero seconds." ,(car mins-mod))) (formatz-nonzero-minutes-helper ,form-string ',(cdr mins-mod))) `(ert-deftest ,(intern (concat "formatz-" form-string "-seconds")) () - ,(concat "Tests time-stamp format " form-string + ,(concat "Test time-stamp format " form-string " with offsets that have non-zero seconds.") (should (equal (formatz ,form-string (fz-make+zone 0 0 30)) ,(car secs-mod))) (formatz-nonzero-seconds-helper ,form-string ',(cdr secs-mod))) `(ert-deftest ,(intern (concat "formatz-" form-string "-threedigit")) () - ,(concat "Tests time-stamp format " form-string + ,(concat "Test time-stamp format " form-string " with offsets that are 100 hours or greater.") (should (equal (formatz ,form-string (fz-make+zone 100)) ,(car big-mod))) @@ -961,6 +975,7 @@ the other expected results for hours greater than 99 with non-zero seconds." ("+000030" formatz-mod-del-colons) ("+100:00") ("+100:00:30")) + ;; Tests that minus with padding pads with spaces. (formatz-generate-tests ("%-12z") ("+00 " formatz-mod-pad-r12) @@ -968,6 +983,7 @@ the other expected results for hours greater than 99 with non-zero seconds." ("+000030 " formatz-mod-del-colons formatz-mod-pad-r12) ("+100:00 " formatz-mod-pad-r12) ("+100:00:30 " formatz-mod-pad-r12)) + ;; Tests that 0 after other digits becomes padding of ten, not zero flag. (formatz-generate-tests ("%-10z") ("+00 " formatz-mod-pad-r10) @@ -981,7 +997,7 @@ the other expected results for hours greater than 99 with non-zero seconds." ;; The legacy exception for %z in time-stamp will need to remain ;; through at least 2024 and Emacs 28. (ert-deftest formatz-%z-spotcheck () - "Spot-checks internal implementation of time-stamp format %z." + "Spot-check internal implementation of time-stamp format %z." (should (equal (format-time-offset "%z" (fz-make+zone 0)) "+0000")) (should (equal (format-time-offset "%z" (fz-make+zone 0 30)) "+0030")) (should (equal (format-time-offset "%z" (fz-make+zone 0 0 30)) "+000030")) @@ -1104,7 +1120,7 @@ the other expected results for hours greater than 99 with non-zero seconds." ;;; Illegal %z formats (ert-deftest formatz-illegal-options () - "Tests that illegal/nonsensical/ambiguous %z formats don't produce output." + "Test that illegal/nonsensical/ambiguous %z formats don't produce output." ;; multiple options (should (equal "" (formatz "%_-z" 0))) (should (equal "" (formatz "%-_z" 0))) diff --git a/test/manual/etags/ETAGS.good_4 b/test/manual/etags/ETAGS.good_4 index afde92702bb..0cb17fbbdb2 100644 --- a/test/manual/etags/ETAGS.good_4 +++ b/test/manual/etags/ETAGS.good_4 @@ -175,7 +175,7 @@ package body Truc.Bidule Truc.Bidule/b138,2153 protected body Bidule Bidule/b139,2181 protected body Machin_T Machin_T/b146,2281 -c-src/abbrev.c,3055 +c-src/abbrev.c,3044 Lisp_Object Vabbrev_table_name_list;43,1429 Lisp_Object Vglobal_abbrev_table;48,1574 Lisp_Object Vfundamental_mode_abbrev_table;52,1685 @@ -222,17 +222,17 @@ syms_of_abbrev 534,15885 DEFVAR_PER_BUFFER ("local-abbrev-table"580,17852 DEFVAR_BOOL ("abbrevs-changed"583,17995 DEFVAR_BOOL ("abbrev-all-caps"588,18198 - DEFVAR_LISP ("abbrev-table-name-list",\1536,15905 - DEFVAR_LISP ("global-abbrev-table",\1542,16167 - DEFVAR_LISP ("fundamental-mode-abbrev-table",\1549,16489 - DEFVAR_LISP ("last-abbrev",\1555,16831 - DEFVAR_LISP ("last-abbrev-text",\1558,16954 - DEFVAR_INT ("last-abbrev-location",\1562,17112 - DEFVAR_LISP ("abbrev-start-location",\1569,17311 - DEFVAR_LISP ("abbrev-start-location-buffer",\1575,17588 - DEFVAR_PER_BUFFER ("local-abbrev-table",\1580,17852 - DEFVAR_BOOL ("abbrevs-changed",\1583,17995 - DEFVAR_BOOL ("abbrev-all-caps",\1588,18198 + DEFVAR_LISP ("abbrev-table-name-list"\1536,15905 + DEFVAR_LISP ("global-abbrev-table"\1542,16167 + DEFVAR_LISP ("fundamental-mode-abbrev-table"\1549,16489 + DEFVAR_LISP ("last-abbrev"\1555,16831 + DEFVAR_LISP ("last-abbrev-text"\1558,16954 + DEFVAR_INT ("last-abbrev-location"\1562,17112 + DEFVAR_LISP ("abbrev-start-location"\1569,17311 + DEFVAR_LISP ("abbrev-start-location-buffer"\1575,17588 + DEFVAR_PER_BUFFER ("local-abbrev-table"\1580,17852 + DEFVAR_BOOL ("abbrevs-changed"\1583,17995 + DEFVAR_BOOL ("abbrev-all-caps"\1588,18198 c-src/torture.c,197 (*tag1 tag118,452 @@ -859,7 +859,7 @@ typedef enum { RECC_ERROR 609,22954 } re_wctype_t;618,23261 typedef int re_wchar_t;623,23388 -c-src/emacs/src/keyboard.c,22931 +c-src/emacs/src/keyboard.c,22861 volatile int interrupt_input_blocked;76,1809 volatile bool pending_signals;80,1945 #define KBD_BUFFER_SIZE 82,1977 @@ -1278,76 +1278,76 @@ syms_of_keyboard 11045,333580 DEFVAR_LISP ("debug-on-event"11825,366557 keys_of_keyboard 11841,367118 mark_kboards 11916,370437 - DEFVAR_LISP ("internal--top-level-message",\111058,333975 - DEFVAR_LISP ("last-command-event",\111312,342176 - DEFVAR_LISP ("last-nonmenu-event",\111315,342300 - DEFVAR_LISP ("last-input-event",\111321,342639 - DEFVAR_LISP ("unread-command-events",\111324,342733 - DEFVAR_LISP ("unread-post-input-method-events",\111332,343193 - DEFVAR_LISP ("unread-input-method-events",\111338,343532 - DEFVAR_LISP ("meta-prefix-char",\111346,343901 - DEFVAR_KBOARD ("last-command",\111351,344109 - DEFVAR_KBOARD ("real-last-command",\111368,344790 - DEFVAR_KBOARD ("last-repeatable-command",\111372,344976 - DEFVAR_LISP ("this-command",\111378,345264 - DEFVAR_LISP ("real-this-command",\111384,345501 - DEFVAR_LISP ("this-command-keys-shift-translated",\111388,345683 - DEFVAR_LISP ("this-original-command",\111396,346126 - DEFVAR_INT ("auto-save-interval",\111403,346523 - DEFVAR_LISP ("auto-save-timeout",\111408,346737 - DEFVAR_LISP ("echo-keystrokes",\111415,347082 - DEFVAR_INT ("polling-period",\111421,347353 - DEFVAR_LISP ("double-click-time",\111428,347696 - DEFVAR_INT ("double-click-fuzz",\111435,348032 - DEFVAR_INT ("num-input-keys",\111446,348522 - DEFVAR_INT ("num-nonmacro-input-events",\111452,348797 - DEFVAR_LISP ("last-event-frame",\111457,349035 - DEFVAR_LISP ("tty-erase-char",\111463,349314 - DEFVAR_LISP ("help-char",\111466,349437 - DEFVAR_LISP ("help-event-list",\111472,349720 - DEFVAR_LISP ("help-form",\111477,349931 - DEFVAR_LISP ("prefix-help-command",\111483,350179 - DEFVAR_LISP ("top-level",\111489,350457 - DEFVAR_KBOARD ("keyboard-translate-table",\111495,350678 - DEFVAR_BOOL ("cannot-suspend",\111511,351491 - DEFVAR_BOOL ("menu-prompting",\111516,351718 - DEFVAR_LISP ("menu-prompt-more-char",\111526,352148 - DEFVAR_INT ("extra-keyboard-modifiers",\111531,352394 - DEFVAR_LISP ("deactivate-mark",\111545,353120 - DEFVAR_LISP ("pre-command-hook",\111553,353489 - DEFVAR_LISP ("post-command-hook",\111560,353844 - DEFVAR_LISP ("echo-area-clear-hook",\111568,354207 - DEFVAR_LISP ("lucid-menu-bar-dirty-flag",\111574,354422 - DEFVAR_LISP ("menu-bar-final-items",\111578,354625 - DEFVAR_LISP ("tool-bar-separator-image-expression",\111583,354875 - DEFVAR_KBOARD ("overriding-terminal-local-map",\111589,355233 - DEFVAR_LISP ("overriding-local-map",\111598,355655 - DEFVAR_LISP ("overriding-local-map-menu-flag",\111607,356106 - DEFVAR_LISP ("special-event-map",\111613,356445 - DEFVAR_LISP ("track-mouse",\111617,356633 - DEFVAR_KBOARD ("system-key-alist",\111620,356760 - DEFVAR_KBOARD ("local-function-key-map",\111629,357141 - DEFVAR_KBOARD ("input-decode-map",\111658,358600 - DEFVAR_LISP ("function-key-map",\111675,359388 - DEFVAR_LISP ("key-translation-map",\111683,359804 - DEFVAR_LISP ("deferred-action-list",\111689,360148 - DEFVAR_LISP ("deferred-action-function",\111694,360396 - DEFVAR_LISP ("delayed-warnings-list",\111700,360695 - DEFVAR_LISP ("timer-list",\111708,361103 - DEFVAR_LISP ("timer-idle-list",\111712,361255 - DEFVAR_LISP ("input-method-function",\111716,361418 - DEFVAR_LISP ("input-method-previous-message",\111737,362387 - DEFVAR_LISP ("show-help-function",\111744,362748 - DEFVAR_LISP ("disable-point-adjustment",\111749,362980 - DEFVAR_LISP ("global-disable-point-adjustment",\111761,363530 - DEFVAR_LISP ("minibuffer-message-timeout",\111770,363896 - DEFVAR_LISP ("throw-on-input",\111775,364174 - DEFVAR_LISP ("command-error-function",\111781,364425 - DEFVAR_LISP ("enable-disabled-menus-and-buttons",\111790,364912 - DEFVAR_LISP ("select-active-regions",\111798,365239 - DEFVAR_LISP ("saved-region-selection",\111807,365631 - DEFVAR_LISP ("selection-inhibit-update-commands",\111815,366016 - DEFVAR_LISP ("debug-on-event",\111825,366557 + DEFVAR_LISP ("internal--top-level-message"\111058,333975 + DEFVAR_LISP ("last-command-event"\111312,342176 + DEFVAR_LISP ("last-nonmenu-event"\111315,342300 + DEFVAR_LISP ("last-input-event"\111321,342639 + DEFVAR_LISP ("unread-command-events"\111324,342733 + DEFVAR_LISP ("unread-post-input-method-events"\111332,343193 + DEFVAR_LISP ("unread-input-method-events"\111338,343532 + DEFVAR_LISP ("meta-prefix-char"\111346,343901 + DEFVAR_KBOARD ("last-command"\111351,344109 + DEFVAR_KBOARD ("real-last-command"\111368,344790 + DEFVAR_KBOARD ("last-repeatable-command"\111372,344976 + DEFVAR_LISP ("this-command"\111378,345264 + DEFVAR_LISP ("real-this-command"\111384,345501 + DEFVAR_LISP ("this-command-keys-shift-translated"\111388,345683 + DEFVAR_LISP ("this-original-command"\111396,346126 + DEFVAR_INT ("auto-save-interval"\111403,346523 + DEFVAR_LISP ("auto-save-timeout"\111408,346737 + DEFVAR_LISP ("echo-keystrokes"\111415,347082 + DEFVAR_INT ("polling-period"\111421,347353 + DEFVAR_LISP ("double-click-time"\111428,347696 + DEFVAR_INT ("double-click-fuzz"\111435,348032 + DEFVAR_INT ("num-input-keys"\111446,348522 + DEFVAR_INT ("num-nonmacro-input-events"\111452,348797 + DEFVAR_LISP ("last-event-frame"\111457,349035 + DEFVAR_LISP ("tty-erase-char"\111463,349314 + DEFVAR_LISP ("help-char"\111466,349437 + DEFVAR_LISP ("help-event-list"\111472,349720 + DEFVAR_LISP ("help-form"\111477,349931 + DEFVAR_LISP ("prefix-help-command"\111483,350179 + DEFVAR_LISP ("top-level"\111489,350457 + DEFVAR_KBOARD ("keyboard-translate-table"\111495,350678 + DEFVAR_BOOL ("cannot-suspend"\111511,351491 + DEFVAR_BOOL ("menu-prompting"\111516,351718 + DEFVAR_LISP ("menu-prompt-more-char"\111526,352148 + DEFVAR_INT ("extra-keyboard-modifiers"\111531,352394 + DEFVAR_LISP ("deactivate-mark"\111545,353120 + DEFVAR_LISP ("pre-command-hook"\111553,353489 + DEFVAR_LISP ("post-command-hook"\111560,353844 + DEFVAR_LISP ("echo-area-clear-hook"\111568,354207 + DEFVAR_LISP ("lucid-menu-bar-dirty-flag"\111574,354422 + DEFVAR_LISP ("menu-bar-final-items"\111578,354625 + DEFVAR_LISP ("tool-bar-separator-image-expression"\111583,354875 + DEFVAR_KBOARD ("overriding-terminal-local-map"\111589,355233 + DEFVAR_LISP ("overriding-local-map"\111598,355655 + DEFVAR_LISP ("overriding-local-map-menu-flag"\111607,356106 + DEFVAR_LISP ("special-event-map"\111613,356445 + DEFVAR_LISP ("track-mouse"\111617,356633 + DEFVAR_KBOARD ("system-key-alist"\111620,356760 + DEFVAR_KBOARD ("local-function-key-map"\111629,357141 + DEFVAR_KBOARD ("input-decode-map"\111658,358600 + DEFVAR_LISP ("function-key-map"\111675,359388 + DEFVAR_LISP ("key-translation-map"\111683,359804 + DEFVAR_LISP ("deferred-action-list"\111689,360148 + DEFVAR_LISP ("deferred-action-function"\111694,360396 + DEFVAR_LISP ("delayed-warnings-list"\111700,360695 + DEFVAR_LISP ("timer-list"\111708,361103 + DEFVAR_LISP ("timer-idle-list"\111712,361255 + DEFVAR_LISP ("input-method-function"\111716,361418 + DEFVAR_LISP ("input-method-previous-message"\111737,362387 + DEFVAR_LISP ("show-help-function"\111744,362748 + DEFVAR_LISP ("disable-point-adjustment"\111749,362980 + DEFVAR_LISP ("global-disable-point-adjustment"\111761,363530 + DEFVAR_LISP ("minibuffer-message-timeout"\111770,363896 + DEFVAR_LISP ("throw-on-input"\111775,364174 + DEFVAR_LISP ("command-error-function"\111781,364425 + DEFVAR_LISP ("enable-disabled-menus-and-buttons"\111790,364912 + DEFVAR_LISP ("select-active-regions"\111798,365239 + DEFVAR_LISP ("saved-region-selection"\111807,365631 + DEFVAR_LISP ("selection-inhibit-update-commands"\111815,366016 + DEFVAR_LISP ("debug-on-event"\111825,366557 c-src/emacs/src/lisp.h,20276 #define EMACS_LISP_H22,801 diff --git a/test/manual/etags/ETAGS.good_5 b/test/manual/etags/ETAGS.good_5 index 26385943f2d..42f30f2fe19 100644 --- a/test/manual/etags/ETAGS.good_5 +++ b/test/manual/etags/ETAGS.good_5 @@ -175,7 +175,7 @@ package body Truc.Bidule Truc.Bidule/b138,2153 protected body Bidule Bidule/b139,2181 protected body Machin_T Machin_T/b146,2281 -c-src/abbrev.c,3055 +c-src/abbrev.c,3044 Lisp_Object Vabbrev_table_name_list;43,1429 Lisp_Object Vglobal_abbrev_table;48,1574 Lisp_Object Vfundamental_mode_abbrev_table;52,1685 @@ -222,17 +222,17 @@ syms_of_abbrev 534,15885 DEFVAR_PER_BUFFER ("local-abbrev-table"580,17852 DEFVAR_BOOL ("abbrevs-changed"583,17995 DEFVAR_BOOL ("abbrev-all-caps"588,18198 - DEFVAR_LISP ("abbrev-table-name-list",\1536,15905 - DEFVAR_LISP ("global-abbrev-table",\1542,16167 - DEFVAR_LISP ("fundamental-mode-abbrev-table",\1549,16489 - DEFVAR_LISP ("last-abbrev",\1555,16831 - DEFVAR_LISP ("last-abbrev-text",\1558,16954 - DEFVAR_INT ("last-abbrev-location",\1562,17112 - DEFVAR_LISP ("abbrev-start-location",\1569,17311 - DEFVAR_LISP ("abbrev-start-location-buffer",\1575,17588 - DEFVAR_PER_BUFFER ("local-abbrev-table",\1580,17852 - DEFVAR_BOOL ("abbrevs-changed",\1583,17995 - DEFVAR_BOOL ("abbrev-all-caps",\1588,18198 + DEFVAR_LISP ("abbrev-table-name-list"\1536,15905 + DEFVAR_LISP ("global-abbrev-table"\1542,16167 + DEFVAR_LISP ("fundamental-mode-abbrev-table"\1549,16489 + DEFVAR_LISP ("last-abbrev"\1555,16831 + DEFVAR_LISP ("last-abbrev-text"\1558,16954 + DEFVAR_INT ("last-abbrev-location"\1562,17112 + DEFVAR_LISP ("abbrev-start-location"\1569,17311 + DEFVAR_LISP ("abbrev-start-location-buffer"\1575,17588 + DEFVAR_PER_BUFFER ("local-abbrev-table"\1580,17852 + DEFVAR_BOOL ("abbrevs-changed"\1583,17995 + DEFVAR_BOOL ("abbrev-all-caps"\1588,18198 c-src/torture.c,197 (*tag1 tag118,452 @@ -1125,7 +1125,7 @@ extern re_wctype_t re_wctype 621,23330 typedef int re_wchar_t;623,23388 extern void re_set_whitespace_regexp 625,23413 -c-src/emacs/src/keyboard.c,25243 +c-src/emacs/src/keyboard.c,25173 volatile int interrupt_input_blocked;76,1809 volatile bool pending_signals;80,1945 #define KBD_BUFFER_SIZE 82,1977 @@ -1598,76 +1598,76 @@ syms_of_keyboard 11045,333580 DEFVAR_LISP ("debug-on-event"11825,366557 keys_of_keyboard 11841,367118 mark_kboards 11916,370437 - DEFVAR_LISP ("internal--top-level-message",\111058,333975 - DEFVAR_LISP ("last-command-event",\111312,342176 - DEFVAR_LISP ("last-nonmenu-event",\111315,342300 - DEFVAR_LISP ("last-input-event",\111321,342639 - DEFVAR_LISP ("unread-command-events",\111324,342733 - DEFVAR_LISP ("unread-post-input-method-events",\111332,343193 - DEFVAR_LISP ("unread-input-method-events",\111338,343532 - DEFVAR_LISP ("meta-prefix-char",\111346,343901 - DEFVAR_KBOARD ("last-command",\111351,344109 - DEFVAR_KBOARD ("real-last-command",\111368,344790 - DEFVAR_KBOARD ("last-repeatable-command",\111372,344976 - DEFVAR_LISP ("this-command",\111378,345264 - DEFVAR_LISP ("real-this-command",\111384,345501 - DEFVAR_LISP ("this-command-keys-shift-translated",\111388,345683 - DEFVAR_LISP ("this-original-command",\111396,346126 - DEFVAR_INT ("auto-save-interval",\111403,346523 - DEFVAR_LISP ("auto-save-timeout",\111408,346737 - DEFVAR_LISP ("echo-keystrokes",\111415,347082 - DEFVAR_INT ("polling-period",\111421,347353 - DEFVAR_LISP ("double-click-time",\111428,347696 - DEFVAR_INT ("double-click-fuzz",\111435,348032 - DEFVAR_INT ("num-input-keys",\111446,348522 - DEFVAR_INT ("num-nonmacro-input-events",\111452,348797 - DEFVAR_LISP ("last-event-frame",\111457,349035 - DEFVAR_LISP ("tty-erase-char",\111463,349314 - DEFVAR_LISP ("help-char",\111466,349437 - DEFVAR_LISP ("help-event-list",\111472,349720 - DEFVAR_LISP ("help-form",\111477,349931 - DEFVAR_LISP ("prefix-help-command",\111483,350179 - DEFVAR_LISP ("top-level",\111489,350457 - DEFVAR_KBOARD ("keyboard-translate-table",\111495,350678 - DEFVAR_BOOL ("cannot-suspend",\111511,351491 - DEFVAR_BOOL ("menu-prompting",\111516,351718 - DEFVAR_LISP ("menu-prompt-more-char",\111526,352148 - DEFVAR_INT ("extra-keyboard-modifiers",\111531,352394 - DEFVAR_LISP ("deactivate-mark",\111545,353120 - DEFVAR_LISP ("pre-command-hook",\111553,353489 - DEFVAR_LISP ("post-command-hook",\111560,353844 - DEFVAR_LISP ("echo-area-clear-hook",\111568,354207 - DEFVAR_LISP ("lucid-menu-bar-dirty-flag",\111574,354422 - DEFVAR_LISP ("menu-bar-final-items",\111578,354625 - DEFVAR_LISP ("tool-bar-separator-image-expression",\111583,354875 - DEFVAR_KBOARD ("overriding-terminal-local-map",\111589,355233 - DEFVAR_LISP ("overriding-local-map",\111598,355655 - DEFVAR_LISP ("overriding-local-map-menu-flag",\111607,356106 - DEFVAR_LISP ("special-event-map",\111613,356445 - DEFVAR_LISP ("track-mouse",\111617,356633 - DEFVAR_KBOARD ("system-key-alist",\111620,356760 - DEFVAR_KBOARD ("local-function-key-map",\111629,357141 - DEFVAR_KBOARD ("input-decode-map",\111658,358600 - DEFVAR_LISP ("function-key-map",\111675,359388 - DEFVAR_LISP ("key-translation-map",\111683,359804 - DEFVAR_LISP ("deferred-action-list",\111689,360148 - DEFVAR_LISP ("deferred-action-function",\111694,360396 - DEFVAR_LISP ("delayed-warnings-list",\111700,360695 - DEFVAR_LISP ("timer-list",\111708,361103 - DEFVAR_LISP ("timer-idle-list",\111712,361255 - DEFVAR_LISP ("input-method-function",\111716,361418 - DEFVAR_LISP ("input-method-previous-message",\111737,362387 - DEFVAR_LISP ("show-help-function",\111744,362748 - DEFVAR_LISP ("disable-point-adjustment",\111749,362980 - DEFVAR_LISP ("global-disable-point-adjustment",\111761,363530 - DEFVAR_LISP ("minibuffer-message-timeout",\111770,363896 - DEFVAR_LISP ("throw-on-input",\111775,364174 - DEFVAR_LISP ("command-error-function",\111781,364425 - DEFVAR_LISP ("enable-disabled-menus-and-buttons",\111790,364912 - DEFVAR_LISP ("select-active-regions",\111798,365239 - DEFVAR_LISP ("saved-region-selection",\111807,365631 - DEFVAR_LISP ("selection-inhibit-update-commands",\111815,366016 - DEFVAR_LISP ("debug-on-event",\111825,366557 + DEFVAR_LISP ("internal--top-level-message"\111058,333975 + DEFVAR_LISP ("last-command-event"\111312,342176 + DEFVAR_LISP ("last-nonmenu-event"\111315,342300 + DEFVAR_LISP ("last-input-event"\111321,342639 + DEFVAR_LISP ("unread-command-events"\111324,342733 + DEFVAR_LISP ("unread-post-input-method-events"\111332,343193 + DEFVAR_LISP ("unread-input-method-events"\111338,343532 + DEFVAR_LISP ("meta-prefix-char"\111346,343901 + DEFVAR_KBOARD ("last-command"\111351,344109 + DEFVAR_KBOARD ("real-last-command"\111368,344790 + DEFVAR_KBOARD ("last-repeatable-command"\111372,344976 + DEFVAR_LISP ("this-command"\111378,345264 + DEFVAR_LISP ("real-this-command"\111384,345501 + DEFVAR_LISP ("this-command-keys-shift-translated"\111388,345683 + DEFVAR_LISP ("this-original-command"\111396,346126 + DEFVAR_INT ("auto-save-interval"\111403,346523 + DEFVAR_LISP ("auto-save-timeout"\111408,346737 + DEFVAR_LISP ("echo-keystrokes"\111415,347082 + DEFVAR_INT ("polling-period"\111421,347353 + DEFVAR_LISP ("double-click-time"\111428,347696 + DEFVAR_INT ("double-click-fuzz"\111435,348032 + DEFVAR_INT ("num-input-keys"\111446,348522 + DEFVAR_INT ("num-nonmacro-input-events"\111452,348797 + DEFVAR_LISP ("last-event-frame"\111457,349035 + DEFVAR_LISP ("tty-erase-char"\111463,349314 + DEFVAR_LISP ("help-char"\111466,349437 + DEFVAR_LISP ("help-event-list"\111472,349720 + DEFVAR_LISP ("help-form"\111477,349931 + DEFVAR_LISP ("prefix-help-command"\111483,350179 + DEFVAR_LISP ("top-level"\111489,350457 + DEFVAR_KBOARD ("keyboard-translate-table"\111495,350678 + DEFVAR_BOOL ("cannot-suspend"\111511,351491 + DEFVAR_BOOL ("menu-prompting"\111516,351718 + DEFVAR_LISP ("menu-prompt-more-char"\111526,352148 + DEFVAR_INT ("extra-keyboard-modifiers"\111531,352394 + DEFVAR_LISP ("deactivate-mark"\111545,353120 + DEFVAR_LISP ("pre-command-hook"\111553,353489 + DEFVAR_LISP ("post-command-hook"\111560,353844 + DEFVAR_LISP ("echo-area-clear-hook"\111568,354207 + DEFVAR_LISP ("lucid-menu-bar-dirty-flag"\111574,354422 + DEFVAR_LISP ("menu-bar-final-items"\111578,354625 + DEFVAR_LISP ("tool-bar-separator-image-expression"\111583,354875 + DEFVAR_KBOARD ("overriding-terminal-local-map"\111589,355233 + DEFVAR_LISP ("overriding-local-map"\111598,355655 + DEFVAR_LISP ("overriding-local-map-menu-flag"\111607,356106 + DEFVAR_LISP ("special-event-map"\111613,356445 + DEFVAR_LISP ("track-mouse"\111617,356633 + DEFVAR_KBOARD ("system-key-alist"\111620,356760 + DEFVAR_KBOARD ("local-function-key-map"\111629,357141 + DEFVAR_KBOARD ("input-decode-map"\111658,358600 + DEFVAR_LISP ("function-key-map"\111675,359388 + DEFVAR_LISP ("key-translation-map"\111683,359804 + DEFVAR_LISP ("deferred-action-list"\111689,360148 + DEFVAR_LISP ("deferred-action-function"\111694,360396 + DEFVAR_LISP ("delayed-warnings-list"\111700,360695 + DEFVAR_LISP ("timer-list"\111708,361103 + DEFVAR_LISP ("timer-idle-list"\111712,361255 + DEFVAR_LISP ("input-method-function"\111716,361418 + DEFVAR_LISP ("input-method-previous-message"\111737,362387 + DEFVAR_LISP ("show-help-function"\111744,362748 + DEFVAR_LISP ("disable-point-adjustment"\111749,362980 + DEFVAR_LISP ("global-disable-point-adjustment"\111761,363530 + DEFVAR_LISP ("minibuffer-message-timeout"\111770,363896 + DEFVAR_LISP ("throw-on-input"\111775,364174 + DEFVAR_LISP ("command-error-function"\111781,364425 + DEFVAR_LISP ("enable-disabled-menus-and-buttons"\111790,364912 + DEFVAR_LISP ("select-active-regions"\111798,365239 + DEFVAR_LISP ("saved-region-selection"\111807,365631 + DEFVAR_LISP ("selection-inhibit-update-commands"\111815,366016 + DEFVAR_LISP ("debug-on-event"\111825,366557 c-src/emacs/src/lisp.h,41391 #define EMACS_LISP_H22,801 diff --git a/test/manual/etags/ETAGS.good_6 b/test/manual/etags/ETAGS.good_6 index 35265f606c2..e6c83fc9140 100644 --- a/test/manual/etags/ETAGS.good_6 +++ b/test/manual/etags/ETAGS.good_6 @@ -175,7 +175,7 @@ package body Truc.Bidule Truc.Bidule/b138,2153 protected body Bidule Bidule/b139,2181 protected body Machin_T Machin_T/b146,2281 -c-src/abbrev.c,3055 +c-src/abbrev.c,3044 Lisp_Object Vabbrev_table_name_list;43,1429 Lisp_Object Vglobal_abbrev_table;48,1574 Lisp_Object Vfundamental_mode_abbrev_table;52,1685 @@ -222,17 +222,17 @@ syms_of_abbrev 534,15885 DEFVAR_PER_BUFFER ("local-abbrev-table"580,17852 DEFVAR_BOOL ("abbrevs-changed"583,17995 DEFVAR_BOOL ("abbrev-all-caps"588,18198 - DEFVAR_LISP ("abbrev-table-name-list",\1536,15905 - DEFVAR_LISP ("global-abbrev-table",\1542,16167 - DEFVAR_LISP ("fundamental-mode-abbrev-table",\1549,16489 - DEFVAR_LISP ("last-abbrev",\1555,16831 - DEFVAR_LISP ("last-abbrev-text",\1558,16954 - DEFVAR_INT ("last-abbrev-location",\1562,17112 - DEFVAR_LISP ("abbrev-start-location",\1569,17311 - DEFVAR_LISP ("abbrev-start-location-buffer",\1575,17588 - DEFVAR_PER_BUFFER ("local-abbrev-table",\1580,17852 - DEFVAR_BOOL ("abbrevs-changed",\1583,17995 - DEFVAR_BOOL ("abbrev-all-caps",\1588,18198 + DEFVAR_LISP ("abbrev-table-name-list"\1536,15905 + DEFVAR_LISP ("global-abbrev-table"\1542,16167 + DEFVAR_LISP ("fundamental-mode-abbrev-table"\1549,16489 + DEFVAR_LISP ("last-abbrev"\1555,16831 + DEFVAR_LISP ("last-abbrev-text"\1558,16954 + DEFVAR_INT ("last-abbrev-location"\1562,17112 + DEFVAR_LISP ("abbrev-start-location"\1569,17311 + DEFVAR_LISP ("abbrev-start-location-buffer"\1575,17588 + DEFVAR_PER_BUFFER ("local-abbrev-table"\1580,17852 + DEFVAR_BOOL ("abbrevs-changed"\1583,17995 + DEFVAR_BOOL ("abbrev-all-caps"\1588,18198 c-src/torture.c,197 (*tag1 tag118,452 @@ -1125,7 +1125,7 @@ extern re_wctype_t re_wctype 621,23330 typedef int re_wchar_t;623,23388 extern void re_set_whitespace_regexp 625,23413 -c-src/emacs/src/keyboard.c,25243 +c-src/emacs/src/keyboard.c,25173 volatile int interrupt_input_blocked;76,1809 volatile bool pending_signals;80,1945 #define KBD_BUFFER_SIZE 82,1977 @@ -1598,76 +1598,76 @@ syms_of_keyboard 11045,333580 DEFVAR_LISP ("debug-on-event"11825,366557 keys_of_keyboard 11841,367118 mark_kboards 11916,370437 - DEFVAR_LISP ("internal--top-level-message",\111058,333975 - DEFVAR_LISP ("last-command-event",\111312,342176 - DEFVAR_LISP ("last-nonmenu-event",\111315,342300 - DEFVAR_LISP ("last-input-event",\111321,342639 - DEFVAR_LISP ("unread-command-events",\111324,342733 - DEFVAR_LISP ("unread-post-input-method-events",\111332,343193 - DEFVAR_LISP ("unread-input-method-events",\111338,343532 - DEFVAR_LISP ("meta-prefix-char",\111346,343901 - DEFVAR_KBOARD ("last-command",\111351,344109 - DEFVAR_KBOARD ("real-last-command",\111368,344790 - DEFVAR_KBOARD ("last-repeatable-command",\111372,344976 - DEFVAR_LISP ("this-command",\111378,345264 - DEFVAR_LISP ("real-this-command",\111384,345501 - DEFVAR_LISP ("this-command-keys-shift-translated",\111388,345683 - DEFVAR_LISP ("this-original-command",\111396,346126 - DEFVAR_INT ("auto-save-interval",\111403,346523 - DEFVAR_LISP ("auto-save-timeout",\111408,346737 - DEFVAR_LISP ("echo-keystrokes",\111415,347082 - DEFVAR_INT ("polling-period",\111421,347353 - DEFVAR_LISP ("double-click-time",\111428,347696 - DEFVAR_INT ("double-click-fuzz",\111435,348032 - DEFVAR_INT ("num-input-keys",\111446,348522 - DEFVAR_INT ("num-nonmacro-input-events",\111452,348797 - DEFVAR_LISP ("last-event-frame",\111457,349035 - DEFVAR_LISP ("tty-erase-char",\111463,349314 - DEFVAR_LISP ("help-char",\111466,349437 - DEFVAR_LISP ("help-event-list",\111472,349720 - DEFVAR_LISP ("help-form",\111477,349931 - DEFVAR_LISP ("prefix-help-command",\111483,350179 - DEFVAR_LISP ("top-level",\111489,350457 - DEFVAR_KBOARD ("keyboard-translate-table",\111495,350678 - DEFVAR_BOOL ("cannot-suspend",\111511,351491 - DEFVAR_BOOL ("menu-prompting",\111516,351718 - DEFVAR_LISP ("menu-prompt-more-char",\111526,352148 - DEFVAR_INT ("extra-keyboard-modifiers",\111531,352394 - DEFVAR_LISP ("deactivate-mark",\111545,353120 - DEFVAR_LISP ("pre-command-hook",\111553,353489 - DEFVAR_LISP ("post-command-hook",\111560,353844 - DEFVAR_LISP ("echo-area-clear-hook",\111568,354207 - DEFVAR_LISP ("lucid-menu-bar-dirty-flag",\111574,354422 - DEFVAR_LISP ("menu-bar-final-items",\111578,354625 - DEFVAR_LISP ("tool-bar-separator-image-expression",\111583,354875 - DEFVAR_KBOARD ("overriding-terminal-local-map",\111589,355233 - DEFVAR_LISP ("overriding-local-map",\111598,355655 - DEFVAR_LISP ("overriding-local-map-menu-flag",\111607,356106 - DEFVAR_LISP ("special-event-map",\111613,356445 - DEFVAR_LISP ("track-mouse",\111617,356633 - DEFVAR_KBOARD ("system-key-alist",\111620,356760 - DEFVAR_KBOARD ("local-function-key-map",\111629,357141 - DEFVAR_KBOARD ("input-decode-map",\111658,358600 - DEFVAR_LISP ("function-key-map",\111675,359388 - DEFVAR_LISP ("key-translation-map",\111683,359804 - DEFVAR_LISP ("deferred-action-list",\111689,360148 - DEFVAR_LISP ("deferred-action-function",\111694,360396 - DEFVAR_LISP ("delayed-warnings-list",\111700,360695 - DEFVAR_LISP ("timer-list",\111708,361103 - DEFVAR_LISP ("timer-idle-list",\111712,361255 - DEFVAR_LISP ("input-method-function",\111716,361418 - DEFVAR_LISP ("input-method-previous-message",\111737,362387 - DEFVAR_LISP ("show-help-function",\111744,362748 - DEFVAR_LISP ("disable-point-adjustment",\111749,362980 - DEFVAR_LISP ("global-disable-point-adjustment",\111761,363530 - DEFVAR_LISP ("minibuffer-message-timeout",\111770,363896 - DEFVAR_LISP ("throw-on-input",\111775,364174 - DEFVAR_LISP ("command-error-function",\111781,364425 - DEFVAR_LISP ("enable-disabled-menus-and-buttons",\111790,364912 - DEFVAR_LISP ("select-active-regions",\111798,365239 - DEFVAR_LISP ("saved-region-selection",\111807,365631 - DEFVAR_LISP ("selection-inhibit-update-commands",\111815,366016 - DEFVAR_LISP ("debug-on-event",\111825,366557 + DEFVAR_LISP ("internal--top-level-message"\111058,333975 + DEFVAR_LISP ("last-command-event"\111312,342176 + DEFVAR_LISP ("last-nonmenu-event"\111315,342300 + DEFVAR_LISP ("last-input-event"\111321,342639 + DEFVAR_LISP ("unread-command-events"\111324,342733 + DEFVAR_LISP ("unread-post-input-method-events"\111332,343193 + DEFVAR_LISP ("unread-input-method-events"\111338,343532 + DEFVAR_LISP ("meta-prefix-char"\111346,343901 + DEFVAR_KBOARD ("last-command"\111351,344109 + DEFVAR_KBOARD ("real-last-command"\111368,344790 + DEFVAR_KBOARD ("last-repeatable-command"\111372,344976 + DEFVAR_LISP ("this-command"\111378,345264 + DEFVAR_LISP ("real-this-command"\111384,345501 + DEFVAR_LISP ("this-command-keys-shift-translated"\111388,345683 + DEFVAR_LISP ("this-original-command"\111396,346126 + DEFVAR_INT ("auto-save-interval"\111403,346523 + DEFVAR_LISP ("auto-save-timeout"\111408,346737 + DEFVAR_LISP ("echo-keystrokes"\111415,347082 + DEFVAR_INT ("polling-period"\111421,347353 + DEFVAR_LISP ("double-click-time"\111428,347696 + DEFVAR_INT ("double-click-fuzz"\111435,348032 + DEFVAR_INT ("num-input-keys"\111446,348522 + DEFVAR_INT ("num-nonmacro-input-events"\111452,348797 + DEFVAR_LISP ("last-event-frame"\111457,349035 + DEFVAR_LISP ("tty-erase-char"\111463,349314 + DEFVAR_LISP ("help-char"\111466,349437 + DEFVAR_LISP ("help-event-list"\111472,349720 + DEFVAR_LISP ("help-form"\111477,349931 + DEFVAR_LISP ("prefix-help-command"\111483,350179 + DEFVAR_LISP ("top-level"\111489,350457 + DEFVAR_KBOARD ("keyboard-translate-table"\111495,350678 + DEFVAR_BOOL ("cannot-suspend"\111511,351491 + DEFVAR_BOOL ("menu-prompting"\111516,351718 + DEFVAR_LISP ("menu-prompt-more-char"\111526,352148 + DEFVAR_INT ("extra-keyboard-modifiers"\111531,352394 + DEFVAR_LISP ("deactivate-mark"\111545,353120 + DEFVAR_LISP ("pre-command-hook"\111553,353489 + DEFVAR_LISP ("post-command-hook"\111560,353844 + DEFVAR_LISP ("echo-area-clear-hook"\111568,354207 + DEFVAR_LISP ("lucid-menu-bar-dirty-flag"\111574,354422 + DEFVAR_LISP ("menu-bar-final-items"\111578,354625 + DEFVAR_LISP ("tool-bar-separator-image-expression"\111583,354875 + DEFVAR_KBOARD ("overriding-terminal-local-map"\111589,355233 + DEFVAR_LISP ("overriding-local-map"\111598,355655 + DEFVAR_LISP ("overriding-local-map-menu-flag"\111607,356106 + DEFVAR_LISP ("special-event-map"\111613,356445 + DEFVAR_LISP ("track-mouse"\111617,356633 + DEFVAR_KBOARD ("system-key-alist"\111620,356760 + DEFVAR_KBOARD ("local-function-key-map"\111629,357141 + DEFVAR_KBOARD ("input-decode-map"\111658,358600 + DEFVAR_LISP ("function-key-map"\111675,359388 + DEFVAR_LISP ("key-translation-map"\111683,359804 + DEFVAR_LISP ("deferred-action-list"\111689,360148 + DEFVAR_LISP ("deferred-action-function"\111694,360396 + DEFVAR_LISP ("delayed-warnings-list"\111700,360695 + DEFVAR_LISP ("timer-list"\111708,361103 + DEFVAR_LISP ("timer-idle-list"\111712,361255 + DEFVAR_LISP ("input-method-function"\111716,361418 + DEFVAR_LISP ("input-method-previous-message"\111737,362387 + DEFVAR_LISP ("show-help-function"\111744,362748 + DEFVAR_LISP ("disable-point-adjustment"\111749,362980 + DEFVAR_LISP ("global-disable-point-adjustment"\111761,363530 + DEFVAR_LISP ("minibuffer-message-timeout"\111770,363896 + DEFVAR_LISP ("throw-on-input"\111775,364174 + DEFVAR_LISP ("command-error-function"\111781,364425 + DEFVAR_LISP ("enable-disabled-menus-and-buttons"\111790,364912 + DEFVAR_LISP ("select-active-regions"\111798,365239 + DEFVAR_LISP ("saved-region-selection"\111807,365631 + DEFVAR_LISP ("selection-inhibit-update-commands"\111815,366016 + DEFVAR_LISP ("debug-on-event"\111825,366557 c-src/emacs/src/lisp.h,41391 #define EMACS_LISP_H22,801 diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el index 19c3793b93d..06b0b00862b 100644 --- a/test/src/emacs-tests.el +++ b/test/src/emacs-tests.el @@ -221,7 +221,7 @@ which the process was running." (terpri) (princ (buffer-substring-no-properties (point-min) (point-max))) ;; Search audit logs for Seccomp messages. - (when-let ((ausearch (executable-find "ausearch"))) + (when-let* ((ausearch (executable-find "ausearch"))) (terpri) (princ "Potentially relevant Seccomp audit events:") (terpri) @@ -236,7 +236,7 @@ which the process was running." (format-time-string "%T" end-time) "--interpret"))) ;; Print coredump information if available. - (when-let ((coredumpctl (executable-find "coredumpctl"))) + (when-let* ((coredumpctl (executable-find "coredumpctl"))) (terpri) (princ "Potentially useful coredump information:") (terpri) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 862416a49a9..98bdbbd42ee 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -946,8 +946,8 @@ COMMAND must be a list returned by (defun process-tests--emacs-command () "Return a command to reinvoke the current Emacs instance. Return nil if that doesn't appear to be possible." - (when-let ((binary (process-tests--emacs-binary)) - (dump (process-tests--dump-file))) + (when-let* ((binary (process-tests--emacs-binary)) + (dump (process-tests--dump-file))) (cons binary (unless (eq dump :not-needed) (list (concat "--dump-file=" @@ -962,18 +962,18 @@ Return nil if that can't be determined." (stringp invocation-directory) (not (file-remote-p invocation-directory)) (file-name-absolute-p invocation-directory) - (when-let ((file (process-tests--usable-file-for-reinvoke - (expand-file-name invocation-name - invocation-directory)))) + (when-let* ((file (process-tests--usable-file-for-reinvoke + (expand-file-name invocation-name + invocation-directory)))) (and (file-executable-p file) file)))) (defun process-tests--dump-file () "Return the filename of the dump file used to start Emacs. Return nil if that can't be determined. Return `:not-needed' if Emacs wasn't started with a dump file." - (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats)))) - (when-let ((file (process-tests--usable-file-for-reinvoke - (cdr (assq 'dump-file-name stats))))) + (if-let* ((stats (and (fboundp 'pdumper-stats) (pdumper-stats)))) + (when-let* ((file (process-tests--usable-file-for-reinvoke + (cdr (assq 'dump-file-name stats))))) (and (file-readable-p file) file)) :not-needed)) diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el index ca595c41244..50f205421d7 100644 --- a/test/src/treesit-tests.el +++ b/test/src/treesit-tests.el @@ -1022,10 +1022,10 @@ and \"]\"." ;; Four functions: next-end, prev-beg, next-beg, prev-end. (mapcar (lambda (conf) (lambda () - (if-let ((pos (funcall - #'treesit-navigate-thing - (point) (car conf) (cdr conf) - treesit-defun-type-regexp tactic))) + (if-let* ((pos (funcall + #'treesit-navigate-thing + (point) (car conf) (cdr conf) + treesit-defun-type-regexp tactic))) (save-excursion (goto-char pos) (funcall treesit-defun-skipper) |