commit aaefb67f54513e8375ec8356d09bf2e6f25b9116 (HEAD, refs/remotes/origin/master) Author: Eli Zaretskii Date: Sun Oct 27 08:43:00 2024 +0200 ; * src/w32dwrite.c (syms_of_w32dwrite): Init 'w32-inhibit-dwrite'. diff --git a/src/w32dwrite.c b/src/w32dwrite.c index 45be5b5beff..32e2644af2c 100644 --- a/src/w32dwrite.c +++ b/src/w32dwrite.c @@ -1100,6 +1100,10 @@ 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); commit 702d5ec56684b87dbe7c46d35c6926a46a0697e9 Author: Cecilio Pardo Date: Sat Oct 26 17:51:22 2024 +0200 ; Fix problem with DirectWrite (MS-Windows) Negative lbearings were not handled. * src/w32dwrite.c (w32_dwrite_draw): Modified to handle negative lbearing. diff --git a/src/w32dwrite.c b/src/w32dwrite.c index ecc33af5f3f..45be5b5beff 100644 --- a/src/w32dwrite.c +++ b/src/w32dwrite.c @@ -895,7 +895,9 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, return false; } - int bitmap_width = metrics.width + metrics.rbearing; + 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. */ @@ -914,7 +916,7 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, = 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, y, SRCCOPY); + BitBlt (text_dc, 0, 0, bitmap_width, bitmap_height, hdc, x - left_margin, y, SRCCOPY); UINT16 *indices = SAFE_ALLOCA (len * sizeof (UINT16)); @@ -948,7 +950,7 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, IDWriteColorGlyphRunEnumerator *layers; /* This call will tell us if we have to handle any color glyphs. */ hr = dwrite_factory2->lpVtbl->TranslateColorGlyphRun (dwrite_factory2, - 0, font->ascent, + left_margin, font->ascent, &glyph_run, NULL, MEASURING_MODE, @@ -959,7 +961,7 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, /* No color. Just draw the GlyphRun. */ if (hr == DWRITE_E_NOCOLOR) bitmap_render_target->lpVtbl->DrawGlyphRun (bitmap_render_target, - 0, font->ascent, + left_margin, font->ascent, MEASURING_MODE, &glyph_run, rendering_params, @@ -1024,7 +1026,7 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, } /* Finally, copy the rendered text back to the original DC. */ - BitBlt (hdc, x, y, bitmap_width, bitmap_height, text_dc, 0, 0, SRCCOPY); + BitBlt (hdc, x - left_margin, y, bitmap_width, bitmap_height, text_dc, 0, 0, SRCCOPY); SAFE_FREE (); return true; } commit d7d5b2ec9a747fac48bd50152e2023d33e78393c Author: Sean Whitton Date: Sun Oct 27 14:11:50 2024 +0800 vc-git-resolve-conflicts: Extend unstage-maybe to similar operations * lisp/vc/vc-git.el (vc-git-resolve-when-done): When vc-git-resolve-conflicts is unstage-maybe, don't clear the staging area during a rebase, am, revert or cherry-pick. (vc-git-resolve-conflicts): Update docstring in light of changes to vc-git-resolve-when-done. (vc-git--cmds-in-progress): Detect reverts and cherry-pick operations in progress. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2eb2379c351..e4969aede74 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" @@ -766,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 @@ -1419,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) commit d354300993e6a48e2d3e72a7e89348cc06b326fb Author: Sean Whitton Date: Thu Oct 24 17:04:40 2024 +0800 lisp/org: Backport org-mode.git fix for if-let/when-let obsolescence Backporting this acked by Org maintainer Ihor Radchenko. * lisp/org/ob-R.el (org-babel-R-associate-session): * lisp/org/ob-clojure.el (ob-clojure-nbb-command) (ob-clojure-cli-command): * lisp/org/ob-core.el (org-babel-execute-src-block): * lisp/org/ob-exp.el (org-babel-exp-code): * lisp/org/ob-julia.el (org-babel-julia-associate-session): * lisp/org/ob-python.el (org-babel-python--python-util-comint-end-of-output-p): * lisp/org/ol.el (org-insert-link): * lisp/org/org-attach.el (org-attach): * lisp/org/org-clock.el (org-clock-select-task): * lisp/org/org-compat.el (fboundp): * lisp/org/org-element-ast.el (org-element-property-raw) (org-element-put-property, org-element-copy): * lisp/org/org-element.el (org-element-timestamp-interpreter) (org-element--cache-key): * lisp/org/org-goto.el (org-goto-location): * lisp/org/org-lint.el (org-lint-suspicious-language-in-src-block) (org-lint-export-option-keywords): * lisp/org/org-macs.el (org-mks): * lisp/org/org-persist.el: (org-persist-write:elisp): * lisp/org/org-table.el (org-table-fedit-finish): * lisp/org/org.el (org-entry-get-with-inheritance): * lisp/org/ox-html.el (org-html--reference) (org-html--build-mathjax-config, org-html-example-block): * lisp/org/ox-latex.el (org-latex-table-row): * lisp/org/ox.el (org-export--prune-tree) (org-export--blindly-expand-include): Replace use of if-let and when-let, obsolete in Emacs 31.0.50. 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 "\n%s" 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) commit 2030b8c7f24a10024ab973149b10194fd50dd2bb Author: Dmitry Gutov Date: Sun Oct 27 03:46:57 2024 +0300 vc-git-log-edit-toggle-amend: Honor vc-allow-rewriting-published-history * etc/NEWS: Update the entry for vc-allow-rewriting-published-history. * lisp/vc/vc-git.el (vc-git-log-edit-toggle-amend): Add a check against published history (bug#64055). diff --git a/etc/NEWS b/etc/NEWS index 5bb1c8a4695..d1c7303f976 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -613,13 +613,11 @@ of seconds. Crossfading can be toggled using the command --- *** New user option 'vc-allow-rewriting-published-history'. -Many VCS commands can change your copy of published change history -without warning. If VC commands detect that this could happen, they -will stop. You can customize this variable to permit rewriting 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 variable to permit rewriting history even though Emacs thinks it is dangerous. -So far, this applies only to using 'e' from Log View mode for Git. - --- *** 'vc-clone' is now an interactive command. When called interactively, 'vc-clone' now prompts for the remote diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2702203a371..2eb2379c351 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1040,6 +1040,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")))) commit 523aade3ea11c188e30e3889f031d1848129cf82 Author: Jim Porter Date: Sun Oct 20 21:37:55 2024 -0700 Fix Eshell incompatibility with "[" command when eshell-pred is disabled * lisp/eshell/em-pred.el (eshell-pred-initialize): Ensure that 'eshell-parse-arg-modifier' is called before 'eshell-parse-glob-chars'. * lisp/eshell/em-glob.el (eshell-glob-initialize): Use a number for hook depth to be clearer. (eshell-parse-glob-chars): Simplify; since eshell-pred's hook now runs first, the extra code is no longer necessary. * test/lisp/eshell/em-glob-tests.el (em-glob-test/test-command-without-pred): New test. diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 8c8466960c1..57bb0c53b57 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)) @@ -165,22 +165,7 @@ The character is not advanced for ordinary globbing characters, so that other function may have a chance to override the globbing interpretation." (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)))))))))) + (ignore (eshell-add-glob-modifier)))) (defvar eshell-glob-matches) (defvar message-shown) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 053ebf91dab..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) diff --git a/test/lisp/eshell/em-glob-tests.el b/test/lisp/eshell/em-glob-tests.el index 88e9cc73bbd..239968917ab 100644 --- a/test/lisp/eshell/em-glob-tests.el +++ b/test/lisp/eshell/em-glob-tests.el @@ -317,4 +317,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 commit d6fe32e531044b518ae5b6b39377378cbf13292d Author: Jim Porter Date: Sat Oct 26 14:22:38 2024 -0700 ; Ensure 'eshell-split-filename' doesn't expand the filename first * lisp/eshell/esh-util.el (eshell-split-filename): Never expand the filename. * lisp/eshell/em-glob.el (eshell-glob-p): A leading "~" isn't a globbing character. * test/lisp/eshell/esh-util-tests.el (esh-util-test/split-filename/absolute) (esh-util-test/split-filename/relative) (esh-util-test/split-filename/user) (esh-util-test/split-filename/remote-absolute) (esh-util-test/split-filename/remote-relative) (esh-util-test/split-filename/remote-user): New tests. diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index f4337872a8e..8c8466960c1 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -244,7 +244,10 @@ 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)) + ;; "~" 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. diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 180f049e495..65e19228e0e 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -462,7 +462,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) diff --git a/test/lisp/eshell/esh-util-tests.el b/test/lisp/eshell/esh-util-tests.el index 4a0874bff39..b2fd01e0c29 100644 --- a/test/lisp/eshell/esh-util-tests.el +++ b/test/lisp/eshell/esh-util-tests.el @@ -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 commit 02510606f6d0e431e36634b8290e648b3a47af18 Author: Eli Zaretskii Date: Sat Oct 26 22:38:58 2024 +0300 Fix bootstrap on MS-Windows * src/w32uniscribe.c (syms_of_w32uniscribe): Don't call 'syms_of_w32dwrite' here... * src/emacs.c (main): ...call it here. Reported by Andy Moreton . 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/w32uniscribe.c b/src/w32uniscribe.c index d6db1e9e7db..66d27b81b9e 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -1512,7 +1512,6 @@ static void syms_of_w32uniscribe_for_pdumper (void); void syms_of_w32uniscribe (void) { - syms_of_w32dwrite (); pdumper_do_now_and_after_load (syms_of_w32uniscribe_for_pdumper); } commit e0b21b6c4de4d7f0b7ad9ae112755435f501835e Author: Earl Hyatt Date: Sat Oct 12 20:28:25 2024 -0400 Add delete-selection-local-mode. * lisp/delsel.el (delete-selection-local-mode): Add local version of 'delete-selection-mode'. The local mode sets the value of the variable 'delete-selection-mode' to maintain compatibility with packages and features that consider the existing mode. * doc/emacs/mark.texi (Using Region): Describe 'delete-selection-local-mode'. * etc/NEWS: Describe 'delete-selection-local-mode'. 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/etc/NEWS b/etc/NEWS index a00536607da..5bb1c8a4695 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -206,6 +206,12 @@ 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 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 commit fb974171b44253aa0600074e9b293bdeabc8c032 Author: Eyal Soha Date: Sat Oct 26 14:16:26 2024 +0200 Improve Tramp VC cache * lisp/net/tramp-sh.el (tramp-vc-file-name-handler): Add `file-directory-p', which is used in `vc-find-root'. (Bug#74026) Copyright-paperwork-exempt: yes diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 9e813ecc628..068c3483750 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3735,10 +3735,12 @@ Fall back to normal file name handler if no Tramp handler exists." (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))) + ;; `file-readable-p' and `file-directory-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 file-directory-p))) (add-to-list 'tramp-vc-registered-file-names localname 'append) nil) ;; `process-file' and `start-file-process' shall be ignored. commit c2fcb6ca5c4baea5eed39376be12c21e03a960c2 Author: Alan Mackenzie Date: Sat Oct 26 11:01:15 2024 +0000 * lisp/progmodes/cc-langs.el (c-cpp-matchers): Remove an unneeded let*. diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 3a87339e38a..83afe081b85 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -556,26 +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. - `((,(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)))) + ;; 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) commit 2a6af880b0958d527a4d32005ef9acf3bc4ea030 Author: Eli Zaretskii Date: Sat Oct 26 09:05:10 2024 +0300 ; * lisp/emacs-lisp/cond-star.el: Require cl-lib. diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index 4cd8b9fd0fc..0e4718f088d 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -38,6 +38,8 @@ ;;; 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 commit 4b9daca842419f94226d40adc9f7844d18dfffa9 Author: Sean Whitton Date: Sat Oct 26 11:15:25 2024 +0800 ; Reformat a couple of recently added long strings * lisp/vc/vc-git.el (vc-git--assert-allowed-rewrite) (vc-git-modify-change-comment): Reformat long strings by prefixing an escaped newline. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index ff0bc68e2d4..2702203a371 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1981,9 +1981,11 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (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?" + (format "\ +Commit %s appears published; allow rewriting history?" rev)))) - (user-error "Will not rewrite likely-public history; see option `vc-allow-rewriting-published-history'"))))) + (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) @@ -2024,8 +2026,8 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." "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?"))) + (not (yes-or-no-p "\ +Rebase may --autosquash your other squash!/fixup!/amend!; proceed?"))) (user-error "Aborted")) (when msg-file commit d44b94a63d2d407fca5d5ec41fcb92d7b765972e Author: Stefan Monnier Date: Fri Oct 25 22:26:06 2024 -0400 cond*: Add support for Pcase patterns * lisp/emacs-lisp/cond-star.el (cond*): Adjust docstring. (match*): Prefer `_VAR` syntax. (cond*-convert-condition): Add support for `pcase*`. * doc/lispref/control.texi (cond* Macro): Document `pcase*`. * test/lisp/emacs-lisp/cond-star-tests.el: New file. diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index b996a372e28..6ad8a779d17 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -1452,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*}. @@ -1475,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})}. @@ -1482,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/etc/NEWS b/etc/NEWS index 18b6678dce9..a00536607da 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -741,12 +741,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'. diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el index 9495ad96a6c..4cd8b9fd0fc 100644 --- a/lisp/emacs-lisp/cond-star.el +++ b/lisp/emacs-lisp/cond-star.el @@ -31,10 +31,10 @@ ;; 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: @@ -44,15 +44,20 @@ 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 +75,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 +138,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 +250,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 +267,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 +392,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 +420,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 +509,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/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 . + +;;; 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 commit 574e97575f4331f43fc079b3bfa6d74213bc2559 Author: Po Lu Date: Sat Oct 26 08:39:24 2024 +0800 ; Fix coding style of Uniscribe files * src/w32dwrite.c (EMACS_DWRITE_UNUSED, IDWriteFontFaceVtbl) (IDWriteFontFace, IDWriteRenderingParamsVtbl) (IDWriteRenderingParams, IDWriteFontVtbl, IDWriteFont) (IDWriteBitmapRenderTargetVtbl, IDWriteBitmapRenderTarget) (IDWriteBitmapRenderTarget1, IDWriteGdiInteropVtbl) (IDWriteGdiInterop, IDWriteFactoryVtbl, IDWriteFactory) (IDWriteColorGlyphRunEnumeratorVtbl) (IDWriteColorGlyphRunEnumerator, IDWriteFactory2Vtbl) (IDWriteFactory2, get_font_face, text_extents_internal) (w32_initialize_direct_write, w32_dwrite_draw) (w32_use_direct_write): * src/w32font.c (w32font_text_extents, w32font_draw): * src/w32uniscribe.c (uniscribe_open): Correct coding style. diff --git a/src/w32dwrite.c b/src/w32dwrite.c index 1ca965fe374..ecc33af5f3f 100644 --- a/src/w32dwrite.c +++ b/src/w32dwrite.c @@ -56,7 +56,7 @@ along with GNU Emacs. If not, see . */ 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 EMACS_DWRITE_UNUSED(name) void (STDMETHODCALLTYPE *name) (void) #define DWRITE_E_NOCOLOR _HRESULT_TYPEDEF_(0x8898500CL) @@ -125,9 +125,12 @@ 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); +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; @@ -168,14 +171,14 @@ typedef struct IDWriteFontFaceVtbl { HRESULT (STDMETHODCALLTYPE *QueryInterface) (IDWriteFontFace *This, REFIID riid, void **ppvObject); - ULONG (STDMETHODCALLTYPE *AddRef)(IDWriteFontFace *This); - ULONG (STDMETHODCALLTYPE *Release)(IDWriteFontFace *This); + 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); + 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); @@ -207,7 +210,7 @@ typedef struct IDWriteFontFaceVtbl { } IDWriteFontFaceVtbl; interface IDWriteFontFace { - CONST_VTBL IDWriteFontFaceVtbl* lpVtbl; + CONST_VTBL IDWriteFontFaceVtbl *lpVtbl; }; typedef struct IDWriteRenderingParamsVtbl { @@ -215,8 +218,8 @@ typedef struct IDWriteRenderingParamsVtbl { HRESULT (STDMETHODCALLTYPE *QueryInterface) (IDWriteRenderingParams *This, REFIID riid, void **ppvObject); - ULONG (STDMETHODCALLTYPE *AddRef)(IDWriteRenderingParams *This); - ULONG (STDMETHODCALLTYPE *Release)(IDWriteRenderingParams *This); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteRenderingParams *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteRenderingParams *This); FLOAT (STDMETHODCALLTYPE *GetGamma) (IDWriteRenderingParams *This); @@ -230,7 +233,7 @@ typedef struct IDWriteRenderingParamsVtbl { } IDWriteRenderingParamsVtbl; interface IDWriteRenderingParams { - CONST_VTBL IDWriteRenderingParamsVtbl* lpVtbl; + CONST_VTBL IDWriteRenderingParamsVtbl *lpVtbl; }; typedef struct IDWriteFontVtbl { @@ -238,8 +241,8 @@ typedef struct IDWriteFontVtbl { HRESULT (STDMETHODCALLTYPE *QueryInterface) (IDWriteFont *This, REFIID riid, void **ppvObject); - ULONG (STDMETHODCALLTYPE *AddRef)(IDWriteFont *This); - ULONG (STDMETHODCALLTYPE *Release)(IDWriteFont *This); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteFont *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteFont *This); EMACS_DWRITE_UNUSED (GetFontFamily); EMACS_DWRITE_UNUSED (GetWeight); @@ -253,7 +256,7 @@ typedef struct IDWriteFontVtbl { void (STDMETHODCALLTYPE *GetMetrics) (IDWriteFont *This, DWRITE_FONT_METRICS *metrics); - EMACS_DWRITE_UNUSED(HasCharacter); + EMACS_DWRITE_UNUSED (HasCharacter); HRESULT (STDMETHODCALLTYPE *CreateFontFace) (IDWriteFont *This, IDWriteFontFace **face); @@ -262,7 +265,7 @@ typedef struct IDWriteFontVtbl { } IDWriteFontVtbl; interface IDWriteFont { - CONST_VTBL IDWriteFontVtbl* lpVtbl; + CONST_VTBL IDWriteFontVtbl *lpVtbl; }; typedef struct IDWriteBitmapRenderTargetVtbl { @@ -270,8 +273,8 @@ typedef struct IDWriteBitmapRenderTargetVtbl { HRESULT (STDMETHODCALLTYPE *QueryInterface) (IDWriteBitmapRenderTarget *This, REFIID riid, void **ppvObject); - ULONG (STDMETHODCALLTYPE *AddRef)(IDWriteBitmapRenderTarget *This); - ULONG (STDMETHODCALLTYPE *Release)(IDWriteBitmapRenderTarget *This); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteBitmapRenderTarget *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteBitmapRenderTarget *This); HRESULT (STDMETHODCALLTYPE *DrawGlyphRun) (IDWriteBitmapRenderTarget *This, @@ -283,7 +286,7 @@ typedef struct IDWriteBitmapRenderTargetVtbl { COLORREF textColor, RECT *blackbox_rect); - HDC (STDMETHODCALLTYPE *GetMemoryDC)(IDWriteBitmapRenderTarget *This); + HDC (STDMETHODCALLTYPE *GetMemoryDC) (IDWriteBitmapRenderTarget *This); EMACS_DWRITE_UNUSED (GetPixelsPerDip); @@ -298,7 +301,7 @@ typedef struct IDWriteBitmapRenderTargetVtbl { } IDWriteBitmapRenderTargetVtbl; interface IDWriteBitmapRenderTarget { - CONST_VTBL IDWriteBitmapRenderTargetVtbl* lpVtbl; + CONST_VTBL IDWriteBitmapRenderTargetVtbl *lpVtbl; }; typedef struct IDWriteBitmapRenderTarget1Vtbl { @@ -326,7 +329,7 @@ typedef struct IDWriteBitmapRenderTarget1Vtbl { } IDWriteBitmapRenderTarget1Vtbl; interface IDWriteBitmapRenderTarget1 { - CONST_VTBL IDWriteBitmapRenderTarget1Vtbl* lpVtbl; + CONST_VTBL IDWriteBitmapRenderTarget1Vtbl *lpVtbl; }; typedef struct IDWriteGdiInteropVtbl { @@ -334,8 +337,8 @@ typedef struct IDWriteGdiInteropVtbl { HRESULT (STDMETHODCALLTYPE *QueryInterface) (IDWriteGdiInterop *This, REFIID riid, void **ppvObject); - ULONG (STDMETHODCALLTYPE *AddRef)(IDWriteGdiInterop *This); - ULONG (STDMETHODCALLTYPE *Release)(IDWriteGdiInterop *This); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteGdiInterop *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteGdiInterop *This); HRESULT (STDMETHODCALLTYPE *CreateFontFromLOGFONT) (IDWriteGdiInterop *This, const LOGFONTW *logfont, @@ -352,7 +355,7 @@ typedef struct IDWriteGdiInteropVtbl { } IDWriteGdiInteropVtbl; interface IDWriteGdiInterop { - CONST_VTBL IDWriteGdiInteropVtbl* lpVtbl; + CONST_VTBL IDWriteGdiInteropVtbl *lpVtbl; }; typedef struct IDWriteFactoryVtbl { @@ -360,8 +363,8 @@ typedef struct IDWriteFactoryVtbl { HRESULT (STDMETHODCALLTYPE *QueryInterface) (IDWriteFactory *This, REFIID riid, void **ppvObject); - ULONG (STDMETHODCALLTYPE *AddRef)(IDWriteFactory *This); - ULONG (STDMETHODCALLTYPE *Release)(IDWriteFactory *This); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteFactory *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteFactory *This); EMACS_DWRITE_UNUSED (GetSystemFontCollection); EMACS_DWRITE_UNUSED (CreateCustomFontCollection); @@ -392,37 +395,35 @@ typedef struct IDWriteFactoryVtbl { END_INTERFACE } IDWriteFactoryVtbl; -interface IDWriteFactory { CONST_VTBL IDWriteFactoryVtbl* lpVtbl; }; +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); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteColorGlyphRunEnumerator *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteColorGlyphRunEnumerator *This); - HRESULT (STDMETHODCALLTYPE *MoveNext)( - IDWriteColorGlyphRunEnumerator *This, - WINBOOL *hasRun); + HRESULT (STDMETHODCALLTYPE *MoveNext) (IDWriteColorGlyphRunEnumerator *This, + WINBOOL *hasRun); - HRESULT (STDMETHODCALLTYPE *GetCurrentRun)( - IDWriteColorGlyphRunEnumerator *This, - const DWRITE_COLOR_GLYPH_RUN **run); + HRESULT (STDMETHODCALLTYPE *GetCurrentRun) (IDWriteColorGlyphRunEnumerator *This, + const DWRITE_COLOR_GLYPH_RUN **run); END_INTERFACE } IDWriteColorGlyphRunEnumeratorVtbl; interface IDWriteColorGlyphRunEnumerator { - CONST_VTBL IDWriteColorGlyphRunEnumeratorVtbl* lpVtbl; + 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); + ULONG (STDMETHODCALLTYPE *AddRef) (IDWriteFactory2 *This); + ULONG (STDMETHODCALLTYPE *Release) (IDWriteFactory2 *This); EMACS_DWRITE_UNUSED (GetSystemFontCollection); EMACS_DWRITE_UNUSED (CreateCustomFontCollection); EMACS_DWRITE_UNUSED (RegisterFontCollectionLoader); @@ -467,7 +468,7 @@ typedef struct IDWriteFactory2Vtbl { } IDWriteFactory2Vtbl; interface IDWriteFactory2 { - CONST_VTBL IDWriteFactory2Vtbl* lpVtbl; + CONST_VTBL IDWriteFactory2Vtbl *lpVtbl; }; #else /* MINGW_W64 */ # include @@ -529,15 +530,15 @@ get_font_face (struct font *infont, IDWriteFontFace **face) LOGFONTW logfont; IDWriteFont *font; - struct uniscribe_font_info *uniscribe_font = - (struct uniscribe_font_info *) infont; + 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); + GetObjectW (FONT_HANDLE (infont), sizeof (LOGFONTW), &logfont); hr = gdi_interop->lpVtbl->CreateFontFromLOGFONT (gdi_interop, (const LOGFONTW *) &logfont, @@ -597,8 +598,8 @@ text_extents_internal (IDWriteFontFace *dwrite_font_face, for (int i = 0; i < nglyphs; i++) indices[i] = code[i]; - DWRITE_GLYPH_METRICS* gmetrics = - SAFE_ALLOCA (nglyphs * sizeof (DWRITE_GLYPH_METRICS)); + DWRITE_GLYPH_METRICS *gmetrics + = SAFE_ALLOCA (nglyphs * sizeof (DWRITE_GLYPH_METRICS)); hr = dwrite_font_face->lpVtbl->GetGdiCompatibleGlyphMetrics (dwrite_font_face, font_size, @@ -620,18 +621,18 @@ text_extents_internal (IDWriteFontFace *dwrite_font_face, for (int i = 0; i < nglyphs; i++) { - float advance = - convert_metrics_sz (gmetrics[i].advanceWidth, font_size, du_per_em); + 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)); + 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; @@ -759,7 +760,8 @@ w32_initialize_direct_write (void) return; /* This is only used here, no need to define it globally. */ - typedef HRESULT (WINAPI *DWCreateFactory) (DWRITE_FACTORY_TYPE f, REFIID r, IUnknown** u); + typedef HRESULT (WINAPI *DWCreateFactory) (DWRITE_FACTORY_TYPE, + REFIID, IUnknown **); DWCreateFactory dw_create_factory = (DWCreateFactory) get_proc_addr (direct_write, @@ -843,7 +845,7 @@ w32_initialize_direct_write (void) config_gamma, config_enhanced_contrast, config_clear_type_level, - def->lpVtbl->GetPixelGeometry(def), + def->lpVtbl->GetPixelGeometry (def), RENDERING_MODE, &rendering_params); @@ -851,7 +853,8 @@ w32_initialize_direct_write (void) if (FAILED (hr)) { - DebPrint (("DirectWrite HRESULT failed: (%d) CreateCustomRenderingParams\n", hr)); + DebPrint (("DirectWrite HRESULT failed: (%d)" + " CreateCustomRenderingParams\n", hr)); RELEASE_COM (dwrite_factory); RELEASE_COM (dwrite_factory2); RELEASE_COM (gdi_interop); @@ -874,8 +877,8 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, USE_SAFE_ALLOCA; - struct uniscribe_font_info *uniscribe_font = - (struct uniscribe_font_info *) font; + struct uniscribe_font_info *uniscribe_font + = (struct uniscribe_font_info *) font; /* What we get as y is the baseline position. */ y -= font->ascent; @@ -907,8 +910,8 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, } /* This DC can't be released. */ - HDC text_dc = bitmap_render_target->lpVtbl->GetMemoryDC - (bitmap_render_target); + 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, y, SRCCOPY); @@ -1036,10 +1039,10 @@ 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; + 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 diff --git a/src/w32font.c b/src/w32font.c index a6a6a4459a3..48968a28fbd 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -452,9 +452,9 @@ w32font_text_extents (struct font *font, const unsigned *code, memset (metrics, 0, sizeof (struct font_metrics)); - if (w32_use_direct_write (w32_font)) - if (w32_dwrite_text_extents (font, code, nglyphs, metrics)) - return; + if (w32_use_direct_write (w32_font) + && w32_dwrite_text_extents (font, code, nglyphs, metrics)) + return; for (i = 0, first = true; i < nglyphs; i++) { @@ -710,9 +710,9 @@ w32font_draw (struct glyph_string *s, int from, int to, int i; for (i = 0; i < len; i++) - if (!w32_use_direct_write (w32font) || - !w32_dwrite_draw (s->hdc, x, y, s->char2b + from, 1, - GetTextColor (s->hdc), s->font)) + 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); @@ -720,10 +720,10 @@ w32font_draw (struct glyph_string *s, int from, int to, } else { - if (!w32_use_direct_write (w32font) || - !w32_dwrite_draw (s->hdc, x, y, - s->char2b + from, len, GetTextColor (s->hdc), - s->font)) + 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 diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c index 015214b1e39..d6db1e9e7db 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -189,7 +189,6 @@ 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. */ commit 76268160ba9262a8479589427b8e783db0242260 Author: Alan Mackenzie Date: Fri Oct 25 20:35:32 2024 +0000 CC Mode: correct handling of properties on #include <...> In C, Pike, and IDL Modes, deleting and reinserting such a < could create havoc with the category/syntax-table properties on the < and >. Also the contents of <...> should only get paren properties when the #include is present and correct. * lisp/progmodes/cc-fonts.el (c-cpp-matchers): Replace the c-make-font-lock-search-function which put properties on the <...> with a simple matcher. * lisp/progmodes/cc-langs.el (c-get-state-before-change-functions) (c-before-font-lock-functions): Add respectively c-before-change-include-<> and c-after-change-include-<> in the C, Pike and IDL entries of these variables. * lisp/progmodes/cc-mode.el (c-before-change-include-<>) (c-after-change-include-<>): New functions. diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 0f086f8e812..3a87339e38a 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -564,26 +564,18 @@ stuff. Used on level 1 and higher." ;; 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)))))) + `((,(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..2fcb46a1c0d 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -2009,6 +2009,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 commit 3d508157e03597b00c46c82d42a60742c01a0250 Author: Eli Zaretskii Date: Fri Oct 25 14:47:43 2024 +0300 ; * src/w32dwrite.c (Fw32_dwrite_reinit): Doc fix. diff --git a/src/w32dwrite.c b/src/w32dwrite.c index 1f5eba19a40..1ca965fe374 100644 --- a/src/w32dwrite.c +++ b/src/w32dwrite.c @@ -1060,9 +1060,10 @@ value. Return value is nil. -ENHANCED_CONTRAST is in the range [0.0, 1.0], and defaults to 0.0. -CLEAR_TYPE_LEVEL is in the range [0.0, 1.0], and defaults to 0.0. -GAMMA is in the range (0.0, 256.0], and defaults to 2.2. */) +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) { commit 222a5207c4d8fa31103637018ae0a7bdb74dd660 Author: Eli Zaretskii Date: Fri Oct 25 14:36:41 2024 +0300 ; Minor fixes to last changes * src/w32font.h: * src/w32font.c: * src/w32dwrite.c: * etc/NEWS: Minor fixes of last changes. (Bug#73730) diff --git a/etc/NEWS b/etc/NEWS index 108d96014db..18b6678dce9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -790,8 +790,11 @@ supported. As on X, the user options 'dnd-scroll-margin' and 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 render -parameters. +'w32-dwrite-reinit' to check availability and to configure the +DirectWrite rendering parameters. + +To show color Emoji in Emacs, customize the default fontset to use a +color Emoji font installed on your system for the 'emoji' script. ---------------------------------------------------------------------- diff --git a/src/w32dwrite.c b/src/w32dwrite.c index 9f7b8d96977..1f5eba19a40 100644 --- a/src/w32dwrite.c +++ b/src/w32dwrite.c @@ -469,11 +469,11 @@ typedef struct IDWriteFactory2Vtbl { interface IDWriteFactory2 { CONST_VTBL IDWriteFactory2Vtbl* lpVtbl; }; -#else /* ifndef MINGW_W64 */ +#else /* MINGW_W64 */ # include #endif -/* User configurable variables. If they are lower than 0 use +/* 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; @@ -495,7 +495,7 @@ release_com (IUnknown **i) } } -#define RELEASE_COM(i) release_com ( (IUnknown **) &i ) +#define RELEASE_COM(i) release_com ((IUnknown **) &i) /* Global variables for DirectWrite. */ static bool direct_write_available = false; @@ -516,7 +516,7 @@ verify_hr (HRESULT hr, const char *msg) return true; } -/* Gets a IDWriteFontFace from a struct font (its HFONT). Returns the +/* 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. @@ -560,10 +560,10 @@ get_font_face (struct font *infont, IDWriteFontFace **face) } /* Cache this FontFace. */ - uniscribe_font->dwrite_font_size = abs (logfont.lfHeight); + uniscribe_font->dwrite_font_size = eabs (logfont.lfHeight); uniscribe_font->dwrite_cache = *face; - return abs (logfont.lfHeight); + return eabs (logfont.lfHeight); } void @@ -642,7 +642,7 @@ text_extents_internal (IDWriteFontFace *dwrite_font_face, if (metrics->rbearing < rbearing) metrics->rbearing = rbearing; } - metrics->width = round(width); + metrics->width = round (width); SAFE_FREE (); return true; } @@ -794,7 +794,6 @@ w32_initialize_direct_write (void) DebPrint (("DirectWrite HRESULT failed: (%d) QueryInterface IDWriteFactory2\n", hr)); RELEASE_COM (dwrite_factory); FreeLibrary (direct_write); - eassert (SUCCEEDED (hr)); return; } @@ -939,12 +938,12 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, glyph_run.glyphIndices = indices; glyph_run.glyphCount = len; glyph_run.isSideways = false; - glyph_run.bidiLevel = 0; + 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 hace to handle any color glyph. */ + /* This call will tell us if we have to handle any color glyphs. */ hr = dwrite_factory2->lpVtbl->TranslateColorGlyphRun (dwrite_factory2, 0, font->ascent, &glyph_run, @@ -965,8 +964,8 @@ w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, NULL); else { - /* If there were color glyphs, layers contains a list of GlyphRun - with a color and a position for each. We draw them + /* 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")) { @@ -1057,11 +1056,13 @@ DirectWrite will be used if it is available and 'w32-inhibit-dwrite' is nil. */ 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. Returns nil. +value. + +Return value is nil. -ENHANCED_CONTRAST is in the range [0.0, 1.0] -CLEAR_TYPE_LEVEL is in the range [0.0, 1.0] -GAMMA is in the range (0.0, 256.0] */) +ENHANCED_CONTRAST is in the range [0.0, 1.0], and defaults to 0.0. +CLEAR_TYPE_LEVEL is in the range [0.0, 1.0], and defaults to 0.0. +GAMMA is in the range (0.0, 256.0], and defaults to 2.2. */) (Lisp_Object enhanced_contrast, Lisp_Object clear_type_level, Lisp_Object gamma) { diff --git a/src/w32font.c b/src/w32font.c index 05e5a067f20..a6a6a4459a3 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -712,7 +712,7 @@ w32font_draw (struct glyph_string *s, int from, int to, for (i = 0; i < len; i++) if (!w32_use_direct_write (w32font) || !w32_dwrite_draw (s->hdc, x, y, s->char2b + from, 1, - GetTextColor(s->hdc), s->font)) + GetTextColor (s->hdc), s->font)) { WCHAR c = s->char2b[from + i] & 0xFFFF; ExtTextOutW (s->hdc, x + i, y, options, NULL, &c, 1, NULL); @@ -722,7 +722,7 @@ w32font_draw (struct glyph_string *s, int from, int to, { if (!w32_use_direct_write (w32font) || !w32_dwrite_draw (s->hdc, x, y, - s->char2b + from, len, GetTextColor(s->hdc), + s->char2b + from, len, GetTextColor (s->hdc), s->font)) { /* The number of glyphs in a glyph_string cannot be larger than diff --git a/src/w32font.h b/src/w32font.h index 75e63e4a32e..74552a5bee5 100644 --- a/src/w32font.h +++ b/src/w32font.h @@ -112,7 +112,7 @@ bool w32_dwrite_draw (HDC hdc, int x, int y, unsigned *glyphs, int len, 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 w32_dwrite_free_cached_face (void *cache); void syms_of_w32dwrite (void); extern void globals_of_w32font (void); commit edf37e811cafa4092b13969613fa83f6e6d69ab3 Author: Cecilio Pardo Date: Wed Oct 9 11:40:28 2024 +0200 Implement drawing text with DirectWrite on MS-Windows. This adds support for color fonts. * configure.ac: Add src/w32drite to W32_OBJ. * src/w32dwrite.c: New file. (w32-initialize-direct-write): New function, initialize the DirectWrite library if it is available, and required global variables. (w32_use_direct_write): New function, check if DirectWrite is available and activated by the user. (w32_dwrite_encode_char): New function, replacement for HarfBuzz's 'encode_char'. (w32_dwrite_text_extents): New function, replacement for w32font text_extents. (w32_dwrite_draw): New function, replacement for w32font draw. (w32_dwrite_free_cached_face): New function, used in the font deletion process to also delete DirectWrite data. (verify_hr): New function, verify COM method results. (release_com): New function, release a COM object. (w32-dwrite-available): New function, returns true if DirectWrite is available. (w32-dwrite-reinit): New function, reinitialize DirectWrite, optionally setting some rendering parameters. * src/w32font.c (w32font_text_extents): If DirectWrite is enabled, call 'w32_dwrite_text_extents'. (w32font_draw): If DirectWrite is enabled, call 'w32_dwrite_draw'. * src/w32uniscribe.c: (w32hb_encode_char): If DirectWrite is enabled, call 'w32_dwrite_encode_char'. (syms_of_w32uniscribe_for_pdumper): Initialize DirectWrite. (uniscribe_close): Free DirectWrite data for the font. Bug#73730 diff --git a/configure.ac b/configure.ac index 947c2827b8e..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" ;; diff --git a/etc/NEWS b/etc/NEWS index b9f58c846db..108d96014db 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -785,6 +785,14 @@ 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 render +parameters. + ---------------------------------------------------------------------- This file is part of GNU Emacs. diff --git a/src/w32dwrite.c b/src/w32dwrite.c new file mode 100644 index 00000000000..9f7b8d96977 --- /dev/null +++ b/src/w32dwrite.c @@ -0,0 +1,1099 @@ +/* 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 . */ + +/* 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 +#include +#include + +#ifndef MINGW_W64 +# define INITGUID +#endif +#include +#include +#include + +#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 /* ifndef MINGW_W64 */ +# include +#endif + +/* User configurable variables. If they are lower 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 = abs (logfont.lfHeight); + uniscribe_font->dwrite_cache = *face; + + return abs (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, + &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 f, REFIID r, IUnknown** u); + + 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); + eassert (SUCCEEDED (hr)); + 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 bitmap_width = 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, 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; + glyph_run.glyphOffsets = NULL; + glyph_run.glyphAdvances = advances; + + IDWriteColorGlyphRunEnumerator *layers; + /* This call will tell us if we hace to handle any color glyph. */ + hr = dwrite_factory2->lpVtbl->TranslateColorGlyphRun (dwrite_factory2, + 0, 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, + 0, 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, 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. Returns nil. + +ENHANCED_CONTRAST is in the range [0.0, 1.0] +CLEAR_TYPE_LEVEL is in the range [0.0, 1.0] +GAMMA is in the range (0.0, 256.0] */) + (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. */); + + defsubr (&Sw32_dwrite_reinit); + defsubr (&Sw32_dwrite_available); +} diff --git a/src/w32font.c b/src/w32font.c index efb42d80336..05e5a067f20 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)) + if (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..75e63e4a32e 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/w32uniscribe.c b/src/w32uniscribe.c index b77bf56b8cf..015214b1e39 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -44,18 +44,6 @@ along with GNU Emacs. If not, see . */ #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,9 @@ 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 +212,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 +1364,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 @@ -1510,6 +1513,7 @@ static void syms_of_w32uniscribe_for_pdumper (void); void syms_of_w32uniscribe (void) { + syms_of_w32dwrite (); pdumper_do_now_and_after_load (syms_of_w32uniscribe_for_pdumper); } @@ -1624,5 +1628,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 */ } commit 517711c373b9c80811371014fc5a7786aa7548eb Author: Eli Zaretskii Date: Fri Oct 25 13:41:27 2024 +0300 ; * etc/NEWS: Fix wording of recently-added entry. diff --git a/etc/NEWS b/etc/NEWS index b7f13e770d5..b9f58c846db 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -782,7 +782,7 @@ 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. The configuration variables 'dnd-scroll-margin' and +supported. As on X, the user options 'dnd-scroll-margin' and 'dnd-indicate-insertion-point' can be used to customize the process. commit 3eb2a85d10e0ad7b50e96ee4e80ba08b3a71b9ae Author: Cecilio Pardo Date: Wed Oct 23 14:41:24 2024 +0200 Improve drag and drop on MS-Windows (bug#3468) Add support for 'dnd-scroll-margin' and 'dnd-indicate-insertion-point' by calling 'dnd-handle-movement' when dragging the mouse. * lisp/term/w32-win.el (w32-drag-n-drop): Call 'dnd-handle-movement' when applicable. * src/w32fns.c (w32_handle_drag_movement): New function, sends a WM_EMACS_DRAGOVER message. (w32_drop_target_DragEnter): Call 'w32_handle_drag_movement'. (w32_drop_target_DragOver): Call 'w32_handle_drag_movement'. * src/w32term.c: (w32_read_socket): Handle WM_EMACS_DRAGOVER, sending a drag-n-drop event. * src/w32term.h: Define new WM_EMACS_DRAGOVER message. diff --git a/etc/NEWS b/etc/NEWS index a4a036cbb50..b7f13e770d5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -781,7 +781,9 @@ 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. The configuration variables 'dnd-scroll-margin' and +'dnd-indicate-insertion-point' can be used to customize the process. ---------------------------------------------------------------------- diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 541fef2ced3..75f8530010c 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. - (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. + (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. diff --git a/src/w32fns.c b/src/w32fns.c index 3ee13dcbbdd..eb42d3b61b2 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -2505,7 +2505,6 @@ process_dropfiles (DROPFILES *files) 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 @@ -2572,6 +2571,19 @@ w32_drop_target_Release (IDropTarget *This) 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 +2593,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 +2603,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; } @@ -3607,6 +3621,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/w32term.c b/src/w32term.c index 3a627308137..88622700386 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -5629,6 +5629,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) commit df677f65fd1b4f0d16e59d5df9735139d2a667c8 Author: Sean Whitton Date: Fri Oct 25 12:43:23 2024 +0800 save-buffers-kill-emacs: Adjust confirmation prompt when restarting * lisp/files.el (save-buffers-kill-emacs): When restarting, ask "Really restart Emacs?". diff --git a/lisp/files.el b/lisp/files.el index 114ddc9c259..9c105dbe1a5 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -8490,7 +8490,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) commit 9729353ba019d9e7f603515dbf88cbc8807bb120 Author: Sean Whitton Date: Fri Oct 25 11:13:46 2024 +0800 vc-modify-change-comment: Revert Log View buffer * lisp/vc/vc.el (vc-modify-change-comment): Revert the Log View buffer after modifying the change comment. diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index ebe3de5c6c4..e0fe4931e63 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2517,7 +2517,17 @@ 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)) + '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))) ;;;###autoload commit f33bc659c9110682174157086c60203d55725d20 Author: Eli Zaretskii Date: Thu Oct 24 17:41:02 2024 +0300 Fix error message in charset.c * src/charset.c (Fdefine_charset_internal): Don't reference uninitialized value in error message. (Bug#73985) 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; commit fefc3005d46f4ac41af624d4591b052df92e4bd0 Author: Sean Whitton Date: Thu Oct 24 21:15:28 2024 +0800 ; Touch up & fix documentation changes from last commit diff --git a/etc/NEWS b/etc/NEWS index 12053fffc57..a4a036cbb50 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -614,15 +614,17 @@ even though Emacs thinks it is dangerous. So far, this applies only to using 'e' from Log View mode for Git. +--- *** 'vc-clone' is now an interactive command. When called interactively, 'vc-clone' now prompts for the remote -repository address, the backend for cloning, if it has not been -determined automatically according to the URL, and the directory to -clone the repository into. +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 -directory to which the repository was cloned. +the directory into which the repository was cloned. * New Modes and Packages in Emacs 31.1 diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ae183cc9f72..d30f616f6ea 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -71,7 +71,7 @@ "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." @@ -809,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 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/vc/vc.el b/lisp/vc/vc.el index 9c85dee9129..ebe3de5c6c4 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3884,17 +3884,17 @@ 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. -If OPEN-DIR is non-nil, switches to a buffer visiting DIRECTORY to -which the repository was cloned. It would be useful in scripts, but not -in regular code. -If called interactively, prompt for REMOTE, DIRECTORY and BACKEND, -if BACKEND has not been automatically determined according to the REMOTE -URL, in the minibuffer." +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) commit be29879850028d316592ba82cd859d31a67c1ffe Author: Aleksandr Vityazev Date: Thu Oct 24 15:19:34 2024 +0300 vc-clone: Make interactive; call vc-guess-url-backend * lisp/vc/vc.el (vc-clone): Make interactive. Call vc-guess-url-backend. Always return DIRECTORY if it names a directory. New optional argument OPEN-DIR. (vc--remotes-history): New defvar. * etc/NEWS: Announce these changes. diff --git a/etc/NEWS b/etc/NEWS index 64e4f22b9d3..12053fffc57 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -614,6 +614,16 @@ even though Emacs thinks it is dangerous. So far, this applies only to using 'e' from Log View mode for Git. +*** 'vc-clone' is now an interactive command. +When called interactively, 'vc-clone' now prompts for the remote +repository address, the backend for cloning, if it has not been +determined automatically according to the URL, and the directory to +clone the repository into. + +*** 'vc-clone' now accepts an optional argument OPEN-DIR. +When the argument is non-nil, the function switches to a buffer visiting +directory to which the repository was cloned. + * New Modes and Packages in Emacs 31.1 diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index dfbb5743eb2..9c85dee9129 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3876,7 +3876,9 @@ 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. @@ -3886,20 +3888,42 @@ 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, switches to a buffer visiting DIRECTORY to +which the repository was cloned. It would be useful in scripts, but not +in regular code. +If called interactively, prompt for REMOTE, DIRECTORY and BACKEND, +if BACKEND has not been automatically determined according to the REMOTE +URL, in the minibuffer." + (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) commit 98b02f56d12f2f39a6667d33d50f9e551a267d6d Author: Aleksandr Vityazev Date: Thu Oct 24 15:11:44 2024 +0300 Move package-vc-heuristic-alist and related to vc.el * lisp/emacs-lisp/package-vc.el (package-vc--backend-type) (package-vc-heuristic-alist, package-vc--guess-backend): Rename to vc-cloneable-backends-custom-type, vc-clone-heuristic-alist and vc-guess-url-backend respectively, and move to lisp/vc/vc.el. Make package-vc-heuristic-alist an obsolete alias. (package-vc--clone, package-vc--read-package-name) (package-vc-install, package-vc-checkout): Use vc-guess-url-backend. * lisp/vc/vc.el (vc-cloneable-backends-custom-type) (vc-clone-heuristic-alist, vc-guess-url-backend): New defconst, defcustom and defun, respectively: renamed and moved here from lisp/emacs-lisp/package-vc.el. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 894bc9c8c37..ae183cc9f72 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -63,61 +63,9 @@ (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. @@ -127,7 +75,7 @@ the backend nor a repository URL that's recognized via 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 @@ -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=) @@ -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) @@ -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/vc/vc.el b/lisp/vc/vc.el index 6498b8522fd..dfbb5743eb2 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -944,6 +944,61 @@ value other than `ask' if you have a strong grasp of the VCS in use." (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 @@ -1033,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. commit db587ae8ba7d7b281f6935ed5d038b7ecf4abd5d Author: Sean Whitton Date: Thu Oct 24 17:19:41 2024 +0800 ; Drop two outdated calls to 'require' * lisp/emacs-lisp/backtrace.el (require): * lisp/wid-edit.el (require): Don't require subr-x. if-let, when-let and friends have all been in subr.el for a while. diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 120972d6cd8..84d9e20abe9 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) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 6fbf6257232..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" commit 767493ccb693f65cf8621cd82f0ecf92be976f55 Author: Michael Albinus Date: Thu Oct 24 11:11:03 2024 +0200 * doc/misc/tramp.texi (Bug Reports): Explain bisecting. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 1b40ce6fa62..96ec6d60b9e 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -5173,6 +5173,17 @@ 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 @chapter Frequently Asked Questions commit 8903106bb783c2825233c149b6799960aacdea57 Author: Sean Whitton Date: Thu Oct 24 16:50:07 2024 +0800 Mark if-let and when-let obsolete * lisp/subr.el (if-let*, when-let*, if-let, when-let): Mark if-let and when-let obsolete (bug#73853 and elsewhere). Move docstring text around so that if-let* and when-let* descriptions no longer refer to if-let and when-let. * etc/NEWS: Announce the change. * admin/admin.el (reminder-for-release-blocking-bugs): * doc/misc/erc.texi (display-buffer): * lisp/ansi-color.el (ansi-color-apply) (ansi-color--face-vec-face): * lisp/ansi-osc.el (ansi-osc-apply-on-region) (ansi-osc-hyperlink): * lisp/arc-mode.el (archive-goto-file) (archive-next-file-displayer): * lisp/auth-source-pass.el (auth-source-pass-search) (auth-source-pass--parse-data) (auth-source-pass--find-match-many): * lisp/autorevert.el (auto-revert-notify-rm-watch): * lisp/buff-menu.el (Buffer-menu-unmark-all-buffers) (Buffer-menu-group-by-root): * lisp/calendar/parse-time.el (parse-iso8601-time-string): * lisp/cedet/pulse.el (pulse-tick): * lisp/comint.el (comint--fontify-input-ppss-flush-indirect) (comint--intersect-regions): * lisp/completion-preview.el (completion-preview--try-table) (completion-preview--capf-wrapper, completion-preview--update): * lisp/cus-edit.el (setopt--set) (custom-dirlocals-maybe-update-cons, custom-dirlocals-validate): * lisp/custom.el (load-theme): * lisp/descr-text.el (describe-char): * lisp/desktop.el (desktop--emacs-pid-running-p): * lisp/dired-x.el (menu): * lisp/dired.el (dired-font-lock-keywords) (dired-insert-directory, dired--insert-disk-space, dired-mode): * lisp/dnd.el (dnd-handle-multiple-urls): * lisp/dom.el (dom-remove-attribute): * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): * lisp/emacs-lisp/bytecomp.el (bytecomp--custom-declare): * lisp/emacs-lisp/comp-common.el (comp-function-type-spec): * lisp/emacs-lisp/comp-cstr.el (comp--all-classes) (comp-cstr-set-range-for-arithm, comp--cstr-union-1-no-mem) (comp-cstr-intersection-no-mem, comp-cstr-fixnum-p) (comp-cstr-type-p): * lisp/emacs-lisp/comp-run.el (comp-subr-trampoline-install) (native--compile-async): * lisp/emacs-lisp/comp.el (comp--get-function-cstr) (comp--function-pure-p, comp--intern-func-in-ctxt) (comp--addr-to-bb-name, comp--emit-assume, comp--maybe-add-vmvar) (comp--add-call-cstr, comp--compute-dominator-tree) (comp--dom-tree-walker, comp--ssa-rename) (comp--function-call-maybe-fold, comp--fwprop-call) (comp--call-optim-func): * lisp/emacs-lisp/edebug.el (edebug-global-prefix) (edebug-remove-instrumentation): * lisp/emacs-lisp/eieio.el (initialize-instance): * lisp/emacs-lisp/ert-x.el (ert-resource-directory): * lisp/emacs-lisp/ert.el (ert--expand-should-1) (ert-test-location, ert-write-junit-test-report) (ert-test--erts-test): * lisp/emacs-lisp/icons.el (icon-complete-spec, icon-string) (icons--create): * lisp/emacs-lisp/lisp-mode.el (lisp--local-defform-body-p): * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate--make-autoload) (loaddefs-generate--parse-file): * lisp/emacs-lisp/multisession.el (multisession-edit-mode--revert, multisession-edit-value): * lisp/emacs-lisp/package-vc.el (package-vc--read-archive-data) (package-vc--version, package-vc--clone): * lisp/emacs-lisp/package.el (package--reload-previously-loaded): * lisp/emacs-lisp/pp.el (pp--insert-lisp): * lisp/emacs-lisp/subr-x.el (add-display-text-property): * lisp/emacs-lisp/tabulated-list.el (tabulated-list-print): * lisp/emacs-lisp/timer.el (run-at-time): * lisp/emacs-lisp/vtable.el (vtable-goto-table) (vtable-goto-column, vtable-update-object, vtable--insert-line) (vtable--compute-widths, vtable--make-keymap): * lisp/emacs-lisp/warnings.el (display-warning): * lisp/epa-file.el (epa-file-insert-file-contents): * lisp/epa.el (epa-show-key): * lisp/erc/erc-backend.el (erc--split-line, erc--conceal-prompt) (PRIVMSG, erc--get-isupport-entry): * lisp/erc/erc-button.el (erc-button-add-nickname-buttons) (erc--button-next): * lisp/erc/erc-common.el (erc--find-group): * lisp/erc/erc-fill.el (erc-fill, erc-fill-static) (erc-fill--wrap-escape-hidden-speaker) (erc-fill--wrap-unmerge-on-date-stamp) (erc-fill--wrap-massage-initial-message-post-clear) (erc-fill-wrap, erc-fill--wrap-rejigger-region): * lisp/erc/erc-goodies.el (erc--scrolltobottom-all) (erc--keep-place-indicator-on-window-buffer-change) (keep-place-indicator, erc--keep-place-indicator-adjust-on-clear) (erc-keep-place-move, erc--command-indicator-display): * lisp/erc/erc-ibuffer.el (erc-members): * lisp/erc/erc-join.el (erc-join--remove-requested-channel) (erc-autojoin--join): * lisp/erc/erc-networks.el (erc-networks--id-qualifying-init-parts, erc-networks--id-reload) (erc-networks--id-ensure-comparable) (erc-networks--reclaim-orphaned-target-buffers) (erc-networks--server-select): * lisp/erc/erc-nicks.el (erc-nicks-invert) (erc-nicks--redirect-face-widget-link, erc-nicks--highlight) (erc-nicks--highlight-button) (erc-nicks--list-faces-help-button-action, erc-nicks-list-faces) (erc-nicks-refresh, erc-nicks--colors-from-faces) (erc-nicks--track-prioritize) (erc-nicks--remember-face-for-track): * lisp/erc/erc-notify.el (querypoll, erc--querypoll-get-next) (erc--querypoll-on-352, erc--querypoll-send): * lisp/erc/erc-sasl.el (erc-sasl--read-password): * lisp/erc/erc-services.el (erc-services-issue-ghost-and-retry-nick): * lisp/erc/erc-speedbar.el (erc-speedbar--ensure, nickbar) (erc-speedbar-toggle-nicknames-window-lock) (erc-speedbar--compose-nicks-face): * lisp/erc/erc-stamp.el (erc-stamp--recover-on-reconnect) (erc-stamp-prefix-log-filter, erc--conceal-prompt) (erc--insert-timestamp-left, erc-insert-timestamp-right) (erc-stamp--defer-date-insertion-on-post-modify) (erc-insert-timestamp-left-and-right) (erc-stamp--redo-right-stamp-post-clear) (erc-stamp--reset-on-clear, erc-stamp--dedupe-date-stamps): * lisp/erc/erc-status-sidebar.el (bufbar) (erc-status-sidebar-prefer-target-as-name) (erc-status-sidebar-default-allsort, erc-status-sidebar-click): * lisp/erc/erc-track.el (erc-track--shortened-names-get) (erc-track--setup, erc-track--select-mode-line-face) (erc-track-modified-channels, erc-track--collect-faces-in) (erc-track--switch-buffer, erc-track--replace-killed-buffer): * lisp/erc/erc-truncate.el (erc-truncate--setup) (erc-truncate-buffer): * lisp/erc/erc.el (erc--ensure-query-member) (erc--ensure-query-members, erc--remove-channel-users-but) (erc--cusr-change-status, erc--find-mode, erc--update-modules) (erc-log-irc-protocol, erc--refresh-prompt) (erc--restore-important-text-props) (erc--order-text-properties-from-hash, erc-send-input-line) (erc-cmd-IGNORE, erc--unignore-user, erc-cmd-QUERY) (erc-cmd-BANLIST, erc--speakerize-nick) (erc--format-speaker-input-message, erc-channel-receive-names) (erc-send-current-line, erc-format-target-and/or-network) (erc-kill-buffer-function, erc-restore-text-properties) (erc--get-eq-comparable-cmd): * lisp/eshell/em-alias.el (eshell-maybe-replace-by-alias--which) (eshell-maybe-replace-by-alias): * lisp/eshell/em-glob.el (eshell-glob-convert): * lisp/eshell/em-pred.el (eshell-pred-user-or-group) (eshell-pred-file-time, eshell-pred-file-type) (eshell-pred-file-mode, eshell-pred-file-links) (eshell-pred-file-size): * lisp/eshell/em-prompt.el (eshell-forward-paragraph) (eshell-next-prompt): * lisp/eshell/esh-arg.el (eshell-resolve-current-argument): * lisp/eshell/esh-cmd.el (eshell-do-eval, eshell/which) (eshell-plain-command--which, eshell-plain-command): * lisp/eshell/esh-io.el (eshell-duplicate-handles) (eshell-protect-handles, eshell-get-target, eshell-close-target): * lisp/eshell/esh-proc.el (eshell-sentinel): * lisp/eshell/esh-var.el (eshell-parse-variable-ref) (eshell-get-variable, eshell-set-variable): * lisp/faces.el (face-at-point): * lisp/ffap.el (ffap-in-project): * lisp/filenotify.el (file-notify--rm-descriptor): * lisp/files-x.el (read-dir-locals-file) (connection-local-update-profile-variables) (connection-local-value): * lisp/files.el (file-remote-p, abbreviate-file-name) (set-auto-mode, hack-local-variables) (revert-buffer-restore-read-only): * lisp/find-dired.el (find-dired-sort-by-filename): * lisp/font-lock.el (font-lock--filter-keywords): * lisp/gnus/gnus-art.el (article-emojize-symbols): * lisp/gnus/gnus-int.el (gnus-close-server): * lisp/gnus/gnus-search.el (gnus-search-transform) (gnus-search-indexed-parse-output, gnus-search-server-to-engine): * lisp/gnus/gnus-sum.el (gnus-collect-urls, gnus-shorten-url): * lisp/gnus/gnus.el (gnus-check-backend-function): * lisp/gnus/message.el (message-send-mail): * lisp/gnus/mml.el (mml-generate-mime, mml-insert-mime-headers): * lisp/gnus/nnatom.el (nnatom--read-feed, nnatom--read-article) (nnatom--read-article-or-group-authors, nnatom--read-publish) (nnatom--read-update, nnatom--read-links): * lisp/gnus/nnfeed.el (nnfeed--read-server, nnfeed--write-server) (nnfeed--parse-feed, nnfeed--group-data, nnfeed-retrieve-article) (nnfeed-retrieve-headers, nnfeed--print-part) (nnfeed-request-article, nnfeed-request-group) (nnfeed-request-list, nnfeed--group-description) (nnfeed-request-group-description) (nnfeed-request-list-newsgroups, nnfeed-request-rename-group): * lisp/gnus/nnmh.el (nnmh-update-gnus-unreads): * lisp/help-fns.el (help-find-source) (help-fns--insert-menu-bindings, help-fns--mention-first-release) (help-fns--mention-shortdoc-groups) (help-fns--customize-variable-version) (help-fns--face-custom-version-info, describe-mode): * lisp/help-mode.el (help-make-xrefs): * lisp/help.el (help-key-description, help--describe-command): * lisp/hfy-cmap.el (htmlfontify-load-rgb-file): * lisp/ibuf-ext.el (ibuffer-jump-to-filter-group) (ibuffer-kill-filter-group, ibuffer-kill-line) (ibuffer-save-filter-groups, ibuffer-save-filters, filename) (basename, file-extension, ibuffer-diff-buffer-with-file-1) (ibuffer-mark-by-file-name-regexp) (ibuffer-mark-by-content-regexp): * lisp/ibuf-macs.el (ibuffer-aif, ibuffer-awhen): * lisp/ibuffer.el (ibuffer-mouse-toggle-mark) (ibuffer-toggle-marks, ibuffer-mark-interactive) (ibuffer-compile-format, process, ibuffer-map-lines): * lisp/image.el (image--compute-map) (image--compute-original-map): * lisp/image/exif.el (exif-parse-buffer): * lisp/image/image-converter.el (image-convert-p, image-convert) (image-converter--find-converter): * lisp/image/image-dired-util.el (image-dired-file-name-at-point): * lisp/image/image-dired.el (image-dired-track-original-file) (image-dired--on-file-in-dired-buffer) (image-dired--with-thumbnail-buffer) (image-dired-jump-original-dired-buffer) (image-dired--slideshow-step, image-dired-display-image): * lisp/image/wallpaper.el (wallpaper--init-action-kill) (wallpaper--find-setter, wallpaper--find-command) (wallpaper--find-command-args, wallpaper--x-monitor-name): * lisp/info-look.el (info-lookup-interactive-arguments) (info-complete)::(:mode): * lisp/info.el (info-pop-to-buffer, Info-read-node-name-1): * lisp/international/emoji.el (emoji--adjust-displayable-1) (emoji--add-recent): * lisp/jsonrpc.el (jsonrpc--call-deferred) (jsonrpc--process-sentinel, jsonrpc--remove): * lisp/keymap.el (keymap-local-lookup): * lisp/mail/emacsbug.el (report-emacs-bug-hook) (submit-emacs-patch): * lisp/mail/ietf-drums.el (ietf-drums-parse-addresses): * lisp/mail/mailclient.el (mailclient-send-it): * lisp/mail/rfc6068.el (rfc6068-parse-mailto-url): * lisp/mail/undigest.el (rmail-digest-parse-mixed-mime): * lisp/minibuffer.el (completion-metadata-get) (completions--after-change) (minibuffer-visible-completions--filter): * lisp/net/browse-url.el (browse-url-url-at-point) (browse-url-file-url, browse-url-emacs): * lisp/net/dbus.el (dbus-byte-array-to-string) (dbus-monitor-goto-serial): * lisp/net/dictionary.el (dictionary-search): * lisp/net/eww.el (eww--download-directory) (eww-auto-rename-buffer, eww-open-in-new-buffer, eww-submit) (eww-follow-link, eww-read-alternate-url) (eww-copy-alternate-url): * lisp/net/goto-addr.el (goto-address-at-point): * lisp/net/mailcap.el (mailcap-mime-info): * lisp/net/rcirc.el (rcirc, rcirc-connect, rcirc-send-string) (rcirc-kill-buffer-hook, rcirc-print, rcirc-when) (rcirc-color-attributes, rcirc-handler-NICK) (rcirc-handler-TAGMSG, rcirc-handler-BATCH): * lisp/net/shr.el (shr-descend, shr-adaptive-fill-function) (shr-correct-dom-case, shr-tag-a): * lisp/net/sieve.el (sieve-manage-quit): * lisp/outline.el (outline-cycle-buffer): * lisp/pcmpl-git.el (pcmpl-git--tracked-file-predicate): * lisp/proced.el (proced-auto-update-timer): * lisp/progmodes/bug-reference.el (bug-reference-try-setup-from-vc): * lisp/progmodes/c-ts-common.el (c-ts-common--fill-paragraph): * lisp/progmodes/c-ts-mode.el (c-ts-mode--preproc-offset) (c-ts-mode--anchor-prev-sibling, c-ts-mode-indent-defun): * lisp/progmodes/compile.el (compilation-error-properties) (compilation-find-file-1): * lisp/progmodes/eglot.el (eglot--check-object) (eglot--read-server, eglot-upgrade-eglot) (eglot-handle-notification, eglot--CompletionParams) (eglot-completion-at-point, eglot--sig-info) (eglot-register-capability): * lisp/progmodes/elisp-mode.el (emacs-lisp-native-compile-and-load) (elisp-eldoc-var-docstring-with-value): * lisp/progmodes/erts-mode.el (erts-mode--goto-start-of-test): * lisp/progmodes/flymake.el (flymake--update-eol-overlays) (flymake-eldoc-function): * lisp/progmodes/gdb-mi.el (gdb-breakpoints-list-handler-custom) (gdb-frame-handler): * lisp/progmodes/go-ts-mode.el (go-ts-mode-docstring) (go-ts-mode--comment-on-previous-line-p) (go-ts-mode--get-test-regexp-at-point) (go-ts-mode-test-this-file): * lisp/progmodes/grep.el (lgrep, rgrep-default-command) (grep-file-at-point): * lisp/progmodes/perl-mode.el (perl--end-of-format-p): * lisp/progmodes/php-ts-mode.el (php-ts-mode--anchor-prev-sibling, php-ts-mode--indent-defun): * lisp/progmodes/project.el (project--other-place-command) (project--find-default-from, project--transplant-file-name) (project-prefixed-buffer-name, project--remove-from-project-list) (project-prompt-project-name, project-remember-projects-under) (project--switch-project-command) (project-uniquify-dirname-transform, project-mode-line-format): * lisp/progmodes/python.el (python-font-lock-keywords-maximum-decoration) (python--treesit-fontify-union-types) (python-shell-get-process-name, python-shell-restart) (python-shell-completion-at-point, python-ffap-module-path) (python-util-comint-end-of-output-p, python--import-sources) (python-add-import, python-remove-import, python-fix-imports): * lisp/progmodes/xref.el (xref--add-log-current-defun): * lisp/repeat.el (repeat-echo-message-string): * lisp/saveplace.el (save-place-dired-hook): * lisp/server.el (server-save-buffers-kill-terminal): * lisp/shadowfile.el (shadow-make-fullname) (shadow-contract-file-name, shadow-define-literal-group): * lisp/shell.el (shell-highlight-undef-mode): * lisp/simple.el (command-completion-using-modes-p) (command-execute, file-user-uid, file-group-gid) (first-completion, last-completion, switch-to-completions): * lisp/startup.el (startup--load-user-init-file): * lisp/tab-line.el (tab-line-tabs-buffer-group-by-project): * lisp/tar-mode.el (tar-goto-file, tar-next-file-displayer): * lisp/term/android-win.el (android-encode-select-string) (gui-backend-set-selection): * lisp/term/haiku-win.el (haiku-dnd-convert-string) (haiku-select-encode-xstring, haiku-select-encode-utf-8-string): * lisp/textmodes/emacs-news-mode.el (emacs-news--buttonize): * lisp/textmodes/ispell.el (ispell-completion-at-point): * lisp/textmodes/sgml-mode.el (sgml-validate) (html-mode--complete-at-point): * lisp/textmodes/tex-mode.el (tex-recenter-output-buffer) (xref-backend-references): * lisp/thingatpt.el (thing-at-point-file-at-point) (thing-at-point-face-at-point): * lisp/thread.el (thread-list--get-status): * lisp/time.el (world-clock-copy-time-as-kill, world-clock): * lisp/touch-screen.el (touch-screen-handle-touch): * lisp/treesit.el (treesit-language-at, treesit-node-at) (treesit-node-on, treesit-buffer-root-node) (treesit-node-field-name, treesit-local-parsers-at) (treesit-local-parsers-on, treesit--cleanup-local-range-overlays) (treesit-font-lock-recompute-features) (treesit-font-lock-fontify-region, treesit-transpose-sexps) (treesit-add-log-current-defun, treesit-major-mode-setup) (treesit--explorer-refresh, treesit-install-language-grammar): * lisp/url/url.el (url-retrieve-synchronously): * lisp/vc/smerge-mode.el (smerge-diff): * lisp/vc/vc-dir.el (vc-dir): * lisp/vc/vc-dispatcher.el (vc-do-async-command): * lisp/vc/vc-git.el (vc-git-dir--branch-headers) (vc-git-dir--stash-headers, vc-git--log-edit-summary-check) (vc-git-stash-list): * lisp/vc/vc.el (vc-responsible-backend, vc-buffer-sync-fileset) (vc-clone): * lisp/visual-wrap.el (visual-wrap--apply-to-line): * lisp/wid-edit.el (widget-text) (widget-editable-list-insert-before): * lisp/window-tool-bar.el (window-tool-bar--keymap-entry-to-string): * lisp/window.el (display-buffer, display-buffer-full-frame) (window-point-context-set, window-point-context-use) (window-point-context-use-default-function): * lisp/xdg.el (xdg-current-desktop): * lisp/xwidget.el (xwidget-webkit-callback): * lisp/yank-media.el (yank-media--get-selection) (yank-media-types): * test/lisp/comint-tests.el (comint-tests/test-password-function): * test/lisp/completion-preview-tests.el (completion-preview-tests--capf): * test/lisp/cus-edit-tests.el (with-cus-edit-test): * test/lisp/erc/erc-scenarios-base-local-modules.el (-phony-sblm-): * test/lisp/erc/erc-scenarios-stamp.el (erc-scenarios-stamp--on-post-modify): * test/lisp/erc/erc-services-tests.el (erc-services-tests--asp-parse-entry): * test/lisp/erc/erc-tests.el (erc-modules--internal-property) (erc--find-mode, erc-tests--update-modules): * test/lisp/erc/resources/erc-d/erc-d-i.el (erc-d-i--parse-message): * test/lisp/erc/resources/erc-d/erc-d-t.el (erc-d-t-kill-related-buffers, erc-d-t-with-cleanup): * test/lisp/erc/resources/erc-d/erc-d-tests.el (erc-d-i--parse-message--irc-parser-tests): * test/lisp/erc/resources/erc-d/erc-d-u.el (erc-d-u--read-exchange-slowly): * test/lisp/erc/resources/erc-d/erc-d.el (erc-d--expire) (erc-d--finalize-done, erc-d--command-handle-all): * test/lisp/erc/resources/erc-scenarios-common.el (erc-scenarios-common-with-cleanup): * test/lisp/erc/resources/erc-tests-common.el (erc-tests--common-display-message) (erc-tests-common-create-subprocess): * test/lisp/ibuffer-tests.el (ibuffer-test-Bug25058): * test/lisp/international/mule-tests.el (mule-cmds-tests--ucs-names-missing-names): * test/lisp/progmodes/python-tests.el (python-tests-get-shell-interpreter) (python-tests--get-interpreter-info): * test/lisp/progmodes/ruby-ts-mode-tests.el (ruby-ts-resource-file): * test/lisp/replace-tests.el (replace-tests-with-undo): * test/src/emacs-tests.el (emacs-tests--seccomp-debug): * test/src/process-tests.el (process-tests--emacs-command) (process-tests--emacs-binary, process-tests--dump-file): * test/src/treesit-tests.el (treesit--ert-test-defun-navigation): Replace use of the now-obsolete if-let and when-let. 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 "" ; to-address 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/etc/NEWS b/etc/NEWS index a6c2c895985..64e4f22b9d3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -641,6 +641,13 @@ 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. + * Lisp Changes in Emacs 31.1 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/autorevert.el b/lisp/autorevert.el index 94082df4502..8ffe7f07cee 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -643,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 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/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/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/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 625de019d3b..f79a2220bea 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -861,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))) @@ -1741,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 @@ -1863,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) @@ -2803,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 @@ -2811,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))))) 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/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/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 96341b0a39f..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 (_) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index deebe5109bd..b96d2437b8a 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3922,8 +3922,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 +4659,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 "\n") (insert (format "\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..1ac7aecdb66 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'. 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/package-vc.el b/lisp/emacs-lisp/package-vc.el index e168096e153..894bc9c8c37 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -247,8 +247,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 +279,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 @@ -663,7 +663,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..."))))) 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/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..2427d76734e 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -475,7 +475,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..925961f012c 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -271,7 +271,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 +279,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 +311,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)) @@ -638,7 +638,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)))))))) @@ -865,13 +865,13 @@ If NEXT, do the next column." (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))))) + (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))))) + (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)) @@ -904,7 +904,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-networks.el b/lisp/erc/erc-networks.el index a5ca05b137a..75de68a284c 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -904,8 +904,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 +986,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 +1002,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 @@ -1387,9 +1387,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) @@ -1593,7 +1593,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..e2cbe613d99 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 (symbol-name (erc-networks--id-symbol 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-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..bf049242443 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 @@ -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..18cc4071b48 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) @@ -2395,12 +2395,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 +2418,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,8 +3063,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))) + (let ((esid (if-let* ((erc-networks--id) + (esid (erc-networks--id-symbol erc-networks--id))) (symbol-name esid) (or erc-server-announced-name (format "%s:%s" erc-session-server erc-session-port)))) @@ -3297,10 +3297,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 +3677,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 +3790,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 +4132,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 +4430,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 +4442,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 +4477,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 @@ -5249,7 +5249,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 +5654,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 +6386,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 +6554,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 +7194,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 +8190,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 +9187,12 @@ 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-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))))) (concat (erc--target-string erc--target) "@" name) (buffer-name))) @@ -9773,8 +9773,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 +9829,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 +9858,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-glob.el b/lisp/eshell/em-glob.el index 42373b8b8c0..f4337872a8e 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -306,8 +306,8 @@ 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)))) + (if-let* ((recurse (cdr (assoc (car globs) + eshell-glob-recursive-alist)))) (if last-saw-recursion (setcar result recurse) (push recurse result) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index a9274e7c60d..053ebf91dab 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -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..de62b5c7d97 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -178,8 +178,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 +212,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/esh-arg.el b/lisp/eshell/esh-arg.el index 4ea25f7f202..ebecb279753 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -292,8 +292,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 diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 137abe6eb75..a8a19d2bcc9 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -1317,8 +1317,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 +1341,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 +1407,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 +1419,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))) 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-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-var.el b/lisp/eshell/esh-var.el index e3ff76abc26..dc0bc4532de 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -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))))) @@ -676,7 +676,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)) @@ -715,7 +715,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) 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..c55164235df 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -552,7 +552,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 +784,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 +959,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 6fc9ae2f1a2..114ddc9c259 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1340,7 +1340,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 @@ -2196,7 +2196,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))) @@ -3531,7 +3531,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) @@ -4160,7 +4160,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)))))) @@ -6938,8 +6938,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))))) 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-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 8ecf7a33305..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)))) 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 "[%s] " 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 "[%s] " 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 "[%s] " 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..1617afdcd6e 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. 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..1ad1677c6ce 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -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/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..44d07557f48 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))))) @@ -3192,7 +3192,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))) 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 6559c7e5eb9..7bbbeadaedd 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -79,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)) @@ -244,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 @@ -625,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)) @@ -2070,7 +2070,7 @@ 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 @@ -2186,7 +2186,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) @@ -2906,9 +2906,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)))) @@ -2952,7 +2952,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..3e847c758c2 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))) 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..4869969f463 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)))))) 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/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/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..4fb61c4ba13 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 "//")))) diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 0c2da768833..1b041a0192b 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))) 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..62f1045a512 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 () @@ -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/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/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 6e6d421110c..e1976144a94 100644 --- a/lisp/progmodes/php-ts-mode.el +++ b/lisp/progmodes/php-ts-mode.el @@ -591,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)) @@ -1224,8 +1224,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))) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 5062021f8a6..4a8afb80b25 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -926,7 +926,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))))) @@ -1075,8 +1075,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))) @@ -1167,7 +1167,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)))) @@ -1443,7 +1443,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))) @@ -1870,7 +1870,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))) @@ -1931,8 +1931,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))) @@ -2029,10 +2029,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) @@ -2180,8 +2180,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) @@ -2238,7 +2238,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 @@ -2273,7 +2273,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..283a545bfb4 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -808,7 +808,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 @@ -1153,7 +1153,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 +3264,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 +3788,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 +4845,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 +5521,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 +6537,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 +6817,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 +6930,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 +6955,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 +6998,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..cc06e06ef78 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)))) 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..2ffd6e86e56 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) @@ -10491,10 +10491,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/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 9113235ca5d..e630087b68f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2623,8 +2623,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))) @@ -2637,8 +2646,10 @@ 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*)) @@ -2665,21 +2676,10 @@ for forms evaluated for side-effect with returned values ignored." (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)])] @@ -2699,6 +2699,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. 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/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/sgml-mode.el b/lisp/textmodes/sgml-mode.el index ee585896946..cc86294df09 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -1205,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) @@ -2436,14 +2436,14 @@ To work around that, do: (defun html-mode--complete-at-point () ;; Complete a tag like %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/smerge-mode.el b/lisp/vc/smerge-mode.el index 13258b15845..e6bfc5e64f3 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -1244,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..634b6fe1555 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)) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index f2dc584bba9..ff0bc68e2d4 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -737,14 +737,14 @@ or an empty string if none." (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)") @@ -877,7 +877,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) @@ -1051,19 +1051,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" @@ -2229,7 +2229,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (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 f64fd55f6a8..6498b8522fd 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -1058,8 +1058,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" @@ -2174,7 +2174,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))))) @@ -3834,9 +3834,9 @@ cloning; the syntax of REV depends on what BACKEND accepts." (catch 'ok (dolist (backend vc-handled-backends) (ignore-error vc-not-supported - (when-let ((res (vc-call-backend - backend 'clone - remote directory rev))) + (when-let* ((res (vc-call-backend + backend 'clone + remote directory rev))) (throw 'ok res))))))) (declare-function log-view-current-tag "log-view" (&optional pos)) diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el index fa128d287a4..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 diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 1d47f80b0dd..6fbf6257232 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1042,8 +1042,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 +2942,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..6655bb705ef 100644 --- a/lisp/yank-media.el +++ b/lisp/yank-media.el @@ -81,7 +81,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 +116,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/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/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/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/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/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) commit 698d75a3355673773c095081c0000e52c36f93f0 Merge: ec9eecbe91e eae798486a9 Author: Sean Whitton Date: Thu Oct 24 12:13:20 2024 +0800 Merge from origin/emacs-30 eae798486a9 Update special conditionals documentation commit ec9eecbe91e6f4c40813bb221c9247053efcf1a8 Merge: 95f89c736fd 75584a3a961 Author: Sean Whitton Date: Thu Oct 24 12:13:20 2024 +0800 ; Merge from origin/emacs-30 The following commit was skipped: 75584a3a961 ; * test/lisp/proced-tests.el (proced--within-buffer): In... commit 95f89c736fd80f27e586127009880f89a77adb3b Merge: 3bb1b85b78b f5451b6a066 Author: Sean Whitton Date: Thu Oct 24 12:13:20 2024 +0800 Merge from origin/emacs-30 f5451b6a066 ; Improve comment from last change 09e05f7ee4d Document and-let* vs. when-let* usage convention b7a375f5c49 Fix error when splicing Eshell globs and a glob expands t... 2289e162268 * etc/package-keyring.gpg: Update expiration and add new key 48024096fea Avoid crashes when scrolling images under winner-mode c35d6ba9f07 ; * doc/lispref/display.texi (Fontsets): Clarify wording. 88a1a32fc57 ; * doc/lispref/display.texi (Fontsets): Fix typo. 6be47058cd7 ; Add indexing for 'use-default-font-for-symbols' 681f70ea04a * src/lread.c (READ_AND_BUFFER): Reject negative chars (b... ac4151e0023 * test/Makefile.in: Do not show emacs-module-tests.log by... 4e0cb960dbd Fix 'php-ts-mode': better indentation and font locking commit eae798486a965ec176bef3cc343625c164986c3f Author: Sean Whitton Date: Thu Oct 24 12:10:09 2024 +0800 Update special conditionals documentation * doc/lispref/control.texi (Conditionals): Document if-let* and when-let*, not if-let and when-let. Document and-let*. diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 58063ecf8db..5ccc8462c9e 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-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 commit 3bb1b85b78b8079e160dcb10774fe82c2daa1b4d Author: Sean Whitton Date: Thu Oct 24 11:26:27 2024 +0800 vc-allow-rewriting-published-history: Use nil->ask->t * lisp/vc/vc.el (vc-allow-rewriting-published-history): Use increasingly permissive values nil->ask->t rather than nil->t->no-ask. Recommend `ask' or nil. * lisp/vc/vc-git.el (vc-git--assert-allowed-rewrite): Update accordingly. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 899358339f3..f2dc584bba9 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1966,7 +1966,8 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." "log" "--max-count=1" "--pretty=format:%B" rev))) (defun vc-git--assert-allowed-rewrite (rev) - (when (and (not (eq vc-allow-rewriting-published-history 'no-ask)) + (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" @@ -1978,7 +1979,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." "--pretty=format:%H" "@{upstream}..HEAD"))))) (unless (or (cl-member rev outgoing :test #'string-prefix-p) - (and vc-allow-rewriting-published-history + (and (eq vc-allow-rewriting-published-history 'ask) (yes-or-no-p (format "Commit %s appears published; allow rewriting history?" rev)))) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 97b05362d8c..f64fd55f6a8 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -931,12 +931,17 @@ 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 a non-nil value, -Emacs will instead prompt you to confirm that you really want to perform -the rewrite. A value of `no-ask' means to proceed with no prompting." +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" t) - (const :tag "Allow without prompting" no-ask)) + (const :tag "Prompt to allow" ask) + (const :tag "Allow without prompting" t)) :version "31.1") commit bc8f416ee97795e77a36d6dd25a2a037bdc4a5c4 Author: Dmitry Gutov Date: Wed Oct 23 22:49:13 2024 +0300 ; Update the NEWS entry to mention project-prompter correctly diff --git a/etc/NEWS b/etc/NEWS index f7ad41b1b9f..a6c2c895985 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -137,9 +137,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 commit efaec5f61df967e2a4b85c5607f559f92f220ca9 Author: Dmitry Gutov Date: Wed Oct 23 22:43:18 2024 +0300 project-prompter: Update the docstring for the recent change * lisp/progmodes/project.el (project-prompter): Update the docstring too (bug#70833). diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 3cdaa7c2a76..5062021f8a6 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" commit 75584a3a9614541478cf05edc6223de8db3d350c Author: Michael Albinus Date: Wed Oct 23 17:01:08 2024 +0200 ; * test/lisp/proced-tests.el (proced--within-buffer): Instrument macro. Do not merge with master diff --git a/test/lisp/proced-tests.el b/test/lisp/proced-tests.el index 6f16a241146..682c1328549 100644 --- a/test/lisp/proced-tests.el +++ b/test/lisp/proced-tests.el @@ -28,11 +28,13 @@ `(let ((proced-format ,format) (proced-filter ,filter) (proced-auto-update-flag nil) - (inhibit-message t)) + (inhibit-message (not (getenv "EMACS_EMBA_CI")))) (proced) (unwind-protect (with-current-buffer "*Proced*" ,@body) + (with-current-buffer "*Proced*" + (message "%s" (buffer-string))) (kill-buffer "*Proced*")))) (defun proced--assert-emacs-pid-in-buffer () commit 5e5689a2a40cd16d7593a0c7ddea5511adc3bf22 Author: Alan Coopersmith Date: Wed Oct 23 15:41:08 2024 +0200 configure.ac: Fix FIONREAD check with gcc-14 on Solaris Before this fix, it would fail to build with gcc-14 with the error: conftest.c: In function 'main': conftest.c:265:11: error: implicit declaration of function 'ioctl' [-Wimplicit-function-declaration] 265 | int foo = ioctl (0, FIONREAD, &foo); | ^~~~~ Solaris documents ioctl() as being defined in . * configure.ac: Fix FIONREAD check with gcc-14 on Solaris. Ref: https://lists.gnu.org/r/emacs-devel/2024-10/msg00195.html Copyright-paperwork-exempt: yes diff --git a/configure.ac b/configure.ac index 8a5ba7db3d1..947c2827b8e 100644 --- a/configure.ac +++ b/configure.ac @@ -7117,6 +7117,9 @@ AC_CACHE_CHECK([for usable FIONREAD], [emacs_cv_usable_FIONREAD], #ifdef USG5_4 # include #endif + #ifdef HAVE_UNISTD_H + # include /* defines ioctl() on Solaris */ + #endif ]], [[int foo = ioctl (0, FIONREAD, &foo);]])], [emacs_cv_usable_FIONREAD=yes], commit c037b253975da883594f10f48e0be53d81a32756 Author: Eli Zaretskii Date: Wed Oct 23 10:00:45 2024 +0300 ; Improve documentation of 'native-compile-directory' (bug#73303) * lisp/emacs-lisp/comp.el (native-compile-directory): Doc fix. * doc/lispref/compile.texi (Native-Compilation Functions): Document 'native-compile-directory'. * etc/NEWS: Improve wording. 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/etc/NEWS b/etc/NEWS index 5b7868e8720..f7ad41b1b9f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -646,8 +646,8 @@ sup-mouse.el, terminal.el, vi.el, vip.el, ws-mode.el, and yow.el. --- ** New function 'native-compile-directory'. -This function native compiles all Lisp files in a directory and in its -sub-directories (if they are not already native compiled). +This function natively-compiles all Lisp files in a directory and in its +sub-directories, recursively, which were not already natively-compiled. +++ ** The 'defcustom' ':local' keyword can now be 'permanent-only'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8866f47aa66..96341b0a39f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3665,9 +3665,9 @@ the compilation was successful return the compiled function." ;;;###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 inside the current `native-comp-eln-load-path'. The search within -DIRECTORY is perfomed recursively." +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))) commit e756d4373bdf1b076ee284c46637855908dd10d7 Author: Sean Whitton Date: Wed Oct 23 10:57:40 2024 +0800 ; vc-git-modify-change-comment: Restore ignoring --amend This was accidentally lost when installing this new feature on master. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index e039133ede5..899358339f3 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1986,7 +1986,8 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defun vc-git-modify-change-comment (files rev comment) (vc-git--assert-allowed-rewrite rev) - (let* ((args (vc-git--log-edit-extract-headers comment)) + (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 commit f5451b6a0668f4dc9992562b62ed37a199f1fdad Author: Sean Whitton Date: Wed Oct 23 10:53:02 2024 +0800 ; Improve comment from last change diff --git a/lisp/subr.el b/lisp/subr.el index d1b2a1efe6e..0acc24042f8 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2654,8 +2654,9 @@ 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 partially explains why we - ;; have both `when-let*' and `and-let*'. + ;; ^ 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 commit c259db1d454a27cc79217f4740b1ecdb4bb28114 Author: Sean Whitton Date: Wed Oct 23 10:49:22 2024 +0800 vc-git-modify-change-comment: Check for other autosquashing * lisp/vc/vc-git.el (vc-git-modify-change-comment): Check that a rebase with --autosquash won't make any other changes and give the user a chance to abort. diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 6d8cca07e37..e039133ede5 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -2010,6 +2010,22 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." ;; 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 commit 87766c88d5f343017972558d364eff024884f71a Author: Sean Whitton Date: Wed Oct 23 09:36:41 2024 +0800 ; Insert missing quotation in FIXME diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index da3f766cf32..a54854a7016 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -560,7 +560,7 @@ If called interactively, visit the version at point." ;; 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, + ;; 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 commit 00149f18ea90c0c1dae525581ef4924201336be3 Author: Sean Whitton Date: Fri Oct 18 17:19:45 2024 +0800 Support modifying VC change comments for Git * lisp/vc/vc.el (vc-allow-rewriting-published-history): New option. * lisp/vc/vc-git.el (vc-git--assert-allowed-rewrite) (vc-git-modify-change-comment): New functions (bug#64055). (vc-git--current-branch): Factor out of vc-git-dir--branch-headers. (vc-git--log-edit-extract-headers): Factor out of vc-git-checkin. * etc/NEWS: Announce the new support and option. diff --git a/etc/NEWS b/etc/NEWS index 63c294fac41..5b7868e8720 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -600,6 +600,20 @@ 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. +** VC + +--- +*** Using 'e' from Log View mode to modify change comments now works for Git. + +--- +*** New user option 'vc-allow-rewriting-published-history'. +Many VCS commands can change your copy of published change history +without warning. If VC commands detect that this could happen, they +will stop. You can customize this variable to permit rewriting history +even though Emacs thinks it is dangerous. + +So far, this applies only to using 'e' from Log View mode for Git. + * New Modes and Packages in Emacs 31.1 diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 783f58575dc..da3f766cf32 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -558,8 +558,8 @@ If called interactively, visit the version at point." ;; See discussion in bug#64055. --spwhitton ;; ;; FIXME: We should implement backend actions - ;; `get-change-comment' and `modify-change-comment' for Git, - ;; bzr and Hg, so that this command works for those backends. + ;; `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 diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index f77bf0cc5ff..6d8cca07e37 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -728,11 +728,13 @@ 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 @@ -1082,6 +1084,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 +1193,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"))) @@ -1960,6 +1965,70 @@ 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 (eq vc-allow-rewriting-published-history 'no-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 vc-allow-rewriting-published-history + (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 (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")) + (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] diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 9fb1fc6c4a4..97b05362d8c 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -914,6 +914,31 @@ 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 a non-nil value, +Emacs will instead prompt you to confirm that you really want to perform +the rewrite. A value of `no-ask' means to proceed with no prompting." + :type '(choice (const :tag "Don't allow" nil) + (const :tag "Prompt to allow" t) + (const :tag "Allow without prompting" no-ask)) + :version "31.1") + ;; File property caching commit 09e05f7ee4de89f5f1dd95aa9498feccfa9a78d6 Author: Sean Whitton Date: Wed Oct 23 09:07:06 2024 +0800 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*. diff --git a/lisp/subr.el b/lisp/subr.el index 28ba30f584e..d1b2a1efe6e 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2640,14 +2640,22 @@ 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." +\(SYMBOL SOMETHING) specially. + +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 partially explains why we + ;; have both `when-let*' and `and-let*'. (declare (indent 1) (debug if-let*)) (let (res) (if varlist commit b7a375f5c49ac86399b9af7a6a74720ed294abd7 Author: Jim Porter Date: Tue Oct 22 09:43:00 2024 -0700 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. diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 36e4f90aed2..2aceaf188f3 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -348,7 +348,7 @@ regular expressions, and these cannot support the above constructs." ;; 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 + (if eshell-glob-splice-results (list glob) glob) (unwind-protect (apply #'eshell-glob-entries globs) (if message-shown diff --git a/test/lisp/eshell/em-glob-tests.el b/test/lisp/eshell/em-glob-tests.el index 2efb3a9df69..88e9cc73bbd 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 spliting, 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 commit 2289e162268b82d1d757c2354bf3fdf92316e91d Author: Stefan Monnier Date: Tue Oct 22 12:35:18 2024 -0400 * etc/package-keyring.gpg: Update expiration and add new key diff --git a/etc/package-keyring.gpg b/etc/package-keyring.gpg index 563acbb16b6..f88d60b2457 100644 Binary files a/etc/package-keyring.gpg and b/etc/package-keyring.gpg differ commit 246d68bd2a5468bd428a0406402e7ad2b3005314 Author: Andrea Corallo Date: Tue Oct 22 17:46:44 2024 +0200 Add 'native-compile-directory' (bug#73303) * lisp/emacs-lisp/comp.el (native-compile-directory): New function. * etc/NEWS (native-compile-directory): Add to NEWS. diff --git a/etc/NEWS b/etc/NEWS index 028e92c57c9..63c294fac41 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -630,6 +630,11 @@ sup-mouse.el, terminal.el, vi.el, vip.el, ws-mode.el, and yow.el. * Lisp Changes in Emacs 31.1 +--- +** New function 'native-compile-directory'. +This function native compiles all Lisp files in a directory and in its +sub-directories (if they are not already native compiled). + +++ ** The 'defcustom' ':local' keyword can now be 'permanent-only'. This means that the variable's 'permanent-local' property is set to t, diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fc87014202c..8866f47aa66 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3662,6 +3662,17 @@ the compilation was successful return the compiled function." (or native-comp-function string)))) (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 inside the current `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. commit 202adfcfcc2ed20fa91d8377107618c8113f7106 Author: Andrea Corallo Date: Tue Oct 22 16:40:12 2024 +0200 * Rework 'comp-lookup-eln' * lisp/emacs-lisp/comp.el (comp-lookup-eln): Rework to use 'comp-eln-load-path-eff'. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index f72d23fee1a..fc87014202c 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -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))) commit f58652a41978974855be0993d42ace225b64efed Author: Jim Porter Date: Tue Oct 22 08:36:23 2024 -0700 ; Fix a recent change to EWW * lisp/net/eww.el (eww--guess-content-type): Save excursion. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 4df9740d540..6559c7e5eb9 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -651,9 +651,10 @@ 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\"." - (or (run-hook-with-args-until-success - 'eww-guess-content-type-functions headers response-buffer) - "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. commit a9cf51d5f01cb7067c547af2905ab391979b18f4 Author: Stefan Monnier Date: Tue Oct 22 10:19:09 2024 -0400 * lisp/vc/smerge-mode.el (global-map): Mitigate bug#73544 diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index aad3e302826..13258b15845 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-x ^ 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) commit 9fdc03e8f9868bb9253a0df9bf0c1b718e8576a8 Author: Eli Zaretskii Date: Tue Oct 22 09:38:09 2024 +0300 ; Improve documentation of 'eww-guess-content-type-functions' * lisp/net/eww.el (eww-guess-content-type-functions): Doc fix. * etc/NEWS: Announce 'eww-guess-content-type-functions'. Bug#73133 diff --git a/etc/NEWS b/etc/NEWS index 3a8ee7ccacb..028e92c57c9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -317,6 +317,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 +++ diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 3cdb8a3f42e..4df9740d540 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -111,13 +111,14 @@ duplicate entries (if any) removed." (defcustom eww-guess-content-type-functions '(eww--html-if-doctype) - "List of functions used to guess a page's content-type. + "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 the -value to be used as Content-Type. They receive two parameters: an alist -of headers, and the buffer that holds the complete response. If the -list is exhausted, EWW assumes \"application/octet-stream\" per -RFC-9110." +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)) commit 9074a9f496b04ab58588b71f51d7830782fc7a29 Author: Sebastián Monía Date: Tue Oct 8 23:26:42 2024 -0400 Add customization to let EWW guess content-type if needed * lisp/net/eww.el (eww-guess-content-type-functions): New user option. (eww--guess-content-type, eww--html-if-doctype): New functions. (eww-render): Call 'eww--guess-content-type' (bug#73133). diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 63ad4ae78b7..3cdb8a3f42e 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -109,6 +109,19 @@ 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 to guess a page's content-type. +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 the +value to be used as Content-Type. They receive two parameters: an alist +of headers, and the buffer that holds the complete response. If the +list is exhausted, EWW assumes \"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" @@ -631,6 +644,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\"." + (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 + (let ((case-fold-search t) + (target + "\\|system +\\(\\\"\\|'\\)+about:legacy-compat\\)")) + (with-current-buffer response-buffer + (goto-char (point-min)) + ;; match basic and also legacy variants as + ;; specified in link above + (when (re-search-forward target nil t) + "text/html")))) + (defun eww--rename-buffer () "Rename the current EWW buffer. The renaming scheme is performed in accordance with @@ -660,7 +697,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 commit e7810ab99fde742f3864cd6e9b2c4b84700edcd7 Merge: 8a2fbddf17b 605f26cf70a Author: Stefan Monnier Date: Mon Oct 21 20:21:23 2024 -0400 Merge branch 'master' of git+ssh://git.sv.gnu.org/srv/git/emacs commit 8a2fbddf17b4beb31d19161769066a4c1bd8bab0 Author: Stefan Monnier Date: Mon Oct 21 20:21:10 2024 -0400 * lisp/files.el (require-with-check): Provide more info in the error message Rather than only show the "new" file to be loaded, show also the name of the currently loaded file, to clarify the conflict. diff --git a/lisp/files.el b/lisp/files.el index a5c34f1f88e..6fc9ae2f1a2 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1282,15 +1282,17 @@ NOERROR is equal to `reload'), or otherwise emit a warning." ((assoc fn load-history) 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)) @@ -4416,7 +4418,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 commit 605f26cf70ab3d7c5ea635c19cd2a280812a4ddc Author: Jim Porter Date: Mon Oct 21 14:21:50 2024 -0700 Fix a race condition when running Eshell startup scripts Previously, these scripts could run before all the Eshell modules had fully-initialized. * lisp/eshell/esh-mode.el (eshell-after-initialize-hook): New hook... (eshell-mode): ... run it. * lisp/eshell/em-script.el (eshell-run-startup-scripts): New function... (eshell-script-initialize): ... add it to 'eshell-after-initialize-hook'. * etc/NEWS: Announce 'eshell-after-initialize-hook'. diff --git a/etc/NEWS b/etc/NEWS index cfc5a8e1785..3a8ee7ccacb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -276,6 +276,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 +++ 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/esh-mode.el b/lisp/eshell/esh-mode.el index ead5a20bec8..37a88fce790 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) commit 48024096fea5ccdeb79dab5793a6f7a293b95919 Author: Eli Zaretskii Date: Mon Oct 21 20:42:01 2024 +0300 Avoid crashes when scrolling images under winner-mode * src/window.c (window_scroll_pixel_based): Fix calculation of a window's vscroll. (Bug#73933) diff --git a/src/window.c b/src/window.c index dba2d6a3523..a2b40cb197f 100644 --- a/src/window.c +++ b/src/window.c @@ -6017,7 +6017,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 commit c35d6ba9f07b0a8417ef116359049c0dd63e12b5 Author: Eli Zaretskii Date: Mon Oct 21 18:32:07 2024 +0300 ; * doc/lispref/display.texi (Fontsets): Clarify wording. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index ac712c43208..afb1272ae41 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -4030,7 +4030,8 @@ that case, use @var{font-spec} for all the characters in the charset. 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{characters} 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 commit 1f8fbae8df764e9d24f1b824de7369d82e36abae Author: Stephen Berman Date: Mon Oct 21 12:50:53 2024 +0200 Let 'tex-view' show PDFs made without a DVI (bug#73854) * lisp/textmodes/tex-mode.el (tex-print-file): Update doc string to mention 'tex-compile'. (tex-compile-commands): Add entries for 'evince' and 'mupdf'. (tex-compile): Set 'tex-print-file'. diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 6fc49800018..cb934690782 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) commit 88a1a32fc57817d5e0e1f79b83ff23d7274cbace Author: Eli Zaretskii Date: Mon Oct 21 13:04:18 2024 +0300 ; * doc/lispref/display.texi (Fontsets): Fix typo. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 3492f4dc29b..ac712c43208 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -4030,7 +4030,7 @@ that case, use @var{font-spec} for all the characters in the charset. 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} is @code{symbol}. @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 commit 6be47058cd741e5868f5c2fdef0fd59e296f18b6 Author: Eli Zaretskii Date: Mon Oct 21 13:01:53 2024 +0300 ; Add indexing for 'use-default-font-for-symbols' * doc/emacs/mule.texi (Modifying Fontsets): * doc/lispref/display.texi (Fontsets): Index 'use-default-font-for-symbols'. 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/lispref/display.texi b/doc/lispref/display.texi index 1d5ba98f062..3492f4dc29b 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -4025,6 +4025,7 @@ 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 commit b3af195213518514f78ac6f66f9598e45befd1ec Merge: e289f7dbb4f b573aaab76b Author: Eli Zaretskii Date: Mon Oct 21 08:26:20 2024 +0300 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit e289f7dbb4f04776e8327e7865a9082078c084a9 Author: Eli Zaretskii Date: Mon Oct 21 08:25:06 2024 +0300 ; Reapply a fix for recent change in eww.el * lisp/net/eww.el (eww--list-buffers-display-table) (eww-buffers-mode): Fix coding conventions. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 17ebccc9453..63ad4ae78b7 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -2617,7 +2617,7 @@ see)." (eww--list-buffers-display-table)) (pop-to-buffer "*eww buffers*")) -(defun eww--list-buffers-display-table (&optional ignore-auto noconfirm) +(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 @@ -2711,8 +2711,8 @@ The format of the data is (title url buffer), for use in of :interactive nil (buffer-disable-undo) (setq truncate-lines t - ;; this is set so that pressing "g" with point just below the - ;; table will still update the listing + ;; 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 commit 88a6a17adb7eff84e05d93ea357ae3eff9a84c48 Author: Eli Zaretskii Date: Mon Oct 21 08:22:56 2024 +0300 Revert "; Fix last change." This reverts commit 75fa0cc1ae2b53fe169fdcfef52bee6719eb38a7. The large part of it was committed by accident. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 63ad4ae78b7..17ebccc9453 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -2617,7 +2617,7 @@ see)." (eww--list-buffers-display-table)) (pop-to-buffer "*eww buffers*")) -(defun eww--list-buffers-display-table (&optional _ignore-auto _noconfirm) +(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 @@ -2711,8 +2711,8 @@ The format of the data is (title url buffer), for use in of :interactive nil (buffer-disable-undo) (setq truncate-lines t - ;; This is set so that pressing "g" with point just below the - ;; table will still update the listing. + ;; 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 diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index d2ada63f71e..f77bf0cc5ff 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -252,27 +252,6 @@ included in the completions." :type 'boolean :version "28.1") -;; The default is nil because only a VC user who also possesses a lot of -;; Git-specific knowledge can know when it is okay to rewrite history, -;; and we can't convey to a relatively Git-naïve user the potential -;; risks in only the space of a minibuffer y/n prompt. -(defcustom vc-git-allow-rewriting-history nil - "When non-nil, permit Git operations that may rewrite published history. - -Many Git 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. See \"Recovering from -Upstream Rebase\" in the Man page git-rebase(1). - -Normally, Emacs refuses to run Git commands that it thinks will rewrite -published history. If you customize this variable to a non-nil value, -Emacs will instead prompt you to confirm that you really want to perform -the rewrite. A value of `no-ask' means to proceed with no prompting." - :type '(choice (const :tag "Don't allow" nil) - (const :tag "Prompt to allow" t) - (const :tag "Allow without prompting" no-ask)) - :version "31.1") - ;; History of Git commands. (defvar vc-git-history nil) @@ -749,13 +728,11 @@ 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--current-branch)) + (let ((branch (vc-git--out-match + '("symbolic-ref" "HEAD") + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) tracking remote-url) (if branch (when-let ((branch-merge @@ -1105,17 +1082,6 @@ 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)) @@ -1214,23 +1180,31 @@ 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))) - ;; 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"))))) + (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")))))) (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)) (when to-stash (let ((cached (make-nearby-temp-file "git-cached"))) @@ -1986,94 +1960,6 @@ 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 (eq vc-git-allow-rewriting-history 'no-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 vc-git-allow-rewriting-history - (yes-or-no-p - (format -"Commit %s looks to be published; are you sure you want to rewrite history?" - rev)))) - (user-error "Will not rewrite likely-public Git 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")))) - (nothing-staged - (zerop - (vc-git-command nil t nil "diff" "--cached" "--quiet")))) - ;; We want to do just - ;; - ;; % git commit --only --allow-empty -m... - ;; % git rebase --autostash --autosquash -i REV~1 - ;; - ;; because the first command is guaranteed to create an empty commit - ;; regardless of the state of the index and working tree. However, - ;; that requires git.git commit 319d835, released in Git 2.11.1. - ;; In order to support older Git we do this longer, slower sequence: - ;; - ;; % git stash push - ;; % git commit --allow-empty -m... - ;; % git rebase --autosquash -i REV~1 - ;; % git stash pop - ;; (unless nothing-staged - ;; (vc-git-command nil 0 nil "stash" "push")) - (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")) - (when msg-file - (let ((coding-system-for-write - (or coding-system-for-write - vc-git-commits-coding-system))) - (write-region message nil msg-file))) - (apply #'vc-git-command nil 0 nil - "commit" "--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" "--autosquash" "-i" - ;; (format "%s~1" rev))) - ;; (unless nothing-staged - ;; (vc-git-command nil 0 nil "stash" "pop" "--index")) - (message "temporary file is: %s" msg-file) - )) - (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] commit b573aaab76b55ec276b9190570b3ca3ae72cb416 Author: Jim Porter Date: Sun Oct 20 16:58:44 2024 -0700 ; Make utility functions for getting the Eshell non-special regexps * lisp/eshell/esh-arg.el (eshell-inside-quote-regexp) (eshell-outside-quote-regexp): Rename to... (eshell--non-special-inside-quote-regexp) (eshell--non-special-outside-quote-regexp): ... these, and add defsubsts. (eshell-arg-initialize): Don't initialize regexp variables. (eshell-parse-non-special): ... use them. * lisp/eshell/em-glob.el (eshell-glob-chars-regexp): Use 'rx-to-string'. diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 36e4f90aed2..b95204c7e1e 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -182,7 +182,6 @@ interpretation." (buffer-substring-no-properties (1- (point)) (1+ end)) (goto-char (1+ end)))))))))) -(defvar eshell-glob-chars-regexp nil) (defvar eshell-glob-matches) (defvar message-shown) @@ -190,11 +189,12 @@ interpretation." '(("**/" . recurse) ("***/" . recurse-symlink))) +(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 - (format "[%s]+" (apply 'string eshell-glob-chars-list))))) + (rx-to-string `(+ (any ,@eshell-glob-chars-list)) t)))) (defun eshell-glob-regexp (pattern) "Convert glob-pattern PATTERN to a regular expression. diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 8785f5216fd..4ea25f7f202 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: @@ -177,13 +175,24 @@ Eshell will expand special refs like \"#\" 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)))) + (defsubst eshell-escape-arg (string) "Return STRING with the `escaped' property on it." (if (stringp string) @@ -422,17 +431,9 @@ their numeric values." (defun eshell-parse-non-special () "Parse any non-special characters, depending on the current context." - (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)) + (eshell--non-special-inside-quote-regexp) + (eshell--non-special-outside-quote-regexp))) (goto-char (match-end 0)) (let ((str (match-string 0))) (when str commit 212cf3125611b123707feac6f7ffd55a230bc568 Author: Jim Porter Date: Thu Oct 17 20:02:28 2024 -0700 Make all the entries in 'eshell-parse-argument-hook' named functions * lisp/eshell/esh-arg.el (eshell-parse-number, eshell-parse-non-special) (eshell-parse-whitespace, eshell-parse-comment): New functions... (eshell-parse-argument-hook): ... use them. diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 6e4c0df7526..8785f5216fd 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -89,66 +89,25 @@ 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 #, or # 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 #, or # is a buffer + ;; or process reference. + eshell-parse-special-reference + ;; Numbers convert to numbers if they stand alone. + eshell-parse-number + ;; 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 @@ -447,6 +406,54 @@ 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")) +(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))) + (when (> (length str) 0) + (add-text-properties 0 (length str) '(number t) str)) + str))) + +(defun eshell-parse-non-special () + "Parse any non-special characters, depending on the current context." + (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))) + (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")) @@ -553,7 +560,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. commit 14624ff0fb7aec095a8846c3de5b089c93aa85da Author: Sean Whitton Date: Mon Oct 21 09:44:20 2024 +0800 ; Undo WIP accidentally included in recent commit diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index d2ada63f71e..f77bf0cc5ff 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -252,27 +252,6 @@ included in the completions." :type 'boolean :version "28.1") -;; The default is nil because only a VC user who also possesses a lot of -;; Git-specific knowledge can know when it is okay to rewrite history, -;; and we can't convey to a relatively Git-naïve user the potential -;; risks in only the space of a minibuffer y/n prompt. -(defcustom vc-git-allow-rewriting-history nil - "When non-nil, permit Git operations that may rewrite published history. - -Many Git 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. See \"Recovering from -Upstream Rebase\" in the Man page git-rebase(1). - -Normally, Emacs refuses to run Git commands that it thinks will rewrite -published history. If you customize this variable to a non-nil value, -Emacs will instead prompt you to confirm that you really want to perform -the rewrite. A value of `no-ask' means to proceed with no prompting." - :type '(choice (const :tag "Don't allow" nil) - (const :tag "Prompt to allow" t) - (const :tag "Allow without prompting" no-ask)) - :version "31.1") - ;; History of Git commands. (defvar vc-git-history nil) @@ -749,13 +728,11 @@ 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--current-branch)) + (let ((branch (vc-git--out-match + '("symbolic-ref" "HEAD") + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) tracking remote-url) (if branch (when-let ((branch-merge @@ -1105,17 +1082,6 @@ 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)) @@ -1214,23 +1180,31 @@ 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))) - ;; 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"))))) + (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")))))) (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)) (when to-stash (let ((cached (make-nearby-temp-file "git-cached"))) @@ -1986,94 +1960,6 @@ 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 (eq vc-git-allow-rewriting-history 'no-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 vc-git-allow-rewriting-history - (yes-or-no-p - (format -"Commit %s looks to be published; are you sure you want to rewrite history?" - rev)))) - (user-error "Will not rewrite likely-public Git 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")))) - (nothing-staged - (zerop - (vc-git-command nil t nil "diff" "--cached" "--quiet")))) - ;; We want to do just - ;; - ;; % git commit --only --allow-empty -m... - ;; % git rebase --autostash --autosquash -i REV~1 - ;; - ;; because the first command is guaranteed to create an empty commit - ;; regardless of the state of the index and working tree. However, - ;; that requires git.git commit 319d835, released in Git 2.11.1. - ;; In order to support older Git we do this longer, slower sequence: - ;; - ;; % git stash push - ;; % git commit --allow-empty -m... - ;; % git rebase --autosquash -i REV~1 - ;; % git stash pop - ;; (unless nothing-staged - ;; (vc-git-command nil 0 nil "stash" "push")) - (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")) - (when msg-file - (let ((coding-system-for-write - (or coding-system-for-write - vc-git-commits-coding-system))) - (write-region message nil msg-file))) - (apply #'vc-git-command nil 0 nil - "commit" "--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" "--autosquash" "-i" - ;; (format "%s~1" rev))) - ;; (unless nothing-staged - ;; (vc-git-command nil 0 nil "stash" "pop" "--index")) - (message "temporary file is: %s" msg-file) - )) - (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] commit fc6854cbd4733ef4247f5d9fd99d88d7b79c4dc4 Author: Jim Porter Date: Sun Oct 20 15:34:15 2024 -0700 ; * lisp/eshell/esh-var.el (eshell-glob-function): Remove unused defvar. diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index df490dd4c6c..e3ff76abc26 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -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)))) commit 183c5efc0fe80074a40ebebb684d787baf578ffe Author: Jim Porter Date: Sun Oct 20 15:02:18 2024 -0700 Be more careful about applying spliced arguments Previously, this could 'nonc' to a list that shouldn't be modified. * lisp/eshell/esh-cmd.el (eshell-rewrite-named-command): Use 'append' instead of 'nconc'. * test/lisp/eshell/esh-var-tests.el (esh-var-test/interp-var-splice): (esh-var-test/quoted-interp-var-splice): New tests. diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index c9096b0d159..137abe6eb75 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) diff --git a/test/lisp/eshell/esh-var-tests.el b/test/lisp/eshell/esh-var-tests.el index 70f6e9c7777..38f90e615a8 100644 --- a/test/lisp/eshell/esh-var-tests.el +++ b/test/lisp/eshell/esh-var-tests.el @@ -217,7 +217,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." @@ -428,7 +429,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" commit 681f70ea04a30bb43bb87448a6d71458d773d247 Author: Eli Zaretskii Date: Sun Oct 20 22:39:53 2024 +0300 * src/lread.c (READ_AND_BUFFER): Reject negative chars (bug#73914). diff --git a/src/lread.c b/src/lread.c index c336c6db6e1..854aaa784ad 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3913,6 +3913,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 \ commit 75fa0cc1ae2b53fe169fdcfef52bee6719eb38a7 Author: Eli Zaretskii Date: Sun Oct 20 21:02:07 2024 +0300 ; Fix last change. * lisp/net/eww.el (eww--list-buffers-display-table) (eww-buffers-mode): Fix coding conventions. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 17ebccc9453..63ad4ae78b7 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -2617,7 +2617,7 @@ see)." (eww--list-buffers-display-table)) (pop-to-buffer "*eww buffers*")) -(defun eww--list-buffers-display-table (&optional ignore-auto noconfirm) +(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 @@ -2711,8 +2711,8 @@ The format of the data is (title url buffer), for use in of :interactive nil (buffer-disable-undo) (setq truncate-lines t - ;; this is set so that pressing "g" with point just below the - ;; table will still update the listing + ;; 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 diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index f77bf0cc5ff..d2ada63f71e 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -252,6 +252,27 @@ included in the completions." :type 'boolean :version "28.1") +;; The default is nil because only a VC user who also possesses a lot of +;; Git-specific knowledge can know when it is okay to rewrite history, +;; and we can't convey to a relatively Git-naïve user the potential +;; risks in only the space of a minibuffer y/n prompt. +(defcustom vc-git-allow-rewriting-history nil + "When non-nil, permit Git operations that may rewrite published history. + +Many Git 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. See \"Recovering from +Upstream Rebase\" in the Man page git-rebase(1). + +Normally, Emacs refuses to run Git commands that it thinks will rewrite +published history. If you customize this variable to a non-nil value, +Emacs will instead prompt you to confirm that you really want to perform +the rewrite. A value of `no-ask' means to proceed with no prompting." + :type '(choice (const :tag "Don't allow" nil) + (const :tag "Prompt to allow" t) + (const :tag "Allow without prompting" no-ask)) + :version "31.1") + ;; History of Git commands. (defvar vc-git-history nil) @@ -728,11 +749,13 @@ 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 @@ -1082,6 +1105,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 +1214,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"))) @@ -1960,6 +1986,94 @@ 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 (eq vc-git-allow-rewriting-history 'no-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 vc-git-allow-rewriting-history + (yes-or-no-p + (format +"Commit %s looks to be published; are you sure you want to rewrite history?" + rev)))) + (user-error "Will not rewrite likely-public Git 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")))) + (nothing-staged + (zerop + (vc-git-command nil t nil "diff" "--cached" "--quiet")))) + ;; We want to do just + ;; + ;; % git commit --only --allow-empty -m... + ;; % git rebase --autostash --autosquash -i REV~1 + ;; + ;; because the first command is guaranteed to create an empty commit + ;; regardless of the state of the index and working tree. However, + ;; that requires git.git commit 319d835, released in Git 2.11.1. + ;; In order to support older Git we do this longer, slower sequence: + ;; + ;; % git stash push + ;; % git commit --allow-empty -m... + ;; % git rebase --autosquash -i REV~1 + ;; % git stash pop + ;; (unless nothing-staged + ;; (vc-git-command nil 0 nil "stash" "push")) + (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")) + (when msg-file + (let ((coding-system-for-write + (or coding-system-for-write + vc-git-commits-coding-system))) + (write-region message nil msg-file))) + (apply #'vc-git-command nil 0 nil + "commit" "--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" "--autosquash" "-i" + ;; (format "%s~1" rev))) + ;; (unless nothing-staged + ;; (vc-git-command nil 0 nil "stash" "pop" "--index")) + (message "temporary file is: %s" msg-file) + )) + (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] commit d3975cc925a856c872016df734563ce0709f3efc Author: Sebastián Monía Date: Sun Oct 13 21:00:03 2024 -0400 Use vtable in eww-list-buffers and add function eww-buffer-list * lisp/net/eww.el (eww-buffer-list): New function. (eww-list-buffers): Move logic to... (eww--list-buffers-display-table, eww--list-buffers-get-data): ... these, and use 'vtable'. (eww-buffer-select, eww-buffer-show, eww-buffer-kill) (eww-buffers-mode-map): Use 'vtable-current-object'. (eww-buffers-mode): Set 'revert-buffer-function' diff --git a/lisp/net/eww.el b/lisp/net/eww.el index b5d2f20781a..17ebccc9453 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)) @@ -2604,58 +2605,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 +2653,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 +2681,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 +2700,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 +2710,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 commit 53e84f8cfa85bb53c92936a3be73ab1445a89459 Author: Mattias Engdegård Date: Sun Oct 20 16:53:52 2024 +0200 Revert "Preserve source position of macro calls in macro expansions" This reverts commit 2114a955c23c213168f012f5e480edae46561fd2. No agreement on this (bug#73725). diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 669b6c76417..d8dbfa62bf9 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -510,9 +510,7 @@ There can be multiple entries for the same NAME if it has several aliases.") (while (progn ;; First, optimize all sub-forms of this one. - (setq form - (macroexp-preserve-posification - form (byte-optimize-form-code-walker form for-effect))) + (setq form (byte-optimize-form-code-walker form for-effect)) ;; If a form-specific optimizer is available, run it and start over ;; until a fixpoint has been reached. @@ -521,8 +519,7 @@ There can be multiple entries for the same NAME if it has several aliases.") (let ((opt (byte-opt--fget (car form) 'byte-optimizer))) (and opt (let ((old form) - (new (macroexp-preserve-posification - form (funcall opt form)))) + (new (funcall opt form))) (byte-compile-log " %s\t==>\t%s" old new) (setq form new) (not (eq new old)))))))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4272a6fb252..29e7882c851 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2582,7 +2582,7 @@ Call from the source buffer." byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (setq form (macroexpand-all form byte-compile-macro-environment t)) + (setq form (macroexpand-all form byte-compile-macro-environment)) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 0b19544652a..053db927b67 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -238,85 +238,22 @@ It should normally be a symbol with position and it defaults to FORM." form)))))))) (t form))) -(defun sub-macroexp--posify-form (form call-pos depth) - "Try to apply the transformation of `macroexp--posify-form' to FORM. -FORM and CALL-POS are as in that function. DEPTH is a small integer, -decremented at each recursive call, to prevent infinite recursion. -Return the changed form, or nil if no change happened." - (let (new-form) - (cond - ((zerop depth) nil) - ((and (consp form) - (symbolp (car form)) - (car form)) - (setcar form (position-symbol (car form) call-pos)) - form) - ((consp form) - (or (when (setq new-form (sub-macroexp--posify-form - (car form) call-pos (1- depth))) - (setcar form new-form) - form) - (when (setq new-form (sub-macroexp--posify-form - (cdr form) call-pos (1- depth))) - (setcdr form new-form) - form))) - ((symbolp form) - (if form ; Don't position nil! - (position-symbol form call-pos))) - ((and (or (vectorp form) (recordp form))) - (let ((len (length form)) - (i 0) - ) - (while (and (< i len) - (not (setq new-form (sub-macroexp--posify-form - (aref form i) call-pos (1- depth))))) - (setq i (1+ i))) - (when (< i len) - (aset form i new-form) - form)))))) - -(defun macroexp--posify-form (form call-pos) - "Try to apply the position CALL-POS to the form FORM. -CALL-POS is a buffer position, a number. FORM may be any lisp form, -and is typically the output form returned by macro expansion. -Apply CALL-POS to FORM as a symbol with position, such that -`byte-compile--first-symbol-with-pos' can later return it. Return -the possibly modified FORM." - (let ((new-form (sub-macroexp--posify-form form call-pos 10))) - (or new-form form))) - -(defmacro macroexp-preserve-posification (pos-form &rest body) - "Evaluate BODY..., posifying the result with POS-FORM's position, if any." - `(let ((call-pos (cond - ((consp ,pos-form) - (and (symbol-with-pos-p (car ,pos-form)) - (symbol-with-pos-pos (car ,pos-form)))) - ((symbol-with-pos-p ,pos-form) - (symbol-with-pos-pos ,pos-form)))) - (new-value (progn ,@body))) - (if call-pos - (macroexp--posify-form new-value call-pos) - new-value))) - (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." (let* ((macroexpand-all-environment env) new-form) - (macroexp-preserve-posification - form - (while (not (eq form (setq new-form (macroexpand-1 form env)))) - (setq macroexpanded t) - (let ((fun (car-safe form))) - (setq form - (if (and fun (symbolp fun) - (get fun 'byte-obsolete-info)) - (macroexp-warn-and-return - (macroexp--obsolete-warning - fun (get fun 'byte-obsolete-info) - (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form (list 'obsolete fun) nil fun) - new-form)))) - new-form))) + (while (not (eq form (setq new-form (macroexpand-1 form env)))) + (let ((fun (car-safe form))) + (setq form + (if (and fun (symbolp fun) + (get fun 'byte-obsolete-info)) + (macroexp-warn-and-return + (macroexp--obsolete-warning + fun (get fun 'byte-obsolete-info) + (if (symbolp (symbol-function fun)) "alias" "macro")) + new-form (list 'obsolete fun) nil fun) + new-form)))) + form)) (defun macroexp--unfold-lambda (form &optional name) (or name (setq name "anonymous lambda")) @@ -580,21 +517,14 @@ Assumes the caller has bound `macroexpand-all-environment'." (_ form)))))) ;;;###autoload -(defun macroexpand-all (form &optional environment keep-pos) +(defun macroexpand-all (form &optional environment) "Return result of expanding macros at all levels in FORM. -If no macros are expanded, FORM is returned unchanged. The second -optional arg ENVIRONMENT specifies an environment of macro definitions -to shadow the loaded ones for use in file byte-compilation. KEEP-POS, -if non-nil, specifies that any symbol-with-position for FORM should be -preserved, later to be usable by `byte-compile--warning-source-offset'." - (let* - ((macroexpand-all-environment environment) +If no macros are expanded, FORM is returned unchanged. +The second optional arg ENVIRONMENT specifies an environment of macro +definitions to shadow the loaded ones for use in file byte-compilation." + (let ((macroexpand-all-environment environment) (macroexp--dynvars macroexp--dynvars)) - (if keep-pos - (macroexp-preserve-posification - form - (macroexp--expand-all form)) - (macroexp--expand-all form)))) + (macroexp--expand-all form))) ;; This function is like `macroexpand-all' but for use with top-level ;; forms. It does not dynbind `macroexp--dynvars' because we want commit 2114a955c23c213168f012f5e480edae46561fd2 Author: Alan Mackenzie Date: Sun Oct 20 14:04:26 2024 +0000 Preserve source position of macro calls in macro expansions This allows the byte compiler to give correct positions, those of the invoking forms, when an error or warning is caused by the innards of the invoked macros. This fixes bug#73725 and bug#73746. * lisp/emacs-lisp/macroexp.el (sub-macroexp--posify-form) (macroexp--posify-form): New functions. (macroexp-preserve-posification): New macro. (macroexp-macroexpand): Use the new macro to preserve a calling form's position. (macroexpand-all): Add a new parameter `keep-pos' which instructs the function to preserve an invoking form's position. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form): Use the new macro to preserve source positions. * lisp/emacs-lisp/bytecomp.el (byte-compile-preprocess): Call macroexpand-all with the new argument `keep-pos' non-nil. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index d8dbfa62bf9..669b6c76417 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -510,7 +510,9 @@ There can be multiple entries for the same NAME if it has several aliases.") (while (progn ;; First, optimize all sub-forms of this one. - (setq form (byte-optimize-form-code-walker form for-effect)) + (setq form + (macroexp-preserve-posification + form (byte-optimize-form-code-walker form for-effect))) ;; If a form-specific optimizer is available, run it and start over ;; until a fixpoint has been reached. @@ -519,7 +521,8 @@ There can be multiple entries for the same NAME if it has several aliases.") (let ((opt (byte-opt--fget (car form) 'byte-optimizer))) (and opt (let ((old form) - (new (funcall opt form))) + (new (macroexp-preserve-posification + form (funcall opt form)))) (byte-compile-log " %s\t==>\t%s" old new) (setq form new) (not (eq new old)))))))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 29e7882c851..4272a6fb252 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2582,7 +2582,7 @@ Call from the source buffer." byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (setq form (macroexpand-all form byte-compile-macro-environment)) + (setq form (macroexpand-all form byte-compile-macro-environment t)) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 053db927b67..0b19544652a 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -238,22 +238,85 @@ It should normally be a symbol with position and it defaults to FORM." form)))))))) (t form))) +(defun sub-macroexp--posify-form (form call-pos depth) + "Try to apply the transformation of `macroexp--posify-form' to FORM. +FORM and CALL-POS are as in that function. DEPTH is a small integer, +decremented at each recursive call, to prevent infinite recursion. +Return the changed form, or nil if no change happened." + (let (new-form) + (cond + ((zerop depth) nil) + ((and (consp form) + (symbolp (car form)) + (car form)) + (setcar form (position-symbol (car form) call-pos)) + form) + ((consp form) + (or (when (setq new-form (sub-macroexp--posify-form + (car form) call-pos (1- depth))) + (setcar form new-form) + form) + (when (setq new-form (sub-macroexp--posify-form + (cdr form) call-pos (1- depth))) + (setcdr form new-form) + form))) + ((symbolp form) + (if form ; Don't position nil! + (position-symbol form call-pos))) + ((and (or (vectorp form) (recordp form))) + (let ((len (length form)) + (i 0) + ) + (while (and (< i len) + (not (setq new-form (sub-macroexp--posify-form + (aref form i) call-pos (1- depth))))) + (setq i (1+ i))) + (when (< i len) + (aset form i new-form) + form)))))) + +(defun macroexp--posify-form (form call-pos) + "Try to apply the position CALL-POS to the form FORM. +CALL-POS is a buffer position, a number. FORM may be any lisp form, +and is typically the output form returned by macro expansion. +Apply CALL-POS to FORM as a symbol with position, such that +`byte-compile--first-symbol-with-pos' can later return it. Return +the possibly modified FORM." + (let ((new-form (sub-macroexp--posify-form form call-pos 10))) + (or new-form form))) + +(defmacro macroexp-preserve-posification (pos-form &rest body) + "Evaluate BODY..., posifying the result with POS-FORM's position, if any." + `(let ((call-pos (cond + ((consp ,pos-form) + (and (symbol-with-pos-p (car ,pos-form)) + (symbol-with-pos-pos (car ,pos-form)))) + ((symbol-with-pos-p ,pos-form) + (symbol-with-pos-pos ,pos-form)))) + (new-value (progn ,@body))) + (if call-pos + (macroexp--posify-form new-value call-pos) + new-value))) + (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." (let* ((macroexpand-all-environment env) new-form) - (while (not (eq form (setq new-form (macroexpand-1 form env)))) - (let ((fun (car-safe form))) - (setq form - (if (and fun (symbolp fun) - (get fun 'byte-obsolete-info)) - (macroexp-warn-and-return - (macroexp--obsolete-warning - fun (get fun 'byte-obsolete-info) - (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form (list 'obsolete fun) nil fun) - new-form)))) - form)) + (macroexp-preserve-posification + form + (while (not (eq form (setq new-form (macroexpand-1 form env)))) + (setq macroexpanded t) + (let ((fun (car-safe form))) + (setq form + (if (and fun (symbolp fun) + (get fun 'byte-obsolete-info)) + (macroexp-warn-and-return + (macroexp--obsolete-warning + fun (get fun 'byte-obsolete-info) + (if (symbolp (symbol-function fun)) "alias" "macro")) + new-form (list 'obsolete fun) nil fun) + new-form)))) + new-form))) (defun macroexp--unfold-lambda (form &optional name) (or name (setq name "anonymous lambda")) @@ -517,14 +580,21 @@ Assumes the caller has bound `macroexpand-all-environment'." (_ form)))))) ;;;###autoload -(defun macroexpand-all (form &optional environment) +(defun macroexpand-all (form &optional environment keep-pos) "Return result of expanding macros at all levels in FORM. -If no macros are expanded, FORM is returned unchanged. -The second optional arg ENVIRONMENT specifies an environment of macro -definitions to shadow the loaded ones for use in file byte-compilation." - (let ((macroexpand-all-environment environment) +If no macros are expanded, FORM is returned unchanged. The second +optional arg ENVIRONMENT specifies an environment of macro definitions +to shadow the loaded ones for use in file byte-compilation. KEEP-POS, +if non-nil, specifies that any symbol-with-position for FORM should be +preserved, later to be usable by `byte-compile--warning-source-offset'." + (let* + ((macroexpand-all-environment environment) (macroexp--dynvars macroexp--dynvars)) - (macroexp--expand-all form))) + (if keep-pos + (macroexp-preserve-posification + form + (macroexp--expand-all form)) + (macroexp--expand-all form)))) ;; This function is like `macroexpand-all' but for use with top-level ;; forms. It does not dynbind `macroexp--dynvars' because we want commit ac4151e0023f4bf17eb128036c006618332f1ac0 Author: Michael Albinus Date: Sun Oct 20 11:35:06 2024 +0200 * test/Makefile.in: Do not show emacs-module-tests.log by default. 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 commit 6c928e490d3347cc309eda51cefbc46fba955650 Author: Sean Whitton Date: Sun Oct 20 16:40:41 2024 +0800 ; * lisp/vc/log-view.el (log-view-modify-change-comment): Add FIXME. diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 360f522272b..783f58575dc 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -556,6 +556,15 @@ If called interactively, visit the version at point." ;; 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 Git, + ;; 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) commit 0bdaab7655787d717d69581e30346233e293c6f2 Author: Michael Albinus Date: Sun Oct 20 10:38:00 2024 +0200 Minor changes of last commit * lisp/autorevert.el (auto-revert--last-time): Init with 0 (Epoch). (auto-revert-notify-handler): Simplify. diff --git a/lisp/autorevert.el b/lisp/autorevert.el index ef758584c0d..94082df4502 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -370,7 +370,7 @@ 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 nil +(defvar-local auto-revert--last-time 0 ;; Epoch. "The last time of buffer was reverted.") (defvar auto-revert-debug nil @@ -752,16 +752,15 @@ system.") ;; Mark buffer modified. (setq auto-revert-notify-modified-p t) - ;; Lock out the buffer + ;; Lock out the buffer. (unless auto-revert--lockout-timer (setq auto-revert--lockout-timer (run-with-timer auto-revert--lockout-interval nil #'auto-revert--end-lockout buffer)) - ;; Revert it when first entry or it was reverted intervals ago - (when (or (null auto-revert--last-time) - (> (float-time (time-since auto-revert--last-time)) - auto-revert--lockout-interval)) + ;; 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) commit 545c54aea1ecccf84eaebbe3a3cb7b5fbc5716f8 Author: Lin Sun Date: Sun Oct 20 10:05:19 2024 +0200 Enhance the auto-revert to avoid revert a buffer in short time * lisp/autorevert.el (auto-revert--last-time): New defvar. (auto-revert-handler, auto-revert-notify-handler): Use it. * test/lisp/autorevert-tests.el (with-auto-revert-test): Set `auto-revert--lockout-interval' correctly. diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 0fdab6ffc9f..ef758584c0d 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 nil + "The last time of buffer was reverted.") + (defvar auto-revert-debug nil "Use for debug messages.") @@ -749,13 +752,17 @@ 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 (or (null auto-revert--last-time) + (> (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 +808,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/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) commit 80627a31c67b383393c53bd87dd21b7f0de3844e Author: Eli Zaretskii Date: Sun Oct 20 08:03:08 2024 +0300 ; Avoid byte-compiler warning in mpc.el * lisp/mpc.el (mpc-cmd-crossfade): Move after definition of 'mpc-crossfade-time', because the function uses it. diff --git a/lisp/mpc.el b/lisp/mpc.el index 01876bf230b..0a43b09c11d 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -883,11 +883,6 @@ If PLAYLIST is t or nil or missing, use the main playlist." (defun mpc-cmd-tagtypes () (mapcar #'cdr (mpc-proc-cmd-to-alist "tagtypes"))) -(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)) - ;; This was never integrated into MPD. ;; (defun mpc-cmd-download (file) ;; (with-current-buffer (generate-new-buffer " *mpc download*") @@ -928,6 +923,11 @@ If PLAYLIST is t or nil or missing, use the main playlist." :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)) commit 81a5beb8af020e4c92a77d61c8aa5e637e2dc945 Author: Jim Porter Date: Sat Oct 19 16:12:43 2024 -0700 Fix 'min-width' calculation in 'visual-wrap-prefix-mode' * lisp/visual-wrap.el (visual-wrap--content-prefix): Remove 'min-width' before computing the pixel width to avoid miscalculation (bug#73882). diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el index 76276c0f474..fa128d287a4 100644 --- a/lisp/visual-wrap.el +++ b/lisp/visual-wrap.el @@ -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. commit 08f3bc1b8e6a3583c8ccda02a7cf1b59c8d3f514 Author: john muhl Date: Sat Sep 28 19:11:03 2024 -0500 Add ability to crossfade between songs in 'mpc' * lisp/mpc.el (mpc-cmd-crossfade): (mpc-toggle-crossfade): New function. (mpc-crossfade-time): New option. (mpc-mode-menu): Add menu item to toggle crossfade. (Bug#73891) diff --git a/etc/NEWS b/etc/NEWS index a889528ab6a..cfc5a8e1785 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -582,6 +582,11 @@ 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 Modes and Packages in Emacs 31.1 diff --git a/lisp/mpc.el b/lisp/mpc.el index 9905e3aa554..01876bf230b 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -883,6 +883,11 @@ If PLAYLIST is t or nil or missing, use the main playlist." (defun mpc-cmd-tagtypes () (mapcar #'cdr (mpc-proc-cmd-to-alist "tagtypes"))) +(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)) + ;; This was never integrated into MPD. ;; (defun mpc-cmd-download (file) ;; (with-current-buffer (generate-new-buffer " *mpc download*") @@ -918,6 +923,11 @@ 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-data-directory () (unless (file-directory-p mpc-data-directory) (make-directory mpc-data-directory)) @@ -1188,6 +1198,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 +2440,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) commit de0800c511740de7ad4dcb7dda0a0083a094d749 Author: Sean Whitton Date: Sun Oct 20 09:20:07 2024 +0800 ; * lisp/vc/log-view.el (log-view-modify-change-comment): Add FIXME. diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index 647a7dc569f..360f522272b 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -550,6 +550,12 @@ 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 (comment (condition-case _ (vc-call-backend log-view-vc-backend 'get-change-comment files rev) commit 43d5b7a04c4b1a8a7d57f25824df2e8720d2c567 Author: Jim Porter Date: Sat Oct 19 11:52:42 2024 -0700 Lazily convert numeric strings to Lisp numbers in Eshell This should reduce the number of issues with Eshell converting strings to numbers too aggressively and losing information (e.g. "001" -> 1) while still allowing almost all of the beneficial uses, like summing a list of numeric strings with '+'. * lisp/eshell/esh-util.el (eshell--do-mark-numeric-string): New function. (eshell-convert-to-number): Make obsolete in favor of... (eshell-mark-numeric-string): ... this. Update callers. * lisp/eshell/esh-arg.el (eshell--numberlike-p): New function... (eshell-concat-1): ... use it. * test/lisp/eshell/esh-util-tests.el: Reimplement type conversion tests to use 'eshell-convertible-to-number-p' instead. * test/lisp/eshell/esh-var-tests.el (esh-var-test/interp-var-splice-concat, esh-var-test/interp-concat-cmd) (esh-var-test/interp-convert-var-split-indices) (esh-var-test/interp-convert-quoted-var-split-indices) (esh-var-test/interp-convert-cmd-multiline) (esh-var-test/interp-convert-cmd-split-indices): Adjust tests to check the new behavior. * doc/misc/eshell.texi (Type Conversion): New section. (Expansion): Clarify concatenation behavior. diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi index 9a2714b14fb..ee4d0ca09c8 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. @@ -1764,8 +1795,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/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index b441cbfc274..6e4c0df7526 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -271,15 +271,21 @@ would produce (\"abc\" \"d\")." (t (setq result (eshell-concat-1 quoted result i)))))))) +(defsubst eshell--numberlike-p (object) + (or (numberp object) + (and (stringp object) (get-text-property 0 'number object)))) + (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." +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) (eshell-stringify second)))) - (if (and (not quoted) - (or (numberp first) (numberp second))) - (eshell-convert-to-number result) - result))) + (remove-text-properties 0 (length result) '(number) result) + (when (and (not quoted) + (or (eshell--numberlike-p first) + (eshell--numberlike-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. diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 46083184aaa..180f049e495 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -343,11 +343,22 @@ 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) + (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)) @@ -376,10 +387,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. diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 059bba03ee4..df490dd4c6c 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -765,11 +765,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 +784,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" diff --git a/test/lisp/eshell/esh-util-tests.el b/test/lisp/eshell/esh-util-tests.el index 031de558d1f..4a0874bff39 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")) diff --git a/test/lisp/eshell/esh-var-tests.el b/test/lisp/eshell/esh-var-tests.el index 7ac9807a1a7..70f6e9c7777 100644 --- a/test/lisp/eshell/esh-var-tests.el +++ b/test/lisp/eshell/esh-var-tests.el @@ -231,7 +231,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 +280,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 () @@ -491,11 +495,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 +524,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 +544,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 +559,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 () commit 4e0cb960dbd95c8001b08c62682b085292184b87 Author: Vincenzo Pupillo Date: Thu Oct 10 16:06:37 2024 +0200 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) diff --git a/lisp/progmodes/php-ts-mode.el b/lisp/progmodes/php-ts-mode.el index d2559e5a45f..1c5fdb6f617 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.4" "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 +usefull 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 , 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 "" 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 "" 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. @@ -648,16 +676,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 +701,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 +714,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) @@ -774,21 +813,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 +846,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 +879,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 +902,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 +943,37 @@ 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_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,9 +988,9 @@ 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)) commit c2a9f519f7e9a5cbb5dbe50ba7b4e4b2757bb3b6 Merge: 6e70be26807 902029b1410 Author: Eli Zaretskii Date: Sat Oct 19 07:01:20 2024 -0400 Merge from origin/emacs-30 902029b1410 * lisp/auth-source.el (read-passwd): Remove entry from `p... a61bf742257 New FAQ about Ctrl keys on xterm f353fcc8506 Autoload 'message-narrow-to-headers-or-head' in mml.el commit 6e70be26807212c5387ad58af938c55006e0b88b Merge: c1791a27494 a815becb63b Author: Eli Zaretskii Date: Sat Oct 19 07:01:20 2024 -0400 ; Merge from origin/emacs-30 The following commit was skipped: a815becb63b * lisp/emacs-lisp/pcase.el (pcase--make-docstring): Fix b... commit 902029b1410ef9128380f9a307721ea6ab008529 Author: Michael Albinus Date: Sat Oct 19 12:36:32 2024 +0200 * lisp/auth-source.el (read-passwd): Remove entry from `post-command-hook'. 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. commit a61bf74225737a7c87b95d604b6e8c2ce9686296 Author: Eli Zaretskii Date: Sat Oct 19 12:14:06 2024 +0300 New FAQ about Ctrl keys on xterm * doc/misc/efaq.texi (Some Ctrl-modified keys do not work on xterm): New section (bug#73813). diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 1fe006c1249..eb38112be1b 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -4066,6 +4066,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 @@ -4537,6 +4538,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 commit f353fcc8506f510401982ec148b94120422f28cd Author: Eli Zaretskii Date: Sat Oct 19 11:57:09 2024 +0300 Autoload 'message-narrow-to-headers-or-head' in mml.el * lisp/gnus/mml.el (message-narrow-to-headers-or-head): Autoload it. (Bug#73815) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index e3bc3932529..8ecf7a33305 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -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 commit c1791a2749468a120bbb8b1023b041f2370fc679 Author: Manuel Giraud Date: Mon Oct 7 10:52:03 2024 +0200 Fix tmm menu layout (Bug#73734) * lisp/tmm.el (tmm-mb-map): Remove unused and unset keymap variable. * lisp/tmm.el (tmm-get-keymap): Fix menu layout to avoid confusion between the tmm-shortcut and the keybinding of the previous column. diff --git a/lisp/tmm.el b/lisp/tmm.el index ed74c307009..252c1e45afa 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -82,9 +82,6 @@ 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 @@ -325,14 +322,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 "^" 'self-insert-and-exit)) (prog1 (current-local-map) (use-local-map (append map (current-local-map)))))) @@ -487,13 +484,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; commit d0be0965ca344caab7879b2ac2373a68025c9ba2 Author: Eli Zaretskii Date: Sat Oct 19 11:18:45 2024 +0300 Fix etags tagging by multiline regexps * lib-src/etags.c (regex_tag_multiline): Fix off-by-one error in determining the end of the tag matched by a multiline regexp. (Bug#73771) * test/manual/etags/ETAGS.good_4: * test/manual/etags/ETAGS.good_5: * test/manual/etags/ETAGS.good_6: Adjust test results to the above change. 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/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 commit 7cbca90569472af5643905fca5b7ab2dea67f876 Author: Álvaro Ramírez Date: Wed Oct 2 11:36:57 2024 +0100 Hide default-directory absolute file name in dired-hide-details-mode * lisp/dired.el (dired-hide-details-hide-absolute-location): New user option. (dired-insert-directory, dired-build-subdir-alist): Use it to hide absolute file name of the directory. (dired-hide-details-mode): Update doc string. * test/lisp/dired-tests.el (dired-test-hide-absolute-location-enabled) (dired-test-hide-absolute-location-disabled): New tests * etc/NEWS: Announce the new feature. Bug#72272 diff --git a/etc/NEWS b/etc/NEWS index 10d86173235..a889528ab6a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -506,6 +506,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 +++ diff --git a/lisp/dired.el b/lisp/dired.el index 2bf5a221f4e..625de019d3b 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 @@ -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. @@ -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")) @@ -3282,6 +3302,11 @@ See options: `dired-hide-details-hide-symlink-targets' and 'add-to-invisibility-spec '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))) @@ -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/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 commit bcc4e64fa7aab9f44e3a7bcdf651a32ec52866c2 Author: Morgan Willcock Date: Sat Oct 5 18:33:51 2024 +0100 Rewrite Speedbar expansion for all descendants (bug#73533) Rewrite 'speedbar-expand-line-descendants' to avoid getting into an infinite loop by reaching max-lisp-eval-depth. The new method avoids querying and displaying information for every movement, instead using a single message to indicate that expansion is in progress, and so is significantly faster. The narrowing per item introduced by the fix for bug#35014 is removed because it prevented expanded descendant items when the top-level item was already expanded. * lisp/speedbar.el (speedbar--get-line-indent-level): New function to return the indentation level of the current line. (speedbar-expand-line-descendants): Use simpler line motion and no recursion. Output messages indicating when expansion is in progress and when it is completed. Fix expansion of descendants where the top-level item was already expanded. 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." commit 9dcc32f10cbae9497d6b33fcc739b75c1d5e411c Author: Morgan Willcock Date: Tue Oct 8 17:34:20 2024 +0100 Add Speedbar tests (bug#73533) Add Speedbar tests which test the operation of 'speedbar-expand-line-descendants'. * test/lisp/speedbar-tests.el (speedbar-tests-container) (eieio-speedbar-object-children, speedbar-tests-item) (speedbar-tests--make-object, speedbar-tests--setup-strings) (speedbar-tests--object-hierarchy, speedbar-tests--base-items) (speedbar-tests--clean-up, speedbar-tests--initialize) (speedbar-tests--object-name-expanded) (speedbar-tests--object-name-function) (speedbar-tests--objects-as-strings) (speedbar-tests--state-test) (speedbar-tests--expand-descendants-single) (speedbar-tests--expand-descendants-nested) (speedbar-tests--expand-descendants-nested-wide) (speedbar-tests--expand-descendants-of-first) (speedbar-tests--expand-descendants-of-first-expanded) (speedbar-tests--expand-descendants-of-last) (speedbar-tests--expand-descendants-of-last-expanded) (speedbar-tests--expand-descendants-of-middle) (speedbar-tests--expand-descendants-of-middle-expanded): New tests, test 'speedbar-expand-line-descendants'. 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 . + +;;; 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 commit a815becb63b48c472ee0b405c00db6a188ad6ddc Author: Stefan Monnier Date: Fri Oct 18 14:55:40 2024 -0400 * lisp/emacs-lisp/pcase.el (pcase--make-docstring): Fix bug#73766 Do not merge to `master`. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 5a7f3995311..e9b2980d3ed 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -181,7 +181,6 @@ Emacs Lisp manual for more information and examples." (let* ((main (documentation (symbol-function 'pcase) 'raw)) (ud (help-split-fundoc main 'pcase))) (require 'help-fns) - (declare-function help-fns-short-filename "help-fns" (filename)) (declare-function help-fns--signature "help-fns" (function doc real-def real-function buffer)) (with-temp-buffer @@ -214,7 +213,9 @@ Emacs Lisp manual for more information and examples." (save-excursion (forward-char -1) (insert (format-message " in `")) - (help-insert-xref-button (help-fns-short-filename filename) + ;; `file-name-nondirectory' is naive, but + ;; `help-fns-short-filename' is not fast enough yet (bug#73766). + (help-insert-xref-button (file-name-nondirectory filename) 'help-function-def symbol filename 'pcase-macro) (insert (format-message "'."))))