From fe491173e8f839653cb22eea63a7261f4aa1dca9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 9 Mar 2024 11:40:27 +0200 Subject: [PATCH 001/155] ; * doc/emacs/files.texi (Image Mode): Fix typo (bug#69671). --- doc/emacs/files.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 36f72d42ba2..971483a6e4c 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -2373,7 +2373,7 @@ multiply the size by the factor of @w{@code{1 + @var{n} / 10}}, so @findex image-decrease-size @kindex i - (Image mode) @item i - -Decrease the image size (@code{image-increase-size}) by 20%. Prefix +Decrease the image size (@code{image-decrease-size}) by 20%. Prefix numeric argument controls the decrement; the value of @var{n} means to multiply the size by the factor of @w{@code{1 - @var{n} / 10}}, so @w{@kbd{C-u 3 i -}} means to decrease the size by 30%. From db5915f30ba063b72b007d243fbd832e8a4e8961 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 10 Mar 2024 20:13:42 -0700 Subject: [PATCH 002/155] Fix 'with-sqlite-transaction' * lisp/sqlite.el (with-sqlite-transaction): Tuck misplaced body of else form back into feature-test control structure whence it escaped. (Bug#67142) * test/lisp/sqlite-tests.el: New file to accompany test/src/sqlite-tests.el. --- lisp/sqlite.el | 7 +++--- test/lisp/sqlite-tests.el | 51 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+), 3 deletions(-) create mode 100644 test/lisp/sqlite-tests.el diff --git a/lisp/sqlite.el b/lisp/sqlite.el index 46e35ac18d8..efc5997fb5c 100644 --- a/lisp/sqlite.el +++ b/lisp/sqlite.el @@ -32,7 +32,8 @@ If BODY completes normally, commit the changes and return the value of BODY. If BODY signals an error, or transaction commit fails, roll -back the transaction changes." +back the transaction changes before allowing the signal to +propagate." (declare (indent 1) (debug (form body))) (let ((db-var (gensym)) (func-var (gensym)) @@ -48,8 +49,8 @@ back the transaction changes." (setq ,res-var (funcall ,func-var)) (setq ,commit-var (sqlite-commit ,db-var)) ,res-var) - (or ,commit-var (sqlite-rollback ,db-var)))) - (funcall ,func-var)))) + (or ,commit-var (sqlite-rollback ,db-var))) + (funcall ,func-var))))) (provide 'sqlite) diff --git a/test/lisp/sqlite-tests.el b/test/lisp/sqlite-tests.el new file mode 100644 index 00000000000..d4892a27efc --- /dev/null +++ b/test/lisp/sqlite-tests.el @@ -0,0 +1,51 @@ +;;; sqlite-tests.el --- Tests for sqlite.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 'sqlite) + +(ert-deftest with-sqlite-transaction () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open))) + (sqlite-execute db "create table test (a)") + (should + (eql 42 (with-sqlite-transaction db + (sqlite-execute db "insert into test values (1)") + (should (equal '((1)) (sqlite-select db "select * from test"))) + 42))) + ;; Body runs exactly once. + (should (equal '((1)) (sqlite-select db "select * from test"))))) + +(ert-deftest with-sqlite-transaction/rollback () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open))) + (sqlite-execute db "create table test (a)") + (should (equal '(sqlite-error + ("SQL logic error" "no such function: fake" 1 1)) + (should-error + (with-sqlite-transaction db + (sqlite-execute db "insert into test values (1)") + (sqlite-execute db "insert into test values (fake(2))") + 42)))) + ;; First insertion (a=1) rolled back. + (should-not (sqlite-select db "select * from test")))) + +;;; sqlite-tests.el ends here From d5773276fb1671da619eeee2c316098d6b1c25c4 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 12 Mar 2024 08:48:09 -0400 Subject: [PATCH 003/155] (comp-known-predicates): Fix overly optimistic `functionp` * lisp/emacs-lisp/comp.el (comp-known-predicates): `functionp` can also be true for `cons` objects. --- lisp/emacs-lisp/comp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 21e2bb01ed0..9c2182092cb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -202,7 +202,7 @@ Useful to hook into pass checkers.") (consp . cons) (floatp . float) (framep . frame) - (functionp . (or function symbol)) + (functionp . (or function symbol cons)) (hash-table-p . hash-table) (integer-or-marker-p . integer-or-marker) (integerp . integer) @@ -244,6 +244,7 @@ Useful to hook into pass checkers.") (defun comp--pred-to-cstr (predicate) "Given PREDICATE, return the corresponding constraint." + ;; FIXME: Unify those two hash tables? (or (gethash predicate comp-known-predicates-h) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) From 7c552b22e64fa9173557e3511aa4e37ac1d5ea59 Mon Sep 17 00:00:00 2001 From: Daniel Pettersson Date: Wed, 28 Feb 2024 13:03:56 +0100 Subject: [PATCH 004/155] Jsonrpc: improve performance of process filter function `run-at-time' keeps `timer-list' list sorted by inserting each timer based on the timer value. This means that `timer--time-less-p' needs is executed ~N*N/2 times for each N pending messages. This means that jsonrpc becomes unusable for connections that generate a lot messages at the same time. * lisp/jsonrpc.el (Version): Bump to 1.0.25. (jsonrpc--process-filter): Improve performance by activating timers in a different order. (Bug#69241) --- lisp/jsonrpc.el | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 14fe0447008..5037d8c5b2b 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora ;; Keywords: processes, languages, extensions -;; Version: 1.0.24 +;; Version: 1.0.25 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -760,10 +760,11 @@ With optional CLEANUP, kill any associated buffers." (setq message (plist-put message :jsonrpc-json (buffer-string))) - (process-put proc 'jsonrpc-mqueue - (nconc (process-get proc - 'jsonrpc-mqueue) - (list message))))) + ;; Put new messages at the front of the queue, + ;; this is correct as the order is reversed + ;; before putting the timers on `timer-list'. + (push message + (process-get proc 'jsonrpc-mqueue)))) (goto-char message-end) (let ((inhibit-read-only t)) (delete-region (point-min) (point))) @@ -782,11 +783,20 @@ With optional CLEANUP, kill any associated buffers." ;; non-locally (typically the reply to a request), so do ;; this all this processing in top-level loops timer. (cl-loop + ;; `timer-activate' orders timers by time, which is an + ;; very expensive operation when jsonrpc-mqueue is large, + ;; therefore the time object is reused for each timer + ;; created. + with time = (current-time) for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg - do (run-at-time 0 nil - (lambda (m) (with-temp-buffer - (jsonrpc-connection-receive conn m))) - msg))))))) + do (let ((timer (timer-create))) + (timer-set-time timer time) + (timer-set-function timer + (lambda (conn msg) + (with-temp-buffer + (jsonrpc-connection-receive conn msg))) + (list conn msg)) + (timer-activate timer)))))))) (defun jsonrpc--remove (conn id &optional deferred-spec) "Cancel CONN's continuations for ID, including its timer, if it exists. From 0cc44094613530744d3650e4a169335374d6727b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Tue, 12 Mar 2024 15:30:18 +0200 Subject: [PATCH 005/155] ; * admin/MAINTAINERS: Add Daniel Pettersson. --- admin/MAINTAINERS | 3 +++ 1 file changed, 3 insertions(+) diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index f59c684e81f..ec719744339 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -360,6 +360,9 @@ Po Lu X11 and GTK xwidget support in src/xwidget.c Precision pixel scrolling in lisp/pixel-scroll.el +Daniel Pettersson + lisp/jsonrpc.el + ============================================================================== 3. Externally maintained packages. ============================================================================== From a9be5c7ea92e7868873d6d3c721d5a0be62ee3ad Mon Sep 17 00:00:00 2001 From: Arash Esbati Date: Tue, 12 Mar 2024 12:53:32 +0100 Subject: [PATCH 006/155] ; * doc/lispref/control.texi (Conditionals): Add missing paren (bug#69742). --- doc/lispref/control.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index eb1640ede52..292086ee4e0 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -322,7 +322,7 @@ described below. @defmac if-let spec then-form else-forms... Evaluate each binding in @var{spec} in turn, like in @code{let*} -(@pxref{Local Variables}, stopping if a binding value is @code{nil}. +(@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 From 3e96dd4f8851a45c66ebc9b8666ae449cc4c2725 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 12 Mar 2024 12:00:17 -0400 Subject: [PATCH 007/155] cl-generic: Signal an error when a type specializer won't work * lisp/emacs-lisp/cl-generic.el (cl--generic--unreachable-types): New var. (cl-generic-generalizers :extra "typeof"): Use it to signal an error for those types we can't handle. --- lisp/emacs-lisp/cl-generic.el | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 84eb800ec24..613ecf82a92 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1332,6 +1332,12 @@ These match if the argument is `eql' to VAL." ;;; Dispatch on "normal types". +(defconst cl--generic--unreachable-types + ;; FIXME: Try to make that list empty? + '(fixnum bignum boolean keyword + special-form subr-primitive subr-native-elisp) + "Built-in classes on which we cannot dispatch for technical reasons.") + (defun cl--generic-type-specializers (tag &rest _) (and (symbolp tag) (let ((class (cl--find-class tag))) @@ -1352,6 +1358,8 @@ This currently works for built-in types and types built on top of records." (and (symbolp type) (not (eq type t)) ;; Handled by the `t-generalizer'. (let ((class (cl--find-class type))) + (when (memq type cl--generic--unreachable-types) + (error "Dispatch on %S is currently not supported" type)) (memq (type-of class) '(built-in-class cl-structure-class eieio--class))) (list cl--generic-typeof-generalizer)) From 8df673907781bce8b080b91b056cb9987587387c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 12 Mar 2024 15:43:43 -0400 Subject: [PATCH 008/155] Cleanup some type predicates Use the new `cl--define-built-in-type` to reduce the manually maintained list of built-in type predicates. Also tweak docstrings to use "supertype" rather than "super type", since it seems to be what we use elsewhere. * lisp/subr.el (special-form-p): Remove redundant `fboundp` test. (compiled-function-p): Don'Return nil for subrs that aren't functions. * lisp/emacs-lisp/cl-macs.el (type predicates): Trim down the list. * lisp/emacs-lisp/cl-preloaded.el (cl--define-built-in-type): Register the corresponding predicate if applicable. (atom, null): Specify the predicate name explicitly. --- lisp/emacs-lisp/cl-macs.el | 45 ++++------------------------- lisp/emacs-lisp/cl-preloaded.el | 51 +++++++++++++++++++++------------ lisp/emacs-lisp/oclosure.el | 2 +- lisp/subr.el | 6 ++-- 4 files changed, 42 insertions(+), 62 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index be477b7a6df..129b83c61b9 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3463,45 +3463,12 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;; Please keep it in sync with `comp-known-predicates'. (pcase-dolist (`(,type . ,pred) ;; Mostly kept in alphabetical order. - '((array . arrayp) - (atom . atom) - (base-char . characterp) - (bignum . bignump) - (boolean . booleanp) - (bool-vector . bool-vector-p) - (buffer . bufferp) - (byte-code-function . byte-code-function-p) - (character . natnump) - (char-table . char-table-p) - (command . commandp) - (compiled-function . compiled-function-p) - (hash-table . hash-table-p) - (cons . consp) - (fixnum . fixnump) - (float . floatp) - (frame . framep) - (function . functionp) - (integer . integerp) - (keyword . keywordp) - (list . listp) - (marker . markerp) - (natnum . natnump) - (number . numberp) - (null . null) - (obarray . obarrayp) - (overlay . overlayp) - (process . processp) - (real . numberp) - (sequence . sequencep) - (subr . subrp) - (string . stringp) - (symbol . symbolp) - (symbol-with-pos . symbol-with-pos-p) - (vector . vectorp) - (window . windowp) - ;; FIXME: Do we really want to consider these types? - (number-or-marker . number-or-marker-p) - (integer-or-marker . integer-or-marker-p) + ;; These aren't defined via `cl--define-built-in-type'. + '((base-char . characterp) ;Could be subtype of `fixnum'. + (character . natnump) ;Could be subtype of `fixnum'. + (command . commandp) ;Subtype of closure & subr. + (natnum . natnump) ;Subtype of fixnum & bignum. + (real . numberp) ;Not clear where it would fit. )) (put type 'cl-deftype-satisfies pred)) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 5743684fa89..515aa99549d 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -308,7 +308,7 @@ (:copier nil)) ) -(defmacro cl--define-built-in-type (name parents &optional docstring &rest _slots) +(defmacro cl--define-built-in-type (name parents &optional docstring &rest slots) ;; `slots' is currently unused, but we could make it take ;; a list of "slot like properties" together with the corresponding ;; accessor, and then we could maybe even make `slot-value' work @@ -317,15 +317,26 @@ (unless (listp parents) (setq parents (list parents))) (unless (or parents (eq name t)) (error "Missing parents for %S: %S" name parents)) - `(progn - (put ',name 'cl--class - (built-in-class--make ',name ,docstring - (mapcar (lambda (type) - (let ((class (get type 'cl--class))) - (unless class - (error "Unknown type: %S" type)) - class)) - ',parents))))) + (let ((predicate (intern-soft (format + (if (string-match "-" (symbol-name name)) + "%s-p" "%sp") + name)))) + (unless (fboundp predicate) (setq predicate nil)) + (while (keywordp (car slots)) + (let ((kw (pop slots)) (val (pop slots))) + (pcase kw + (:predicate (setq predicate val)) + (_ (error "Unknown keyword arg: %S" kw))))) + `(progn + ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate)) + (put ',name 'cl--class + (built-in-class--make ',name ,docstring + (mapcar (lambda (type) + (let ((class (get type 'cl--class))) + (unless class + (error "Unknown type: %S" type)) + class)) + ',parents)))))) ;; FIXME: Our type DAG has various quirks: ;; - `subr' says it's a `compiled-function' but that's not true @@ -336,8 +347,9 @@ ;; so the DAG of OClosure types is "orthogonal" to the distinction ;; between interpreted and compiled functions. -(cl--define-built-in-type t nil "The type of everything.") -(cl--define-built-in-type atom t "The type of anything but cons cells.") +(cl--define-built-in-type t nil "Abstract supertype of everything.") +(cl--define-built-in-type atom t "Abstract supertype of anything but cons cells." + :predicate atom) (cl--define-built-in-type tree-sitter-compiled-query atom) (cl--define-built-in-type tree-sitter-node atom) @@ -358,7 +370,7 @@ (cl--define-built-in-type window-configuration atom) (cl--define-built-in-type overlay atom) (cl--define-built-in-type number-or-marker atom - "Abstract super type of both `number's and `marker's.") + "Abstract supertype of both `number's and `marker's.") (cl--define-built-in-type symbol atom "Type of symbols." ;; Example of slots we could document. It would be desirable to @@ -373,14 +385,14 @@ (cl--define-built-in-type obarray atom) (cl--define-built-in-type native-comp-unit atom) -(cl--define-built-in-type sequence t "Abstract super type of sequences.") +(cl--define-built-in-type sequence t "Abstract supertype of sequences.") (cl--define-built-in-type list sequence) -(cl--define-built-in-type array (sequence atom) "Abstract super type of arrays.") +(cl--define-built-in-type array (sequence atom) "Abstract supertype of arrays.") (cl--define-built-in-type number (number-or-marker) - "Abstract super type of numbers.") + "Abstract supertype of numbers.") (cl--define-built-in-type float (number)) (cl--define-built-in-type integer-or-marker (number-or-marker) - "Abstract super type of both `integer's and `marker's.") + "Abstract supertype of both `integer's and `marker's.") (cl--define-built-in-type integer (number integer-or-marker)) (cl--define-built-in-type marker (integer-or-marker)) (cl--define-built-in-type bignum (integer) @@ -404,13 +416,14 @@ For this build of Emacs it's %dbit." "Type of special arrays that are indexed by characters.") (cl--define-built-in-type string (array)) (cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'? - "Type of the nil value.") + "Type of the nil value." + :predicate null) (cl--define-built-in-type cons (list) "Type of cons cells." ;; Example of slots we could document. (car car) (cdr cdr)) (cl--define-built-in-type function (atom) - "Abstract super type of function values.") + "Abstract supertype of function values.") (cl--define-built-in-type compiled-function (function) "Abstract type of functions that have been compiled.") (cl--define-built-in-type byte-code-function (compiled-function) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 977d5735171..4da8e61aaa7 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -437,7 +437,7 @@ This has 2 uses: - For compiled code, this is used as a marker which cconv uses to check that immutable fields are indeed not mutated." (if (byte-code-function-p oclosure) - ;; Actually, this should never happen since the `cconv.el' should have + ;; Actually, this should never happen since `cconv.el' should have ;; optimized away the call to this function. oclosure ;; For byte-coded functions, we store the type as a symbol in the docstring diff --git a/lisp/subr.el b/lisp/subr.el index ce933e3bfdc..38a3f6edb34 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4494,8 +4494,7 @@ Otherwise, return nil." (defun special-form-p (object) "Non-nil if and only if OBJECT is a special form." (declare (side-effect-free error-free)) - (if (and (symbolp object) (fboundp object)) - (setq object (indirect-function object))) + (if (symbolp object) (setq object (indirect-function object))) (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) (defun plistp (object) @@ -4517,7 +4516,8 @@ Otherwise, return nil." Does not distinguish between functions implemented in machine code or byte-code." (declare (side-effect-free error-free)) - (or (subrp object) (byte-code-function-p object))) + (or (and (subrp object) (not (eq 'unevalled (cdr (subr-arity object))))) + (byte-code-function-p object))) (defun field-at-pos (pos) "Return the field at position POS, taking stickiness etc into account." From 4afafa03704aab0c21e4cb4f028256ecead5f795 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 12 Mar 2024 16:09:23 -0400 Subject: [PATCH 009/155] Try and avoid hardcoding lists of function types * lisp/bind-key.el (bind-key--get-binding-description): Show docstrings for compiled functions also. Don't hardcode knowledge about various particular kinds of functions. * lisp/emacs-lisp/bytecomp.el (display-call-tree): Remove special support for functions with a `byte-code` body since we never generate that nowadays. Don't hardcode knowledge about various particular kinds of functions. --- lisp/bind-key.el | 42 +++++++++++++++++-------------------- lisp/emacs-lisp/bytecomp.el | 15 +++---------- 2 files changed, 22 insertions(+), 35 deletions(-) diff --git a/lisp/bind-key.el b/lisp/bind-key.el index 378ad69b2bc..1e59c75566a 100644 --- a/lisp/bind-key.el +++ b/lisp/bind-key.el @@ -453,31 +453,27 @@ other modes. See `override-global-mode'." (macroexp-progn (bind-keys-form args 'override-global-map))) (defun bind-key--get-binding-description (elem) - (cond - ((listp elem) + (let (doc) (cond - ((memq (car elem) '(lambda function)) - (if (and bind-key-describe-special-forms - (stringp (nth 2 elem))) - (nth 2 elem) - "#")) - ((eq 'closure (car elem)) - (if (and bind-key-describe-special-forms - (stringp (nth 3 elem))) - (nth 3 elem) - "#")) - ((eq 'keymap (car elem)) - "#") + ((symbolp elem) + (cond + ((and bind-key-describe-special-forms (keymapp elem) + ;; FIXME: Is this really ever better than the symbol-name? + ;; FIXME: `variable-documentation' describe what's in + ;; elem's `symbol-value', whereas `elem' here stands for + ;; its `symbol-function'. + (stringp (setq doc (get elem 'variable-documentation)))) + doc) + (t elem))) + ((and bind-key-describe-special-forms (functionp elem) + (stringp (setq doc (documentation elem)))) + doc) ;;FIXME: Keep only the first line? + ((consp elem) + (if (symbolp (car elem)) + (format "#<%s>" (car elem)) + elem)) (t - elem))) - ;; must be a symbol, non-symbol keymap case covered above - ((and bind-key-describe-special-forms (keymapp elem)) - (let ((doc (get elem 'variable-documentation))) - (if (stringp doc) doc elem))) - ((symbolp elem) - elem) - (t - "#"))) + (format "#<%s>" (type-of elem)))))) (defun bind-key--compare-keybindings (l r) (let* ((regex bind-key-segregation-regexp) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index cf0e6d600dd..7af568cfe34 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5536,23 +5536,14 @@ invoked interactively." (if (null f) " ";; shouldn't insert nil then, actually -sk " ")) - ((subrp (setq f (symbol-function f))) - " ") - ((symbolp f) + ((symbolp (setq f (symbol-function f))) ;; An alias. (format " ==> %s" f)) - ((byte-code-function-p f) - "") ((not (consp f)) - "") + (format " <%s>" (type-of f))) ((eq 'macro (car f)) - (if (or (compiled-function-p (cdr f)) - ;; FIXME: Can this still happen? - (assq 'byte-code (cdr (cdr (cdr f))))) + (if (compiled-function-p (cdr f)) " " " ")) - ((assq 'byte-code (cdr (cdr f))) - ;; FIXME: Can this still happen? - "") ((eq 'lambda (car f)) "") (t "???")) From db027a06976ee1bcbe6294e281bd5954dd1052ef Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Tue, 12 Mar 2024 22:47:45 +0100 Subject: [PATCH 010/155] ; Fix bibtex-biblatex-field-alist docstring typo. --- lisp/textmodes/bibtex.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 3d155ac87b5..d78dac53516 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -1012,7 +1012,7 @@ if `bibtex-BibTeX-entry-alist' does not define a comment for FIELD." ("volumes" "Total number of volumes of a multi-volume work") ("year" "Year of publication")) "Alist of biblatex fields. -It has the same format as `bibtex-BibTeX-entry-alist'." +It has the same format as `bibtex-BibTeX-field-alist'." :group 'bibtex :version "28.1" :type 'bibtex-field-alist) From 6b40d557c4a9a4152565c1a1b0da49a1aaaec84f Mon Sep 17 00:00:00 2001 From: Po Lu Date: Wed, 13 Mar 2024 10:59:39 +0800 Subject: [PATCH 011/155] Port more notification senders to non-XDG systems * doc/lispref/os.texi (Desktop Notifications): Document that `:timeout' is now implemented. * java/org/gnu/emacs/EmacsDesktopNotification.java (EmacsDesktopNotification): New field delay. (display1): Set delay on Android 8.0 and up. * lisp/erc/erc-desktop-notifications.el (erc-notifications-notify): Call Android or Haiku notification functions on those systems. * lisp/gnus/gnus-notifications.el (gnus-notifications-action) (gnus-notification-close): Remove dismissed notifications from the notification to message map. (gnus-notifications-notify): Call android-notifications-notify if possible. * src/androidselect.c (android_init_emacs_desktop_notification): Update accordingly. (android_notifications_notify_1): New argument TIMEOUT. (Fandroid_notifications_notify): New argument QCtimeout. (syms_of_androidselect) : New symbol. --- doc/lispref/os.texi | 1 + .../gnu/emacs/EmacsDesktopNotification.java | 10 ++- lisp/erc/erc-desktop-notifications.el | 24 ++++-- lisp/gnus/gnus-notifications.el | 41 ++++++--- src/androidselect.c | 86 +++++++++++++------ 5 files changed, 115 insertions(+), 47 deletions(-) diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 435886320fd..3ba3da459bf 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -3244,6 +3244,7 @@ of parameters analogous to its namesake in @item :on-action @var{on-action} @item :on-cancel @var{on-close} @item :actions @var{actions} +@item :timeout @var{timeout} @item :resident @var{resident} These have the same meaning as they do when used in calls to @code{notifications-notify}, except that no more than three non-default diff --git a/java/org/gnu/emacs/EmacsDesktopNotification.java b/java/org/gnu/emacs/EmacsDesktopNotification.java index d05ed2e6203..d00b9f2ea22 100644 --- a/java/org/gnu/emacs/EmacsDesktopNotification.java +++ b/java/org/gnu/emacs/EmacsDesktopNotification.java @@ -83,11 +83,16 @@ public final class EmacsDesktopNotification notification. */ public final String[] actions, titles; + /* Delay in miliseconds after which this notification should be + automatically dismissed. */ + public final long delay; + public EmacsDesktopNotification (String title, String content, String group, String tag, int icon, int importance, - String[] actions, String[] titles) + String[] actions, String[] titles, + long delay) { this.content = content; this.title = title; @@ -97,6 +102,7 @@ public final class EmacsDesktopNotification this.importance = importance; this.actions = actions; this.titles = titles; + this.delay = delay; } @@ -191,6 +197,8 @@ public final class EmacsDesktopNotification builder.setContentTitle (title); builder.setContentText (content); builder.setSmallIcon (icon); + builder.setTimeoutAfter (delay); + insertActions (context, builder); notification = builder.build (); } diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index 2e905097f97..9bb89fbfc81 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -54,6 +54,9 @@ (defvar dbus-debug) ; used in the macroexpansion of dbus-ignore-errors +(declare-function haiku-notifications-notify "haikuselect.c") +(declare-function android-notifications-notify "androidselect.c") + (defun erc-notifications-notify (nick msg &optional privp) "Notify that NICK send some MSG, where PRIVP should be non-nil for PRIVMSGs. This will replace the last notification sent with this function." @@ -64,14 +67,19 @@ This will replace the last notification sent with this function." (let* ((channel (if privp (erc-get-buffer nick) (current-buffer))) (title (format "%s in %s" (xml-escape-string nick t) channel)) (body (xml-escape-string (erc-controls-strip msg) t))) - (notifications-notify :bus erc-notifications-bus - :title title - :body body - :replaces-id erc-notifications-last-notification - :app-icon erc-notifications-icon - :actions '("default" "Switch to buffer") - :on-action (lambda (&rest _) - (pop-to-buffer channel))))))) + (funcall (cond ((featurep 'android) + #'android-notifications-notify) + ((featurep 'haiku) + #'haiku-notifications-notify) + (t #'notifications-notify)) + :bus erc-notifications-bus + :title title + :body body + :replaces-id erc-notifications-last-notification + :app-icon erc-notifications-icon + :actions '("default" "Switch to buffer") + :on-action (lambda (&rest _) + (pop-to-buffer channel))))))) (defun erc-notifications-PRIVMSG (_proc parsed) (let ((nick (car (erc-parse-user (erc-response.sender parsed)))) diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el index f34f5ea0e26..9ef21c91627 100644 --- a/lisp/gnus/gnus-notifications.el +++ b/lisp/gnus/gnus-notifications.el @@ -83,27 +83,46 @@ not get notifications." group (delq article (gnus-list-of-unread-articles group))) ;; gnus-group-refresh-group - (gnus-group-update-group group))))))) + (gnus-group-update-group group)))))) + ;; Notifications are removed unless otherwise specified once they (or + ;; an action of theirs) are selected + (assoc-delete-all id gnus-notifications-id-to-msg)) + +(defun gnus-notification-close (id reason) + "Remove ID from the alist of notification identifiers to messages. +REASON is ignored." + (assoc-delete-all id gnus-notifications-id-to-msg)) (defun gnus-notifications-notify (from subject photo-file) "Send a notification about a new mail. Return a notification id if any, or t on success." - (if (fboundp 'notifications-notify) + (if (featurep 'android) (gnus-funcall-no-warning - 'notifications-notify + 'android-notifications-notify :title from :body subject :actions '("read" "Read" "mark-read" "Mark As Read") :on-action 'gnus-notifications-action - :app-icon (gnus-funcall-no-warning - 'image-search-load-path "gnus/gnus.png") - :image-path photo-file - :app-name "Gnus" - :category "email.arrived" + :on-close 'gnus-notifications-close + :group "Email arrivals" :timeout gnus-notifications-timeout) - (message "New message from %s: %s" from subject) - ;; Don't return an id - t)) + (if (fboundp 'notifications-notify) + (gnus-funcall-no-warning + 'notifications-notify + :title from + :body subject + :actions '("read" "Read" "mark-read" "Mark As Read") + :on-action 'gnus-notifications-action + :on-close 'gnus-notifications-close + :app-icon (gnus-funcall-no-warning + 'image-search-load-path "gnus/gnus.png") + :image-path photo-file + :app-name "Gnus" + :category "email.arrived" + :timeout gnus-notifications-timeout) + (message "New message from %s: %s" from subject) + ;; Don't return an id + t))) (declare-function gravatar-retrieve-synchronously "gravatar.el" (mail-address)) diff --git a/src/androidselect.c b/src/androidselect.c index 521133976a7..87dd2c3d079 100644 --- a/src/androidselect.c +++ b/src/androidselect.c @@ -526,7 +526,7 @@ android_init_emacs_desktop_notification (void) FIND_METHOD (init, "", "(Ljava/lang/String;" "Ljava/lang/String;Ljava/lang/String;" "Ljava/lang/String;II[Ljava/lang/String;" - "[Ljava/lang/String;)V"); + "[Ljava/lang/String;J)V"); FIND_METHOD (display, "display", "()V"); #undef FIND_METHOD } @@ -567,16 +567,17 @@ android_locate_icon (const char *name) } /* Display a desktop notification with the provided TITLE, BODY, - REPLACES_ID, GROUP, ICON, URGENCY, ACTIONS, RESIDENT, ACTION_CB and - CLOSE_CB. Return an identifier for the resulting notification. */ + REPLACES_ID, GROUP, ICON, URGENCY, ACTIONS, TIMEOUT, RESIDENT, + ACTION_CB and CLOSE_CB. Return an identifier for the resulting + notification. */ static intmax_t android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, Lisp_Object replaces_id, Lisp_Object group, Lisp_Object icon, Lisp_Object urgency, Lisp_Object actions, - Lisp_Object resident, Lisp_Object action_cb, - Lisp_Object close_cb) + Lisp_Object timeout, Lisp_Object resident, + Lisp_Object action_cb, Lisp_Object close_cb) { static intmax_t counter; intmax_t id; @@ -593,6 +594,7 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, jint nitems, i; jstring item; Lisp_Object length; + jlong timeout_val; if (EQ (urgency, Qlow)) type = 2; /* IMPORTANCE_LOW */ @@ -603,6 +605,23 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, else signal_error ("Invalid notification importance given", urgency); + /* Decode the timeout. */ + + timeout_val = 0; + + if (!NILP (timeout)) + { + CHECK_INTEGER (timeout); + + if (!integer_to_intmax (timeout, &id) + || id > TYPE_MAXIMUM (jlong) + || id < TYPE_MINIMUM (jlong)) + signal_error ("Invalid timeout", timeout); + + if (id > 0) + timeout_val = id; + } + nitems = 0; /* If ACTIONS is provided, split it into two arrays of Java strings @@ -714,7 +733,8 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, notification_class.init, title1, body1, group1, identifier1, icon1, type, - action_keys, action_titles); + action_keys, action_titles, + timeout_val); android_exception_check_6 (title1, body1, group1, identifier1, action_titles, action_keys); @@ -723,12 +743,8 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, ANDROID_DELETE_LOCAL_REF (body1); ANDROID_DELETE_LOCAL_REF (group1); ANDROID_DELETE_LOCAL_REF (identifier1); - - if (action_keys) - ANDROID_DELETE_LOCAL_REF (action_keys); - - if (action_titles) - ANDROID_DELETE_LOCAL_REF (action_titles); + ANDROID_DELETE_LOCAL_REF (action_keys); + ANDROID_DELETE_LOCAL_REF (action_titles); /* Display the notification. */ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -769,8 +785,14 @@ keywords is understood: The action for which CALLBACK is called when the notification itself is selected is named "default", its existence is implied, and its TITLE is ignored. - No more than three actions can be defined, not - counting any action with "default" as its key. + No more than three actions defined here will be + displayed, not counting any with "default" as its + key. + :timeout Number of miliseconds from the display of the + notification at which it will be automatically + dismissed, or a value of zero or smaller if it + is to remain until user action is taken to dismiss + it. :resident When set the notification will not be automatically dismissed when it or an action is selected. :on-action Function to call when an action is invoked. @@ -780,12 +802,15 @@ keywords is understood: with the notification id and the symbol `undefined' for arguments. -The notification group is ignored on Android 7.1 and earlier versions -of Android. Outside such older systems, it identifies a category that -will be displayed in the system Settings menu, and the urgency -provided always extends to affect all notifications displayed within -that category. If the group is not provided, it defaults to the -string "Desktop Notifications". +The notification group and timeout are ignored on Android 7.1 and +earlier versions of Android. On more recent versions, the urgency +identifies a category that will be displayed in the system Settings +menu, and the urgency provided always extends to affect all +notifications displayed within that category, though it may be ignored +if higher than any previously-specified urgency or if the user have +already configured a different urgency for this category from Settings. +If the group is not provided, it defaults to the string "Desktop +Notifications" with the urgency suffixed. Each caller should strive to provide one unchanging combination of notification group and urgency for each kind of notification it sends, @@ -795,8 +820,8 @@ first notification sent to its notification group. The provided icon should be the name of a "drawable resource" present within the "android.R.drawable" class designating an icon with a -transparent background. If no icon is provided (or the icon is absent -from this system), it defaults to "ic_dialog_alert". +transparent background. Should no icon be provided (or the icon is +absent from this system), it defaults to "ic_dialog_alert". Actions specified with :actions cannot be displayed on Android 4.0 and earlier versions of the system. @@ -814,17 +839,18 @@ this function. usage: (android-notifications-notify &rest ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object title, body, replaces_id, group, urgency, resident; + Lisp_Object title, body, replaces_id, group, urgency, timeout, resident; Lisp_Object icon; Lisp_Object key, value, actions, action_cb, close_cb; ptrdiff_t i; + AUTO_STRING (default_icon, "ic_dialog_alert"); if (!android_init_gui) error ("No Android display connection!"); /* Clear each variable above. */ title = body = replaces_id = group = icon = urgency = actions = Qnil; - resident = action_cb = close_cb = Qnil; + timeout = resident = action_cb = close_cb = Qnil; /* If NARGS is odd, error. */ @@ -852,6 +878,8 @@ usage: (android-notifications-notify &rest ARGS) */) icon = value; else if (EQ (key, QCactions)) actions = value; + else if (EQ (key, QCtimeout)) + timeout = value; else if (EQ (key, QCresident)) resident = value; else if (EQ (key, QCon_action)) @@ -874,16 +902,19 @@ usage: (android-notifications-notify &rest ARGS) */) urgency = Qlow; if (NILP (group)) - group = build_string ("Desktop Notifications"); + { + AUTO_STRING (format, "Desktop Notifications (%s importance)"); + group = CALLN (Fformat, format, urgency); + } if (NILP (icon)) - icon = build_string ("ic_dialog_alert"); + icon = default_icon; else CHECK_STRING (icon); return make_int (android_notifications_notify_1 (title, body, replaces_id, group, icon, urgency, - actions, resident, + actions, timeout, resident, action_cb, close_cb)); } @@ -1001,6 +1032,7 @@ syms_of_androidselect (void) DEFSYM (QCurgency, ":urgency"); DEFSYM (QCicon, ":icon"); DEFSYM (QCactions, ":actions"); + DEFSYM (QCtimeout, ":timeout"); DEFSYM (QCresident, ":resident"); DEFSYM (QCon_action, ":on-action"); DEFSYM (QCon_close, ":on-close"); From 4ac4cec652ffaca4333d8f297b8a6c0e5bd79c68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gerd=20M=C3=B6llmann?= Date: Sat, 9 Mar 2024 15:06:29 +0100 Subject: [PATCH 012/155] Prevent freezes on macOS (bug#69561) * src/nsterm.m (ns_select_1): Store pending input_events. Always call [NSApp run]. --- src/nsterm.m | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/nsterm.m b/src/nsterm.m index f094b145fe3..f161edc4ac2 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -4739,12 +4739,15 @@ Function modeled after x_draw_glyph_string_box (). check_native_fs (); #endif - if (hold_event_q.nr > 0 && !run_loop_only) + /* If there are input events pending, store them so that Emacs can + recognize C-g. (And we must make sure [NSApp run] is called in + this function, so that C-g has a chance to land in + hold_event_q.) */ + if (hold_event_q.nr > 0) { - /* We already have events pending. */ - raise (SIGIO); - errno = EINTR; - return -1; + for (int i = 0; i < hold_event_q.nr; ++i) + kbd_buffer_store_event_hold (&hold_event_q.q[i], NULL); + hold_event_q.nr = 0; } eassert (nfds <= FD_SETSIZE); @@ -4757,8 +4760,8 @@ Function modeled after x_draw_glyph_string_box (). if (NSApp == nil || ![NSThread isMainThread] || (timeout && timeout->tv_sec == 0 && timeout->tv_nsec == 0)) - return thread_select (pselect, nfds, readfds, writefds, - exceptfds, timeout, sigmask); + thread_select (pselect, nfds, readfds, writefds, + exceptfds, timeout, sigmask); else { struct timespec t = {0, 0}; From e7e285ec348c8c19b1ce06a52b89baec71956d7a Mon Sep 17 00:00:00 2001 From: Po Lu Date: Wed, 13 Mar 2024 15:33:24 +0800 Subject: [PATCH 013/155] Fix crash when displaying notifications on Android 3.0 * java/org/gnu/emacs/EmacsDesktopNotification.java (display1): Don't call setPriority until Jelly Bean. --- java/org/gnu/emacs/EmacsDesktopNotification.java | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/java/org/gnu/emacs/EmacsDesktopNotification.java b/java/org/gnu/emacs/EmacsDesktopNotification.java index d00b9f2ea22..d072994df2b 100644 --- a/java/org/gnu/emacs/EmacsDesktopNotification.java +++ b/java/org/gnu/emacs/EmacsDesktopNotification.java @@ -228,10 +228,12 @@ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) builder.setContentTitle (title); builder.setContentText (content); builder.setSmallIcon (icon); - builder.setPriority (priority); if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.JELLY_BEAN) - insertActions (context, builder); + { + builder.setPriority (priority); + insertActions (context, builder); + } notification = builder.build (); From c5945e0f9eaf01e653d5afbce72837a05e3e347a Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Wed, 13 Mar 2024 07:38:49 -0700 Subject: [PATCH 014/155] Fix name of gnus-notification(s)-close; ignore argument * lisp/gnus/gnus-notifications.el (gnus-notifications-close): Original name was probably a typo. --- lisp/gnus/gnus-notifications.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el index 9ef21c91627..35f90ebfe40 100644 --- a/lisp/gnus/gnus-notifications.el +++ b/lisp/gnus/gnus-notifications.el @@ -88,7 +88,7 @@ not get notifications." ;; an action of theirs) are selected (assoc-delete-all id gnus-notifications-id-to-msg)) -(defun gnus-notification-close (id reason) +(defun gnus-notifications-close (id _reason) "Remove ID from the alist of notification identifiers to messages. REASON is ignored." (assoc-delete-all id gnus-notifications-id-to-msg)) From d95f2a882d5f0587a8e02c5be6f0fd005d4a6a43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gerd=20M=C3=B6llmann?= Date: Wed, 13 Mar 2024 20:27:20 +0100 Subject: [PATCH 015/155] ns_select fix for macOS terminals (bug#69561) * src/nsterm.m (ns_select_1): Return early for terminals. --- src/nsterm.m | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/nsterm.m b/src/nsterm.m index f161edc4ac2..faf9324402b 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -4757,8 +4757,12 @@ Function modeled after x_draw_glyph_string_box (). if (writefds && FD_ISSET(k, writefds)) ++nr; } - if (NSApp == nil - || ![NSThread isMainThread] + /* emacs -nw doesn't have an NSApp, so we're done. */ + if (NSApp == nil) + return thread_select (pselect, nfds, readfds, writefds, exceptfds, + timeout, sigmask); + + if (![NSThread isMainThread] || (timeout && timeout->tv_sec == 0 && timeout->tv_nsec == 0)) thread_select (pselect, nfds, readfds, writefds, exceptfds, timeout, sigmask); From db5c8bda638468f8798c974f4ef4ab3905dbddd3 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Thu, 14 Mar 2024 08:24:42 +0800 Subject: [PATCH 016/155] ; * java/org/gnu/emacs/EmacsDesktopNotification.java (display1): Another fix. --- java/org/gnu/emacs/EmacsDesktopNotification.java | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/java/org/gnu/emacs/EmacsDesktopNotification.java b/java/org/gnu/emacs/EmacsDesktopNotification.java index d072994df2b..c80aa21b4fe 100644 --- a/java/org/gnu/emacs/EmacsDesktopNotification.java +++ b/java/org/gnu/emacs/EmacsDesktopNotification.java @@ -233,9 +233,10 @@ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) { builder.setPriority (priority); insertActions (context, builder); + notification = builder.build (); } - - notification = builder.build (); + else + notification = builder.getNotification (); if (Build.VERSION.SDK_INT > Build.VERSION_CODES.JELLY_BEAN) notification.priority = priority; From 30bc867aecc59265b6e315acf459f8d79c423bca Mon Sep 17 00:00:00 2001 From: Po Lu Date: Thu, 14 Mar 2024 13:45:48 +0800 Subject: [PATCH 017/155] Improve /proc/self/exe substitution on Android * exec/configure.ac (USER_SWORD): New macro. * exec/exec.c (format_pid): Export this function. * exec/exec.h: * exec/trace.c (canon_path): New function. (handle_readlinkat, handle_openat): Test complete file name against /proc/self/exe, and further check for /proc/pid/exe. --- exec/configure.ac | 8 +++ exec/exec.c | 2 +- exec/exec.h | 1 + exec/trace.c | 121 ++++++++++++++++++++++++++++++++++++++++++---- 4 files changed, 121 insertions(+), 11 deletions(-) diff --git a/exec/configure.ac b/exec/configure.ac index 317250332cb..a473a1dc633 100644 --- a/exec/configure.ac +++ b/exec/configure.ac @@ -122,6 +122,7 @@ AH_TEMPLATE([SYSCALL_RET_REG], [Define to register holding value of system calls AH_TEMPLATE([STACK_POINTER], [Define to register holding the stack pointer.]) AH_TEMPLATE([EXEC_SYSCALL], [Define to number of the `exec' system call.]) AH_TEMPLATE([USER_WORD], [Define to word type used by tracees.]) +AH_TEMPLATE([USER_SWORD], [Define to signed word type used by tracees.]) AH_TEMPLATE([EXEC_64], [Define to 1 if the system utilizes 64-bit ELF.]) AH_TEMPLATE([STACK_GROWS_DOWNWARDS], [Define to 1 if the stack grows downwards.]) AH_TEMPLATE([ABI_RED_ZONE], [Define to number of reserved bytes past the stack frame.]) @@ -251,6 +252,7 @@ AS_CASE([$host], [x86_64-*linux*], AC_DEFINE([STACK_POINTER], [rsp]) AC_DEFINE([EXEC_SYSCALL], [__NR_execve]) AC_DEFINE([USER_WORD], [uintptr_t]) + AC_DEFINE([USER_SWORD], [intptr_t]) AC_DEFINE([EXEC_64], [1]) AC_DEFINE([ABI_RED_ZONE], [128]) AC_DEFINE([EXECUTABLE_BASE], [0x555555554000]) @@ -283,6 +285,7 @@ AS_CASE([$host], [x86_64-*linux*], AC_DEFINE([STACK_POINTER], [esp]) AC_DEFINE([EXEC_SYSCALL], [__NR_execve]) AC_DEFINE([USER_WORD], [uintptr_t]) + AC_DEFINE([USER_SWORD], [intptr_t]) AC_DEFINE([EXECUTABLE_BASE], [0x0f000000]) AC_DEFINE([INTERPRETER_BASE], [0xaf000000]) AC_DEFINE([STACK_GROWS_DOWNWARDS], [1]) @@ -313,6 +316,7 @@ AS_CASE([$host], [x86_64-*linux*], AC_DEFINE([STACK_POINTER], [sp]) AC_DEFINE([EXEC_SYSCALL], [__NR_execve]) AC_DEFINE([USER_WORD], [uintptr_t]) + AC_DEFINE([USER_SWORD], [intptr_t]) AC_DEFINE([EXEC_64], [1]) AC_DEFINE([EXECUTABLE_BASE], [0x3000000000]) AC_DEFINE([INTERPRETER_BASE], [0x3f00000000]) @@ -344,6 +348,7 @@ AS_CASE([$host], [x86_64-*linux*], AC_DEFINE([STACK_POINTER], [[uregs[13]]]) AC_DEFINE([EXEC_SYSCALL], [__NR_execve]) AC_DEFINE([USER_WORD], [uintptr_t]) + AC_DEFINE([USER_SWORD], [intptr_t]) AC_DEFINE([EXECUTABLE_BASE], [0x0f000000]) AC_DEFINE([INTERPRETER_BASE], [0x1f000000]) AC_DEFINE([STACK_GROWS_DOWNWARDS], [1]) @@ -368,6 +373,7 @@ AS_CASE([$host], [x86_64-*linux*], AC_DEFINE([STACK_POINTER], [[uregs[13]]]) AC_DEFINE([EXEC_SYSCALL], [__NR_execve]) AC_DEFINE([USER_WORD], [uintptr_t]) + AC_DEFINE([USER_SWORD], [intptr_t]) AC_DEFINE([EXECUTABLE_BASE], [0x0f000000]) AC_DEFINE([INTERPRETER_BASE], [0x1f000000]) AC_DEFINE([STACK_GROWS_DOWNWARDS], [1]) @@ -398,6 +404,7 @@ AS_CASE([$host], [x86_64-*linux*], AC_DEFINE([STACK_POINTER], [[gregs[29]]]) # sp AC_DEFINE([EXEC_SYSCALL], [__NR_execve]) AC_DEFINE([USER_WORD], [uintptr_t]) + AC_DEFINE([USER_SWORD], [intptr_t]) AC_DEFINE([EXECUTABLE_BASE], [0x0f000000]) AC_DEFINE([INTERPRETER_BASE], [0x1f000000]) AC_DEFINE([STACK_GROWS_DOWNWARDS], [1]) @@ -427,6 +434,7 @@ AS_CASE([$host], [x86_64-*linux*], AC_DEFINE([STACK_POINTER], [[gregs[29]]]) # sp AC_DEFINE([EXEC_SYSCALL], [__NR_execve]) AC_DEFINE([USER_WORD], [uintptr_t]) + AC_DEFINE([USER_SWORD], [intptr_t]) AC_DEFINE([EXEC_64], [1]) AC_DEFINE([EXECUTABLE_BASE], [0x400000]) AC_DEFINE([INTERPRETER_BASE], [0x3f00000000]) diff --git a/exec/exec.c b/exec/exec.c index 254a983f25f..cbe22d4f18c 100644 --- a/exec/exec.c +++ b/exec/exec.c @@ -865,7 +865,7 @@ insert_args (struct exec_tracee *tracee, USER_REGS_STRUCT *regs, result in *IN, and return a pointer to the byte after the result. REM should be NULL. */ -static char * +char * format_pid (char *in, unsigned int pid) { unsigned int digits[32], *fill; diff --git a/exec/exec.h b/exec/exec.h index ad1b50276c8..3ce06c35311 100644 --- a/exec/exec.h +++ b/exec/exec.h @@ -180,6 +180,7 @@ extern int aarch64_set_regs (pid_t, USER_REGS_STRUCT *, bool); +extern char *format_pid (char *, unsigned int); extern USER_WORD user_alloca (struct exec_tracee *, USER_REGS_STRUCT *, USER_REGS_STRUCT *, USER_WORD); extern int user_copy (struct exec_tracee *, const unsigned char *, diff --git a/exec/trace.c b/exec/trace.c index a7cbda54d68..64dadc092c2 100644 --- a/exec/trace.c +++ b/exec/trace.c @@ -31,6 +31,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include #include "exec.h" @@ -894,6 +895,68 @@ handle_exec (struct exec_tracee *tracee, USER_REGS_STRUCT *regs) return 3; } +/* Modify BUFFER, of size SIZE, so that it holds the absolute name of + the file identified by BUFFER, relative to the current working + directory of TRACEE if FD be AT_FDCWD, or the file referenced by FD + otherwise. + + Value is 1 if this information is unavailable (of which there are + variety of causes), and 0 on success. */ + +static int +canon_path (struct exec_tracee *tracee, int fd, char *buffer, + ptrdiff_t size) +{ + char link[sizeof "/proc//fd/" + 48], *p; /* Or /proc/pid/cwd. */ + char target[PATH_MAX]; + ssize_t rc, length; + + if (buffer[0] == '/') + /* Absolute file name; return immediately. */ + return 0; + else if (fd == AT_FDCWD) + { + p = stpcpy (link, "/proc/"); + p = format_pid (p, tracee->pid); + stpcpy (p, "/cwd"); + } + else if (fd < 0) + /* Invalid file descriptor. */ + return 1; + else + { + p = stpcpy (link, "/proc/"); + p = format_pid (p, tracee->pid); + p = stpcpy (p, "/fd/"); + format_pid (p, fd); + } + + /* Read LINK's target, and should it be oversized, punt. */ + rc = readlink (link, target, PATH_MAX); + if (rc < 0 || rc >= PATH_MAX) + return 1; + + /* Consider the amount by which BUFFER's existing contents should be + displaced. */ + + length = strlen (buffer) + 1; + if ((length + rc + (target[rc - 1] != '/')) > size) + /* Punt if this would overflow. */ + return 1; + + memmove ((buffer + rc + (target[rc - 1] != '/')), + buffer, length); + + /* Copy the new file name into BUFFER. */ + memcpy (buffer, target, rc); + + /* Insert separator in between if need be. */ + if (target[rc - 1] != '/') + buffer[rc] = '/'; + + return 0; +} + /* Handle a `readlink' or `readlinkat' system call. CALLNO is the system call number, and REGS are the current user @@ -924,22 +987,26 @@ handle_readlinkat (USER_WORD callno, USER_REGS_STRUCT *regs, char buffer[PATH_MAX + 1]; USER_WORD address, return_buffer, size; size_t length; + char proc_pid_exe[sizeof "/proc//exe" + 24], *p; + int dirfd; /* Read the file name. */ #ifdef READLINK_SYSCALL if (callno == READLINK_SYSCALL) { - address = regs->SYSCALL_ARG_REG; + dirfd = AT_FDCWD; + address = regs->SYSCALL_ARG_REG; return_buffer = regs->SYSCALL_ARG1_REG; - size = regs->SYSCALL_ARG2_REG; + size = regs->SYSCALL_ARG2_REG; } else #endif /* READLINK_SYSCALL */ { - address = regs->SYSCALL_ARG1_REG; + dirfd = (USER_SWORD) regs->SYSCALL_ARG_REG; + address = regs->SYSCALL_ARG1_REG; return_buffer = regs->SYSCALL_ARG2_REG; - size = regs->SYSCALL_ARG3_REG; + size = regs->SYSCALL_ARG3_REG; } read_memory (tracee, buffer, PATH_MAX, address); @@ -952,12 +1019,25 @@ handle_readlinkat (USER_WORD callno, USER_REGS_STRUCT *regs, return 1; } - /* Now check if the caller is looking for /proc/self/exe. + /* Expand BUFFER into an absolute file name. TODO: + AT_SYMLINK_FOLLOW? */ + + if (canon_path (tracee, dirfd, buffer, sizeof buffer)) + return 0; + + /* Now check if the caller is looking for /proc/self/exe or its + equivalent with the PID made explicit. dirfd can be ignored, as for now only absolute file names are handled. FIXME. */ - if (strcmp (buffer, "/proc/self/exe") || !tracee->exec_file) + p = stpcpy (proc_pid_exe, "/proc/"); + p = format_pid (p, tracee->pid); + stpcpy (p, "/exe"); + + if ((strcmp (buffer, "/proc/self/exe") + && strcmp (buffer, proc_pid_exe)) + || !tracee->exec_file) return 0; /* Copy over tracee->exec_file. Truncate it to PATH_MAX, length, or @@ -1004,15 +1084,23 @@ handle_openat (USER_WORD callno, USER_REGS_STRUCT *regs, USER_WORD address; size_t length; USER_REGS_STRUCT original; + char proc_pid_exe[sizeof "/proc//exe" + 24], *p; + int dirfd; /* Read the file name. */ #ifdef OPEN_SYSCALL if (callno == OPEN_SYSCALL) - address = regs->SYSCALL_ARG_REG; + { + dirfd = AT_FDCWD; + address = regs->SYSCALL_ARG_REG; + } else #endif /* OPEN_SYSCALL */ - address = regs->SYSCALL_ARG1_REG; + { + dirfd = (USER_SWORD) regs->SYSCALL_ARG_REG; + address = regs->SYSCALL_ARG1_REG; + } /* Read the file name into the buffer and verify that it is NULL terminated. */ @@ -1024,12 +1112,25 @@ handle_openat (USER_WORD callno, USER_REGS_STRUCT *regs, return 1; } - /* Now check if the caller is looking for /proc/self/exe. + /* Expand BUFFER into an absolute file name. TODO: + AT_SYMLINK_FOLLOW? */ + + if (canon_path (tracee, dirfd, buffer, sizeof buffer)) + return 0; + + /* Now check if the caller is looking for /proc/self/exe or its + equivalent with the PID made explicit. dirfd can be ignored, as for now only absolute file names are handled. FIXME. */ - if (strcmp (buffer, "/proc/self/exe") || !tracee->exec_file) + p = stpcpy (proc_pid_exe, "/proc/"); + p = format_pid (p, tracee->pid); + stpcpy (p, "/exe"); + + if ((strcmp (buffer, "/proc/self/exe") + && strcmp (buffer, proc_pid_exe)) + || !tracee->exec_file) return 0; /* Copy over tracee->exec_file. This doesn't correctly handle the From 1b94f800ae34de5f4e72682a81de1d42bdda9276 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Thu, 14 Mar 2024 14:21:49 +0800 Subject: [PATCH 018/155] * exec/trace.c (rpl_stpcpy): Replace stpcpy if absent. --- exec/trace.c | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/exec/trace.c b/exec/trace.c index 64dadc092c2..05d862f5b9f 100644 --- a/exec/trace.c +++ b/exec/trace.c @@ -895,6 +895,36 @@ handle_exec (struct exec_tracee *tracee, USER_REGS_STRUCT *regs) return 3; } + + +/* Define replacements for required string functions. */ + +#if !defined HAVE_STPCPY || !defined HAVE_DECL_STPCPY + +/* Copy SRC to DEST, returning the address of the terminating '\0' in + DEST. */ + +static char * +rpl_stpcpy (char *dest, const char *src) +{ + register char *d; + register const char *s; + + d = dest; + s = src; + + do + *d++ = *s; + while (*s++ != '\0'); + + return d - 1; +} + +#define stpcpy rpl_stpcpy +#endif /* !defined HAVE_STPCPY || !defined HAVE_DECL_STPCPY */ + + + /* Modify BUFFER, of size SIZE, so that it holds the absolute name of the file identified by BUFFER, relative to the current working directory of TRACEE if FD be AT_FDCWD, or the file referenced by FD From e7b1743b798cab338e0fa7b98dfb20c0ba7204b1 Mon Sep 17 00:00:00 2001 From: Raffael Stocker Date: Mon, 4 Mar 2024 19:06:07 +0100 Subject: [PATCH 019/155] Fix resetting keyboard hook state on MS-Windows Register session notifications so Emacs is notified when the computer is being locked, as required to reset the low level keyboard hook state. (Bug#69083). * src/w32term.h: * src/w32fns.c (setup_w32_kbdhook, remove_w32_kbdhook) (w32_wnd_proc, globals_of_w32fns, maybe_pass_notification): Register and manage session notifications in GUI Emacs. * src/w32console.c (initialize_w32_display, find_ime_window): * src/w32xfns.c (drain_message_queue): Register notifications and reset keyboard hook state in console Emacs. * src/w32.c (term_ntproc): Un-register session notifications when terminating. --- src/w32.c | 5 +++ src/w32console.c | 25 ++++++++++++-- src/w32fns.c | 84 +++++++++++++++++++++++++++++++++++++++++++++--- src/w32term.h | 3 +- src/w32xfns.c | 12 +++++-- 5 files changed, 120 insertions(+), 9 deletions(-) diff --git a/src/w32.c b/src/w32.c index df5465c2135..d34ab70f82d 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10392,11 +10392,16 @@ check_windows_init_file (void) } } +/* from w32fns.c */ +extern void remove_w32_kbdhook (void); + void term_ntproc (int ignored) { (void)ignored; + remove_w32_kbdhook (); + term_timers (); /* shutdown the socket interface if necessary */ diff --git a/src/w32console.c b/src/w32console.c index 0936b5f37e6..7dcbc795cac 100644 --- a/src/w32console.c +++ b/src/w32console.c @@ -659,6 +659,24 @@ w32_face_attributes (struct frame *f, int face_id) return char_attr; } +/* The IME window is needed to receive the session notifications + required to reset the low level keyboard hook state. */ + +static BOOL CALLBACK +find_ime_window (HWND hwnd, LPARAM arg) +{ + char window_class[32]; + + GetClassName (hwnd, window_class, sizeof (window_class)); + if (strcmp (window_class, "IME") == 0) + { + *(HWND *) arg = hwnd; + return FALSE; + } + /* keep looking */ + return TRUE; +} + void initialize_w32_display (struct terminal *term, int *width, int *height) { @@ -818,11 +836,14 @@ initialize_w32_display (struct terminal *term, int *width, int *height) else w32_console_unicode_input = 0; - /* Setup w32_display_info structure for this frame. */ + /* Setup w32_display_info structure for this frame. */ w32_initialize_display_info (build_string ("Console")); + HWND hwnd = NULL; + EnumThreadWindows (GetCurrentThreadId (), find_ime_window, (LPARAM) &hwnd); + /* Set up the keyboard hook. */ - setup_w32_kbdhook (); + setup_w32_kbdhook (hwnd); } diff --git a/src/w32fns.c b/src/w32fns.c index 8d4bd00b91c..3e4a8c475b7 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -49,6 +49,7 @@ along with GNU Emacs. If not, see . */ #ifdef WINDOWSNT #include #include /* for _getmbcp */ +#include /* for WTS(Un)RegisterSessionNotification */ #endif /* WINDOWSNT */ #if CYGWIN @@ -204,6 +205,10 @@ typedef HRESULT (WINAPI * SetWindowTheme_Proc) typedef HRESULT (WINAPI * DwmSetWindowAttribute_Proc) (HWND hwnd, DWORD dwAttribute, IN LPCVOID pvAttribute, DWORD cbAttribute); +typedef BOOL (WINAPI * WTSRegisterSessionNotification_Proc) + (HWND hwnd, DWORD dwFlags); +typedef BOOL (WINAPI * WTSUnRegisterSessionNotification_Proc) (HWND hwnd); + TrackMouseEvent_Proc track_mouse_event_fn = NULL; ImmGetCompositionString_Proc get_composition_string_fn = NULL; ImmGetContext_Proc get_ime_context_fn = NULL; @@ -220,6 +225,8 @@ IsDebuggerPresent_Proc is_debugger_present = NULL; SetThreadDescription_Proc set_thread_description = NULL; SetWindowTheme_Proc SetWindowTheme_fn = NULL; DwmSetWindowAttribute_Proc DwmSetWindowAttribute_fn = NULL; +WTSUnRegisterSessionNotification_Proc WTSUnRegisterSessionNotification_fn = NULL; +WTSRegisterSessionNotification_Proc WTSRegisterSessionNotification_fn = NULL; extern AppendMenuW_Proc unicode_append_menu; @@ -307,6 +314,7 @@ static struct int hook_count; /* counter, if several windows are created */ HHOOK hook; /* hook handle */ HWND console; /* console window handle */ + HWND notified_wnd; /* window that receives session notifications */ int lwindown; /* Left Windows key currently pressed (and hooked) */ int rwindown; /* Right Windows key currently pressed (and hooked) */ @@ -2744,7 +2752,7 @@ funhook (int code, WPARAM w, LPARAM l) /* Set up the hook; can be called several times, with matching remove_w32_kbdhook calls. */ void -setup_w32_kbdhook (void) +setup_w32_kbdhook (HWND hwnd) { kbdhook.hook_count++; @@ -2800,6 +2808,15 @@ setup_w32_kbdhook (void) /* Set the hook. */ kbdhook.hook = SetWindowsHookEx (WH_KEYBOARD_LL, funhook, GetModuleHandle (NULL), 0); + + /* Register session notifications so we get notified about the + computer being locked. */ + kbdhook.notified_wnd = NULL; + if (hwnd != NULL && WTSRegisterSessionNotification_fn != NULL) + { + WTSRegisterSessionNotification_fn (hwnd, NOTIFY_FOR_THIS_SESSION); + kbdhook.notified_wnd = hwnd; + } } } @@ -2811,7 +2828,11 @@ remove_w32_kbdhook (void) if (kbdhook.hook_count == 0 && w32_kbdhook_active) { UnhookWindowsHookEx (kbdhook.hook); + if (kbdhook.notified_wnd != NULL + && WTSUnRegisterSessionNotification_fn != NULL) + WTSUnRegisterSessionNotification_fn (kbdhook.notified_wnd); kbdhook.hook = NULL; + kbdhook.notified_wnd = NULL; } } #endif /* WINDOWSNT */ @@ -2884,13 +2905,12 @@ check_w32_winkey_state (int vkey) } return 0; } -#endif /* WINDOWSNT */ /* Reset the keyboard hook state. Locking the workstation with Win-L leaves the Win key(s) "down" from the hook's point of view - the keyup event is never seen. Thus, this function must be called when the system is locked. */ -static void +void reset_w32_kbdhook_state (void) { kbdhook.lwindown = 0; @@ -2900,6 +2920,7 @@ reset_w32_kbdhook_state (void) kbdhook.suppress_lone = 0; kbdhook.winseen = 0; } +#endif /* WINDOWSNT */ /* GetKeyState and MapVirtualKey on Windows 95 do not actually distinguish between left and right keys as advertised. We test for this @@ -4129,6 +4150,47 @@ deliver_wm_chars (int do_translate, HWND hwnd, UINT msg, UINT wParam, return 0; } +/* Maybe pass session notification registration to another frame. If + the frame with window handle HWND is deleted, we must pass the + notifications to some other frame, if they have been sent to this + frame before and have not already been passed on. If there is no + other frame, do nothing. */ + +#ifdef WINDOWSNT +static void +maybe_pass_notification (HWND hwnd) +{ + if (hwnd == kbdhook.notified_wnd + && kbdhook.hook_count > 0 && w32_kbdhook_active) + { + Lisp_Object tail, frame; + struct frame *f; + bool found_frame = false; + + FOR_EACH_FRAME (tail, frame) + { + f = XFRAME (frame); + if (FRAME_W32_P (f) && FRAME_OUTPUT_DATA (f) != NULL + && FRAME_W32_WINDOW (f) != hwnd) + { + found_frame = true; + break; + } + } + + if (found_frame && WTSUnRegisterSessionNotification_fn != NULL + && WTSRegisterSessionNotification_fn != NULL) + { + /* There is another frame, pass on the session notification. */ + HWND next_wnd = FRAME_W32_WINDOW (f); + WTSUnRegisterSessionNotification_fn (hwnd); + WTSRegisterSessionNotification_fn (next_wnd, NOTIFY_FOR_THIS_SESSION); + kbdhook.notified_wnd = next_wnd; + } + } +} +#endif /* WINDOWSNT */ + /* Main window procedure */ static LRESULT CALLBACK @@ -5301,23 +5363,29 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) #ifdef WINDOWSNT case WM_CREATE: - setup_w32_kbdhook (); + setup_w32_kbdhook (hwnd); goto dflt; #endif case WM_DESTROY: #ifdef WINDOWSNT + maybe_pass_notification (hwnd); remove_w32_kbdhook (); #endif CoUninitialize (); return 0; +#ifdef WINDOWSNT case WM_WTSSESSION_CHANGE: if (wParam == WTS_SESSION_LOCK) reset_w32_kbdhook_state (); goto dflt; +#endif case WM_CLOSE: +#ifdef WINDOWSNT + maybe_pass_notification (hwnd); +#endif wmsg.dwModifiers = w32_get_modifiers (); my_post_msg (&wmsg, hwnd, msg, wParam, lParam); return 0; @@ -11335,6 +11403,14 @@ globals_of_w32fns (void) set_thread_description = (SetThreadDescription_Proc) get_proc_addr (hm_kernel32, "SetThreadDescription"); +#ifdef WINDOWSNT + HMODULE wtsapi32_lib = LoadLibrary ("wtsapi32.dll"); + WTSRegisterSessionNotification_fn = (WTSRegisterSessionNotification_Proc) + get_proc_addr (wtsapi32_lib, "WTSRegisterSessionNotification"); + WTSUnRegisterSessionNotification_fn = (WTSUnRegisterSessionNotification_Proc) + get_proc_addr (wtsapi32_lib, "WTSUnRegisterSessionNotification"); +#endif + /* Support OS dark mode on Windows 10 version 1809 and higher. See `w32_applytheme' which uses appropriate APIs per version of Windows. For future wretches who may need to understand Windows build numbers: diff --git a/src/w32term.h b/src/w32term.h index 29ace0b2797..3120c8bd71f 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -779,8 +779,9 @@ extern bool w32_image_rotations_p (void); #ifdef WINDOWSNT /* Keyboard hooks. */ -extern void setup_w32_kbdhook (void); +extern void setup_w32_kbdhook (HWND); extern void remove_w32_kbdhook (void); +extern void reset_w32_kbdhook_state (void); extern int check_w32_winkey_state (int); #define w32_kbdhook_active (os_subtype != OS_SUBTYPE_9X) #else diff --git a/src/w32xfns.c b/src/w32xfns.c index fa7d5fbdb61..3d7a1514f72 100644 --- a/src/w32xfns.c +++ b/src/w32xfns.c @@ -413,8 +413,16 @@ drain_message_queue (void) while (PeekMessage (&msg, NULL, 0, 0, PM_REMOVE)) { - if (msg.message == WM_EMACS_FILENOTIFY) - retval = 1; + switch (msg.message) + { + case WM_WTSSESSION_CHANGE: + if (msg.wParam == WTS_SESSION_LOCK) + reset_w32_kbdhook_state (); + break; + case WM_EMACS_FILENOTIFY: + retval = 1; + break; + } TranslateMessage (&msg); DispatchMessage (&msg); } From 7971537d3cdab62f7ce1924cbb2effde73b59b1e Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 14 Mar 2024 10:22:52 +0200 Subject: [PATCH 020/155] ; Fix last change to compile with mingw.org's MinGW * src/w32xfns.c: * src/w32fns.c (WTS_VIRTUAL_CLASS) [!MINGW_W64]: Declare. * src/w32xfns.c: Include wtsapi32.h. --- src/w32fns.c | 7 +++++++ src/w32xfns.c | 11 +++++++++++ 2 files changed, 18 insertions(+) diff --git a/src/w32fns.c b/src/w32fns.c index 3e4a8c475b7..7d288ce7bd5 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -47,6 +47,13 @@ along with GNU Emacs. If not, see . */ #include "w32inevt.h" #ifdef WINDOWSNT +/* mingw.org's MinGW headers mistakenly omit this enumeration: */ +# ifndef MINGW_W64 +typedef enum _WTS_VIRTUAL_CLASS { + WTSVirtualClientData, + WTSVirtualFileHandle +} WTS_VIRTUAL_CLASS; +# endif #include #include /* for _getmbcp */ #include /* for WTS(Un)RegisterSessionNotification */ diff --git a/src/w32xfns.c b/src/w32xfns.c index 3d7a1514f72..853c8368118 100644 --- a/src/w32xfns.c +++ b/src/w32xfns.c @@ -22,6 +22,17 @@ along with GNU Emacs. If not, see . */ #include #include #include +/* Override API version to get the required functionality. */ +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0501 +/* mingw.org's MinGW headers mistakenly omit this enumeration: */ +# ifndef MINGW_W64 +typedef enum _WTS_VIRTUAL_CLASS { + WTSVirtualClientData, + WTSVirtualFileHandle +} WTS_VIRTUAL_CLASS; +# endif +#include /* for WM_WTSSESSION_CHANGE, WTS_SESSION_LOCK */ #include "lisp.h" #include "frame.h" From 013114664ef4923872ffad26a97f4d314c9a84bf Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 8 Mar 2024 22:28:52 -0600 Subject: [PATCH 021/155] * lisp/emacs-lisp/vtable.el (vtable-update-object): Fix. The order of the arguments to 'seq-position' was wrong, and it did not compare the correct values. (Bug#69664) --- lisp/emacs-lisp/vtable.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 02020552e7f..5cf8d8854bb 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -300,7 +300,9 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... - (let* ((line-number (seq-position old-object (car (vtable--cache table)))) + (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))) (unless line (error "Can't find cached object")) From f6a27bc32d19727dfcbee65fb9894b53aec46c65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?No=C3=A9=20Lopez?= Date: Fri, 19 Jan 2024 23:40:53 +0100 Subject: [PATCH 022/155] Add user option to disable JavaScript in xwidget webview * src/xwidget.c: Add the 'xwidget-webkit-disable-javascript' variable to disable JavaScript in WebKit sessions. (Bug#68604) * etc/NEWS: * doc/emacs/misc.texi (Embedded Webkit Widgets): Document the change. --- doc/emacs/misc.texi | 8 ++++++++ etc/NEWS | 6 ++++++ lisp/xwidget.el | 7 +++++++ src/xwidget.c | 8 +++++++- 4 files changed, 28 insertions(+), 1 deletion(-) diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 7eb28f56826..bfc86e3c9d4 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -3009,6 +3009,14 @@ buffer, and lets you navigate to those pages by hitting @kbd{RET}. It is bound to @kbd{H}. +@vindex xwidget-webkit-disable-javascript +@cindex disabling javascript in webkit buffers + JavaScript is enabled by default inside WebKit buffers, this can be +undesirable as websites often use it to track your online activity. It +can be disabled by setting the variable @code{xwidget-webkit-disable-javascript} to @code{t}. +You must kill all WebKit buffers for this setting to take effect after +it is changed. + @node Browse-URL @subsection Following URLs @cindex World Wide Web diff --git a/etc/NEWS b/etc/NEWS index 19cd170e5c7..2985169ea91 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1437,6 +1437,12 @@ This allows the user to customize the key selection method, which can be either by using a pop-up buffer or from the minibuffer. The pop-up buffer method is the default, which preserves previous behavior. +** Xwidget Webkit + ++++ +*** New user option 'xwidget-webkit-disable-javascript'. +This allows disabling JavaScript in xwidget Webkit sessions. + * New Modes and Packages in Emacs 30.1 diff --git a/lisp/xwidget.el b/lisp/xwidget.el index cca01c8cb3a..2fb79bb7b1d 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -116,6 +116,13 @@ buffers for this setting to take effect after setting it to nil." :type '(choice (const :tag "Do not store cookies" nil) file) :version "29.1") +(defcustom xwidget-webkit-disable-javascript nil + "If non-nil, disables the execution of JavaScript in xwidget webkit sessions. +You must kill all xwidget-webkit buffers for this setting to take +effect after changing it." + :type '(boolean) + :version "30.0") + ;;;###autoload (defun xwidget-webkit-browse-url (url &optional new-session) "Ask xwidget-webkit to browse URL. diff --git a/src/xwidget.c b/src/xwidget.c index 58910459142..5b82ef6e840 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -22,7 +22,6 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "coding.h" #include "xwidget.h" - #include "lisp.h" #include "blockinput.h" #include "dispextern.h" @@ -379,6 +378,7 @@ fails. */) /* Enable the developer extras. */ settings = webkit_web_view_get_settings (WEBKIT_WEB_VIEW (xw->widget_osr)); g_object_set (G_OBJECT (settings), "enable-developer-extras", TRUE, NULL); + g_object_set (G_OBJECT (settings), "enable-javascript", !xwidget_webkit_disable_javascript, NULL); } gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, @@ -3972,6 +3972,12 @@ syms_of_xwidget (void) doc: /* List of all xwidget views. */); Vxwidget_view_list = Qnil; + DEFVAR_BOOL("xwidget-webkit-disable-javascript", xwidget_webkit_disable_javascript, + doc: /* If non-nil, disables the execution of JavaScript in xwidget webkit sessions. +You must kill all xwidget-webkit buffers for this setting to take +effect after changing it. */); + xwidget_webkit_disable_javascript = false; + Fprovide (intern ("xwidget-internal"), Qnil); id_to_xwidget_map = CALLN (Fmake_hash_table, QCtest, Qeq, From a60804ab954e0de73a80a217f677142176678465 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 14 Mar 2024 11:32:00 +0200 Subject: [PATCH 023/155] ; Fix last change (bug#68604) * lisp/xwidget.el (xwidget-webkit-disable-javascript): Move from here... * lisp/cus-start.el (standard): ...to here. * src/xwidget.c (syms_of_xwidget) : Doc fix. * doc/emacs/misc.texi (Embedded WebKit Widgets): Fix wording. --- doc/emacs/misc.texi | 9 +++++---- lisp/cus-start.el | 4 ++++ lisp/xwidget.el | 7 ------- src/xwidget.c | 6 +++--- 4 files changed, 12 insertions(+), 14 deletions(-) diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index bfc86e3c9d4..8f9ee317080 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -3011,10 +3011,11 @@ It is bound to @kbd{H}. @vindex xwidget-webkit-disable-javascript @cindex disabling javascript in webkit buffers - JavaScript is enabled by default inside WebKit buffers, this can be -undesirable as websites often use it to track your online activity. It -can be disabled by setting the variable @code{xwidget-webkit-disable-javascript} to @code{t}. -You must kill all WebKit buffers for this setting to take effect after + JavaScript is enabled by default inside WebKit buffers, which could be +undesirable, as Web sites often use it to track your online activity. +You can disable JavaScript in WebKit buffers by customizing the variable +@code{xwidget-webkit-disable-javascript} to a non-@code{nil} value. +You must kill all WebKit buffers for this setting to take effect, after it is changed. @node Browse-URL diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 3fe62c8d0da..165296d2242 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -846,6 +846,8 @@ since it could result in memory overflow and make Emacs crash." (x-select-enable-clipboard-manager killing boolean "24.1") ;; xsettings.c (font-use-system-font font-selection boolean "23.2") + ;; xwidget.c + (xwidget-webkit-disable-javascript xwidget boolean "30.1") ;; haikuterm.c (haiku-debug-on-fatal-error debug boolean "29.1") ;; haikufns.c @@ -906,6 +908,8 @@ since it could result in memory overflow and make Emacs crash." (symbol-name symbol)) ;; Any function from fontset.c will do. (fboundp 'new-fontset)) + ((string-match "xwidget-" (symbol-name symbol)) + (boundp 'xwidget-internal)) (t t)))) (if (not (boundp symbol)) ;; If variables are removed from C code, give an error here! diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 2fb79bb7b1d..cca01c8cb3a 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -116,13 +116,6 @@ buffers for this setting to take effect after setting it to nil." :type '(choice (const :tag "Do not store cookies" nil) file) :version "29.1") -(defcustom xwidget-webkit-disable-javascript nil - "If non-nil, disables the execution of JavaScript in xwidget webkit sessions. -You must kill all xwidget-webkit buffers for this setting to take -effect after changing it." - :type '(boolean) - :version "30.0") - ;;;###autoload (defun xwidget-webkit-browse-url (url &optional new-session) "Ask xwidget-webkit to browse URL. diff --git a/src/xwidget.c b/src/xwidget.c index 5b82ef6e840..557b1e60409 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -3973,9 +3973,9 @@ syms_of_xwidget (void) Vxwidget_view_list = Qnil; DEFVAR_BOOL("xwidget-webkit-disable-javascript", xwidget_webkit_disable_javascript, - doc: /* If non-nil, disables the execution of JavaScript in xwidget webkit sessions. -You must kill all xwidget-webkit buffers for this setting to take -effect after changing it. */); + doc: /* If non-nil, disable execution of JavaScript in xwidget webkit sessions. +You must kill all xwidget-webkit buffers for this setting to take effect +after changing it. */); xwidget_webkit_disable_javascript = false; Fprovide (intern ("xwidget-internal"), Qnil); From cb9ee24ea69be4a70f68cb2d564b23a55cb84216 Mon Sep 17 00:00:00 2001 From: Visuwesh Date: Sat, 9 Mar 2024 15:17:26 +0530 Subject: [PATCH 024/155] Add bounds-of-thing-at-point property for 'number' * lisp/thingatpt.el (thing-at-point-decimal-regexp) (thing-at-point-hexadecimal-regexp): Extract regexps from... (number-at-point): ...here. Use them in 'number-at-point'. (number): Add 'bounds-of-thing-at-point' property as `forward-word' does not always return the right boundary, e.g., in latex-mode buffers. (Bug#69239) --- lisp/thingatpt.el | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 83ddc640d35..7896ad984df 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -735,20 +735,33 @@ Signal an error if the entire string was not used." (let ((thing (thing-at-point 'symbol))) (if thing (intern thing)))) +(defvar thing-at-point-decimal-regexp + "-?[0-9]+\\.?[0-9]*" + "A regexp matching a decimal number.") + +(defvar thing-at-point-hexadecimal-regexp + "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)" + "A regexp matchin a hexadecimal number.") + ;;;###autoload (defun number-at-point () "Return the number at point, or nil if none is found. Decimal numbers like \"14\" or \"-14.5\", as well as hex numbers like \"0xBEEF09\" or \"#xBEEF09\", are recognized." (cond - ((thing-at-point-looking-at "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)" 500) + ((thing-at-point-looking-at thing-at-point-hexadecimal-regexp 500) (string-to-number (buffer-substring (match-beginning 2) (match-end 2)) 16)) - ((thing-at-point-looking-at "-?[0-9]+\\.?[0-9]*" 500) + ((thing-at-point-looking-at thing-at-point-decimal-regexp 500) (string-to-number (buffer-substring (match-beginning 0) (match-end 0)))))) +(put 'number 'bounds-of-thing-at-point + (lambda () + (and (or (thing-at-point-looking-at thing-at-point-hexadecimal-regexp 500) + (thing-at-point-looking-at thing-at-point-decimal-regexp 500)) + (cons (match-beginning 0) (match-end 0))))) (put 'number 'forward-op 'forward-word) (put 'number 'thing-at-point 'number-at-point) From fd0a6cb172dbae8779dae768fa8c475eb0af50ee Mon Sep 17 00:00:00 2001 From: StrawberryTea Date: Sat, 9 Mar 2024 15:37:44 -0600 Subject: [PATCH 025/155] ffap.el: Exclude angle brackets from file names in XML * lisp/ffap.el (ffap-string-at-point-mode-alist): Add elements for XML, to better recognize file names in XML buffers. Copyright-paperwork-exempt: yes --- lisp/ffap.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/ffap.el b/lisp/ffap.el index 5383f743878..b2b681b7c44 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1065,6 +1065,9 @@ If a given RFC isn't in these then `ffap-rfc-path' is offered." ;; (La)TeX: don't allow braces (latex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:") (tex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:") + ;; XML: don't allow angle brackets + (xml-mode "--:\\\\${}+@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}") + (nxml-mode "--:\\\\${}+@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}") ) "Alist of (MODE CHARS BEG END), where MODE is a symbol. This is possibly a major-mode name, or one of the symbols From 3807f380b3334205bfcbba88003ff96507c86fc4 Mon Sep 17 00:00:00 2001 From: Phil Hagelberg Date: Sat, 9 Mar 2024 15:36:11 -0800 Subject: [PATCH 026/155] bug#69685: Add language server for Fennel to eglot * lisp/progmodes/eglot.el (eglot-server-programs): Add fennel-ls language server. Copyright-paperwork-exempt: yes --- lisp/progmodes/eglot.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index afe3281361d..4ffaf5f8a0e 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -294,6 +294,7 @@ automatically)." (nickel-mode . ("nls")) ((nushell-mode nushell-ts-mode) . ("nu" "--lsp")) (gdscript-mode . ("localhost" 6008)) + (fennel-mode . ("fennel-ls")) ((fortran-mode f90-mode) . ("fortls")) (futhark-mode . ("futhark" "lsp")) ((lua-mode lua-ts-mode) . ,(eglot-alternatives From 6d1c1fca0aa7c5a1ff0254af3f89a34d5309ea0d Mon Sep 17 00:00:00 2001 From: Tim Landscheidt Date: Tue, 12 Mar 2024 00:21:06 +0000 Subject: [PATCH 027/155] ; Simplify (with-current-buffer (get-buffer ...) ...) There's no need to call 'get-buffer', since 'with-current-buffer' does that internally. * lisp/calendar/todo-mode.el (todo-merge-category): * lisp/comint.el (comint-dynamic-list-completions): * lisp/emacs-lisp/checkdoc.el (checkdoc-error): * lisp/emacs-lisp/debug.el (debug, debugger-record-expression): * lisp/emacs-lisp/eieio-opt.el (eieio-browse): * lisp/emacs-lisp/re-builder.el (reb-restart-font-lock): * lisp/erc/erc-dcc.el (erc-dcc-do-LIST-command): * lisp/eshell/em-unix.el (eshell-poor-mans-grep): * lisp/gnus/gnus-group.el (gnus-add-mark): * lisp/net/eww.el (eww-next-bookmark, eww-previous-bookmark): * lisp/net/sieve.el (sieve-upload): * lisp/net/tramp-cmds.el (tramp-cleanup-some-buffers): * lisp/obsolete/quickurl.el (quickurl-list-populate-buffer): * lisp/org/ob-calc.el: (org-babel-execute:calc): * lisp/org/org-agenda.el (org-agenda-use-sticky-p): * lisp/pcomplete.el (pcomplete-show-completions): * lisp/progmodes/bug-reference.el (bug-reference--try-setup-gnus-article): * lisp/progmodes/idlw-help.el (idlwave-highlight-linked-completions): * lisp/progmodes/verilog-mode.el (verilog-preprocess): * lisp/replace.el (occur-1): * lisp/term.el (term-dynamic-list-completions): * lisp/time.el (world-clock-update): * lisp/url/url-cache.el (url-store-in-cache): * lisp/vc/vc-cvs.el (vc-cvs-merge, vc-cvs-merge-news): * lisp/vc/vc-rcs.el (vc-rcs-system-release): * lisp/vc/vc-svn.el (vc-svn-merge, vc-svn-merge-news): * test/lisp/calendar/icalendar-tests.el (icalendar-tests--get-error-string-for-export): * test/lisp/erc/erc-dcc-tests.el (pcomplete/erc-mode/DCC--get-1flag) (pcomplete/erc-mode/DCC--get-2flags) (pcomplete/erc-mode/DCC--get-2flags-reverse): * test/lisp/erc/erc-networks-tests.el (erc-networks--rename-server-buffer--existing--noreuse): * test/lisp/erc/erc-scenarios-services-misc.el (erc-scenarios-services-misc--reconnect-retry-nick): * test/lisp/erc/erc-tests.el (erc--refresh-prompt): Replace (with-current-buffer (get-buffer ...) ...) with (with-current-buffer ...). --- lisp/calendar/todo-mode.el | 8 ++++---- lisp/comint.el | 2 +- lisp/emacs-lisp/checkdoc.el | 2 +- lisp/emacs-lisp/debug.el | 4 ++-- lisp/emacs-lisp/eieio-opt.el | 2 +- lisp/emacs-lisp/re-builder.el | 2 +- lisp/erc/erc-dcc.el | 2 +- lisp/eshell/em-unix.el | 2 +- lisp/gnus/gnus-group.el | 2 +- lisp/net/eww.el | 4 ++-- lisp/net/sieve.el | 2 +- lisp/net/tramp-cmds.el | 2 +- lisp/obsolete/quickurl.el | 2 +- lisp/org/ob-calc.el | 2 +- lisp/org/org-agenda.el | 2 +- lisp/pcomplete.el | 2 +- lisp/progmodes/bug-reference.el | 2 +- lisp/progmodes/idlw-help.el | 2 +- lisp/progmodes/verilog-mode.el | 2 +- lisp/replace.el | 2 +- lisp/term.el | 2 +- lisp/time.el | 2 +- lisp/url/url-cache.el | 2 +- lisp/vc/vc-cvs.el | 4 ++-- lisp/vc/vc-rcs.el | 2 +- lisp/vc/vc-svn.el | 4 ++-- test/lisp/calendar/icalendar-tests.el | 2 +- test/lisp/erc/erc-dcc-tests.el | 6 +++--- test/lisp/erc/erc-networks-tests.el | 2 +- test/lisp/erc/erc-scenarios-services-misc.el | 2 +- test/lisp/erc/erc-tests.el | 2 +- 31 files changed, 40 insertions(+), 40 deletions(-) diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index f2ee94ec8f7..12287299a7f 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -1612,7 +1612,7 @@ archive file and the source category is deleted." (garchive (concat (file-name-sans-extension gfile) ".toda")) (archived-count (todo-get-count 'archived)) here) - (with-current-buffer (get-buffer (find-file-noselect tfile)) + (with-current-buffer (find-file-noselect tfile) (widen) (let* ((inhibit-read-only t) (cbeg (progn @@ -1638,7 +1638,7 @@ archive file and the source category is deleted." (todo-count (todo-get-count 'todo cat)) (done-count (todo-get-count 'done cat))) ;; Merge into goal todo category. - (with-current-buffer (get-buffer (find-file-noselect gfile)) + (with-current-buffer (find-file-noselect gfile) (unless (derived-mode-p 'todo-mode) (todo-mode)) (widen) (goto-char (point-min)) @@ -1677,7 +1677,7 @@ archive file and the source category is deleted." (mapc (lambda (m) (set-marker m nil)) (list cbeg tbeg dbeg tend cend)))) (when (> archived-count 0) - (with-current-buffer (get-buffer (find-file-noselect tarchive)) + (with-current-buffer (find-file-noselect tarchive) (widen) (goto-char (point-min)) (let* ((inhibit-read-only t) @@ -1697,7 +1697,7 @@ archive file and the source category is deleted." (forward-line) (buffer-substring-no-properties (point) cend)))) ;; Merge into goal archive category, if it exists, else create it. - (with-current-buffer (get-buffer (find-file-noselect garchive)) + (with-current-buffer (find-file-noselect garchive) (let ((gbeg (when (re-search-forward (concat "^" (regexp-quote (concat todo-category-beg goal)) diff --git a/lisp/comint.el b/lisp/comint.el index 655ff30469c..a8fe095e99c 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -3510,7 +3510,7 @@ the completions." ;; Read the next key, to process SPC. (let (key first) - (if (with-current-buffer (get-buffer "*Completions*") + (if (with-current-buffer "*Completions*" (setq-local comint-displayed-dynamic-completions completions) (setq key (read-key-sequence nil) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 02c11cae573..c22dfb2eb26 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -2794,7 +2794,7 @@ function called to create the messages." ": " msg))) (if (string= checkdoc-diagnostic-buffer "*warn*") (warn (apply #'concat text)) - (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) + (with-current-buffer checkdoc-diagnostic-buffer (let ((inhibit-read-only t) (pt (point-max))) (goto-char pt) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 506b73f6fa2..60d14d11970 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -200,7 +200,7 @@ the debugger will not be entered." (let (debugger-value (debugger-previous-state (if (get-buffer "*Backtrace*") - (with-current-buffer (get-buffer "*Backtrace*") + (with-current-buffer "*Backtrace*" (debugger--save-buffer-state)))) (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) @@ -651,7 +651,7 @@ Complete list of commands: (princ (debugger-eval-expression exp)) (terpri)) - (with-current-buffer (get-buffer debugger-record-buffer) + (with-current-buffer debugger-record-buffer (message "%s" (buffer-substring (line-beginning-position 0) (line-end-position 0))))) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 893f8cd7e7f..bf6be1690e4 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -50,7 +50,7 @@ variable `eieio-default-superclass'." (if (not root-class) (setq root-class 'eieio-default-superclass)) (cl-check-type root-class class) (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t) - (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*") + (with-current-buffer "*EIEIO OBJECT BROWSE*" (erase-buffer) (goto-char 0) (eieio-browse-tree root-class "" "") diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 0a47cca0231..c5307f70d08 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -825,7 +825,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions." (defun reb-restart-font-lock () "Restart `font-lock-mode' to fit current regexp format." - (with-current-buffer (get-buffer reb-buffer) + (with-current-buffer reb-buffer (let ((font-lock-is-on font-lock-mode)) (font-lock-mode -1) (kill-local-variable 'font-lock-set-defaults) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 522973a0156..b8e16df755b 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -619,7 +619,7 @@ It lists the current state of `erc-dcc-list' in an easy to read manner." (buffer-live-p (get-buffer (plist-get elt :file))) (plist-member elt :size)) (let ((byte-count (with-current-buffer - (get-buffer (plist-get elt :file)) + (plist-get elt :file) (+ (buffer-size) 0.0 erc-dcc-byte-count)))) (format " (%d%%)" diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 23028576f45..751f13cc715 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -789,7 +789,7 @@ available..." (ignore-errors (occur (car args)))) (if (get-buffer "*Occur*") - (with-current-buffer (get-buffer "*Occur*") + (with-current-buffer "*Occur*" (setq string (buffer-string)) (kill-buffer (current-buffer))))) (if string (insert string)) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index d562d052d82..71bfaa639fa 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4638,7 +4638,7 @@ and the second element is the address." "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." (let ((buffer (gnus-summary-buffer-name group))) (if (gnus-buffer-live-p buffer) - (with-current-buffer (get-buffer buffer) + (with-current-buffer buffer (gnus-summary-add-mark article mark)) (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists)) (list article))))) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 2936bc8f099..54847bdf396 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -2267,7 +2267,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (setq first t) (eww-read-bookmarks t) (eww-bookmark-prepare)) - (with-current-buffer (get-buffer "*eww bookmarks*") + (with-current-buffer "*eww bookmarks*" (when (and (not first) (not (eobp))) (forward-line 1)) @@ -2286,7 +2286,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (setq first t) (eww-read-bookmarks t) (eww-bookmark-prepare)) - (with-current-buffer (get-buffer "*eww bookmarks*") + (with-current-buffer "*eww bookmarks*" (if first (goto-char (point-max)) (beginning-of-line)) diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index fddc6e21bcc..a6ba556e7ae 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -354,7 +354,7 @@ Used to bracket operations which move point in the sieve-buffer." (let ((script (buffer-string)) (script-name (file-name-sans-extension (buffer-name))) err) - (with-current-buffer (get-buffer sieve-buffer) + (with-current-buffer sieve-buffer (setq err (sieve-manage-putscript (or name sieve-buffer-script-name script-name) script sieve-manage-buffer)) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index a545a8e7273..d3af7a009ec 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -281,7 +281,7 @@ non-nil." ;; Remove all buffers with a remote default-directory which fit the hook. (dolist (name (tramp-list-remote-buffers)) (and (buffer-live-p (get-buffer name)) - (with-current-buffer (get-buffer name) + (with-current-buffer name (run-hook-with-args-until-success 'tramp-cleanup-some-buffers-hook)) (kill-buffer name)))) diff --git a/lisp/obsolete/quickurl.el b/lisp/obsolete/quickurl.el index 7393bebdce1..7da51a8a4a8 100644 --- a/lisp/obsolete/quickurl.el +++ b/lisp/obsolete/quickurl.el @@ -447,7 +447,7 @@ The key bindings for `quickurl-list-mode' are: (defun quickurl-list-populate-buffer () "Populate the `quickurl-list' buffer." - (with-current-buffer (get-buffer quickurl-list-buffer-name) + (with-current-buffer quickurl-list-buffer-name (let* ((sizes (or (cl-loop for url in quickurl-urls collect (length (quickurl-url-description url))) (list 20))) diff --git a/lisp/org/ob-calc.el b/lisp/org/ob-calc.el index d335aab7499..f834f05cb6d 100644 --- a/lisp/org/ob-calc.el +++ b/lisp/org/ob-calc.el @@ -93,7 +93,7 @@ (mapcar #'org-trim (split-string (org-babel-expand-body:calc body params) "[\n\r]")))) (save-excursion - (with-current-buffer (get-buffer "*Calculator*") + (with-current-buffer "*Calculator*" (prog1 (calc-eval (calc-top 1)) (calc-pop 1))))) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index f8195a053bc..06249ed48fa 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -3883,7 +3883,7 @@ generating a new one." ;; buffer found (get-buffer org-agenda-buffer-name) ;; C-u parameter is same as last call - (with-current-buffer (get-buffer org-agenda-buffer-name) + (with-current-buffer org-agenda-buffer-name (and (equal current-prefix-arg org-agenda-last-prefix-arg) diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 196c5f159cd..0b34712a50c 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -1140,7 +1140,7 @@ Typing SPC flushes the help buffer." (let (event) (prog1 (catch 'done - (while (with-current-buffer (get-buffer "*Completions*") + (while (with-current-buffer "*Completions*" (setq event (read-event))) (cond ((eq event ?\s) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 29ff521253b..977a3d72cb7 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -493,7 +493,7 @@ and set it if applicable." ;; the values of the From, To, and Cc headers. (let (header-values) (with-current-buffer - (get-buffer gnus-original-article-buffer) + gnus-original-article-buffer (save-excursion (goto-char (point-min)) ;; The Newsgroup is omitted because we already matched diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index 217b2ab6691..7bed69a738b 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -631,7 +631,7 @@ Needs additional info stored in global `idlwave-completion-help-info'." Those words in `idlwave-completion-help-links' have links. The `idlwave-help-link' face is used for this." (if idlwave-highlight-help-links-in-completion - (with-current-buffer (get-buffer "*Completions*") + (with-current-buffer "*Completions*" (save-excursion (let* ((case-fold-search t) (props (list 'face 'idlwave-help-link)) diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 7af78f2229a..a83bad0e8ed 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -5803,7 +5803,7 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'." (dir (file-name-directory (or filename buffer-file-name))) (cmd (concat "cd " dir "; " command))) (with-output-to-temp-buffer "*Verilog-Preprocessed*" - (with-current-buffer (get-buffer "*Verilog-Preprocessed*") + (with-current-buffer "*Verilog-Preprocessed*" (insert (concat "// " cmd "\n")) (call-process shell-file-name nil t nil shell-command-switch cmd) (verilog-mode) diff --git a/lisp/replace.el b/lisp/replace.el index 49e7c85c487..01a892bbba7 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1931,7 +1931,7 @@ See also `multi-occur'." (lambda (boo) (buffer-name (if (overlayp boo) (overlay-buffer boo) boo))) active-bufs)) - (with-current-buffer (get-buffer buf-name) + (with-current-buffer buf-name (rename-uniquely))) ;; Now find or create the output buffer. diff --git a/lisp/term.el b/lisp/term.el index 2ce0c2b5e79..3a0ecc041ca 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -4342,7 +4342,7 @@ Typing SPC flushes the help buffer." (display-completion-list (sort completions 'string-lessp))) (message "Hit space to flush") (let (key first) - (if (with-current-buffer (get-buffer "*Completions*") + (if (with-current-buffer "*Completions*" (setq key (read-key-sequence nil) first (aref key 0)) (and (consp first) diff --git a/lisp/time.el b/lisp/time.el index 9b932e945ba..a8d3ab9c813 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -611,7 +611,7 @@ To turn off the world time display, go to the window and type \\[quit-window]." (defun world-clock-update (&optional _arg _noconfirm) "Update the `world-clock' buffer." (if (get-buffer world-clock-buffer-name) - (with-current-buffer (get-buffer world-clock-buffer-name) + (with-current-buffer world-clock-buffer-name (let ((op (point))) (world-clock-display (time--display-world-list)) (goto-char op))) diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 0d27321cc47..ce6de2b3ee4 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -70,7 +70,7 @@ FILE can be created or overwritten." ;;;###autoload (defun url-store-in-cache (&optional buff) "Store buffer BUFF in the cache." - (with-current-buffer (get-buffer (or buff (current-buffer))) + (with-current-buffer (or buff (current-buffer)) (let ((fname (url-cache-create-filename (url-view-url t)))) (if (url-cache-prepare fname) (let ((coding-system-for-write 'binary)) diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 52039f8da74..63b566b0afe 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -476,7 +476,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." (concat "-j" first-revision) (concat "-j" second-revision)) (vc-file-setprop file 'vc-state 'edited) - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) (if (re-search-forward "conflicts during merge" nil t) (progn @@ -495,7 +495,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION." (vc-cvs-command nil nil file "update") ;; Analyze the merge result reported by CVS, and set ;; file properties accordingly. - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) ;; get new working revision (if (re-search-forward diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 1a43b440d18..33377ce1cc8 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -1177,7 +1177,7 @@ variable `vc-rcs-release' is set to the returned value." (or vc-rcs-release (setq vc-rcs-release (or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V")) - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1))) 'unknown)))) diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index 96baa642b44..ae281e54519 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -436,7 +436,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION." (concat first-version ":" second-version) first-version)) (vc-file-setprop file 'vc-state 'edited) - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) (if (looking-at "C ") 1 ; signal conflict @@ -450,7 +450,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION." (vc-svn-command nil 0 file "update") ;; Analyze the merge result reported by SVN, and set ;; file properties accordingly. - (with-current-buffer (get-buffer "*vc*") + (with-current-buffer "*vc*" (goto-char (point-min)) ;; get new working revision (if (re-search-forward diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 7d3af25ea49..39ad735a789 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -68,7 +68,7 @@ (with-temp-buffer (insert diary-string) (icalendar-export-region (point-min) (point-max) file)) - (with-current-buffer (get-buffer "*icalendar-errors*") + (with-current-buffer "*icalendar-errors*" (buffer-string)))) ;; ====================================================================== diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index a2fb0392727..d4b5919a1cc 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -243,7 +243,7 @@ (delete-region (point) (point-max)) (insert "/dcc get -") (call-interactively #'completion-at-point) - (with-current-buffer (get-buffer "*Completions*") + (with-current-buffer "*Completions*" (goto-char (point-min)) (search-forward "-s") (search-forward "-t")) @@ -264,7 +264,7 @@ (delete-region (point) (point-max)) (insert "/dcc get -") (call-interactively #'completion-at-point) - (with-current-buffer (get-buffer "*Completions*") + (with-current-buffer "*Completions*" (goto-char (point-min)) (search-forward "-s") (search-forward "-t")) @@ -289,7 +289,7 @@ (delete-region (point) (point-max)) (insert "/dcc get -") (call-interactively #'completion-at-point) - (with-current-buffer (get-buffer "*Completions*") + (with-current-buffer "*Completions*" (goto-char (point-min)) (search-forward "-s") (search-forward "-t")) diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el index 90b8aa99741..0d8861f2167 100644 --- a/test/lisp/erc/erc-networks-tests.el +++ b/test/lisp/erc/erc-networks-tests.el @@ -1349,7 +1349,7 @@ (should-not (erc-server-process-alive (should (get-buffer "#chan/irc.foonet.org")))) - (with-current-buffer (get-buffer "#chan/irc.foonet.org") + (with-current-buffer "#chan/irc.foonet.org" (should-not erc-server-connected) (should (eq erc-server-process old-proc)) (erc-with-server-buffer diff --git a/test/lisp/erc/erc-scenarios-services-misc.el b/test/lisp/erc/erc-scenarios-services-misc.el index ab4a97c5724..47d0bcff41a 100644 --- a/test/lisp/erc/erc-scenarios-services-misc.el +++ b/test/lisp/erc/erc-scenarios-services-misc.el @@ -186,7 +186,7 @@ (funcall expect 10 "Last login from") (funcall expect 10 "Your new nickname is tester"))) - (with-current-buffer (get-buffer "#test") + (with-current-buffer "#test" (funcall expect 10 "tester ") (funcall expect 10 "was created on")))) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 6809d9db41d..3e8ddef3731 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -382,7 +382,7 @@ (should-not (search-forward (rx (or "9" "10") ">") nil t))))) (ert-info ("Query buffer") - (with-current-buffer (get-buffer "bob") + (with-current-buffer "bob" (goto-char erc-insert-marker) (should (looking-at-p "bob@ServNet 14>")) (goto-char erc-input-marker) From c94d680f6eb46a47549633c7076fe32660b3cd42 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Tue, 12 Mar 2024 16:01:57 -0500 Subject: [PATCH 028/155] Handle the case where 'vtable-update-object' doesn't find old object * lisp/emacs-lisp/vtable.el (vtable-update-object): If OLD-OBJECT is not found, don't call ELT, since SEQ-POSITION may return nil. (Bug#69664) --- lisp/emacs-lisp/vtable.el | 44 +++++++++++++++++++-------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 5cf8d8854bb..15a430f5c26 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -300,28 +300,28 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... - (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))) - (unless line - (error "Can't find cached object")) - (setcar line object) - (setcdr line (vtable--compute-cached-line table object)) - ;; ... and redisplay the line in question. - (save-excursion - (vtable-goto-object old-object) - (let ((keymap (get-text-property (point) 'keymap)) - (start (point))) - (delete-line) - (vtable--insert-line table line line-number - (nth 1 (vtable--cache table)) - (vtable--spacer table)) - (add-text-properties start (point) (list 'keymap keymap - 'vtable table)))) - ;; We may have inserted a non-numerical value into a previously - ;; all-numerical table, so recompute. - (vtable--recompute-numerical table (cdr line))))) + (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)) + ;; ... and redisplay the line in question. + (save-excursion + (vtable-goto-object old-object) + (let ((keymap (get-text-property (point) 'keymap)) + (start (point))) + (delete-line) + (vtable--insert-line table line line-number + (nth 1 (vtable--cache table)) + (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table)))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))) + (error "Can't find cached object in vtable")))) (defun vtable-remove-object (table object) "Remove OBJECT from TABLE. From a7057745f5ef903a2655c6d9e7813168e361baf7 Mon Sep 17 00:00:00 2001 From: Liu Hui Date: Mon, 26 Feb 2024 18:46:36 +0800 Subject: [PATCH 029/155] Detect the readline support for Python shell completion * lisp/progmodes/python.el (python-shell-comint-watch-for-first-prompt-output-filter): Detect the readline support. (python-shell-readline-completer-delims): Update docstring. (python-shell-completion-native-setup): Move the readline detection code to ... (python-shell-readline-detect): ... new function. (python-shell-completion-native-turn-on-maybe): Skip if Python has no readline support. (python-shell-completion-at-point): Respect the delimiter of readline completer in non-native completion. * test/lisp/progmodes/python-tests.el (python-shell-completion-at-point-1) (python-shell-completion-at-point-native-1) (python-completion-at-point-1, python-completion-at-point-2) (python-completion-at-point-pdb-1) (python-completion-at-point-while-running-1) (python-completion-at-point-native-1) (python-completion-at-point-native-2) (python-completion-at-point-native-with-ffap-1) (python-completion-at-point-native-with-eldoc-1): Skip tests if Python has no readline support. (python-shell-completion-at-point-jedi-completer): Add test for non-native Python shell completion. (bug#68559) --- lisp/progmodes/python.el | 29 ++++++++++++++++++++------- test/lisp/progmodes/python-tests.el | 31 ++++++++++++++++++++++++----- 2 files changed, 48 insertions(+), 12 deletions(-) diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 1016655cb62..8279617b6e7 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -3601,6 +3601,7 @@ The coding cookie regexp is specified in PEP 263.") (python-shell-send-string-no-output python-shell-eval-file-setup-code)) (with-current-buffer (current-buffer) (let ((inhibit-quit nil)) + (python-shell-readline-detect) (run-hooks 'python-shell-first-prompt-hook)))))) output) @@ -4361,7 +4362,23 @@ When a match is found, native completion is disabled." (defvar python-shell-readline-completer-delims nil "Word delimiters used by the readline completer. -It is automatically set by Python shell.") +It is automatically set by Python shell. An empty string means no +characters are considered delimiters and the readline completion +considers the entire line of input. A value of nil means the Python +shell has no readline support.") + +(defun python-shell-readline-detect () + "Detect the readline support for Python shell completion." + (let* ((process (python-shell-get-process)) + (output (python-shell-send-string-no-output " +try: + import readline + print(readline.get_completer_delims()) +except: + print('No readline support')" process))) + (setq-local python-shell-readline-completer-delims + (unless (string-search "No readline support" output) + (string-trim-right output))))) (defvar python-shell-completion-native-redirect-buffer " *Python completions redirect*" @@ -4501,10 +4518,6 @@ def __PYTHON_EL_native_completion_setup(): __PYTHON_EL_native_completion_setup()" process))) (when (string-match-p "python\\.el: native completion setup loaded" output) - (setq-local python-shell-readline-completer-delims - (string-trim-right - (python-shell-send-string-no-output - "import readline; print(readline.get_completer_delims())"))) (python-shell-completion-native-try)))) (defun python-shell-completion-native-turn-off (&optional msg) @@ -4533,7 +4546,8 @@ With argument MSG show activation/deactivation message." (cond ((python-shell-completion-native-interpreter-disabled-p) (python-shell-completion-native-turn-off msg)) - ((python-shell-completion-native-setup) + ((and python-shell-readline-completer-delims + (python-shell-completion-native-setup)) (when msg (message "Shell native completion is enabled."))) (t @@ -4705,7 +4719,8 @@ using that one instead of current buffer's process." (with-current-buffer (process-buffer process) (if python-shell-completion-native-enable (string= python-shell-readline-completer-delims "") - (string-match-p "ipython[23]?\\'" python-shell-interpreter))))) + (or (string-match-p "ipython[23]?\\'" python-shell-interpreter) + (equal python-shell-readline-completer-delims "")))))) (start (if (< (point) line-start) (point) diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 1ceee690cfb..e11440cdb5b 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -4783,6 +4783,7 @@ def foo(): (python-tests-with-temp-buffer-with-shell "" (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims) (insert "import abc") (comint-send-input) (python-tests-shell-wait-for-prompt) @@ -4797,6 +4798,7 @@ def foo(): "" (python-shell-completion-native-turn-on) (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims) (insert "import abc") (comint-send-input) (python-tests-shell-wait-for-prompt) @@ -4883,11 +4885,14 @@ def foo(): (python-tests-with-temp-buffer-with-shell "" (python-shell-with-shell-buffer - (python-shell-completion-native-turn-on) - (skip-unless (string= python-shell-readline-completer-delims "")) - (python-tests--completion-module) - (python-tests--completion-parameters) - (python-tests--completion-extra-context))))) + (skip-unless (string= python-shell-readline-completer-delims "")) + (python-shell-completion-native-turn-off) + (python-tests--completion-module) + (python-tests--completion-parameters) + (python-shell-completion-native-turn-on) + (python-tests--completion-module) + (python-tests--completion-parameters) + (python-tests--completion-extra-context))))) (ert-deftest python-shell-completion-at-point-ipython () "Check if Python shell completion works for IPython." @@ -4924,6 +4929,8 @@ def foo(): import abc " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-send-buffer) (python-tests-shell-wait-for-prompt) (goto-char (point-max)) @@ -4940,6 +4947,8 @@ import abc import abc " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-send-buffer) (python-tests-shell-wait-for-prompt) (python-shell-with-shell-buffer @@ -4959,6 +4968,8 @@ pdb.set_trace() print('Hello') " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-send-buffer) (python-tests-shell-wait-for-prompt) (goto-char (point-max)) @@ -4975,6 +4986,8 @@ import time time.sleep(3) " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-send-buffer) (goto-char (point-max)) (insert "time.") @@ -4987,6 +5000,8 @@ time.sleep(3) import abc " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-completion-native-turn-on) (python-shell-send-buffer) (python-tests-shell-wait-for-prompt) @@ -5004,6 +5019,8 @@ import abc import abc " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-completion-native-turn-on) (python-shell-send-buffer) (python-tests-shell-wait-for-prompt) @@ -5020,6 +5037,8 @@ import abc import abc " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-completion-native-turn-on) (python-shell-send-buffer) (python-tests-shell-wait-for-prompt) @@ -5036,6 +5055,8 @@ import abc import abc " (let ((inhibit-message t)) + (python-shell-with-shell-buffer + (skip-unless python-shell-readline-completer-delims)) (python-shell-completion-native-turn-on) (python-shell-send-buffer) (python-tests-shell-wait-for-prompt) From eae2c73edb3f09a06a31a38edd28e9751626e761 Mon Sep 17 00:00:00 2001 From: Pankaj Jangid Date: Thu, 14 Mar 2024 17:11:43 +0530 Subject: [PATCH 030/155] Add language server for Move to eglot * lisp/progmodes/eglot.el (eglot-server-programs): Added 'move-analyzer' language server. (Bug#69796) --- lisp/progmodes/eglot.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 4ffaf5f8a0e..b3fd104a227 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -295,6 +295,7 @@ automatically)." ((nushell-mode nushell-ts-mode) . ("nu" "--lsp")) (gdscript-mode . ("localhost" 6008)) (fennel-mode . ("fennel-ls")) + (move-mode . ("move-analyzer")) ((fortran-mode f90-mode) . ("fortls")) (futhark-mode . ("futhark" "lsp")) ((lua-mode lua-ts-mode) . ,(eglot-alternatives From f3deaa117acfc975be3edbe8461b18fc29b4adf0 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Thu, 14 Mar 2024 19:29:16 +0200 Subject: [PATCH 031/155] Context menu for project (bug#69566) * lisp/menu-bar.el (menu-bar-project-item): New variable from 'project-menu-entry'. (menu-bar-tools-menu): Use 'menu-bar-project-item'. * lisp/mouse.el (context-menu-functions): Add 'context-menu-project' to choice. (context-menu-project): New function. * lisp/progmodes/project.el (project-menu-entry): Remove variable. (project-mode-line-map): Use 'menu-bar-project-item' instead of 'project-menu-entry'. --- lisp/menu-bar.el | 5 ++++- lisp/mouse.el | 7 +++++++ lisp/progmodes/project.el | 6 ++---- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 5b290899ff5..320fabb54cf 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1838,6 +1838,9 @@ mail status in mode line")) (bindings--define-key menu [project-open-file] '(menu-item "Open File..." project-find-file :help "Open an existing file that belongs to current project")) menu)) +(defvar menu-bar-project-item + `(menu-item "Project" ,menu-bar-project-menu)) + (defun menu-bar-read-mail () "Read mail using `read-mail-command'." (interactive) @@ -1925,7 +1928,7 @@ mail status in mode line")) :help "Start language server suitable for this buffer's major-mode")) (bindings--define-key menu [project] - `(menu-item "Project" ,menu-bar-project-menu)) + menu-bar-project-item) (bindings--define-key menu [ede] '(menu-item "Project Support (EDE)" diff --git a/lisp/mouse.el b/lisp/mouse.el index 26835437c08..cef88dede8a 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -393,6 +393,7 @@ and should return the same menu with changes such as added new menu items." (function-item context-menu-local) (function-item context-menu-minor) (function-item context-menu-buffers) + (function-item context-menu-project) (function-item context-menu-vc) (function-item context-menu-ffap) (function-item hi-lock-context-menu) @@ -533,6 +534,12 @@ Some context functions add menu items below the separator." (mouse-buffer-menu-keymap)) menu) +(defun context-menu-project (menu _click) + "Populate MENU with project commands." + (define-key-after menu [separator-project] menu-bar-separator) + (define-key-after menu [project-menu] menu-bar-project-item) + menu) + (defun context-menu-vc (menu _click) "Populate MENU with Version Control commands." (define-key-after menu [separator-vc] menu-bar-separator) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 9622b1b6768..4284ea6edc6 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -2140,12 +2140,10 @@ is part of the default mode line beginning with Emacs 30." :group 'project :version "30.1") -(defvar project-menu-entry - `(menu-item "Project" ,(bound-and-true-p menu-bar-project-menu))) - (defvar project-mode-line-map (let ((map (make-sparse-keymap))) - (define-key map [mode-line down-mouse-1] project-menu-entry) + (define-key map [mode-line down-mouse-1] + (bound-and-true-p menu-bar-project-item)) map)) (defvar project-mode-line-face nil From bd6b64e0a8856a735b484f0482af0e937eb585d3 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Thu, 14 Mar 2024 19:37:44 +0200 Subject: [PATCH 032/155] * lisp/progmodes/project.el: Don't run modes from .dir-locals.el. (project--value-in-dir): Use 'alist-get' on 'file-local-variables-alist' to avoid calling 'hack-local-variables-apply' via 'hack-dir-local-variables-non-file-buffer' because it might enable undesirable modes such as flyspell-mode in a temporary buffer (bug#69740). --- lisp/progmodes/project.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 4284ea6edc6..a7c164f5857 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -808,8 +808,9 @@ DIRS must contain directory names." (with-temp-buffer (setq default-directory dir) (let ((enable-local-variables :all)) - (hack-dir-local-variables-non-file-buffer)) - (symbol-value var))) + (hack-dir-local-variables)) + ;; Don't use `hack-local-variables-apply' to avoid setting modes. + (alist-get var file-local-variables-alist))) (cl-defmethod project-buffers ((project (head vc))) (let* ((root (expand-file-name (file-name-as-directory (project-root project)))) From f03f14165ed51148b72b431ac99c4a4829bb1a7f Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Thu, 14 Mar 2024 20:11:33 +0200 Subject: [PATCH 033/155] * lisp/textmodes/flyspell.el (flyspell-check-changes): New user option. (flyspell--mode-on): Add flyspell-check-changes to post-command-hook when flyspell-check-changes is non-nil. (flyspell--mode-off): Remove flyspell-check-changes from post-command-hook. (flyspell-check-changes): New function (bug#61874). --- etc/NEWS | 5 +++++ lisp/textmodes/flyspell.el | 27 ++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 2985169ea91..327042f9d20 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1129,6 +1129,11 @@ distracting and easily confused with actual code, or a significant early aid that relieves you from moving the buffer or reaching for the mouse to consult an error message. +** Flyspell + +*** New user option 'flyspell-check-changes'. +It checks only edited text. + ** JS mode. The binding 'M-.' has been removed from the major mode keymaps in 'js-mode' and 'js-ts-mode', having it default to the global binding diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index de59294e9f0..d64e4d601f7 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -288,6 +288,12 @@ If this variable is nil, all regions are treated as small." "The key binding for flyspell auto correction." :type 'key-sequence) +(defcustom flyspell-check-changes nil + "Check only on moving point from the edited word. +Unlike the default behavior, don't check when moving point without editing." + :type 'boolean + :version "30.1") + ;;*---------------------------------------------------------------------*/ ;;* Mode specific options */ ;;* ------------------------------------------------------------- */ @@ -610,7 +616,9 @@ are both non-nil." (flyspell-accept-buffer-local-defs 'force) (flyspell-delay-commands) (flyspell-deplacement-commands) - (add-hook 'post-command-hook (function flyspell-post-command-hook) t t) + (if flyspell-check-changes + (add-hook 'post-command-hook (function flyspell-check-changes) t t) + (add-hook 'post-command-hook (function flyspell-post-command-hook) t t)) (add-hook 'pre-command-hook (function flyspell-pre-command-hook) t t) (add-hook 'after-change-functions 'flyspell-after-change-function nil t) (add-hook 'hack-local-variables-hook @@ -709,6 +717,7 @@ has been used, the current word is not checked." ;;;###autoload (defun flyspell--mode-off () "Turn Flyspell mode off." + (remove-hook 'post-command-hook (function flyspell-check-changes) t) (remove-hook 'post-command-hook (function flyspell-post-command-hook) t) (remove-hook 'pre-command-hook (function flyspell-pre-command-hook) t) (remove-hook 'after-change-functions 'flyspell-after-change-function t) @@ -990,6 +999,22 @@ Mostly we check word delimiters." (setq flyspell-changes (cdr flyspell-changes)))) (setq flyspell-previous-command command))))) +(defun flyspell-check-changes () + "The `post-command-hook' used by flyspell to check only edits. +It checks only on moving point from the edited word, +not when moving point without editing." + (when flyspell-mode + (with-local-quit + (when (consp flyspell-changes) + (let ((start (car (car flyspell-changes))) + (stop (cdr (car flyspell-changes))) + (word (save-excursion (flyspell-get-word)))) + (unless (and word (<= (nth 1 word) start) (>= (nth 2 word) stop)) + (save-excursion + (goto-char start) + (flyspell-word)) + (setq flyspell-changes nil))))))) + ;;*---------------------------------------------------------------------*/ ;;* flyspell-notify-misspell ... */ ;;*---------------------------------------------------------------------*/ From b708e639d63f488a98c7416866665c16730b9e8f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 14 Mar 2024 21:08:36 +0200 Subject: [PATCH 034/155] ; * src/lread.c (maybe_swap_for_eln): Clarify warning message. --- src/lread.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lread.c b/src/lread.c index 451f699e27d..7574e45f3dd 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1745,9 +1745,9 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd, = Fcons (list2 (Qcomp, CALLN (Fformat, - build_string ("Cannot look up eln " - "file as no source file " - "was found for %s"), + build_string ("Cannot look up .eln file " + "for %s because no source " + "file was found for it"), *filename)), Vdelayed_warnings_list); return; From 9a2c7d865ff8df960793e19c3f854db66b40e0fb Mon Sep 17 00:00:00 2001 From: Po Lu Date: Fri, 15 Mar 2024 08:36:21 +0800 Subject: [PATCH 035/155] Fix last change * src/xwidget.c (Fmake_xwidget): Cast boolean value to gboolean. (syms_of_xwidget): Fix coding style and improve doc string. --- src/xwidget.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/xwidget.c b/src/xwidget.c index 557b1e60409..2260c0c2e0f 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -378,7 +378,8 @@ fails. */) /* Enable the developer extras. */ settings = webkit_web_view_get_settings (WEBKIT_WEB_VIEW (xw->widget_osr)); g_object_set (G_OBJECT (settings), "enable-developer-extras", TRUE, NULL); - g_object_set (G_OBJECT (settings), "enable-javascript", !xwidget_webkit_disable_javascript, NULL); + g_object_set (G_OBJECT (settings), "enable-javascript", + (gboolean) (!xwidget_webkit_disable_javascript), NULL); } gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, @@ -3972,10 +3973,10 @@ syms_of_xwidget (void) doc: /* List of all xwidget views. */); Vxwidget_view_list = Qnil; - DEFVAR_BOOL("xwidget-webkit-disable-javascript", xwidget_webkit_disable_javascript, - doc: /* If non-nil, disable execution of JavaScript in xwidget webkit sessions. -You must kill all xwidget-webkit buffers for this setting to take effect -after changing it. */); + DEFVAR_BOOL ("xwidget-webkit-disable-javascript", xwidget_webkit_disable_javascript, + doc: /* If non-nil, disable execution of JavaScript in WebKit widgets. +Modifications to this setting do not take effect in existing WebKit +widgets. */); xwidget_webkit_disable_javascript = false; Fprovide (intern ("xwidget-internal"), Qnil); From c8c0d0a9550620adb111bf5d9e0155332498a6bf Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 14 Mar 2024 22:00:14 -0400 Subject: [PATCH 036/155] (customize-mode): Fix bug#69501 * lisp/cus-edit.el (customize-mode): Use the predicate arg of `completing-read` instead of binding `completion-regexp-list`. --- lisp/cus-edit.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 8fad51dc116..f004002333b 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1159,14 +1159,15 @@ argument or if the current major mode has no known group, prompt for the MODE to customize." (interactive (list - (let ((completion-regexp-list '("-mode\\'")) - (group (custom-group-of-mode major-mode))) + (let ((group (custom-group-of-mode major-mode))) (if (and group (not current-prefix-arg)) major-mode (intern (completing-read (format-prompt "Mode" (and group major-mode)) obarray - 'custom-group-of-mode + (lambda (s) + (and (string-match "-mode\\'" (symbol-name s)) + (custom-group-of-mode s))) t nil nil (if group (symbol-name major-mode)))))))) (customize-group (custom-group-of-mode mode))) From 9422a6737447b186ca017929da79985cef7898a8 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 14 Mar 2024 22:15:41 -0400 Subject: [PATCH 037/155] (set-auto-mode): Streamline to fix bug#67795 The old code tested if the mode function is `fboundp` but in an inconsistent way and without paying attention to `major-mode-remap`. * lisp/files.el (set-auto-mode-0): Return `:keep` rather than nil if the mode was already set. And emit a warning when the mode function doesn't exist. (set-auto-mode): Remove checks that the mode function exists now that `set-auto-mode-0` does it for us. Adjust to the new return values of that function, and simplify the code using a big `or` instead of a sequence of steps each setting&testing `done`. (hack-local-variables--find-variables): Use `major-mode-remap` when skipping the "mode:" entries that specify modes we don't have. Also, when (eq handle-mode t), don't bother building a list of results only to return a single element in the end. --- lisp/files.el | 231 ++++++++++++++++++++++++++------------------------ 1 file changed, 118 insertions(+), 113 deletions(-) diff --git a/lisp/files.el b/lisp/files.el index 3ca4f047144..766ed573392 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -3425,7 +3425,7 @@ set the major mode only if that would change it. In other words we don't actually set it to the same mode the buffer already has." ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*- (let ((try-locals (not (inhibit-local-variables-p))) - end done mode modes) + end modes) ;; Once we drop the deprecated feature where mode: is also allowed to ;; specify minor-modes (ie, there can be more than one "mode:"), we can ;; remove this section and just let (hack-local-variables t) handle it. @@ -3456,100 +3456,96 @@ we don't actually set it to the same mode the buffer already has." (push (intern (concat (downcase (buffer-substring (point) end)) "-mode")) modes)))) - ;; If we found modes to use, invoke them now, outside the save-excursion. - (if modes - (catch 'nop - (dolist (mode (nreverse modes)) - (if (not (functionp mode)) - (message "Ignoring unknown mode `%s'" mode) - (setq done t) - (or (set-auto-mode-0 mode keep-mode-if-same) - ;; continuing would call minor modes again, toggling them off - (throw 'nop nil)))))) - ;; Check for auto-mode-alist entry in dir-locals. - (unless done - (with-demoted-errors "Directory-local variables error: %s" - ;; Note this is a no-op if enable-local-variables is nil. - (let* ((mode-alist (cdr (hack-dir-local--get-variables - (lambda (key) (eq key 'auto-mode-alist)))))) - (setq done (set-auto-mode--apply-alist mode-alist - keep-mode-if-same t))))) - (and (not done) - (setq mode (hack-local-variables t (not try-locals))) - (not (memq mode modes)) ; already tried and failed - (if (not (functionp mode)) - (message "Ignoring unknown mode `%s'" mode) - (setq done t) - (set-auto-mode-0 mode keep-mode-if-same))) - ;; 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. - (and (not done) - (setq mode (save-excursion - (goto-char (point-min)) - (if (looking-at auto-mode-interpreter-regexp) - (match-string 2)))) - ;; Map interpreter name to a mode, signaling we're done at the - ;; same time. - (setq done (assoc-default - (file-name-nondirectory mode) - (mapcar (lambda (e) - (cons - (format "\\`%s\\'" (car e)) - (cdr e))) - interpreter-mode-alist) - #'string-match-p)) - ;; If we found an interpreter mode to use, invoke it now. - (set-auto-mode-0 done keep-mode-if-same)) - ;; Next try matching the buffer beginning against magic-mode-alist. - (unless done - (if (setq done (save-excursion - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point-min) - (min (point-max) - (+ (point-min) magic-mode-regexp-match-limit))) - (assoc-default - nil magic-mode-alist - (lambda (re _dummy) - (cond - ((functionp re) - (funcall re)) - ((stringp re) - (let ((case-fold-search nil)) - (looking-at re))) - (t - (error - "Problem in magic-mode-alist with element %s" - re)))))))) - (set-auto-mode-0 done keep-mode-if-same))) - ;; Next compare the filename against the entries in auto-mode-alist. - (unless done - (setq done (set-auto-mode--apply-alist auto-mode-alist - keep-mode-if-same nil))) - ;; Next try matching the buffer beginning against magic-fallback-mode-alist. - (unless done - (if (setq done (save-excursion - (goto-char (point-min)) - (save-restriction - (narrow-to-region (point-min) - (min (point-max) - (+ (point-min) magic-mode-regexp-match-limit))) - (assoc-default nil magic-fallback-mode-alist - (lambda (re _dummy) - (cond - ((functionp re) - (funcall re)) - ((stringp re) - (let ((case-fold-search nil)) - (looking-at re))) - (t - (error - "Problem with magic-fallback-mode-alist element: %s" - re)))))))) - (set-auto-mode-0 done keep-mode-if-same))) - (unless done - (set-buffer-major-mode (current-buffer))))) + (or + ;; If we found modes to use, invoke them now, outside the save-excursion. + ;; Presume `modes' holds a major mode followed by minor modes. + (let ((done ())) + (dolist (mode (nreverse modes)) + (if (eq done :keep) + ;; `keep-mode-if-same' is set and the (major) mode + ;; was already set. Refrain from calling the following + ;; minor modes since they have already been set. + ;; It was especially important in the past when calling + ;; minor modes without an arg would toggle them, but it's + ;; still preferable to avoid re-enabling them, + nil + (let ((res (set-auto-mode-0 mode keep-mode-if-same))) + (setq done (or res done))))) + done) + ;; Check for auto-mode-alist entry in dir-locals. + (with-demoted-errors "Directory-local variables error: %s" + ;; Note this is a no-op if enable-local-variables is nil. + (let* ((mode-alist (cdr (hack-dir-local--get-variables + (lambda (key) (eq key 'auto-mode-alist)))))) + (set-auto-mode--apply-alist mode-alist keep-mode-if-same t))) + (let ((mode (hack-local-variables t (not try-locals)))) + (unless (memq mode modes) ; already tried and failed + (set-auto-mode-0 mode keep-mode-if-same))) + ;; 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 + ((interp (save-excursion + (goto-char (point-min)) + (if (looking-at auto-mode-interpreter-regexp) + (match-string 2)))) + ;; Map interpreter name to a mode, signaling we're done at the + ;; same time. + (mode (assoc-default + (file-name-nondirectory interp) + (mapcar (lambda (e) + (cons + (format "\\`%s\\'" (car e)) + (cdr e))) + interpreter-mode-alist) + #'string-match-p))) + ;; If we found an interpreter mode to use, invoke it now. + (set-auto-mode-0 mode keep-mode-if-same)) + ;; Next try matching the buffer beginning against magic-mode-alist. + (let ((mode (save-excursion + (goto-char (point-min)) + (save-restriction + (narrow-to-region (point-min) + (min (point-max) + (+ (point-min) magic-mode-regexp-match-limit))) + (assoc-default + nil magic-mode-alist + (lambda (re _dummy) + (cond + ((functionp re) + (funcall re)) + ((stringp re) + (let ((case-fold-search nil)) + (looking-at re))) + (t + (error + "Problem in magic-mode-alist with element %s" + re))))))))) + (set-auto-mode-0 mode keep-mode-if-same)) + ;; Next compare the filename against the entries in auto-mode-alist. + (set-auto-mode--apply-alist auto-mode-alist + keep-mode-if-same nil) + ;; Next try matching the buffer beginning against magic-fallback-mode-alist. + (let ((mode (save-excursion + (goto-char (point-min)) + (save-restriction + (narrow-to-region (point-min) + (min (point-max) + (+ (point-min) magic-mode-regexp-match-limit))) + (assoc-default nil magic-fallback-mode-alist + (lambda (re _dummy) + (cond + ((functionp re) + (funcall re)) + ((stringp re) + (let ((case-fold-search nil)) + (looking-at re))) + (t + (error + "Problem with magic-fallback-mode-alist element: %s" + re))))))))) + (set-auto-mode-0 mode keep-mode-if-same)) + (set-buffer-major-mode (current-buffer))))) (defvar-local set-auto-mode--last nil "Remember the mode we have set via `set-auto-mode-0'.") @@ -3583,18 +3579,29 @@ and it is meant to be modified by packages rather than users.") "Apply MODE and return it. If optional arg KEEP-MODE-IF-SAME is non-nil, MODE is chased of any aliases and compared to current major mode. If they are the -same, do nothing and return nil." - (unless (and keep-mode-if-same - (or (eq (indirect-function mode) - (indirect-function major-mode)) - (and set-auto-mode--last - (eq mode (car set-auto-mode--last)) - (eq major-mode (cdr set-auto-mode--last))))) - (when mode - (funcall (major-mode-remap mode)) - (unless (eq mode major-mode) - (setq set-auto-mode--last (cons mode major-mode))) - mode))) +same, do nothing and return `:keep'. +Return nil if MODE could not be applied." + (when mode + (if (and keep-mode-if-same + (or (eq (indirect-function mode) + (indirect-function major-mode)) + (and set-auto-mode--last + (eq mode (car set-auto-mode--last)) + (eq major-mode (cdr set-auto-mode--last))))) + :keep + (let ((modefun (major-mode-remap mode))) + (if (not (functionp modefun)) + (progn + (message "Ignoring unknown mode `%s'%s" mode + (if (eq mode modefun) "" + (format " (remapped to `%S')" modefun))) + nil) + (funcall modefun) + (unless (or (eq mode major-mode) ;`set-auto-mode--last' is overkill. + ;; `modefun' is something like a minor mode. + (local-variable-p 'set-auto-mode--last)) + (setq set-auto-mode--last (cons mode major-mode))) + mode))))) (defvar file-auto-mode-skip "^\\(#!\\|'\\\\\"\\)" "Regexp of lines to skip when looking for file-local settings. @@ -4201,8 +4208,9 @@ major-mode." (not (string-match "-minor\\'" (setq val2 (downcase (symbol-name val))))) - ;; Allow several mode: elements. - (push (intern (concat val2 "-mode")) result)) + (let ((mode (intern (concat val2 "-mode")))) + (when (fboundp (major-mode-remap mode)) + (setq result mode)))) (cond ((eq var 'coding)) ((eq var 'lexical-binding) (unless hack-local-variables--warned-lexical @@ -4233,10 +4241,7 @@ major-mode." val) result)))))) (forward-line 1))))))) - (if (eq handle-mode t) - ;; Return the final mode: setting that's defined. - (car (seq-filter #'fboundp result)) - result))) + result)) (defun hack-local-variables-apply () "Apply the elements of `file-local-variables-alist'. From 5037b9eed711dec0ef73dd6fca1e60e0b521c13b Mon Sep 17 00:00:00 2001 From: Patrick Bader Date: Mon, 4 Mar 2024 16:14:25 +0100 Subject: [PATCH 038/155] fix: project submodule detection does not work for worktrees --- lisp/progmodes/project.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index a7c164f5857..7103b36a892 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -602,7 +602,7 @@ See `project-vc-extra-root-markers' for the marker value format.") (goto-char (point-min)) ;; Kind of a hack to distinguish a submodule from ;; other cases of .git files pointing elsewhere. - (looking-at "gitdir: [./]+/\\.git/modules/")) + (looking-at "gitdir: .+/\\.git/\\(worktrees/.*\\)?modules/")) t) (t nil)))) From 77a86d738eebc7a80b7d4a6357a5fa675df9de8c Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Fri, 15 Mar 2024 04:28:45 +0200 Subject: [PATCH 039/155] (project--value-in-dir): Ensure that the global value is still honored * lisp/progmodes/project.el (project--value-in-dir): Ensure that the global value of the variable is still honored, when the variable is not in dir-locals. --- lisp/progmodes/project.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 7103b36a892..ac18aceadcf 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -810,7 +810,8 @@ DIRS must contain directory names." (let ((enable-local-variables :all)) (hack-dir-local-variables)) ;; Don't use `hack-local-variables-apply' to avoid setting modes. - (alist-get var file-local-variables-alist))) + (alist-get var file-local-variables-alist + (symbol-value var)))) (cl-defmethod project-buffers ((project (head vc))) (let* ((root (expand-file-name (file-name-as-directory (project-root project)))) From c453c82dc6af2178ce10ffddccd9f38543ea6e88 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Fri, 15 Mar 2024 11:50:09 +0800 Subject: [PATCH 040/155] * src/sfntfont-android.c (init_sfntfont_android): Fix SDK check. --- src/sfntfont-android.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/sfntfont-android.c b/src/sfntfont-android.c index 94aedd0cd66..1ed394b9458 100644 --- a/src/sfntfont-android.c +++ b/src/sfntfont-android.c @@ -770,7 +770,7 @@ init_sfntfont_android (void) build_string ("Roboto")), Fcons (build_string ("DejaVu Serif"), build_string ("Noto Serif"))); - else if (api_level >= 15) + else if (api_level >= 14) /* Android 4.0 and later distribute Roboto in lieu of Droid Sans. */ Vsfnt_default_family_alist From 1be33963f068b884d1f8cbd37372638c47a79e84 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Fri, 15 Mar 2024 11:50:27 +0800 Subject: [PATCH 041/155] ; * src/androidselect.c (Fandroid_notifications_notify): Typo in doc string. --- src/androidselect.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/androidselect.c b/src/androidselect.c index 87dd2c3d079..2f6114d0fcb 100644 --- a/src/androidselect.c +++ b/src/androidselect.c @@ -803,7 +803,7 @@ keywords is understood: for arguments. The notification group and timeout are ignored on Android 7.1 and -earlier versions of Android. On more recent versions, the urgency +earlier versions of Android. On more recent versions, the group identifies a category that will be displayed in the system Settings menu, and the urgency provided always extends to affect all notifications displayed within that category, though it may be ignored From 09ab66935154ea0cc4a351b8320bc0e9276b7780 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Sun, 3 Mar 2024 17:20:56 +0100 Subject: [PATCH 042/155] Keep indenting text when 'shr-fill-text' is nil (bug#69555) The 'shr-fill-...' functions handle both hard-filling (adding newlines to break long lines) and indentation. Setting 'shr-fill-text' to nil currently causes these functions to be short-circuited completely, so e.g. blockquotes are no longer indented, whereas the intent of this user option is only to prevent hard-filling to let visual-line-mode reflow text. * lisp/net/shr.el (shr-fill-lines): Document that the function handles more than just filling; move the 'shr-fill-text' check... (shr-fill-line): ... here, after indentation has been taken care of. * test/lisp/net/shr-resources/blockquote.html: * test/lisp/net/shr-resources/blockquote.txt: New test resources. * test/lisp/net/shr-tests.el (shr-test--rendering-check): Rename from 'shr-test', to make the relationship with the 'rendering' testcase clearer; prefer 'file-name-concat' to 'format'; raise ERT failure if need be, calling (ert-fail ...) directly instead of (should (not (list ...))). (shr-test--rendering-extra-configs): New variable to easily check that user customizations do not degrade rendering. (rendering): Consult that new variable; delegate failure-raising to reduce duplication. --- lisp/net/shr.el | 15 +++-- test/lisp/net/shr-resources/blockquote.html | 2 + test/lisp/net/shr-resources/blockquote.txt | 3 + test/lisp/net/shr-tests.el | 72 +++++++++++++++------ 4 files changed, 67 insertions(+), 25 deletions(-) create mode 100644 test/lisp/net/shr-resources/blockquote.html create mode 100644 test/lisp/net/shr-resources/blockquote.txt diff --git a/lisp/net/shr.el b/lisp/net/shr.el index e23fc6104d2..09df5f5a9bb 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -784,8 +784,9 @@ size, and full-buffer size." (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) - (if (or (not shr-fill-text) (<= shr-internal-width 0)) - nil + "Indent and fill text from START to END. +When `shr-fill-text' is nil, only indent." + (unless (<= shr-internal-width 0) (save-restriction (narrow-to-region start end) (goto-char start) @@ -807,6 +808,8 @@ size, and full-buffer size." (forward-char 1)))) (defun shr-fill-line () + "Indent and fill the current line. +When `shr-fill-text' is nil, only indent." (let ((shr-indentation (or (get-text-property (point) 'shr-indentation) shr-indentation)) (continuation (get-text-property @@ -821,9 +824,11 @@ size, and full-buffer size." `,(shr-face-background face)))) (setq start (point)) (setq shr-indentation (or continuation shr-indentation)) - ;; If we have an indentation that's wider than the width we're - ;; trying to fill to, then just give up and don't do any filling. - (when (< shr-indentation shr-internal-width) + ;; Fill the current line, unless `shr-fill-text' is unset, or we + ;; have an indentation that's wider than the width we're trying to + ;; fill to. + (when (and shr-fill-text + (< shr-indentation shr-internal-width)) (shr-vertical-motion shr-internal-width) (when (looking-at " $") (delete-region (point) (line-end-position))) diff --git a/test/lisp/net/shr-resources/blockquote.html b/test/lisp/net/shr-resources/blockquote.html new file mode 100644 index 00000000000..412caf8bae6 --- /dev/null +++ b/test/lisp/net/shr-resources/blockquote.html @@ -0,0 +1,2 @@ +
Citation.
+
Reply.
diff --git a/test/lisp/net/shr-resources/blockquote.txt b/test/lisp/net/shr-resources/blockquote.txt new file mode 100644 index 00000000000..8ed610b8ea2 --- /dev/null +++ b/test/lisp/net/shr-resources/blockquote.txt @@ -0,0 +1,3 @@ + Citation. + +Reply. diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index 0c6e2c091bf..17138053450 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -29,30 +29,62 @@ (declare-function libxml-parse-html-region "xml.c") -(defun shr-test (name) - (with-temp-buffer - (insert-file-contents (format (concat (ert-resource-directory) "/%s.html") name)) - (let ((dom (libxml-parse-html-region (point-min) (point-max))) - (shr-width 80) - (shr-use-fonts nil)) - (erase-buffer) - (shr-insert-document dom) - (cons (buffer-substring-no-properties (point-min) (point-max)) - (with-temp-buffer - (insert-file-contents - (format (concat (ert-resource-directory) "/%s.txt") name)) - (while (re-search-forward "%\\([0-9A-F][0-9A-F]\\)" nil t) - (replace-match (string (string-to-number (match-string 1) 16)) - t t)) - (buffer-string)))))) +(defun shr-test--rendering-check (name &optional context) + "Render NAME.html and compare it to NAME.txt. +Raise a test failure if the rendered buffer does not match NAME.txt. +Append CONTEXT to the failure data, if non-nil." + (let ((text-file (file-name-concat (ert-resource-directory) (concat name ".txt"))) + (html-file (file-name-concat (ert-resource-directory) (concat name ".html"))) + (description (if context (format "%s (%s)" name context) name))) + (with-temp-buffer + (insert-file-contents html-file) + (let ((dom (libxml-parse-html-region (point-min) (point-max))) + (shr-width 80) + (shr-use-fonts nil)) + (erase-buffer) + (shr-insert-document dom) + (let ((result (buffer-substring-no-properties (point-min) (point-max))) + (expected + (with-temp-buffer + (insert-file-contents text-file) + (while (re-search-forward "%\\([0-9A-F][0-9A-F]\\)" nil t) + (replace-match (string (string-to-number (match-string 1) 16)) + t t)) + (buffer-string)))) + (unless (equal result expected) + (ert-fail (list description result expected)))))))) + +(defconst shr-test--rendering-extra-configs + '(("blockquote" + ;; Make sure blockquotes remain indented even when filling is + ;; disabled (bug#69555). + . ((shr-fill-text . nil)))) + "Extra customizations which can impact rendering. +This is a list of (NAME . SETTINGS) pairs. NAME is the basename of a +set of txt/html files under shr-resources/, as passed to `shr-test'. +SETTINGS is a list of (OPTION . VALUE) pairs that are interesting to +validate for the NAME testcase. + +The `rendering' testcase will test NAME once without altering any +settings, then once more for each (OPTION . VALUE) pair.") (ert-deftest rendering () (skip-unless (fboundp 'libxml-parse-html-region)) (dolist (file (directory-files (ert-resource-directory) nil "\\.html\\'")) - (let* ((name (replace-regexp-in-string "\\.html\\'" "" file)) - (result (shr-test name))) - (unless (equal (car result) (cdr result)) - (should (not (list name (car result) (cdr result)))))))) + (let* ((name (string-remove-suffix ".html" file)) + (extra-options (alist-get name shr-test--rendering-extra-configs + nil nil 'string=))) + ;; Test once with default settings. + (shr-test--rendering-check name) + ;; Test once more for every extra option for this specific NAME. + (pcase-dolist (`(,option-sym ,option-val) + extra-options) + (let ((option-old (symbol-value option-sym))) + (set option-sym option-val) + (unwind-protect + (shr-test--rendering-check + name (format "with %s %s" option-sym option-val)) + (set option-sym option-old))))))) (ert-deftest use-cookies () (let ((shr-cookie-policy 'same-origin)) From 9dcb28d6014f72e5f52ad46d6141e9be4e11bfa5 Mon Sep 17 00:00:00 2001 From: Spencer Baugh Date: Tue, 27 Feb 2024 15:42:38 -0500 Subject: [PATCH 043/155] With visible-completions, only bind RET when completion is selected Previously, if minibuffer-visible-completions was non-nil, we bound RET whenever the *Completions* buffer was visible. This meant that RET in completion-in-region would not enter a newline, which is a somewhat annoying behavior change from minibuffer-visible-completions=nil. Now, we only bind RET when a completion is selected. This means RET will newline in completion-in-region. So that completion help continues to suggest the correct keys, we also add minibuffer-visible-completions--always-bind. When let-bound to a non-nil value, it makes the minibuffer-visible-completions binds always active. We let-bind it around substitute-command-keys. * lisp/minibuffer.el (minibuffer-visible-completions--always-bind) (minibuffer-visible-completions--filter): Add. (minibuffer-visible-completions-bind): Use minibuffer-visible-completions--filter. (bug#68801) * lisp/simple.el (minibuffer-visible-completions--always-bind) (completion-setup-function): Let-bind minibuffer-visible-completions--always-bind so the completion help is correct. --- lisp/minibuffer.el | 24 ++++++++++++++++++------ lisp/simple.el | 19 +++++++++++-------- 2 files changed, 29 insertions(+), 14 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 099fa1599d5..0a844c538b4 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -3163,18 +3163,30 @@ and `RET' accepts the input typed into the minibuffer." :type 'boolean :version "30.1") +(defvar minibuffer-visible-completions--always-bind nil + "If non-nil, force the `minibuffer-visible-completions' bindings on.") + +(defun minibuffer-visible-completions--filter (cmd) + "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 (and (eq (buffer-local-value 'completion-reference-buffer + (window-buffer window)) + (window-buffer (active-minibuffer-window))) + (if (eq cmd #'minibuffer-choose-completion-or-exit) + (with-current-buffer (window-buffer window) + (get-text-property (point) 'completion--string)) + t)) + cmd)))) + (defun minibuffer-visible-completions-bind (binding) "Use BINDING when completions are visible. Return an item that is enabled only when a window displaying the *Completions* buffer exists." `(menu-item "" ,binding - :filter ,(lambda (cmd) - (when-let ((window (get-buffer-window "*Completions*" 0))) - (when (eq (buffer-local-value 'completion-reference-buffer - (window-buffer window)) - (window-buffer (active-minibuffer-window))) - cmd))))) + :filter ,#'minibuffer-visible-completions--filter)) (defvar-keymap minibuffer-visible-completions-map :doc "Local keymap for minibuffer input with visible completions." diff --git a/lisp/simple.el b/lisp/simple.el index f127290231b..0645f18cc78 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -10298,6 +10298,8 @@ Called from `temp-buffer-show-hook'." :version "22.1" :group 'completion) +(defvar minibuffer-visible-completions--always-bind) + ;; This function goes in completion-setup-hook, so that it is called ;; after the text of the completion list buffer is written. (defun completion-setup-function () @@ -10338,15 +10340,16 @@ Called from `temp-buffer-show-hook'." (if minibuffer-visible-completions (let ((helps (with-current-buffer (window-buffer (active-minibuffer-window)) - (list - (substitute-command-keys - (if (display-mouse-p) - "Click or type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n" - "Type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n")) - (substitute-command-keys - "Type \\[minibuffer-next-completion], \\[minibuffer-previous-completion], \ + (let ((minibuffer-visible-completions--always-bind t)) + (list + (substitute-command-keys + (if (display-mouse-p) + "Click or type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n" + "Type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n")) + (substitute-command-keys + "Type \\[minibuffer-next-completion], \\[minibuffer-previous-completion], \ \\[minibuffer-next-line-completion], \\[minibuffer-previous-line-completion] \ -to move point between completions.\n\n"))))) +to move point between completions.\n\n")))))) (dolist (help helps) (insert help))) (insert (substitute-command-keys From ffbf876a93c7b34c84806e43659efbac519279fa Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Fri, 15 Mar 2024 09:45:48 +0200 Subject: [PATCH 044/155] * lisp/vc/diff-mode.el (diff-mode-menu): Add menu item "Apply all hunks". It's bound to the recently added command 'diff-apply-buffer'. --- lisp/vc/diff-mode.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index ac7d55c8a46..0f393ba86a2 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -240,6 +240,8 @@ The default \"-b\" means to ignore whitespace-only changes, :help "Apply the current hunk to the source file and go to the next"] ["Test applying hunk" diff-test-hunk :help "See whether it's possible to apply the current hunk"] + ["Apply all hunks" diff-apply-buffer + :help "Apply all hunks in the current diff buffer"] ["Apply diff with Ediff" diff-ediff-patch :help "Call `ediff-patch-file' on the current buffer"] ["Create Change Log entries" diff-add-change-log-entries-other-window From ebd32040e06bf57761f59638b600cfdeb408cbc5 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 15 Mar 2024 10:29:06 +0200 Subject: [PATCH 045/155] ; * src/xwidget.c (xwidget-webkit-disable-javascript): Doc fix. --- src/xwidget.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/xwidget.c b/src/xwidget.c index 2260c0c2e0f..389c48ca7f5 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -3974,9 +3974,10 @@ syms_of_xwidget (void) Vxwidget_view_list = Qnil; DEFVAR_BOOL ("xwidget-webkit-disable-javascript", xwidget_webkit_disable_javascript, - doc: /* If non-nil, disable execution of JavaScript in WebKit widgets. + doc: /* If non-nil, disable execution of JavaScript in xwidget WebKit widgets. Modifications to this setting do not take effect in existing WebKit -widgets. */); +widgets; kill all xwidget-webkit buffers for changes in this setting +to take effect. */); xwidget_webkit_disable_javascript = false; Fprovide (intern ("xwidget-internal"), Qnil); From 1c4233b9a391ba5d5746acf6b6fd4b352b8c3a58 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 15 Mar 2024 10:44:23 +0200 Subject: [PATCH 046/155] ; Fix documentation of 'flyspell-check-changes' * lisp/textmodes/flyspell.el (flyspell-check-changes): Doc fixes. * etc/NEWS: Improve wording of entry for 'flyspell-check-changes'. --- etc/NEWS | 3 ++- lisp/textmodes/flyspell.el | 14 +++++++++----- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 327042f9d20..da9a2fd90fa 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1132,7 +1132,8 @@ mouse to consult an error message. ** Flyspell *** New user option 'flyspell-check-changes'. -It checks only edited text. +When non-nil, Flyspell mode spell-checks only words that you edited; it +does not check unedited words just because you move point across them. ** JS mode. The binding 'M-.' has been removed from the major mode keymaps in diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index d64e4d601f7..09d4e8a8d1a 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -289,8 +289,11 @@ If this variable is nil, all regions are treated as small." :type 'key-sequence) (defcustom flyspell-check-changes nil - "Check only on moving point from the edited word. -Unlike the default behavior, don't check when moving point without editing." + "If non-nil, spell-check only words that were edited. +By default, this is nil, and Flyspell checks every word across which +you move point, even if you haven't edited the word. Customizing this +option to a non-nil value will not flag mis-spelled words across which +you move point without editing them." :type 'boolean :version "30.1") @@ -1000,9 +1003,10 @@ Mostly we check word delimiters." (setq flyspell-previous-command command))))) (defun flyspell-check-changes () - "The `post-command-hook' used by flyspell to check only edits. -It checks only on moving point from the edited word, -not when moving point without editing." + "Function to spell-check only edited words when point moves off the word. +This is installed by flyspell as `post-command-hook' when the user +option `flyspell-check-changes' is non-nil. It spell-checks a word +on moving point from the word only if the word was edited before the move." (when flyspell-mode (with-local-quit (when (consp flyspell-changes) From 5bba1b95b8088048808b306bf8b00eb9b342ce92 Mon Sep 17 00:00:00 2001 From: Martin Rudalics Date: Fri, 15 Mar 2024 10:35:27 +0100 Subject: [PATCH 047/155] Further adjustments for restoring killed buffer windows (Bug#68235) * etc/NEWS: Announce 'window-restore-killed-buffer-windows'. * src/buffer.h (struct buffer) : New field last_name_. * src/buffer.c (Fbuffer_last_name): New function to return last name of buffer before it was killed or renamed. (bset_last_name, Fget_buffer_create, Fmake_indirect_buffer) (Frename_buffer, Fkill_buffer, init_buffer_once): Set buffer's last_name_ field accordingly. * src/window.c (window_restore_killed_buffer_windows): New variable replacing Vwindow_kept_windows_functions. (Fset_window_configuration): Use window_restore_killed_buffer_windows instead of Vwindow_kept_windows_functions. * lisp/window.el (window--state-put-2, window-state-put): Use 'window-restore-killed-buffer-windows' instead of 'window-kept-windows-functions'. * doc/lispref/windows.texi (Window Configurations): Describe 'window-restore-killed-buffer-windows' which replaces 'window-kept-windows-functions'. --- doc/lispref/windows.texi | 114 +++++++++++++++++++---------- etc/NEWS | 6 ++ lisp/window.el | 49 ++++++------- src/buffer.c | 26 ++++++- src/buffer.h | 3 + src/window.c | 153 +++++++++++++++++++++++---------------- 6 files changed, 224 insertions(+), 127 deletions(-) diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index fe3dc573df5..45d67ba4946 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -6264,15 +6264,10 @@ this function does is to restore the value of the variable @code{minibuffer-selected-window}. In this case, the function returns @code{nil}. Otherwise, it returns @code{t}. -If the buffer of a window of @var{configuration} has been killed since -@var{configuration} was made, that window is, as a rule, removed from -the restored configuration. However, if that window is the last window -remaining in the restored configuration, another live buffer is shown in -it. Also, if the variable @var{window-kept-windows-functions} is -non-@code{nil}, any window whose buffer is now dead is not deleted. -Rather, this function will show another live buffer in that window and -include an entry for that window when calling any function in -@var{window-kept-windows-functions} (@pxref{Window Hooks}). +This function consults the variable +@code{window-restore-killed-buffer-windows} (see below) when it tries to +restore a window whose buffer was killed after @var{configuration} was +recorded. Here is a way of using this function to get the same effect as @code{save-window-excursion}: @@ -6361,14 +6356,9 @@ a live window, it is replaced by a new live window created on the same frame before putting @var{state} into it. If @var{window} is @code{nil}, it puts the window state into a new window. -If the buffer of any window recorded in @var{state} has been killed -since @var{state} was made, that window is, as a rule, not restored. -However, if that window is the only window in @var{state}, another live -buffer will be shown in it. Also, if the variable -@var{window-kept-windows-functions} is non-@code{nil}, any window whose -buffer is now dead is restored. This function will show another live -buffer in it and include an entry for that window when calling a -function in @var{window-kept-windows-functions} (@pxref{Window Hooks}). +This function consults the variable +@code{window-restore-killed-buffer-windows} (see below) when it tries to +restore a window whose buffer was killed after @var{state} was recorded. If the optional argument @var{ignore} is non-@code{nil}, it means to ignore minimum window sizes and fixed-size restrictions. If @var{ignore} @@ -6376,6 +6366,75 @@ is @code{safe}, this means windows can get as small as one line and/or two columns. @end defun +By default, @code{set-window-configuration} and @code{window-state-put} +may delete a window from the restored configuration when they find out +that its buffer was killed since the corresponding configuration or +state has been recorded. The variable described next can be used to +fine-tune that behavior. + +@cindex restoring windows whose buffers have been killed +@defvar window-restore-killed-buffer-windows +This variable specifies how @code{set-window-configuration} and +@code{window-state-put} shall handle a window whose buffer has been +killed since the corresponding configuration or state was made. Any +such window may be live - in which case it shows some other buffer - or +dead at the time one of these functions is called. Usually, +@code{set-window-configuration} leaves the window alone if it is live +while @code{window-state-put} deletes it. + +The following values can be used to override the default behavior for +dead windows in the case of @code{set-window-configuration} and for dead +and live windows in the case of @code{window-state-put}. + +@table @asis +@item @code{t} +This value means to unconditionally restore the window and show some +other buffer in it. + +@item @code{delete} +This means to unconditionally try to delete the window. + +@item @code{dedicated} +This means to try to delete the window if and only if it is dedicated to +its buffer. + +@item @code{nil} +This is the default and means that @code{set-window-configuration} will +try to delete the window if and only if it is dedicated to its buffer +and @code{window-state-put} will unconditionally try to delete it. + +@item a function +This means to restore the window, show some other buffer in it and add +an entry for that window to a list that will be later passed as argument +to that function. +@end table + +If a window cannot be deleted (typically, because it is the last window +on its frame), @code{set-window-configuration} and +@code{window-state-put} will show another buffer in it. + +If the value of this variable is a function, that function should take +three arguments. The first argument specifies the frame whose windows +have been restored. The third argument is either the constant +@code{configuration} if the windows are restored by +@code{set-window-configuration} or the constant @code{state} if the +windows are restored by @code{window-state-put}. + +The second argument specifies a list of entries for @emph{any} window +whose previous buffer has been encountered dead at the time +@code{set-window-configuration} or @code{window-state-put} tried to +restore it in that window (minibuffer windows are excluded). This means +that the function specified by this variable may also delete windows +encountered live by @code{set-window-configuration}. + +Each entry is a list of six values - the window whose buffer was found +dead, the dead buffer or its name, the positions of start and point of +the buffer in that window, the dedicated status of the window as +previously reported by @code{window-dedicated-p} and a flag that is +@code{t} if the window has been encountered live by +@code{set-window-configuration} and @code{nil} otherwise. +@end defvar + The functions @code{window-state-get} and @code{window-state-put} also allow exchanging the contents of two live windows. The following function does precisely that: @@ -6636,27 +6695,6 @@ Lock fontification function, which will be called whenever parts of a buffer are (re)fontified because a window was scrolled or its size changed. @xref{Other Font Lock Variables}. -@cindex window kept windows functions -@defvar window-kept-windows-functions - This variable holds a list of functions that Emacs will call after -restoring a window configuration via @code{set-window-configuration} or -state via @code{window-state-put} (@pxref{Window Configurations}). When -the value of this variable is non-@code{nil}, these functions will not -delete any window whose buffer has been killed since the corresponding -configuration or state was saved, but show some live buffer in it. - -The value should be a list of functions that take two arguments. The -first argument specifies the frame whose windows have been restored. -The second argument specifies a list of entries for each window whose -buffer has been found dead at the time @code{set-window-configuration} -or @code{window-state-put} tried to restore it. Each entry is a list of -four values - the window whose buffer was found dead, the dead buffer, -and the last known positions of start and point of the buffer in that -window. Any function run by this hook should check that the window is -live since another function run by this hook may have deleted it in the -meantime. -@end defvar - @cindex window change functions The remainder of this section covers six hooks that are called during redisplay provided a significant, non-scrolling change of a diff --git a/etc/NEWS b/etc/NEWS index da9a2fd90fa..dfbf6edb098 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -283,6 +283,12 @@ right-aligned to is controlled by the new user option It specifies whether the window of the displayed buffer should be selected or deselected at the end of executing the current command. ++++ +*** New variable 'window-restore-killed-buffer-windows'. +It specifies how 'set-window-configuration' and 'window-state-put' +should proceed with windows whose buffer was killed after the +corresponding configuration or state was made. + ** Tab Bars and Tab Lines --- diff --git a/lisp/window.el b/lisp/window.el index 29336f573f8..246708dbd56 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -6286,7 +6286,8 @@ value can be also stored on disk and read back in a new session." (when state (let* ((old-buffer-or-name (car state)) (buffer (get-buffer old-buffer-or-name)) - (state (cdr state))) + (state (cdr state)) + (dedicated (cdr (assq 'dedicated state)))) (if (buffer-live-p buffer) (with-current-buffer buffer (set-window-buffer window buffer) @@ -6345,7 +6346,7 @@ value can be also stored on disk and read back in a new session." window delta t ignore nil nil nil pixelwise)) (window-resize window delta t ignore pixelwise)))) ;; Set dedicated status. - (set-window-dedicated-p window (cdr (assq 'dedicated state))) + (set-window-dedicated-p window dedicated) ;; Install positions (maybe we should do this after all ;; windows have been created and sized). (ignore-errors @@ -6388,12 +6389,12 @@ value can be also stored on disk and read back in a new session." (set-marker (make-marker) m2 buffer)))))) prev-buffers)))) - ;; We don't want to raise an error in case the buffer does - ;; not exist anymore, so we switch to a previous one and - ;; save the window with the intention of deleting it later - ;; if possible. - (switch-to-prev-buffer window) - (if window-kept-windows-functions + (unless (window-minibuffer-p window) + ;; Preferably show a buffer previously shown in this + ;; window. + (switch-to-prev-buffer window) + (cond + ((functionp window-restore-killed-buffer-windows) (let* ((start (cdr (assq 'start state))) ;; Handle both - marker positions from writable ;; states and markers from non-writable states. @@ -6404,9 +6405,15 @@ value can be also stored on disk and read back in a new session." (point-pos (if (markerp point) (marker-last-position point) point))) - (push (list window old-buffer-or-name start-pos point-pos) - window-state-put-kept-windows)) - (push window window-state-put-stale-windows)))))))) + (push (list window old-buffer-or-name + start-pos point-pos dedicated nil) + window-state-put-kept-windows))) + ((or (and dedicated + (eq window-restore-killed-buffer-windows 'dedicated)) + (memq window-restore-killed-buffer-windows '(nil delete))) + ;; Try to delete the window. + (push window window-state-put-stale-windows))) + (set-window-dedicated-p window nil)))))))) (defun window-state-put (state &optional window ignore) "Put window state STATE into WINDOW. @@ -6421,16 +6428,9 @@ sizes and fixed size restrictions. IGNORE equal `safe' means windows can get as small as `window-safe-min-height' and `window-safe-min-width'. -If the abnormal hook `window-kept-windows-functions' is non-nil, -do not delete any windows saved by STATE whose buffers were -deleted since STATE was saved. Rather, show some live buffer in -them and call the functions in `window-kept-windows-functions' -with a list of two arguments: the frame where STATE was put and a -list of entries for each such window. Each entry contains four -elements - the window, its old buffer and the last positions of -`window-start' and `window-point' for the buffer in that window. -Always check the window for liveness because another function run -by this hook may have deleted it." +If this function tries to restore a non-minibuffer window whose buffer +was killed since STATE was made, it will consult the variable +`window-restore-killed-buffer-windows' on how to proceed." (setq window-state-put-stale-windows nil) (setq window-state-put-kept-windows nil) @@ -6544,10 +6544,9 @@ by this hook may have deleted it." (when (and (window-valid-p window) (eq (window-deletable-p window) t)) (delete-window window)))) - (when window-kept-windows-functions - (run-hook-with-args - 'window-kept-windows-functions - frame window-state-put-kept-windows) + (when (functionp window-restore-killed-buffer-windows) + (funcall window-restore-killed-buffer-windows + frame window-state-put-kept-windows 'state) (setq window-state-put-kept-windows nil)) (window--check frame)))) diff --git a/src/buffer.c b/src/buffer.c index 43a9249528c..07d19dfc078 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -327,6 +327,11 @@ bset_name (struct buffer *b, Lisp_Object val) b->name_ = val; } static void +bset_last_name (struct buffer *b, Lisp_Object val) +{ + b->last_name_ = val; +} +static void bset_overwrite_mode (struct buffer *b, Lisp_Object val) { b->overwrite_mode_ = val; @@ -647,6 +652,7 @@ even if it is dead. The return value is never nil. */) name = Fcopy_sequence (buffer_or_name); set_string_intervals (name, NULL); bset_name (b, name); + bset_last_name (b, name); b->inhibit_buffer_hooks = !NILP (inhibit_buffer_hooks); bset_undo_list (b, SREF (name, 0) != ' ' ? Qnil : Qt); @@ -866,6 +872,7 @@ Interactively, CLONE and INHIBIT-BUFFER-HOOKS are nil. */) name = Fcopy_sequence (name); set_string_intervals (name, NULL); bset_name (b, name); + bset_last_name (b, name); /* An indirect buffer shares undo list of its base (Bug#18180). */ bset_undo_list (b, BVAR (b->base_buffer, undo_list)); @@ -1282,6 +1289,17 @@ Return nil if BUFFER has been killed. */) return BVAR (decode_buffer (buffer), name); } +DEFUN ("buffer-last-name", Fbuffer_last_name, Sbuffer_last_name, 0, 1, 0, + doc: /* Return last name of BUFFER, as a string. +BUFFER defaults to the current buffer. + +This is the name BUFFER had before the last time it was renamed or +immediately before it was killed. */) + (Lisp_Object buffer) +{ + return BVAR (decode_buffer (buffer), last_name); +} + DEFUN ("buffer-file-name", Fbuffer_file_name, Sbuffer_file_name, 0, 1, 0, doc: /* Return name of file BUFFER is visiting, or nil if none. No argument or nil as argument means use the current buffer. */) @@ -1652,6 +1670,7 @@ This does not change the name of the visited file (if any). */) (register Lisp_Object newname, Lisp_Object unique) { register Lisp_Object tem, buf; + Lisp_Object oldname = BVAR (current_buffer, name); Lisp_Object requestedname = newname; CHECK_STRING (newname); @@ -1669,12 +1688,12 @@ This does not change the name of the visited file (if any). */) if (NILP (unique) && XBUFFER (tem) == current_buffer) return BVAR (current_buffer, name); if (!NILP (unique)) - newname = Fgenerate_new_buffer_name (newname, - BVAR (current_buffer, name)); + newname = Fgenerate_new_buffer_name (newname, oldname); else error ("Buffer name `%s' is in use", SDATA (newname)); } + bset_last_name (current_buffer, oldname); bset_name (current_buffer, newname); /* Catch redisplay's attention. Unless we do this, the mode lines for @@ -2095,6 +2114,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) This gets rid of them for certain. */ reset_buffer_local_variables (b, 1); + bset_last_name (b, BVAR (b, name)); bset_name (b, Qnil); block_input (); @@ -4666,6 +4686,7 @@ init_buffer_once (void) /* These used to be stuck at 0 by default, but now that the all-zero value means Qnil, we have to initialize them explicitly. */ bset_name (&buffer_local_flags, make_fixnum (0)); + bset_last_name (&buffer_local_flags, make_fixnum (0)); bset_mark (&buffer_local_flags, make_fixnum (0)); bset_local_var_alist (&buffer_local_flags, make_fixnum (0)); bset_keymap (&buffer_local_flags, make_fixnum (0)); @@ -6026,6 +6047,7 @@ There is no reason to change that value except for debugging purposes. */); defsubr (&Smake_indirect_buffer); defsubr (&Sgenerate_new_buffer_name); defsubr (&Sbuffer_name); + defsubr (&Sbuffer_last_name); defsubr (&Sbuffer_file_name); defsubr (&Sbuffer_base_buffer); defsubr (&Sbuffer_local_value); diff --git a/src/buffer.h b/src/buffer.h index 87ba2802b39..bbe1aeff668 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -309,6 +309,9 @@ struct buffer /* The name of this buffer. */ Lisp_Object name_; + /* The last name of this buffer before it was renamed or killed. */ + Lisp_Object last_name_; + /* The name of the file visited in this buffer, or nil. */ Lisp_Object filename_; diff --git a/src/window.c b/src/window.c index ea761fad8bc..928c4ae02a8 100644 --- a/src/window.c +++ b/src/window.c @@ -7109,23 +7109,9 @@ current at the start of the function. If DONT-SET-MINIWINDOW is non-nil, the mini-window of the frame doesn't get set to the corresponding element of CONFIGURATION. -Normally, this function will try to delete any dead window in -CONFIGURATION whose buffer has been deleted since CONFIGURATION was -made. However, if the abnormal hook `window-kept-windows-functions' is -non-nil, it will preserve such a window in the restored layout and show -another buffer in it. - -After restoring the frame layout, this function runs the abnormal hook -`window-kept-windows-functions' with two arguments - the frame whose -layout it has restored and a list of entries for each window whose -buffer has been found dead when it tried to restore CONFIGURATION: Each -entry is a list of four elements where -`window' denotes the window whose buffer was found dead, `buffer' -denotes the dead buffer, and `start' and `point' denote the last known -positions of `window-start' and `window-point' of the buffer in that -window. Any function run by this hook should check such a window for -liveness because another function run by this hook may have deleted it -in the meantime." +This function consults the variable `window-restore-killed-buffer-windows' +when restoring a window whose buffer was killed after CONFIGURATION was +recorded. If CONFIGURATION was made from a frame that is now deleted, only frame-independent values can be restored. In this case, @@ -7378,10 +7364,12 @@ the return value is nil. Otherwise the value is t. */) BUF_PT (XBUFFER (w->contents)), BUF_PT_BYTE (XBUFFER (w->contents))); w->start_at_line_beg = true; - if (!NILP (Vwindow_kept_windows_functions)) - kept_windows = Fcons (list4 (window, p->buffer, + if (FUNCTIONP (window_restore_killed_buffer_windows) + && !MINI_WINDOW_P (w)) + kept_windows = Fcons (listn (6, window, p->buffer, Fmarker_last_position (p->start), - Fmarker_last_position (p->pointm)), + Fmarker_last_position (p->pointm), + p->dedicated, Qt), kept_windows); } else if (!NILP (w->start)) @@ -7398,16 +7386,25 @@ the return value is nil. Otherwise the value is t. */) set_marker_restricted_both (w->pointm, w->contents, 0, 0); set_marker_restricted_both (w->old_pointm, w->contents, 0, 0); w->start_at_line_beg = true; - if (!NILP (w->dedicated)) - /* Record this window as dead. */ - dead_windows = Fcons (window, dead_windows); - /* Make sure window is no more dedicated. */ - wset_dedicated (w, Qnil); - if (!NILP (Vwindow_kept_windows_functions)) - kept_windows = Fcons (list4 (window, p->buffer, - Fmarker_last_position (p->start), - Fmarker_last_position (p->pointm)), - kept_windows); + if (!MINI_WINDOW_P (w)) + { + if (FUNCTIONP (window_restore_killed_buffer_windows)) + kept_windows + = Fcons (listn (6, window, p->buffer, + Fmarker_last_position (p->start), + Fmarker_last_position (p->pointm), + p->dedicated, Qnil), + kept_windows); + else if (EQ (window_restore_killed_buffer_windows, Qdelete) + || (!NILP (p->dedicated) + && (NILP (window_restore_killed_buffer_windows) + || EQ (window_restore_killed_buffer_windows, + Qdedicated)))) + /* Try to delete this window later. */ + dead_windows = Fcons (window, dead_windows); + /* Make sure window is no more dedicated. */ + wset_dedicated (w, Qnil); + } } } @@ -7459,13 +7456,12 @@ the return value is nil. Otherwise the value is t. */) unblock_input (); /* Scan dead buffer windows. */ - if (!NILP (Vwindow_kept_windows_functions)) - for (; CONSP (dead_windows); dead_windows = XCDR (dead_windows)) - { - window = XCAR (dead_windows); - if (WINDOW_LIVE_P (window) && !EQ (window, FRAME_ROOT_WINDOW (f))) - delete_deletable_window (window); - } + for (; CONSP (dead_windows); dead_windows = XCDR (dead_windows)) + { + window = XCAR (dead_windows); + if (WINDOW_LIVE_P (window) && !EQ (window, FRAME_ROOT_WINDOW (f))) + delete_deletable_window (window); + } /* Record the selected window's buffer here. The window should already be the selected one from the call above. */ @@ -7513,9 +7509,9 @@ the return value is nil. Otherwise the value is t. */) SAFE_FREE (); - if (!NILP (Vrun_hooks) && !NILP (Vwindow_kept_windows_functions)) - run_hook_with_args_2 (Qwindow_kept_windows_functions, frame, - kept_windows); + if (!NILP (Vrun_hooks) && FUNCTIONP (window_restore_killed_buffer_windows)) + safe_calln (window_restore_killed_buffer_windows, + frame, kept_windows, Qconfiguration); return FRAME_LIVE_P (f) ? Qt : Qnil; } @@ -8514,8 +8510,9 @@ syms_of_window (void) DEFSYM (Qheader_line_format, "header-line-format"); DEFSYM (Qtab_line_format, "tab-line-format"); DEFSYM (Qno_other_window, "no-other-window"); - DEFSYM (Qwindow_kept_windows_functions, - "window-kept-windows-functions"); + DEFSYM (Qconfiguration, "configuration"); + DEFSYM (Qdelete, "delete"); + DEFSYM (Qdedicated, "dedicated"); DEFVAR_LISP ("temp-buffer-show-function", Vtemp_buffer_show_function, doc: /* Non-nil means call as function to display a help buffer. @@ -8673,27 +8670,59 @@ its buffer or its total or body size since the last redisplay. Each call is performed with the frame temporarily selected. */); Vwindow_configuration_change_hook = Qnil; - DEFVAR_LISP ("window-kept-windows-functions", - Vwindow_kept_windows_functions, - doc: /* Functions run after restoring a window configuration or state. -These functions are called by `set-window-configuration' and -`window-state-put'. When the value of this variable is non-nil, these -functions restore any window whose buffer has been deleted since the -corresponding configuration or state was saved. Rather than deleting -such a window, `set-window-configuration' and `window-state-put' show -some live buffer in it. + DEFVAR_LISP ("window-restore-killed-buffer-windows", + window_restore_killed_buffer_windows, + doc: /* Control restoring windows whose buffer was killed. +This variable specifies how the functions `set-window-configuration' and +`window-state-put' shall handle a window whose buffer has been killed +since the corresponding configuration or state was made. Any such +window may be live - in which case it shows some other buffer - or dead +at the time one of these functions is called. -The value should be a list of functions that take two arguments. The -first argument specifies the frame whose configuration has been -restored. The second argument, if non-nil, specifies a list of entries -for each window whose buffer has been found dead at the time -'set-window-configuration' or `window-state-put' tried to restore it in -that window. Each entry is a list of four values - the window whose -buffer was found dead, the dead buffer, and the positions of start and -point of the buffer in that window. Note that the window may be already -dead since another function on this list may have deleted it in the -meantime. */); - Vwindow_kept_windows_functions = Qnil; +As a rule, `set-window-configuration' leaves the window alone if it is +live while `window-state-put' deletes it. The following values can be +used to override the default behavior for dead windows in the case of +`set-window-configuration' and for dead and live windows in the case of +`window-state-put'. + +- t means to restore the window and show some other buffer in it. + +- `delete' means to try to delete the window. + +- `dedicated' means to try to delete the window if and only if it is + dedicated to its buffer. + +- nil, the default, means that `set-window-configuration' will try to + delete the window if and only if it is dedicated to its buffer while + `window-state-put' will unconditionally try to delete it. + +- a function means to restore the window, show some other buffer in it + and add an entry for that window to a list that will be later passed + as argument to that function. + +If a window cannot be deleted (typically, because it is the last window +on its frame), show another buffer in it. + +If the value is a function, it should take three arguments. The first +argument specifies the frame whose windows have been restored. The +third argument is the constant `configuration' if the windows are +restored by `set-window-configuration' and the constant `state' if the +windows are restored by `window-state-put'. + +The second argument specifies a list of entries for @emph{any} window +whose previous buffer has been encountered dead at the time +`set-window-configuration' or `window-state-put' tried to restore it in +that window (minibuffer windows are excluded). This means that the +function specified by this variable may also delete windows encountered +live by `set-window-configuration'. + +Each entry is a list of six values - the window whose buffer was found +dead, the dead buffer or its name, the positions of start and point of +the buffer in that window, the dedicated status of the window as +reported by `window-dedicated-p' and a boolean - t if the window was +live when `set-window-configuration' tried to restore it and nil +otherwise. */); + window_restore_killed_buffer_windows = Qnil; DEFVAR_LISP ("recenter-redisplay", Vrecenter_redisplay, doc: /* Non-nil means `recenter' redraws entire frame. From 3858e4f22946dc49d2d3dde5f45a65eab83fd7aa Mon Sep 17 00:00:00 2001 From: Martin Rudalics Date: Fri, 15 Mar 2024 11:53:31 +0100 Subject: [PATCH 048/155] Fix bug with CHECK_STRUCTS introduced by last buffer.h change * src/pdumper.c (dump_buffer): Fix HASH_buffer_. Assign last_name_ field. --- src/pdumper.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/pdumper.c b/src/pdumper.c index f0bce09cbde..c7ebb38dea5 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2796,7 +2796,7 @@ dump_obarray (struct dump_context *ctx, Lisp_Object object) static dump_off dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) { -#if CHECK_STRUCTS && !defined HASH_buffer_EBBA38AEFA +#if CHECK_STRUCTS && !defined HASH_buffer_B02F648B82 # error "buffer changed. See CHECK_STRUCTS comment in config.h." #endif struct buffer munged_buffer = *in_buffer; @@ -2808,6 +2808,7 @@ dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) else eassert (buffer->window_count == -1); buffer->local_minor_modes_ = Qnil; + buffer->last_name_ = Qnil; buffer->last_selected_window_ = Qnil; buffer->display_count_ = make_fixnum (0); buffer->clip_changed = 0; From ed48b0d657cbf183a3e391a95672f921688e6ba8 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 15 Mar 2024 13:29:31 +0200 Subject: [PATCH 049/155] ; * CONTRIBUTE: Ask not to use non-ASCII unless necessary. --- CONTRIBUTE | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CONTRIBUTE b/CONTRIBUTE index cdb47911d76..af5519c1bb3 100644 --- a/CONTRIBUTE +++ b/CONTRIBUTE @@ -237,6 +237,8 @@ formatting them: particular, gnu.org and fsf.org URLs should start with "https:". - Commit messages should contain only printable UTF-8 characters. + However, we ask that non-ASCII characters be used only if strictly + necessary, not just for aesthetic purposes. - Commit messages should not contain the "Signed-off-by:" lines that are used in some other projects. From bf3d296d24ea24fb707a9410fccd745523347d2a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 15 Mar 2024 14:22:14 +0200 Subject: [PATCH 050/155] ; Fix documentation of a recent change (bug#68235) * etc/NEWS: * doc/lispref/windows.texi (Window Configurations): Improve wording of 'window-restore-killed-buffer-windows's doc. * src/window.c (syms_of_window) : Doc fix. * etc/NEWS: * doc/lispref/buffers.texi (Buffer Names): Document 'buffer-last-name'. --- doc/lispref/buffers.texi | 6 +++++ doc/lispref/windows.texi | 37 +++++++++++++++------------- etc/NEWS | 6 ++++- src/window.c | 52 +++++++++++++++++++++------------------- 4 files changed, 58 insertions(+), 43 deletions(-) diff --git a/doc/lispref/buffers.texi b/doc/lispref/buffers.texi index 77f5f09c7bd..5375eb64155 100644 --- a/doc/lispref/buffers.texi +++ b/doc/lispref/buffers.texi @@ -371,6 +371,12 @@ See the related function @code{generate-new-buffer} in @ref{Creating Buffers}. @end defun +@defun buffer-last-name &optional buffer +This function returns the previous name of @var{buffer}, before it was +killed or before the last time it was renamed. If nil or omitted, +@var{buffer} defaults to the current buffer. +@end defun + @node Buffer File Name @section Buffer File Name @cindex visited file diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 45d67ba4946..8fa4e57b153 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -6376,8 +6376,8 @@ fine-tune that behavior. @defvar window-restore-killed-buffer-windows This variable specifies how @code{set-window-configuration} and @code{window-state-put} shall handle a window whose buffer has been -killed since the corresponding configuration or state was made. Any -such window may be live - in which case it shows some other buffer - or +killed since the corresponding configuration or state was recorded. Any +such window may be live---in which case it shows some other buffer---or dead at the time one of these functions is called. Usually, @code{set-window-configuration} leaves the window alone if it is live while @code{window-state-put} deletes it. @@ -6399,14 +6399,15 @@ This means to try to delete the window if and only if it is dedicated to its buffer. @item @code{nil} -This is the default and means that @code{set-window-configuration} will -try to delete the window if and only if it is dedicated to its buffer -and @code{window-state-put} will unconditionally try to delete it. +This is the default, and it means that @code{set-window-configuration} +will try to delete the window if and only if it is dedicated to its +buffer, and @code{window-state-put} will unconditionally try to delete +it. @item a function -This means to restore the window, show some other buffer in it and add -an entry for that window to a list that will be later passed as argument -to that function. +This means to restore the window and show some other buffer in it, like +if the value is @code{t}, and also add an entry for that window to a +list that will be later passed as the second argument to that function. @end table If a window cannot be deleted (typically, because it is the last window @@ -6417,21 +6418,23 @@ If the value of this variable is a function, that function should take three arguments. The first argument specifies the frame whose windows have been restored. The third argument is either the constant @code{configuration} if the windows are restored by -@code{set-window-configuration} or the constant @code{state} if the +@code{set-window-configuration}, or the constant @code{state} if the windows are restored by @code{window-state-put}. -The second argument specifies a list of entries for @emph{any} window -whose previous buffer has been encountered dead at the time +The second argument specifies a list of entries for @emph{all} windows +whose previous buffers have been found dead at the time @code{set-window-configuration} or @code{window-state-put} tried to restore it in that window (minibuffer windows are excluded). This means -that the function specified by this variable may also delete windows -encountered live by @code{set-window-configuration}. +that the function may also delete windows which were found live by +@code{set-window-configuration}. -Each entry is a list of six values - the window whose buffer was found -dead, the dead buffer or its name, the positions of start and point of -the buffer in that window, the dedicated status of the window as +Each entry in the list that is passed as the second argument to the +function is itself a list of six values: the window whose buffer was +found dead, the dead buffer or its name, the positions of window-start +(@pxref{Window Start and End}) and window-point (@pxref{Window Point}) +of the buffer in that window, the dedicated state of the window as previously reported by @code{window-dedicated-p} and a flag that is -@code{t} if the window has been encountered live by +@code{t} if the window has been found to be alive by @code{set-window-configuration} and @code{nil} otherwise. @end defvar diff --git a/etc/NEWS b/etc/NEWS index dfbf6edb098..a654d2d8d79 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -287,7 +287,7 @@ selected or deselected at the end of executing the current command. *** New variable 'window-restore-killed-buffer-windows'. It specifies how 'set-window-configuration' and 'window-state-put' should proceed with windows whose buffer was killed after the -corresponding configuration or state was made. +corresponding configuration or state was recorded. ** Tab Bars and Tab Lines @@ -1812,6 +1812,10 @@ styles to skip eager fontification of completion candidates, which improves performance. Such a Lisp program can then use the 'completion-lazy-hilit' function to fontify candidates just in time. +** New primitive 'buffer-last-name'. +It returns the name of a buffer before the last time it was renamed or +killed. + ** Functions and variables to transpose sexps +++ diff --git a/src/window.c b/src/window.c index 928c4ae02a8..2c002418605 100644 --- a/src/window.c +++ b/src/window.c @@ -8675,30 +8675,32 @@ call is performed with the frame temporarily selected. */); doc: /* Control restoring windows whose buffer was killed. This variable specifies how the functions `set-window-configuration' and `window-state-put' shall handle a window whose buffer has been killed -since the corresponding configuration or state was made. Any such -window may be live - in which case it shows some other buffer - or dead -at the time one of these functions is called. +since the corresponding configuration or state was recorded. Any such +window may be live -- in which case it shows some other buffer -- or +dead at the time one of these functions is called. -As a rule, `set-window-configuration' leaves the window alone if it is -live while `window-state-put' deletes it. The following values can be +By default, `set-window-configuration' leaves the window alone if it is +live, while `window-state-put' deletes it. The following values can be used to override the default behavior for dead windows in the case of `set-window-configuration' and for dead and live windows in the case of `window-state-put'. -- t means to restore the window and show some other buffer in it. + - t means to restore the window and show some other buffer in it. -- `delete' means to try to delete the window. + - `delete' means to try to delete the window. -- `dedicated' means to try to delete the window if and only if it is - dedicated to its buffer. + - `dedicated' means to try to delete the window if and only if it is + dedicated to its buffer. -- nil, the default, means that `set-window-configuration' will try to - delete the window if and only if it is dedicated to its buffer while - `window-state-put' will unconditionally try to delete it. + - nil, the default, which means that `set-window-configuration' will + try to delete the window if and only if it is dedicated to its + buffer while `window-state-put' will unconditionally try to delete + it. -- a function means to restore the window, show some other buffer in it - and add an entry for that window to a list that will be later passed - as argument to that function. + - a function means to restore the window and show some other buffer in + it, like if the value were t, but also to add an entry for that + window to a list that will be later passed as argument to that + function. If a window cannot be deleted (typically, because it is the last window on its frame), show another buffer in it. @@ -8709,19 +8711,19 @@ third argument is the constant `configuration' if the windows are restored by `set-window-configuration' and the constant `state' if the windows are restored by `window-state-put'. -The second argument specifies a list of entries for @emph{any} window -whose previous buffer has been encountered dead at the time +The second argument specifies a list of entries for all windows +whose previous buffers have been found dead at the time `set-window-configuration' or `window-state-put' tried to restore it in that window (minibuffer windows are excluded). This means that the -function specified by this variable may also delete windows encountered -live by `set-window-configuration'. +function specified by this variable may also delete windows which were +found to be alive by `set-window-configuration'. -Each entry is a list of six values - the window whose buffer was found -dead, the dead buffer or its name, the positions of start and point of -the buffer in that window, the dedicated status of the window as -reported by `window-dedicated-p' and a boolean - t if the window was -live when `set-window-configuration' tried to restore it and nil -otherwise. */); +Each entry is a list of six values: the window whose buffer was found +dead, the dead buffer or its name, the positions of window-start and +window-point of the buffer in that window, the dedicated state of the +window as reported by `window-dedicated-p', and a boolean -- t if the +window was live when `set-window-configuration' tried to restore it, +and nil otherwise. */); window_restore_killed_buffer_windows = Qnil; DEFVAR_LISP ("recenter-redisplay", Vrecenter_redisplay, From c393c0467972cba9dc7ed256acd72b553204c33a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 15 Mar 2024 12:32:06 +0100 Subject: [PATCH 051/155] * lisp/emacs-lisp/advice.el (comp-subr-trampoline-install): Don't declare. --- lisp/emacs-lisp/advice.el | 2 -- 1 file changed, 2 deletions(-) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 9489a9fd1b3..752660156b9 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2042,8 +2042,6 @@ in that CLASS." function class name))) (error "ad-remove-advice: `%s' is not advised" function))) -(declare-function comp-subr-trampoline-install "comp-run") - ;;;###autoload (defun ad-add-advice (function advice class position) "Add a piece of ADVICE to FUNCTION's list of advices in CLASS. From 005536285585bcdf5a67a01cdfd8e1242742f953 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 15 Mar 2024 14:18:51 +0100 Subject: [PATCH 052/155] * Don't install unnecessary trampolines (bug#69573) * lisp/emacs-lisp/comp-run.el (comp-subr-trampoline-install): Check that subr-name actually matches the target subr. --- lisp/emacs-lisp/comp-run.el | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 057760322ab..afb46e3cd19 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -364,13 +364,15 @@ Return the trampoline if found or nil otherwise." (when (memq subr-name comp-warn-primitives) (warn "Redefining `%s' might break native compilation of trampolines." subr-name)) - (unless (or (null native-comp-enable-subr-trampolines) - (memq subr-name native-comp-never-optimize-functions) - (gethash subr-name comp-installed-trampolines-h)) - (cl-assert (subr-primitive-p (symbol-function subr-name))) - (when-let ((trampoline (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) - (comp--install-trampoline subr-name trampoline)))) + (let ((subr (symbol-function subr-name))) + (unless (or (not (string= subr-name (subr-name subr))) ;; (bug#69573) + (null native-comp-enable-subr-trampolines) + (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)))) + (comp--install-trampoline subr-name trampoline))))) ;;;###autoload (defun native--compile-async (files &optional recursively load selector) From 7231a89524f280c51278c3c74c6ae2215a307f0f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 15 Mar 2024 12:45:09 -0400 Subject: [PATCH 053/155] * lisp/emacs-lisp/bindat.el (sint): Burp in dynbind (bug#69749) --- lisp/emacs-lisp/bindat.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index ef0ec688dbd..42ba89ba2c1 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -944,9 +944,13 @@ a bindat type expression." (bindat-defmacro sint (bitlen le) "Signed integer of size BITLEN. Big-endian if LE is nil and little-endian if not." + (unless lexical-binding + (error "The `sint' type requires 'lexical-binding'")) (let ((bl (make-symbol "bitlen")) (max (make-symbol "max")) (wrap (make-symbol "wrap"))) + ;; FIXME: This `let*' around the `struct' results in code which the + ;; byte-compiler does not handle efficiently. 🙁 `(let* ((,bl ,bitlen) (,max (ash 1 (1- ,bl))) (,wrap (+ ,max ,max))) From 3b791ebbe173fa18515558acaafbef1f88c51791 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 16 Mar 2024 00:19:43 +0100 Subject: [PATCH 054/155] ; Fix 'usage:' keyword in Ffile_name_concat doc. --- src/fileio.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fileio.c b/src/fileio.c index a2e230879c3..a5d29d81fb7 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -759,7 +759,7 @@ Elements in COMPONENTS must be a string or nil. DIRECTORY or the non-final elements in COMPONENTS may or may not end with a slash -- if they don't end with a slash, a slash will be inserted before concatenating. -usage: (record DIRECTORY &rest COMPONENTS) */) +usage: (file-name-concat DIRECTORY &rest COMPONENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { ptrdiff_t chars = 0, bytes = 0, multibytes = 0, eargs = 0; From 983d17309911b84199e43a83d841cf7caff47316 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 16 Mar 2024 00:23:41 +0100 Subject: [PATCH 055/155] ; * src/eval.c (Fhandler_bind_1): Fix docstring. --- src/eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/eval.c b/src/eval.c index 95eb21909d2..f48d7b0682f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1374,8 +1374,8 @@ push_handler_bind (Lisp_Object conditions, Lisp_Object handler, int skip) } DEFUN ("handler-bind-1", Fhandler_bind_1, Shandler_bind_1, 1, MANY, 0, - doc: /* Setup error handlers around execution of BODYFUN. -BODYFUN be a function and it is called with no arguments. + doc: /* Set up error handlers around execution of BODYFUN. +BODYFUN should be a function and it is called with no arguments. CONDITIONS should be a list of condition names (symbols). When an error is signaled during execution of BODYFUN, if that error matches one of CONDITIONS, then the associated HANDLER is From bbbf1e6f2d5c93e51e62c33529d3098b1ee46616 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 16 Mar 2024 09:29:42 +0800 Subject: [PATCH 056/155] Fix calc.texi for Texinfo 4.13 * doc/misc/calc.texi (Fractions): Replace instances of @U with raw Unicode characters and adjust the document encoding suitably. --- doc/misc/calc.texi | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi index dacf1451cc2..ac2ac5a0f91 100644 --- a/doc/misc/calc.texi +++ b/doc/misc/calc.texi @@ -6,6 +6,7 @@ @settitle GNU Emacs Calc Manual @include docstyle.texi @setchapternewpage odd +@documentencoding UTF-8 @comment %**end of header (This is for running Texinfo on a region.) @include emacsver.texi @@ -10572,12 +10573,11 @@ Non-decimal fractions are entered and displayed as form). The numerator and denominator always use the same radix. @ifnottex -Fractions may also be entered with @kbd{@U{2044}} (U+2044 FRACTION -SLASH) in place of any @kbd{:}. Precomposed fraction characters from -@kbd{@U{00BD}} (U+00BD VULGAR FRACTION ONE HALF) through -@kbd{@U{215E}} (U+215E VULGAR FRACTION SEVEN EIGHTHS) are supported as -well. Thus, @samp{2:3}, @samp{2@U{2044}3}, and @samp{@U{2154}} are all -equivalent. +Fractions may also be entered with @kbd{⁄} (U+2044 FRACTION SLASH) in +place of any @kbd{:}. Precomposed fraction characters from @kbd{½} +(U+00BD VULGAR FRACTION ONE HALF) through @kbd{⅞} (U+215E VULGAR +FRACTION SEVEN EIGHTHS) are supported as well. Thus, @samp{2:3}, +@samp{2⁄3}, and @samp{⅞} are all equivalent. @end ifnottex @iftex Fractions may also be entered with U+2044 FRACTION SLASH in place of From 6461854f47d0b768e0550b46317045811a8cbe80 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 16 Mar 2024 09:50:58 +0800 Subject: [PATCH 057/155] ; Circumvent miscompilations on Sun C 5.12 (148917-07) * src/minibuf.c (Ftry_completion, Fall_completions): Transform ternary expressions after open-ended if statements into proper if/else statements. --- src/minibuf.c | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/src/minibuf.c b/src/minibuf.c index df6ca7ce1d8..51816133fb2 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1701,11 +1701,12 @@ or from one of the possible completions. */) tem = Fcommandp (elt, Qnil); else { - tem = (type == hash_table - ? call2 (predicate, elt, - HASH_VALUE (XHASH_TABLE (collection), - idx - 1)) - : call1 (predicate, elt)); + if (type == hash_table) + tem = call2 (predicate, elt, + HASH_VALUE (XHASH_TABLE (collection), + idx - 1)); + else + tem = call1 (predicate, elt); } if (NILP (tem)) continue; } @@ -1845,9 +1846,12 @@ with a space are ignored unless STRING itself starts with a space. */) Lisp_Object allmatches; if (VECTORP (collection)) collection = check_obarray (collection); - int type = HASH_TABLE_P (collection) ? 3 - : OBARRAYP (collection) ? 2 - : NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection)); + int type = (HASH_TABLE_P (collection) + ? 3 : (OBARRAYP (collection) + ? 2 : ((NILP (collection) + || (CONSP (collection) + && !FUNCTIONP (collection))) + ? 1 : 0))); ptrdiff_t idx = 0; Lisp_Object bucket, tem, zero; @@ -1931,10 +1935,12 @@ with a space are ignored unless STRING itself starts with a space. */) tem = Fcommandp (elt, Qnil); else { - tem = type == 3 - ? call2 (predicate, elt, - HASH_VALUE (XHASH_TABLE (collection), idx - 1)) - : call1 (predicate, elt); + if (type == 3) + tem = call2 (predicate, elt, + HASH_VALUE (XHASH_TABLE (collection), + idx - 1)); + else + tem = call1 (predicate, elt); } if (NILP (tem)) continue; } From c77e35efd36f2c43e87066faa4257606d5c6f849 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 16 Mar 2024 09:55:23 +0800 Subject: [PATCH 058/155] * doc/lispref/frames.texi (Window System Selections): Fix misuse of xref. --- doc/lispref/frames.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 16c0432da3a..cf7fc7721c5 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -4052,8 +4052,8 @@ programs. It takes two optional arguments, @var{type} and The @var{data-type} argument specifies the form of data conversion to use, to convert the raw data obtained from another program into Lisp -data. @xref{X Selections}, for an enumeration of data types valid -under X, and @xref{Other Selections} for those elsewhere. +data. @xref{X Selections}, for an enumeration of data types valid under +X, and @pxref{Other Selections} for those elsewhere. @end defun @defopt selection-coding-system From 4d03f70b7f01477a8d72f827ba8b0dabba8c0a61 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 16 Mar 2024 15:12:33 +0800 Subject: [PATCH 059/155] Correct doc strings for x-*-keysym * src/xterm.c (syms_of_xterm): Clarify whether x-*-keysym affects the modifier key reported for a keysym or the other way around. --- src/xterm.c | 42 ++++++++++++++++++++++-------------------- 1 file changed, 22 insertions(+), 20 deletions(-) diff --git a/src/xterm.c b/src/xterm.c index c8a43785564..bebc30c9103 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -32536,38 +32536,40 @@ Android does not support scroll bars at all. */); DEFSYM (Qreally_fast, "really-fast"); DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, - doc: /* Which keys Emacs uses for the ctrl modifier. -This should be one of the symbols `ctrl', `alt', `hyper', `meta', -`super'. For example, `ctrl' means use the Ctrl_L and Ctrl_R keysyms. -The default is nil, which is the same as `ctrl'. */); + doc: /* Which modifer value Emacs reports when Ctrl is depressed. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', or +`super', representing a modifier to be reported in key events with the +Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed. */); Vx_ctrl_keysym = Qnil; DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym, - doc: /* Which keys Emacs uses for the alt modifier. -This should be one of the symbols `ctrl', `alt', `hyper', `meta', -`super'. For example, `alt' means use the Alt_L and Alt_R keysyms. -The default is nil, which is the same as `alt'. */); + doc: /* Which modifer value Emacs reports when Alt is depressed. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', or +`super', representing a modifier to be reported in key events with the +Alt modifier (e.g. the keysym Alt_L or Alt_R, if the keyboard features a +dedicated key for Meta) depressed. */); Vx_alt_keysym = Qnil; DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym, - doc: /* Which keys Emacs uses for the hyper modifier. -This should be one of the symbols `ctrl', `alt', `hyper', `meta', -`super'. For example, `hyper' means use the Hyper_L and Hyper_R -keysyms. The default is nil, which is the same as `hyper'. */); + doc: /* Which modifer value Emacs reports when Hyper is depressed. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', or +`super', representing a modifier to be reported in key events with the +Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed. */); Vx_hyper_keysym = Qnil; DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym, - doc: /* Which keys Emacs uses for the meta modifier. -This should be one of the symbols `ctrl', `alt', `hyper', `meta', -`super'. For example, `meta' means use the Meta_L and Meta_R keysyms. -The default is nil, which is the same as `meta'. */); + doc: /* Which modifer value Emacs reports when Meta is depressed. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', or +`super', representing a modifier to be reported in key events with the +Meta modifier (e.g. the keysym Alt_L or Alt_R, when the keyboard does +not feature a dedicated key for Meta) depressed. */); Vx_meta_keysym = Qnil; DEFVAR_LISP ("x-super-keysym", Vx_super_keysym, - doc: /* Which keys Emacs uses for the super modifier. -This should be one of the symbols `ctrl', `alt', `hyper', `meta', -`super'. For example, `super' means use the Super_L and Super_R -keysyms. The default is nil, which is the same as `super'. */); + doc: /* Which modifer value Emacs reports when Super is depressed. +This should be one of the symbols `ctrl', `alt', `hyper', `meta', or +`super', representing a modifier to be reported in key events with the +Super modifier (i.e. the keysym Super_L or Super_R) depressed. */); Vx_super_keysym = Qnil; DEFVAR_LISP ("x-wait-for-event-timeout", Vx_wait_for_event_timeout, From 658529921614b8d5498c267a7ffc786c25d2d26f Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 16 Mar 2024 15:13:09 +0800 Subject: [PATCH 060/155] Support x-*-keysym on Android * src/androidterm.c (android_android_to_emacs_modifiers) (android_emacs_to_android_modifiers, syms_of_androidterm): Port x-*-keysym from xterm.c. --- src/androidterm.c | 81 +++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 71 insertions(+), 10 deletions(-) diff --git a/src/androidterm.c b/src/androidterm.c index f68f8a9ef62..9948a2919d8 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -361,22 +361,52 @@ static int android_android_to_emacs_modifiers (struct android_display_info *dpyinfo, int state) { - return (((state & ANDROID_CONTROL_MASK) ? ctrl_modifier : 0) - | ((state & ANDROID_SHIFT_MASK) ? shift_modifier : 0) - | ((state & ANDROID_ALT_MASK) ? meta_modifier : 0) - | ((state & ANDROID_SUPER_MASK) ? super_modifier : 0) - | ((state & ANDROID_META_MASK) ? alt_modifier : 0)); + int mod_ctrl = ctrl_modifier; + int mod_meta = meta_modifier; + int mod_alt = alt_modifier; + int mod_super = super_modifier; + Lisp_Object tem; + + tem = Fget (Vx_ctrl_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem) & INT_MAX; + tem = Fget (Vx_alt_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem) & INT_MAX; + tem = Fget (Vx_meta_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem) & INT_MAX; + tem = Fget (Vx_super_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_super = XFIXNUM (tem) & INT_MAX; + + return (((state & ANDROID_CONTROL_MASK) ? mod_ctrl : 0) + | ((state & ANDROID_SHIFT_MASK) ? mod_shift : 0) + | ((state & ANDROID_ALT_MASK) ? mod_meta : 0) + | ((state & ANDROID_SUPER_MASK) ? mod_super : 0) + | ((state & ANDROID_META_MASK) ? mod_alt : 0)); } static int android_emacs_to_android_modifiers (struct android_display_info *dpyinfo, intmax_t state) { - return (((state & ctrl_modifier) ? ANDROID_CONTROL_MASK : 0) - | ((state & shift_modifier) ? ANDROID_SHIFT_MASK : 0) - | ((state & meta_modifier) ? ANDROID_ALT_MASK : 0) - | ((state & super_modifier) ? ANDROID_SUPER_MASK : 0) - | ((state & alt_modifier) ? ANDROID_META_MASK : 0)); + EMACS_INT mod_ctrl = ctrl_modifier; + EMACS_INT mod_meta = meta_modifier; + EMACS_INT mod_alt = alt_modifier; + EMACS_INT mod_super = super_modifier; + Lisp_Object tem; + + tem = Fget (Vx_ctrl_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem); + tem = Fget (Vx_alt_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem); + tem = Fget (Vx_meta_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem); + tem = Fget (Vx_super_keysym, Qmodifier_value); + if (FIXNUMP (tem)) mod_super = XFIXNUM (tem); + + return (((state & mod_ctrl) ? ANDROID_CONTROL_MASK : 0) + | ((state & mod_shift) ? ANDROID_SHIFT_MASK : 0) + | ((state & mod_meta) ? ANDROID_ALT_MASK : 0) + | ((state & mod_super) ? ANDROID_SUPER_MASK : 0) + | ((state & mod_alt) ? ANDROID_META_MASK : 0)); } static void android_frame_rehighlight (struct android_display_info *); @@ -6670,6 +6700,26 @@ Emacs is running on. */); doc: /* Name of the developer of the running version of Android. */); Vandroid_build_manufacturer = Qnil; + DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, + doc: /* SKIP: real doc in xterm.c. */); + Vx_ctrl_keysym = Qnil; + + DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym, + doc: /* SKIP: real doc in xterm.c. */); + Vx_alt_keysym = Qnil; + + DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym, + doc: /* SKIP: real doc in xterm.c. */); + Vx_hyper_keysym = Qnil; + + DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym, + doc: /* SKIP: real doc in xterm.c. */); + Vx_meta_keysym = Qnil; + + DEFVAR_LISP ("x-super-keysym", Vx_super_keysym, + doc: /* SKIP: real doc in xterm.c. */); + Vx_super_keysym = Qnil; + /* Only defined so loadup.el loads scroll-bar.el. */ DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars, doc: /* SKIP: real doc in xterm.c. */); @@ -6683,6 +6733,17 @@ Emacs is running on. */); /* Symbols defined for DND events. */ DEFSYM (Quri, "uri"); DEFSYM (Qtext, "text"); + + /* Symbols defined for modifier value reassignment. */ + DEFSYM (Qmodifier_value, "modifier-value"); + DEFSYM (Qctrl, "ctrl"); + Fput (Qctrl, Qmodifier_value, make_fixnum (ctrl_modifier)); + DEFSYM (Qalt, "alt"); + Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier)); + DEFSYM (Qmeta, "meta"); + Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier)); + DEFSYM (Qsuper, "super"); + Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier)); } void From 28e481bf7af873cdaf016e25855a8e0ebc424fe7 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 16 Mar 2024 15:15:10 +0800 Subject: [PATCH 061/155] Respond to default action from Gnus notifications * lisp/gnus/gnus-notifications.el (gnus-notifications-action): Consider default equivalent to read. --- lisp/gnus/gnus-notifications.el | 5 +++-- src/androidterm.c | 20 ++++++++++---------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el index 35f90ebfe40..e4c3d2c0381 100644 --- a/lisp/gnus/gnus-notifications.el +++ b/lisp/gnus/gnus-notifications.el @@ -75,10 +75,11 @@ not get notifications." (when group-article (let ((group (cadr group-article)) (article (nth 2 group-article))) - (cond ((string= key "read") + (cond ((or (equal key "read") + (equal key "default")) (gnus-fetch-group group (list article)) (select-frame-set-input-focus (selected-frame))) - ((string= key "mark-read") + ((equal key "mark-read") (gnus-update-read-articles group (delq article (gnus-list-of-unread-articles group))) diff --git a/src/androidterm.c b/src/androidterm.c index 9948a2919d8..ba9b6d3b8a9 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -376,11 +376,11 @@ android_android_to_emacs_modifiers (struct android_display_info *dpyinfo, tem = Fget (Vx_super_keysym, Qmodifier_value); if (FIXNUMP (tem)) mod_super = XFIXNUM (tem) & INT_MAX; - return (((state & ANDROID_CONTROL_MASK) ? mod_ctrl : 0) - | ((state & ANDROID_SHIFT_MASK) ? mod_shift : 0) - | ((state & ANDROID_ALT_MASK) ? mod_meta : 0) - | ((state & ANDROID_SUPER_MASK) ? mod_super : 0) - | ((state & ANDROID_META_MASK) ? mod_alt : 0)); + return (((state & ANDROID_CONTROL_MASK) ? mod_ctrl : 0) + | ((state & ANDROID_SHIFT_MASK) ? shift_modifier : 0) + | ((state & ANDROID_ALT_MASK) ? mod_meta : 0) + | ((state & ANDROID_SUPER_MASK) ? mod_super : 0) + | ((state & ANDROID_META_MASK) ? mod_alt : 0)); } static int @@ -402,11 +402,11 @@ android_emacs_to_android_modifiers (struct android_display_info *dpyinfo, tem = Fget (Vx_super_keysym, Qmodifier_value); if (FIXNUMP (tem)) mod_super = XFIXNUM (tem); - return (((state & mod_ctrl) ? ANDROID_CONTROL_MASK : 0) - | ((state & mod_shift) ? ANDROID_SHIFT_MASK : 0) - | ((state & mod_meta) ? ANDROID_ALT_MASK : 0) - | ((state & mod_super) ? ANDROID_SUPER_MASK : 0) - | ((state & mod_alt) ? ANDROID_META_MASK : 0)); + return (((state & mod_ctrl) ? ANDROID_CONTROL_MASK : 0) + | ((state & shift_modifier) ? ANDROID_SHIFT_MASK : 0) + | ((state & mod_meta) ? ANDROID_ALT_MASK : 0) + | ((state & mod_super) ? ANDROID_SUPER_MASK : 0) + | ((state & mod_alt) ? ANDROID_META_MASK : 0)); } static void android_frame_rehighlight (struct android_display_info *); From deebf74b0e178f841c8f504b002b139d13889344 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 16 Mar 2024 15:18:07 +0800 Subject: [PATCH 062/155] ; * src/xterm.c (syms_of_xterm): Fix typo. --- src/xterm.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/xterm.c b/src/xterm.c index bebc30c9103..c30015ec8f0 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -32538,14 +32538,14 @@ Android does not support scroll bars at all. */); DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, doc: /* Which modifer value Emacs reports when Ctrl is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or -`super', representing a modifier to be reported in key events with the +`super', representing a modifier to be reported for key events with the Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed. */); Vx_ctrl_keysym = Qnil; DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym, doc: /* Which modifer value Emacs reports when Alt is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or -`super', representing a modifier to be reported in key events with the +`super', representing a modifier to be reported for key events with the Alt modifier (e.g. the keysym Alt_L or Alt_R, if the keyboard features a dedicated key for Meta) depressed. */); Vx_alt_keysym = Qnil; @@ -32553,14 +32553,14 @@ dedicated key for Meta) depressed. */); DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym, doc: /* Which modifer value Emacs reports when Hyper is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or -`super', representing a modifier to be reported in key events with the +`super', representing a modifier to be reported for key events with the Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed. */); Vx_hyper_keysym = Qnil; DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym, doc: /* Which modifer value Emacs reports when Meta is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or -`super', representing a modifier to be reported in key events with the +`super', representing a modifier to be reported for key events with the Meta modifier (e.g. the keysym Alt_L or Alt_R, when the keyboard does not feature a dedicated key for Meta) depressed. */); Vx_meta_keysym = Qnil; @@ -32568,7 +32568,7 @@ not feature a dedicated key for Meta) depressed. */); DEFVAR_LISP ("x-super-keysym", Vx_super_keysym, doc: /* Which modifer value Emacs reports when Super is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or -`super', representing a modifier to be reported in key events with the +`super', representing a modifier to be reported for key events with the Super modifier (i.e. the keysym Super_L or Super_R) depressed. */); Vx_super_keysym = Qnil; From 899ea79310d1b8ed78c3fd8ac1784043dd732dbf Mon Sep 17 00:00:00 2001 From: Martin Rudalics Date: Sat, 16 Mar 2024 10:10:29 +0100 Subject: [PATCH 063/155] In window-related documentation write 'symbol' instead of 'constant' Suggested by Michael Heerdegen . * src/window.c (window_restore_killed_buffer_windows): In doc-string write 'symbol' instead of 'constant'. * lisp/window.el (display-buffer--lru-window) (display-buffer-use-least-recent-window): In doc-strings write 'symbol' instead of 'constant'. * doc/lispref/windows.texi (Window Configurations): Write 'symbol' instead of 'constant'. --- doc/lispref/windows.texi | 4 ++-- lisp/window.el | 8 ++++---- src/window.c | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 8fa4e57b153..2e2fdee422b 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -6416,9 +6416,9 @@ on its frame), @code{set-window-configuration} and If the value of this variable is a function, that function should take three arguments. The first argument specifies the frame whose windows -have been restored. The third argument is either the constant +have been restored. The third argument is either the symbol @code{configuration} if the windows are restored by -@code{set-window-configuration}, or the constant @code{state} if the +@code{set-window-configuration}, or the symbol @code{state} if the windows are restored by @code{window-state-put}. The second argument specifies a list of entries for @emph{all} windows diff --git a/lisp/window.el b/lisp/window.el index 246708dbd56..df55a7ca673 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -8668,11 +8668,11 @@ buffer. ALIST is a buffer display action alist as compiled by use time is higher than this. - `window-min-width' specifies a preferred minimum width in - canonical frame columns. If it is the constant `full-width', + canonical frame columns. If it is the symbol `full-width', prefer a full-width window. - `window-min-height' specifies a preferred minimum height in - canonical frame lines. If it is the constant `full-height', + canonical frame lines. If it is the symbol `full-height', prefer a full-height window. If ALIST contains a non-nil `inhibit-same-window' entry, do not @@ -8799,11 +8799,11 @@ Distinctive features are: call. `window-min-width' specifies a preferred minimum width in - canonical frame columns. If it is the constant `full-width', + canonical frame columns. If it is the symbol `full-width', prefer a full-width window. `window-min-height' specifies a preferred minimum height in - canonical frame lines. If it is the constant `full-height', + canonical frame lines. If it is the symbol `full-height', prefer a full-height window. - If the preceding steps fail, try to pop up a new window on the diff --git a/src/window.c b/src/window.c index 2c002418605..b69f4719d93 100644 --- a/src/window.c +++ b/src/window.c @@ -8707,8 +8707,8 @@ on its frame), show another buffer in it. If the value is a function, it should take three arguments. The first argument specifies the frame whose windows have been restored. The -third argument is the constant `configuration' if the windows are -restored by `set-window-configuration' and the constant `state' if the +third argument is the symbol `configuration' if the windows are +restored by `set-window-configuration' and the symbol `state' if the windows are restored by `window-state-put'. The second argument specifies a list of entries for all windows From c12852bbf61ebb9ae124033deb427b15ce1a2ffb Mon Sep 17 00:00:00 2001 From: Martin Rudalics Date: Sat, 16 Mar 2024 10:46:02 +0100 Subject: [PATCH 064/155] Document and announce 'marker-last-position' * doc/lispref/markers.texi (Information from Markers): Document 'marker-last-position'. * etc/NEWS: Announce 'marker-last-position'. * src/window.c (window_restore_killed_buffer_windows): Minor doc-string fix. * doc/lispref/windows.texi (Window Configurations): Minor fix. --- doc/lispref/markers.texi | 7 +++++++ doc/lispref/windows.texi | 4 ++-- etc/NEWS | 5 +++++ src/window.c | 12 ++++++------ 4 files changed, 20 insertions(+), 8 deletions(-) diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi index 3037790692c..28ad0ff73c0 100644 --- a/doc/lispref/markers.texi +++ b/doc/lispref/markers.texi @@ -283,6 +283,13 @@ This function returns the position that @var{marker} points to, or @code{nil} if it points nowhere. @end defun +@defun marker-last-position marker +This function returns the last known position of @var{marker} in its +buffer. It behaves like @code{marker-position} with one exception: If +the buffer of @var{marker} has been killed, it returns the last position +of @var{marker} in that buffer before it was killed. +@end defun + @defun marker-buffer marker This function returns the buffer that @var{marker} points into, or @code{nil} if it points nowhere. diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 2e2fdee422b..eef05d94fdb 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -6424,8 +6424,8 @@ windows are restored by @code{window-state-put}. The second argument specifies a list of entries for @emph{all} windows whose previous buffers have been found dead at the time @code{set-window-configuration} or @code{window-state-put} tried to -restore it in that window (minibuffer windows are excluded). This means -that the function may also delete windows which were found live by +restore them (minibuffer windows are excluded). This means that the +function may also delete windows which were found live by @code{set-window-configuration}. Each entry in the list that is passed as the second argument to the diff --git a/etc/NEWS b/etc/NEWS index a654d2d8d79..8cad9412def 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1816,6 +1816,11 @@ improves performance. Such a Lisp program can then use the It returns the name of a buffer before the last time it was renamed or killed. +** New primitive 'marker-last-position'. +It returns the last position of MARKER in its buffer even if that buffer +has been killed. + + ** Functions and variables to transpose sexps +++ diff --git a/src/window.c b/src/window.c index b69f4719d93..748ad9e77d4 100644 --- a/src/window.c +++ b/src/window.c @@ -8711,12 +8711,12 @@ third argument is the symbol `configuration' if the windows are restored by `set-window-configuration' and the symbol `state' if the windows are restored by `window-state-put'. -The second argument specifies a list of entries for all windows -whose previous buffers have been found dead at the time -`set-window-configuration' or `window-state-put' tried to restore it in -that window (minibuffer windows are excluded). This means that the -function specified by this variable may also delete windows which were -found to be alive by `set-window-configuration'. +The second argument specifies a list of entries for all windows whose +previous buffers have been found dead at the time +`set-window-configuration' or `window-state-put' tried to restore them +(minibuffer windows are excluded). This means that the function +specified by this variable may also delete windows which were found to +be alive by `set-window-configuration'. Each entry is a list of six values: the window whose buffer was found dead, the dead buffer or its name, the positions of window-start and From d855f1c3f9c488f48694fe63bbc49d66d775c16c Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Mar 2024 11:58:56 +0200 Subject: [PATCH 065/155] ; Fix recent changes in documentation * doc/lispref/markers.texi (Information from Markers): * etc/NEWS: Improve description of 'marker-last-position'. --- doc/lispref/markers.texi | 5 +++-- etc/NEWS | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi index 28ad0ff73c0..a13edb02ae6 100644 --- a/doc/lispref/markers.texi +++ b/doc/lispref/markers.texi @@ -285,9 +285,10 @@ This function returns the position that @var{marker} points to, or @defun marker-last-position marker This function returns the last known position of @var{marker} in its -buffer. It behaves like @code{marker-position} with one exception: If +buffer. It behaves like @code{marker-position} with one exception: if the buffer of @var{marker} has been killed, it returns the last position -of @var{marker} in that buffer before it was killed. +of @var{marker} in that buffer before the buffer was killed, instead of +returning @code{nil}. @end defun @defun marker-buffer marker diff --git a/etc/NEWS b/etc/NEWS index 8cad9412def..50f0ee4a1aa 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1817,8 +1817,9 @@ It returns the name of a buffer before the last time it was renamed or killed. ** New primitive 'marker-last-position'. -It returns the last position of MARKER in its buffer even if that buffer -has been killed. +It returns the last position of a marker in its buffer even if that +buffer has been killed. ('marker-position' would return nil in that +case.) ** Functions and variables to transpose sexps From d5901f3f05e0aec9bf4b6b4b6ebf27c66c7cee14 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Mar 2024 12:42:16 +0200 Subject: [PATCH 066/155] Improve documentation of 'edebug-print-*' variables * lisp/emacs-lisp/edebug.el (edebug-print-length) (edebug-print-level): Fix doc strings and customization labels. Suggested by Matt Trzcinski . (Bug#69745) --- lisp/emacs-lisp/edebug.el | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 9656bdf03d8..623b1c6a8c9 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -193,11 +193,15 @@ Use this with caution since it is not debugged." (defcustom edebug-print-length 50 - "If non-nil, default value of `print-length' for printing results in Edebug." - :type '(choice integer (const nil))) + "Maximum length of list to print before abbreviating, when in Edebug. +If this is nil, use the value of `print-length' instead." + :type '(choice (integer :tag "A number") + (const :tag "Use `print-length'" nil))) (defcustom edebug-print-level 50 - "If non-nil, default value of `print-level' for printing results in Edebug." - :type '(choice integer (const nil))) + "Maximum depth of list nesting to print before abbreviating, when in Edebug. +If nil, use the value of `print-level' instead." + :type '(choice (integer :tag "A number") + (const :tag "Use `print-level'" nil))) (defcustom edebug-print-circle t "If non-nil, default value of `print-circle' for printing results in Edebug." :type 'boolean) From 685f4295f9810b4aab8ec3ba7146b17904a1c37f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Mar 2024 12:58:33 +0200 Subject: [PATCH 067/155] ; Document more DND functions with limited support * lisp/dnd.el (dnd-begin-text-drag, dnd-begin-file-drag) (dnd-begin-drag-files): Document platforms that support these functions. (Bug#69662) --- lisp/dnd.el | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/lisp/dnd.el b/lisp/dnd.el index 22cb18359a3..1fc1ab45b84 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -453,7 +453,10 @@ on FRAME itself. This function might return immediately if no mouse buttons are currently being held down. It should only be called upon a -`down-mouse-1' (or similar) event." +`down-mouse-1' (or similar) event. + +This function is only supported on X Windows, macOS/GNUstep, and Haiku; +on all other platforms it will signal an error." (unless (fboundp 'x-begin-drag) (error "Dragging text from Emacs is not supported by this window system")) (gui-set-selection 'XdndSelection text) @@ -513,7 +516,10 @@ nil, any drops on FRAME itself will be ignored. This function might return immediately if no mouse buttons are currently being held down. It should only be called upon a -`down-mouse-1' (or similar) event." +`down-mouse-1' (or similar) event. + +This function is only supported on X Windows, macOS/GNUstep, and Haiku; +on all other platforms it will signal an error." (unless (fboundp 'x-begin-drag) (error "Dragging files from Emacs is not supported by this window system")) (dnd-remove-last-dragged-remote-file) @@ -580,7 +586,10 @@ FRAME, ACTION and ALLOW-SAME-FRAME mean the same as in FILES is a list of files that will be dragged. If the drop target doesn't support dropping multiple files, the first file in -FILES will be dragged." +FILES will be dragged. + +This function is only supported on X Windows, macOS/GNUstep, and Haiku; +on all other platforms it will signal an error." (unless (fboundp 'x-begin-drag) (error "Dragging files from Emacs is not supported by this window system")) (dnd-remove-last-dragged-remote-file) From 8cf05d9be12e8b5f8893cfd8a67c92e904a2aa05 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Mar 2024 13:07:52 +0200 Subject: [PATCH 068/155] Fix 'shortdoc-copy-function-as-kill' * lisp/emacs-lisp/shortdoc.el (shortdoc-copy-function-as-kill): Fix handling of functions with no arguments. (Bug#69720) --- lisp/emacs-lisp/shortdoc.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 75ac7b3d52c..fdba6d32418 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1675,7 +1675,7 @@ With prefix numeric argument ARG, do it that many times." (interactive) (save-excursion (goto-char (pos-bol)) - (when-let* ((re (rx bol "(" (group (+ (not (in " ")))))) + (when-let* ((re (rx bol "(" (group (+ (not (in " )")))))) (string (and (or (looking-at re) (re-search-backward re nil t)) From f48babb1120343f211367a1b5854dc7740c3091d Mon Sep 17 00:00:00 2001 From: Konstantin Kharlamov Date: Sat, 16 Mar 2024 13:24:34 +0300 Subject: [PATCH 069/155] `term-mode': mention the keymap to add keybindings to A user typically expects a keymap for mode `foo' to be called `foo-mode-map'. term-mode has `term-mode-map' too, but for user-defined bindings to have effect they have to be put to `term-raw-map' instead. So let's mention that. * lisp/term.el (term-mode) (term-mode-map) (term-raw-map): Mention the keymaps to add keybindings to for `term-mode'. (Bug#69786) --- lisp/term.el | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/lisp/term.el b/lisp/term.el index 647938c3b86..e769577b4f2 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -658,7 +658,8 @@ executed once, when the buffer is created." ["Forward Output Group" term-next-prompt t] ["Kill Current Output Group" term-kill-output t])) map) - "Keymap for Term mode.") + "Keymap for \"line mode\" in Term mode. For custom keybindings purposes +please note there is also `term-raw-map'") (defvar term-escape-char nil "Escape character for char sub-mode of term mode. @@ -958,7 +959,9 @@ underlying shell." (dotimes (key 21) (keymap-set map (format "" key) #'term-send-function-key))) map) - "Keyboard map for sending characters directly to the inferior process.") + "Keyboard map for sending characters directly to the inferior process. +For custom keybindings purposes please note there is also +`term-mode-map'") (easy-menu-define term-terminal-menu (list term-mode-map term-raw-map term-pager-break-map) @@ -1122,6 +1125,10 @@ particular subprocesses. This can be done by setting the hooks and the variable `term-prompt-regexp' to the appropriate regular expression. +If you define custom keybindings, make sure to assign them to the +correct keymap (or to both): use `term-raw-map' in raw mode and +`term-mode-map' in line mode. + Commands in raw mode: \\{term-raw-map} From ad3a3ad6e616a53ec5ae28aed02e8d3461a5ce5c Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 16 Mar 2024 14:15:25 +0100 Subject: [PATCH 070/155] ; Pacify -Wmaybe-uninitialized in coding.c. Warning seen with GCC 13 -Og. --- src/coding.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/coding.c b/src/coding.c index 5f3ceab718b..ff7cf56c297 100644 --- a/src/coding.c +++ b/src/coding.c @@ -5488,7 +5488,7 @@ decode_coding_charset (struct coding_system *coding) { int c; Lisp_Object val; - struct charset *charset; + struct charset *charset UNINIT; int dim; int len = 1; unsigned code; From c890622e1a9ae6f2ab5d083ca8b668c9228c52fa Mon Sep 17 00:00:00 2001 From: Theodor Thornhill Date: Sat, 16 Mar 2024 20:28:10 +0100 Subject: [PATCH 071/155] Tweak regexp for object initializers in csharp-mode (bug#69571) * lisp/progmodes/csharp-mode.el (csharp-guess-basic-syntax): Add handling to not consider ended statements as object init openers. * test/lisp/progmodes/csharp-mode-resources/indent.erts: New test resources. * test/lisp/progmodes/csharp-mode-tests.el: Add test for this particular issue. --- lisp/progmodes/csharp-mode.el | 7 +++-- .../csharp-mode-resources/indent.erts | 19 ++++++++++++ test/lisp/progmodes/csharp-mode-tests.el | 30 +++++++++++++++++++ 3 files changed, 54 insertions(+), 2 deletions(-) create mode 100644 test/lisp/progmodes/csharp-mode-resources/indent.erts create mode 100644 test/lisp/progmodes/csharp-mode-tests.el diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 3cd64ae435f..2740d34e3b2 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -495,9 +495,12 @@ compilation and evaluation time conflicts." (unless (eq (char-after) ?{) (ignore-errors (backward-up-list 1 t t))) (save-excursion - ;; 'new' should be part of the line + ;; 'new' should be part of the line, but should not trigger if + ;; statement has already ended, like for 'var x = new X();'. + ;; Also, deal with the possible end of line obscured by a + ;; trailing comment. (goto-char (c-point 'iopl)) - (looking-at ".*new.*"))) + (looking-at "^[^//]*new[^//]*;$"))) ;; Line should not already be terminated (save-excursion (goto-char (c-point 'eopl)) diff --git a/test/lisp/progmodes/csharp-mode-resources/indent.erts b/test/lisp/progmodes/csharp-mode-resources/indent.erts new file mode 100644 index 00000000000..a676ecc9728 --- /dev/null +++ b/test/lisp/progmodes/csharp-mode-resources/indent.erts @@ -0,0 +1,19 @@ +Code: + (lambda () + (csharp-mode) + (indent-region (point-min) (point-max))) + +Point-Char: | + +Name: Don't consider closed statements as object initializers. (bug#69571) + +=-= +public class Foo { + void Bar () { + var x = new X(); // [1] + for (;;) { + x(); + } // [2] + } +} +=-=-= diff --git a/test/lisp/progmodes/csharp-mode-tests.el b/test/lisp/progmodes/csharp-mode-tests.el new file mode 100644 index 00000000000..f50fabf5836 --- /dev/null +++ b/test/lisp/progmodes/csharp-mode-tests.el @@ -0,0 +1,30 @@ +;;; csharp-mode-tests.el --- Tests for CC Mode C# mode -*- 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 . + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'csharp-mode) + +(ert-deftest csharp-mode-test-indentation () + (ert-test-erts-file (ert-resource-file "indent.erts"))) + +(provide 'csharp-mode-tests) +;;; csharp-mode-tests.el ends here From 445e2499baa1b8ef21e8edcc13692b5d78912922 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 16 Mar 2024 23:10:48 -0400 Subject: [PATCH 072/155] debug.el: Prevent re-entering the debugger for the same error We can have several active `handler-bind`s that all want to invoke the debugger, in which case we can have the following sequence: - The more deeply nested handler calls the debugger. - After a while the user invokes `debugger-continue`. - `signal_or_quit` propagates the error up the stack to the second handler, which calls the debugger again. - The user thus ends up right back at the same place, as if `debugger-continue` had not be processed. Fix this by remembering the last processed error and skipping the debugger if we bump into it again. * lisp/emacs-lisp/debug.el (debugger--last-error): New var. (debugger--duplicate-p): New function. (debug): Use them. --- lisp/emacs-lisp/debug.el | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 60d14d11970..ec947c1215d 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -153,6 +153,12 @@ where CAUSE can be: (insert (debugger--buffer-state-content state))) (goto-char (debugger--buffer-state-pos state))) +(defvar debugger--last-error nil) + +(defun debugger--duplicate-p (args) + (pcase args + (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error))))) + ;;;###autoload (setq debugger 'debug) ;;;###autoload @@ -175,9 +181,14 @@ first will be printed into the backtrace buffer. If `inhibit-redisplay' is non-nil when this function is called, the debugger will not be entered." (interactive) - (if inhibit-redisplay - ;; Don't really try to enter debugger within an eval from redisplay. + (if (or inhibit-redisplay + (debugger--duplicate-p args)) + ;; Don't really try to enter debugger within an eval from redisplay + ;; or if we already popper into the debugger for this error, + ;; which can happen when we have several nested `handler-bind's that + ;; want to invoke the debugger. debugger-value + (setq debugger--last-error nil) (let ((non-interactive-frame (or noninteractive ;FIXME: Presumably redundant. ;; If we're in the initial-frame (where `message' just @@ -318,6 +329,12 @@ the debugger will not be entered." (backtrace-mode)))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) + (when (eq 'error (car-safe debugger-args)) + ;; Remember the error we just debugged, to avoid re-entering + ;; the debugger if some higher-up `handler-bind' invokes us + ;; again, oblivious that the error was already debugged from + ;; a more deeply nested `handler-bind'. + (setq debugger--last-error (nth 1 debugger-args))) (setq debug-on-next-call debugger-step-after-exit) debugger-value)))) From 06a991e7e87c9954f590d30e87d8710ff60ce7b8 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 17 Mar 2024 10:47:41 +0200 Subject: [PATCH 073/155] ; * admin/notes/bugtracker: Minor copyedit. --- admin/notes/bugtracker | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/admin/notes/bugtracker b/admin/notes/bugtracker index b47061884d6..93532e02d20 100644 --- a/admin/notes/bugtracker +++ b/admin/notes/bugtracker @@ -430,8 +430,8 @@ reassign 123 spam *** To change the title of a bug: retitle 123 Some New Title -*** To change the submitter address: -submitter 123 none@example.com +*** To change the submitter name and address: +submitter 123 J. Hacker none@example.com Note that it does not seem to work to specify "Submitter:" in the pseudo-header when first reporting a bug. From 7a0f4de3c18cab43b5bff47fdab4944e006c68e4 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sun, 17 Mar 2024 19:32:15 +0800 Subject: [PATCH 074/155] Improve C++ standard library detection on Android * configure.ac: Stop relaying --with-ndk-cxx-shared to the nested invocation of configure. * build-aux/ndk-build-helper-1.mk (SYSTEM_LIBRARIES): * build-aux/ndk-build-helper-2.mk (SYSTEM_LIBRARIES): Insert all of the C++ libraries available on Android. * configure.ac: Call ndk_LATE and ndk_LATE_EARLY within if statement at toplevel, averting needless calls to AC_PROG_CXX. * cross/ndk-build/Makefile.in (NDK_BUILD_CXX_STL) (NDK_BUILD_CXX_LDFLAGS): * cross/ndk-build/ndk-build.mk.in (NDK_BUILD_CXX_STL) (NDK_BUILD_CXX_LDFLAGS): New variables. * cross/ndk-build/ndk-resolve.mk (NDK_SYSTEM_LIBRARIES): Introduce several other C++ libraries sometimes present on Android. (NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE)): Insert NDK_BUILD_CXX_STL when any of these new C++ libraries are requested. * m4/ndk-build.m4: Completely rewrite C++ compiler and library detection. * java/org/gnu/emacs/EmacsNative.java (EmacsNative): Attempt to load more libraries from static initializer. * java/INSTALL: Remove obsolete information. --- build-aux/ndk-build-helper-1.mk | 2 +- build-aux/ndk-build-helper-2.mk | 2 +- configure.ac | 12 +- cross/ndk-build/Makefile.in | 26 +- cross/ndk-build/ndk-build.mk.in | 2 + cross/ndk-build/ndk-resolve.mk | 32 ++- java/INSTALL | 30 +-- java/org/gnu/emacs/EmacsNative.java | 6 +- m4/ndk-build.m4 | 354 +++++++++++++++++++++------- 9 files changed, 335 insertions(+), 131 deletions(-) diff --git a/build-aux/ndk-build-helper-1.mk b/build-aux/ndk-build-helper-1.mk index 5681728154c..490064b6e32 100644 --- a/build-aux/ndk-build-helper-1.mk +++ b/build-aux/ndk-build-helper-1.mk @@ -94,7 +94,7 @@ endef # dependencies can be ignored while building a shared library, as they # will be linked in to the resulting shared object file later. -SYSTEM_LIBRARIES = z libz libc c libdl dl stdc++ libstdc++ log liblog android libandroid +SYSTEM_LIBRARIES = z libz libc c libdl dl stdc++ libstdc++ stlport libstlport gnustl libgnustl c++ libc++ log liblog android libandroid $(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_SHARED_LIBRARIES)),$(eval $(call add-so-name,$(module)))) $(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_SHARED_LIBRARIES) $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_STATIC_LIBRARIES)),$(eval $(call add-includes,$(module)))) diff --git a/build-aux/ndk-build-helper-2.mk b/build-aux/ndk-build-helper-2.mk index 1c2409cfd57..e696fcbdade 100644 --- a/build-aux/ndk-build-helper-2.mk +++ b/build-aux/ndk-build-helper-2.mk @@ -87,7 +87,7 @@ endef # Resolve additional dependencies based on LOCAL_STATIC_LIBRARIES and # LOCAL_SHARED_LIBRARIES. -SYSTEM_LIBRARIES = z libz libc c libdl dl libstdc++ stdc++ log liblog android libandroid +SYSTEM_LIBRARIES = z libz libc c libdl dl libstdc++ stdc++ stlport libstlport gnustl libgnustl c++ libc++ log liblog android libandroid $(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_STATIC_LIBRARIES)),$(eval $(call add-a-name,$(module)))) $(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_SHARED_LIBRARIES)),$(eval $(call add-so-name,$(module)))) diff --git a/configure.ac b/configure.ac index 452aa0838f1..bd678ea52a3 100644 --- a/configure.ac +++ b/configure.ac @@ -171,7 +171,6 @@ AS_IF([test "$XCONFIGURE" = "android"],[ # Make sure to pass through the CFLAGS, as older versions of the # NDK require them to be able to find system includes. with_ndk_path="$android_ndk_path" - with_ndk_cxx_shared="$android_ndk_cxx_shared" with_ndk_cxx="$android_ndk_cxx" ndk_INIT([$android_abi], [$ANDROID_SDK], [cross/ndk-build], [$ANDROID_CFLAGS]) @@ -1233,7 +1232,7 @@ package will likely install on older systems but crash on startup.]) passthrough="$passthrough --with-harfbuzz=$with_harfbuzz" passthrough="$passthrough --with-threads=$with_threads" - # Now pass through some checking options. + # Now pass through some checking-related options. emacs_val="--enable-check-lisp-object-type=$enable_check_lisp_object_type" passthrough="$passthrough $emacs_val" @@ -1243,7 +1242,6 @@ package will likely install on older systems but crash on startup.]) AS_IF([XCONFIGURE=android ANDROID_CC="$ANDROID_CC" \ ANDROID_SDK="$android_sdk" android_abi=$android_abi \ android_ndk_path="$with_ndk_path" \ - android_ndk_cxx_shared="$with_ndk_cxx_shared" \ android_ndk_cxx="$android_ndk_cxx" \ $CONFIG_SHELL $0 $passthrough], [], [AC_MSG_ERROR([Failed to cross-configure Emacs for android.])]) @@ -1570,7 +1568,13 @@ AC_DEFUN_ONCE([gl_STDLIB_H], # Initialize gnulib right after choosing the compiler. dnl Amongst other things, this sets AR and ARFLAGS. gl_EARLY -ndk_LATE + +# ndk_LATE must be enclosed in this conditional to prevent the +# AC_PROG_CXX it indirectly requires from being expanded at top level. +if test "$ndk_INITIALIZED" = "yes"; then + ndk_LATE_EARLY + ndk_LATE +fi if test "$ac_test_CFLAGS" != set; then # It's helpful to have C macros available to GDB, so prefer -g3 to -g diff --git a/cross/ndk-build/Makefile.in b/cross/ndk-build/Makefile.in index 8ba2d356f27..0970a765b45 100644 --- a/cross/ndk-build/Makefile.in +++ b/cross/ndk-build/Makefile.in @@ -24,15 +24,17 @@ srcdir = @srcdir@ # This is a list of Android.mk files which provide targets. -NDK_BUILD_ANDROID_MK = @NDK_BUILD_ANDROID_MK@ - NDK_BUILD_ARCH = @NDK_BUILD_ARCH@ - NDK_BUILD_ABI = @NDK_BUILD_ABI@ - NDK_BUILD_SDK = @NDK_BUILD_SDK@ - NDK_BUILD_CC = @NDK_BUILD_CC@ - NDK_BUILD_CXX = @NDK_BUILD_CXX@ - NDK_BUILD_AR = @NDK_BUILD_AR@ - NDK_BUILD_NASM = @NDK_BUILD_NASM@ - NDK_BUILD_CFLAGS = @NDK_BUILD_CFLAGS@ + NDK_BUILD_ANDROID_MK = @NDK_BUILD_ANDROID_MK@ + NDK_BUILD_ARCH = @NDK_BUILD_ARCH@ + NDK_BUILD_ABI = @NDK_BUILD_ABI@ + NDK_BUILD_SDK = @NDK_BUILD_SDK@ + NDK_BUILD_CC = @NDK_BUILD_CC@ + NDK_BUILD_CXX = @NDK_BUILD_CXX@ + NDK_BUILD_CXX_STL = @NDK_BUILD_CXX_STL@ +NDK_BUILD_CXX_LDFLAGS = @NDK_BUILD_CXX_LDFLAGS@ + NDK_BUILD_AR = @NDK_BUILD_AR@ + NDK_BUILD_NASM = @NDK_BUILD_NASM@ + NDK_BUILD_CFLAGS = @NDK_BUILD_CFLAGS@ # This is a list of targets to build. NDK_BUILD_MODULES = @NDK_BUILD_MODULES@ @@ -58,8 +60,10 @@ NDK_BUILD_ANDROID_MK := $(call uniqify,$(NDK_BUILD_ANDROID_MK)) NDK_BUILD_MODULES := $(call uniqify,$(NDK_BUILD_MODULES)) # Define CFLAGS for compiling C++ code; this involves removing all -# -std=NNN options. -NDK_BUILD_CFLAGS_CXX := $(filter-out -std=%,$(NDK_BUILD_CFLAGS)) +# -std=NNN options and inserting compilation options for the C++ +# library. +NDK_BUILD_CFLAGS_CXX := $(filter-out -std=%,$(NDK_BUILD_CFLAGS)) \ + $(NDK_BUILD_CXX_STL) define subr-1 diff --git a/cross/ndk-build/ndk-build.mk.in b/cross/ndk-build/ndk-build.mk.in index 6c85ff5044e..ea1be5af6f1 100644 --- a/cross/ndk-build/ndk-build.mk.in +++ b/cross/ndk-build/ndk-build.mk.in @@ -22,6 +22,8 @@ NDK_BUILD_MODULES = @NDK_BUILD_MODULES@ NDK_BUILD_CXX_SHARED = @NDK_BUILD_CXX_SHARED@ +NDK_BUILD_CXX_STL = @NDK_BUILD_CXX_STL@ +NDK_BUILD_CXX_LDFLAGS = @NDK_BUILD_CXX_LDFLAGS@ NDK_BUILD_ANY_CXX_MODULE = @NDK_BUILD_ANY_CXX_MODULE@ NDK_BUILD_SHARED = NDK_BUILD_STATIC = diff --git a/cross/ndk-build/ndk-resolve.mk b/cross/ndk-build/ndk-resolve.mk index d3b398bca62..4d8ecf8667a 100644 --- a/cross/ndk-build/ndk-resolve.mk +++ b/cross/ndk-build/ndk-resolve.mk @@ -20,7 +20,7 @@ # which actually builds targets. # List of system libraries to ignore. -NDK_SYSTEM_LIBRARIES = z libz libc c libdl dl stdc++ libstdc++ log liblog android libandroid +NDK_SYSTEM_LIBRARIES = z libz libc c libdl dl stdc++ libstdc++ stlport libstlport gnustl libgnustl c++ libc++ log liblog android libandroid # Save information. NDK_LOCAL_PATH_$(LOCAL_MODULE) := $(LOCAL_PATH) @@ -90,11 +90,35 @@ endif # Likewise for libstdc++. ifeq ($(strip $(1)),libstdc++) -NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -lstdc++ +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) endif -ifeq ($(strip $(1)),dl) -NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -lstdc++ +ifeq ($(strip $(1)),stdc++) +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) +endif + +ifeq ($(strip $(1)),libstlport) +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) +endif + +ifeq ($(strip $(1)),stlport) +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) +endif + +ifeq ($(strip $(1)),libgnustl) +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) +endif + +ifeq ($(strip $(1)),gnustl) +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) +endif + +ifeq ($(strip $(1)),libc++) +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) +endif + +ifeq ($(strip $(1)),c++) +NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS) endif # Likewise for liblog. diff --git a/java/INSTALL b/java/INSTALL index 175ff2826b2..f1063b40c25 100644 --- a/java/INSTALL +++ b/java/INSTALL @@ -166,25 +166,21 @@ than a compressed package for a newer version of Android. BUILDING C++ DEPENDENCIES -With a new version of the NDK, dependencies containing C++ code should -build without any further configuration. However, older versions -require that you use the ``make_standalone_toolchain.py'' script in -the NDK distribution to create a ``standalone toolchain'', and use -that instead, in order for C++ headers to be found. +In normal circumstances, Emacs should automatically detect and configure +one of the C++ standard libraries part of the NDK when such a library is +required to build a dependency specified under `--with-ndk-path'. -See https://developer.android.com/ndk/guides/standalone_toolchain for -more details; when a ``standalone toolchain'' is specified, the -configure script will try to determine the location of the C++ -compiler based on the C compiler specified. If that automatic -detection does not work, you can specify a C++ compiler yourself, like -so: +Nevertheless, this process is not infalliable, and with certain versions +of the NDK is liable to fail to locate a C++ compiler, requiring that +you run the `make_standalone_toolchain.py' script in the NDK +distribution to create a ``standalone toolchain'' and substitute the +same for the regular compiler toolchain. See +https://developer.android.com/ndk/guides/standalone_toolchain for +further details. - ./configure --with-ndk-cxx=/path/to/toolchain/bin/i686-linux-android-g++ - -Some versions of the NDK have a bug, where GCC fails to locate -``stddef.h'' after being copied to a standalone toolchain. To work -around this problem (which normally exhibits itself when building C++ -code), add: +Some versions of the NDK that ship GCC 4.9.x exhibit a bug where the +compiler cannot locate `stddef.h' after being copied to a standalone +toolchain. To work around this problem, add: -isystem /path/to/toolchain/include/c++/4.9.x diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java index 6845f833908..898eaef41a7 100644 --- a/java/org/gnu/emacs/EmacsNative.java +++ b/java/org/gnu/emacs/EmacsNative.java @@ -323,7 +323,9 @@ public static native void blitRect (Bitmap src, Bitmap dest, int x1, Every time you add a new shared library dependency to Emacs, please add it here as well. */ - libraryDeps = new String[] { "png_emacs", "selinux_emacs", + libraryDeps = new String[] { "c++_shared", "gnustl_shared", + "stlport_shared", "gabi++_shared", + "png_emacs", "selinux_emacs", "crypto_emacs", "pcre_emacs", "packagelistparser_emacs", "gnutls_emacs", "gmp_emacs", @@ -331,7 +333,7 @@ public static native void blitRect (Bitmap src, Bitmap dest, int x1, "tasn1_emacs", "hogweed_emacs", "jansson_emacs", "jpeg_emacs", "tiff_emacs", "xml2_emacs", - "icuuc_emacs", + "icuuc_emacs", "harfbuzz_emacs", "tree-sitter_emacs", }; for (String dependency : libraryDeps) diff --git a/m4/ndk-build.m4 b/m4/ndk-build.m4 index aacb2ed048b..7012471e046 100644 --- a/m4/ndk-build.m4 +++ b/m4/ndk-build.m4 @@ -21,10 +21,6 @@ AC_ARG_WITH([ndk_path], [AS_HELP_STRING([--with-ndk-path], [find Android libraries in these directories])]) -AC_ARG_WITH([ndk_cxx_shared], - [AS_HELP_STRING([--with-ndk-cxx-shared], - [name of the C++ standard library included with the NDK])]) - AC_ARG_WITH([ndk_cxx], [AS_HELP_STRING([--with-ndk-cxx], [name of the C++ compiler included with the NDK])]) @@ -59,6 +55,7 @@ ndk_DIR=$3 ndk_ANY_CXX= ndk_BUILD_CFLAGS="$4" ndk_working_cxx=no +ndk_CXX_SHARED= AS_CASE(["$ndk_ABI"], [*arm64*], [ndk_ARCH=arm64], @@ -149,7 +146,7 @@ ndk_resolve_import_module () { for ndk_android_mk in $ndk_module_files; do # Read this Android.mk file. Set NDK_ROOT to /tmp: the Android in - # tree build system sets it to a meaning value, but build files + # tree build system sets it to a meaningful value, but build files # just use it to test whether or not the NDK is being used. ndk_commands=`ndk_run_test` eval "$ndk_commands" @@ -169,13 +166,14 @@ that could not be found in the list of directories specified in \ ndk_ANY_CXX=yes fi - AS_IF([test "$ndk_ANY_CXX" = "yes" && test -z "$with_ndk_cxx_shared"], - [AC_MSG_ERROR([The module [$]1 requires the C++ standard library \ -(libc++_shared.so), but it was not found.])]) + AS_IF([test "$module_cxx_deps" = "yes" && test -z "$ndk_CXX_STL" \ + && test -z "$ndk_CXX_LDFLAGS"], + [AC_MSG_ERROR([The module $1 requires a C++ standard library, +but none were found.])]) - AS_IF([test "$ndk_ANY_CXX" = "yes" && test "$ndk_working_cxx" != "yes"], - [AC_MSG_ERROR([The module [$]1 requires the C++ standard library \ -(libc++_shared.so), but a working C++ compiler was not found.])]) + AS_IF([test "$module_cxx_deps" = "yes" && test "$ndk_working_cxx" != "yes"], + [AC_MSG_ERROR([The module [$]1 requires the C++ standard library, +but a working C++ compiler was not found.])]) AC_MSG_RESULT([yes]) @@ -227,6 +225,88 @@ ndk_subst_cc_onto_cxx () { done } +# ndk_subst_cflags_onto_cxx +# --------------------- +# Print any options in CFLAGS also suitable for a C++ compiler. + +ndk_subst_cflags_onto_cxx () { + ndk_flag= + for ndk_word in $CFLAGS; do + AS_IF([test "$ndk_flag" = "yes"], + [AS_ECHO_N(["$ndk_word "]) + ndk_flag=no], + [AS_CASE([$ndk_word], + [*-sysroot=*], + [AS_ECHO_N(["$ndk_word "])], + [*-isystem*], + [AS_ECHO_N(["$ndk_word "]) + ndk_flag=yes], + [*-I*], + [AS_ECHO_N(["$ndk_word "]) + ndk_flag=yes], + [*-sysroot*], + [AS_ECHO_N(["$ndk_word "]) + ndk_flag=yes], + [-D__ANDROID_API__*], + [AS_ECHO_N(["$ndk_word "])])]) + done +} + +# Detect the installation directory and type of the NDK being used. + +ndk_install_dir= +ndk_toolchain_type= + +AC_MSG_CHECKING([for the directory where the NDK is installed]) + +dnl If the install directory isn't available, repeat the search over +dnl each entry in the programs directory. +ndk_programs_dirs=`$CC -print-search-dirs | sed -n "s/^programs:[[\t ]]*=\?\(.*\)/\1/p"` +ndk_save_IFS=$IFS; IFS=: +for ndk_dir in $ndk_programs_dirs; do + if test -d "$ndk_dir"; then :; else + continue + fi + ndk_dir=`cd "$ndk_dir"; pwd` + while test "$ndk_dir" != "/" && test -z "$ndk_toolchain_type"; do + ndk_dir=`AS_DIRNAME([$ndk_dir])` + AS_IF([test -d "$ndk_dir/bin" && test -d "$ndk_dir/lib"], + [dnl The directory reached is most likely either the directory + dnl holding prebuilt binaries in a combined toolchain or the + dnl directory holding a standalone toolchain itself. + dnl + dnl Distinguish between the two by verifying the name of the + dnl parent directory (and its parent). + ndk_dir1=`AS_DIRNAME(["$ndk_dir"])` + ndk_basename=`AS_BASENAME(["$ndk_dir1"])` + AS_IF([test "$ndk_basename" = "prebuilt"], + [dnl Directories named "prebuilt" are exclusively present in + dnl combined toolchains, where they are children of the + dnl base directory or, in recent releases, a directory + dnl within the base directory. Continue searching for the + dnl base directory. + ndk_toolchain_type=combined + while test "$ndk_dir1" != "/"; do + AS_IF([test -d "$ndk_dir1/toolchains" \ + && test -d "$ndk_dir1/sources"], + [ndk_install_dir=$ndk_dir1 + break]) + ndk_dir1=`AS_DIRNAME(["$ndk_dir1"])` + done], + [ndk_toolchain_type=standalone + ndk_install_dir=$ndk_dir])]) + done + AS_IF([test -n "$ndk_toolchain_type"], + [break]) +done +IFS=$ndk_save_IFS + +AS_IF([test -z "$ndk_install_dir"], + [AC_MSG_RESULT([unknown]) + AC_MSG_WARN([The NDK installation directory could not be \ +derived from the compiler.])], + [AC_MSG_RESULT([$ndk_install_dir ($ndk_toolchain_type)])]) + # Look for a suitable ar and ranlib in the same directory as the C # compiler. ndk_cc_firstword=`AS_ECHO(["$CC"]) | cut -d' ' -f1` @@ -259,72 +339,8 @@ NDK_BUILD_NASM= AS_IF([test "$ndk_ARCH" = "x86" || test "$ndk_ARCH" = "x86_64"], [AC_CHECK_PROGS([NDK_BUILD_NASM], [nasm])]) -# Look for a file named ``libc++_shared.so'' in a subdirectory of -# $ndk_where_cc if it was not specified. -AC_MSG_CHECKING([for libc++_shared.so]) - -ndk_where_toolchain= -AS_IF([test -z "$with_ndk_cxx_shared" && test -n "$ndk_where_cc"],[ - # Find the NDK root directory. Go to $ndk_where_cc. - SAVE_PWD=`pwd` - cd `AS_DIRNAME(["$ndk_where_cc"])` - - # Now, keep moving backwards until pwd ends with ``toolchains''. - while :; do - if test "`pwd`" = "/"; then - cd "$SAVE_PWD" - break - fi - - ndk_pwd=`pwd` - if test "`AS_BASENAME([$ndk_pwd])`" = "toolchains"; then - ndk_where_toolchain=$ndk_pwd - cd "$SAVE_PWD" - break - fi - - cd .. - done - - ndk_matching_libcxx_shared_so= - - # The toolchain directory should be in "$ndk_where_toolchain". - AS_IF([test -n "$ndk_where_toolchain"],[ - # Now, look in the directory behind it. - ndk_cxx_shared_so=`find "$ndk_where_toolchain" -name libc++_shared.so` - - # Look for one with the correct architecture. - for ndk_candidate in $ndk_cxx_shared_so; do - AS_CASE([$ndk_candidate], - [*arm-linux-android*], - [AS_IF([test "$ndk_ARCH" = "arm"], - [ndk_matching_libcxx_shared_so=$ndk_candidate])], - [*aarch64-linux-android*], - [AS_IF([test "$ndk_ARCH" = "arm64"], - [ndk_matching_libcxx_shared_so=$ndk_candidate])], - [*i[[3-6]]86-linux-android*], - [AS_IF([test "$ndk_ARCH" = "x86"], - [ndk_matching_libcxx_shared_so=$ndk_candidate])], - [*x86_64-linux-android*], - [AS_IF([test "$ndk_ARCH" = "x86_64"], - [ndk_matching_libcxx_shared_so=$ndk_candidate])]) - - AS_IF([test -n "$ndk_matching_libcxx_shared_so"], - [with_ndk_cxx_shared=$ndk_matching_libcxx_shared_so]) - done])]) - -AS_IF([test -z "$with_ndk_cxx_shared"],[AC_MSG_RESULT([no]) - AC_MSG_WARN([The C++ standard library could not be found. \ -If you try to build Emacs with a dependency that requires the C++ standard \ -library, Emacs will not build correctly, unless you manually specify the \ -name of an appropriate ``libc++_shared.so'' binary.])], - [AC_MSG_RESULT([$with_ndk_cxx_shared])]) - -ndk_CXX_SHARED=$with_ndk_cxx_shared - -# These variables have now been found. Now look for a C++ compiler. -# Upon failure, pretend the C compiler is a C++ compiler and use that -# instead. +# Search for a C++ compiler. Upon failure, pretend the C compiler is a +# C++ compiler and use that instead. ndk_cc_name=`AS_BASENAME(["${ndk_cc_firstword}"])` ndk_cxx_name= @@ -338,8 +354,162 @@ AS_IF([test -n "$with_ndk_cxx"], [CXX=$with_ndk_cxx], [], [`AS_DIRNAME(["$ndk_where_cc"])`:$PATH]) AS_IF([test -z "$CXX"], [CXX=`ndk_filter_cc_for_cxx`], [CXX=`ndk_subst_cc_onto_cxx`])]) + +# None of the C++ standard libraries installed with Android are +# available to NDK programs, which are expected to select one of several +# standard libraries distributed with the NDK. This library must be +# extracted from the NDK by the program's build system and copied into +# the application directory, and the build system is also expected to +# provide the compiler with suitable options to enable it. +# +# Emacs, on recent releases of the NDK, prefers the libc++ library, the +# most complete of the libraries available, when it detects the presence +# of its headers and libraries in the compiler's search path. Next in +# line are the several libraries located in a directory named `cxx-stl' +# inside the NDK distribution, of which Emacs prefers, in this order, +# the GNU libstdc++, stlport, gabi and the system C++ library. The +# scope of the last two is confined to providing runtime support for +# basic C++ operations, and is useless for compiling most C++ +# dependencies whose requirements go beyond such operations. +# +# The NDK comes in two forms. In a "combined toolchain", all C++ +# libraries are present in the NDK directory and the responsibility is +# left to the build system to locate and select the best C++ library, +# whereas in a "standalone toolchain" an STL will have already been +# specified a C++ library, besides which no others will be present. +# +# Though Android.mk files are provided by the NDK for each such library, +# Emacs cannot use any of these, both for lack of prebuilt support in +# its ndk-build implementation, and since they are absent from combined +# toolchains. + +ndk_CXX_SHARED= +ndk_CXX_STL= +ndk_CXX_LDFLAGS= + +AS_IF([test -n "$CXX" && test -n "$ndk_install_dir"], + [ndk_library_dirs=`$CXX -print-search-dirs \ + | sed -n "s/^libraries:[[\t ]]*=\?\(.*\)/\1/p"` + AS_IF([test "$ndk_toolchain_type" = "standalone"], + [dnl With a standalone toolchain, just use the first C++ library + dnl present in the compiler's library search path, that being the + dnl only C++ library that will ever be present. + ndk_save_IFS=$IFS; IFS=: + for ndk_dir in $ndk_library_dirs; do + if test -d "$ndk_dir"; then :; else + continue + fi + ndk_dir=`cd "$ndk_dir"; pwd` + if test -f "$ndk_dir/libc++_shared.so"; then + ndk_CXX_SHARED="$ndk_dir/libc++_shared.so" + ndk_CXX_LDFLAGS=-lc++_shared; break + elif test -f "$ndk_dir/libgnustl_shared.so"; then + ndk_CXX_SHARED="$ndk_dir/libgnustl_shared.so" + ndk_CXX_LDFLAGS=-lgnustl_shared; break + elif test -f "$ndk_dir/libstlport_shared.so"; then + ndk_CXX_SHARED="$ndk_dir/libstlport_shared.so" + ndk_CXX_LDFLAGS=-lstlport_shared; break + fi + done + IFS=$ndk_save_IFS], + [dnl Otherwise, search for a suitable standard library + dnl in the order stated above. + dnl + dnl Detect if this compiler is configured to link against libc++ by + dnl default. + AC_MSG_CHECKING([whether compiler defaults to libc++]) + cat <<_ACEOF >conftest.cc +#include +#ifndef _LIBCPP_VERSION +Not libc++! +#endif /* _LIBCPP_VERSION */ + +int +main (void) +{ + +} +_ACEOF + AS_IF([$CXX conftest.cc -o conftest.o >&AS_MESSAGE_LOG_FD 2>&1], + [dnl The compiler defaults to libc++. + AC_MSG_RESULT([yes]) + ndk_save_IFS=$IFS; IFS=: + for ndk_dir in $ndk_library_dirs; do + if test -f "$ndk_dir/libc++_shared.so"; then + ndk_CXX_SHARED="$ndk_dir/libc++_shared.so" + ndk_CXX_LDFLAGS=-lc++_shared; break + fi + done + IFS=$ndk_save_IFS], + [dnl Search for gnustl, stlport, gabi, and failing that, system. + dnl The name of the gabi system root directory varies by GCC + dnl version. + AC_MSG_RESULT([no]) + ndk_gcc_version=`($CXX -v 2>&1) \ + | sed -n "s/^gcc version \([[0123456789]\+.[0123456789]\+]\).*/\1/p"` + cxx_stl="$ndk_install_dir/sources/cxx-stl" + ndk_cxx_stl_base="$cxx_stl/gnu-libstdc++/$ndk_gcc_version" + AS_IF([test -n "$ndk_gcc_version" \ + && test -d "$ndk_cxx_stl_base/libs/$ndk_ABI"], + [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lgnustl_shared" + ndk_CXX_LDFLAGS="$ndk_CXX_LDFLAGS -lsupc++" + ndk_CXX_STL="-isystem $ndk_cxx_stl_base/include" + ndk_CXX_STL="$ndk_CXX_STL -isystem $ndk_cxx_stl_base/libs/$ndk_ABI/include" + ndk_CXX_SHARED="$ndk_cxx_stl_base/libs/$ndk_ABI/libgnustl_shared.so"]) + AS_IF([test -f "$ndk_CXX_SHARED"], [], + [dnl No STL was located or the library is not reachable. + dnl Search for alternatives. + ndk_CXX_STL= + ndk_CXX_SHARED= + ndk_CXX_LDFLAGS= + ndk_cxx_stl_base="$cxx_stl/stlport" + AS_IF([test -d "$ndk_cxx_stl_base"], + [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lstlport_shared" + ndk_CXX_STL="-isystem $ndk_cxx_stl_base/stlport" + ndk_CXX_SHARED="$ndk_cxx_stl_base/libs/$ndk_ABI/libstlport_shared.so"]) + AS_IF([test -f "$ndk_CXX_SHARED"], [], + [ndk_CXX_STL= + ndk_CXX_SHARED= + ndk_CXX_LDFLAGS= + ndk_cxx_stl_base="$cxx_stl/gabi++" + AS_IF([test -d "$ndk_cxx_stl_base"], + [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lgabi++_shared" + ndk_CXX_STL="$ndk_CXX_STL -isystem $ndk_cxx_stl_base/include" + ndk_CXX_SHARED="$ndk_cxx_stl_base/libs/$ndk_ABI/lgabi++_shared.so"])]) + AS_IF([test -f "$ndk_CXX_SHARED"], [], + [ndk_CXX_STL= + ndk_CXX_SHARED= + ndk_CXX_LDFLAGS= + ndk_cxx_stl_base="$cxx_stl/system" + AS_IF([test -d "$ndk_cxx_stl_base"], + [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lstdc++" + ndk_CXX_STL="-isystem $ndk_cxx_stl_base/include" + dnl The "system" library is distributed with Android and + dnl need not be present in app packages. + ndk_CXX_SHARED= + dnl Done. + ])])])]) + rm -f conftest.o])]) + +AS_ECHO([]) +AS_ECHO(["C++ compiler configuration: "]) +AS_ECHO([]) +AS_ECHO(["Library includes : $ndk_CXX_STL"]) +AS_ECHO(["Linker options : $ndk_CXX_LDFLAGS"]) +AS_ECHO(["Library file (if any) : $ndk_CXX_SHARED"]) +AS_ECHO([]) ]) +# ndk_LATE_EARLY +# -------------- +# Call before ndk_LATE to establish certain variables in time for +# ndk_LATE's C++ compiler detection. + +AC_DEFUN([ndk_LATE_EARLY], +[ndk_save_LDFLAGS="$LDFLAGS" + LDFLAGS="$LDFLAGS $ndk_CXX_LDFLAGS" + CXXFLAGS="$CXXFLAGS `ndk_subst_cflags_onto_cxx` $ndk_CXX_STL"]) + # ndk_LATE # -------- # Perform late initialization of the ndk-build system by checking for @@ -347,17 +517,14 @@ AS_IF([test -n "$with_ndk_cxx"], [CXX=$with_ndk_cxx], AC_DEFUN([ndk_LATE], [dnl -dnl This calls AC_REQUIRE([AC_PROG_CXX]), leading to configure looking -dnl for a C++ compiler. However, the language is not restored -dnl afterwards if not `$ndk_INITIALIZED'. AS_IF([test "$ndk_INITIALIZED" = "yes"],[ - AS_IF([test -n "$CXX"], [AC_LANG_PUSH([C++]) + AS_IF([test -n "$CXX"], [ + AC_LANG_PUSH([C++]) AC_CHECK_HEADER([string], [ndk_working_cxx=yes], - [AC_MSG_WARN([Your C++ compiler is not properly set up, and\ - the standard library headers could not be found.])]) + [AC_MSG_WARN([Your C++ compiler is not properly configured, as \ +the standard library headers could not be found.])]) AC_LANG_POP([C++])])]) -dnl Thus, manually switch back to C here. -AC_LANG([C]) +LDFLAGS="$ndk_save_LDFLAGS" ]) # ndk_SEARCH_MODULE(MODULE, NAME, ACTION-IF-FOUND, [ACTION-IF-NOT-FOUND]) @@ -396,13 +563,14 @@ else ndk_ANY_CXX=yes fi - AS_IF([test "$ndk_ANY_CXX" = "yes" && test -z "$with_ndk_cxx_shared"], - [AC_MSG_ERROR([The module $1 requires the C++ standard library \ -(libc++_shared.so), but it was not found.])]) + AS_IF([test "$module_cxx_deps" = "yes" && test -z "$ndk_CXX_STL" \ + && test -z "$ndk_CXX_LDFLAGS"], + [AC_MSG_ERROR([The module $1 requires a C++ standard library, +but none were found.])]) - AS_IF([test "$ndk_ANY_CXX" = "yes" && test "$ndk_working_cxx" != "yes"], - [AC_MSG_ERROR([The module [$]1 requires the C++ standard library \ -(libc++_shared.so), but a working C++ compiler was not found.])]) + AS_IF([test "$module_cxx_deps" = "yes" && test "$ndk_working_cxx" != "yes"], + [AC_MSG_ERROR([The module [$]1 requires the C++ standard library, +but a working C++ compiler was not found.])]) $2[]_CFLAGS="[$]$2[]_CFLAGS $module_cflags $module_includes" $2[]_LIBS="[$]$2[]_LIBS $module_ldflags" @@ -457,6 +625,8 @@ AC_DEFUN_ONCE([ndk_CONFIG_FILES], NDK_BUILD_AR=$AR NDK_BUILD_MODULES="$ndk_MODULES" NDK_BUILD_CXX_SHARED="$ndk_CXX_SHARED" + NDK_BUILD_CXX_STL="$ndk_CXX_STL" + NDK_BUILD_CXX_LDFLAGS="$ndk_CXX_LDFLAGS" NDK_BUILD_ANY_CXX_MODULE=$ndk_ANY_CXX NDK_BUILD_CFLAGS="$ndk_BUILD_CFLAGS" @@ -470,6 +640,8 @@ AC_DEFUN_ONCE([ndk_CONFIG_FILES], AC_SUBST([NDK_BUILD_NASM]) AC_SUBST([NDK_BUILD_MODULES]) AC_SUBST([NDK_BUILD_CXX_SHARED]) + AC_SUBST([NDK_BUILD_CXX_STL]) + AC_SUBST([NDK_BUILD_CXX_LDFLAGS]) AC_SUBST([NDK_BUILD_ANY_CXX_MODULE]) AC_SUBST([NDK_BUILD_CFLAGS]) From 8014dbb2ad8c1163bedfda8c94f66d2bfa5b69ab Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 17 Mar 2024 13:25:35 +0100 Subject: [PATCH 075/155] * admin/notes/bugtracker: Minor copyedit. --- admin/notes/bugtracker | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/admin/notes/bugtracker b/admin/notes/bugtracker index 93532e02d20..419d91ae854 100644 --- a/admin/notes/bugtracker +++ b/admin/notes/bugtracker @@ -431,7 +431,7 @@ reassign 123 spam retitle 123 Some New Title *** To change the submitter name and address: -submitter 123 J. Hacker none@example.com +submitter 123 J. Hacker Note that it does not seem to work to specify "Submitter:" in the pseudo-header when first reporting a bug. From 21828f288ef57422d12860d71e3d4cd8b8cc97b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Mon, 12 Feb 2024 08:29:19 +0100 Subject: [PATCH 076/155] Fix vc-dir when "remote" Git branch is local While in there, add that "tracking" branch to the vc-dir buffer. For bug#68183. * lisp/vc/vc-git.el (vc-git-dir-extra-headers): Reduce boilerplate with new function 'vc-git--out-ok'; stop calling vc-git-repository-url when REMOTE is "." to avoid throwing an error; display tracking branch; prefer "none ()" to "not ()" since that reads more grammatically correct. (vc-git--out-ok): Add documentation. (vc-git--out-str): New function to easily get the output from a Git command. * test/lisp/vc/vc-git-tests.el (vc-git-test--with-repo) (vc-git-test--run): New helpers, defined to steer clear of vc-git-- internal functions. (vc-git-test-dir-track-local-branch): Check that vc-dir does not crash. --- lisp/vc/vc-git.el | 46 +++++++++++++++++++++++++----------- test/lisp/vc/vc-git-tests.el | 40 +++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 14 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 18b4a8691e9..0d54e234659 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -817,27 +817,31 @@ or an empty string if none." cmds)) (defun vc-git-dir-extra-headers (dir) - (let ((str (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "symbolic-ref" "HEAD")))) + (let ((str (vc-git--out-str "symbolic-ref" "HEAD")) (stash-list (vc-git-stash-list)) (default-directory dir) (in-progress (vc-git--cmds-in-progress)) - branch remote remote-url stash-button stash-string) + branch remote-url stash-button stash-string tracking-branch) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) (progn (setq branch (match-string 2 str)) - (setq remote - (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "config" - (concat "branch." branch ".remote"))))) - (when (string-match "\\([^\n]+\\)" remote) - (setq remote (match-string 1 remote))) - (when (> (length remote) 0) - (setq remote-url (vc-git-repository-url dir remote)))) - (setq branch "not (detached HEAD)")) + (let ((remote (vc-git--out-str + "config" (concat "branch." branch ".remote"))) + (merge (vc-git--out-str + "config" (concat "branch." branch ".merge")))) + (when (string-match "\\([^\n]+\\)" remote) + (setq remote (match-string 1 remote))) + (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge) + (setq tracking-branch (match-string 2 merge))) + (pcase remote + ("." + (setq remote-url "none (tracking local branch)")) + ((pred (not string-empty-p)) + (setq + remote-url (vc-git-repository-url dir remote) + tracking-branch (concat remote "/" tracking-branch)))))) + (setq branch "none (detached HEAD)")) (when stash-list (let* ((len (length stash-list)) (limit @@ -890,6 +894,11 @@ or an empty string if none." (propertize "Branch : " 'face 'vc-dir-header) (propertize branch 'face 'vc-dir-header-value) + (when tracking-branch + (concat + "\n" + (propertize "Tracking : " 'face 'vc-dir-header) + (propertize tracking-branch 'face 'vc-dir-header-value))) (when remote-url (concat "\n" @@ -2226,8 +2235,17 @@ The difference to vc-do-command is that this function always invokes (apply #'process-file vc-git-program nil buffer nil "--no-pager" command args))) (defun vc-git--out-ok (command &rest args) + "Run `git COMMAND ARGS...' and insert standard output in current buffer. +Return whether the process exited with status zero." (zerop (apply #'vc-git--call '(t nil) command args))) +(defun vc-git--out-str (command &rest args) + "Run `git COMMAND ARGS...' and return standard output. +The exit status is ignored." + (with-output-to-string + (with-current-buffer standard-output + (apply #'vc-git--out-ok command args)))) + (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string. FILE can be nil." diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index c52cd9c5875..fd3e8ccd602 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -24,6 +24,8 @@ ;;; Code: +(require 'ert-x) +(require 'vc) (require 'vc-git) (ert-deftest vc-git-test-program-version-general () @@ -81,4 +83,42 @@ (should-not (vc-git-annotate-time)) (should-not (vc-git-annotate-time)))) +(defmacro vc-git-test--with-repo (name &rest body) + "Initialize a repository in a temporary directory and evaluate BODY. + +The current directory will be set to the top of that repository; NAME +will be bound to that directory's file name. Once BODY exits, the +directory will be deleted." + (declare (indent 1)) + `(ert-with-temp-directory ,name + (let ((default-directory ,name)) + (vc-create-repo 'Git) + ,@body))) + +(defun vc-git-test--run (&rest args) + "Run git ARGS…, check for non-zero status, and return output." + (with-temp-buffer + (apply 'vc-git-command t 0 nil args) + (buffer-string))) + +(ert-deftest vc-git-test-dir-track-local-branch () + "Test that `vc-dir' works when tracking local branches. Bug#68183." + (skip-unless (executable-find vc-git-program)) + (vc-git-test--with-repo repo + ;; Create an initial commit to get a branch started. + (write-region "hello" nil "README") + (vc-git-test--run "add" "README") + (vc-git-test--run "commit" "-mFirst") + ;; Get current branch name lazily, to remain agnostic of + ;; init.defaultbranch. + (let ((upstream-branch + (string-trim (vc-git-test--run "branch" "--show-current")))) + (vc-git-test--run "checkout" "--track" "-b" "hack" upstream-branch) + (vc-dir default-directory) + (pcase-dolist (`(,header ,value) + `(("Branch" "hack") + ("Tracking" ,upstream-branch))) + (goto-char (point-min)) + (re-search-forward (format "^%s *: %s$" header value)))))) + ;;; vc-git-tests.el ends here From 67b0c1c09eab65c302eb02b20d87900be6367565 Mon Sep 17 00:00:00 2001 From: Protesilaos Stavrou Date: Sun, 17 Mar 2024 18:46:15 +0200 Subject: [PATCH 077/155] Update modus-themes to their 4.4.0 version * doc/misc/modus-themes.org: Update the manual to better document existing functionality and cover the new features. * etc/themes/modus-operandi-deuteranopia-theme.el: * etc/themes/modus-operandi-theme.el: * etc/themes/modus-operandi-tinted-theme.el: * etc/themes/modus-operandi-tritanopia-theme.el: * etc/themes/modus-vivendi-deuteranopia-theme.el: * etc/themes/modus-vivendi-theme.el: * etc/themes/modus-vivendi-tinted-theme.el: * etc/themes/modus-vivendi-tritanopia-theme.el: Update the palette of each theme. * etc/themes/modus-themes.el (require): Remove call to cl-lib and do not use relevant functions. (modus-themes-operandi-colors, modus-themes-vivendi-colors) (modus-themes-version, modus-themes-report-bug): Remove old calls to 'make-obsolete' and related. (modus-themes--annotate-theme): Tweak the completion annotation function. (modus-themes--org-block): Deprecate the user option 'modus-themes-org-blocks'. (modus-themes-faces): Update faces. (modus-themes-custom-variables): Update the list of custom variables. Detailed release notes are available here: . --- doc/misc/modus-themes.org | 1433 +++++++++-------- .../modus-operandi-deuteranopia-theme.el | 77 +- etc/themes/modus-operandi-theme.el | 75 +- etc/themes/modus-operandi-tinted-theme.el | 84 +- etc/themes/modus-operandi-tritanopia-theme.el | 77 +- etc/themes/modus-themes.el | 545 +++---- .../modus-vivendi-deuteranopia-theme.el | 78 +- etc/themes/modus-vivendi-theme.el | 77 +- etc/themes/modus-vivendi-tinted-theme.el | 96 +- etc/themes/modus-vivendi-tritanopia-theme.el | 77 +- lisp/vc/vc-git.el | 46 +- test/lisp/vc/vc-git-tests.el | 40 - 12 files changed, 1427 insertions(+), 1278 deletions(-) diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org index 45f96778203..c3de15c35ad 100644 --- a/doc/misc/modus-themes.org +++ b/doc/misc/modus-themes.org @@ -4,9 +4,9 @@ #+language: en #+options: ':t toc:nil author:t email:t num:t #+startup: content -#+macro: stable-version 4.3.0 -#+macro: release-date 2023-09-19 -#+macro: development-version 4.4.0-dev +#+macro: stable-version 4.4.0 +#+macro: release-date 2024-03-17 +#+macro: development-version 4.5.0-dev #+macro: file @@texinfo:@file{@@$1@@texinfo:}@@ #+macro: space @@texinfo:@: @@ #+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@ @@ -37,12 +37,10 @@ Current development target is {{{development-version}}}. + Change log: + Color palette: + Sample pictures: -+ Git repo on SourceHut: - - Mirrors: - + GitHub: - + GitLab: -+ Mailing list: -+ Backronym: My Old Display Unexpectedly Sharpened ... themes ++ Git repositories: + + GitHub: + + GitLab: ++ Backronym: My Old Display Unexpectedly Sharpened ... themes. #+toc: headlines 8 insert TOC here, with eight headline levels @@ -90,7 +88,7 @@ The Modus themes consist of eight themes, divided into four subgroups. are variants of the two main themes. They slightly tone down the intensity of the background and provide a bit more color variety. ~modus-operandi-tinted~ has a set of base tones that are shades of - light ocher (earthly colors), while ~modus-vivendi-tinted~ gives a + light ochre (earthly colors), while ~modus-vivendi-tinted~ gives a night sky impression. - Deuteranopia themes :: ~modus-operandi-deuteranopia~ and its @@ -265,9 +263,6 @@ wrong. :properties: :custom_id: h:3f3c3728-1b34-437d-9d0c-b110f5b161a9 :end: -#+findex: modus-themes-toggle -#+findex: modus-themes-load-theme -#+vindex: modus-themes-after-load-theme-hook #+cindex: Essential configuration NOTE that Emacs can load multiple themes, which typically produces @@ -285,7 +280,7 @@ theme of their preference by adding either form to their init file: (load-theme 'modus-vivendi) ; Dark theme #+end_src -Remember that the Modus themes are six themes ([[#h:f0f3dbcb-602d-40cf-b918-8f929c441baf][Overview]]). Adapt the +Remember that there are multiple Modus themes ([[#h:f0f3dbcb-602d-40cf-b918-8f929c441baf][Overview]]). Adapt the above snippet accordingly. Users of packaged variants of the themes must add a few more lines to @@ -342,6 +337,38 @@ This is how a basic setup could look like ([[#h:b66b128d-54a4-4265-b59f-4d1ea2fe [[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration with and without use-package]]. +To disable other themes before loading a Modus theme, use something +like this: + +#+begin_src emacs-lisp +(mapc #'disable-theme custom-enabled-themes) +(load-theme 'modus-operandi :no-confirm) +#+end_src + +#+findex: modus-themes-load-theme +Instead of using the basic ~load-theme~ function, users can rely on +the ~modus-themes-load-theme~. It accepts a single argument, which is +a symbol representing the Modus theme of choice, such as: + +#+begin_src emacs-lisp +(modus-themes-load-theme 'modus-operandi) +#+end_src + +#+vindex: modus-themes-after-load-theme-hook +#+vindex: modus-themes-post-load-hook +The ~modus-themes-load-theme~ takes care to disable other themes, if +the user opts in ([[#h:adb0c49a-f1f9-4690-868b-013a080eed68][Option for disabling other themes while loading Modus]]). +After loading the theme of choice, this function calls the +hook ~modus-themes-after-load-theme-hook~ (alias ~modus-themes-post-load-hook~). +Users can add their own functions to this hook to make further +customizations ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). + +#+findex: modus-themes-toggle +#+findex: modus-themes-select +The commands ~modus-themes-toggle~ and ~modus-themes-select~ use +~modus-themes-load-theme~ internally ([[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]]). +The aforementioned hold true for them as well. + ** The ~require-theme~ for built-in Emacs themes :PROPERTIES: :CUSTOM_ID: h:b66b128d-54a4-4265-b59f-4d1ea2feb073 @@ -449,8 +476,6 @@ will lead to failures in loading the files. If either or both of those variables need to be changed, their values should be defined before the package declaration of the themes. -[[#h:aabcada6-810d-4eee-b34a-d2a9c301824d][Make the themes look like what the maintainer uses]] - ** Differences between loading and enabling :properties: :custom_id: h:e68560b3-7fb0-42bc-a151-e015948f8a35 @@ -608,9 +633,9 @@ Possible values: When the value is non-~nil~, the commands ~modus-themes-toggle~ and ~modus-themes-select~, as well as the ~modus-themes-load-theme~ function, will disable all other themes while loading the specified -Modus theme. This is done to ensure that Emacs does not blend two or -more themes: such blends lead to awkward results that undermine the -work of the designer. +Modus theme ([[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]]). This is done to +ensure that Emacs does not blend two or more themes: such blends lead +to awkward results that undermine the work of the designer. When the value is ~nil~, the aforementioned commands and function will only disable other themes within the Modus collection. @@ -678,6 +703,32 @@ Advanced users may also want to configure the exact attributes of the [[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]]. +** Option for which themes to toggle +:PROPERTIES: +:CUSTOM_ID: h:4fbfed66-5a89-447a-a07d-a03f6819c5bd +:END: +#+vindex: modus-themes-to-toggle + +Brief: Choose to Modus themes to toggle between + +Symbol: ~modus-themes-to-toggle~ (=list= type) + +Default value: ='(modus-operandi modus-vivendi)= + +Possible values: + +- ~modus-operandi~ +- ~modus-vivendi~ +- ~modus-operandi-tinted~ +- ~modus-vivendi-tinted~ +- ~modus-operandi-deuteranopia~ +- ~modus-vivendi-deuteranopia~ +- ~modus-operandi-tritanopia~ +- ~modus-vivendi-tritanopia~ + +Specify two themes to toggle between using the command +~modus-themes-toggle~. + ** Option for font mixing :properties: :alt_title: Mixed fonts @@ -851,43 +902,13 @@ Is the same as: :end: #+vindex: modus-themes-org-blocks -Brief: Set the overall style of Org code blocks, quotes, and the like. +As part of version =4.4.0=, the ~modus-themes-org-blocks~ is no more. +Users can apply palette overrides to set a style that fits their +preference (purple, blue, yellow, green, etc.). It is more flexible +and more powerful ([[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][DIY Make Org block colors more or less colorful]]) -Symbol: ~modus-themes-org-blocks~ (=choice= type) - -Possible values: - -1. ~nil~ (default) -2. ~gray-background~ -3. ~tinted-background~ - -Option ~nil~ (the default) means that the block has no background of -its own: it uses the one that applies to the rest of the buffer. -In this case, the delimiter lines have a gray color for their text, -making them look exactly like all other Org properties. - -Option ~gray-background~ applies a subtle gray background to the -block's contents. It also affects the begin and end lines of the -block as they get another shade of gray as their background, which -differentiates them from the contents of the block. All background -colors extend to the edge of the window, giving the area a -rectangular, "blocky" presentation. If the begin/end lines do not -extend in this way, check the value of the Org user option -~org-fontify-whole-block-delimiter-line~. - -Option ~tinted-background~ uses a colored background for the contents -of the block. The exact color value will depend on the programming -language and is controlled by the variable ~org-src-block-faces~ -(refer to the theme's source code for the current association list). -For this to take effect, the Org buffer needs to be restarted with -~org-mode-restart~. - -Code blocks use their major mode's fontification (syntax highlighting) -only when the variable ~org-src-fontify-natively~ is non-~nil~. While -quote/verse blocks require setting -~org-fontify-quote-and-verse-blocks~ to a non-~nil~ value. - -[[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][Update Org block delimiter fontification]]. +For the option to change the background of Org source blocks, we +provide the relevant setup ([[#h:8c842804-43b7-4287-b4e9-8c07d04d1f89][DIY Use colored Org source blocks per language]]). ** Option for the headings' overall style :properties: @@ -1169,22 +1190,175 @@ Named colors can be previewed, such as with the command For a video tutorial that users of all skill levels can approach, watch: https://protesilaos.com/codelog/2022-12-17-modus-themes-v4-demo/. +* Preview theme colors +:properties: +:custom_id: h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d +:end: +#+cindex: Preview named colors or semantic color mappings + +#+findex: modus-themes-list-colors +The command ~modus-themes-list-colors~ uses minibuffer completion to +select an item from the Modus themes and then produces a buffer with +previews of its color palette entries. The buffer has a naming scheme +that reflects the given choice, like =modus-operandi-list-colors= for +the ~modus-operandi~ theme. + +#+findex: modus-themes-list-colors-current +The command ~modus-themes-list-colors-current~ skips the minibuffer +selection process and just produces a preview for the current Modus +theme. + +When called with a prefix argument (=C-u= with the default key +bindings), these commands will show a preview of the palette's +semantic color mappings instead of the named colors. In this context, +"named colors" are entries that associate a symbol to a string color +value, such as =(blue-warmer "#354fcf")=. Whereas "semantic color +mappings" associate a named color to a symbol, like =(string +blue-warmer)=, thus making the theme render all string constructs in +the =blue-warmer= color value ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). + +#+findex: modus-themes-preview-colors +#+findex: modus-themes-preview-colors-current +Aliases for those commands are ~modus-themes-preview-colors~ and +~modus-themes-preview-colors-current~. + +Each row shows a foreground and background coloration using the +underlying value it references. For example a line with =#a60000= (a +shade of red) will show red text followed by a stripe with that same +color as a backdrop. + +The name of the buffer describes the given Modus theme and what the +contents are, such as =*modus-operandi-list-colors*= for named colors +and ==*modus-operandi-list-mappings*= for the semantic color mappings. + +* Use colors from the Modus themes palette +:PROPERTIES: +:CUSTOM_ID: h:33460ae8-984b-40fd-8baa-383cc5fc2698 +:END: + +The Modus themes provide the means to access the palette of (i) the +active theme or (ii) any theme in the Modus collection. These are +useful for Do-It-Yourself customizations ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]), +though it can also be helpful in other cases, such as to reuse a color +value in some other application. + +- Function :: [[#h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e][Get a single color from the palette with ~modus-themes-get-color-value~]] +- Macro :: [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with ~modus-themes-with-colors~]]. + +** Get a single color from the palette with ~modus-themes-get-color-value~ +:PROPERTIES: +:CUSTOM_ID: h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e +:END: + +#+findex: modus-themes-get-color-value +The fuction ~modus-themes-get-color-value~ can be called from Lisp to +return the value of a color from the active Modus theme palette. It +takea a =COLOR= argument and an optional =OVERRIDES=. It also accepts +a third =THEME= argument, to get the color from the given theme. + +=COLOR= is a symbol that represents a named color entry in the +palette ([[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]). + +If the value is the name of another color entry in the palette (so a +mapping), this function recurs until it finds the underlying color +value. + +With an optional =OVERRIDES= argument as a non-~nil~ value, it +accounts for palette overrides. Else it reads only the default palette +([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]) + +With an optional =THEME= as a symbol among the ~modus-themes-items~ +(alias ~modus-themes-collection~), it uses the palette of that theme. +Else it uses the current Modus theme. + +If =COLOR= is not present in the palette, this function returns the +~unspecified~ symbol, which is safe when used as a face attribute's +value. + +An example with ~modus-operandi~ to show how this function behaves +with/without overrides and when recursive mappings are introduced. + +#+begin_src emacs-lisp +;; Here we show the recursion of palette mappings. In general, it is +;; better for the user to specify named colors to avoid possible +;; confusion with their configuration, though those still work as +;; expected. +(setq modus-themes-common-palette-overrides + '((cursor red) + (fg-mode-line-active cursor) + (border-mode-line-active fg-mode-line-active))) + +;; Ignore the overrides and get the original value. +(modus-themes-get-color-value 'border-mode-line-active) +;; => "#5a5a5a" + +;; Read from the overrides and deal with any recursion to find the +;; underlying value. +(modus-themes-get-color-value 'border-mode-line-active :overrides) +;; => "#a60000" +#+end_src + +** Use theme colors in code with ~modus-themes-with-colors~ +:properties: +:custom_id: h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae +:end: +#+cindex: Use colors from the palette anywhere + +[ Note that for common cases the following is not not needed. Just rely on + the comprehensive overrides we provide ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). ] + +#+findex: modus-themes-with-colors +Advanced users may want to apply many colors from the palette of the +active Modus theme in their custom code. In such a case, retrieving +each value with the function ~modus-themes-get-color-value~ is +inefficient ([[#h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e][Get a single color from the palette]]). The Lisp macro +~modus-themes-with-colors~ provides the requisite functionality. It +supplies the current theme's palette to the code called from inside of +it. For example: + +#+begin_src emacs-lisp +(modus-themes-with-colors + (list blue-warmer magenta-cooler fg-added warning variable fg-heading-4)) +;; => ("#354fcf" "#531ab6" "#005000" "#884900" "#005e8b" "#721045") +#+end_src + +The above return value is for ~modus-operandi~ when that is the active +theme. Switching to another theme and evaluating this code anew will +return the relevant results for that theme (remember that since +version 4, the Modus themes consist of many items ([[#h:f0f3dbcb-602d-40cf-b918-8f929c441baf][Overview]])). The +same with ~modus-vivendi~ as the active theme: + +#+begin_src emacs-lisp +(modus-themes-with-colors + (list blue-warmer magenta-cooler fg-added warning variable fg-heading-4)) +;; => ("#79a8ff" "#b6a0ff" "#a0e0a0" "#fec43f" "#00d3d0" "#feacd0") +#+end_src + +The ~modus-themes-with-colors~ has access to the whole palette of the +active theme, meaning that it can instantiate both (i) named colors +like =blue-warmer= and (ii) semantic color mappings like =warning=. +We provide commands to inspect those ([[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]). + +Others sections in this manual show how to use the aforementioned +macro ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). In practice, the use of a hook will +also be needed ([[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][DIY Use a hook at the post-load-theme phase]]). + * Advanced customization :properties: :custom_id: h:f4651d55-8c07-46aa-b52b-bed1e53463bb :end: -Unlike the predefined customization options which follow a clear pattern -of allowing the user to quickly specify their preference, the themes -also provide a more flexible, albeit difficult, mechanism to control -things with precision ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]). +Unlike the predefined customization options which follow a clear +pattern of allowing the user to quickly specify their preference, the +themes also provide a more flexible, albeit a bit more difficult, +mechanism to control things with precision ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]). This section is of interest only to users who are prepared to maintain their own local tweaks and who are willing to deal with any possible -incompatibilities between versioned releases of the themes. As such, +incompatibilities between versioned releases of the themes. As such, they are labeled as "do-it-yourself" or "DIY". -** Palette override presets +** DIY Palette override presets :PROPERTIES: :CUSTOM_ID: h:b0bc811c-227e-42ec-bf67-15e1f41eb7bc :END: @@ -1257,7 +1431,7 @@ the general idea (extra space for didactic purposes): ,@modus-themes-preset-overrides-intense)) #+end_src -** Stylistic variants using palette overrides +** DIY Stylistic variants using palette overrides :PROPERTIES: :CUSTOM_ID: h:df1199d8-eaba-47db-805d-6b568a577bf3 :END: @@ -1269,7 +1443,7 @@ to take effect. To apply overrides at startup simply define them before the call that loads the theme. Remember that we also provide presets that are easier to apply ([[#h:b0bc811c-227e-42ec-bf67-15e1f41eb7bc][Palette override presets]]). -*** Make the mode line borderless +*** DIY Make the mode line borderless :PROPERTIES: :CUSTOM_ID: h:80ddba52-e188-411f-8cc0-480ebd75befe :END: @@ -1284,14 +1458,6 @@ set their color to that of the underlying background. [[#h:5a0c58cc-f97f-429c-be08-927b9fbb0a9c][Add padding to mode line]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Remove the border (setq modus-themes-common-palette-overrides '((border-mode-line-active unspecified) @@ -1306,7 +1472,9 @@ set their color to that of the underlying background. (border-mode-line-inactive bg-mode-line-inactive))) #+end_src -*** Make the active mode line colorful +Reload the theme for changes to take effect. + +*** DIY Make the active mode line colorful :PROPERTIES: :CUSTOM_ID: h:e8d781be-eefc-4a81-ac4e-5ed156190df7 :END: @@ -1323,14 +1491,6 @@ have a blue mode line for ~modus-operandi~ and a red one for [[#h:5a0c58cc-f97f-429c-be08-927b9fbb0a9c][Add padding to mode line]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Blue background, neutral foreground, intense blue border (setq modus-themes-common-palette-overrides '((bg-mode-line-active bg-blue-intense) @@ -1343,14 +1503,28 @@ have a blue mode line for ~modus-operandi~ and a red one for (fg-mode-line-active fg-main) (border-mode-line-active blue-intense))) -;; Subtle red background, red foreground, invisible border +;; Sage (green/cyan) background, neutral foreground, slightly distinct green border (setq modus-themes-common-palette-overrides - '((bg-mode-line-active bg-red-subtle) - (fg-mode-line-active red-warmer) - (border-mode-line-active bg-red-subtle))) + '((bg-mode-line-active bg-sage) + (fg-mode-line-active fg-main) + (border-mode-line-active bg-green-intense))) + +;; As above, but with a purple style +(setq modus-themes-common-palette-overrides + '((bg-mode-line-active bg-lavender) + (fg-mode-line-active fg-main) + (border-mode-line-active bg-magenta-intense))) + +;; As above, but with an earthly style +(setq modus-themes-common-palette-overrides + '((bg-mode-line-active bg-ochre) + (fg-mode-line-active fg-main) + (border-mode-line-active bg-yellow-intense))) #+end_src -*** Make the tab bar more or less colorful +Reload the theme for changes to take effect. + +*** DIY Make the tab bar more or less colorful :PROPERTIES: :CUSTOM_ID: h:096658d7-a0bd-4a99-b6dc-9b20a20cda37 :END: @@ -1365,15 +1539,6 @@ fringes, and line numbers. These are shown in other sections of this manual. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; Make the `tab-bar-mode' mode subtle while keepings its original ;; gray aesthetic. (setq modus-themes-common-palette-overrides @@ -1402,7 +1567,9 @@ manual. (bg-tab-other bg-cyan-subtle))) #+end_src -*** Make the fringe invisible or another color +Reload the theme for changes to take effect. + +*** DIY Make the fringe invisible or another color :PROPERTIES: :CUSTOM_ID: h:c312dcac-36b6-4a1f-b1f5-ab1c9abe27b0 :END: @@ -1415,14 +1582,6 @@ side of the Emacs window which shows indicators such as for truncation or continuation lines. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Make the fringe invisible (setq modus-themes-common-palette-overrides '((fringe unspecified))) @@ -1436,7 +1595,9 @@ or continuation lines. '((fringe bg-blue-nuanced))) #+end_src -*** Make links use subtle or no underlines +Reload the theme for changes to take effect. + +*** DIY Make links use subtle or no underlines :PROPERTIES: :CUSTOM_ID: h:6c1d1dea-5cbf-4d92-b7bb-570a7a23ffe9 :END: @@ -1460,7 +1621,9 @@ that underline mappings can read correctly. (underline-link-symbolic unspecified))) #+end_src -*** Make prompts more or less colorful +Reload the theme for changes to take effect. + +*** DIY Make prompts more or less colorful :PROPERTIES: :CUSTOM_ID: h:bd75b43a-0bf1-45e7-b8b4-20944ca8b7f8 :END: @@ -1472,14 +1635,6 @@ block we show how to add or remove color from prompts. [[#h:db5a9a7c-2928-4a28-b0f0-6f2b9bd52ba1][Option for command prompt styles]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Keep the background unspecified (like the default), but use a faint ;; foreground color. (setq modus-themes-common-palette-overrides @@ -1497,7 +1652,9 @@ block we show how to add or remove color from prompts. (bg-prompt bg-yellow-subtle))) ; try to replace "subtle" with "intense" #+end_src -*** Make completion matches more or less colorful +Reload the theme for changes to take effect. + +*** DIY Make completion matches more or less colorful :PROPERTIES: :CUSTOM_ID: h:d959f789-0517-4636-8780-18123f936f91 :END: @@ -1510,14 +1667,6 @@ three different degrees of intensity. [[#h:f1c20c02-7b34-4c35-9c65-99170efb2882][Option for completion framework aesthetics]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Add a nuanced background color to completion matches, while keeping ;; their foreground intact (foregrounds do not need to be specified in ;; this case, but we do it for didactic purposes). @@ -1584,7 +1733,9 @@ colors to two: The user can mix and match to their liking. -*** Make comments yellow and strings green +Reload the theme for changes to take effect. + +*** DIY Make comments yellow and strings green :PROPERTIES: :CUSTOM_ID: h:26f53daa-0065-48dc-88ab-6a718d16cd95 :END: @@ -1601,14 +1752,6 @@ reproduce the effect, but also how to tweak it to one's liking. [[#h:943063da-7b27-4ba4-9afe-f8fe77652fd1][Make use of alternative styles for code syntax]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Yellow comments and green strings like older versions of the Modus ;; themes (setq modus-themes-common-palette-overrides @@ -1627,7 +1770,9 @@ reproduce the effect, but also how to tweak it to one's liking. (string yellow-cooler))) #+end_src -*** Make code syntax use the old alt-syntax style +Reload the theme for changes to take effect. + +*** DIY Make code syntax use the old alt-syntax style :PROPERTIES: :CUSTOM_ID: h:c8767172-bf11-4c96-81dc-e736c464fc9c :END: @@ -1640,16 +1785,7 @@ upside of using overrides for this purpose is that we can tweak the style to our liking, but first let's start with its recreation: #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - -;; The old "alt-syntax" +;; The old "alt-syntax" (before version 4.0.0 of the Modus themes) (setq modus-themes-common-palette-overrides '((builtin magenta) (comment fg-dim) @@ -1712,7 +1848,9 @@ The user can always mix and match styles to their liking. [[#h:943063da-7b27-4ba4-9afe-f8fe77652fd1][Make use of alternative styles for code syntax]]. -*** Make use of alternative styles for code syntax +Reload the theme for changes to take effect. + +*** DIY Make use of alternative styles for code syntax :PROPERTIES: :CUSTOM_ID: h:943063da-7b27-4ba4-9afe-f8fe77652fd1 :END: @@ -1730,18 +1868,9 @@ theme palette. [[#h:26f53daa-0065-48dc-88ab-6a718d16cd95][Make comments yellow and strings green]]. -[[*Make code syntax use the old alt-syntax style][Make code syntax use the old alt-syntax style]]. +[[#h:c8767172-bf11-4c96-81dc-e736c464fc9c][Make code syntax use the old alt-syntax style]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; Mimic `ef-night' theme (from my `ef-themes') for code syntax ;; highlighting, while still using the Modus colors (and other ;; mappings). @@ -1803,7 +1932,9 @@ theme palette. (variable cyan-warmer))) #+end_src -*** Make matching parenthesis more or less intense +Reload the theme for changes to take effect. + +*** DIY Make matching parenthesis more or less intense :PROPERTIES: :CUSTOM_ID: h:259cf8f5-48ec-4b13-8a69-5d6387094468 :END: @@ -1815,14 +1946,6 @@ delimiters when ~show-paren-mode~ is enabled. We also demonstrate how to enable underlines for those highlights. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Change the background to a shade of magenta (setq modus-themes-common-palette-overrides '((bg-paren-match bg-magenta-intense))) @@ -1831,9 +1954,17 @@ to enable underlines for those highlights. (setq modus-themes-common-palette-overrides '((bg-paren-match bg-magenta-intense) (underline-paren-match fg-main))) + +;; Do not use any background color and instead apply an intense red +;; foreground. +(setq modus-themes-common-palette-overrides + '((bg-paren-match unspecified) + (fg-paren-match red-intense))) #+end_src -*** Make box buttons more or less gray +Reload the theme for changes to take effect. + +*** DIY Make box buttons more or less gray :PROPERTIES: :CUSTOM_ID: h:4f6b6ca3-f5bb-4830-8312-baa232305360 :END: @@ -1846,14 +1977,6 @@ removes the gray from the active buttons and amplifies it for the inactive ones. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - (setq modus-themes-common-palette-overrides '((bg-button-active bg-main) (fg-button-active fg-main) @@ -1861,7 +1984,9 @@ inactive ones. (fg-button-inactive "gray50"))) #+end_src -*** Make TODO and DONE more or less intense +Reload the theme for changes to take effect. + +*** DIY Make TODO and DONE more or less intense :PROPERTIES: :CUSTOM_ID: h:b57bb50b-a863-4ea8-bb38-6de2275fa868 :END: @@ -1877,14 +2002,6 @@ to subdue them. [[#h:bb5b396f-5532-4d52-ab13-149ca24854f1][Make inline code in prose use alternative styles]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Increase intensity (setq modus-themes-common-palette-overrides '((prose-done green-intense) @@ -1901,7 +2018,9 @@ to subdue them. '((prose-done fg-dim))) #+end_src -*** Make headings more or less colorful +Reload the theme for changes to take effect. + +*** DIY Make headings more or less colorful :PROPERTIES: :CUSTOM_ID: h:11297984-85ea-4678-abe9-a73aeab4676a :END: @@ -1916,15 +2035,6 @@ match styles at will. [[#h:b57bb50b-a863-4ea8-bb38-6de2275fa868][Make TODO and DONE more intense]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; Apply more colorful foreground to some headings (headings 0-8). ;; Level 0 is for Org #+title and related. (setq modus-themes-common-palette-overrides @@ -1958,7 +2068,107 @@ match styles at will. (overline-heading-1 border))) #+end_src -*** Make Org agenda more or less colorful +Reload the theme for changes to take effect. + +*** DIY Make Org block colors more or less colorful +:properties: +:custom_id: h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50 +:end: + +This is one of our practical examples to override the semantic colors +of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). Here +we show how to change the presentation of Org blocks (and other such +blocks like Markdown fenced code sections, though the exact +presentation depends on each major mode). + +The default style of Org blocks is a subtle gray background for the +contents and for the delimiter lines (the =#+begin_= and =#+end_= +parts). The text of the delimiter lines is a subtle gray foreground +color. + +[[#h:bb5b396f-5532-4d52-ab13-149ca24854f1][Make inline code in prose use alternative styles]]. + +#+begin_src emacs-lisp +;; Make code blocks (in Org, for example) use a more colorful style +;; for their delimiter lines as well as their contents. Give this a +;; purple feel. Make the delimiter lines distinct from the contents. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-magenta-nuanced) + (bg-prose-block-delimiter bg-lavender) + (fg-prose-block-delimiter fg-main))) + +;; As above, but with a more blue feel. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-blue-nuanced) + (bg-prose-block-delimiter bg-lavender) + (fg-prose-block-delimiter fg-main))) + +;; As above, but with a green feel. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-green-nuanced) + (bg-prose-block-delimiter bg-sage) + (fg-prose-block-delimiter fg-main))) + +;; As above, but with a yellow/gold feel. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-yellow-nuanced) + (bg-prose-block-delimiter bg-ochre) + (fg-prose-block-delimiter fg-main))) + +;; As above, but with a slightly more red feel. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-red-nuanced) + (bg-prose-block-delimiter bg-ochre) + (fg-prose-block-delimiter fg-main))) +#+end_src + +The previous examples differentiate the delimiter lines from the +block's contents. Though we can mimic the default aesthetic of a +uniform background, while changing the applicable colors. Here are +some nice combinations: + +#+begin_src emacs-lisp +;; Solid green style. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-green-nuanced) + (bg-prose-block-delimiter bg-green-nuanced) + (fg-prose-block-delimiter green-warmer))) + +;; Solid yellow style. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-yellow-nuanced) + (bg-prose-block-delimiter bg-yellow-nuanced) + (fg-prose-block-delimiter yellow-cooler))) + +;; Solid cyan style. +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents bg-cyan-nuanced) + (bg-prose-block-delimiter bg-cyan-nuanced) + (fg-prose-block-delimiter cyan-cooler))) +#+end_src + +[ Combine the above with a suitable mode line style for maximum effect + ([[#h:e8d781be-eefc-4a81-ac4e-5ed156190df7][DIY Make the active mode line colorful]]). ] + +Finally, the following makes code blocks have no distinct background. +The minimal styles are applied to the delimiter lines, which only use +a subtle gray foreground. This was the default for the Modus themes up +until version 4.3.0. + +#+begin_src emacs-lisp +;; Make code blocks more minimal, so that (i) the delimiter lines have +;; no background, (ii) the delimiter foreground is a subtle gray, and +;; (iii) the block contents have no distinct background either. This +;; was the default in versions of the Modus themes before 4.4.0 +(setq modus-themes-common-palette-overrides + '((bg-prose-block-contents unspecified) + (bg-prose-block-delimiter unspeficied) + (fg-prose-block-delimiter fg-dim))) +#+end_src + +[[#h:8c842804-43b7-4287-b4e9-8c07d04d1f89][DIY Use colored Org source blocks per language]]. + +*** DIY Make Org agenda more or less colorful :PROPERTIES: :CUSTOM_ID: h:a5af0452-a50f-481d-bf60-d8143f98105f :END: @@ -1973,14 +2183,6 @@ these styles with what we show in the other chapters with practical stylistic variants. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - ;; Make the Org agenda use alternative and varied colors. (setq modus-themes-common-palette-overrides '((date-common cyan) ; default value (for timestamps and more) @@ -2004,7 +2206,7 @@ An example with faint coloration: (date-holiday magenta) ; default (for M-x calendar) (date-now fg-main) ; default (date-scheduled yellow-faint) - (date-weekday fg-dim) + (date-weekday fg-alt) (date-weekend fg-dim))) #+end_src @@ -2041,7 +2243,9 @@ Yet another example that also affects =DONE= and =TODO= keywords: (prose-todo yellow))) #+end_src -*** Make inline code in prose use alternative styles +Reload the theme for changes to take effect. + +*** DIY Make inline code in prose use alternative styles :PROPERTIES: :CUSTOM_ID: h:bb5b396f-5532-4d52-ab13-149ca24854f1 :END: @@ -2053,54 +2257,47 @@ Org's verbatim, code, and macro entries. We also provide mappings for tables, property drawers, tags, and code block delimiters, though we do not show every possible permutation. -[[#h:b57bb50b-a863-4ea8-bb38-6de2275fa868][Make TODO and DONE more or less intense]]. +- [[#h:b57bb50b-a863-4ea8-bb38-6de2275fa868][Make TODO and DONE more or less intense]]. +- [[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][DIY Make Org block colors more or less colorful]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - -;; These are all the mappings at their default values for didactic -;; purposes +;; A nuanced accented background, combined with a suitable foreground. (setq modus-themes-common-palette-overrides - '((prose-block fg-dim) - (prose-code green-cooler) - (prose-done green) - (prose-macro magenta-cooler) - (prose-metadata fg-dim) - (prose-metadata-value fg-alt) - (prose-table fg-alt) - (prose-tag magenta-faint) - (prose-todo red) - (prose-verbatim magenta-warmer))) + '((bg-prose-code bg-green-nuanced) + (fg-prose-code green-cooler) -;; Make code block delimiters use a shade of red, tone down verbatim, -;; code, and macro, and amplify the style of property drawers -(setq modus-themes-common-palette-overrides - '((prose-block red-faint) - (prose-code fg-dim) - (prose-macro magenta-faint) - (prose-metadata cyan) - (prose-metadata-value green-warmer) - (prose-verbatim fg-dim))) + (bg-prose-verbatim bg-magenta-nuanced) + (fg-prose-verbatim magenta-warmer) -;; Like the above but with more color variety for the inline code -;; elements + (bg-prose-macro bg-blue-nuanced) + (fg-prose-macro magenta-cooler))) + +;; A more noticeable accented background, combined with a suitable foreground. (setq modus-themes-common-palette-overrides - '((prose-block red-faint) - (prose-code blue-cooler) - (prose-macro yellow-warmer) - (prose-metadata cyan) - (prose-metadata-value green-warmer) - (prose-verbatim red-warmer))) + '((bg-prose-code bg-sage) + (fg-prose-code green-faint) + + (bg-prose-verbatim bg-ochre) + (fg-prose-verbatim red-faint) + + (bg-prose-macro bg-lavender) + (fg-prose-macro blue-faint))) + +;; Leave the backgrounds without a color and simply make the foregrounds more intense. +(setq modus-themes-common-palette-overrides + '((bg-prose-code unspecified) + (fg-prose-code green-intense) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-intense) + + (bg-prose-macro unspecified) + (fg-prose-macro cyan-intense))) #+end_src -*** Make mail citations and headers more or less colorful +Reload the theme for changes to take effect. + +*** DIY Make mail citations and headers more or less colorful :PROPERTIES: :CUSTOM_ID: h:7da7a4ad-5d3a-4f11-9796-5a1abed0f0c4 :END: @@ -2125,15 +2322,6 @@ This is some sample text We thus have the following: #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; Reduce the intensity of mail citations and headers (setq modus-themes-common-palette-overrides '((mail-cite-0 cyan-faint) @@ -2169,7 +2357,9 @@ We thus have the following: (mail-other green))) #+end_src -*** Make the region preserve text colors, plus other styles +Reload the theme for changes to take effect. + +*** DIY Make the region preserve text colors, plus other styles :PROPERTIES: :CUSTOM_ID: h:c8605d37-66e1-42aa-986e-d7514c3af6fe :END: @@ -2183,15 +2373,6 @@ with an appropriate foreground value. [[#h:a5140c9c-18b2-45db-8021-38d0b5074116][Do not extend the region background]]. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; A background with no specific foreground (use foreground of ;; underlying text) (setq modus-themes-common-palette-overrides @@ -2209,7 +2390,9 @@ with an appropriate foreground value. (fg-region fg-main))) #+end_src -*** Make mouse highlights more or less colorful +Reload the theme for changes to take effect. + +*** DIY Make mouse highlights more or less colorful :PROPERTIES: :CUSTOM_ID: h:b5cab69d-d7cb-451c-8ff9-1f545ceb6caf :END: @@ -2220,15 +2403,6 @@ the following code block we show how to affect the semantic color mapping that covers mouse hover effects and related highlights: #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; Make the background an intense yellow (setq modus-themes-common-palette-overrides '((bg-hover bg-yellow-intense))) @@ -2238,7 +2412,9 @@ mapping that covers mouse hover effects and related highlights: '((bg-hover bg-green-subtle))) #+end_src -*** Make language underlines less colorful +Reload the theme for changes to take effect. + +*** DIY Make language underlines less colorful :PROPERTIES: :CUSTOM_ID: h:03dbd5af-6bae-475e-85a2-cec189f69598 :END: @@ -2249,15 +2425,6 @@ Here we show how to affect the color of the underlines that are used by code linters and prose spell checkers. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; Make the underlines less intense (setq modus-themes-common-palette-overrides '((underline-err red-faint) @@ -2271,7 +2438,9 @@ by code linters and prose spell checkers. (underline-note green-intense))) #+end_src -*** Make line numbers use alternative styles +Reload the theme for changes to take effect. + +*** DIY Make line numbers use alternative styles :PROPERTIES: :CUSTOM_ID: h:b6466f51-cb58-4007-9ebe-53a27af655c7 :END: @@ -2281,15 +2450,6 @@ of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic varian this section we show how to affect the ~display-line-numbers-mode~. #+begin_src emacs-lisp -;; These overrides are common to all Modus themes. We also provide -;; theme-specific options, such as `modus-operandi-palette-overrides'. -;; -;; In general, the theme-specific overrides are better for overriding -;; color values, such as redefining what `blue-faint' looks like. The -;; common overrides are best used for changes to semantic color -;; mappings, as we show below. - - ;; Make line numbers less intense (setq modus-themes-common-palette-overrides '((fg-line-number-inactive "gray50") @@ -2313,7 +2473,9 @@ this section we show how to affect the ~display-line-numbers-mode~. (bg-line-number-active bg-cyan-intense))) #+end_src -*** Make diffs use only a foreground +Reload the theme for changes to take effect. + +*** DIY Make diffs use only a foreground :PROPERTIES: :CUSTOM_ID: h:b3761482-bcbf-4990-a41e-4866fb9dad15 :END: @@ -2377,7 +2539,9 @@ just using the "common" overrides. (fg-removed-intense yellow-intense))) #+end_src -*** Make deuteranopia diffs red and blue instead of yellow and blue +Reload the theme for changes to take effect. + +*** DIY Make deuteranopia diffs red and blue instead of yellow and blue :PROPERTIES: :CUSTOM_ID: h:16389ea1-4cb6-4b18-9409-384324113541 :END: @@ -2428,112 +2592,9 @@ respectively. This is achieved by overriding the "changed" and (fg-removed-intense "#ff9095"))) #+end_src -*** Make the themes look like what the maintainer uses -:PROPERTIES: -:CUSTOM_ID: h:aabcada6-810d-4eee-b34a-d2a9c301824d -:END: +Reload the theme for changes to take effect. -Based on what we have learnt from the previous sections of this -manual, here is what Protesilaos uses: - -#+begin_src emacs-lisp -;; Always reload the theme for changes to take effect! - -(setq modus-themes-custom-auto-reload nil - modus-themes-to-toggle '(modus-operandi modus-vivendi) - modus-themes-mixed-fonts t - modus-themes-variable-pitch-ui nil - modus-themes-italic-constructs t - modus-themes-bold-constructs nil - modus-themes-org-blocks nil - modus-themes-completions '((t . (extrabold))) - modus-themes-prompts nil - modus-themes-headings - '((agenda-structure . (variable-pitch light 2.2)) - (agenda-date . (variable-pitch regular 1.3)) - (t . (regular 1.15)))) - -(setq modus-themes-common-palette-overrides - '((cursor magenta-cooler) - ;; Make the fringe invisible. - (fringe unspecified) - ;; Make line numbers less intense and add a shade of cyan - ;; for the current line number. - (fg-line-number-inactive "gray50") - (fg-line-number-active cyan-cooler) - (bg-line-number-inactive unspecified) - (bg-line-number-active unspecified) - ;; Make the current line of `hl-line-mode' a fine shade of - ;; gray (though also see my `lin' package). - (bg-hl-line bg-dim) - ;; Make the region have a cyan-green background with no - ;; specific foreground (use foreground of underlying text). - ;; "bg-sage" refers to Salvia officinalis, else the common - ;; sage. - (bg-region bg-sage) - (fg-region unspecified) - ;; Make matching parentheses a shade of magenta. It - ;; complements the region nicely. - (bg-paren-match bg-magenta-intense) - ;; Make email citations faint and neutral, reducing the - ;; default four colors to two; make mail headers cyan-blue. - (mail-cite-0 fg-dim) - (mail-cite-1 blue-faint) - (mail-cite-2 fg-dim) - (mail-cite-3 blue-faint) - (mail-part cyan-warmer) - (mail-recipient blue-warmer) - (mail-subject magenta-cooler) - (mail-other cyan-warmer) - ;; Change dates to a set of more subtle combinations. - (date-deadline magenta-cooler) - (date-scheduled magenta) - (date-weekday fg-main) - (date-event fg-dim) - (date-now blue-faint) - ;; Make tags (Org) less colorful and tables look the same as - ;; the default foreground. - (prose-done cyan-cooler) - (prose-tag fg-dim) - (prose-table fg-main) - ;; Make headings less colorful (though I never use deeply - ;; nested headings). - (fg-heading-2 blue-faint) - (fg-heading-3 magenta-faint) - (fg-heading-4 blue-faint) - (fg-heading-5 magenta-faint) - (fg-heading-6 blue-faint) - (fg-heading-7 magenta-faint) - (fg-heading-8 blue-faint) - ;; Make the active mode line a fine shade of lavender - ;; (purple) and tone down the gray of the inactive mode - ;; lines. - (bg-mode-line-active bg-lavender) - (border-mode-line-active bg-lavender) - - (bg-mode-line-inactive bg-dim) - (border-mode-line-inactive bg-inactive) - ;; Make the prompts a shade of magenta, to fit in nicely with - ;; the overall blue-cyan-purple style of the other overrides. - ;; Add a nuanced background as well. - (bg-prompt bg-magenta-nuanced) - (fg-prompt magenta-cooler) - ;; Tweak some more constructs for stylistic consistency. - (name blue-warmer) - (identifier magenta-faint) - (keybind magenta-cooler) - (accent-0 magenta-cooler) - (accent-1 cyan-cooler) - (accent-2 blue-warmer) - (accent-3 red-cooler))) - -;; Make the active mode line have a pseudo 3D effect (this assumes -;; you are using the default mode line and not an extra package). -(custom-set-faces - '(mode-line ((t :box (:style released-button))))) -#+end_src - -** More accurate colors in terminal emulators +** DIY More accurate colors in terminal emulators :PROPERTIES: :CUSTOM_ID: h:fbb5e254-afd6-4313-bb05-93b3b4f67358 :END: @@ -2562,7 +2623,7 @@ Another example that can be bound to a key: : TERM=xterm-direct uxterm -e emacsclient -nw -** Range of color with terminal emulators +** DIY Range of color with terminal emulators :PROPERTIES: :CUSTOM_ID: h:6b8211b0-d11b-4c00-9543-4685ec3b742f :END: @@ -2633,48 +2694,7 @@ xterm*color14: #6ae4b9 xterm*color15: #ffffff #+end_src -** Preview theme colors -:properties: -:custom_id: h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d -:end: -#+cindex: Preview named colors or semantic color mappings - -#+findex: modus-themes-list-colors -The command ~modus-themes-list-colors~ uses minibuffer completion to -select an item from the Modus themes and then produces a buffer with -previews of its color palette entries. The buffer has a naming scheme -that reflects the given choice, like =modus-operandi-list-colors= for -the ~modus-operandi~ theme. - -#+findex: modus-themes-list-colors-current -The command ~modus-themes-list-colors-current~ skips the minibuffer -selection process and just produces a preview for the current Modus -theme. - -When called with a prefix argument (=C-u= with the default key -bindings), these commands will show a preview of the palette's -semantic color mappings instead of the named colors. In this context, -"named colors" are entries that associate a symbol to a string color -value, such as =(blue-warmer "#354fcf")=. Whereas "semantic color -mappings" associate a named color to a symbol, like =(string -blue-warmer)=, thus making the theme render all string constructs in -the =blue-warmer= color value ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). - -#+findex: modus-themes-preview-colors -#+findex: modus-themes-preview-colors-current -Aliases for those commands are ~modus-themes-preview-colors~ and -~modus-themes-preview-colors-current~. - -Each row shows a foreground and background coloration using the -underlying value it references. For example a line with =#a60000= (a -shade of red) will show red text followed by a stripe with that same -color as a backdrop. - -The name of the buffer describes the given Modus theme and what the -contents are, such as =*modus-operandi-list-colors*= for named colors -and ==*modus-operandi-list-mappings*= for the semantic color mappings. - -** Per-theme customization settings +** DIY Per-theme customization settings :properties: :custom_id: h:a897b302-8e10-4a26-beab-3caaee1e1193 :end: @@ -2709,114 +2729,9 @@ equivalent the themes provide. For a more elaborate design, it is better to inspect the source code of ~modus-themes-toggle~ and relevant functions. -** Get a single color from the palette -:PROPERTIES: -:CUSTOM_ID: h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e -:END: +Reload the theme for changes to take effect. -[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]]. - -#+findex: modus-themes-get-color-value -The function ~modus-themes-get-color-value~ can be called from Lisp to -return the value of a color from the active Modus theme palette. It -takea a =COLOR= argument and an optional =OVERRIDES=. - -=COLOR= is a symbol that represents a named color entry in the -palette. - -[[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]. - -If the value is the name of another color entry in the palette (so a -mapping), this function recurs until it finds the underlying color -value. - -With an optional =OVERRIDES= argument as a non-~nil~ value, it accounts -for palette overrides. Else it reads only the default palette. - -[[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]. - -With optional =THEME= as a symbol among ~modus-themes-items~ (alias -~modus-themes-collection~), use the palette of that item. Else use -the current Modus theme. - -If =COLOR= is not present in the palette, this function returns the -~unspecified~ symbol, which is safe when used as a face attribute's -value. - -An example with ~modus-operandi~ to show how this function behaves -with/without overrides and when recursive mappings are introduced. - -#+begin_src emacs-lisp -;; Here we show the recursion of palette mappings. In general, it is -;; better for the user to specify named colors to avoid possible -;; confusion with their configuration, though those still work as -;; expected. -(setq modus-themes-common-palette-overrides - '((cursor red) - (fg-mode-line-active cursor) - (border-mode-line-active fg-mode-line-active))) - -;; Ignore the overrides and get the original value. -(modus-themes-get-color-value 'border-mode-line-active) -;; => "#5a5a5a" - -;; Read from the overrides and deal with any recursion to find the -;; underlying value. -(modus-themes-get-color-value 'border-mode-line-active :overrides) -;; => "#a60000" -#+end_src - -** Use theme colors in code with modus-themes-with-colors -:properties: -:custom_id: h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae -:end: -#+cindex: Use colors from the palette anywhere - -[[#h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e][Get a single color from the palette]]. - -Note that users most probably do not need the following. Just rely on -the comprehensive overrides we provide ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). - -#+findex: modus-themes-with-colors -Advanced users may want to apply colors from the palette of the active -Modus theme in their custom code. The ~modus-themes-with-colors~ -macro supplies those to any form called inside of it. For example: - -#+begin_src emacs-lisp -(modus-themes-with-colors - (list blue-warmer magenta-cooler fg-added warning variable fg-heading-4)) -;; => ("#354fcf" "#531ab6" "#005000" "#884900" "#005e8b" "#721045") -#+end_src - -The above return value is for ~modus-operandi~ when that is the active -theme. Switching to another theme and evaluating this code anew will -give us the relevant results for that theme (remember that since -version 4, the Modus themes consist of six items ([[#h:f0f3dbcb-602d-40cf-b918-8f929c441baf][Overview]])). The -same with ~modus-vivendi~ as the active theme: - -#+begin_src emacs-lisp -(modus-themes-with-colors - (list blue-warmer magenta-cooler fg-added warning variable fg-heading-4)) -;; => ("#79a8ff" "#b6a0ff" "#a0e0a0" "#fec43f" "#00d3d0" "#feacd0") -#+end_src - -The ~modus-themes-with-colors~ has access to the whole palette of the -active theme, meaning that it can instantiate both (i) named colors -like =blue-warmer= and (ii) semantic color mappings like =warning=. -We provide commands to inspect those ([[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]). - -Others sections in this manual show how to use the aforementioned -macro ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). - -Because the ~modus-themes-with-colors~ will most likely be used to -customize faces, note that any function that calls it must be run at -startup after the theme loads. The same function must also be -assigned to the ~modus-themes-after-load-theme-hook~ for its effects -to persist and be updated when switching between Modus themes (e.g. to -update the exact value of =blue-warmer= when toggling between -~modus-operandi~ to ~modus-vivendi~. - -** Do not extend the region background +** DIY Do not extend the region background :PROPERTIES: :CUSTOM_ID: h:a5140c9c-18b2-45db-8021-38d0b5074116 :END: @@ -2834,11 +2749,14 @@ this to the Emacs configuration file will suffice: [[#h:c8605d37-66e1-42aa-986e-d7514c3af6fe][Make the region preserve text colors, plus other styles]]. -** Add padding to mode line +** DIY Add padding to the mode line :PROPERTIES: :CUSTOM_ID: h:5a0c58cc-f97f-429c-be08-927b9fbb0a9c :END: +[ Consider using the ~spacious-padding~ package from GNU ELPA (by + Protesilaos) for more than just the mode line. ] + Emacs faces do not have a concept of "padding" for the space between the text and its box boundaries. We can approximate the effect by adding a =:box= attribute, making its border several pixels thick, and @@ -2849,7 +2767,7 @@ mode line. [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]]. #+begin_src emacs-lisp -(defun my-modus-themes-custom-faces () +(defun my-modus-themes-custom-faces (&rest _) (modus-themes-with-colors (custom-set-faces ;; Add "padding" to the mode lines @@ -2859,6 +2777,8 @@ mode line. (add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) #+end_src +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + The above has the effect of removing the border around the mode lines. In older versions of the themes, we provided the option for a padded mode line which could also have borders around it. Those were not @@ -2866,7 +2786,7 @@ real border, however, but an underline and an overline. Adjusting the above: #+begin_src emacs-lisp -(defun my-modus-themes-custom-faces () +(defun my-modus-themes-custom-faces (&rest _) (modus-themes-with-colors (custom-set-faces ;; Add "padding" to the mode lines @@ -2886,13 +2806,15 @@ above: The reason we no longer provide this option is because it depends on a non-~nil~ value for ~x-underline-at-descent-line~. That variable affects ALL underlines, including those of links. The effect is -intrusive and looks awkward in prose. +intrusive and looks awkard in prose. As such, the Modus themes no longer provide that option but instead offer this piece of documentation to make the user fully aware of the state of affairs. -** Remap face with local value +Reload the theme for changes to take effect. + +** DIY Remap face with local value :properties: :custom_id: h:7a93cb6f-4eca-4d56-a85c-9dcd813d6b0f :end: @@ -2954,12 +2876,17 @@ Perhaps you may wish to generalize those findings in to a set of functions that also accept an arbitrary face. We shall leave the experimentation up to you. -** Font configurations for Org and others +Reload the theme for changes to take effect. + +** DIY Font configurations for Org and others :properties: :custom_id: h:defcf4fc-8fa8-4c29-b12e-7119582cc929 :end: #+cindex: Font configurations +[ Consider using the ~fontaine~ package from GNU ELPA (by Protesilaos) + for all font-related configurations. ] + The themes are designed to optionally cope well with mixed font configurations. This mostly concerns ~org-mode~ and ~markdown-mode~, though expect to find it elsewhere like in ~Info-mode~. @@ -2979,9 +2906,6 @@ the ~variable-pitch~ (proportional spacing) and ~fixed-pitch~ (monospaced) faces respectively. It may also be convenient to set your main typeface by configuring the ~default~ face the same way. -[ The ~fontaine~ package on GNU ELPA (by Protesilaos) is designed to - handle this case. ] - Put something like this in your initialization file (also consider reading the doc string of ~set-face-attribute~): @@ -3023,12 +2947,15 @@ absolute height). [[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts]]. -** Configure bold and italic faces +** DIY Configure bold and italic faces :properties: :custom_id: h:2793a224-2109-4f61-a106-721c57c01375 :end: #+cindex: Bold and italic fonts +[ Consider using the ~fontaine~ package from GNU ELPA (by Protesilaos) + for all font-related configurations. ] + The Modus themes do not hardcode a ~:weight~ or ~:slant~ attribute in the thousands of faces they cover. Instead, they configure the generic faces called ~bold~ and ~italic~ to use the appropriate styles and then @@ -3082,12 +3009,12 @@ To reset the font family, one can use this: #+end_src To ensure that the effects persist after switching between the Modus -themes (such as with {{{kbd(M-x modus-themes-toggle)}}}), the user needs to -write their configurations to a function and pass it to the -~modus-themes-after-load-theme-hook~. This is necessary because themes -set the styles of faces upon activation, overriding prior values where -conflicts occur between the previous and the current states (otherwise -changing themes would not be possible). +themes (such as with {{{kbd(M-x modus-themes-toggle)}}}), the user +needs to write their configurations to a function and pass it to the +~modus-themes-after-load-theme-hook~ ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). This is +necessary because themes set the styles of faces upon activation, +overriding prior values where conflicts occur between the previous and +the current states (otherwise changing themes would not be possible). [[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]. @@ -3100,14 +3027,14 @@ of the themes, which can make it easier to redefine faces in bulk). #+begin_src emacs-lisp ;; our generic function -(defun my-modes-themes-bold-italic-faces () +(defun my-modes-themes-bold-italic-faces (&rest _) (set-face-attribute 'default nil :family "Source Code Pro" :height 110) (set-face-attribute 'bold nil :weight 'semibold)) ;; or use this if you configure a lot of face and attributes and ;; especially if you plan to use `modus-themes-with-colors', as shown ;; elsewhere in the manual -(defun my-modes-themes-bold-italic-faces () +(defun my-modes-themes-bold-italic-faces (&rest _) (custom-set-faces '(default ((t :family "Source Code Pro" :height 110))) '(bold ((t :weight semibold))))) @@ -3118,7 +3045,11 @@ of the themes, which can make it easier to redefine faces in bulk). [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]]. -** Custom Org todo keyword and priority faces +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + +Reload the theme for changes to take effect. + +** DIY Custom Org todo keyword and priority faces :properties: :custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad :end: @@ -3207,7 +3138,7 @@ it if you plan to control face attributes. [[#h:02e25930-e71a-493d-828a-8907fc80f874][Check color combinations]]. -** Custom Org emphasis faces +** DIY Custom Org emphasis faces :properties: :custom_id: h:26026302-47f4-4471-9004-9665470e7029 :end: @@ -3229,7 +3160,7 @@ specification of that variable looks like this: With the exception of ~org-verbatim~ and ~org-code~ faces, everything else uses the corresponding type of emphasis: a bold typographic weight, or -italicized, underlined, and struck through text. +italicised, underlined, and struck through text. The best way for users to add some extra attributes, such as a foreground color, is to define their own faces and assign them to the @@ -3340,49 +3271,97 @@ styled by the themes, it probably is best not to edit them: That's it! For changes to take effect in already visited Org files, invoke {{{kbd(M-x org-mode-restart)}}}. -** Update Org block delimiter fontification -:properties: -:custom_id: h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50 -:end: +** DIY Use colored Org source blocks per language +:PROPERTIES: +:CUSTOM_ID: h:8c842804-43b7-4287-b4e9-8c07d04d1f89 +:END: -As noted in the section about ~modus-themes-org-blocks~, Org contains a -variable that determines whether the block's begin and end lines are -extended to the edge of the window ([[#h:b7e328c0-3034-4db7-9cdf-d5ba12081ca2][Option for org-mode block styles]]). -The variable is ~org-fontify-whole-block-delimiter-line~. +[[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][DIY Make Org block colors more or less colorful]]. -Users who change the style of Org blocks from time to time may prefer to -automatically update delimiter line fontification, such as with the -following setup: +In versions of the Modus themes before =4.4.0= there was an option to +change the coloration of Org source blocks so that certain languages +would have a distinctly colored background. This was not flexible +enough, because (i) we cannot cover all languages effectively and (ii) +the user had no choice over the =language --> color= mapping. + +As such, the old user option is no more. Users can use the following +to achieve what they want: + +[ All this is done by setting the Org user option ~org-src-block-faces~, + so it is not related to the palette overrides mechanism provided by + the Modus themes. ] #+begin_src emacs-lisp -(defun my-modus-themes-org-fontify-block-delimiter-lines () - "Match `org-fontify-whole-block-delimiter-line' to theme style. -Run this function at the post theme load phase, such as with the -`modus-themes-after-load-theme-hook'." - (if (eq modus-themes-org-blocks 'gray-background) - (setq org-fontify-whole-block-delimiter-line t) - (setq org-fontify-whole-block-delimiter-line nil))) +(defun my-modus-themes-org-block-faces (&rest _) + (modus-themes-with-colors + ;; The `org-src-block-faces' does not get re-applied in existing + ;; Org buffers. Do M-x org-mode-restart for changes to take + ;; effect. + (setq org-src-block-faces + `(("emacs-lisp" modus-themes-nuanced-magenta) + ("elisp" modus-themes-nuanced-magenta) + ("clojure" modus-themes-nuanced-magenta) + ("clojurescript" modus-themes-nuanced-magenta) + ("c" modus-themes-nuanced-blue) + ("c++" modus-themes-nuanced-blue) + ("sh" modus-themes-nuanced-yellow) + ("shell" modus-themes-nuanced-yellow) + ("python" modus-themes-nuanced-yellow) + ("ipython" modus-themes-nuanced-yellow) + ("r" modus-themes-nuanced-yellow) + ("html" modus-themes-nuanced-green) + ("xml" modus-themes-nuanced-green) + ("css" modus-themes-nuanced-red) + ("scss" modus-themes-nuanced-red) + ("yaml" modus-themes-nuanced-cyan) + ("conf" modus-themes-nuanced-cyan) + ("docker" modus-themes-nuanced-cyan))))) -(add-hook 'modus-themes-after-load-theme-hook - #'my-modus-themes-org-fontify-block-delimiter-lines) +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-org-block-faces) #+end_src -Then {{{kbd(M-x org-mode-restart)}}} for changes to take effect, though manual -intervention can be circumvented by tweaking the function thus: +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][DIY Use a hook at the post-load-theme phase]]. + +Note that the ~org-src-block-faces~ accepts a named face, as shown +above, as well as a list of face attributes. The latter approach is +not good enough because it hardcodes values in such a way that an +~org-mode-restart~ is necessary. Whereas the indirection of the named +face lets the theme change the values while Org buffers continue to +show the right colors. + +Still, if a user prefers to hardcode face attributes, here is the +idea: #+begin_src emacs-lisp -(defun my-modus-themes-org-fontify-block-delimiter-lines () - "Match `org-fontify-whole-block-delimiter-line' to theme style. -Run this function at the post theme load phase, such as with the -`modus-themes-after-load-theme-hook'." - (if (eq modus-themes-org-blocks 'gray-background) - (setq org-fontify-whole-block-delimiter-line t) - (setq org-fontify-whole-block-delimiter-line nil)) - (when (derived-mode-p 'org-mode) - (font-lock-flush))) +;; This is for the sake of completeness. I DO NOT RECOMMEND THIS +;; method because it hardcodes values and thus requires +;; `org-mode-restart' every time you change a theme. +(defun my-modus-themes-org-block-faces (&rest _) + (modus-themes-with-colors + (setq org-src-block-faces + `(("emacs-lisp" (:inherit org-block :background ,bg-magenta-nuanced)) + ("elisp" (:inherit org-block :background ,bg-magenta-nuanced)) + ("clojure" (:inherit org-block :background ,bg-magenta-nuanced)) + ("clojurescript" (:inherit org-block :background ,bg-magenta-nuanced)) + ("c" (:inherit org-block :background ,bg-blue-nuanced)) + ("c++" (:inherit org-block :background ,bg-blue-nuanced)) + ("sh" (:inherit org-block :background ,bg-yellow-nuanced)) + ("shell" (:inherit org-block :background ,bg-yellow-nuanced)) + ("python" (:inherit org-block :background ,bg-yellow-nuanced)) + ("ipython" (:inherit org-block :background ,bg-yellow-nuanced)) + ("r" (:inherit org-block :background ,bg-yellow-nuanced)) + ("html" (:inherit org-block :background ,bg-green-nuanced)) + ("xml" (:inherit org-block :background ,bg-green-nuanced)) + ("css" (:inherit org-block :background ,bg-red-nuanced)) + ("scss" (:inherit org-block :background ,bg-red-nuanced)) + ("yaml" (:inherit org-block :background ,bg-cyan-nuanced)) + ("conf" (:inherit org-block :background ,bg-cyan-nuanced)) + ("docker" (:inherit org-block :background ,bg-cyan-nuanced)))))) + +(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-org-block-faces) #+end_src -** Measure color contrast +** DIY Measure color contrast :properties: :custom_id: h:02e25930-e71a-493d-828a-8907fc80f874 :end: @@ -3455,7 +3434,7 @@ minutia and relevant commentary. Such knowledge may prove valuable while attempting to customize the theme's color palette. -** Load theme depending on time of day +** DIY Load theme depending on time of day :properties: :custom_id: h:1d1ef4b4-8600-4a09-993c-6de3af0ddd26 :end: @@ -3483,7 +3462,7 @@ the ~circadian~ package: (circadian-setup)) #+end_src -** Backdrop for pdf-tools +** DIY Backdrop for pdf-tools :properties: :custom_id: h:ff69dfe1-29c0-447a-915c-b5ff7c5509cd :end: @@ -3504,7 +3483,7 @@ buffer-local value of the ~default~ face. To remap the buffer's backdrop, we start with a function like this one: #+begin_src emacs-lisp -(defun my-pdf-tools-backdrop () +(defun my-pdf-tools-backdrop (&rest _) (modus-themes-with-colors (face-remap-add-relative 'default @@ -3518,7 +3497,8 @@ The idea is to assign that function to a hook that gets called when when you only use one theme. However it has the downside of setting the background color value only at render time. In other words, the face remapping function does not get evaluated anew whenever the theme -changes, such as upon invoking {{{kbd(M-x modus-themes-toggle)}}}. +changes, such as upon invoking {{{kbd(M-x modus-themes-toggle)}}} +([[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]]). To have our face remapping adapt gracefully while switching between the Modus themes, we need to also account for the current theme and control @@ -3526,20 +3506,20 @@ the activation of ~pdf-view-midnight-minor-mode~. To which end we arrive at something like the following, which builds on the above example: #+begin_src emacs-lisp -(defun my-pdf-tools-backdrop () +(defun my-pdf-tools-backdrop (&rest _) (modus-themes-with-colors (face-remap-add-relative 'default `(:background ,bg-dim)))) -(defun my-pdf-tools-midnight-mode-toggle () +(defun my-pdf-tools-midnight-mode-toggle (&rest _) (when (derived-mode-p 'pdf-view-mode) (if (eq (car custom-enabled-themes) 'modus-vivendi) (pdf-view-midnight-minor-mode 1) (pdf-view-midnight-minor-mode -1)) (my-pdf-tools-backdrop))) -(defun my-pdf-tools-themes-toggle () +(defun my-pdf-tools-themes-toggle (&rest _) (mapc (lambda (buf) (with-current-buffer buf @@ -3550,11 +3530,15 @@ at something like the following, which builds on the above example: (add-hook 'modus-themes-after-load-theme-hook #'my-pdf-tools-themes-toggle) #+end_src +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + With those in place, PDFs have a distinct backdrop for their page, while buffers with major-mode as ~pdf-view-mode~ automatically switches to dark mode when ~modus-themes-toggle~ is called. -** Toggle themes without reloading them +Reload the theme for changes to take effect. + +** DIY Toggle themes without reloading them :properties: :custom_id: h:b40aca50-a3b2-4c43-be58-2c26fcd14237 :end: @@ -3583,58 +3567,7 @@ manual." Recall that ~modus-themes-toggle~ uses ~load-theme~. -** A theme-agnostic hook for theme loading -:properties: -:custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776 -:end: - -The themes are designed with the intent to be useful to Emacs users of -varying skill levels, from beginners to experts. This means that we try -to make things easier by not expecting anyone reading this document to -be proficient in Emacs Lisp or programming in general. - -Such a case is with the use of ~modus-themes-after-load-theme-hook~, -which runs after the ~modus-themes-load-theme~ function (used by the -command ~modus-themes-toggle~). We recommend using that hook for -advanced customizations, because (1) we know for sure that it is -available once the themes are loaded, and (2) anyone consulting this -manual, especially the sections on enabling and loading the themes, -will be in a good position to benefit from that hook. - -Advanced users who have a need to switch between the Modus themes and -other items will find that such a hook does not meet their requirements: -it only works with the Modus themes and only with the aforementioned -functions. - -A theme-agnostic setup can be configured thus: - -#+begin_src emacs-lisp -(defvar after-enable-theme-hook nil - "Normal hook run after enabling a theme.") - -(defun run-after-enable-theme-hook (&rest _args) - "Run `after-enable-theme-hook'." - (run-hooks 'after-enable-theme-hook)) - -(advice-add 'enable-theme :after #'run-after-enable-theme-hook) -#+end_src - -This creates the ~after-enable-theme-hook~ and makes it run after each -call to ~enable-theme~, which means that it will work for all themes and -also has the benefit that it does not depend on functions such as -~modus-themes-toggle~ and the others mentioned above. ~enable-theme~ is -called internally by ~load-theme~, so the hook works everywhere. - -The downside of the theme-agnostic hook is that any functions added to -it will likely not be able to benefit from macro calls that read the -active theme, such as ~modus-themes-with-colors~. Not all Emacs -themes have the same capabilities. - -In this document, we cover ~modus-themes-after-load-theme-hook~ though -the user can replace it with ~after-enable-theme-hook~ should they -need to (provided they understand the implications). - -** Use more spacious margins or padding in Emacs frames +** DIY Use more spacious margins or padding in Emacs frames :PROPERTIES: :CUSTOM_ID: h:43bcb5d0-e25f-470f-828c-662cee9e21f1 :END: @@ -3687,7 +3620,7 @@ The reason we do this with a function is so we can hook it to the faces will no longer be invisible). #+begin_src emacs-lisp -(defun my-modus-themes-invisible-dividers () +(defun my-modus-themes-invisible-dividers (&rest _) "Make window dividers invisible. Add this to the `modus-themes-post-load-hook'." (let ((bg (face-background 'default))) @@ -3700,6 +3633,8 @@ Add this to the `modus-themes-post-load-hook'." (add-hook 'modus-themes-post-load-hook #'my-modus-themes-invisible-dividers) #+end_src +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + The above will work only for themes that belong to the Modus family. For users of Emacs version 29 or higher, there exists a theme-agnostic hook that takes a function with one argument---that of the theme---and @@ -3707,7 +3642,7 @@ calls in the the "post enable" phase of theme loading. Here is the above snippet, with the necessary tweaks: #+begin_src emacs-lisp -(defun my-modus-themes-invisible-dividers (_theme) +(defun my-modus-themes-invisible-dividers (&rest _) "Make window dividers for THEME invisible." (let ((bg (face-background 'default))) (custom-set-faces @@ -3722,7 +3657,7 @@ above snippet, with the necessary tweaks: Users of older versions of Emacs can read the entry herein about defining their own theme-agnostic hook ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]). -** Custom hl-todo colors +** DIY Custom hl-todo colors :PROPERTIES: :CUSTOM_ID: h:2ef83a21-2f0a-441e-9634-473feb940743 :END: @@ -3735,7 +3670,7 @@ may still prefer to apply their custom values, in which case the following approach is necessary: #+begin_src emacs-lisp -(defun my-modus-themes-hl-todo-faces () +(defun my-modus-themes-hl-todo-faces (&rest _) (setq hl-todo-keyword-faces '(("TODO" . "#ff0000") ("HACK" . "#ffff00") ("XXX" . "#00ffff") @@ -3744,10 +3679,12 @@ following approach is necessary: (add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-hl-todo-faces) #+end_src +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + Or include a ~let~ form, if needed: #+begin_src emacs-lisp -(defun my-modus-themes-hl-todo-faces () +(defun my-modus-themes-hl-todo-faces (&rest _) (let ((red "#ff0000") (blue "#0000ff")) (setq hl-todo-keyword-faces `(("TODO" . ,blue) @@ -3758,10 +3695,14 @@ Or include a ~let~ form, if needed: (add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-hl-todo-faces) #+end_src +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + Normally, we do not touch user options, though this is an exception: otherwise the defaults are not always legible. -** Add support for solaire-mode +Reload the theme for changes to take effect. + +** DIY Add support for solaire-mode :PROPERTIES: :CUSTOM_ID: h:439c9e46-52e2-46be-b1dc-85841dd99671 :END: @@ -3806,7 +3747,7 @@ on what we cover at length elsewhere in this manual: [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]]. #+begin_src emacs-lisp -(defun my-modus-themes-custom-faces () +(defun my-modus-themes-custom-faces (&rest _) (modus-themes-with-colors (custom-set-faces `(solaire-default-face ((,c :inherit default :background ,bg-dim :foreground ,fg-dim))) @@ -3817,7 +3758,106 @@ on what we cover at length elsewhere in this manual: (add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) #+end_src -As always, re-load the theme for changes to take effect. +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + +Reload the theme for changes to take effect. + +** DIY Use a hook at the post-load-theme phase +:PROPERTIES: +:CUSTOM_ID: h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24 +:END: + +Many of the Do-It-Yourself (DIY) snippets provided herein make use of +a hook to apply the desired changes. In most examples, this hook is +the ~modus-themes-after-load-theme-hook~ (alias ~modus-themes-post-load-hook~). +This hook is provided by the Modus themes and is called at the end of +one the following: + +- Command ~modus-themes-toggle~ :: [[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]]. + +- Command ~modus-themes-select~ :: Select a Modus theme using minibuffer + completion and then load it. + +- Function ~modus-themes-load-theme~ :: Called only from Lisp, such as + in the user's init file, with the quoted symbol of a Modus theme as + an argument ([[#h:adb0c49a-f1f9-4690-868b-013a080eed68][Option for disabling other themes while loading Modus]]). + This function is used internally by ~modus-themes-toggle~ and + ~modus-themes-select~. + +Users who switch between themes that are not limited to the Modus +collection cannot benefit from the aforementioned hook: it only works +with the Modus themes. A theme-agnostic hook is needed in such a case. +Before Emacs 29, this had to be set up manually ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][DIY A theme-agnostic hook for theme loading]]). +Starting with Emacs 29, the special hook ~enable-theme-functions~ +works with anything that uses the basic ~enable-theme~ function. + +To use the ~enable-theme-functions~ just add the given function to it +the way it is done with every hook: + +#+begin_src emacs-lisp +(add-hook 'enable-theme-functions 'MY-FUNCTION-HERE) +#+end_src + +Functions added to ~enable-theme-functions~ accept a single =THEME= +argument. The examples shown in this manual use the pattern =(&rest +_)=, which is how a function accepts one or more arguments but +declares it will not use them (in plain terms, the code works with or +without ~enable-theme-functions~). + +*** DIY A theme-agnostic hook for theme loading +:properties: +:custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776 +:end: + +[ NOTE: The following is for versions of Emacs before 29. For Emacs 29 + or higher, users can rely on the built-in ~enable-theme-functions~ + ([[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]). ] + +The themes are designed with the intent to be useful to Emacs users of +varying skill levels, from beginners to experts. This means that we try +to make things easier by not expecting anyone reading this document to +be proficient in Emacs Lisp or programming in general. + +Such a case is with the use of ~modus-themes-after-load-theme-hook~, +which runs after the ~modus-themes-load-theme~ function (used by the +command ~modus-themes-toggle~). We recommend using that hook for +advanced customizations, because (1) we know for sure that it is +available once the themes are loaded, and (2) anyone consulting this +manual, especially the sections on enabling and loading the themes, +will be in a good position to benefit from that hook. + +Advanced users who have a need to switch between the Modus themes and +other items will find that such a hook does not meet their requirements: +it only works with the Modus themes and only with the aforementioned +functions. + +A theme-agnostic setup can be configured thus: + +#+begin_src emacs-lisp +(defvar after-enable-theme-hook nil + "Normal hook run after enabling a theme.") + +(defun run-after-enable-theme-hook (&rest _args) + "Run `after-enable-theme-hook'." + (run-hooks 'after-enable-theme-hook)) + +(advice-add 'enable-theme :after #'run-after-enable-theme-hook) +#+end_src + +This creates the ~after-enable-theme-hook~ and makes it run after each +call to ~enable-theme~, which means that it will work for all themes and +also has the benefit that it does not depend on functions such as +~modus-themes-toggle~ and the others mentioned above. ~enable-theme~ is +called internally by ~load-theme~, so the hook works everywhere. + +The downside of the theme-agnostic hook is that any functions added to +it will likely not be able to benefit from macro calls that read the +active theme, such as ~modus-themes-with-colors~. Not all Emacs +themes have the same capabilities. + +In this document, we cover ~modus-themes-after-load-theme-hook~ though +the user can replace it with ~after-enable-theme-hook~ should they +need to (provided they understand the implications). * Face coverage :properties: @@ -3882,7 +3922,9 @@ have lots of extensions, so the "full support" may not be 100% true… + custom (what you get with {{{kbd(M-x customize)}}}) + dashboard + deadgrep ++ debbugs + deft ++ denote + devdocs + dictionary + diff-hl @@ -3978,6 +4020,7 @@ have lots of extensions, so the "full support" may not be 100% true… + marginalia + markdown-mode + markup-faces (~adoc-mode~) ++ mct + messages + minimap + mode-line @@ -4089,6 +4132,7 @@ have lots of extensions, so the "full support" may not be 100% true… + xterm-color (and ansi-colors) + yaml-mode + yasnippet ++ ztree Plus many other miscellaneous faces that are provided by Emacs. @@ -4213,7 +4257,7 @@ length elsewhere in this manual: [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]]. #+begin_src emacs-lisp -(defun my-modus-themes-custom-faces () +(defun my-modus-themes-custom-faces (&rest _) (modus-themes-with-colors (custom-set-faces ;; Make foreground the same as background for a uniform bar on @@ -4229,6 +4273,8 @@ length elsewhere in this manual: (add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces) #+end_src +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + As always, re-load the theme for changes to take effect. If the above does not work, try this instead: @@ -4260,7 +4306,7 @@ multiline comments in PHP with the ~php-mode~ package use the This seems to make all comments use the appropriate face: #+begin_src emacs-lisp -(defun my-multine-comments () +(defun my-multine-comments (&rest _) (setq-local c-doc-face-name 'font-lock-comment-face)) (add-hook 'php-mode-hook #'my-multine-comments) @@ -4396,7 +4442,7 @@ advanced customization options of the themes. [[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]. In the following example, we are assuming that the user wants to (i) -reuse color variables provided by the themes, (ii) be able to retain +re-use color variables provided by the themes, (ii) be able to retain their tweaks while switching between ~modus-operandi~ and ~modus-vivendi~, and (iii) have the option to highlight either the foreground of the parentheses or the background as well. @@ -4416,7 +4462,7 @@ Then we can update our preference with this: (setq my-highlight-parentheses-use-background nil) #+end_src -To reuse colors from the themes, we must wrap our code in the +To re-use colors from the themes, we must wrap our code in the ~modus-themes-with-colors~ macro. Our implementation must interface with the variables ~highlight-parentheses-background-colors~ and/or ~highlight-parentheses-colors~. @@ -4472,7 +4518,7 @@ implementation: (setq my-highlight-parentheses-use-background nil) ; Set to nil to disable backgrounds -(defun my-modus-themes-highlight-parentheses () +(defun my-modus-themes-highlight-parentheses (&rest _) (modus-themes-with-colors ;; Our preference for setting either background or foreground ;; styles, depending on `my-highlight-parentheses-use-background'. @@ -4507,6 +4553,8 @@ implementation: (add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-highlight-parentheses) #+end_src +[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]. + As always, re-load the theme for changes to take effect. ** Note on mmm-mode.el background colors @@ -5026,7 +5074,7 @@ more effective than trying to do the same with either red or blue (the latter is the least effective in that regard). When we need to work with several colors, it is always better to have -sufficient maneuvering space, especially since we cannot pick arbitrary +sufficient manoeuvring space, especially since we cannot pick arbitrary colors but only those that satisfy the accessibility objectives of the themes. @@ -5080,7 +5128,7 @@ each of the three channels of light (red, green, blue). For example: : xrandr --output LVDS1 --brightness 1.0 --gamma 0.76:0.75:0.68 Typography is another variable. Some font families are blurry at small -point sizes. Others may have a regular weight that is lighter (thinner) +point sizes. Others may have a regular weight that is lighter (thiner) than that of their peers which may, under certain circumstances, cause a halo effect around each glyph. @@ -5132,7 +5180,7 @@ it is already understood that one must follow the indicator or headline to view its contents and (ii) underlining everything would make the interface virtually unusable. -Again, one must exercise judgment in order to avoid discrimination, +Again, one must exercise judgement in order to avoid discrimination, where "discrimination" refers to: + The treatment of substantially different magnitudes as if they were of @@ -5206,7 +5254,7 @@ the themes, which is partially fleshed out in this manual. With regard to the artistic aspect (where "art" qua skill may amount to an imprecise science), there is no hard-and-fast rule in effect as it -requires one to exercise discretion and make decisions based on +requires one to exercize discretion and make decisions based on context-dependent information or constraints. As is true with most things in life, when in doubt, do not cling on to the letter of the law but try to understand its spirit. @@ -5356,12 +5404,12 @@ The Modus themes are a collective effort. Every bit of work matters. Daniel Mendler, David Edmondson, Eli Zaretskii, Fritz Grabo, Gautier Ponsinet, Illia Ostapyshyn, Kévin Le Gouguec, Koen van Greevenbroek, Kostadin Ninev, Madhavan Krishnan, Manuel Giraud, Markus Beppler, - Matthew Stevenson, Mauro Aranda, Nacho Barrientos, Nicolas De - Jaeghere, Paul David, Philip Kaludercic, Pierre Téchoueyres, Rudolf - Adamkovič, Sergey Nichiporchik, Shreyas Ragavan, Stefan Kangas, - Stephen Berman, Stephen Gildea, Steve Downey, Tomasz Hołubowicz, - Utkarsh Singh, Vincent Murphy, Xinglu Chen, Yuanchen Xie, fluentpwn, - okamsn. + Matthew Stevenson, Mauro Aranda, Nacho Barrientos, Niall Dooley, + Nicolas De Jaeghere, Paul David, Philip Kaludercic, Pierre + Téchoueyres, Rudolf Adamkovič, Sergey Nichiporchik, Shreyas Ragavan, + Stefan Kangas, Stephen Berman, Stephen Gildea, Steve Downey, Tomasz + Hołubowicz, Utkarsh Singh, Vincent Murphy, Xinglu Chen, Yuanchen + Xie, fluentpwn, okamsn. + Ideas and user feedback :: Aaron Jensen, Adam Porter, Adam Spiers, Adrian Manea, Aleksei Pirogov, Alex Griffin, Alex Koen, Alex @@ -5376,13 +5424,13 @@ The Modus themes are a collective effort. Every bit of work matters. Gonçalo Marrafa, Guilherme Semente, Gustavo Barros, Hörmetjan Yiltiz, Ilja Kocken, Imran Khan, Iris Garcia, Ivan Popovych, James Ferguson, Jeremy Friesen, Jerry Zhang, Johannes Grødem, John Haman, - Jonas Collberg, Jorge Morais, Joshua O'Connor, Julio C. Villasante, - Kenta Usami, Kevin Fleming, Kévin Le Gouguec, Kevin Kainan Li, - Kostadin Ninev, Laith Bahodi, Lasse Lindner, Len Trigg, Lennart - C. Karssen, Luis Miguel Castañeda, Magne Hov, Manuel Giraud, Manuel - Uberti, Mark Bestley, Mark Burton, Mark Simpson, Marko Kocic, Markus - Beppler, Matt Armstrong, Matthias Fuchs, Mattias Engdegård, Mauro - Aranda, Maxime Tréca, Michael Goldenberg, Morgan Smith, Morgan + John Wick, Jonas Collberg, Jorge Morais, Joshua O'Connor, Julio C. + Villasante, Kenta Usami, Kevin Fleming, Kévin Le Gouguec, Kevin + Kainan Li, Kostadin Ninev, Laith Bahodi, Lasse Lindner, Len Trigg, + Lennart C.{{{space()}}} Karssen, Luis Miguel Castañeda, Magne Hov, Manuel Giraud, + Manuel Uberti, Mark Bestley, Mark Burton, Mark Simpson, Marko Kocic, + Markus Beppler, Matt Armstrong, Matthias Fuchs, Mattias Engdegård, + Mauro Aranda, Maxime Tréca, Michael Goldenberg, Morgan Smith, Morgan Willcock, Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere, Nicolas Semrau, Olaf Meeuwissen, Oliver Epper, Pablo Stafforini, Paul Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, Philip @@ -5392,11 +5440,12 @@ The Modus themes are a collective effort. Every bit of work matters. Ragavan, Simon Pugnet, Steve Downey, Tassilo Horn, Thanos Apollo, Thibaut Verron, Thomas Heartman, Togan Muftuoglu, Tony Zorman, Trey Merkley, Tomasz Hołubowicz, Toon Claes, Uri Sharf, Utkarsh Singh, - Vincent Foley, Zoltan Kiraly. As well as users: Ben, CsBigDataHub1, + Vincent Foley, Zoltan Kiraly. As well as users: Ben, CsBigDataHub1, Emacs Contrib, Eugene, Fourchaux, Fredrik, Moesasji, Nick, Summer Emacs, TheBlob42, TitusMu, Trey, bepolymathe, bit9tream, bangedorrunt, derek-upham, doolio, fleimgruber, gitrj95, iSeeU, - jixiuf, okamsn, pRot0ta1p, soaringbird, tumashu, wakamenod. + jixiuf, ltmsyvag, okamsn, pRot0ta1p, soaringbird, tumashu, + wakamenod. + Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core diff --git a/etc/themes/modus-operandi-deuteranopia-theme.el b/etc/themes/modus-operandi-deuteranopia-theme.el index 4d210b977eb..42479965300 100644 --- a/etc/themes/modus-operandi-deuteranopia-theme.el +++ b/etc/themes/modus-operandi-deuteranopia-theme.el @@ -1,11 +1,10 @@ ;;; modus-operandi-deuteranopia-theme.el --- Deuteranopia-optimized theme with a white background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -128,12 +127,12 @@ standard)." (bg-magenta-subtle "#ffddff") (bg-cyan-subtle "#bfefff") - (bg-red-nuanced "#fff1f0") - (bg-green-nuanced "#ecf7ed") - (bg-yellow-nuanced "#fff3da") - (bg-blue-nuanced "#f3f3ff") - (bg-magenta-nuanced "#fdf0ff") - (bg-cyan-nuanced "#ebf6fa") + (bg-red-nuanced "#ffe8e8") + (bg-green-nuanced "#e0f6e0") + (bg-yellow-nuanced "#f8f0d0") + (bg-blue-nuanced "#ecedff") + (bg-magenta-nuanced "#f8e6f5") + (bg-cyan-nuanced "#e0f2fa") ;;; Uncommon accent backgrounds @@ -212,6 +211,7 @@ standard)." ;;; Paren match (bg-paren-match "#5fcfff") + (fg-paren-match fg-main) (bg-paren-expression "#efd3f5") (underline-paren-match unspecified) @@ -241,6 +241,11 @@ standard)." (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-yellow-nuanced) + (fg-active-argument yellow-warmer) + (bg-active-value bg-blue-nuanced) + (fg-active-value blue-warmer) + ;;;; Code mappings (builtin magenta-warmer) @@ -289,7 +294,7 @@ standard)." (date-event fg-alt) (date-holiday yellow-warmer) (date-holiday-other blue) - (date-now blue-faint) + (date-now fg-main) (date-range fg-alt) (date-scheduled yellow-cooler) (date-weekday cyan) @@ -343,16 +348,29 @@ standard)." ;;;; Prose mappings - (prose-block fg-dim) - (prose-code cyan-cooler) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan-cooler) + + (bg-prose-macro unspecified) + (fg-prose-macro magenta-cooler) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done blue) - (prose-macro magenta-cooler) + (prose-todo yellow-warmer) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) + (prose-table-formula yellow-warmer) + (prose-tag magenta-faint) - (prose-todo yellow-warmer) - (prose-verbatim magenta-warmer) ;;;; Rainbow mappings @@ -366,6 +384,17 @@ standard)." (rainbow-7 yellow-faint) (rainbow-8 cyan) +;;;; Search mappings + + (bg-search-current bg-yellow-intense) + (bg-search-lazy bg-blue-intense) + (bg-search-replace bg-magenta-intense) + + (bg-search-rx-group-0 bg-cyan-intense) + (bg-search-rx-group-1 bg-magenta-intense) + (bg-search-rx-group-2 bg-blue-subtle) + (bg-search-rx-group-3 bg-yellow-subtle) + ;;;; Space mappings (bg-space unspecified) @@ -374,10 +403,10 @@ standard)." ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -409,10 +438,10 @@ standard)." (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el index b41d5491c2e..fb2ff99a74b 100644 --- a/etc/themes/modus-operandi-theme.el +++ b/etc/themes/modus-operandi-theme.el @@ -1,11 +1,10 @@ ;;; modus-operandi-theme.el --- Elegant, highly legible theme with a white background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -126,12 +125,12 @@ which corresponds to a minimum contrast in relative luminance of (bg-magenta-subtle "#ffddff") (bg-cyan-subtle "#bfefff") - (bg-red-nuanced "#fff1f0") - (bg-green-nuanced "#ecf7ed") - (bg-yellow-nuanced "#fff3da") - (bg-blue-nuanced "#f3f3ff") - (bg-magenta-nuanced "#fdf0ff") - (bg-cyan-nuanced "#ebf6fa") + (bg-red-nuanced "#ffe8e8") + (bg-green-nuanced "#e0f6e0") + (bg-yellow-nuanced "#f8f0d0") + (bg-blue-nuanced "#ecedff") + (bg-magenta-nuanced "#f8e6f5") + (bg-cyan-nuanced "#e0f2fa") ;;; Uncommon accent backgrounds @@ -210,6 +209,7 @@ which corresponds to a minimum contrast in relative luminance of ;;; Paren match (bg-paren-match "#5fcfff") + (fg-paren-match fg-main) (bg-paren-expression "#efd3f5") (underline-paren-match unspecified) @@ -239,6 +239,11 @@ which corresponds to a minimum contrast in relative luminance of (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-yellow-nuanced) + (fg-active-argument yellow-warmer) + (bg-active-value bg-cyan-nuanced) + (fg-active-value cyan-warmer) + ;;;; Code mappings (builtin magenta-warmer) @@ -341,16 +346,29 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Prose mappings - (prose-block fg-dim) - (prose-code green-cooler) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan-cooler) + + (bg-prose-macro unspecified) + (fg-prose-macro magenta-cooler) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done green) - (prose-macro magenta-cooler) + (prose-todo red) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) + (prose-table-formula magenta-warmer) + (prose-tag magenta-faint) - (prose-todo red) - (prose-verbatim magenta-warmer) ;;;; Rainbow mappings @@ -364,6 +382,17 @@ which corresponds to a minimum contrast in relative luminance of (rainbow-7 blue-warmer) (rainbow-8 magenta-warmer) +;;;; Search mappings + + (bg-search-current bg-yellow-intense) + (bg-search-lazy bg-cyan-intense) + (bg-search-replace bg-red-intense) + + (bg-search-rx-group-0 bg-blue-intense) + (bg-search-rx-group-1 bg-green-intense) + (bg-search-rx-group-2 bg-red-subtle) + (bg-search-rx-group-3 bg-magenta-subtle) + ;;;; Space mappings (bg-space unspecified) @@ -372,10 +401,10 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -407,10 +436,10 @@ which corresponds to a minimum contrast in relative luminance of (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings diff --git a/etc/themes/modus-operandi-tinted-theme.el b/etc/themes/modus-operandi-tinted-theme.el index 7e0ad3d7ea8..f112456034b 100644 --- a/etc/themes/modus-operandi-tinted-theme.el +++ b/etc/themes/modus-operandi-tinted-theme.el @@ -1,11 +1,11 @@ -;;; modus-operandi-tinted-theme.el --- Elegant, highly legible theme with a light ocher background -*- lexical-binding:t -*- +;;; modus-operandi-tinted-theme.el --- Elegant, highly legible theme with a light ochre background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes +;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -44,7 +44,7 @@ ;;;###theme-autoload (deftheme modus-operandi-tinted - "Elegant, highly legible theme with a light ocher background. + "Elegant, highly legible theme with a light ochre background. Conforms with the highest legibility standard for color contrast between background and foreground in any given piece of text, which corresponds to a minimum contrast in relative luminance of @@ -125,12 +125,12 @@ which corresponds to a minimum contrast in relative luminance of (bg-magenta-subtle "#ffddff") (bg-cyan-subtle "#bfefff") - (bg-red-nuanced "#ffe8f0") - (bg-green-nuanced "#e0f5e0") - (bg-yellow-nuanced "#f9ead0") - (bg-blue-nuanced "#ebebff") - (bg-magenta-nuanced "#f6e7ff") - (bg-cyan-nuanced "#e1f3fc") + (bg-red-nuanced "#ffe8e8") + (bg-green-nuanced "#e0f6e0") + (bg-yellow-nuanced "#f8f0d0") + (bg-blue-nuanced "#ecedff") + (bg-magenta-nuanced "#f8e6f5") + (bg-cyan-nuanced "#e0f2fa") ;;; Uncommon accent backgrounds @@ -209,6 +209,7 @@ which corresponds to a minimum contrast in relative luminance of ;;; Paren match (bg-paren-match "#7fdfcf") + (fg-paren-match fg-main) (bg-paren-expression "#efd3f5") (underline-paren-match unspecified) @@ -217,9 +218,9 @@ which corresponds to a minimum contrast in relative luminance of ;;;; General mappings (fringe bg-dim) - (cursor red) + (cursor red-intense) - (keybind blue-cooler) + (keybind red) (name magenta) (identifier yellow-cooler) @@ -238,6 +239,11 @@ which corresponds to a minimum contrast in relative luminance of (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-yellow-nuanced) + (fg-active-argument yellow-warmer) + (bg-active-value bg-cyan-nuanced) + (fg-active-value cyan-warmer) + ;;;; Code mappings (builtin magenta-warmer) @@ -340,16 +346,29 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Prose mappings - (prose-block fg-dim) - (prose-code green-cooler) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan-cooler) + + (bg-prose-macro unspecified) + (fg-prose-macro magenta-cooler) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done green) - (prose-macro magenta-cooler) + (prose-todo red) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) + (prose-table-formula magenta-warmer) + (prose-tag magenta-faint) - (prose-todo red) - (prose-verbatim magenta-warmer) ;;;; Rainbow mappings @@ -363,6 +382,17 @@ which corresponds to a minimum contrast in relative luminance of (rainbow-7 blue-warmer) (rainbow-8 magenta-warmer) +;;;; Search mappings + + (bg-search-current bg-yellow-intense) + (bg-search-lazy bg-cyan-intense) + (bg-search-replace bg-red-intense) + + (bg-search-rx-group-0 bg-blue-intense) + (bg-search-rx-group-1 bg-green-intense) + (bg-search-rx-group-2 bg-red-subtle) + (bg-search-rx-group-3 bg-magenta-subtle) + ;;;; Space mappings (bg-space unspecified) @@ -371,10 +401,10 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -406,10 +436,10 @@ which corresponds to a minimum contrast in relative luminance of (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings diff --git a/etc/themes/modus-operandi-tritanopia-theme.el b/etc/themes/modus-operandi-tritanopia-theme.el index 968a6526ca3..56be8329784 100644 --- a/etc/themes/modus-operandi-tritanopia-theme.el +++ b/etc/themes/modus-operandi-tritanopia-theme.el @@ -1,11 +1,10 @@ ;;; modus-operandi-tritanopia-theme.el --- Tritanopia-optimized theme with a white background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -128,12 +127,12 @@ standard)." (bg-magenta-subtle "#ffddff") (bg-cyan-subtle "#bfefff") - (bg-red-nuanced "#fff1f0") - (bg-green-nuanced "#ecf7ed") - (bg-yellow-nuanced "#fff3da") - (bg-blue-nuanced "#f3f3ff") - (bg-magenta-nuanced "#fdf0ff") - (bg-cyan-nuanced "#ebf6fa") + (bg-red-nuanced "#ffe8e8") + (bg-green-nuanced "#e0f6e0") + (bg-yellow-nuanced "#f8f0d0") + (bg-blue-nuanced "#ecedff") + (bg-magenta-nuanced "#f8e6f5") + (bg-cyan-nuanced "#e0f2fa") ;;; Uncommon accent backgrounds @@ -212,6 +211,7 @@ standard)." ;;; Paren match (bg-paren-match "#5fcfff") + (fg-paren-match fg-main) (bg-paren-expression "#efd3f5") (underline-paren-match unspecified) @@ -241,6 +241,11 @@ standard)." (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-red-nuanced) + (fg-active-argument red-warmer) + (bg-active-value bg-cyan-nuanced) + (fg-active-value cyan) + ;;;; Code mappings (builtin magenta) @@ -343,16 +348,29 @@ standard)." ;;;; Prose mappings - (prose-block fg-dim) - (prose-code cyan) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan) + + (bg-prose-macro unspecified) + (fg-prose-macro red-warmer) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done cyan) - (prose-macro red-warmer) + (prose-todo red) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) - (prose-tag fg-alt) - (prose-todo red) - (prose-verbatim magenta-warmer) + (prose-table-formula red-cooler) + + (prose-tag magenta-faint) ;;;; Rainbow mappings @@ -366,6 +384,17 @@ standard)." (rainbow-7 magenta-faint) (rainbow-8 red-faint) +;;;; Search mappings + + (bg-search-current bg-red-intense) + (bg-search-lazy bg-cyan-intense) + (bg-search-replace bg-magenta-intense) + + (bg-search-rx-group-0 bg-blue-intense) + (bg-search-rx-group-1 bg-magenta-intense) + (bg-search-rx-group-2 bg-cyan-subtle) + (bg-search-rx-group-3 bg-red-subtle) + ;;;; Space mappings (bg-space unspecified) @@ -374,10 +403,10 @@ standard)." ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -409,10 +438,10 @@ standard)." (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index 44f25182a30..b776f12671e 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -1,12 +1,11 @@ ;;; modus-themes.el --- Elegant, highly legible and customizable themes -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes -;; Version: 4.3.0 +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes +;; Version: 4.4.0 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: faces, theme, accessibility @@ -37,9 +36,7 @@ -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) +(eval-when-compile (require 'subr-x)) (defgroup modus-themes () "User options for the Modus themes. @@ -66,11 +63,6 @@ deficiency (deuteranopia or tritanopia, respectively)." :prefix "modus-themes-" :tag "Modus Themes Faces") -(make-obsolete-variable 'modus-themes-operandi-colors nil "4.0.0") -(make-obsolete-variable 'modus-themes-vivendi-colors nil "4.0.0") -(make-obsolete-variable 'modus-themes-version nil "4.0.0") -(make-obsolete 'modus-themes-report-bug nil "4.0.0") - ;;;; Custom faces @@ -139,7 +131,7 @@ deficiency (deuteranopia or tritanopia, respectively)." :version "30.1" :group 'modus-themes-faces)) -(dolist (scope '(current lazy)) +(dolist (scope '(current lazy replace)) (custom-declare-face (intern (format "modus-themes-search-%s" scope)) nil (format "Search of type %s." scope) @@ -147,15 +139,13 @@ deficiency (deuteranopia or tritanopia, respectively)." :version "30.1" :group 'modus-themes-faces)) -(define-obsolete-variable-alias - 'modus-themes-search-success - 'modus-themes-search-current - "4.0.0") - -(define-obsolete-variable-alias - 'modus-themes-search-success-lazy - 'modus-themes-search-lazy - "4.0.0") +(dotimes (n 4) + (custom-declare-face + (intern (format "modus-themes-search-rx-group-%s" n)) + nil (format "Search regexp group number %s." n) + :package-version '(modus-themes . "4.4.0") + :version "30.1" + :group 'modus-themes-faces)) (dolist (scope '(code macro verbatim)) (custom-declare-face @@ -165,21 +155,6 @@ deficiency (deuteranopia or tritanopia, respectively)." :version "30.1" :group 'modus-themes-faces)) -(define-obsolete-variable-alias - 'modus-themes-markup-code - 'modus-themes-prose-code - "4.0.0") - -(define-obsolete-variable-alias - 'modus-themes-markup-macro - 'modus-themes-prose-macro - "4.0.0") - -(define-obsolete-variable-alias - 'modus-themes-markup-verbatim - 'modus-themes-prose-verbatim - "4.0.0") - (dotimes (n 9) (custom-declare-face (intern (format "modus-themes-heading-%d" n)) @@ -248,67 +223,6 @@ text should not be underlined as well) yet still blend in." :version "30.1" :group 'modus-themes-faces)) -(make-obsolete-variable 'modus-themes-reset-hard nil "4.0.0") -(make-obsolete-variable 'modus-themes-subtle-neutral nil "4.0.0") -(make-obsolete-variable 'modus-themes-intense-neutral nil "4.0.0") -(make-obsolete-variable 'modus-themes-refine-red nil "4.0.0") -(make-obsolete-variable 'modus-themes-refine-green nil "4.0.0") -(make-obsolete-variable 'modus-themes-refine-yellow nil "4.0.0") -(make-obsolete-variable 'modus-themes-refine-blue nil "4.0.0") -(make-obsolete-variable 'modus-themes-refine-magenta nil "4.0.0") -(make-obsolete-variable 'modus-themes-refine-cyan nil "4.0.0") -(make-obsolete-variable 'modus-themes-active-red nil "4.0.0") -(make-obsolete-variable 'modus-themes-active-green nil "4.0.0") -(make-obsolete-variable 'modus-themes-active-yellow nil "4.0.0") -(make-obsolete-variable 'modus-themes-active-blue nil "4.0.0") -(make-obsolete-variable 'modus-themes-active-magenta nil "4.0.0") -(make-obsolete-variable 'modus-themes-active-cyan nil "4.0.0") -(make-obsolete-variable 'modus-themes-fringe-red nil "4.0.0") -(make-obsolete-variable 'modus-themes-fringe-green nil "4.0.0") -(make-obsolete-variable 'modus-themes-fringe-yellow nil "4.0.0") -(make-obsolete-variable 'modus-themes-fringe-blue nil "4.0.0") -(make-obsolete-variable 'modus-themes-fringe-magenta nil "4.0.0") -(make-obsolete-variable 'modus-themes-fringe-cyan nil "4.0.0") -(make-obsolete-variable 'modus-themes-grue nil "4.0.0") -(make-obsolete-variable 'modus-themes-grue-nuanced nil "4.0.0") -(make-obsolete-variable 'modus-themes-red-nuanced nil "4.0.0") -(make-obsolete-variable 'modus-themes-green-nuanced nil "4.0.0") -(make-obsolete-variable 'modus-themes-yellow-nuanced nil "4.0.0") -(make-obsolete-variable 'modus-themes-blue-nuanced nil "4.0.0") -(make-obsolete-variable 'modus-themes-magenta-nuanced nil "4.0.0") -(make-obsolete-variable 'modus-themes-cyan-nuanced nil "4.0.0") -(make-obsolete-variable 'modus-themes-special-calm nil "4.0.0") -(make-obsolete-variable 'modus-themes-special-cold nil "4.0.0") -(make-obsolete-variable 'modus-themes-special-mild nil "4.0.0") -(make-obsolete-variable 'modus-themes-special-warm nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-added nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-changed nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-removed nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-refine-added nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-refine-changed nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-refine-removed nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-focus-added nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-focus-changed nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-focus-removed nil "4.0.0") -(make-obsolete-variable 'modus-themes-diff-heading nil "4.0.0") -(make-obsolete-variable 'modus-themes-pseudo-header nil "4.0.0") -(make-obsolete-variable 'modus-themes-mark-symbol nil "4.0.0") -(make-obsolete-variable 'modus-themes-hl-line nil "4.0.0") -(make-obsolete-variable 'modus-themes-search-success-modeline nil "4.0.0") -(make-obsolete-variable 'modus-themes-grue-active nil "4.0.0") -(make-obsolete-variable 'modus-themes-grue-background-active nil "4.0.0") -(make-obsolete-variable 'modus-themes-grue-background-intense nil "4.0.0") -(make-obsolete-variable 'modus-themes-grue-background-subtle nil "4.0.0") -(make-obsolete-variable 'modus-themes-grue-background-refine nil "4.0.0") -(make-obsolete-variable 'modus-themes-link-broken nil "4.0.0") -(make-obsolete-variable 'modus-themes-link-symlink nil "4.0.0") -(make-obsolete-variable 'modus-themes-tab-backdrop nil "4.0.0") -(make-obsolete-variable 'modus-themes-tab-active nil "4.0.0") -(make-obsolete-variable 'modus-themes-tab-inactive nil "4.0.0") -(make-obsolete-variable 'modus-themes-completion-selected-popup nil "4.0.0") -(make-obsolete-variable 'modus-themes-box-button nil "4.0.0") -(make-obsolete-variable 'modus-themes-box-button-pressed nil "4.0.0") - ;;;; Customization variables @@ -331,8 +245,6 @@ consequences. The user must manually reload the theme." :type 'boolean :link '(info-link "(modus-themes) Custom reload theme")) -(make-obsolete-variable 'modus-themes-inhibit-reload 'modus-themes-custom-auto-reload "4.0.0") - (defun modus-themes--set-option (sym val) "Custom setter for theme related user options. Will set SYM to VAL, and reload the current theme, unless @@ -422,9 +334,6 @@ This is used by the command `modus-themes-toggle'." :initialize #'custom-initialize-default :group 'modus-themes) -(make-obsolete-variable 'modus-themes-operandi-color-overrides nil "4.0.0") -(make-obsolete-variable 'modus-themes-vivendi-color-overrides nil "4.0.0") - (defvaralias 'modus-themes-slanted-constructs 'modus-themes-italic-constructs) (defcustom modus-themes-italic-constructs nil @@ -477,8 +386,6 @@ Protesilaos))." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Mixed fonts")) -(make-obsolete-variable 'modus-themes-intense-mouseovers nil "4.0.0") - (defconst modus-themes--weight-widget '(choice :tag "Font weight (must be supported by the typeface)" (const :tag "Unspecified (use whatever the default is)" nil) @@ -611,51 +518,7 @@ and related user options." :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Heading styles")) -(make-obsolete-variable 'modus-themes-org-agenda nil "4.0.0") -(make-obsolete-variable 'modus-themes-fringes nil "4.0.0") -(make-obsolete-variable 'modus-themes-lang-checkers nil "4.0.0") - -(defcustom modus-themes-org-blocks nil - "Set the overall style of Org code blocks, quotes, and the like. - -Nil (the default) means that the block has no background of its -own: it uses the one that applies to the rest of the buffer. In -this case, the delimiter lines have a gray color for their text, -making them look exactly like all other Org properties. - -Option `gray-background' applies a subtle gray background to the -block's contents. It also affects the begin and end lines of the -block as they get another shade of gray as their background, -which differentiates them from the contents of the block. All -background colors extend to the edge of the window, giving the -area a rectangular, \"blocky\" presentation. If the begin/end -lines do not extend in this way, check the value of the Org user -option `org-fontify-whole-block-delimiter-line'. - -Option `tinted-background' uses a colored background for the -contents of the block. The exact color value will depend on the -programming language and is controlled by the variable -`org-src-block-faces' (refer to the theme's source code for the -current association list). For this to take effect, the Org -buffer needs to be restarted with `org-mode-restart'. - -Code blocks use their major mode's fontification (syntax -highlighting) only when the variable `org-src-fontify-natively' -is non-nil. While quote/verse blocks require setting -`org-fontify-quote-and-verse-blocks' to a non-nil value." - :group 'modus-themes - :package-version '(modus-themes . "4.0.0") - :version "30.1" - :type '(choice - (const :format "[%v] %t\n" :tag "No Org block background (default)" nil) - (const :format "[%v] %t\n" :tag "Subtle gray block background" gray-background) - (const :format "[%v] %t\n" :tag "Color-coded background per programming language" tinted-background)) - :set #'modus-themes--set-option - :initialize #'custom-initialize-default - :link '(info-link "(modus-themes) Org mode blocks")) - -(make-obsolete-variable 'modus-themes-mode-line nil "4.0.0") -(make-obsolete-variable 'modus-themes-diffs nil "4.0.0") +(make-obsolete-variable 'modus-themes-org-blocks nil "4.4.0: Use palette overrides") (defcustom modus-themes-completions nil "Control the style of completion user interfaces. @@ -778,17 +641,6 @@ In user configuration files the form may look like this: :initialize #'custom-initialize-default :link '(info-link "(modus-themes) Command prompts")) -(make-obsolete-variable 'modus-themes-subtle-line-numbers nil "4.0.0") -(make-obsolete-variable 'modus-themes-markup nil "4.0.0") -(make-obsolete-variable 'modus-themes-paren-match nil "4.0.0") -(make-obsolete-variable 'modus-themes-syntax nil "4.0.0") -(make-obsolete-variable 'modus-themes-links nil "4.0.0") -(make-obsolete-variable 'modus-themes-region nil "4.0.0") -(make-obsolete-variable 'modus-themes-deuteranopia nil "4.0.0") -(make-obsolete-variable 'modus-themes-mail-citations nil "4.0.0") -(make-obsolete-variable 'modus-themes-tabs-accented nil "4.0.0") -(make-obsolete-variable 'modus-themes-box-buttons nil "4.0.0") - (defcustom modus-themes-common-palette-overrides nil "Set palette overrides for all the Modus themes. @@ -918,12 +770,13 @@ represents." (fg-prompt cyan-faint) - (prose-code olive) + (fg-prose-code olive) + (fg-prose-macro indigo) + (fg-prose-verbatim maroon) + (prose-done green-faint) - (prose-macro indigo) (prose-tag rust) (prose-todo red-faint) - (prose-verbatim maroon) (rainbow-0 fg-main) (rainbow-1 magenta) @@ -983,17 +836,18 @@ Info node `(modus-themes) Option for palette overrides'.") (keybind blue-intense) (mail-cite-0 blue) - (mail-cite-1 yellow) - (mail-cite-2 green) + (mail-cite-1 yellow-cooler) + (mail-cite-2 green-warmer) (mail-cite-3 magenta) - (mail-part magenta-cooler) - (mail-recipient cyan) + (mail-part cyan) + (mail-recipient magenta-cooler) (mail-subject red-warmer) (mail-other cyan-cooler) (fg-prompt blue-intense) - (prose-block red-faint) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter red-faint) (prose-done green-intense) (prose-metadata magenta-faint) (prose-metadata-value blue-cooler) @@ -1081,7 +935,7 @@ Info node `(modus-themes) Option for palette overrides'.") (mail-other blue) (prose-tag fg-dim) - (prose-verbatim blue-cooler)) + (fg-prose-verbatim blue-cooler)) "Preset of palette overrides with cooler colors. This changes parts of the palette to use more blue and @@ -1136,7 +990,7 @@ Info node `(modus-themes) Option for palette overrides'.") (mail-subject blue-warmer) (mail-other magenta-warmer) - (prose-macro red-cooler) + (fg-prose-macro red-cooler) (prose-tag fg-dim)) "Preset of palette overrides with warmer colors. @@ -1162,14 +1016,22 @@ Info node `(modus-themes) Option for palette overrides'.") ;;;; Helper functions for theme setup ;; This is the WCAG formula: https://www.w3.org/TR/WCAG20-TECHS/G18.html +(defun modus-themes--wcag-contribution (channel weight) + "Return the CHANNEL contribution to overall luminance given WEIGHT." + (* weight + (if (<= channel 0.03928) + (/ channel 12.92) + (expt (/ (+ channel 0.055) 1.055) 2.4)))) + (defun modus-themes-wcag-formula (hex) "Get WCAG value of color value HEX. The value is defined in hexadecimal RGB notation, such #123456." - (cl-loop for k in '(0.2126 0.7152 0.0722) - for x in (color-name-to-rgb hex) - sum (* k (if (<= x 0.03928) - (/ x 12.92) - (expt (/ (+ x 0.055) 1.055) 2.4))))) + (let ((channels (color-name-to-rgb hex)) + (weights '(0.2126 0.7152 0.0722)) + contribution) + (while channels + (push (modus-themes--wcag-contribution (pop channels) (pop weights)) contribution)) + (apply #'+ contribution))) ;;;###autoload (defun modus-themes-contrast (c1 c2) @@ -1179,32 +1041,27 @@ C1 and C2 are color values written in hexadecimal RGB." (+ (modus-themes-wcag-formula c2) 0.05)))) (max ct (/ ct)))) -(make-obsolete 'modus-themes-color nil "4.0.0") -(make-obsolete 'modus-themes-color-alts nil "4.0.0") - -(declare-function cl-remove-if-not "cl-seq" (cl-pred cl-list &rest cl-keys)) +(defun modus-themes--modus-p (theme) + "Return non-nil if THEME name has a modus- prefix." + (string-prefix-p "modus-" (symbol-name theme))) (defun modus-themes--list-enabled-themes () "Return list of `custom-enabled-themes' with modus- prefix." - (cl-remove-if-not - (lambda (theme) - (string-prefix-p "modus-" (symbol-name theme))) - custom-enabled-themes)) + (seq-filter #'modus-themes--modus-p custom-enabled-themes)) + +(defun modus-themes--load-no-enable (theme) + "Load but do not enable THEME if it belongs to `custom-known-themes'." + (unless (memq theme custom-known-themes) + (load-theme theme :no-confirm :no-enable))) (defun modus-themes--enable-themes () "Enable the Modus themes." - (mapc (lambda (theme) - (unless (memq theme custom-known-themes) - (load-theme theme :no-confirm :no-enable))) - modus-themes-items)) + (mapc #'modus-themes--load-no-enable modus-themes-items)) (defun modus-themes--list-known-themes () "Return list of `custom-known-themes' with modus- prefix." (modus-themes--enable-themes) - (cl-remove-if-not - (lambda (theme) - (string-prefix-p "modus-" (symbol-name theme))) - custom-known-themes)) + (seq-filter #'modus-themes--modus-p custom-known-themes)) (defun modus-themes--current-theme () "Return first enabled Modus theme." @@ -1311,10 +1168,6 @@ symbol, which is safe when used as a face attribute's value." ;;;; Commands -(make-obsolete 'modus-themes-load-themes nil "4.0.0") -(make-obsolete 'modus-themes-load-operandi nil "4.0.0; Check `modus-themes-load-theme'") -(make-obsolete 'modus-themes-load-vivendi nil "4.0.0; Check `modus-themes-load-theme'") - (defvar modus-themes--select-theme-history nil "Minibuffer history of `modus-themes--select-prompt'.") @@ -1322,7 +1175,9 @@ symbol, which is safe when used as a face attribute's value." "Return completion annotation for THEME." (when-let ((symbol (intern-soft theme)) (doc-string (get symbol 'theme-documentation))) - (format " -- %s" (car (split-string doc-string "\\."))))) + (format " -- %s" + (propertize (car (split-string doc-string "\\.")) + 'face 'completions-annotations)))) (defun modus-themes--completion-table (category candidates) "Pass appropriate metadata CATEGORY to completion CANDIDATES." @@ -1486,8 +1341,7 @@ Check PROPERTIES for an alist value that corresponds to ALIST-KEY. If no alist is present, search the PROPERTIES list given LIST-PRED, using DEFAULT as a fallback." (if-let* ((val (or (alist-get alist-key properties) - (cl-loop for x in properties - if (funcall list-pred x) return x) + (seq-filter (lambda (x) (funcall list-pred x)) properties) default)) ((listp val))) (car val) @@ -1535,7 +1389,7 @@ color that is combined with FG-FOR-BG." :foreground fg :weight ;; If we have `bold' specifically, we inherit the face of - ;; the same name. This allows the user to customize that + ;; the same name. This allows the user to customise that ;; face, such as to change its font family. (if (and weight (not (eq weight 'bold))) weight @@ -1581,16 +1435,6 @@ Optional OL is the color of an overline." 'unspecified) :weight (or weight 'unspecified)))) -(defun modus-themes--org-block (fg bg) - "Conditionally set the FG and BG of Org blocks." - (let ((gray (or (eq modus-themes-org-blocks 'gray-background) - (eq modus-themes-org-blocks 'grayscale) ; for backward compatibility - (eq modus-themes-org-blocks 'greyscale)))) - (list :inherit 'modus-themes-fixed-pitch - :background (if gray bg 'unspecified) - :foreground (if gray 'unspecified fg) - :extend (if gray t 'unspecified)))) - (defun modus-themes--completion-line (bg) "Styles for `modus-themes-completions' with BG as the background." (let* ((var (modus-themes--list-or-warn 'modus-themes-completions)) @@ -1723,12 +1567,18 @@ FG and BG are the main colors." `(modus-themes-prominent-note ((,c :background ,bg-prominent-note :foreground ,fg-prominent-note))) `(modus-themes-prominent-warning ((,c :background ,bg-prominent-warning :foreground ,fg-prominent-warning))) ;;;;; markup - `(modus-themes-prose-code ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-code))) - `(modus-themes-prose-macro ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-macro))) - `(modus-themes-prose-verbatim ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-verbatim))) + `(modus-themes-prose-code ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-code :foreground ,fg-prose-code))) + `(modus-themes-prose-macro ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-macro :foreground ,fg-prose-macro))) + `(modus-themes-prose-verbatim ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-verbatim :foreground ,fg-prose-verbatim))) ;;;;; search - `(modus-themes-search-current ((,c :background ,bg-yellow-intense :foreground ,fg-main))) - `(modus-themes-search-lazy ((,c :background ,bg-cyan-intense :foreground ,fg-main))) + `(modus-themes-search-current ((,c :background ,bg-search-current :foreground ,fg-main))) + `(modus-themes-search-lazy ((,c :background ,bg-search-lazy :foreground ,fg-main))) + `(modus-themes-search-replace ((,c :background ,bg-search-replace :foreground ,fg-main))) +;;;;; search regexp groups + `(modus-themes-search-rx-group-0 ((,c :background ,bg-search-rx-group-0 :foreground ,fg-main))) + `(modus-themes-search-rx-group-1 ((,c :background ,bg-search-rx-group-1 :foreground ,fg-main))) + `(modus-themes-search-rx-group-2 ((,c :background ,bg-search-rx-group-2 :foreground ,fg-main))) + `(modus-themes-search-rx-group-3 ((,c :background ,bg-search-rx-group-3 :foreground ,fg-main))) ;;;;; completion frameworks `(modus-themes-completion-match-0 ((,c ,@(modus-themes--completion-match fg-completion-match-0 bg-completion-match-0)))) `(modus-themes-completion-match-1 ((,c ,@(modus-themes--completion-match fg-completion-match-1 bg-completion-match-1)))) @@ -1756,12 +1606,12 @@ FG and BG are the main colors." `(cursor ((,c :background ,cursor))) `(fringe ((,c :background ,fringe :foreground ,fg-main))) `(menu ((,c :background ,bg-dim :foreground ,fg-main))) - `(scroll-bar ((,c :background ,bg-dim :foreground ,fg-dim))) + `(scroll-bar ((,c :background ,fringe :foreground ,border))) `(tool-bar ((,c :background ,bg-dim :foreground ,fg-main))) `(vertical-border ((,c :foreground ,border))) ;;;;; basic and/or ungrouped styles - `(appt-notification ((,c :inherit error))) - `(blink-matching-paren-highlight-offscreen ((,c :background ,bg-paren-match))) + `(appt-notification ((,c :inherit bold :foreground ,modeline-err))) + `(blink-matching-paren-offscreen ((,c :background ,bg-paren-match))) `(bold ((,c :weight bold))) `(bold-italic ((,c :inherit (bold italic)))) `(underline ((,c :underline ,fg-dim))) @@ -1776,7 +1626,7 @@ FG and BG are the main colors." `(escape-glyph ((,c :foreground ,err))) `(file-name-shadow ((,c :inherit shadow))) `(header-line ((,c :inherit modus-themes-ui-variable-pitch :background ,bg-dim))) - `(header-line-highlight ((,c :inherit highlight))) + `(header-line-highlight ((,c :background ,bg-hover :foreground ,fg-main :box ,fg-main))) `(help-argument-name ((,c :inherit modus-themes-slant :foreground ,variable))) `(help-key-binding ((,c :inherit modus-themes-key-binding))) `(highlight ((,c :background ,bg-hover :foreground ,fg-main))) @@ -1792,7 +1642,7 @@ FG and BG are the main colors." `(mm-uu-extract ((,c :foreground ,mail-part))) `(next-error ((,c :inherit modus-themes-prominent-error :extend t))) `(pgtk-im-0 ((,c :inherit modus-themes-prominent-note))) - `(read-multiple-choice-face ((,c :inherit (bold modus-themes-mark-alt)))) + `(read-multiple-choice-face ((,c :inherit modus-themes-mark-sel))) `(rectangle-preview ((,c :inherit secondary-selection))) `(region ((,c :background ,bg-region :foreground ,fg-region))) `(secondary-selection ((,c :background ,bg-hover-secondary :foreground ,fg-main))) @@ -1909,7 +1759,7 @@ FG and BG are the main colors." `(anzu-match-3 ((,c :inherit modus-themes-subtle-yellow))) `(anzu-mode-line ((,c :inherit bold))) `(anzu-mode-line-no-match ((,c :inherit error))) - `(anzu-replace-highlight ((,c :inherit modus-themes-prominent-error :underline t))) + `(anzu-replace-highlight ((,c :inherit modus-themes-search-replace))) `(anzu-replace-to ((,c :inherit modus-themes-search-current))) ;;;;; auctex and Tex `(font-latex-bold-face ((,c :inherit bold))) @@ -2097,6 +1947,7 @@ FG and BG are the main colors." `(completions-annotations ((,c :inherit modus-themes-slant :foreground ,docstring))) `(completions-common-part ((,c :inherit modus-themes-completion-match-0))) `(completions-first-difference ((,c :inherit modus-themes-completion-match-1))) + `(completions-highlight ((,c :inherit modus-themes-completion-selected))) ;;;;; consult `(consult-async-split ((,c :inherit error))) `(consult-file ((,c :inherit modus-themes-bold :foreground ,info))) @@ -2104,6 +1955,7 @@ FG and BG are the main colors." `(consult-imenu-prefix ((,c :inherit shadow))) `(consult-line-number ((,c :inherit shadow))) `(consult-line-number-prefix ((,c :inherit shadow))) + `(consult-preview-insertion ((,c :background ,bg-dim))) ;;;;; corfu `(corfu-current ((,c :inherit modus-themes-completion-selected))) `(corfu-bar ((,c :background ,fg-dim))) @@ -2164,6 +2016,22 @@ FG and BG are the main colors." `(deadgrep-meta-face ((,c :inherit shadow))) `(deadgrep-regexp-metachar-face ((,c :inherit font-lock-regexp-grouping-construct))) `(deadgrep-search-term-face ((,c :inherit success))) +;;;;; debbugs + `(debbugs-gnu-archived ((,c :background ,bg-inactive :foreground ,fg-dim))) + `(debbugs-gnu-done ((,c :inherit success))) + `(debbugs-gnu-forwarded ((,c :inherit modus-themes-slant :foreground ,info))) + `(debbugs-gnu-handled (( ))) + `(debbugs-gnu-marked ((,c :inherit modus-themes-mark-sel))) + `(debbugs-gnu-marked-stale ((,c :inherit modus-themes-mark-alt))) + `(debbugs-gnu-new ((,c :inherit error))) + `(debbugs-gnu-pending ((,c :inherit modus-themes-slant :foreground ,fg-alt))) + `(debbugs-gnu-stale-1 ((,c :foreground ,red-cooler))) + `(debbugs-gnu-stale-2 ((,c :foreground ,yellow-warmer))) + `(debbugs-gnu-stale-3 ((,c :foreground ,magenta-warmer))) + `(debbugs-gnu-stale-4 ((,c :foreground ,magenta-cooler))) + `(debbugs-gnu-stale-5 ((,c :foreground ,cyan-faint))) + `(debbugs-gnu-tagged ((,c :inherit modus-themes-mark-alt))) + `(debbugs-gnu-title ((,c :inherit bold))) ;;;;; deft `(deft-filter-string-face ((,c :inherit success))) `(deft-header-face ((,c :inherit shadow))) @@ -2171,6 +2039,20 @@ FG and BG are the main colors." `(deft-summary-face ((,c :inherit (shadow modus-themes-slant)))) `(deft-time-face ((,c :foreground ,date-common))) `(deft-title-face ((,c :inherit bold))) +;;;;; denote + `(denote-faces-date ((,c :foreground ,date-common))) + `(denote-faces-delimiter ((,c :inherit shadow))) + `(denote-faces-extension ((,c :inherit shadow))) + `(denote-faces-keywords ((,c :inherit modus-themes-bold :foreground ,keyword))) + `(denote-faces-link ((,c :inherit link))) + `(denote-faces-prompt-current-name ((,c :inherit modus-themes-slant :foreground ,fg-changed-intense))) + `(denote-faces-prompt-new-name ((,c :inherit modus-themes-slant :foreground ,fg-added-intense))) + `(denote-faces-prompt-old-name ((,c :inherit modus-themes-slant :foreground ,fg-removed-intense))) + `(denote-faces-signature ((,c :inherit modus-themes-bold :foreground ,string))) + `(denote-faces-subdirectory ((,c :inherit modus-themes-bold :foreground ,fg-alt))) + `(denote-faces-time ((,c :inherit denote-faces-date))) + `(denote-faces-time-delimiter ((,c :inherit shadow))) + `(denote-faces-title (( ))) ;;;;; devdocs `(devdocs-code-block ((,c :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t))) ;;;;; dictionary @@ -2340,7 +2222,7 @@ FG and BG are the main colors." `(el-search-occur-match ((,c :inherit match))) ;;;;; eldoc ;; NOTE: see https://github.com/purcell/package-lint/issues/187 - (list 'eldoc-highlight-function-argument `((,c :inherit modus-themes-mark-alt))) + (list 'eldoc-highlight-function-argument `((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument))) ;;;;; eldoc-box `(eldoc-box-body ((,c :background ,bg-dim :foreground ,fg-main))) `(eldoc-box-border ((,c :background ,border))) @@ -2420,9 +2302,11 @@ FG and BG are the main colors." `(erc-dangerous-host-face ((,c :inherit error))) `(erc-direct-msg-face ((,c :inherit shadow))) `(erc-error-face ((,c :inherit error))) + `(erc-fill-wrap-merge-indicator-face ((,c :foreground ,fg-dim))) `(erc-fool-face ((,c :inherit shadow))) `(erc-input-face ((,c :foreground ,fnname))) `(erc-inverse-face ((,c :inherit erc-default-face :inverse-video t))) + `(erc-keep-place-indicator-arrow ((,c :foreground ,info))) `(erc-keyword-face ((,c :inherit bold :foreground ,keyword))) `(erc-my-nick-face ((,c :inherit bold :foreground ,name))) `(erc-my-nick-prefix-face ((,c :inherit erc-my-nick-face))) @@ -2463,7 +2347,7 @@ FG and BG are the main colors." `(evil-ex-info ((,c :inherit font-lock-type-face))) `(evil-ex-lazy-highlight ((,c :inherit modus-themes-search-lazy))) `(evil-ex-search ((,c :inherit modus-themes-search-current))) - `(evil-ex-substitute-matches ((,c :inherit modus-themes-prominent-error :underline t))) + `(evil-ex-substitute-matches ((,c :inherit modus-themes-search-replace))) `(evil-ex-substitute-replacement ((,c :inherit modus-themes-search-current))) ;;;;; eww `(eww-invalid-certificate ((,c :foreground ,err))) @@ -2533,7 +2417,7 @@ FG and BG are the main colors." `(font-lock-variable-name-face ((,c :foreground ,variable))) `(font-lock-warning-face ((,c :inherit modus-themes-bold :foreground ,warning))) ;;;;; geiser - `(geiser-font-lock-autodoc-current-arg ((,c :inherit modus-themes-mark-alt))) + `(geiser-font-lock-autodoc-current-arg ((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument))) `(geiser-font-lock-autodoc-identifier ((,c :foreground ,docstring))) `(geiser-font-lock-doc-button ((,c :inherit button))) `(geiser-font-lock-doc-link ((,c :inherit button))) @@ -2574,7 +2458,7 @@ FG and BG are the main colors." `(git-timemachine-minibuffer-author-face ((,c :foreground ,name))) `(git-timemachine-minibuffer-detail-face ((,c :foreground ,fg-main))) ;;;;; gnus - `(gnus-button ((,c :inherit button))) + `(gnus-button ((,c :inherit button :underline nil))) `(gnus-cite-1 ((,c :inherit message-cited-text-1))) `(gnus-cite-2 ((,c :inherit message-cited-text-2))) `(gnus-cite-3 ((,c :inherit message-cited-text-3))) @@ -2665,37 +2549,37 @@ FG and BG are the main colors." ;; entries in their palette for such an edge case. Defining those ;; entries is not appropriate. `(hi-aquamarine ((((class color) (min-colors 88) (background light)) - :background "white" :foreground "#227f9f" :inverse-video t) + :background "#ffffff" :foreground "#227f9f" :inverse-video t) (((class color) (min-colors 88) (background dark)) - :background "black" :foreground "#66cbdc" :inverse-video t))) + :background "#000000" :foreground "#66cbdc" :inverse-video t))) `(hi-black-b ((,c :inverse-video t))) `(hi-black-hb ((,c :background ,bg-main :foreground ,fg-dim :inverse-video t))) `(hi-blue ((((class color) (min-colors 88) (background light)) - :background "white" :foreground "#3366dd" :inverse-video t) + :background "#ffffff" :foreground "#3366dd" :inverse-video t) (((class color) (min-colors 88) (background dark)) - :background "black" :foreground "#aaccff" :inverse-video t))) + :background "#000000" :foreground "#aaccff" :inverse-video t))) `(hi-blue-b ((,c :inherit (bold hi-blue)))) `(hi-green ((((class color) (min-colors 88) (background light)) - :background "white" :foreground "#008a00" :inverse-video t) + :background "#ffffff" :foreground "#008a00" :inverse-video t) (((class color) (min-colors 88) (background dark)) - :background "black" :foreground "#66dd66" :inverse-video t))) + :background "#000000" :foreground "#66dd66" :inverse-video t))) `(hi-green-b ((,c :inherit (bold hi-green)))) `(hi-pink ((((class color) (min-colors 88) (background light)) - :background "white" :foreground "#bd30aa" :inverse-video t) + :background "#ffffff" :foreground "#bd30aa" :inverse-video t) (((class color) (min-colors 88) (background dark)) - :background "black" :foreground "#ff88ee" :inverse-video t))) + :background "#000000" :foreground "#ff88ee" :inverse-video t))) `(hi-red-b ((((class color) (min-colors 88) (background light)) - :background "white" :foreground "#dd0000" :inverse-video t) + :background "#ffffff" :foreground "#dd0000" :inverse-video t) (((class color) (min-colors 88) (background dark)) - :background "black" :foreground "#f06666" :inverse-video t))) + :background "#000000" :foreground "#f06666" :inverse-video t))) `(hi-salmon ((((class color) (min-colors 88) (background light)) - :background "white" :foreground "#bf555a" :inverse-video t) + :background "#ffffff" :foreground "#bf555a" :inverse-video t) (((class color) (min-colors 88) (background dark)) - :background "black" :foreground "#e08a50" :inverse-video t))) + :background "#000000" :foreground "#e08a50" :inverse-video t))) `(hi-yellow ((((class color) (min-colors 88) (background light)) - :background "white" :foreground "#af6400" :inverse-video t) + :background "#ffffff" :foreground "#af6400" :inverse-video t) (((class color) (min-colors 88) (background dark)) - :background "black" :foreground "#faea00" :inverse-video t))) + :background "#000000" :foreground "#faea00" :inverse-video t))) `(highlight-changes ((,c :foreground ,warning :underline nil))) `(highlight-changes-delete ((,c :foreground ,err :underline t))) `(hl-line ((,c :background ,bg-hl-line :extend t))) @@ -2735,14 +2619,14 @@ FG and BG are the main colors." `(image-dired-thumb-header-file-size ((,c :foreground ,constant))) `(image-dired-thumb-mark ((,c :inherit modus-themes-mark-sel :box (:line-width -3)))) ;;;;; imenu-list - `(imenu-list-entry-face-0 ((,c :foreground ,fg-heading-0))) - `(imenu-list-entry-face-1 ((,c :foreground ,fg-heading-1))) - `(imenu-list-entry-face-2 ((,c :foreground ,fg-heading-2))) - `(imenu-list-entry-face-3 ((,c :foreground ,fg-heading-3))) - `(imenu-list-entry-subalist-face-0 ((,c :inherit bold :foreground ,fg-heading-4 :underline t))) - `(imenu-list-entry-subalist-face-1 ((,c :inherit bold :foreground ,fg-heading-5 :underline t))) - `(imenu-list-entry-subalist-face-2 ((,c :inherit bold :foreground ,fg-heading-6 :underline t))) - `(imenu-list-entry-subalist-face-3 ((,c :inherit bold :foreground ,fg-heading-7 :underline t))) + `(imenu-list-entry-face-0 ((,c :foreground ,fg-heading-1))) + `(imenu-list-entry-face-1 ((,c :foreground ,fg-heading-2))) + `(imenu-list-entry-face-2 ((,c :foreground ,fg-heading-3))) + `(imenu-list-entry-face-3 ((,c :foreground ,fg-heading-4))) + `(imenu-list-entry-subalist-face-0 ((,c :inherit bold :foreground ,fg-heading-1 :underline t))) + `(imenu-list-entry-subalist-face-1 ((,c :inherit bold :foreground ,fg-heading-2 :underline t))) + `(imenu-list-entry-subalist-face-2 ((,c :inherit bold :foreground ,fg-heading-3 :underline t))) + `(imenu-list-entry-subalist-face-3 ((,c :inherit bold :foreground ,fg-heading-4 :underline t))) ;;;;; indium `(indium-breakpoint-face ((,c :foreground ,err))) `(indium-frame-url-face ((,c :inherit (shadow button)))) @@ -2807,11 +2691,11 @@ FG and BG are the main colors." ;;;;; isearch, occur, and the like `(isearch ((,c :inherit modus-themes-search-current))) `(isearch-fail ((,c :inherit modus-themes-prominent-error))) - `(isearch-group-1 ((,c :inherit modus-themes-intense-blue))) - `(isearch-group-2 ((,c :inherit modus-themes-intense-magenta))) + `(isearch-group-1 ((,c :inherit modus-themes-search-rx-group-0))) + `(isearch-group-2 ((,c :inherit modus-themes-search-rx-group-1))) `(lazy-highlight ((,c :inherit modus-themes-search-lazy))) `(match ((,c :background ,bg-magenta-subtle :foreground ,fg-main))) - `(query-replace ((,c :inherit modus-themes-prominent-error))) + `(query-replace ((,c :inherit modus-themes-search-replace))) ;;;;; ivy `(ivy-action ((,c :inherit modus-themes-key-binding))) `(ivy-confirm-face ((,c :inherit success))) @@ -2876,7 +2760,7 @@ FG and BG are the main colors." `(kaocha-runner-warning-face ((,c :inherit warning))) ;;;;; keycast `(keycast-command ((,c :inherit bold))) - `(keycast-key ((,c :background ,keybind :foreground ,bg-main))) + `(keycast-key ((,c :inherit modus-themes-bold :background ,keybind :foreground ,bg-main))) ;;;;; ledger-mode `(ledger-font-auto-xact-face ((,c :inherit font-lock-builtin-face))) `(ledger-font-account-name-face ((,c :foreground ,name))) @@ -3033,7 +2917,7 @@ FG and BG are the main colors." `(markdown-highlighting-face ((,c :inherit secondary-selection))) `(markdown-inline-code-face ((,c :inherit modus-themes-prose-code))) `(markdown-italic-face ((,c :inherit italic))) - `(markdown-language-keyword-face ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-block))) + `(markdown-language-keyword-face ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-block-delimiter :foreground ,fg-prose-block-delimiter))) `(markdown-line-break-face ((,c :inherit nobreak-space))) `(markdown-link-face ((,c :inherit link))) `(markdown-markup-face ((,c :inherit shadow))) @@ -3046,12 +2930,12 @@ FG and BG are the main colors." ;;;;; markup-faces (`adoc-mode') `(markup-attribute-face ((,c :inherit (modus-themes-slant markup-meta-face)))) `(markup-bold-face ((,c :inherit bold))) - `(markup-code-face ((,c :foreground ,prose-code))) + `(markup-code-face ((,c :inherit modus-themes-prose-code))) `(markup-comment-face ((,c :inherit font-lock-comment-face))) - `(markup-complex-replacement-face ((,c :foreground ,prose-macro))) + `(markup-complex-replacement-face ((,c :inherit modus-themes-prose-macro))) `(markup-emphasis-face ((,c :inherit markup-italic-face))) `(markup-error-face ((,c :inherit error))) - `(markup-gen-face ((,c :foreground ,prose-verbatim))) + `(markup-gen-face ((,c :inherit modus-themes-prose-verbatim))) `(markup-internal-reference-face ((,c :inherit (shadow modus-themes-slant)))) `(markup-italic-face ((,c :inherit italic))) `(markup-list-face ((,c :background ,bg-inactive))) @@ -3073,7 +2957,9 @@ FG and BG are the main colors." `(markup-title-3-face ((,c :inherit modus-themes-heading-4))) `(markup-title-4-face ((,c :inherit modus-themes-heading-5))) `(markup-title-5-face ((,c :inherit modus-themes-heading-6))) - `(markup-verbatim-face ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-verbatim))) + `(markup-verbatim-face ((,c :inherit modus-themes-prose-verbatim))) +;;;;; mct + `(mct-highlight-candidate ((,c :inherit modus-themes-completion-selected))) ;;;;; messages `(message-cited-text-1 ((,c :foreground ,mail-cite-0))) `(message-cited-text-2 ((,c :foreground ,mail-cite-1))) @@ -3087,7 +2973,7 @@ FG and BG are the main colors." `(message-header-xheader ((,c :inherit message-header-other))) `(message-header-other ((,c :foreground ,mail-other))) `(message-mml ((,c :foreground ,mail-part))) - `(message-separator ((,c :background ,bg-active))) + `(message-separator ((,c :background ,bg-inactive :foreground ,fg-main))) ;;;;; minimap `(minimap-active-region-background ((,c :background ,bg-active))) `(minimap-current-line-face ((,c :background ,bg-cyan-intense :foreground ,fg-main))) @@ -3129,7 +3015,7 @@ FG and BG are the main colors." `(mu4e-contact-face ((,c :inherit message-header-to))) `(mu4e-context-face ((,c :inherit bold))) `(mu4e-draft-face ((,c :foreground ,warning))) - `(mu4e-flagged-face ((,c :foreground ,err))) + `(mu4e-flagged-face ((,c :foreground ,keyword))) `(mu4e-footer-face ((,c :inherit italic :foreground ,fg-alt))) `(mu4e-forwarded-face ((,c :inherit italic :foreground ,info))) `(mu4e-header-face ((,c :inherit shadow))) @@ -3148,6 +3034,7 @@ FG and BG are the main colors." `(mu4e-replied-face ((,c :foreground ,info))) `(mu4e-special-header-value-face ((,c :inherit message-header-subject))) `(mu4e-system-face ((,c :inherit italic))) + `(mu4e-thread-fold-face ((,c :foreground ,border))) `(mu4e-title-face (( ))) `(mu4e-trashed-face ((,c :foreground ,err))) `(mu4e-unread-face ((,c :inherit bold))) @@ -3233,7 +3120,7 @@ FG and BG are the main colors." `(notmuch-message-summary-face ((,c :inherit bold :background ,bg-inactive))) `(notmuch-search-count ((,c :foreground ,fg-dim))) `(notmuch-search-date ((,c :foreground ,date-common))) - `(notmuch-search-flagged-face ((,c :foreground ,err))) + `(notmuch-search-flagged-face ((,c :foreground ,keyword))) `(notmuch-search-matching-authors ((,c :foreground ,mail-recipient))) `(notmuch-search-non-matching-authors ((,c :inherit shadow))) `(notmuch-search-subject ((,c :foreground ,fg-main))) @@ -3241,7 +3128,7 @@ FG and BG are the main colors." `(notmuch-tag-added ((,c :underline ,info))) `(notmuch-tag-deleted ((,c :strike-through ,err))) `(notmuch-tag-face ((,c :foreground ,accent-0))) - `(notmuch-tag-flagged ((,c :foreground ,err))) + `(notmuch-tag-flagged ((,c :foreground ,keyword))) `(notmuch-tag-unread ((,c :foreground ,accent-1))) `(notmuch-tree-match-author-face ((,c :inherit notmuch-search-matching-authors))) `(notmuch-tree-match-date-face ((,c :inherit notmuch-search-date))) @@ -3280,7 +3167,7 @@ FG and BG are the main colors." `(nxml-ref ((,c :inherit (shadow modus-themes-bold)))) `(rng-error ((,c :inherit error))) ;;;;; olivetti - `(olivetti-fringe ((,c :background ,bg-main))) + `(olivetti-fringe ((,c :background ,fringe))) ;;;;; orderless `(orderless-match-face-0 ((,c :inherit modus-themes-completion-match-0))) `(orderless-match-face-1 ((,c :inherit modus-themes-completion-match-1))) @@ -3290,7 +3177,7 @@ FG and BG are the main colors." `(org-agenda-calendar-daterange ((,c :foreground ,date-range))) `(org-agenda-calendar-event ((,c :foreground ,date-event))) `(org-agenda-calendar-sexp ((,c :inherit (modus-themes-slant org-agenda-calendar-event)))) - `(org-agenda-clocking ((,c :inherit modus-themes-mark-alt))) + `(org-agenda-clocking ((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument))) `(org-agenda-column-dateline ((,c :background ,bg-inactive))) `(org-agenda-current-time ((,c :foreground ,date-now))) `(org-agenda-date ((,c ,@(modus-themes--heading 'agenda-date date-weekday)))) @@ -3309,10 +3196,10 @@ FG and BG are the main colors." `(org-agenda-structure-filter ((,c :inherit org-agenda-structure :foreground ,warning))) `(org-agenda-structure-secondary ((,c :inherit font-lock-doc-face))) `(org-archived ((,c :background ,bg-inactive :foreground ,fg-main))) - `(org-block ((,c ,@(modus-themes--org-block fg-main bg-dim)))) - `(org-block-begin-line ((,c ,@(modus-themes--org-block prose-block bg-inactive)))) + `(org-block ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-block-contents :extend t))) + `(org-block-begin-line ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-block-delimiter :foreground ,fg-prose-block-delimiter :extend t))) `(org-block-end-line ((,c :inherit org-block-begin-line))) - `(org-checkbox ((,c :foreground ,warning))) + `(org-checkbox ((,c :inherit modus-themes-fixed-pitch :foreground ,warning))) `(org-checkbox-statistics-done ((,c :inherit org-done))) `(org-checkbox-statistics-todo ((,c :inherit org-todo))) `(org-clock-overlay ((,c :inherit secondary-selection))) @@ -3321,6 +3208,11 @@ FG and BG are the main colors." `(org-column-title ((,c :inherit (bold default) :underline t :background ,bg-dim))) `(org-date ((,c :inherit modus-themes-fixed-pitch :foreground ,date-common))) `(org-date-selected ((,c :foreground ,date-common :inverse-video t))) + ;; NOTE 2024-03-17: Normally we do not want to add this padding + ;; with the :box, but I do it here because the keys are otherwise + ;; very hard to read. The square brackets around them are not + ;; colored, which is what is causing the problem. + `(org-dispatcher-highlight ((,c :inherit modus-themes-bold :box (:line-width 2 :color ,bg-hover-secondary) :background ,bg-hover-secondary :foreground ,fg-main))) `(org-document-info ((,c :foreground ,prose-metadata-value))) `(org-document-info-keyword ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-metadata))) `(org-document-title ((,c :inherit modus-themes-heading-0))) @@ -3328,7 +3220,7 @@ FG and BG are the main colors." `(org-drawer ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-metadata))) `(org-ellipsis (( ))) ; inherits from the heading's color `(org-footnote ((,c :inherit link))) - `(org-formula ((,c :inherit modus-themes-fixed-pitch :foreground ,fnname))) + `(org-formula ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-table-formula))) `(org-headline-done ((,c :inherit org-done))) `(org-headline-todo ((,c :inherit org-todo))) `(org-hide ((,c :foreground ,bg-main))) @@ -3370,13 +3262,13 @@ FG and BG are the main colors." `(org-verse ((,c :inherit org-block))) `(org-warning ((,c :inherit warning))) ;;;;; org-habit - `(org-habit-alert-face ((,c :background ,bg-graph-yellow-0 :foreground "black"))) ; fg is special case + `(org-habit-alert-face ((,c :background ,bg-graph-yellow-0 :foreground "#000000"))) ; fg is special case `(org-habit-alert-future-face ((,c :background ,bg-graph-yellow-1))) - `(org-habit-clear-face ((,c :background ,bg-graph-blue-0 :foreground "black"))) ; fg is special case + `(org-habit-clear-face ((,c :background ,bg-graph-blue-0 :foreground "#000000"))) ; fg is special case `(org-habit-clear-future-face ((,c :background ,bg-graph-blue-1))) `(org-habit-overdue-face ((,c :background ,bg-graph-red-0))) `(org-habit-overdue-future-face ((,c :background ,bg-graph-red-1))) - `(org-habit-ready-face ((,c :background ,bg-graph-green-0 :foreground "black"))) ; fg is special case + `(org-habit-ready-face ((,c :background ,bg-graph-green-0 :foreground "#000000"))) ; fg is special case `(org-habit-ready-future-face ((,c :background ,bg-graph-green-1))) ;;;;; org-journal `(org-journal-calendar-entry-face ((,c :inherit modus-themes-slant :foreground ,date-common))) @@ -3551,10 +3443,10 @@ FG and BG are the main colors." `(recursion-indicator-general ((,c :foreground ,modeline-err))) `(recursion-indicator-minibuffer ((,c :foreground ,modeline-info))) ;;;;; regexp-builder (re-builder) - `(reb-match-0 ((,c :inherit modus-themes-intense-cyan))) - `(reb-match-1 ((,c :inherit modus-themes-subtle-magenta))) - `(reb-match-2 ((,c :inherit modus-themes-subtle-green))) - `(reb-match-3 ((,c :inherit modus-themes-intense-yellow))) + `(reb-match-0 ((,c :inherit modus-themes-search-rx-group-0))) + `(reb-match-1 ((,c :inherit modus-themes-search-rx-group-1))) + `(reb-match-2 ((,c :inherit modus-themes-search-rx-group-2))) + `(reb-match-3 ((,c :inherit modus-themes-search-rx-group-3))) `(reb-regexp-grouping-backslash ((,c :inherit font-lock-regexp-grouping-backslash))) `(reb-regexp-grouping-construct ((,c :inherit font-lock-regexp-grouping-construct))) ;;;;; rg (rg.el) @@ -3609,7 +3501,7 @@ FG and BG are the main colors." `(shortdoc-heading ((,c :inherit bold))) `(shortdoc-section (())) ; remove the default's variable-pitch style ;;;;; show-paren-mode - `(show-paren-match ((,c :background ,bg-paren-match :foreground ,fg-main :underline ,underline-paren-match))) + `(show-paren-match ((,c :background ,bg-paren-match :foreground ,fg-paren-match :underline ,underline-paren-match))) `(show-paren-match-expression ((,c :background ,bg-paren-expression))) `(show-paren-mismatch ((,c :inherit modus-themes-prominent-error))) ;;;;; shr @@ -3621,6 +3513,7 @@ FG and BG are the main colors." `(shr-h4 ((,c :inherit modus-themes-heading-4))) `(shr-h5 ((,c :inherit modus-themes-heading-5))) `(shr-h6 ((,c :inherit modus-themes-heading-6))) + `(shr-mark ((,c :inherit match))) `(shr-selected-link ((,c :inherit modus-themes-mark-sel))) ;;;;; side-notes `(side-notes ((,c :background ,bg-dim :foreground ,fg-dim))) @@ -3803,14 +3696,25 @@ FG and BG are the main colors." `(transient-amaranth ((,c :inherit bold :foreground ,yellow-warmer))) ;; Placate the compiler for what is a spurious warning. We also ;; have to do this with `eldoc-highlight-function-argument'. - (list 'transient-argument `((,c :inherit (bold modus-themes-mark-alt)))) + (list 'transient-argument `((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument))) `(transient-blue ((,c :inherit bold :foreground ,blue))) `(transient-disabled-suffix ((,c :inherit modus-themes-mark-del))) `(transient-enabled-suffix ((,c :inherit modus-themes-subtle-cyan))) `(transient-heading ((,c :inherit bold :foreground ,fg-main))) `(transient-inactive-argument ((,c :inherit shadow))) `(transient-inactive-value ((,c :inherit shadow))) + ;; NOTE 2023-12-09 10:30:09 +0200: The new user option + ;; `transient-semantic-coloring' is enabled by default. This is + ;; not good for us, because we are making it harder for users who + ;; need accessible colors to use the transient interfaces. I + ;; could set that user option to nil, but I think it is less + ;; intrusive to enforce uniformity among the relevant faces. + ;; Those who want semantic coloring can modify these faces. `(transient-key ((,c :inherit modus-themes-key-binding))) + `(transient-key-exit ((,c :inherit modus-themes-key-binding))) + `(transient-key-noop ((,c :inherit (shadow modus-themes-key-binding)))) + `(transient-key-return ((,c :inherit modus-themes-key-binding))) + `(transient-key-stay ((,c :inherit modus-themes-key-binding))) `(transient-mismatched-key ((,c :underline t))) `(transient-nonstandard-key ((,c :underline t))) `(transient-pink ((,c :inherit bold :foreground ,magenta))) @@ -3819,7 +3723,7 @@ FG and BG are the main colors." `(transient-teal ((,c :inherit bold :foreground ,cyan-cooler))) `(transient-unreachable ((,c :inherit shadow))) `(transient-unreachable-key ((,c :inherit shadow))) - `(transient-value ((,c :inherit (bold modus-themes-mark-sel)))) + `(transient-value ((,c :inherit bold :background ,bg-active-value :foreground ,fg-active-value))) ;;;;; trashed `(trashed-deleted ((,c :inherit modus-themes-mark-del))) `(trashed-directory ((,c :foreground ,accent-0))) @@ -3918,11 +3822,11 @@ FG and BG are the main colors." `(visible-mark-forward-face1 ((,c :background ,bg-magenta-intense))) `(visible-mark-forward-face2 ((,c :background ,bg-green-intense))) ;;;;; visual-regexp - `(vr/group-0 ((,c :inherit modus-themes-intense-blue))) - `(vr/group-1 ((,c :inherit modus-themes-intense-magenta))) - `(vr/group-2 ((,c :inherit modus-themes-intense-green))) - `(vr/match-0 ((,c :inherit modus-themes-intense-yellow))) - `(vr/match-1 ((,c :inherit modus-themes-intense-yellow))) + `(vr/group-0 ((,c :inherit modus-themes-search-rx-group-0))) + `(vr/group-1 ((,c :inherit modus-themes-search-rx-group-1))) + `(vr/group-2 ((,c :inherit modus-themes-search-rx-group-2))) + `(vr/match-0 ((,c :inherit modus-themes-search-current))) + `(vr/match-1 ((,c :inherit modus-themes-search-lazy))) `(vr/match-separator-face ((,c :inherit bold :background ,bg-active))) ;;;;; vterm ;; NOTE 2023-08-10: `vterm-color-black' and `vterm-color-white' @@ -4025,7 +3929,7 @@ FG and BG are the main colors." `(which-func ((,c :inherit bold :foreground ,modeline-info))) ; same as `breadcrumb-imenu-leaf-face' ;;;;; which-key `(which-key-command-description-face ((,c :foreground ,fg-main))) - `(which-key-group-description-face ((,c :foreground ,keyword))) + `(which-key-group-description-face ((,c :foreground ,type))) `(which-key-highlighted-command-face ((,c :foreground ,warning :underline t))) `(which-key-key-face ((,c :inherit modus-themes-key-binding))) `(which-key-local-map-description-face ((,c :foreground ,fg-main))) @@ -4034,14 +3938,14 @@ FG and BG are the main colors." `(which-key-special-key-face ((,c :inherit error))) ;;;;; whitespace-mode `(whitespace-big-indent ((,c :background ,bg-space-err))) - `(whitespace-empty ((,c :inherit modus-themes-intense-magenta))) + `(whitespace-empty ((,c :background ,bg-space))) `(whitespace-hspace ((,c :background ,bg-space :foreground ,fg-space))) `(whitespace-indentation ((,c :background ,bg-space :foreground ,fg-space))) `(whitespace-line ((,c :background ,bg-space :foreground ,warning))) `(whitespace-newline ((,c :background ,bg-space :foreground ,fg-space))) `(whitespace-space ((,c :background ,bg-space :foreground ,fg-space))) - `(whitespace-space-after-tab ((,c :inherit modus-themes-subtle-magenta))) - `(whitespace-space-before-tab ((,c :inherit modus-themes-subtle-cyan))) + `(whitespace-space-after-tab ((,c :inherit warning :background ,bg-space))) + `(whitespace-space-before-tab ((,c :inherit warning :background ,bg-space))) `(whitespace-tab ((,c :background ,bg-space :foreground ,fg-space))) `(whitespace-trailing ((,c :background ,bg-space-err))) ;;;;; window-divider-mode @@ -4072,14 +3976,27 @@ FG and BG are the main colors." ;;;;; yaml-mode `(yaml-tab-face ((,c :background ,bg-space-err))) ;;;;; yasnippet - `(yas-field-highlight-face ((,c :inherit highlight)))) + `(yas-field-highlight-face ((,c :inherit highlight))) +;;;;; ztree + `(ztreep-arrow-face ((,c :inherit shadow))) + `(ztreep-diff-header-face ((,c :inherit modus-themes-heading-0))) + `(ztreep-diff-header-small-face ((,c :inherit font-lock-doc-face))) + `(ztreep-diff-model-add-face ((,c :foreground ,info))) + `(ztreep-diff-model-diff-face ((,c :foreground ,err))) + `(ztreep-diff-model-ignored-face ((,c :foreground ,fg-dim :strike-through t))) + `(ztreep-diff-model-normal-face (( ))) + `(ztreep-expand-sign-face ((,c :inherit shadow))) + `(ztreep-header-face ((,c :inherit modus-themes-heading-0))) + `(ztreep-leaf-face (( ))) + `(ztreep-node-count-children-face ((,c :inherit (shadow italic)))) + `(ztreep-node-face ((,c :foreground ,accent-0)))) "Face specs for use with `modus-themes-theme'.") (defconst modus-themes-custom-variables '( ;;;; ansi-colors `(ansi-color-faces-vector [default bold shadow italic underline success warning error]) - `(ansi-color-names-vector ["gray35" ,red ,green ,yellow ,blue ,magenta ,cyan "gray65"]) + `(ansi-color-names-vector ["#595959" ,red ,green ,yellow ,blue ,magenta ,cyan "#a6a6a6"]) ;;;; chart `(chart-face-color-list '( ,bg-graph-red-0 ,bg-graph-green-0 ,bg-graph-yellow-0 ,bg-graph-blue-0 ,bg-graph-magenta-0 ,bg-graph-cyan-0 @@ -4152,29 +4069,35 @@ FG and BG are the main colors." modus-themes-fg-yellow-intense modus-themes-fg-magenta-intense modus-themes-fg-cyan-intense)) -;;;; org-src-block-faces - (if (or (eq modus-themes-org-blocks 'tinted-background) - (eq modus-themes-org-blocks 'rainbow)) - `(org-src-block-faces - `(("emacs-lisp" modus-themes-nuanced-magenta) - ("elisp" modus-themes-nuanced-magenta) - ("clojure" modus-themes-nuanced-magenta) - ("clojurescript" modus-themes-nuanced-magenta) - ("c" modus-themes-nuanced-blue) - ("c++" modus-themes-nuanced-blue) - ("sh" modus-themes-nuanced-green) - ("shell" modus-themes-nuanced-green) - ("html" modus-themes-nuanced-yellow) - ("xml" modus-themes-nuanced-yellow) - ("css" modus-themes-nuanced-red) - ("scss" modus-themes-nuanced-red) - ("python" modus-themes-nuanced-green) - ("ipython" modus-themes-nuanced-magenta) - ("r" modus-themes-nuanced-cyan) - ("yaml" modus-themes-nuanced-cyan) - ("conf" modus-themes-nuanced-cyan) - ("docker" modus-themes-nuanced-cyan))) - `(org-src-block-faces '()))) +;;;; rustic-ansi-faces + `(rustic-ansi-faces + [,fg-term-black + ,fg-term-red + ,fg-term-green + ,fg-term-yellow + ,fg-term-blue + ,fg-term-magenta + ,fg-term-cyan + ,fg-term-white]) +;;;; xterm-color + `(xterm-color-names + [,fg-term-black + ,fg-term-red + ,fg-term-green + ,fg-term-yellow + ,fg-term-blue + ,fg-term-magenta + ,fg-term-cyan + ,fg-term-white]) + `(xterm-color-names-bright + [,fg-term-black-bright + ,fg-term-red-bright + ,fg-term-green-bright + ,fg-term-yellow-bright + ,fg-term-blue-bright + ,fg-term-magenta-bright + ,fg-term-cyan-bright + ,fg-term-white-bright])) "Custom variables for `modus-themes-theme'.") ;;; Theme macros diff --git a/etc/themes/modus-vivendi-deuteranopia-theme.el b/etc/themes/modus-vivendi-deuteranopia-theme.el index 62715e20e51..d721dba09a9 100644 --- a/etc/themes/modus-vivendi-deuteranopia-theme.el +++ b/etc/themes/modus-vivendi-deuteranopia-theme.el @@ -1,11 +1,11 @@ ;;; modus-vivendi-deuteranopia-theme.el --- Deuteranopia-optimized theme with a black background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes +;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -127,12 +127,12 @@ standard)." (bg-magenta-subtle "#552f5f") (bg-cyan-subtle "#004065") - (bg-red-nuanced "#2c0614") - (bg-green-nuanced "#001904") - (bg-yellow-nuanced "#221000") - (bg-blue-nuanced "#0f0e39") - (bg-magenta-nuanced "#230631") - (bg-cyan-nuanced "#041529") + (bg-red-nuanced "#3a0c14") + (bg-green-nuanced "#092f1f") + (bg-yellow-nuanced "#381d0f") + (bg-blue-nuanced "#12154a") + (bg-magenta-nuanced "#2f0c3f") + (bg-cyan-nuanced "#042837") ;;; Uncommon accent backgrounds @@ -211,6 +211,7 @@ standard)." ;;; Paren match (bg-paren-match "#2f7f9f") + (fg-paren-match fg-main) (bg-paren-expression "#453040") (underline-paren-match unspecified) @@ -240,6 +241,11 @@ standard)." (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-yellow-nuanced) + (fg-active-argument yellow-warmer) + (bg-active-value bg-blue-nuanced) + (fg-active-value blue-warmer) + ;;;; Code mappings (builtin magenta-warmer) @@ -288,7 +294,7 @@ standard)." (date-event fg-alt) (date-holiday yellow-warmer) (date-holiday-other blue) - (date-now blue-faint) + (date-now fg-main) (date-range fg-alt) (date-scheduled yellow-cooler) (date-weekday cyan) @@ -342,16 +348,29 @@ standard)." ;;;; Prose mappings - (prose-block fg-dim) - (prose-code cyan-cooler) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan-cooler) + + (bg-prose-macro unspecified) + (fg-prose-macro magenta-cooler) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done blue) - (prose-macro magenta-cooler) + (prose-todo yellow-warmer) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) + (prose-table-formula yellow-warmer) + (prose-tag magenta-faint) - (prose-todo yellow-warmer) - (prose-verbatim magenta-warmer) ;;;; Rainbow mappings @@ -365,6 +384,17 @@ standard)." (rainbow-7 blue-faint) (rainbow-8 magenta-faint) +;;;; Search mappings + + (bg-search-current bg-yellow-intense) + (bg-search-lazy bg-blue-intense) + (bg-search-replace bg-magenta-intense) + + (bg-search-rx-group-0 bg-cyan-intense) + (bg-search-rx-group-1 bg-magenta-intense) + (bg-search-rx-group-2 bg-blue-subtle) + (bg-search-rx-group-3 bg-yellow-subtle) + ;;;; Space mappings (bg-space unspecified) @@ -373,10 +403,10 @@ standard)." ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -408,10 +438,10 @@ standard)." (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el index 238484206bb..8b822974c15 100644 --- a/etc/themes/modus-vivendi-theme.el +++ b/etc/themes/modus-vivendi-theme.el @@ -1,11 +1,11 @@ ;;; modus-vivendi-theme.el --- Elegant, highly legible theme with a black background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes +;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -125,12 +125,12 @@ which corresponds to a minimum contrast in relative luminance of (bg-magenta-subtle "#552f5f") (bg-cyan-subtle "#004065") - (bg-red-nuanced "#2c0614") - (bg-green-nuanced "#001904") - (bg-yellow-nuanced "#221000") - (bg-blue-nuanced "#0f0e39") - (bg-magenta-nuanced "#230631") - (bg-cyan-nuanced "#041529") + (bg-red-nuanced "#3a0c14") + (bg-green-nuanced "#092f1f") + (bg-yellow-nuanced "#381d0f") + (bg-blue-nuanced "#12154a") + (bg-magenta-nuanced "#2f0c3f") + (bg-cyan-nuanced "#042837") ;;; Uncommon accent backgrounds @@ -209,6 +209,7 @@ which corresponds to a minimum contrast in relative luminance of ;;; Paren match (bg-paren-match "#2f7f9f") + (fg-paren-match fg-main) (bg-paren-expression "#453040") (underline-paren-match unspecified) @@ -238,6 +239,11 @@ which corresponds to a minimum contrast in relative luminance of (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-yellow-nuanced) + (fg-active-argument yellow-cooler) + (bg-active-value bg-cyan-nuanced) + (fg-active-value cyan-cooler) + ;;;; Code mappings (builtin magenta-warmer) @@ -340,16 +346,29 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Prose mappings - (prose-block fg-dim) - (prose-code cyan-cooler) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan-cooler) + + (bg-prose-macro unspecified) + (fg-prose-macro magenta-cooler) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done green) - (prose-macro magenta-cooler) + (prose-todo red) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) + (prose-table-formula magenta-warmer) + (prose-tag magenta-faint) - (prose-todo red) - (prose-verbatim magenta-warmer) ;;;; Rainbow mappings @@ -363,6 +382,17 @@ which corresponds to a minimum contrast in relative luminance of (rainbow-7 blue-warmer) (rainbow-8 magenta-warmer) +;;;; Search mappings + + (bg-search-current bg-yellow-intense) + (bg-search-lazy bg-cyan-intense) + (bg-search-replace bg-red-intense) + + (bg-search-rx-group-0 bg-blue-intense) + (bg-search-rx-group-1 bg-green-intense) + (bg-search-rx-group-2 bg-red-subtle) + (bg-search-rx-group-3 bg-magenta-subtle) + ;;;; Space mappings (bg-space unspecified) @@ -371,10 +401,10 @@ which corresponds to a minimum contrast in relative luminance of ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -406,10 +436,10 @@ which corresponds to a minimum contrast in relative luminance of (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings @@ -451,7 +481,6 @@ Semantic color mappings have the form (MAPPING-NAME COLOR-NAME) with both as symbols. The latter is a named color that already exists in the palette and is associated with a HEX-VALUE.") - (defcustom modus-vivendi-palette-overrides nil "Overrides for `modus-vivendi-palette'. diff --git a/etc/themes/modus-vivendi-tinted-theme.el b/etc/themes/modus-vivendi-tinted-theme.el index 025257ef01c..5aa44304ee9 100644 --- a/etc/themes/modus-vivendi-tinted-theme.el +++ b/etc/themes/modus-vivendi-tinted-theme.el @@ -1,11 +1,11 @@ ;;; modus-vivendi-tinted-theme.el --- Elegant, highly legible theme with a night sky background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes +;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -125,12 +125,18 @@ which corresponds to a minimum contrast in relative luminance of (bg-magenta-subtle "#552f5f") (bg-cyan-subtle "#004065") - (bg-red-nuanced "#350f14") - (bg-green-nuanced "#002718") - (bg-yellow-nuanced "#2c1f00") - (bg-blue-nuanced "#131c4d") - (bg-magenta-nuanced "#2f133f") - (bg-cyan-nuanced "#04253f") + (bg-red-nuanced "#3a0c14") + (bg-green-nuanced "#092f1f") + (bg-yellow-nuanced "#381d0f") + (bg-blue-nuanced "#12154a") + (bg-magenta-nuanced "#2f0c3f") + (bg-cyan-nuanced "#042837") + +;;; Uncommon accent backgrounds + + (bg-ochre "#442c2f") + (bg-lavender "#38325c") + (bg-sage "#0f3d30") ;;; Graphs @@ -200,15 +206,10 @@ which corresponds to a minimum contrast in relative luminance of (bg-diff-context "#1a1f30") -;;; Uncommon accent backgrounds - - (bg-ochre "#442c2f") - (bg-lavender "#38325c") - (bg-sage "#0f3d30") - ;;; Paren match - (bg-paren-match "#2f7f9f") + (bg-paren-match "#5f789f") + (fg-paren-match fg-main) (bg-paren-expression "#453040") (underline-paren-match unspecified) @@ -217,9 +218,9 @@ which corresponds to a minimum contrast in relative luminance of ;;;; General mappings (fringe bg-dim) - (cursor magenta-warmer) + (cursor magenta-intense) - (keybind blue-cooler) + (keybind magenta-cooler) (name magenta) (identifier yellow-faint) @@ -238,6 +239,11 @@ which corresponds to a minimum contrast in relative luminance of (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-yellow-nuanced) + (fg-active-argument yellow-cooler) + (bg-active-value bg-cyan-nuanced) + (fg-active-value cyan-cooler) + ;;;; Code mappings (builtin magenta-warmer) @@ -337,20 +343,32 @@ which corresponds to a minimum contrast in relative luminance of (fg-prompt cyan-cooler) (bg-prompt unspecified) - (bg-space-err bg-red-intense) ;;;; Prose mappings - (prose-block fg-dim) - (prose-code cyan-cooler) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan-cooler) + + (bg-prose-macro unspecified) + (fg-prose-macro magenta-cooler) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done green) - (prose-macro magenta-cooler) + (prose-todo red) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) + (prose-table-formula magenta-warmer) + (prose-tag magenta-faint) - (prose-todo red) - (prose-verbatim magenta-warmer) ;;;; Rainbow mappings @@ -364,17 +382,29 @@ which corresponds to a minimum contrast in relative luminance of (rainbow-7 blue-warmer) (rainbow-8 magenta-warmer) +;;;; Search mappings + + (bg-search-current bg-yellow-intense) + (bg-search-lazy bg-cyan-intense) + (bg-search-replace bg-red-intense) + + (bg-search-rx-group-0 bg-blue-intense) + (bg-search-rx-group-1 bg-green-intense) + (bg-search-rx-group-2 bg-red-subtle) + (bg-search-rx-group-3 bg-magenta-subtle) + ;;;; Space mappings (bg-space unspecified) (fg-space border) + (bg-space-err bg-red-intense) ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -406,10 +436,10 @@ which corresponds to a minimum contrast in relative luminance of (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings diff --git a/etc/themes/modus-vivendi-tritanopia-theme.el b/etc/themes/modus-vivendi-tritanopia-theme.el index bfd6d63b844..2327a1e9c97 100644 --- a/etc/themes/modus-vivendi-tritanopia-theme.el +++ b/etc/themes/modus-vivendi-tritanopia-theme.el @@ -1,11 +1,10 @@ ;;; modus-vivendi-tritanopia-theme.el --- Tritanopia-optimized theme with a black background -*- lexical-binding:t -*- -;; Copyright (C) 2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2019-2024 Free Software Foundation, Inc. ;; Author: Protesilaos Stavrou -;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht> -;; URL: https://git.sr.ht/~protesilaos/modus-themes -;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes +;; Maintainer: Protesilaos Stavrou +;; URL: https://github.com/protesilaos/modus-themes ;; Keywords: faces, theme, accessibility ;; This file is part of GNU Emacs. @@ -128,12 +127,12 @@ standard)." (bg-magenta-subtle "#552f5f") (bg-cyan-subtle "#004065") - (bg-red-nuanced "#2c0614") - (bg-green-nuanced "#001904") - (bg-yellow-nuanced "#221000") - (bg-blue-nuanced "#0f0e39") - (bg-magenta-nuanced "#230631") - (bg-cyan-nuanced "#041529") + (bg-red-nuanced "#3a0c14") + (bg-green-nuanced "#092f1f") + (bg-yellow-nuanced "#381d0f") + (bg-blue-nuanced "#12154a") + (bg-magenta-nuanced "#2f0c3f") + (bg-cyan-nuanced "#042837") ;;; Uncommon accent backgrounds @@ -212,6 +211,7 @@ standard)." ;;; Paren match (bg-paren-match "#2f7f9f") + (fg-paren-match fg-main) (bg-paren-expression "#453040") (underline-paren-match unspecified) @@ -241,6 +241,11 @@ standard)." (bg-prominent-note bg-cyan-intense) (fg-prominent-note fg-main) + (bg-active-argument bg-red-nuanced) + (fg-active-argument red-warmer) + (bg-active-value bg-cyan-nuanced) + (fg-active-value cyan) + ;;;; Code mappings (builtin magenta) @@ -343,16 +348,29 @@ standard)." ;;;; Prose mappings - (prose-block fg-dim) - (prose-code cyan) + (bg-prose-block-delimiter bg-dim) + (fg-prose-block-delimiter fg-dim) + (bg-prose-block-contents bg-dim) + + (bg-prose-code unspecified) + (fg-prose-code cyan) + + (bg-prose-macro unspecified) + (fg-prose-macro red-warmer) + + (bg-prose-verbatim unspecified) + (fg-prose-verbatim magenta-warmer) + (prose-done cyan) - (prose-macro red-warmer) + (prose-todo red) + (prose-metadata fg-dim) (prose-metadata-value fg-alt) + (prose-table fg-alt) - (prose-tag fg-alt) - (prose-todo red) - (prose-verbatim magenta-warmer) + (prose-table-formula red-cooler) + + (prose-tag magenta-faint) ;;;; Rainbow mappings @@ -366,6 +384,17 @@ standard)." (rainbow-7 magenta-faint) (rainbow-8 red-faint) +;;;; Search mappings + + (bg-search-current bg-red-intense) + (bg-search-lazy bg-cyan-intense) + (bg-search-replace bg-magenta-intense) + + (bg-search-rx-group-0 bg-blue-intense) + (bg-search-rx-group-1 bg-magenta-intense) + (bg-search-rx-group-2 bg-cyan-subtle) + (bg-search-rx-group-3 bg-red-subtle) + ;;;; Space mappings (bg-space unspecified) @@ -374,10 +403,10 @@ standard)." ;;;; Terminal mappings - (bg-term-black "black") - (fg-term-black "black") - (bg-term-black-bright "gray35") - (fg-term-black-bright "gray35") + (bg-term-black "#000000") + (fg-term-black "#000000") + (bg-term-black-bright "#595959") + (fg-term-black-bright "#595959") (bg-term-red red) (fg-term-red red) @@ -409,10 +438,10 @@ standard)." (bg-term-cyan-bright cyan-cooler) (fg-term-cyan-bright cyan-cooler) - (bg-term-white "gray65") - (fg-term-white "gray65") - (bg-term-white-bright "white") - (fg-term-white-bright "white") + (bg-term-white "#a6a6a6") + (fg-term-white "#a6a6a6") + (bg-term-white-bright "#ffffff") + (fg-term-white-bright "#ffffff") ;;;; Heading mappings diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 0d54e234659..18b4a8691e9 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -817,31 +817,27 @@ or an empty string if none." cmds)) (defun vc-git-dir-extra-headers (dir) - (let ((str (vc-git--out-str "symbolic-ref" "HEAD")) + (let ((str (with-output-to-string + (with-current-buffer standard-output + (vc-git--out-ok "symbolic-ref" "HEAD")))) (stash-list (vc-git-stash-list)) (default-directory dir) (in-progress (vc-git--cmds-in-progress)) - branch remote-url stash-button stash-string tracking-branch) + branch remote remote-url stash-button stash-string) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) (progn (setq branch (match-string 2 str)) - (let ((remote (vc-git--out-str - "config" (concat "branch." branch ".remote"))) - (merge (vc-git--out-str - "config" (concat "branch." branch ".merge")))) - (when (string-match "\\([^\n]+\\)" remote) - (setq remote (match-string 1 remote))) - (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge) - (setq tracking-branch (match-string 2 merge))) - (pcase remote - ("." - (setq remote-url "none (tracking local branch)")) - ((pred (not string-empty-p)) - (setq - remote-url (vc-git-repository-url dir remote) - tracking-branch (concat remote "/" tracking-branch)))))) - (setq branch "none (detached HEAD)")) + (setq remote + (with-output-to-string + (with-current-buffer standard-output + (vc-git--out-ok "config" + (concat "branch." branch ".remote"))))) + (when (string-match "\\([^\n]+\\)" remote) + (setq remote (match-string 1 remote))) + (when (> (length remote) 0) + (setq remote-url (vc-git-repository-url dir remote)))) + (setq branch "not (detached HEAD)")) (when stash-list (let* ((len (length stash-list)) (limit @@ -894,11 +890,6 @@ or an empty string if none." (propertize "Branch : " 'face 'vc-dir-header) (propertize branch 'face 'vc-dir-header-value) - (when tracking-branch - (concat - "\n" - (propertize "Tracking : " 'face 'vc-dir-header) - (propertize tracking-branch 'face 'vc-dir-header-value))) (when remote-url (concat "\n" @@ -2235,17 +2226,8 @@ The difference to vc-do-command is that this function always invokes (apply #'process-file vc-git-program nil buffer nil "--no-pager" command args))) (defun vc-git--out-ok (command &rest args) - "Run `git COMMAND ARGS...' and insert standard output in current buffer. -Return whether the process exited with status zero." (zerop (apply #'vc-git--call '(t nil) command args))) -(defun vc-git--out-str (command &rest args) - "Run `git COMMAND ARGS...' and return standard output. -The exit status is ignored." - (with-output-to-string - (with-current-buffer standard-output - (apply #'vc-git--out-ok command args)))) - (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string. FILE can be nil." diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index fd3e8ccd602..c52cd9c5875 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -24,8 +24,6 @@ ;;; Code: -(require 'ert-x) -(require 'vc) (require 'vc-git) (ert-deftest vc-git-test-program-version-general () @@ -83,42 +81,4 @@ (should-not (vc-git-annotate-time)) (should-not (vc-git-annotate-time)))) -(defmacro vc-git-test--with-repo (name &rest body) - "Initialize a repository in a temporary directory and evaluate BODY. - -The current directory will be set to the top of that repository; NAME -will be bound to that directory's file name. Once BODY exits, the -directory will be deleted." - (declare (indent 1)) - `(ert-with-temp-directory ,name - (let ((default-directory ,name)) - (vc-create-repo 'Git) - ,@body))) - -(defun vc-git-test--run (&rest args) - "Run git ARGS…, check for non-zero status, and return output." - (with-temp-buffer - (apply 'vc-git-command t 0 nil args) - (buffer-string))) - -(ert-deftest vc-git-test-dir-track-local-branch () - "Test that `vc-dir' works when tracking local branches. Bug#68183." - (skip-unless (executable-find vc-git-program)) - (vc-git-test--with-repo repo - ;; Create an initial commit to get a branch started. - (write-region "hello" nil "README") - (vc-git-test--run "add" "README") - (vc-git-test--run "commit" "-mFirst") - ;; Get current branch name lazily, to remain agnostic of - ;; init.defaultbranch. - (let ((upstream-branch - (string-trim (vc-git-test--run "branch" "--show-current")))) - (vc-git-test--run "checkout" "--track" "-b" "hack" upstream-branch) - (vc-dir default-directory) - (pcase-dolist (`(,header ,value) - `(("Branch" "hack") - ("Tracking" ,upstream-branch))) - (goto-char (point-min)) - (re-search-forward (format "^%s *: %s$" header value)))))) - ;;; vc-git-tests.el ends here From 562d9c9db56172c754a2556a996245145ae223f5 Mon Sep 17 00:00:00 2001 From: Protesilaos Stavrou Date: Sun, 17 Mar 2024 18:49:21 +0200 Subject: [PATCH 078/155] Update source repository of the Modus themes * admin/MAINTAINERS: Update URL and remove outdated references. --- admin/MAINTAINERS | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index ec719744339..4fa65a8df24 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -381,9 +381,7 @@ Tramp Modus themes Maintainer: Protesilaos Stavrou - Repository: https://git.sr.ht/~protesilaos - Mailing list: https://lists.sr.ht/~protesilaos/modus-themes - Bug Reports: M-x modus-themes-report-bug + Repository: https://github.com/protesilaos/modus-themes doc/misc/modus-themes.org etc/themes/modus*.el From c29b6df2273347946d5b8c88b5dee39d8d6fd202 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Sun, 17 Mar 2024 19:57:05 +0200 Subject: [PATCH 079/155] * lisp/tab-bar.el (tab-bar-select-restore-windows): New defcustom. (tab-bar-select-restore-windows): New function. (tab-bar-select-tab): Let-bind window-restore-killed-buffer-windows to tab-bar-select-restore-windows (bug#68235). --- etc/NEWS | 7 +++++++ lisp/tab-bar.el | 54 ++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 60 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 50f0ee4a1aa..b02712dd21c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -291,6 +291,13 @@ corresponding configuration or state was recorded. ** Tab Bars and Tab Lines +--- +*** New user option 'tab-bar-select-restore-windows'. +It defines what to do with windows whose buffer was killed +since the tab was last selected. By default it displays +a placeholder buffer that provides information about the name +of the killed buffer that was displayed in that window. + --- *** New user option 'tab-bar-tab-name-format-functions'. It can be used to add, remove and reorder functions that change diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 61efa332e0b..fa22500a04e 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1393,6 +1393,55 @@ and the newly selected tab." :group 'tab-bar :version "30.1") +(defcustom tab-bar-select-restore-windows #'tab-bar-select-restore-windows + "Function called when selecting a tab to handle windows whose buffer was killed. +When a tab-bar tab displays a window whose buffer was killed since +this tab was last selected, this function determines what to do with +that window. By default, either a random buffer is displayed instead of +the killed buffer, or the window gets deleted. However, with the help +of `window-restore-killed-buffer-windows' it's possible to handle such +situations better by displaying an information about the killed buffer." + :type '(choice (const :tag "No special handling" nil) + (const :tag "Show placeholder buffers" + tab-bar-select-restore-windows) + (function :tag "Function")) + :group 'tab-bar + :version "30.1") + +(defun tab-bar-select-restore-windows (_frame windows _type) + "Display a placeholder buffer in the window whose buffer was killed. +A button in the window allows to restore the killed buffer, +if it was visiting a file." + (dolist (quad windows) + (when (window-live-p (nth 0 quad)) + (let* ((window (nth 0 quad)) + (old-buffer (nth 1 quad)) + (file (when (bufferp old-buffer) + (buffer-file-name old-buffer))) + (name (or file + (and (bufferp old-buffer) + (fboundp 'buffer-last-name) + (buffer-last-name old-buffer)) + old-buffer)) + (new-buffer (generate-new-buffer + (format "*Old buffer %s*" name)))) + (with-current-buffer new-buffer + (set-auto-mode) + (insert (format-message "This window displayed the %s `%s'.\n" + (if file "file" "buffer") + name)) + (when file + (insert-button + "[Restore]" 'action + (lambda (_button) + (set-window-buffer window (find-file-noselect file)) + (set-window-start window (nth 2 quad) t) + (set-window-point window (nth 3 quad)))) + (insert "\n")) + (goto-char (point-min)) + (setq buffer-read-only t) + (set-window-buffer window new-buffer)))))) + (defvar tab-bar-minibuffer-restore-tab nil "Tab number for `tab-bar-minibuffer-restore-tab'.") @@ -1438,7 +1487,10 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (let* ((from-tab (tab-bar--tab)) (to-tab (nth to-index tabs)) (wc (alist-get 'wc to-tab)) - (ws (alist-get 'ws to-tab))) + (ws (alist-get 'ws to-tab)) + (window-restore-killed-buffer-windows + (or tab-bar-select-restore-windows + window-restore-killed-buffer-windows))) ;; During the same session, use window-configuration to switch ;; tabs, because window-configurations are more reliable From 8d4a8b7dfd0905defac172cc58c2252dc1b39ad7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Mon, 12 Feb 2024 08:29:19 +0100 Subject: [PATCH 080/155] ; Re-apply accidentally reverted commit This re-applies: 2024-03-17 "Fix vc-dir when "remote" Git branch is local" (21828f288ef) reverted as part of the unrelated: 2024-03-17 "Update modus-themes to their 4.4.0 version" (67b0c1c09ea) The original commit message follows: Fix vc-dir when "remote" Git branch is local While in there, add that "tracking" branch to the vc-dir buffer. For bug#68183. * lisp/vc/vc-git.el (vc-git-dir-extra-headers): Reduce boilerplate with new function 'vc-git--out-ok'; stop calling vc-git-repository-url when REMOTE is "." to avoid throwing an error; display tracking branch; prefer "none ()" to "not ()" since that reads more grammatically correct. (vc-git--out-ok): Add documentation. (vc-git--out-str): New function to easily get the output from a Git command. * test/lisp/vc/vc-git-tests.el (vc-git-test--with-repo) (vc-git-test--run): New helpers, defined to steer clear of vc-git-- internal functions. (vc-git-test-dir-track-local-branch): Check that vc-dir does not crash. --- lisp/vc/vc-git.el | 46 +++++++++++++++++++++++++----------- test/lisp/vc/vc-git-tests.el | 40 +++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 14 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 18b4a8691e9..0d54e234659 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -817,27 +817,31 @@ or an empty string if none." cmds)) (defun vc-git-dir-extra-headers (dir) - (let ((str (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "symbolic-ref" "HEAD")))) + (let ((str (vc-git--out-str "symbolic-ref" "HEAD")) (stash-list (vc-git-stash-list)) (default-directory dir) (in-progress (vc-git--cmds-in-progress)) - branch remote remote-url stash-button stash-string) + branch remote-url stash-button stash-string tracking-branch) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) (progn (setq branch (match-string 2 str)) - (setq remote - (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "config" - (concat "branch." branch ".remote"))))) - (when (string-match "\\([^\n]+\\)" remote) - (setq remote (match-string 1 remote))) - (when (> (length remote) 0) - (setq remote-url (vc-git-repository-url dir remote)))) - (setq branch "not (detached HEAD)")) + (let ((remote (vc-git--out-str + "config" (concat "branch." branch ".remote"))) + (merge (vc-git--out-str + "config" (concat "branch." branch ".merge")))) + (when (string-match "\\([^\n]+\\)" remote) + (setq remote (match-string 1 remote))) + (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge) + (setq tracking-branch (match-string 2 merge))) + (pcase remote + ("." + (setq remote-url "none (tracking local branch)")) + ((pred (not string-empty-p)) + (setq + remote-url (vc-git-repository-url dir remote) + tracking-branch (concat remote "/" tracking-branch)))))) + (setq branch "none (detached HEAD)")) (when stash-list (let* ((len (length stash-list)) (limit @@ -890,6 +894,11 @@ or an empty string if none." (propertize "Branch : " 'face 'vc-dir-header) (propertize branch 'face 'vc-dir-header-value) + (when tracking-branch + (concat + "\n" + (propertize "Tracking : " 'face 'vc-dir-header) + (propertize tracking-branch 'face 'vc-dir-header-value))) (when remote-url (concat "\n" @@ -2226,8 +2235,17 @@ The difference to vc-do-command is that this function always invokes (apply #'process-file vc-git-program nil buffer nil "--no-pager" command args))) (defun vc-git--out-ok (command &rest args) + "Run `git COMMAND ARGS...' and insert standard output in current buffer. +Return whether the process exited with status zero." (zerop (apply #'vc-git--call '(t nil) command args))) +(defun vc-git--out-str (command &rest args) + "Run `git COMMAND ARGS...' and return standard output. +The exit status is ignored." + (with-output-to-string + (with-current-buffer standard-output + (apply #'vc-git--out-ok command args)))) + (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string. FILE can be nil." diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index c52cd9c5875..fd3e8ccd602 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -24,6 +24,8 @@ ;;; Code: +(require 'ert-x) +(require 'vc) (require 'vc-git) (ert-deftest vc-git-test-program-version-general () @@ -81,4 +83,42 @@ (should-not (vc-git-annotate-time)) (should-not (vc-git-annotate-time)))) +(defmacro vc-git-test--with-repo (name &rest body) + "Initialize a repository in a temporary directory and evaluate BODY. + +The current directory will be set to the top of that repository; NAME +will be bound to that directory's file name. Once BODY exits, the +directory will be deleted." + (declare (indent 1)) + `(ert-with-temp-directory ,name + (let ((default-directory ,name)) + (vc-create-repo 'Git) + ,@body))) + +(defun vc-git-test--run (&rest args) + "Run git ARGS…, check for non-zero status, and return output." + (with-temp-buffer + (apply 'vc-git-command t 0 nil args) + (buffer-string))) + +(ert-deftest vc-git-test-dir-track-local-branch () + "Test that `vc-dir' works when tracking local branches. Bug#68183." + (skip-unless (executable-find vc-git-program)) + (vc-git-test--with-repo repo + ;; Create an initial commit to get a branch started. + (write-region "hello" nil "README") + (vc-git-test--run "add" "README") + (vc-git-test--run "commit" "-mFirst") + ;; Get current branch name lazily, to remain agnostic of + ;; init.defaultbranch. + (let ((upstream-branch + (string-trim (vc-git-test--run "branch" "--show-current")))) + (vc-git-test--run "checkout" "--track" "-b" "hack" upstream-branch) + (vc-dir default-directory) + (pcase-dolist (`(,header ,value) + `(("Branch" "hack") + ("Tracking" ,upstream-branch))) + (goto-char (point-min)) + (re-search-forward (format "^%s *: %s$" header value)))))) + ;;; vc-git-tests.el ends here From 1a8b34a503e5af32851c1aac27a3f09e2345673b Mon Sep 17 00:00:00 2001 From: Po Lu Date: Mon, 18 Mar 2024 09:14:18 +0800 Subject: [PATCH 081/155] Makeshift solution for X server bug * src/xterm.c (x_sync_init_fences): Detect errors around XSyncCreateFence. (bug#69762) --- src/xterm.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/xterm.c b/src/xterm.c index c30015ec8f0..b30a2485148 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7292,6 +7292,11 @@ x_sync_init_fences (struct frame *f) && dpyinfo->xsync_minor < 1)) return; + /* Suppress errors around XSyncCreateFence requests, since its + implementations on certain X servers erroneously reject valid + drawables, such as the frame's inner window. (bug#69762) */ + + x_catch_errors (dpyinfo->display); output->sync_fences[0] = XSyncCreateFence (FRAME_X_DISPLAY (f), /* The drawable given below is only used to @@ -7303,6 +7308,9 @@ x_sync_init_fences (struct frame *f) = XSyncCreateFence (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), False); + if (x_had_errors_p (dpyinfo->display)) + output->sync_fences[1] = output->sync_fences[0] = None; + x_uncatch_errors_after_check (); XChangeProperty (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), dpyinfo->Xatom_net_wm_sync_fences, XA_CARDINAL, From 706403f2aa3a306369a0150022da0cba1802ca2b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 12 Mar 2024 09:26:24 -0400 Subject: [PATCH 082/155] (cl-type-of): New function to return more precise types (bug#69739) * src/data.c (Fcl_type_of): New function, extracted from `Ftype_of`. Make it return more precise types for symbols, integers, and subrs. (Ftype_of): Use it. (syms_of_data): Define the corresponding new symbols and defsubr the new function. * doc/lispref/objects.texi (Type Predicates): Document it. * src/comp.c (emit_limple_insn): Use `Fcl_type_of`. * lisp/emacs-lisp/cl-preloaded.el (subr): Demote it to `atom`. (subr-native-elisp, subr-primitive): Add `compiled-function` as parent instead. (special-form): New type. * lisp/obsolete/eieio-core.el (cl--generic-struct-tag): * lisp/emacs-lisp/cl-generic.el (cl--generic-typeof-generalizer): Use `cl-type-of`. cl--generic--unreachable-types): Update accordingly. test/src/data-tests.el (data-tests--cl-type-of): New test. --- doc/lispref/objects.texi | 21 +++++++++++++++++ etc/NEWS | 5 +++++ lisp/emacs-lisp/cl-generic.el | 6 ++--- lisp/emacs-lisp/cl-preloaded.el | 12 +++++----- lisp/emacs-lisp/eieio-core.el | 2 +- src/comp.c | 2 +- src/data.c | 40 ++++++++++++++++++++++++++++----- test/src/data-tests.el | 37 ++++++++++++++++++++++++++++++ 8 files changed, 108 insertions(+), 17 deletions(-) diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 279f449a994..1e448b64296 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -2207,6 +2207,27 @@ slot is returned; @ref{Records}. @end example @end defun +@defun cl-type-of object +This function returns a symbol naming @emph{the} type of +@var{object}. It usually behaves like @code{type-of}, except +that it guarantees to return the most precise type possible, which also +implies that the specific type it returns may change depending on the +Emacs version. For this reason, as a rule you should never compare its +return value against some fixed set of types. + +@example +(cl-type-of 1) + @result{} fixnum +@group +(cl-type-of 'nil) + @result{} null +(cl-type-of (record 'foo)) + @result{} foo +@end group +@end example +@end defun + + @node Equality Predicates @section Equality Predicates @cindex equality diff --git a/etc/NEWS b/etc/NEWS index b02712dd21c..b522fbd338b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1647,6 +1647,11 @@ values. * Lisp Changes in Emacs 30.1 +** New function 'cl-type-of'. +This function is like 'type-of' except that it sometimes returns +a more precise type. For example, for nil and t it returns 'null' +and 'boolean' respectively, instead of just 'symbol'. + ** Built-in types have now corresponding classes. At the Lisp level, this means that things like (cl-find-class 'integer) will now return a class object, and at the UI level it means that diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 613ecf82a92..62abe8d1589 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1334,8 +1334,7 @@ These match if the argument is `eql' to VAL." (defconst cl--generic--unreachable-types ;; FIXME: Try to make that list empty? - '(fixnum bignum boolean keyword - special-form subr-primitive subr-native-elisp) + '(keyword) "Built-in classes on which we cannot dispatch for technical reasons.") (defun cl--generic-type-specializers (tag &rest _) @@ -1345,8 +1344,7 @@ These match if the argument is `eql' to VAL." (cl--class-allparents class))))) (cl-generic-define-generalizer cl--generic-typeof-generalizer - ;; FIXME: We could also change `type-of' to return `null' for nil. - 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) + 10 (lambda (name &rest _) `(cl-type-of ,name)) #'cl--generic-type-specializers) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 515aa99549d..3e89afea452 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -339,8 +339,6 @@ ',parents)))))) ;; FIXME: Our type DAG has various quirks: -;; - `subr' says it's a `compiled-function' but that's not true -;; for those subrs that are special forms! ;; - Some `keyword's are also `symbol-with-pos' but that's not reflected ;; in the DAG. ;; - An OClosure can be an interpreted function or a `byte-code-function', @@ -428,15 +426,17 @@ For this build of Emacs it's %dbit." "Abstract type of functions that have been compiled.") (cl--define-built-in-type byte-code-function (compiled-function) "Type of functions that have been byte-compiled.") -(cl--define-built-in-type subr (compiled-function) +(cl--define-built-in-type subr (atom) "Abstract type of functions compiled to machine code.") (cl--define-built-in-type module-function (function) "Type of functions provided via the module API.") (cl--define-built-in-type interpreted-function (function) "Type of functions that have not been compiled.") -(cl--define-built-in-type subr-native-elisp (subr) - "Type of function that have been compiled by the native compiler.") -(cl--define-built-in-type subr-primitive (subr) +(cl--define-built-in-type special-form (subr) + "Type of the core syntactic elements of the Emacs Lisp language.") +(cl--define-built-in-type subr-native-elisp (subr compiled-function) + "Type of functions that have been compiled by the native compiler.") +(cl--define-built-in-type subr-primitive (subr compiled-function) "Type of functions hand written in C.") (unless (cl--class-parents (cl--find-class 'cl-structure-object)) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index a2f7c4172a3..cf8bd749f2a 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1046,7 +1046,7 @@ method invocation orders of the involved classes." (defun cl--generic-struct-tag (name &rest _) ;; Use exactly the same code as for `typeof'. - `(if ,name (type-of ,name) 'null)) + `(cl-type-of ,name)) (cl-generic-define-generalizer eieio--generic-generalizer ;; Use the exact same tagcode as for cl-struct, so that methods diff --git a/src/comp.c b/src/comp.c index 3f989c722d4..76cf1f3ab6e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2442,7 +2442,7 @@ emit_limple_insn (Lisp_Object insn) { Lisp_Object arg1 = arg[1]; - if (EQ (Ftype_of (arg1), Qcomp_mvar)) + if (EQ (Fcl_type_of (arg1), Qcomp_mvar)) res = emit_mvar_rval (arg1); else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); diff --git a/src/data.c b/src/data.c index 35f4c82c68f..5d6b6e0ba9d 100644 --- a/src/data.c +++ b/src/data.c @@ -193,16 +193,37 @@ DEFUN ("null", Fnull, Snull, 1, 1, 0, DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0, doc: /* Return a symbol representing the type of OBJECT. The symbol returned names the object's basic type; -for example, (type-of 1) returns `integer'. */) +for example, (type-of 1) returns `integer'. +Contrary to `cl-type-of', the returned type is not always the most +precise type possible, because instead this function tries to preserve +compatibility with the return value of previous Emacs versions. */) + (Lisp_Object object) +{ + return SYMBOLP (object) ? Qsymbol + : INTEGERP (object) ? Qinteger + : SUBRP (object) ? Qsubr + : Fcl_type_of (object); +} + +DEFUN ("cl-type-of", Fcl_type_of, Scl_type_of, 1, 1, 0, + doc: /* Return a symbol representing the type of OBJECT. +The returned symbol names the most specific possible type of the object. +for example, (cl-type-of nil) returns `null'. +The specific type returned may change depending on Emacs versions, +so we recommend you use `cl-typep', `cl-typecase', or other predicates +rather than compare the return value of this function against +a fixed set of types. */) (Lisp_Object object) { switch (XTYPE (object)) { case_Lisp_Int: - return Qinteger; + return Qfixnum; case Lisp_Symbol: - return Qsymbol; + return NILP (object) ? Qnull + : EQ (object, Qt) ? Qboolean + : Qsymbol; case Lisp_String: return Qstring; @@ -215,7 +236,7 @@ for example, (type-of 1) returns `integer'. */) switch (PSEUDOVECTOR_TYPE (XVECTOR (object))) { case PVEC_NORMAL_VECTOR: return Qvector; - case PVEC_BIGNUM: return Qinteger; + case PVEC_BIGNUM: return Qbignum; case PVEC_MARKER: return Qmarker; case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos; case PVEC_OVERLAY: return Qoverlay; @@ -224,7 +245,10 @@ for example, (type-of 1) returns `integer'. */) case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration; case PVEC_PROCESS: return Qprocess; case PVEC_WINDOW: return Qwindow; - case PVEC_SUBR: return Qsubr; + case PVEC_SUBR: + return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form + : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp + : Qsubr_primitive; case PVEC_COMPILED: return Qcompiled_function; case PVEC_BUFFER: return Qbuffer; case PVEC_CHAR_TABLE: return Qchar_table; @@ -4202,7 +4226,9 @@ syms_of_data (void) "Variable binding depth exceeds max-specpdl-size"); /* Types that type-of returns. */ + DEFSYM (Qboolean, "boolean"); DEFSYM (Qinteger, "integer"); + DEFSYM (Qbignum, "bignum"); DEFSYM (Qsymbol, "symbol"); DEFSYM (Qstring, "string"); DEFSYM (Qcons, "cons"); @@ -4218,6 +4244,9 @@ syms_of_data (void) DEFSYM (Qprocess, "process"); DEFSYM (Qwindow, "window"); DEFSYM (Qsubr, "subr"); + DEFSYM (Qspecial_form, "special-form"); + DEFSYM (Qsubr_primitive, "subr-primitive"); + DEFSYM (Qsubr_native_elisp, "subr-native-elisp"); DEFSYM (Qcompiled_function, "compiled-function"); DEFSYM (Qbuffer, "buffer"); DEFSYM (Qframe, "frame"); @@ -4255,6 +4284,7 @@ syms_of_data (void) defsubr (&Seq); defsubr (&Snull); defsubr (&Stype_of); + defsubr (&Scl_type_of); defsubr (&Slistp); defsubr (&Snlistp); defsubr (&Sconsp); diff --git a/test/src/data-tests.el b/test/src/data-tests.el index ad3b2071254..9d76c58224d 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -838,4 +838,41 @@ comparing the subr with a much slower Lisp implementation." (dolist (sym (list nil t 'xyzzy (make-symbol ""))) (should (eq sym (bare-symbol (position-symbol sym 0))))))) +(require 'cl-extra) ;For `cl--class-children'. + +(ert-deftest data-tests--cl-type-of () + ;; Make sure that `cl-type-of' returns the most precise type. + ;; Note: This doesn't work for list/vector structs since those types + ;; are too difficult/unreliable to detect (so `cl-type-of' only says + ;; it's a `cons' or a `vector'). + (dolist (val (list -2 10 (expt 2 128) nil t 'car + (symbol-function 'car) + (symbol-function 'progn) + (position-symbol 'car 7))) + (let* ((type (cl-type-of val)) + (class (cl-find-class type)) + (alltypes (cl--class-allparents class)) + ;; FIXME: Our type DAG is affected by `symbols-with-pos-enabled'. + ;; (e.g. `symbolp' returns nil on a sympos if that var is nil). + (symbols-with-pos-enabled t)) + (dolist (parent alltypes) + (should (cl-typep val parent)) + (dolist (subtype (cl--class-children (cl-find-class parent))) + (unless (memq subtype alltypes) + (unless (memq subtype + ;; FIXME: Some types don't have any associated + ;; predicate, + '( font-spec font-entity font-object + finalizer condvar terminal + native-comp-unit interpreted-function + tree-sitter-compiled-query + tree-sitter-node tree-sitter-parser + ;; `functionp' also matches things of type + ;; `symbol' and `cons'. + ;; FIXME: `subr-primitive-p' also matches + ;; special-forms. + function subr-primitive)) + (should-not (cl-typep val subtype))))))))) + + ;;; data-tests.el ends here From e624bc62752ceb2e60940c5fd9cb6e70611df71c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 17 Mar 2024 17:29:02 -0400 Subject: [PATCH 083/155] (primitive-function): New type The type hierarchy and `cl-type-of` code assumed that `subr-primitive` only applies to functions, but since it also accepts special-forms it makes it an unsuitable choice since it can't be a subtype of `compiled-function`. So, use a new type `primitive-function` instead. * lisp/subr.el (subr-primitive-p): Fix docstring (bug#69832). (primitive-function-p): New function. * lisp/emacs-lisp/cl-preloaded.el (primitive-function): Rename from `subr-primitive` since `subr-primitive-p` means something else. * src/data.c (Fcl_type_of): Return `primitive-function` instead of `subr-primitive` for C functions. (syms_of_data): Adjust accordingly. * test/src/data-tests.el (data-tests--cl-type-of): Remove workaround. --- etc/NEWS | 4 ++++ lisp/emacs-lisp/cl-preloaded.el | 2 +- lisp/subr.el | 11 ++++++++++- src/data.c | 4 ++-- test/src/data-tests.el | 4 +--- 5 files changed, 18 insertions(+), 7 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index b522fbd338b..69e61d91b0e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1652,6 +1652,10 @@ This function is like 'type-of' except that it sometimes returns a more precise type. For example, for nil and t it returns 'null' and 'boolean' respectively, instead of just 'symbol'. +** New function `primitive-function-p`. +This is like `subr-primitive-p` except that it returns t only if the +argument is a function rather than a special-form. + ** Built-in types have now corresponding classes. At the Lisp level, this means that things like (cl-find-class 'integer) will now return a class object, and at the UI level it means that diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 3e89afea452..d11c97a3e3a 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -436,7 +436,7 @@ For this build of Emacs it's %dbit." "Type of the core syntactic elements of the Emacs Lisp language.") (cl--define-built-in-type subr-native-elisp (subr compiled-function) "Type of functions that have been compiled by the native compiler.") -(cl--define-built-in-type subr-primitive (subr compiled-function) +(cl--define-built-in-type primitive-function (subr compiled-function) "Type of functions hand written in C.") (unless (cl--class-parents (cl--find-class 'cl-structure-object)) diff --git a/lisp/subr.el b/lisp/subr.el index 38a3f6edb34..3de4412637f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -312,11 +312,20 @@ value of last one, or nil if there are none." cond '(empty-body unless) t))) (defsubst subr-primitive-p (object) - "Return t if OBJECT is a built-in primitive function." + "Return t if OBJECT is a built-in primitive written in C. +Such objects can be functions or special forms." (declare (side-effect-free error-free)) (and (subrp object) (not (subr-native-elisp-p object)))) +(defsubst primitive-function-p (object) + "Return t if OBJECT is a built-in primitive function. +This excludes special forms, since they are not functions." + (declare (side-effect-free error-free)) + (and (subrp object) + (not (or (subr-native-elisp-p object) + (eq (cdr (subr-arity object)) 'unevalled))))) + (defsubst xor (cond1 cond2) "Return the boolean exclusive-or of COND1 and COND2. If only one of the arguments is non-nil, return it; otherwise diff --git a/src/data.c b/src/data.c index 5d6b6e0ba9d..69b990bed76 100644 --- a/src/data.c +++ b/src/data.c @@ -248,7 +248,7 @@ a fixed set of types. */) case PVEC_SUBR: return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp - : Qsubr_primitive; + : Qprimitive_function; case PVEC_COMPILED: return Qcompiled_function; case PVEC_BUFFER: return Qbuffer; case PVEC_CHAR_TABLE: return Qchar_table; @@ -4245,7 +4245,7 @@ syms_of_data (void) DEFSYM (Qwindow, "window"); DEFSYM (Qsubr, "subr"); DEFSYM (Qspecial_form, "special-form"); - DEFSYM (Qsubr_primitive, "subr-primitive"); + DEFSYM (Qprimitive_function, "primitive-function"); DEFSYM (Qsubr_native_elisp, "subr-native-elisp"); DEFSYM (Qcompiled_function, "compiled-function"); DEFSYM (Qbuffer, "buffer"); diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 9d76c58224d..daa49e671b5 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -869,9 +869,7 @@ comparing the subr with a much slower Lisp implementation." tree-sitter-node tree-sitter-parser ;; `functionp' also matches things of type ;; `symbol' and `cons'. - ;; FIXME: `subr-primitive-p' also matches - ;; special-forms. - function subr-primitive)) + function)) (should-not (cl-typep val subtype))))))))) From 63e67916b01569da5bb24f6d9a354dc72897c468 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 14 Mar 2024 12:49:08 -0400 Subject: [PATCH 084/155] Followup changes to `cl-type-of` These changes came up while working on `cl-type-of` but are not directly related to the new `cl-type-of`. The BASE_PURESIZE bump was needed at some point on one of my machine, not sure why. * src/puresize.h (BASE_PURESIZE): Bump up. * src/sqlite.c (bind_value): Don't use `Ftype_of`. * lisp/emacs-lisp/seq.el (seq-remove-at-position): Simplify. * lisp/emacs-lisp/cl-preloaded.el (finalizer): New (previously missing) type. * doc/lispref/objects.texi (Type Predicates): Minor tweaks. --- doc/lispref/objects.texi | 6 +++--- lisp/emacs-lisp/cl-preloaded.el | 1 + lisp/emacs-lisp/seq.el | 3 +-- src/lisp.h | 6 ++---- src/puresize.h | 2 +- src/sqlite.c | 17 ++++++----------- 6 files changed, 14 insertions(+), 21 deletions(-) diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 1e448b64296..aa1e073042f 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -1485,8 +1485,8 @@ types that are not built into Emacs. @subsection Type Descriptors A @dfn{type descriptor} is a @code{record} which holds information -about a type. Slot 1 in the record must be a symbol naming the type, and -@code{type-of} relies on this to return the type of @code{record} +about a type. The first slot in the record must be a symbol naming the type, +and @code{type-of} relies on this to return the type of @code{record} objects. No other type descriptor slot is used by Emacs; they are free for use by Lisp extensions. @@ -2175,7 +2175,7 @@ with references to further information. function @code{type-of}. Recall that each object belongs to one and only one primitive type; @code{type-of} tells you which one (@pxref{Lisp Data Types}). But @code{type-of} knows nothing about non-primitive -types. In most cases, it is more convenient to use type predicates than +types. In most cases, it is preferable to use type predicates than @code{type-of}. @defun type-of object diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index d11c97a3e3a..cba56e0bbd4 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -365,6 +365,7 @@ (cl--define-built-in-type buffer atom) (cl--define-built-in-type window atom) (cl--define-built-in-type process atom) +(cl--define-built-in-type finalizer atom) (cl--define-built-in-type window-configuration atom) (cl--define-built-in-type overlay atom) (cl--define-built-in-type number-or-marker atom diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 20077db9e60..a20cff16982 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -362,8 +362,7 @@ the result. The result is a sequence of the same type as SEQUENCE." (seq-concatenate - (let ((type (type-of sequence))) - (if (eq type 'cons) 'list type)) + (if (listp sequence) 'list (type-of sequence)) (seq-subseq sequence 0 n) (seq-subseq sequence (1+ n)))) diff --git a/src/lisp.h b/src/lisp.h index f353e4956eb..f86758c88fb 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -569,10 +569,8 @@ enum Lisp_Fwd_Type your object -- this way, the same object could be used to represent several disparate C structures. - In addition, you need to add switch branches in data.c for Ftype_of. - - You also need to add the new type to the constant - `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */ + In addition, you need to add switch branches in data.c for Fcl_type_of + and `cl--define-builtin-type` in lisp/emacs-lisp/cl-preloaded.el. */ /* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a diff --git a/src/puresize.h b/src/puresize.h index ac5d2da30dc..2a716872832 100644 --- a/src/puresize.h +++ b/src/puresize.h @@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN #endif #ifndef BASE_PURESIZE -#define BASE_PURESIZE (2750000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA) +#define BASE_PURESIZE (3000000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA) #endif /* Increase BASE_PURESIZE by a ratio depending on the machine's word size. */ diff --git a/src/sqlite.c b/src/sqlite.c index 7a018b28aa4..261080da673 100644 --- a/src/sqlite.c +++ b/src/sqlite.c @@ -349,9 +349,7 @@ bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values) value = XCAR (values); values = XCDR (values); } - Lisp_Object type = Ftype_of (value); - - if (EQ (type, Qstring)) + if (STRINGP (value)) { Lisp_Object encoded; bool blob = false; @@ -385,14 +383,11 @@ bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values) SSDATA (encoded), SBYTES (encoded), NULL); } - else if (EQ (type, Qinteger)) - { - if (BIGNUMP (value)) - ret = sqlite3_bind_int64 (stmt, i + 1, bignum_to_intmax (value)); - else - ret = sqlite3_bind_int64 (stmt, i + 1, XFIXNUM (value)); - } - else if (EQ (type, Qfloat)) + else if (FIXNUMP (value)) + ret = sqlite3_bind_int64 (stmt, i + 1, XFIXNUM (value)); + else if (BIGNUMP (value)) + ret = sqlite3_bind_int64 (stmt, i + 1, bignum_to_intmax (value)); + else if (FLOATP (value)) ret = sqlite3_bind_double (stmt, i + 1, XFLOAT_DATA (value)); else if (NILP (value)) ret = sqlite3_bind_null (stmt, i + 1); From 70ac815ece299007ff468c09632ef4d488e69be3 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 18 Mar 2024 09:38:23 -0400 Subject: [PATCH 085/155] * lisp/emacs-lisp/cl-preloaded.el (user-ptr): Add predicate --- lisp/emacs-lisp/cl-preloaded.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index cba56e0bbd4..f7757eae9c0 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -328,7 +328,9 @@ (:predicate (setq predicate val)) (_ (error "Unknown keyword arg: %S" kw))))) `(progn - ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate)) + ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate) + ;; (message "Missing predicate for: %S" name) + nil) (put ',name 'cl--class (built-in-class--make ',name ,docstring (mapcar (lambda (type) @@ -352,7 +354,8 @@ (cl--define-built-in-type tree-sitter-compiled-query atom) (cl--define-built-in-type tree-sitter-node atom) (cl--define-built-in-type tree-sitter-parser atom) -(cl--define-built-in-type user-ptr atom) +(cl--define-built-in-type user-ptr atom + nil :predicate user-ptrp) ;; FIXME: Shouldn't it be called `user-ptr-p'? (cl--define-built-in-type font-object atom) (cl--define-built-in-type font-entity atom) (cl--define-built-in-type font-spec atom) From ce29ae32d0b05cedbc9ba65c1a347ab7c34420ad Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 18 Mar 2024 15:59:54 +0200 Subject: [PATCH 086/155] ; * lisp/vc/vc-git.el (vc-git--out-str): Doc fix. --- lisp/emacs-lisp/shortdoc.el | 2 +- lisp/vc/vc-git.el | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index cbb5618ffce..a1e49b50510 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1781,7 +1781,7 @@ With prefix numeric argument ARG, do it that many times." (interactive) (save-excursion (goto-char (pos-bol)) - (when-let* ((re (rx bol "(" (group (+ (not (in " ")))))) + (when-let* ((re (rx bol "(" (group (+ (not (in " )")))))) (string (and (or (looking-at re) (re-search-backward re nil t)) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 0d54e234659..b23a5ca95a1 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -2240,7 +2240,7 @@ Return whether the process exited with status zero." (zerop (apply #'vc-git--call '(t nil) command args))) (defun vc-git--out-str (command &rest args) - "Run `git COMMAND ARGS...' and return standard output. + "Run `git COMMAND ARGS...' and return standard output as a string. The exit status is ignored." (with-output-to-string (with-current-buffer standard-output From f2e239c6a7d54ec3849a3bb783685953b6683752 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Tue, 19 Mar 2024 12:08:17 +0800 Subject: [PATCH 087/155] Respect display names of Android content URIs * java/org/gnu/emacs/EmacsNative.java (displayNameHash): New function. * java/org/gnu/emacs/EmacsService.java (buildContentName): New argument RESOLVER. Generate names holding URI's display name if available. All callers changed. * lisp/international/mule-cmds.el (set-default-coding-systems): Fix file name coding system as utf-8-unix on Android as on Mac OS. * src/androidvfs.c (enum android_vnode_type): New enum ANDROID_VNODE_CONTENT_AUTHORITY_NAMED. (android_content_name): Register root directories for this new type. (displayNameHash): New function. (android_get_content_name): New argument WITH_CHECKSUM. If present, treat the final two components as a pair of checksum and display name, and verify and exclude the two. (android_authority_name): Provide new argument as appropriate. (android_authority_initial_name): New function. --- java/org/gnu/emacs/EmacsNative.java | 10 +- java/org/gnu/emacs/EmacsOpenActivity.java | 9 +- java/org/gnu/emacs/EmacsService.java | 80 +++++++++++- lisp/international/mule-cmds.el | 7 +- src/androidvfs.c | 150 ++++++++++++++++++++-- 5 files changed, 231 insertions(+), 25 deletions(-) diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java index 898eaef41a7..654e94b1a7d 100644 --- a/java/org/gnu/emacs/EmacsNative.java +++ b/java/org/gnu/emacs/EmacsNative.java @@ -281,7 +281,7 @@ public static native SurroundingText getSurroundingText (short window, public static native int[] getSelection (short window); - /* Graphics functions used as a replacement for potentially buggy + /* Graphics functions used as replacements for potentially buggy Android APIs. */ public static native void blitRect (Bitmap src, Bitmap dest, int x1, @@ -289,7 +289,6 @@ public static native void blitRect (Bitmap src, Bitmap dest, int x1, /* Increment the generation ID of the specified BITMAP, forcing its texture to be re-uploaded to the GPU. */ - public static native void notifyPixelsChanged (Bitmap bitmap); @@ -313,6 +312,13 @@ public static native void blitRect (Bitmap src, Bitmap dest, int x1, in the process. */ public static native boolean ftruncate (int fd); + + /* Functions that assist in generating content file names. */ + + /* Calculate an 8 digit checksum for the byte array DISPLAYNAME + suitable for inclusion in a content file name. */ + public static native String displayNameHash (byte[] displayName); + static { /* Older versions of Android cannot link correctly with shared diff --git a/java/org/gnu/emacs/EmacsOpenActivity.java b/java/org/gnu/emacs/EmacsOpenActivity.java index 9ae1bf353dd..2cdfa2ec776 100644 --- a/java/org/gnu/emacs/EmacsOpenActivity.java +++ b/java/org/gnu/emacs/EmacsOpenActivity.java @@ -252,7 +252,7 @@ private class EmacsClientThread extends Thread if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.KITKAT) { - content = EmacsService.buildContentName (uri); + content = EmacsService.buildContentName (uri, getContentResolver ()); return content; } @@ -423,6 +423,7 @@ private class EmacsClientThread extends Thread /* Obtain the intent that started Emacs. */ intent = getIntent (); action = intent.getAction (); + resolver = getContentResolver (); if (action == null) { @@ -536,7 +537,7 @@ private class EmacsClientThread extends Thread if ((scheme = uri.getScheme ()) != null && scheme.equals ("content")) { - tem1 = EmacsService.buildContentName (uri); + tem1 = EmacsService.buildContentName (uri, resolver); attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\") .replace ("\"", "\\\"") .replace ("$", "\\$")) @@ -568,7 +569,8 @@ private class EmacsClientThread extends Thread && (scheme = uri.getScheme ()) != null && scheme.equals ("content")) { - tem1 = EmacsService.buildContentName (uri); + tem1 + = EmacsService.buildContentName (uri, resolver); builder.append ("\""); builder.append (tem1.replace ("\\", "\\\\") .replace ("\"", "\\\"") @@ -609,7 +611,6 @@ private class EmacsClientThread extends Thread underlying file, but it cannot be found without opening the file and doing readlink on its file descriptor in /proc/self/fd. */ - resolver = getContentResolver (); fd = null; try diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 9bc40d63311..19aa3dee456 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -79,6 +79,7 @@ import android.provider.DocumentsContract; import android.provider.DocumentsContract.Document; +import android.provider.OpenableColumns; import android.provider.Settings; import android.util.Log; @@ -1033,22 +1034,87 @@ invocation of app_process (through android-emacs) can return false; } + /* Return a 8 character checksum for the string STRING, after encoding + as UTF-8 data. */ + + public static String + getDisplayNameHash (String string) + { + byte[] encoded; + + try + { + encoded = string.getBytes ("UTF-8"); + return EmacsNative.displayNameHash (encoded); + } + catch (UnsupportedEncodingException exception) + { + /* This should be impossible. */ + return "error"; + } + } + /* Build a content file name for URI. Return a file name within the /contents/by-authority pseudo-directory that `android_get_content_name' can then transform back into an encoded URI. + If a display name can be requested from URI (using the resolver + RESOLVER), append it to this file name. + A content name consists of any number of unencoded path segments separated by `/' characters, possibly followed by a question mark and an encoded query string. */ public static String - buildContentName (Uri uri) + buildContentName (Uri uri, ContentResolver resolver) { StringBuilder builder; + String displayName; + String[] projection; + Cursor cursor; + int column; - builder = new StringBuilder ("/content/by-authority/"); + displayName = null; + cursor = null; + + try + { + projection = new String[] { OpenableColumns.DISPLAY_NAME, }; + cursor = resolver.query (uri, projection, null, null, null); + + if (cursor != null) + { + cursor.moveToFirst (); + column + = cursor.getColumnIndexOrThrow (OpenableColumns.DISPLAY_NAME); + displayName + = cursor.getString (column); + + /* Verify that the display name is valid, i.e. it + contains no characters unsuitable for a file name and + is nonempty. */ + if (displayName.isEmpty () || displayName.contains ("/")) + displayName = null; + } + } + catch (Exception e) + { + /* Ignored. */ + } + finally + { + if (cursor != null) + cursor.close (); + } + + /* If a display name is available, at this point it should be the + value of displayName. */ + + builder = new StringBuilder (displayName != null + ? "/content/by-authority-named/" + : "/content/by-authority/"); builder.append (uri.getAuthority ()); /* First, append each path segment. */ @@ -1065,6 +1131,16 @@ invocation of app_process (through android-emacs) can if (uri.getEncodedQuery () != null) builder.append ('?').append (uri.getEncodedQuery ()); + /* Append the display name. */ + + if (displayName != null) + { + builder.append ('/'); + builder.append (getDisplayNameHash (displayName)); + builder.append ('/'); + builder.append (displayName); + } + return builder.toString (); } diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 6b4c83112e3..e80c42f523a 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -350,9 +350,10 @@ This also sets the following values: if CODING-SYSTEM is ASCII-compatible" (check-coding-system coding-system) (setq-default buffer-file-coding-system coding-system) - - (if (eq system-type 'darwin) - ;; The file-name coding system on Darwin systems is always utf-8. + (if (or (eq system-type 'darwin) + (eq system-type 'android)) + ;; The file-name coding system on Darwin and Android systems is + ;; always UTF-8. (setq default-file-name-coding-system 'utf-8-unix) (if (and (or (not coding-system) (coding-system-get coding-system 'ascii-compatible-p))) diff --git a/src/androidvfs.c b/src/androidvfs.c index 4bb652f3eb7..9e3d5cab8cf 100644 --- a/src/androidvfs.c +++ b/src/androidvfs.c @@ -33,6 +33,7 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include @@ -255,6 +256,7 @@ enum android_vnode_type ANDROID_VNODE_AFS, ANDROID_VNODE_CONTENT, ANDROID_VNODE_CONTENT_AUTHORITY, + ANDROID_VNODE_CONTENT_AUTHORITY_NAMED, ANDROID_VNODE_SAF_ROOT, ANDROID_VNODE_SAF_TREE, ANDROID_VNODE_SAF_FILE, @@ -2435,6 +2437,7 @@ struct android_content_vdir }; static struct android_vnode *android_authority_initial (char *, size_t); +static struct android_vnode *android_authority_initial_name (char *, size_t); static struct android_vnode *android_saf_root_initial (char *, size_t); /* Content provider meta-interface. This implements a vnode at @@ -2445,9 +2448,9 @@ static struct android_vnode *android_saf_root_initial (char *, size_t); a list of each directory tree Emacs has been granted permanent access to through the Storage Access Framework. - /content/by-authority exists on Android 4.4 and later; it contains - no directories, but provides a `name' function that converts - children into content URIs. */ + /content/by-authority and /content/by-authority-named exists on + Android 4.4 and later; it contains no directories, but provides a + `name' function that converts children into content URIs. */ static struct android_vnode *android_content_name (struct android_vnode *, char *, size_t); @@ -2490,7 +2493,7 @@ static struct android_vops content_vfs_ops = static const char *content_directory_contents[] = { - "storage", "by-authority", + "storage", "by-authority", "by-authority-named", }; /* Chain consisting of all open content directory streams. */ @@ -2508,8 +2511,9 @@ android_content_name (struct android_vnode *vnode, char *name, int api; static struct android_special_vnode content_vnodes[] = { - { "storage", 7, android_saf_root_initial, }, - { "by-authority", 12, android_authority_initial, }, + { "storage", 7, android_saf_root_initial, }, + { "by-authority", 12, android_authority_initial, }, + { "by-authority-named", 18, android_authority_initial_name, }, }; /* Canonicalize NAME. */ @@ -2551,7 +2555,7 @@ android_content_name (struct android_vnode *vnode, char *name, call its root lookup function with the rest of NAME there. */ if (api < 19) - i = 2; + i = 3; else if (api < 21) i = 1; else @@ -2855,18 +2859,59 @@ android_content_initial (char *name, size_t length) +#ifdef __clang__ +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wmissing-prototypes" +#else /* GNUC */ +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wmissing-prototypes" +#endif /* __clang__ */ + /* Content URI management functions. */ +JNIEXPORT jstring JNICALL +NATIVE_NAME (displayNameHash) (JNIEnv *env, jobject object, + jbyteArray display_name) +{ + char checksum[9], block[MD5_DIGEST_SIZE]; + jbyte *data; + + data = (*env)->GetByteArrayElements (env, display_name, NULL); + if (!data) + return NULL; + + /* Hash the buffer. */ + md5_buffer ((char *) data, (*env)->GetArrayLength (env, display_name), + block); + (*env)->ReleaseByteArrayElements (env, display_name, data, JNI_ABORT); + + /* Generate the digest string. */ + hexbuf_digest (checksum, (char *) block, 4); + checksum[8] = '\0'; + return (*env)->NewStringUTF (env, checksum); +} + +#ifdef __clang__ +#pragma clang diagnostic pop +#else /* GNUC */ +#pragma GCC diagnostic pop +#endif /* __clang__ */ + /* Return the content URI corresponding to a `/content/by-authority' file name, or NULL if it is invalid for some reason. FILENAME should be relative to /content/by-authority, with no leading - directory separator character. */ + directory separator character. + + WITH_CHECKSUM should be true if FILENAME contains a display name and + a checksum for that display name. */ static char * -android_get_content_name (const char *filename) +android_get_content_name (const char *filename, bool with_checksum) { char *fill, *buffer; size_t length; + char checksum[9], new_checksum[9], block[MD5_DIGEST_SIZE]; + const char *p2, *p1; /* Make sure FILENAME isn't obviously invalid: it must contain an authority name and a file name component. */ @@ -2888,11 +2933,55 @@ android_get_content_name (const char *filename) return NULL; } + if (!with_checksum) + goto no_checksum; + + /* Content file names hold two components providing a display name and + a short checksum that protects against files being opened under + display names besides those provided in the content file name at + the time of generation. */ + + p1 = strrchr (filename, '/'); /* Display name. */ + p2 = memrchr (filename, '/', p1 - filename); /* Start of checksum. */ + + /* If the name be excessively short or the checksum of an invalid + length, return. */ + if (!p2 || (p1 - p2) != 9) + { + errno = ENOENT; + return NULL; + } + + /* Copy the checksum into CHECKSUM. */ + memcpy (checksum, p2 + 1, 8); + new_checksum[8] = checksum[8] = '\0'; + + /* Hash this string and store 8 bytes of the resulting digest into + new_checksum. */ + md5_buffer (p1 + 1, strlen (p1 + 1), block); + hexbuf_digest (new_checksum, (char *) block, 4); + + /* Compare both checksums. */ + if (strcmp (new_checksum, checksum)) + { + errno = ENOENT; + return NULL; + } + + /* Remove the checksum and file display name from the URI. */ + length = p2 - filename; + + no_checksum: + if (length > INT_MAX) + { + errno = ENOMEM; + return NULL; + } + /* Prefix FILENAME with content:// and return the buffer containing that URI. */ - - buffer = xmalloc (sizeof "content://" + length); - sprintf (buffer, "content://%s", filename); + buffer = xmalloc (sizeof "content://" + length + 1); + sprintf (buffer, "content://%.*s", (int) length, filename); return buffer; } @@ -2932,7 +3021,7 @@ android_check_content_access (const char *uri, int mode) /* Content authority-based vnode implementation. - /contents/by-authority is a simple vnode implementation that converts + /content/by-authority is a simple vnode implementation that converts components to content:// URIs. It does not canonicalize file names by removing parent directory @@ -3039,7 +3128,14 @@ android_authority_name (struct android_vnode *vnode, char *name, if (android_verify_jni_string (name)) goto no_entry; - uri_name = android_get_content_name (name); + if (vp->vnode.type == ANDROID_VNODE_CONTENT_AUTHORITY_NAMED) + /* This indicates that the two trailing components of NAME + provide a checksum and a file display name, to be verified, + then excluded from the content URI. */ + uri_name = android_get_content_name (name, true); + else + uri_name = android_get_content_name (name, false); + if (!uri_name) goto error; @@ -3333,6 +3429,32 @@ android_authority_initial (char *name, size_t length) return android_authority_name (&temp.vnode, name, length); } +/* Find the vnode designated by NAME relative to the root of the + by-authority-named directory. + + If NAME is empty or a single leading separator character, return + a vnode representing the by-authority directory itself. + + Otherwise, represent the remainder of NAME as a URI (without + normalizing it) and return a vnode corresponding to that. + + Value may also be NULL with errno set if the designated vnode is + not available, such as when Android windowing has not been + initialized. */ + +static struct android_vnode * +android_authority_initial_name (char *name, size_t length) +{ + struct android_authority_vnode temp; + + temp.vnode.ops = &authority_vfs_ops; + temp.vnode.type = ANDROID_VNODE_CONTENT_AUTHORITY_NAMED; + temp.vnode.flags = 0; + temp.uri = NULL; + + return android_authority_name (&temp.vnode, name, length); +} + /* SAF ``root'' vnode implementation. From a7cb220523d881449a2dba683e7358b3312fd482 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Tue, 19 Mar 2024 12:17:43 +0800 Subject: [PATCH 088/155] Update android.texi * doc/emacs/android.texi (Android Startup): Describe /content/by-authority-named. --- doc/emacs/android.texi | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index a45ec84f3f0..56bfa2591f6 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -143,11 +143,13 @@ that if that Emacs in turn does not start the Emacs server, subsequent attempts to open the file with the wrapper will fail. @cindex /content/by-authority directory, android +@cindex /content/by-authority-named directory, android Some files are given to Emacs as ``content identifiers'' that the system provides access to outside the normal filesystem APIs. Emacs -uses a pseudo-directory named @file{/content/by-authority} to access -those files. Do not make any assumptions about the contents of this -directory, or try to open files in it yourself. +uses pseudo-directories named @file{/content/by-authority} and +@file{/content/by-authority-named} to access those files. Do not make +any assumptions about the contents of this directory, or try to open +files in it yourself. This feature is not provided on Android 4.3 and earlier, in which case such files are copied to a temporary directory before being From 0f76baeac074a3d8f15b29b34b873b44d551979b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Mar 2024 10:41:52 +0100 Subject: [PATCH 089/155] * Use 'cl-type-of' in comp-cstr.el * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-homogeneous-no-range) (comp-cstr-union-1-no-mem, comp-cstr-intersection-no-hashcons): Make use of 'cl-type-of' in place of 'type-of'. --- lisp/emacs-lisp/comp-cstr.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5922a8caf12..70456a70de1 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -575,7 +575,7 @@ All SRCS constraints must be homogeneously negated or non-negated." ;; We propagate only values those types are not already ;; into typeset. when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) + (comp-subtype-p (cl-type-of v) x)) (comp-cstr-typeset dst)) collect v))) @@ -664,7 +664,7 @@ DST is returned." ;; Verify disjoint condition between positive types and ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (let ((neg-value-types (nconc (mapcar #'cl-type-of (valset neg)) (when (range neg) '(integer))))) (when (cl-some (lambda (x) @@ -685,7 +685,7 @@ DST is returned." ((cl-some (lambda (x) (cl-some (lambda (y) (comp-subtype-p y x)) - (mapcar #'type-of (valset pos)))) + (mapcar #'cl-type-of (valset pos)))) (typeset neg)) (give-up)) (t @@ -1108,7 +1108,7 @@ DST is returned." (cl-loop for v in (valset dst) unless (symbolp v) do (push v strip-values) - (push (type-of v) strip-types)) + (push (cl-type-of v) strip-types)) (when strip-values (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) (valset dst) (cl-set-difference (valset dst) strip-values))) From f7f619779c93bb567a1658ef06199fc1816f88fb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 19 Mar 2024 10:48:18 +0100 Subject: [PATCH 090/155] * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-test-93): Add test. --- test/lisp/emacs-lisp/comp-cstr-tests.el | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 991ab1f40eb..b823a190d5a 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -232,9 +232,8 @@ The arg is an alist of: type specifier -> expected type specifier." ;; 92 ((or string char-table bool-vector vector cons symbol number) . (or number sequence symbol)) - ;; 93? - ;; FIXME: I get `cons' rather than `list'? - ;;((or null cons) . list) + ;; 93 + ((or list (not null)) . t) )) ;;; comp-cstr-tests.el ends here From 88355de6022458c3e890cc6d5da60d6f35fe8868 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Tue, 19 Mar 2024 14:45:45 +0200 Subject: [PATCH 091/155] Unbreak the Cygw32 build broken by resent WTS_SESSION changes * src/w32xfns.c (WTS_VIRTUAL_CLASS): * src/w32fns.c (WTS_VIRTUAL_CLASS, WM_WTSSESSION_CHANGE) (WTS_SESSION_LOCK): Define only for WINDOWSNT. * src/w32xfns.c (drain_message_queue): Call 'reset_w32_kbdhook_state' only for WINDOWSNT. (Bug#69888) --- src/w32fns.c | 8 +++++--- src/w32xfns.c | 9 +++++++-- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/w32fns.c b/src/w32fns.c index 7d288ce7bd5..ace8d1016a5 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -305,10 +305,12 @@ static unsigned int sound_type = 0xFFFFFFFF; /* Special virtual key code for indicating "any" key. */ #define VK_ANY 0xFF -#ifndef WM_WTSSESSION_CHANGE +#ifdef WINDOWSNT +# ifndef WM_WTSSESSION_CHANGE /* 32-bit MinGW does not define these constants. */ -# define WM_WTSSESSION_CHANGE 0x02B1 -# define WTS_SESSION_LOCK 0x7 +# define WM_WTSSESSION_CHANGE 0x02B1 +# define WTS_SESSION_LOCK 0x7 +# endif #endif #ifndef WS_EX_NOACTIVATE diff --git a/src/w32xfns.c b/src/w32xfns.c index 853c8368118..b248697e658 100644 --- a/src/w32xfns.c +++ b/src/w32xfns.c @@ -22,9 +22,11 @@ along with GNU Emacs. If not, see . */ #include #include #include + +#ifdef WINDOWSNT /* Override API version to get the required functionality. */ -#undef _WIN32_WINNT -#define _WIN32_WINNT 0x0501 +# undef _WIN32_WINNT +# define _WIN32_WINNT 0x0501 /* mingw.org's MinGW headers mistakenly omit this enumeration: */ # ifndef MINGW_W64 typedef enum _WTS_VIRTUAL_CLASS { @@ -33,6 +35,7 @@ typedef enum _WTS_VIRTUAL_CLASS { } WTS_VIRTUAL_CLASS; # endif #include /* for WM_WTSSESSION_CHANGE, WTS_SESSION_LOCK */ +#endif /* WINDOWSNT */ #include "lisp.h" #include "frame.h" @@ -426,10 +429,12 @@ drain_message_queue (void) { switch (msg.message) { +#ifdef WINDOWSNT case WM_WTSSESSION_CHANGE: if (msg.wParam == WTS_SESSION_LOCK) reset_w32_kbdhook_state (); break; +#endif case WM_EMACS_FILENOTIFY: retval = 1; break; From 014cd0040275bb2a4d08d392825b4814452275db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Mon, 18 Mar 2024 19:47:59 +0100 Subject: [PATCH 092/155] Fix vc-git test when no identities are configured Reported by john muhl . * test/lisp/vc/vc-git-tests.el (vc-git-test--with-repo): Set some environment variables (lifted from vc-tests.el) to let 'git commit' compute dummy author and committer identities. --- test/lisp/vc/vc-git-tests.el | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index fd3e8ccd602..bbf0c4277dd 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -88,10 +88,17 @@ The current directory will be set to the top of that repository; NAME will be bound to that directory's file name. Once BODY exits, the -directory will be deleted." +directory will be deleted. + +Some dummy environment variables will be set for the duration of BODY to +allow 'git commit' to determine identities for authors and committers." (declare (indent 1)) `(ert-with-temp-directory ,name - (let ((default-directory ,name)) + (let ((default-directory ,name) + (process-environment (append '("EMAIL=john@doe.ee" + "GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) (vc-create-repo 'Git) ,@body))) From e72f17e4622fae45c9814f6ed196e5a9ed06cdd2 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Wed, 20 Mar 2024 10:23:42 +0800 Subject: [PATCH 093/155] Respect file display names during Android drag-and-drop * java/org/gnu/emacs/EmacsService.java (buildContentName): Remove redundant projection argument to resolver.query. * java/org/gnu/emacs/EmacsWindow.java (onDragEvent): If a content resolver is available, attempt to convert content URIs into file names in advance. * lisp/term/android-win.el (android-handle-dnd-event): Adjust correspondingly. --- java/org/gnu/emacs/EmacsService.java | 4 +-- java/org/gnu/emacs/EmacsWindow.java | 18 +++++++++++++- lisp/term/android-win.el | 37 ++++++++++++++++------------ 3 files changed, 39 insertions(+), 20 deletions(-) diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 19aa3dee456..785163c713c 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -1072,7 +1072,6 @@ If a display name can be requested from URI (using the resolver { StringBuilder builder; String displayName; - String[] projection; Cursor cursor; int column; @@ -1081,8 +1080,7 @@ If a display name can be requested from URI (using the resolver try { - projection = new String[] { OpenableColumns.DISPLAY_NAME, }; - cursor = resolver.query (uri, projection, null, null, null); + cursor = resolver.query (uri, null, null, null, null); if (cursor != null) { diff --git a/java/org/gnu/emacs/EmacsWindow.java b/java/org/gnu/emacs/EmacsWindow.java index 6e8bdaf7401..93a512cc7ef 100644 --- a/java/org/gnu/emacs/EmacsWindow.java +++ b/java/org/gnu/emacs/EmacsWindow.java @@ -31,6 +31,7 @@ import android.content.ClipData; import android.content.ClipDescription; +import android.content.ContentResolver; import android.content.Context; import android.graphics.Rect; @@ -1699,10 +1700,11 @@ else if (EmacsWindow.this.isMapped) ClipData data; ClipDescription description; int i, j, x, y, itemCount; - String type; + String type, uriString; Uri uri; EmacsActivity activity; StringBuilder builder; + ContentResolver resolver; x = (int) event.getX (); y = (int) event.getY (); @@ -1799,6 +1801,20 @@ else if (type.equals (ClipDescription.MIMETYPE_TEXT_URILIST)) { if ((activity.requestDragAndDropPermissions (event) == null)) uri = null; + else + { + resolver = activity.getContentResolver (); + + /* Substitute a content file name for the URI, if + possible. */ + uriString = EmacsService.buildContentName (uri, resolver); + + if (uriString != null) + { + builder.append (uriString).append ("\n"); + continue; + } + } } if (uri != null) diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index 1d10402b15d..8d262e5da98 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -282,11 +282,12 @@ If it reflects the motion of an item above a frame, call `dnd-handle-movement' to move the cursor or scroll the window under the item pursuant to the pertinent user options. -If it reflects dropped text, insert such text within window at -the location of the drop. +If it holds dropped text, insert such text within window at the +location of the drop. -If it reflects a list of URIs, then open each URI, converting -content:// URIs into the special file names which represent them." +If it holds a list of URIs, or file names, then open each URI or +file name, converting content:// URIs into the special file +names which represent them." (interactive "e") (let ((message (caddr event)) (posn (event-start event))) @@ -304,18 +305,22 @@ content:// URIs into the special file names which represent them." (new-uri-list nil) (dnd-unescape-file-uris t)) (dolist (uri uri-list) - (ignore-errors - (let ((url (url-generic-parse-url uri))) - (when (equal (url-type url) "content") - ;; Replace URI with a matching /content file - ;; name. - (setq uri (format "file:/content/by-authority/%s%s" - (url-host url) - (url-filename url)) - ;; And guarantee that this file URI is not - ;; subject to URI decoding, for it must be - ;; transformed back into a content URI. - dnd-unescape-file-uris nil)))) + ;; If the URI is a preprepared file name, insert it directly. + (if (string-match-p "^/content/by-authority\\(-named\\)?/" uri) + (setq uri (concat "file:" uri) + dnd-unescape-file-uris nil) + (ignore-errors + (let ((url (url-generic-parse-url uri))) + (when (equal (url-type url) "content") + ;; Replace URI with a matching /content file + ;; name. + (setq uri (format "file:/content/by-authority/%s%s" + (url-host url) + (url-filename url)) + ;; And guarantee that this file URI is not + ;; subject to URI decoding, for it must be + ;; transformed back into a content URI. + dnd-unescape-file-uris nil))))) (push uri new-uri-list)) (dnd-handle-multiple-urls (posn-window posn) new-uri-list From 5bdc2436c649ccc897a548a8e553244f58168216 Mon Sep 17 00:00:00 2001 From: Robert Pluim Date: Wed, 20 Mar 2024 09:33:37 +0100 Subject: [PATCH 094/155] ; * lisp/emacs-lisp/cl-macs.el (cl-labels): Fix stray diff marker. --- lisp/emacs-lisp/cl-macs.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 949b3284782..732deda618d 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2203,7 +2203,7 @@ Like `cl-flet' but the definitions can refer to previous ones. ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -+BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the forms of the function body. FUNC is defined in any BODY, as well as FORM, so you can write recursive and mutually recursive From 0b0c7da8c80a1e4dc328459f3403f358736ae90d Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 21 Feb 2024 22:31:45 +0100 Subject: [PATCH 095/155] Add native compiler sanitizer * src/comp.c (ABI_VERSION): Bump new version. (CALL0I): Uncomment. (helper_link_table, declare_runtime_imported_funcs): Add 'helper_sanitizer_assert'. (Fcomp__init_ctxt): Register emitter for 'helper_sanitizer_assert'. (helper_sanitizer_assert): New function. (syms_of_comp): 'helper_sanitizer_assert' defsym. (syms_of_comp): 'comp-sanitizer-error' define error. (syms_of_comp): 'comp-sanitizer-active' defvar. * lisp/emacs-lisp/comp.el (comp-passes): Add 'comp--sanitizer'. (comp-sanitizer-emit): Define var. (comp--sanitizer): Define function. * lisp/emacs-lisp/comp-run.el (comp-run-async-workers): Forward 'comp-sanitizer-emit'. --- lisp/emacs-lisp/comp-run.el | 1 + lisp/emacs-lisp/comp.el | 46 +++++++++++++++++++++++++++++++++++++ src/comp.c | 42 ++++++++++++++++++++++++++++++--- 3 files changed, 86 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index afb46e3cd19..480f048777c 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -256,6 +256,7 @@ display a message." load-path backtrace-line-length byte-compile-warnings + comp-sanitizer-emit ;; package-load-list ;; package-user-dir ;; package-directory-list diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9c2182092cb..6afb357bef2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -165,6 +165,7 @@ Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") comp--tco comp--fwprop comp--remove-type-hints + comp--sanitizer comp--compute-function-types comp--final) "Passes to be executed in order.") @@ -3006,6 +3007,51 @@ These are substituted with a normal `set' op." (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) + +;;; Sanitizer pass specific code. + +;; This pass aims to verify compile time value type predictions during +;; execution. +;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before +;; each conditional branch. 'helper_sanitizer_assert' will verify that +;; the variable tested by the conditional branch is of the predicted +;; value type and signal an error otherwise. + +(defvar comp-sanitizer-emit nil + "Gates the sanitizer pass. +In use for native compiler development and verification only.") + +(defun comp--sanitizer (_) + (when comp-sanitizer-emit + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + for comp-func = f + unless (comp-func-has-non-local comp-func) + do + (cl-loop + for b being each hash-value of (comp-func-blocks f) + do + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((cond-jump ,(and (pred comp-mvar-p) mvar-tested) + ,(pred comp-mvar-p) ,_bb1 ,_bb2)) + (let ((type (comp-cstr-to-type-spec mvar-tested)) + (insn (car insns-seq))) + ;; No need to check if type is t. + (unless (eq type t) + (comp--add-const-to-relocs type) + (setcar + insns-seq + (comp--call 'helper_sanitizer_assert + mvar-tested + (make--comp-mvar :constant type))) + (setcdr insns-seq (list insn))) + ;; (setf (comp-func-ssa-status comp-func) 'dirty) + (cl-return-from in-the-basic-block)))))) + do (comp--log-func comp-func 3)))) + ;;; Function types pass specific code. diff --git a/src/comp.c b/src/comp.c index 76cf1f3ab6e..5e4ca643072 100644 --- a/src/comp.c +++ b/src/comp.c @@ -469,7 +469,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "5" +#define ABI_VERSION "6" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -502,11 +502,9 @@ load_gccjit_if_necessary (bool mandatory) #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -#if 0 /* unused for now */ /* Like call0 but stringify and intern. */ #define CALL0I(fun) \ CALLN (Ffuncall, intern_c_string (STR (fun))) -#endif /* Like call1 but stringify and intern. */ #define CALL1I(fun, arg) \ @@ -702,6 +700,8 @@ static void helper_save_restriction (void); static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object, enum pvec_type); static struct Lisp_Symbol_With_Pos * helper_GET_SYMBOL_WITH_POSITION (Lisp_Object); +static Lisp_Object +helper_sanitizer_assert (Lisp_Object, Lisp_Object); /* Note: helper_link_table must match the list created by `declare_runtime_imported_funcs'. */ @@ -714,6 +714,7 @@ static void *helper_link_table[] = helper_unbind_n, helper_save_restriction, helper_GET_SYMBOL_WITH_POSITION, + helper_sanitizer_assert, record_unwind_current_buffer, set_internal, helper_unwind_protect, @@ -2975,6 +2976,10 @@ declare_runtime_imported_funcs (void) ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type, 1, args); + args[0] = comp.lisp_obj_type; + args[1] = comp.lisp_obj_type; + ADD_IMPORTED (helper_sanitizer_assert, comp.lisp_obj_type, 2, args); + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; @@ -4619,6 +4624,8 @@ Return t on success. */) emit_simple_limple_call_void_ret); register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); + register_emitter (Qhelper_sanitizer_assert, + emit_simple_limple_call_lisp_ret); /* Inliners. */ register_emitter (Qadd1, emit_add1); register_emitter (Qsub1, emit_sub1); @@ -5082,6 +5089,21 @@ helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); } +static Lisp_Object +helper_sanitizer_assert (Lisp_Object val, Lisp_Object type) +{ + if (!comp_sanitizer_active + || !NILP ((CALL2I (cl-typep, val, type)))) + return Qnil; + + AUTO_STRING (format, "Comp sanitizer FAIL for %s with type %s"); + CALLN (Fmessage, format, val, type); + CALL0I (backtrace); + xsignal2 (Qcomp_sanitizer_error, val, type); + + return Qnil; +} + /* `native-comp-eln-load-path' clean-up support code. */ @@ -5709,6 +5731,7 @@ natively-compiled one. */); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + DEFSYM (Qhelper_sanitizer_assert, "helper_sanitizer_assert"); /* Inliners. */ DEFSYM (Qadd1, "1+"); DEFSYM (Qsub1, "1-"); @@ -5779,6 +5802,12 @@ natively-compiled one. */); build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + DEFSYM (Qcomp_sanitizer_error, "comp-sanitizer-error"); + Fput (Qcomp_sanitizer_error, Qerror_conditions, + pure_list (Qcomp_sanitizer_error, Qerror)); + Fput (Qcomp_sanitizer_error, Qerror_message, + build_pure_c_string ("Native code sanitizer runtime error")); + DEFSYM (Qnative__compile_async, "native--compile-async"); defsubr (&Scomp__subr_signature); @@ -5901,6 +5930,13 @@ subr-name -> arity For internal use. */); Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal); + DEFVAR_BOOL ("comp-sanitizer-active", comp_sanitizer_active, + doc: /* When non-nil enable sanitizer runtime execution. +To be effective Lisp Code must have been compiled with +`comp-sanitizer-emit' non-nil. +In use for native compiler development and verification only. */); + comp_sanitizer_active = false; + Fprovide (intern_c_string ("native-compile"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ From e8d2bc75314262d512d367c270c6d43201ef533f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Mar 2024 11:49:32 +0100 Subject: [PATCH 096/155] ; * lisp/emacs-lisp/comp-cstr.el (comp--normalize-typeset0): Fix comment. --- lisp/emacs-lisp/comp-cstr.el | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 70456a70de1..cbfb9540f03 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -288,13 +288,10 @@ Return them as multiple value." (apply #'append (mapcar #'comp--direct-supertypes typeset))) for subs = (comp--direct-subtypes sup) - when (and (length> subs 1) ;;FIXME: Why? - ;; Every subtype of `sup` is a subtype of - ;; some element of `typeset`? - ;; It's tempting to just check (member x typeset), - ;; but think of the typeset (marker number), - ;; where `sup' is `integer-or-marker' and `sub' - ;; is `integer'. + when (and (length> subs 1) ;; If there's only one sub do + ;; nothing as we want to + ;; return the most specific + ;; type. (cl-every (lambda (sub) (cl-some (lambda (type) (comp-subtype-p sub type)) From 1475e3c3b562f7604e538fccbb41f1d66b10663d Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 20 Mar 2024 14:27:25 +0200 Subject: [PATCH 097/155] ; Fix doc strings of recent changes * src/comp.c (syms_of_comp) : * lisp/emacs-lisp/comp.el (comp-sanitizer-emit): Doc fixes. --- lisp/emacs-lisp/comp.el | 3 ++- src/comp.c | 9 +++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6afb357bef2..d7830597709 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3019,7 +3019,8 @@ These are substituted with a normal `set' op." (defvar comp-sanitizer-emit nil "Gates the sanitizer pass. -In use for native compiler development and verification only.") +This is intended to be used only for development and verification of +the native compiler.") (defun comp--sanitizer (_) (when comp-sanitizer-emit diff --git a/src/comp.c b/src/comp.c index 5e4ca643072..99f51e07048 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5931,10 +5931,11 @@ For internal use. */); Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal); DEFVAR_BOOL ("comp-sanitizer-active", comp_sanitizer_active, - doc: /* When non-nil enable sanitizer runtime execution. -To be effective Lisp Code must have been compiled with -`comp-sanitizer-emit' non-nil. -In use for native compiler development and verification only. */); + doc: /* If non-nil, enable runtime execution of native-compiler sanitizer. +For this to be effective, Lisp code must be compiled +with `comp-sanitizer-emit' non-nil. +This is intended to be used only for development and +verification of the native compiler. */); comp_sanitizer_active = false; Fprovide (intern_c_string ("native-compile"), Qnil); From 7f6e335f4b4dba9378345625274fa477e0d38c5d Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 20 Mar 2024 14:45:24 +0200 Subject: [PATCH 098/155] Fix documentation of M-SPC in user manual * doc/emacs/killing.texi (Deletion): Fix documentation of 'cycle-spacing'. (Bug#69905) --- doc/emacs/killing.texi | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi index 75ad631649c..c6633eb1892 100644 --- a/doc/emacs/killing.texi +++ b/doc/emacs/killing.texi @@ -91,9 +91,11 @@ Delete the next character (@code{delete-char}). @item M-\ Delete spaces and tabs around point (@code{delete-horizontal-space}). +@item M-x just-one-space +Delete spaces and tabs around point, leaving one space. @item M-@key{SPC} -Delete spaces and tabs around point, leaving one space -(@code{just-one-space}). +Delete spaces and tabs around point in flexible ways +(@code{cycle-spacing}). @item C-x C-o Delete blank lines around the current line (@code{delete-blank-lines}). @item M-^ @@ -118,12 +120,13 @@ characters before and after point. With a prefix argument, this only deletes spaces and tab characters before point. @findex just-one-space -@code{just-one-space} does likewise but leaves a single space before -point, regardless of the number of spaces that existed previously -(even if there were none before). With a numeric argument @var{n}, it -leaves @var{n} spaces before point if @var{n} is positive; if @var{n} -is negative, it deletes newlines in addition to spaces and tabs, -leaving @minus{}@var{n} spaces before point. +@kbd{M-x just-one-space} deletes tabs and spaces around point, but +leaves a single space before point, regardless of the number of spaces +that existed previously (even if there were none before). With a +numeric argument @var{n}, it leaves @var{n} spaces before point if +@var{n} is positive; if @var{n} is negative, it deletes newlines in +addition to spaces and tabs, leaving @minus{}@var{n} spaces before +point. @kindex M-SPC @findex cycle-spacing @@ -131,7 +134,14 @@ leaving @minus{}@var{n} spaces before point. The command @code{cycle-spacing} (@kbd{M-@key{SPC}}) acts like a more flexible version of @code{just-one-space}. It performs different space cleanup actions defined by @code{cycle-spacing-actions}, in a -cyclic manner, if you call it repeatedly in succession. +cyclic manner, if you call it repeatedly in succession. By default, +the first invocation does the same as @code{just-one-space}, the +second deletes all whitespace characters around point like +@code{delete-horizontal-space}, and the third restores the original +whitespace characters; then it cycles. If invoked with a prefix +argument, each action is given that value of the argument. The user +option @code{cycle-spacing-actions} can include other members; see the +doc string of that option for the details. @kbd{C-x C-o} (@code{delete-blank-lines}) deletes all blank lines after the current line. If the current line is blank, it deletes all From e2fec514fd22e61c2a4e9343056aa744e93203a1 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Mar 2024 14:49:28 +0100 Subject: [PATCH 099/155] ; * lisp/emacs-lisp/comp.el: Add a simple sanitizer usage example. --- lisp/emacs-lisp/comp.el | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7830597709..7e8d4e15e0a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3017,6 +3017,18 @@ These are substituted with a normal `set' op." ;; the variable tested by the conditional branch is of the predicted ;; value type and signal an error otherwise. +;;; Example: +;; Assuming we want to compile 'test.el' and test function `foo' defined +;; into it. + +;; Native compile 'test.el' instrumenting it for sanitizer usage. +;; (let ((comp-sanitizer-emit t)) +;; (load (native-compile "test.el"))) + +;; Run `foo' with the sanitizer active. +;; (let ((comp-sanitizer-active t)) +;; (foo)) + (defvar comp-sanitizer-emit nil "Gates the sanitizer pass. This is intended to be used only for development and verification of From ae9d8eedfdd6030a082010ac933b4aa4ddc05749 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 20 Mar 2024 16:08:15 +0200 Subject: [PATCH 100/155] ; Minor copyedits of last change. --- lisp/emacs-lisp/comp.el | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7e8d4e15e0a..1df1e3b3ddb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3010,24 +3010,25 @@ These are substituted with a normal `set' op." ;;; Sanitizer pass specific code. -;; This pass aims to verify compile time value type predictions during -;; execution. +;; This pass aims to verify compile-time value-type predictions during +;; execution of the code. ;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before -;; each conditional branch. 'helper_sanitizer_assert' will verify that +;; each conditional branch. 'helper_sanitizer_assert' will verify that ;; the variable tested by the conditional branch is of the predicted -;; value type and signal an error otherwise. +;; value type, or signal an error otherwise. ;;; Example: -;; Assuming we want to compile 'test.el' and test function `foo' defined -;; into it. -;; Native compile 'test.el' instrumenting it for sanitizer usage. -;; (let ((comp-sanitizer-emit t)) -;; (load (native-compile "test.el"))) +;; Assume we want to compile 'test.el' and test the function `foo' +;; defined in it. Then: -;; Run `foo' with the sanitizer active. -;; (let ((comp-sanitizer-active t)) -;; (foo)) +;; - Native-compile 'test.el' instrumenting it for sanitizer usage: +;; (let ((comp-sanitizer-emit t)) +;; (load (native-compile "test.el"))) + +;; - Run `foo' with the sanitizer active: +;; (let ((comp-sanitizer-active t)) +;; (foo)) (defvar comp-sanitizer-emit nil "Gates the sanitizer pass. From 0df28dc00edd0db343619d02aa41999a7bfce5fb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 20 Mar 2024 16:59:33 +0100 Subject: [PATCH 101/155] ; * lisp/emacs-lisp/comp-run.el (comp-run-async-workers): Fix indentation. --- lisp/emacs-lisp/comp-run.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 480f048777c..5cc61579030 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -233,8 +233,8 @@ display a message." "`comp-files-queue' should be \".el\" files: %s" source-file) when (or native-comp-always-compile - load ; Always compile when the compilation is - ; commanded for late load. + load ; Always compile when the compilation is + ; commanded for late load. ;; Skip compilation if `comp-el-to-eln-filename' fails ;; to find a writable directory. (with-demoted-errors "Async compilation :%S" From ad0492c5a97aaad7f784f7834772400d9af96b69 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Thu, 21 Mar 2024 14:23:40 +0800 Subject: [PATCH 102/155] Android compatibility fixes * doc/emacs/android.texi (Android Windowing): Document restrictions on number of windows under Android 4.4 and earlier. * java/AndroidManifest.xml.in : Assign each class of activity a unique task affinity. * java/org/gnu/emacs/EmacsDesktopNotification.java (display1): Remove redundant priority assignment. * java/org/gnu/emacs/EmacsOpenActivity.java (onCreate): Handle file URIs when processing attachments from a mailto URI, and check for KitKat before opening content ones. * java/org/gnu/emacs/EmacsWindow.java (figureChange): Replace coordinate HashMap with a SparseArray. * java/org/gnu/emacs/EmacsWindowAttachmentManager.java (registerWindow): Don't specify FLAG_ACTIVITY_NEW_DOCUMENT on systems where it is absent. --- doc/emacs/android.texi | 6 ++++ java/AndroidManifest.xml.in | 4 ++- .../gnu/emacs/EmacsDesktopNotification.java | 35 +++++++++---------- java/org/gnu/emacs/EmacsOpenActivity.java | 34 ++++++++++++++++-- java/org/gnu/emacs/EmacsWindow.java | 12 ++++--- .../emacs/EmacsWindowAttachmentManager.java | 9 +++-- 6 files changed, 70 insertions(+), 30 deletions(-) diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index 56bfa2591f6..b367515cb35 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -864,6 +864,12 @@ behalf of a specific frame, Emacs deletes the frame displayed within that window. @end itemize + When the system predates Android 5.0, the window manager will not +accept more than one user-created Emacs window. If frame creation gives +rise to windows in excess of this limit, the window manager will +arbitrarily select one of their number to display, with the rest +remaining invisible until that window is destroyed with its frame. + @cindex windowing limitations, android @cindex frame parameters, android Emacs only supports a limited subset of GUI features on Android; the diff --git a/java/AndroidManifest.xml.in b/java/AndroidManifest.xml.in index 4d23c752747..563914fb02c 100644 --- a/java/AndroidManifest.xml.in +++ b/java/AndroidManifest.xml.in @@ -218,6 +218,7 @@ along with GNU Emacs. If not, see . --> @@ -229,7 +230,7 @@ along with GNU Emacs. If not, see . --> @@ -273,6 +274,7 @@ along with GNU Emacs. If not, see . --> diff --git a/java/org/gnu/emacs/EmacsDesktopNotification.java b/java/org/gnu/emacs/EmacsDesktopNotification.java index c80aa21b4fe..72569631a8c 100644 --- a/java/org/gnu/emacs/EmacsDesktopNotification.java +++ b/java/org/gnu/emacs/EmacsDesktopNotification.java @@ -208,22 +208,6 @@ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) distinct categories, but permit an importance to be assigned to each individual notification. */ - switch (importance) - { - case 2: /* IMPORTANCE_LOW */ - default: - priority = Notification.PRIORITY_LOW; - break; - - case 3: /* IMPORTANCE_DEFAULT */ - priority = Notification.PRIORITY_DEFAULT; - break; - - case 4: /* IMPORTANCE_HIGH */ - priority = Notification.PRIORITY_HIGH; - break; - } - builder = new Notification.Builder (context); builder.setContentTitle (title); builder.setContentText (content); @@ -231,15 +215,28 @@ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.JELLY_BEAN) { + switch (importance) + { + case 2: /* IMPORTANCE_LOW */ + default: + priority = Notification.PRIORITY_LOW; + break; + + case 3: /* IMPORTANCE_DEFAULT */ + priority = Notification.PRIORITY_DEFAULT; + break; + + case 4: /* IMPORTANCE_HIGH */ + priority = Notification.PRIORITY_HIGH; + break; + } + builder.setPriority (priority); insertActions (context, builder); notification = builder.build (); } else notification = builder.getNotification (); - - if (Build.VERSION.SDK_INT > Build.VERSION_CODES.JELLY_BEAN) - notification.priority = priority; } else { diff --git a/java/org/gnu/emacs/EmacsOpenActivity.java b/java/org/gnu/emacs/EmacsOpenActivity.java index 2cdfa2ec776..327a53bc417 100644 --- a/java/org/gnu/emacs/EmacsOpenActivity.java +++ b/java/org/gnu/emacs/EmacsOpenActivity.java @@ -535,7 +535,9 @@ private class EmacsClientThread extends Thread uri = intent.getParcelableExtra (Intent.EXTRA_STREAM); if ((scheme = uri.getScheme ()) != null - && scheme.equals ("content")) + && scheme.equals ("content") + && (Build.VERSION.SDK_INT + >= Build.VERSION_CODES.KITKAT)) { tem1 = EmacsService.buildContentName (uri, resolver); attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\") @@ -543,6 +545,14 @@ private class EmacsClientThread extends Thread .replace ("$", "\\$")) + "\")"); } + else if (scheme != null && scheme.equals ("file")) + { + tem1 = uri.getPath (); + attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\") + .replace ("\"", "\\\"") + .replace ("$", "\\$")) + + "\")"); + } } else { @@ -567,7 +577,9 @@ private class EmacsClientThread extends Thread if (uri != null && (scheme = uri.getScheme ()) != null - && scheme.equals ("content")) + && scheme.equals ("content") + && (Build.VERSION.SDK_INT + >= Build.VERSION_CODES.KITKAT)) { tem1 = EmacsService.buildContentName (uri, resolver); @@ -577,6 +589,16 @@ private class EmacsClientThread extends Thread .replace ("$", "\\$")); builder.append ("\""); } + else if (scheme != null + && scheme.equals ("file")) + { + tem1 = uri.getPath (); + builder.append ("\""); + builder.append (tem1.replace ("\\", "\\\\") + .replace ("\"", "\\\"") + .replace ("$", "\\$")); + builder.append ("\""); + } } builder.append (")"); @@ -604,7 +626,13 @@ private class EmacsClientThread extends Thread { fileName = null; - if (scheme.equals ("content")) + if (scheme.equals ("content") + /* Retrieving the native file descriptor of a + ParcelFileDescriptor requires Honeycomb, and + proceeding without this capability is pointless on + systems before KitKat, since Emacs doesn't support + opening content files on those. */ + && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) { /* This is one of the annoying Android ``content'' URIs. Most of the time, there is actually an diff --git a/java/org/gnu/emacs/EmacsWindow.java b/java/org/gnu/emacs/EmacsWindow.java index 93a512cc7ef..2baede1d2d0 100644 --- a/java/org/gnu/emacs/EmacsWindow.java +++ b/java/org/gnu/emacs/EmacsWindow.java @@ -23,7 +23,6 @@ import java.util.ArrayList; import java.util.List; import java.util.ListIterator; -import java.util.HashMap; import java.util.LinkedHashMap; import java.util.Map; @@ -50,6 +49,7 @@ import android.view.ViewManager; import android.view.WindowManager; +import android.util.SparseArray; import android.util.Log; import android.os.Build; @@ -109,7 +109,7 @@ private static class Coordinate /* Map between pointer identifiers and last known position. Used to compute which pointer changed upon a touch event. */ - private HashMap pointerMap; + private SparseArray pointerMap; /* The window consumer currently attached, if it exists. */ private EmacsWindowAttachmentManager.WindowConsumer attached; @@ -166,7 +166,7 @@ private static class Coordinate super (handle); rect = new Rect (x, y, x + width, y + height); - pointerMap = new HashMap (); + pointerMap = new SparseArray (); /* Create the view from the context's UI thread. The window is unmapped, so the view is GONE. */ @@ -1001,7 +1001,8 @@ private static class Coordinate case MotionEvent.ACTION_CANCEL: /* Primary pointer released with index 0. */ pointerID = event.getPointerId (0); - coordinate = pointerMap.remove (pointerID); + coordinate = pointerMap.get (pointerID); + pointerMap.delete (pointerID); break; case MotionEvent.ACTION_POINTER_DOWN: @@ -1020,7 +1021,8 @@ private static class Coordinate /* Pointer removed. Remove it from the map. */ pointerIndex = event.getActionIndex (); pointerID = event.getPointerId (pointerIndex); - coordinate = pointerMap.remove (pointerID); + coordinate = pointerMap.get (pointerID); + pointerMap.delete (pointerID); break; default: diff --git a/java/org/gnu/emacs/EmacsWindowAttachmentManager.java b/java/org/gnu/emacs/EmacsWindowAttachmentManager.java index 18bdb6dbf60..aae4e2ee49b 100644 --- a/java/org/gnu/emacs/EmacsWindowAttachmentManager.java +++ b/java/org/gnu/emacs/EmacsWindowAttachmentManager.java @@ -124,10 +124,15 @@ public interface WindowConsumer intent = new Intent (EmacsService.SERVICE, EmacsMultitaskActivity.class); - intent.addFlags (Intent.FLAG_ACTIVITY_NEW_DOCUMENT - | Intent.FLAG_ACTIVITY_NEW_TASK + + intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK | Intent.FLAG_ACTIVITY_MULTIPLE_TASK); + /* Intent.FLAG_ACTIVITY_NEW_DOCUMENT is lamentably unavailable on + older systems than Lolipop. */ + if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP) + intent.addFlags (Intent.FLAG_ACTIVITY_NEW_DOCUMENT); + if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N) EmacsService.SERVICE.startActivity (intent); else From b3f04eb68499f285e05b5b74e9cbd67f3140fb3c Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Thu, 21 Mar 2024 02:13:28 -0500 Subject: [PATCH 103/155] Avoid recomputing the whole table in 'vtable--recompute-numerical' Each element of LINE being tested is a list, the first element of which is the value actually being represented in the table. Previously, the 'numberp' test would always fail, because it was being compared with the list rather than the intended value in it; that could cause the whole table to be recomputed, sometimes unnecessarily. * lisp/emacs-lisp/vtable.el (vtable--recompute-numerical): Test the car of ELEM, not ELEM itself, which is a list. (Bug#69927) --- lisp/emacs-lisp/vtable.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 15a430f5c26..5f7d3ae5210 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -743,7 +743,7 @@ If NEXT, do the next column." (seq-do-indexed (lambda (elem index) (when (and (vtable-column--numerical (elt columns index)) - (not (numberp elem))) + (not (numberp (car elem)))) (setq recompute t))) line) (when recompute From fa79de7c6b8883de4433572b2f6dc5b941f6ac66 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Thu, 21 Mar 2024 09:49:34 +0200 Subject: [PATCH 104/155] ; * lisp/calendar/calendar.el: Remove extra space. --- lisp/calendar/calendar.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index a13c2b7ca6d..422a6ceaa7a 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1973,7 +1973,7 @@ Gregorian date Sunday, December 31, 1 BC. This function does not handle dates in years BC." ;; For an explanation, see the footnote on page 384 of "Calendrical ;; Calculations, Part II: Three Historical Calendars" by - ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, + ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, ;; Software--Practice and Experience, Volume 23, Number 4 (April, ;; 1993), pages 383-404 ;; . From fe24a8c3c091c1e051fe6a8c1ec4fd30ca052ca7 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 21 Mar 2024 10:25:56 +0200 Subject: [PATCH 105/155] Speed up display of RTL text with many character compositions * src/bidi.c (bidi_level_start): New function. * src/dispextern.h (bidi_level_start): Add prototype. * src/xdisp.c (compute_stop_pos, set_iterator_to_next) (get_visually_first_element, next_element_from_buffer): Call 'bidi_level_start' when looking for composed characters backwards, to set limit of searching back, instead of looking all the way to BOB. (Bug#69385) --- src/bidi.c | 13 +++++++++++++ src/dispextern.h | 1 + src/xdisp.c | 20 +++++++++++--------- 3 files changed, 25 insertions(+), 9 deletions(-) diff --git a/src/bidi.c b/src/bidi.c index 36d1a0496b8..bdf60001781 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -754,6 +754,19 @@ bidi_cache_find_level_change (int level, int dir, bool before) return -1; } +/* Find the previous character position where LEVEL changes to a lower + one. Return -1 if not found (which really shouldn't happen if this + function is called on a backward scan). */ +ptrdiff_t +bidi_level_start (int level) +{ + ptrdiff_t slot = bidi_cache_find_level_change (level, -1, true); + + if (slot >= 0) + return bidi_cache[slot].charpos; + return -1; +} + static void bidi_cache_ensure_space (ptrdiff_t idx) { diff --git a/src/dispextern.h b/src/dispextern.h index 5387cb45603..1c3232fae3d 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3438,6 +3438,7 @@ extern void bidi_pop_it (struct bidi_it *); extern void *bidi_shelve_cache (void); extern void bidi_unshelve_cache (void *, bool); extern ptrdiff_t bidi_find_first_overridden (struct bidi_it *); +extern ptrdiff_t bidi_level_start (int); /* Defined in xdisp.c */ diff --git a/src/xdisp.c b/src/xdisp.c index d03769e2a31..140d71129f3 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -4353,7 +4353,7 @@ compute_stop_pos (struct it *it) an automatic composition, limit the search of composable characters to that position. */ if (it->bidi_p && it->bidi_it.scan_dir < 0) - stoppos = -1; + stoppos = bidi_level_start (it->bidi_it.resolved_level) - 1; else if (!STRINGP (it->string) && it->cmp_it.stop_pos <= IT_CHARPOS (*it) && cmp_limit_pos > 0) @@ -8712,9 +8712,8 @@ set_iterator_to_next (struct it *it, bool reseat_p) ptrdiff_t stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) - /* Now we are scanning backward and don't know - where to stop. */ - stop = -1; + /* Now we are scanning backward; figure out where to stop. */ + stop = bidi_level_start (it->bidi_it.resolved_level) - 1; composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it), IT_BYTEPOS (*it), stop, Qnil, true); } @@ -8745,7 +8744,7 @@ set_iterator_to_next (struct it *it, bool reseat_p) re-compute the stop position for composition. */ ptrdiff_t stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) - stop = -1; + stop = bidi_level_start (it->bidi_it.resolved_level) - 1; composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it), IT_BYTEPOS (*it), stop, Qnil, true); @@ -9190,7 +9189,9 @@ get_visually_first_element (struct it *it) bytepos = IT_BYTEPOS (*it); } if (it->bidi_it.scan_dir < 0) - stop = -1; + stop = STRINGP (it->string) + ? -1 + : bidi_level_start (it->bidi_it.resolved_level) - 1; composition_compute_stop_pos (&it->cmp_it, charpos, bytepos, stop, it->string, true); } @@ -9694,9 +9695,10 @@ next_element_from_buffer (struct it *it) && PT < it->end_charpos) ? PT : it->end_charpos; } else - stop = it->bidi_it.scan_dir < 0 ? -1 : it->end_charpos; - if (CHAR_COMPOSED_P (it, IT_CHARPOS (*it), IT_BYTEPOS (*it), - stop) + stop = it->bidi_it.scan_dir < 0 + ? bidi_level_start (it->bidi_it.resolved_level) - 1 + : it->end_charpos; + if (CHAR_COMPOSED_P (it, IT_CHARPOS (*it), IT_BYTEPOS (*it), stop) && next_element_from_composition (it)) { return true; From 759dedfab07a1c4db49c1291c9dde2aee648919d Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 21 Mar 2024 10:55:59 +0200 Subject: [PATCH 106/155] More accurate documentation of 'rmail-mail-new-frame' * doc/emacs/rmail.texi (Rmail Reply): More accurate documentation of the effects of 'rmail-mail-new-frame'. (Bug#69738) --- doc/emacs/rmail.texi | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/doc/emacs/rmail.texi b/doc/emacs/rmail.texi index 51bd6086ce0..f94708b08ac 100644 --- a/doc/emacs/rmail.texi +++ b/doc/emacs/rmail.texi @@ -875,7 +875,10 @@ already composing, or to alter a message you have sent. If you set the variable @code{rmail-mail-new-frame} to a non-@code{nil} value, then all the Rmail commands to start sending a message create a new frame to edit it in. This frame is deleted when -you send the message. +you send the message (but not if it is the only visible frame on the +current display, or if it's a text-mode frame). If this frame cannot +be deleted when you send the message, Emacs will try to reuse it for +composing subsequent messages. @ignore @c FIXME does not work with Message -> Kill Message , or when you use the @samp{Cancel} item in the @samp{Mail} menu. From 689f04a2ddfae856153bed762cc1461d66ec88de Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 17 Mar 2024 13:04:32 +0100 Subject: [PATCH 107/155] Clarify description of format-spec truncation * doc/lispref/strings.texi (Custom Format Strings): Mention that precision specifier affects both '<' and '>' truncation (bug#69822). * lisp/format-spec.el (format-spec, format-spec--do-flags): Use same terminology as 'format', especially when referring to its behavior. --- doc/lispref/strings.texi | 2 +- lisp/format-spec.el | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index a364fef3aab..eca69002779 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -1369,7 +1369,7 @@ given width and precision, if specified. @item > This flag causes the substitution to be truncated on the right to the -given width, if specified. +given width and precision, if specified. @item ^ This flag converts the substituted text to upper case (@pxref{Case diff --git a/lisp/format-spec.el b/lisp/format-spec.el index cf34017b994..73f9fccd793 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -38,7 +38,7 @@ For instance: (?l . \"ls\"))) Each %-spec may contain optional flag, width, and precision -modifiers, as follows: +specifiers, as follows: %character @@ -51,7 +51,7 @@ The following flags are allowed: * ^: Convert to upper case. * _: Convert to lower case. -The width and truncation modifiers behave like the corresponding +The width and precision specifiers behave like the corresponding ones in `format' when applied to %s. For example, \"%<010b\" means \"substitute into the output the @@ -145,7 +145,7 @@ is returned, where each format spec is its own element." "Return STR formatted according to FLAGS, WIDTH, and TRUNC. FLAGS is a list of keywords as returned by `format-spec--parse-flags'. WIDTH and TRUNC are either nil or -string widths corresponding to `format-spec' modifiers." +string widths corresponding to `format-spec' specifiers." (let (diff str-width) ;; Truncate original string first, like `format' does. (when trunc From 393f58c85aeb78f814866ccaad9ae7efd3fa6766 Mon Sep 17 00:00:00 2001 From: Adam Porter Date: Fri, 8 Mar 2024 23:43:14 -0600 Subject: [PATCH 108/155] 'vtable-update-object' can now be called with one argument It's often necessary to update the representation of a single object in a table (e.g a struct, whose identity does not change when its slots' values are changed). To do so, now the function may be called like this: (vtable-update-object table object) Instead of like this: (vtable-update-object table object object) This also documents the behavior of the just-discovered limitation filed as bug#69837. * lisp/emacs-lisp/vtable.el (vtable-update-object): Make 'old-object' argument optional. (Bug#69666) * doc/misc/vtable.texi (Interface Functions): Update documentation. * etc/NEWS: Add news entry. --- doc/misc/vtable.texi | 13 ++++++++++--- etc/NEWS | 9 +++++++++ lisp/emacs-lisp/vtable.el | 15 +++++++++++++-- 3 files changed, 32 insertions(+), 5 deletions(-) diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index a4f2ed29d93..dd5b70cf32f 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -554,12 +554,19 @@ the object after this object; otherwise append to @var{table}. This also updates the displayed table. @end defun -@defun vtable-update-object table object old-object -Change @var{old-object} into @var{object} in @var{table}. This also -updates the displayed table. +@defun vtable-update-object table object &optional old-object +Update @var{object}'s representation in @var{table}. Optional argument +@var{old-object}, if non-@code{nil}, means to replace @var{old-object} +with @var{object} and redisplay the associated row in the table. In +either case, if the existing object is not found in the table (being +compared with @code{equal}), signal an error. This has the same effect as calling @code{vtable-remove-object} and then @code{vtable-insert-object}, but is more efficient. + +Note a limitation: if the table's buffer is not in a visible window, or +if its window has changed width since it was updated, updating the table +is not possible, and an error is signaled. @end defun @defun vtable-column table index diff --git a/etc/NEWS b/etc/NEWS index 69e61d91b0e..ba0e4c80fa0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2197,6 +2197,15 @@ aforementioned functions: (and (arrayp executing-kbd-macro) (>= executing-kbd-macro-index (length executing-kbd-macro)))) ++++ +** 'vtable-update-object' updates an existing object with just two arguments. +It is now possible to update the representation of an object in a vtable +by calling 'vtable-update-object' with just the vtable and the object as +arguments. (Previously the 'old-object' argument was required which, in +this case, would mean repeating the object in the argument list.) When +replacing an object with a different one, passing both the new and old +objects is still necessary. + * Changes in Emacs 30.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 5f7d3ae5210..d8e5136c666 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -283,8 +283,16 @@ If it can't be found, return nil and don't move point." (goto-char (prop-match-beginning match)) (end-of-line))) -(defun vtable-update-object (table object old-object) - "Replace OLD-OBJECT in TABLE with OBJECT." +(defun vtable-update-object (table object &optional old-object) + "Update OBJECT's representation in TABLE. +If OLD-OBJECT is non-nil, replace OLD-OBJECT with OBJECT and display it. +In either case, if the existing object is not found in the table (being +compared with `equal'), signal an error. Note a limitation: if TABLE's +buffer is not in a visible window, or if its window has changed width +since it was updated, updating the TABLE is not possible, and an error +is signaled." + (unless old-object + (setq old-object object)) (let* ((objects (vtable-objects table)) (inhibit-read-only t)) ;; First replace the object in the object storage. @@ -300,6 +308,9 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... + ;; 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)))) From 51848e4731f3e32e5d152990bf570b08ca544a92 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 17 May 2023 15:28:46 +0200 Subject: [PATCH 109/155] * Fix missing `comp-files-queue' update (bug#63415). * lisp/emacs-lisp/comp.el (native--compile-async): Update `comp-files-queue' for real. --- lisp/emacs-lisp/comp.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 614c62c35c6..6b65a375ea0 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4229,8 +4229,9 @@ bytecode definition was not changed in the meantime)." ;; compilation, so update `comp-files-queue' to reflect that. (unless (or (null load) (eq load (cdr entry))) - (cl-substitute (cons file load) (car entry) comp-files-queue - :key #'car :test #'string=)) + (setf comp-files-queue + (cl-substitute (cons file load) (car entry) comp-files-queue + :key #'car :test #'string=))) (unless (native-compile-async-skip-p file load selector) (let* ((out-filename (comp-el-to-eln-filename file)) From 5a09cc111f052c120eddf0bcc98eeb1fd5435ae2 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Thu, 21 Mar 2024 20:45:25 +0800 Subject: [PATCH 110/155] ; * src/xterm.c (syms_of_xterm): Document x-*-keysym's default values. --- src/xterm.c | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/xterm.c b/src/xterm.c index b30a2485148..c0aef65ab66 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -32547,7 +32547,8 @@ Android does not support scroll bars at all. */); doc: /* Which modifer value Emacs reports when Ctrl is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the -Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed. */); +Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed, with nil or +any other value equivalent to `ctrl'. */); Vx_ctrl_keysym = Qnil; DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym, @@ -32555,14 +32556,16 @@ Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed. */); This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the Alt modifier (e.g. the keysym Alt_L or Alt_R, if the keyboard features a -dedicated key for Meta) depressed. */); +dedicated key for Meta) depressed, with nil or any other value +equivalent to `alt'. */); Vx_alt_keysym = Qnil; DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym, doc: /* Which modifer value Emacs reports when Hyper is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the -Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed. */); +Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed, with nil +or any other value equivalent to `hyper'. */); Vx_hyper_keysym = Qnil; DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym, @@ -32570,14 +32573,16 @@ Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed. */); This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the Meta modifier (e.g. the keysym Alt_L or Alt_R, when the keyboard does -not feature a dedicated key for Meta) depressed. */); +not feature a dedicated key for Meta) depressed, with nil or any other +value equivalent to `meta'. */); Vx_meta_keysym = Qnil; DEFVAR_LISP ("x-super-keysym", Vx_super_keysym, doc: /* Which modifer value Emacs reports when Super is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the -Super modifier (i.e. the keysym Super_L or Super_R) depressed. */); +Super modifier (i.e. the keysym Super_L or Super_R) depressed, with nil +or any other value equivalent to `super'. */); Vx_super_keysym = Qnil; DEFVAR_LISP ("x-wait-for-event-timeout", Vx_wait_for_event_timeout, From 3a902db97a99525b6f54100dc45a8cffcd3c5c8e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 11:38:12 -0400 Subject: [PATCH 111/155] (widget--allow-insertion): New macro * lisp/wid-edit.el (widget--allow-insertion): New macro. (widget-specify-insert, widget-insert, widget-setup) (widget-default-delete, widget-editable-list-insert-before) (widget-editable-list-delete-at): Use it. --- lisp/wid-edit.el | 156 +++++++++++++++++++++++------------------------ 1 file changed, 78 insertions(+), 78 deletions(-) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index cd06acd3f99..0645871f16d 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -510,14 +510,20 @@ With CHECK-AFTER non-nil, considers also the content after point, if needed." ;; indented it. (not (eq (following-char) ?\s)))))) -(defmacro widget-specify-insert (&rest form) - "Execute FORM without inheriting any text properties." - (declare (debug (body))) +(defmacro widget--allow-insertion (&rest forms) + "Run FORMS such that they can insert widgets in the current buffer." + (declare (debug t)) + `(let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ;; FIXME: Why? This is risky! + ,@forms)) + +(defmacro widget-specify-insert (&rest forms) + "Execute FORMS without inheriting any text properties." + (declare (debug t)) `(save-restriction - (let ((inhibit-read-only t) - (inhibit-modification-hooks t)) + (widget--allow-insertion (narrow-to-region (point) (point)) - (prog1 (progn ,@form) + (prog1 (progn ,@forms) (goto-char (point-max)))))) (defface widget-inactive @@ -954,9 +960,8 @@ The optional ARGS are additional keyword arguments." ;;;###autoload (defun widget-insert (&rest args) "Call `insert' with ARGS even if surrounding text is read only." - (let ((inhibit-read-only t) - (inhibit-modification-hooks t)) - (apply 'insert args))) + (widget--allow-insertion + (apply #'insert args))) (defun widget-convert-text (type from to &optional button-from button-to @@ -1376,19 +1381,18 @@ When not inside a field, signal an error." ;;;###autoload (defun widget-setup () "Setup current buffer so editing string widgets works." - (let ((inhibit-read-only t) - (inhibit-modification-hooks t) - field) - (while widget-field-new - (setq field (car widget-field-new) - widget-field-new (cdr widget-field-new) - widget-field-list (cons field widget-field-list)) - (let ((from (car (widget-get field :field-overlay))) - (to (cdr (widget-get field :field-overlay)))) - (widget-specify-field field - (marker-position from) (marker-position to)) - (set-marker from nil) - (set-marker to nil)))) + (widget--allow-insertion + (let (field) + (while widget-field-new + (setq field (car widget-field-new) + widget-field-new (cdr widget-field-new) + widget-field-list (cons field widget-field-list)) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil))))) (widget-clear-undo) (widget-add-change)) @@ -1773,24 +1777,23 @@ The value of the :type attribute should be an unconverted widget type." (inactive-overlay (widget-get widget :inactive)) (button-overlay (widget-get widget :button-overlay)) (sample-overlay (widget-get widget :sample-overlay)) - (doc-overlay (widget-get widget :doc-overlay)) - (inhibit-modification-hooks t) - (inhibit-read-only t)) - (widget-apply widget :value-delete) - (widget-children-value-delete widget) - (when inactive-overlay - (delete-overlay inactive-overlay)) - (when button-overlay - (delete-overlay button-overlay)) - (when sample-overlay - (delete-overlay sample-overlay)) - (when doc-overlay - (delete-overlay doc-overlay)) - (when (< from to) - ;; Kludge: this doesn't need to be true for empty formats. - (delete-region from to)) - (set-marker from nil) - (set-marker to nil)) + (doc-overlay (widget-get widget :doc-overlay))) + (widget--allow-insertion + (widget-apply widget :value-delete) + (widget-children-value-delete widget) + (when inactive-overlay + (delete-overlay inactive-overlay)) + (when button-overlay + (delete-overlay button-overlay)) + (when sample-overlay + (delete-overlay sample-overlay)) + (when doc-overlay + (delete-overlay doc-overlay)) + (when (< from to) + ;; Kludge: this doesn't need to be true for empty formats. + (delete-region from to)) + (set-marker from nil) + (set-marker to nil))) (widget-clear-undo)) (defun widget-default-value-set (widget value) @@ -2885,27 +2888,26 @@ The new widget gets inserted at the position of the BEFORE child." (last-deleted (when-let ((lst (widget-get widget :last-deleted))) (prog1 (pop lst) - (widget-put widget :last-deleted lst)))) - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (cond (before - (goto-char (widget-get before :entry-from))) - (t - (goto-char (widget-get widget :value-pos)))) - (let ((child (widget-editable-list-entry-create - widget (and last-deleted - (widget-apply last-deleted - :value-to-external - (widget-get last-deleted :value))) - last-deleted))) - (when (< (widget-get child :entry-from) (widget-get widget :from)) - (set-marker (widget-get widget :from) - (widget-get child :entry-from))) - (if (eq (car children) before) - (widget-put widget :children (cons child children)) - (while (not (eq (car (cdr children)) before)) - (setq children (cdr children))) - (setcdr children (cons child (cdr children))))))) + (widget-put widget :last-deleted lst))))) + (widget--allow-insertion + (cond (before + (goto-char (widget-get before :entry-from))) + (t + (goto-char (widget-get widget :value-pos)))) + (let ((child (widget-editable-list-entry-create + widget (and last-deleted + (widget-apply last-deleted + :value-to-external + (widget-get last-deleted :value))) + last-deleted))) + (when (< (widget-get child :entry-from) (widget-get widget :from)) + (set-marker (widget-get widget :from) + (widget-get child :entry-from))) + (if (eq (car children) before) + (widget-put widget :children (cons child children)) + (while (not (eq (car (cdr children)) before)) + (setq children (cdr children))) + (setcdr children (cons child (cdr children)))))))) (widget-setup) (widget-apply widget :notify widget)) @@ -2922,24 +2924,22 @@ Save CHILD into the :last-deleted list, so it can be inserted later." ;; Delete child from list of children. (save-excursion (let ((buttons (copy-sequence (widget-get widget :buttons))) - button - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (when (eq (widget-get button :widget) child) - (widget-put widget - :buttons (delq button (widget-get widget :buttons))) - (widget-delete button)))) + button) + (widget--allow-insertion + (while buttons + (setq button (car buttons) + buttons (cdr buttons)) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button))))) (let ((entry-from (widget-get child :entry-from)) - (entry-to (widget-get child :entry-to)) - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (widget-delete child) - (delete-region entry-from entry-to) - (set-marker entry-from nil) - (set-marker entry-to nil)) + (entry-to (widget-get child :entry-to))) + (widget--allow-insertion + (widget-delete child) + (delete-region entry-from entry-to) + (set-marker entry-from nil) + (set-marker entry-to nil))) (widget-put widget :children (delq child (widget-get widget :children)))) (widget-setup) (widget-apply widget :notify widget)) From 129bc91a2c9b7a6e314b4a5a4c60c266ca1cac0f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 12:08:02 -0400 Subject: [PATCH 112/155] wid-edit.el: Cosmetic changes * lisp/wid-edit.el: Use #' to quote function names. (widget--simplify-menu, widget-echo-help): Explicitly specify the lexenv to `eval`. (widget-choose, widget-get-sibling, widget-setup, widget-field-find) (widget-choice-action, widget-checklist-value-get) (widget-radio-value-create, widget-radio-value-set) (widget-radio-action, widget-editable-list-delete-at) (widget-group-value-create, widget-choice-prompt-value): Use `dolist`. (widget-convert): Hoist `(setq current` out of the ifs. (widget-convert): Hoist `(setq keys` out of the if. (widget-after-change): Hoist `(setq begin` out of the if. (widget-default-completions): Use `cond`. (widget-default-value-set): Hoist `goto-char` out of the if. (widget-choice-action): Hoist `nth` out of the if. (widget-checkbox-action): Hoist `widget-apply` out of the if. (widget-editable-list-value-create): Hoist `car` out of the if. (widget-editable-list-entry-create): Hoist `(setq child ...` out of the if. (widget-documentation-link-action): Fold `if` into `cond`. (widget-key-sequence-value-to-external): Use `key-parse`. (widget-plist-convert-option, widget-alist-convert-option): Hoist `(setq key-type` out of the if. --- lisp/wid-edit.el | 363 +++++++++++++++++++++-------------------------- 1 file changed, 159 insertions(+), 204 deletions(-) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 0645871f16d..f69a3d3b05f 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,4 +1,4 @@ -;;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*- +;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*- ;; ;; Copyright (C) 1996-1997, 1999-2024 Free Software Foundation, Inc. ;; @@ -247,10 +247,10 @@ to evaluate to nil for the menu item to be meaningful." (eq (car value) :radio)) (setq selected (cdr value)))) (setq plist (cddr plist))) - (when (and (eval visible) - (eval enable) + (when (and (eval visible t) + (eval enable t) (or (not selected) - (not (eval selected)))) + (not (eval selected t)))) (push (cons (nth 1 def) ev) simplified))))) extended) (reverse simplified))) @@ -317,7 +317,7 @@ in the key vector, as in the argument of `define-key'." (when (keymapp items) (setq items (widget--simplify-menu items))) ;; Read the choice of name from the minibuffer. - (setq items (cl-remove-if 'stringp items)) + (setq items (cl-remove-if #'stringp items)) (let ((val (completing-read (concat title ": ") items nil t))) (if (stringp val) (let ((try (try-completion val items))) @@ -330,12 +330,11 @@ in the key vector, as in the argument of `define-key'." ;; Construct a menu of the choices ;; and then use it for prompting for a single character. (let ((next-digit ?0) - alist choice some-choice-enabled value) + alist some-choice-enabled value) (with-current-buffer (get-buffer-create " widget-choose") (erase-buffer) (insert "Available choices:\n\n") - (while items - (setq choice (pop items)) + (dolist (choice items) (when (consp choice) (insert (format "%c = %s\n" next-digit (car choice))) (push (cons next-digit (cdr choice)) alist) @@ -665,12 +664,9 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil." (defun widget-get-sibling (widget) "Get the item WIDGET is assumed to toggle. This is only meaningful for radio buttons or checkboxes in a list." - (let* ((children (widget-get (widget-get widget :parent) :children)) - child) + (let* ((children (widget-get (widget-get widget :parent) :children))) (catch 'child - (while children - (setq child (car children) - children (cdr children)) + (dolist (child children) (when (eq (widget-get child :button) widget) (throw 'child child))) nil))) @@ -850,14 +846,14 @@ button is pressed or inactive, respectively. These are currently ignored." (defun widget-create (type &rest args) "Create widget of TYPE. The optional ARGS are additional keyword arguments." - (let ((widget (apply 'widget-convert type args))) + (let ((widget (apply #'widget-convert type args))) (widget-apply widget :create) widget)) (defun widget-create-child-and-convert (parent type &rest args) "As part of the widget PARENT, create a child widget TYPE. The child is converted, using the keyword arguments ARGS." - (let ((widget (apply 'widget-convert type args))) + (let ((widget (apply #'widget-convert type args))) (widget-put widget :parent parent) (unless (widget-get widget :indent) (widget-put widget :indent (+ (or (widget-get parent :indent) 0) @@ -911,18 +907,19 @@ The optional ARGS are additional keyword arguments." (keys args)) ;; First set the :args keyword. (while (cdr current) ;Look in the type. - (if (and (keywordp (cadr current)) - ;; If the last element is a keyword, - ;; it is still the :args element, - ;; even though it is a keyword. - (cddr current)) - (if (eq (cadr current) :args) - ;; If :args is explicitly specified, obey it. - (setq current nil) - ;; Some other irrelevant keyword. - (setq current (cdr (cdr current)))) - (setcdr current (list :args (cdr current))) - (setq current nil))) + (setq current + (if (and (keywordp (cadr current)) + ;; If the last element is a keyword, + ;; it is still the :args element, + ;; even though it is a keyword. + (cddr current)) + (if (eq (cadr current) :args) + ;; If :args is explicitly specified, obey it. + nil + ;; Some other irrelevant keyword. + (cdr (cdr current))) + (setcdr current (list :args (cdr current))) + nil))) (while (and args (not done)) ;Look in ARGS. (cond ((eq (car args) :args) ;; Handle explicit specification of :args. @@ -943,11 +940,9 @@ The optional ARGS are additional keyword arguments." ;; Finally set the keyword args. (while keys (let ((next (nth 0 keys))) - (if (keywordp next) - (progn - (widget-put widget next (nth 1 keys)) - (setq keys (nthcdr 2 keys))) - (setq keys nil)))) + (setq keys (when (keywordp next) + (widget-put widget next (nth 1 keys)) + (nthcdr 2 keys))))) ;; Convert the :value to internal format. (if (widget-member widget :value) (widget-put widget @@ -972,7 +967,7 @@ and TO will be used as the widgets end points. If optional arguments BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets button end points. Optional ARGS are extra keyword arguments for TYPE." - (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) + (let ((widget (apply #'widget-convert type :delete 'widget-leave-text args)) (from (copy-marker from)) (to (copy-marker to))) (set-marker-insertion-type from t) @@ -989,7 +984,7 @@ Optional ARGS are extra keyword arguments for TYPE. No text will be inserted to the buffer, instead the text between FROM and TO will be used as the widgets end points, as well as the widgets button end points." - (apply 'widget-convert-text type from to from to args)) + (apply #'widget-convert-text type from to from to args)) (defun widget-leave-text (widget) "Remove markers and overlays from WIDGET and its children." @@ -1007,7 +1002,7 @@ button end points." (delete-overlay doc)) (when field (delete-overlay field)) - (mapc 'widget-leave-text (widget-get widget :children)))) + (mapc #'widget-leave-text (widget-get widget :children)))) (defun widget-text (widget) "Get the text representation of the widget." @@ -1022,7 +1017,7 @@ button end points." ;; Custom-mode) which key-binding of widget-keymap one wants to refer to. ;; https://lists.gnu.org/r/emacs-devel/2008-11/msg00480.html (define-obsolete-function-alias 'advertised-widget-backward - 'widget-backward "23.2") + #'widget-backward "23.2") ;;;###autoload (defvar widget-keymap @@ -1048,13 +1043,13 @@ Note that such modes will need to require wid-edit.") (defvar widget-field-keymap (let ((map (copy-keymap widget-keymap))) - (define-key map "\C-k" 'widget-kill-line) - (define-key map "\M-\t" 'widget-complete) - (define-key map "\C-m" 'widget-field-activate) + (define-key map "\C-k" #'widget-kill-line) + (define-key map "\M-\t" #'widget-complete) + (define-key map "\C-m" #'widget-field-activate) ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. - ;; (define-key map "\C-a" 'widget-beginning-of-line) - (define-key map "\C-e" 'widget-end-of-line) + ;; (define-key map "\C-a" #'widget-beginning-of-line) + (define-key map "\C-e" #'widget-end-of-line) map) "Keymap used inside an editable field.") @@ -1062,8 +1057,8 @@ Note that such modes will need to require wid-edit.") (let ((map (copy-keymap widget-keymap))) ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. - ;; (define-key map "\C-a" 'widget-beginning-of-line) - (define-key map "\C-e" 'widget-end-of-line) + ;; (define-key map "\C-a" #'widget-beginning-of-line) + (define-key map "\C-e" #'widget-end-of-line) map) "Keymap used inside a text field.") @@ -1304,7 +1299,7 @@ With optional ARG, move across that many fields." ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. -(defalias 'widget-beginning-of-line 'beginning-of-line) +(defalias 'widget-beginning-of-line #'beginning-of-line) (defun widget-end-of-line () "Go to end of field or end of line, whichever is first. @@ -1382,17 +1377,14 @@ When not inside a field, signal an error." (defun widget-setup () "Setup current buffer so editing string widgets works." (widget--allow-insertion - (let (field) - (while widget-field-new - (setq field (car widget-field-new) - widget-field-new (cdr widget-field-new) - widget-field-list (cons field widget-field-list)) - (let ((from (car (widget-get field :field-overlay))) - (to (cdr (widget-get field :field-overlay)))) - (widget-specify-field field - (marker-position from) (marker-position to)) - (set-marker from nil) - (set-marker to nil))))) + (dolist (field widget-field-new) + (push field widget-field-list) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil)))) (widget-clear-undo) (widget-add-change)) @@ -1467,11 +1459,8 @@ When not inside a field, signal an error." (defun widget-field-find (pos) "Return the field at POS. Unlike (get-char-property POS \\='field), this works with empty fields too." - (let ((fields widget-field-list) - field found) - (while fields - (setq field (car fields) - fields (cdr fields)) + (let (found) + (dolist (field widget-field-list) (when (and (<= (widget-field-start field) pos) (<= pos (widget-field-end field))) (when found @@ -1486,11 +1475,11 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (let ((from-field (widget-field-find from)) (to-field (widget-field-find to))) (cond ((not (eq from-field to-field)) - (add-hook 'post-command-hook 'widget-add-change nil t) + (add-hook 'post-command-hook #'widget-add-change nil t) (signal 'text-read-only '("Change should be restricted to a single field"))) ((null from-field) - (add-hook 'post-command-hook 'widget-add-change nil t) + (add-hook 'post-command-hook #'widget-add-change nil t) (signal 'text-read-only '("Attempt to change text outside editable field"))) (widget-field-use-before-change @@ -1498,9 +1487,9 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." from-field (list 'before-change from to))))))) (defun widget-add-change () - (remove-hook 'post-command-hook 'widget-add-change t) - (add-hook 'before-change-functions 'widget-before-change nil t) - (add-hook 'after-change-functions 'widget-after-change nil t)) + (remove-hook 'post-command-hook #'widget-add-change t) + (add-hook 'before-change-functions #'widget-before-change nil t) + (add-hook 'after-change-functions #'widget-after-change nil t)) (defun widget-after-change (from to _old) "Adjust field size and text properties." @@ -1520,12 +1509,12 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (insert-char ?\s (- (+ begin size) end)))) ((> (- end begin) size) ;; Field too large and - (if (or (< (point) (+ begin size)) - (> (point) end)) - ;; Point is outside extra space. - (setq begin (+ begin size)) - ;; Point is within the extra space. - (setq begin (point))) + (setq begin (if (or (< (point) (+ begin size)) + (> (point) end)) + ;; Point is outside extra space. + (+ begin size) + ;; Point is within the extra space. + (point))) (save-excursion (goto-char end) (while (and (eq (preceding-char) ?\s) @@ -1545,9 +1534,9 @@ Optional EVENT is the event that triggered the action." (defun widget-children-value-delete (widget) "Delete all :children and :buttons in WIDGET." - (mapc 'widget-delete (widget-get widget :children)) + (mapc #'widget-delete (widget-get widget :children)) (widget-put widget :children nil) - (mapc 'widget-delete (widget-get widget :buttons)) + (mapc #'widget-delete (widget-get widget :buttons)) (widget-put widget :buttons nil)) (defun widget-children-validate (widget) @@ -1598,13 +1587,13 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-types-copy (widget) "Copy :args as widget types in WIDGET." - (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args))) + (widget-put widget :args (mapcar #'widget-copy (widget-get widget :args))) widget) ;; Made defsubst to speed up face editor creation. (defsubst widget-types-convert-widget (widget) "Convert :args as widget types in WIDGET." - (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) + (widget-put widget :args (mapcar #'widget-convert (widget-get widget :args))) widget) (defun widget-value-convert-widget (widget) @@ -1659,17 +1648,18 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-default-completions (widget) "Return completion data, like `completion-at-point-functions' would." (let ((completions (widget-get widget :completions))) - (if completions - (list (widget-field-start widget) - (max (point) (widget-field-text-end widget)) - completions) - (if (widget-get widget :complete) - (lambda () (widget-apply widget :complete)) - (if (widget-get widget :complete-function) - (lambda () - (let ((widget--completing-widget widget)) - (call-interactively - (widget-get widget :complete-function))))))))) + (cond + (completions + (list (widget-field-start widget) + (max (point) (widget-field-text-end widget)) + completions)) + ((widget-get widget :complete) + (lambda () (widget-apply widget :complete))) + ((widget-get widget :complete-function) + (lambda () + (let ((widget--completing-widget widget)) + (call-interactively + (widget-get widget :complete-function)))))))) (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." @@ -1814,9 +1804,9 @@ The value of the :type attribute should be an unconverted widget type." (widget-put widget :value value) (widget-apply widget :create)) (if offset - (if (< offset 0) - (goto-char (+ (widget-get widget :to) offset 1)) - (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) + (goto-char (if (< offset 0) + (+ (widget-get widget :to) offset 1) + (min (+ from offset) (1- (widget-get widget :to)))))))) (defun widget-default-value-inline (widget) "Wrap value in a list unless it is inline." @@ -1979,8 +1969,8 @@ as the argument to `documentation-property'." ;; Only bind mouse-2, since mouse-1 will be translated accordingly to ;; the customization of `mouse-1-click-follows-link'. (define-key map [down-mouse-1] (lookup-key widget-global-map [down-mouse-1])) - (define-key map [down-mouse-2] 'widget-button-click) - (define-key map [mouse-2] 'widget-button-click) + (define-key map [down-mouse-2] #'widget-button-click) + (define-key map [mouse-2] #'widget-button-click) map) "Keymap used inside a link widget.") @@ -2328,13 +2318,10 @@ when he invoked the menu." ((and widget-choice-toggle (= (length args) 2) (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) + (nth (if (eq old (nth 0 args)) 1 0) + args)) (t - (while args - (setq current (car args) - args (cdr args)) + (dolist (current args) (setq choices (cons (cons (widget-apply current :menu-tag-get) current) @@ -2427,9 +2414,8 @@ when he invoked the menu." (widget-toggle-action widget event) (let ((sibling (widget-get-sibling widget))) (when sibling - (if (widget-value widget) - (widget-apply sibling :activate) - (widget-apply sibling :deactivate)) + (widget-apply sibling + (if (widget-value widget) :activate :deactivate)) (widget-clear-undo)))) ;;; The `checklist' Widget. @@ -2478,7 +2464,7 @@ If the item is checked, CHOSEN is a cons whose cdr is the value." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert + (setq button (apply #'widget-create-child-and-convert widget 'checkbox :value (not (null chosen)) button-args))) @@ -2558,11 +2544,8 @@ Return an alist of (TYPE MATCH)." (defun widget-checklist-value-get (widget) ;; The values of all selected items. - (let ((children (widget-get widget :children)) - child result) - (while children - (setq child (car children) - children (cdr children)) + (let (result) + (dolist (child (widget-get widget :children)) (if (widget-value (widget-get child :button)) (setq result (append result (widget-apply child :value-inline))))) result)) @@ -2630,12 +2613,8 @@ Return an alist of (TYPE MATCH)." (defun widget-radio-value-create (widget) ;; Insert all values - (let ((args (widget-get widget :args)) - arg) - (while args - (setq arg (car args) - args (cdr args)) - (widget-radio-add-item widget arg)))) + (dolist (arg (widget-get widget :args)) + (widget-radio-add-item widget arg))) (defun widget-radio-add-item (widget type) "Add to radio widget WIDGET a new radio button item of type TYPE." @@ -2662,7 +2641,7 @@ Return an alist of (TYPE MATCH)." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert + (setq button (apply #'widget-create-child-and-convert widget 'radio-button :value (not (null chosen)) button-args))) @@ -2718,11 +2697,8 @@ Return an alist of (TYPE MATCH)." ;; We can't just delete and recreate a radio widget, since children ;; can be added after the original creation and won't be recreated ;; by `:create'. - (let ((children (widget-get widget :children)) - current found) - (while children - (setq current (car children) - children (cdr children)) + (let (found) + (dolist (current (widget-get widget :children)) (let* ((button (widget-get current :button)) (match (and (not found) (widget-apply current :match value)))) @@ -2749,13 +2725,9 @@ Return an alist of (TYPE MATCH)." (defun widget-radio-action (widget child event) ;; Check if a radio button was pressed. - (let ((children (widget-get widget :children)) - (buttons (widget-get widget :buttons)) - current) + (let ((buttons (widget-get widget :buttons))) (when (memq child buttons) - (while children - (setq current (car children) - children (cdr children)) + (dolist (current (widget-get widget :children)) (let* ((button (widget-get current :button))) (cond ((eq child button) (widget-value-set button t) @@ -2825,7 +2797,7 @@ Return an alist of (TYPE MATCH)." (and (widget--should-indent-p) (widget-get widget :indent) (insert-char ?\s (widget-get widget :indent))) - (apply 'widget-create-child-and-convert + (apply #'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) (t @@ -2845,9 +2817,9 @@ Return an alist of (TYPE MATCH)." (if answer (setq children (cons (widget-editable-list-entry-create widget - (if (widget-inline-p type t) - (car answer) - (car (car answer))) + (car (if (widget-inline-p type t) + answer + (car answer))) t) children) value (cdr answer)) @@ -2856,8 +2828,8 @@ Return an alist of (TYPE MATCH)." (defun widget-editable-list-value-get (widget) ;; Get value of the child widget. - (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) - (widget-get widget :children)))) + (apply #'append (mapcar (lambda (child) (widget-apply child :value-inline)) + (widget-get widget :children)))) (defun widget-editable-list-match (widget value) ;; Value must be a list and all the members must match the type. @@ -2923,16 +2895,12 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (widget-put widget :last-deleted lst)) ;; Delete child from list of children. (save-excursion - (let ((buttons (copy-sequence (widget-get widget :buttons))) - button) - (widget--allow-insertion - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (when (eq (widget-get button :widget) child) - (widget-put widget - :buttons (delq button (widget-get widget :buttons))) - (widget-delete button))))) + (widget--allow-insertion + (dolist (button (copy-sequence (widget-get widget :buttons))) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button)))) (let ((entry-from (widget-get child :entry-from)) (entry-to (widget-get child :entry-to))) (widget--allow-insertion @@ -2962,19 +2930,17 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?i) - (setq insert (apply 'widget-create-child-and-convert + (setq insert (apply #'widget-create-child-and-convert widget 'insert-button (widget-get widget :insert-button-args)))) ((eq escape ?d) - (setq delete (apply 'widget-create-child-and-convert + (setq delete (apply #'widget-create-child-and-convert widget 'delete-button (widget-get widget :delete-button-args)))) ((eq escape ?v) - (if conv - (setq child (widget-create-child-value - widget type value)) - (setq child (widget-create-child-value - widget type (widget-default-get type))))) + (setq child (widget-create-child-value + widget type + (if conv value (widget-default-get type))))) (t (error "Unknown escape `%c'" escape))))) (let ((buttons (widget-get widget :buttons))) @@ -3014,13 +2980,10 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (defun widget-group-value-create (widget) ;; Create each component. - (let ((args (widget-get widget :args)) - (value (widget-get widget :value)) - arg answer children) - (while args - (setq arg (car args) - args (cdr args) - answer (widget-match-inline arg value) + (let ((value (widget-get widget :value)) + answer children) + (dolist (arg (widget-get widget :args)) + (setq answer (widget-match-inline arg value) value (cdr answer)) (and (widget--should-indent-p) (widget-get widget :indent) @@ -3036,7 +2999,7 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (defun widget-group-default-get (widget) ;; Get the default of the components. - (mapcar 'widget-default-get (widget-get widget :args))) + (mapcar #'widget-default-get (widget-get widget :args))) (defun widget-group-match (widget vals) ;; Match if the components match. @@ -3094,20 +3057,20 @@ The following properties have special meanings for this widget: "Display documentation for WIDGET's value. Ignore optional argument EVENT." (let* ((string (widget-get widget :value)) (symbol (intern string))) - (if (and (fboundp symbol) (boundp symbol)) - ;; If there are two doc strings, give the user a way to pick one. - (apropos (concat "\\`" (regexp-quote string) "\\'")) - (cond - ((fboundp symbol) - (describe-function symbol)) - ((facep symbol) - (describe-face symbol)) - ((featurep symbol) - (describe-package symbol)) - ((or (boundp symbol) (get symbol 'variable-documentation)) - (describe-variable symbol)) - (t - (message "No documentation available for %s" symbol)))))) + (cond + ((and (fboundp symbol) (boundp symbol)) + ;; If there are two doc strings, give the user a way to pick one. + (apropos (concat "\\`" (regexp-quote string) "\\'"))) + ((fboundp symbol) + (describe-function symbol)) + ((facep symbol) + (describe-face symbol)) + ((featurep symbol) + (describe-package symbol)) + ((or (boundp symbol) (get symbol 'variable-documentation)) + (describe-variable symbol)) + (t + (message "No documentation available for %s" symbol))))) (defcustom widget-documentation-links t "Add hyperlinks to documentation strings when non-nil." @@ -3240,7 +3203,7 @@ Optional ARGS specifies additional keyword arguments for the (unless (or (numberp doc-indent) (null doc-indent)) (setq doc-indent 0)) (widget-put widget :buttons - (cons (apply 'widget-create-child-and-convert + (cons (apply #'widget-create-child-and-convert widget 'documentation-string :indent doc-indent (nconc args (list doc))) @@ -3352,18 +3315,18 @@ It reads a file name from an editable text field." (must-match (widget-get widget :must-match))) (read-file-name (format-prompt prompt value) dir nil must-match file))))) -;;;(defun widget-file-action (widget &optional event) -;;; ;; Read a file name from the minibuffer. -;;; (let* ((value (widget-value widget)) -;;; (dir (file-name-directory value)) -;;; (file (file-name-nondirectory value)) -;;; (menu-tag (widget-apply widget :menu-tag-get)) -;;; (must-match (widget-get widget :must-match)) -;;; (answer (read-file-name (format-prompt menu-tag value) -;;; dir nil must-match file))) -;;; (widget-value-set widget (abbreviate-file-name answer)) -;;; (widget-setup) -;;; (widget-apply widget :notify widget event))) +;;(defun widget-file-action (widget &optional event) +;; ;; Read a file name from the minibuffer. +;; (let* ((value (widget-value widget)) +;; (dir (file-name-directory value)) +;; (file (file-name-nondirectory value)) +;; (menu-tag (widget-apply widget :menu-tag-get)) +;; (must-match (widget-get widget :must-match)) +;; (answer (read-file-name (format-prompt menu-tag value) +;; dir nil must-match file))) +;; (widget-value-set widget (abbreviate-file-name answer)) +;; (widget-setup) +;; (widget-apply widget :notify widget event))) ;; Fixme: use file-name-as-directory. (define-widget 'directory 'file @@ -3552,7 +3515,7 @@ It reads a directory name from an editable text field." (if (stringp value) (if (string-match "\\`[[:space:]]*\\'" value) widget-key-sequence-default-value - (read-kbd-macro value)) + (key-parse value)) value)) @@ -3825,7 +3788,7 @@ or a list with the default value of each component of the list WIDGET." :format "%{%t%}:\n%v" :match 'widget-vector-match :value-to-internal (lambda (_widget value) (append value nil)) - :value-to-external (lambda (_widget value) (apply 'vector value))) + :value-to-external (lambda (_widget value) (apply #'vector value))) (defun widget-vector-match (widget value) (and (vectorp value) @@ -3840,7 +3803,7 @@ or a list with the default value of each component of the list WIDGET." :value-to-internal (lambda (_widget value) (list (car value) (cdr value))) :value-to-external (lambda (_widget value) - (apply 'cons value))) + (apply #'cons value))) (defun widget-cons-match (widget value) (and (consp value) @@ -3927,7 +3890,7 @@ example: (args (if options (list `(checklist :inline t :greedy t - ,@(mapcar 'widget-plist-convert-option + ,@(mapcar #'widget-plist-convert-option options)) other) (list other)))) @@ -3940,9 +3903,7 @@ example: (if (listp option) (let ((key (nth 0 option))) (setq value-type (nth 1 option)) - (if (listp key) - (setq key-type key) - (setq key-type `(const ,key)))) + (setq key-type (if (listp key) key `(const ,key)))) (setq key-type `(const ,option) value-type widget-plist-value-type)) `(group :format "Key: %v" :inline t ,key-type ,value-type))) @@ -3972,7 +3933,7 @@ example: (args (if options (list `(checklist :inline t :greedy t - ,@(mapcar 'widget-alist-convert-option + ,@(mapcar #'widget-alist-convert-option options)) other) (list other)))) @@ -3985,9 +3946,7 @@ example: (if (listp option) (let ((key (nth 0 option))) (setq value-type (nth 1 option)) - (if (listp key) - (setq key-type key) - (setq key-type `(const ,key)))) + (setq key-type (if (listp key) key `(const ,key)))) (setq key-type `(const ,option) value-type widget-alist-value-type)) `(cons :format "Key: %v" ,key-type ,value-type))) @@ -4045,17 +4004,13 @@ current choice is inline." ((and widget-choice-toggle (= (length args) 2) (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) + (nth (if (eq old (nth 0 args)) 1 0) + args)) (t - (while args - (setq current (car args) - args (cdr args)) - (setq choices - (cons (cons (widget-apply current :menu-tag-get) - current) - choices))) + (dolist (current args) + (push (cons (widget-apply current :menu-tag-get) + current) + choices)) (let ((val (completing-read prompt choices nil t))) (if (stringp val) (let ((try (try-completion val choices))) @@ -4206,7 +4161,7 @@ is inline." (help-echo (and widget (widget-get widget :help-echo)))) (if (functionp help-echo) (setq help-echo (funcall help-echo widget))) - (if help-echo (message "%s" (eval help-echo))))) + (if help-echo (message "%s" (eval help-echo t))))) (define-obsolete-function-alias 'widget-sublist #'seq-subseq "28.1") (define-obsolete-function-alias 'widget-visibility-value-create From e819413e24d81875abaf81c281115e695ad5cc28 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 12:28:54 -0400 Subject: [PATCH 113/155] Speed up `describe-char` when a property has a large value Doing `C-u C-x =` on a buffer position where the overlay/text properties hold large values (e.g. inside the profiler report) can be surprisingly slow because it pretty prints all those properties. Change the code to do the pretty printing more lazily. While at it, share that duplicated code between `descr-text.el` and `wid-browse.el`. * lisp/emacs-lisp/pp.el (pp-insert-short-sexp): New function. * lisp/descr-text.el (describe-text-sexp): Delete function. (describe-property-list): Use `pp-insert-short-sexp` instead. * lisp/wid-browse.el (widget-browse-sexp): Use `pp-insert-short-sexp` and `widget--allow-insertion`. --- lisp/descr-text.el | 52 ++++++++++++++----------------------------- lisp/emacs-lisp/pp.el | 17 ++++++++++++++ lisp/wid-browse.el | 34 +++++++++------------------- 3 files changed, 44 insertions(+), 59 deletions(-) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index eeab995c37d..524a6474cd4 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -42,26 +42,6 @@ (insert-text-button "(widget)Top" 'type 'help-info 'help-args '("(widget)Top"))) -(defun describe-text-sexp (sexp) - "Insert a short description of SEXP in the current buffer." - (let ((pp (condition-case signal - (pp-to-string sexp) - (error (prin1-to-string signal))))) - (when (string-match-p "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - - (if (and (not (string-search "\n" pp)) - (<= (length pp) (- (window-width) (current-column)))) - (insert pp) - (insert-text-button - "[Show]" - 'follow-link t - 'action (lambda (&rest _ignore) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ pp))) - 'help-echo "mouse-2, RET: pretty print value in another buffer")))) - (defun describe-property-list (properties) "Insert a description of PROPERTIES in the current buffer. PROPERTIES should be a list of overlay or text properties. @@ -92,7 +72,9 @@ into help buttons that call `describe-text-category' or (format "%S" value) 'type 'help-face 'help-args (list value))) (t - (describe-text-sexp value)))) + (require 'pp) + (declare-function pp-insert-short-sexp "pp" (sexp &optional width)) + (pp-insert-short-sexp value)))) (insert "\n"))) ;;; Describe-Text Commands. @@ -522,24 +504,24 @@ The character information includes: (setcar composition (concat " with the surrounding characters \"" - (mapconcat 'describe-char-padded-string - (buffer-substring from pos) "") + (mapconcat #'describe-char-padded-string + (buffer-substring from pos)) "\" and \"" - (mapconcat 'describe-char-padded-string - (buffer-substring (1+ pos) to) "") + (mapconcat #'describe-char-padded-string + (buffer-substring (1+ pos) to)) "\"")) (setcar composition (concat " with the preceding character(s) \"" - (mapconcat 'describe-char-padded-string - (buffer-substring from pos) "") + (mapconcat #'describe-char-padded-string + (buffer-substring from pos)) "\""))) (if (< (1+ pos) to) (setcar composition (concat " with the following character(s) \"" - (mapconcat 'describe-char-padded-string - (buffer-substring (1+ pos) to) "") + (mapconcat #'describe-char-padded-string + (buffer-substring (1+ pos) to)) "\"")) (setcar composition nil))) (setcar (cdr composition) @@ -568,7 +550,7 @@ The character information includes: ("character" ,(format "%s (displayed as %s) (codepoint %d, #o%o, #x%x)" char-description - (apply 'propertize char-description + (apply #'propertize char-description (text-properties-at pos)) char char char)) ("charset" @@ -620,7 +602,7 @@ The character information includes: (if (consp key-list) (list "type" (concat "\"" - (mapconcat 'identity + (mapconcat #'identity key-list "\" or \"") "\"") "with" @@ -721,7 +703,7 @@ The character information includes: (let ((unicodedata (describe-char-unicode-data char))) (if unicodedata (cons (list "Unicode data" "") unicodedata)))))) - (setq max-width (apply 'max (mapcar (lambda (x) + (setq max-width (apply #'max (mapcar (lambda (x) (if (cadr x) (length (car x)) 0)) item-list))) (set-buffer src-buf) @@ -736,7 +718,7 @@ The character information includes: (dolist (clm (cdr elt)) (cond ((eq (car-safe clm) 'insert-text-button) (insert " ") - (eval clm)) + (eval clm t)) ((not (zerop (length clm))) (insert " " clm)))) (insert "\n")))) @@ -855,7 +837,7 @@ The character information includes: (insert "\n") (dolist (elt (cond ((eq describe-char-unidata-list t) - (nreverse (mapcar 'car char-code-property-alist))) + (nreverse (mapcar #'car char-code-property-alist))) ((< char 32) ;; Temporary fix (2016-05-22): The ;; decomposition item for \n corrupts the @@ -898,7 +880,7 @@ characters." (setq width (- width (length (car last)) 1))) (let ((ellipsis (and (cdr last) "..."))) (setcdr last nil) - (concat (mapconcat 'identity words " ") ellipsis))) + (concat (mapconcat #'identity words " ") ellipsis))) ""))) (defun describe-char-eldoc--format (ch &optional width) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 569f70ca604..de7468b3e38 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -346,6 +346,23 @@ after OUT-BUFFER-NAME." (setq buffer-read-only nil) (setq-local font-lock-verbose nil))))) +(defun pp-insert-short-sexp (sexp &optional width) + "Insert a short description of SEXP in the current buffer. +WIDTH is the maximum width to use for it and it defaults to the +space available between point and the window margin." + (let ((printed (format "%S" sexp))) + (if (and (not (string-search "\n" printed)) + (<= (string-width printed) + (or width (- (window-width) (current-column))))) + (insert printed) + (insert-text-button + "[Show]" + 'follow-link t + 'action (lambda (&rest _ignore) + ;; FIXME: Why "eval output"? + (pp-display-expression sexp "*Pp Eval Output*")) + 'help-echo "mouse-2, RET: pretty print value in another buffer")))) + ;;;###autoload (defun pp-eval-expression (expression) "Evaluate EXPRESSION and pretty-print its value. diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index bb56f3f62fb..d4000187bd1 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -141,7 +141,7 @@ The following commands are available: (setq key (nth 0 items) value (nth 1 items) printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) + #'widget-browse-sexp) items (cdr (cdr items))) (widget-insert "\n" (symbol-name key) "\n\t") (funcall printer widget key value) @@ -204,24 +204,10 @@ VALUE is assumed to be a list of widgets." (defun widget-browse-sexp (_widget _key value) "Insert description of WIDGET's KEY VALUE. Nothing is assumed about value." - (let ((pp (condition-case signal - (pp-to-string value) - (error (prin1-to-string signal))))) - (when (string-match "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - (if (cond ((string-search "\n" pp) - nil) - ((> (length pp) (- (window-width) (current-column))) - nil) - (t t)) - (widget-insert pp) - (widget-create 'push-button - :tag "show" - :action (lambda (widget &optional _event) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ (widget-get widget :value)))) - pp)))) + (require 'pp) + (declare-function pp-insert-short-sexp "pp" (sexp &optional width)) + (widget--allow-insertion + (pp-insert-short-sexp value))) (defun widget-browse-sexps (widget key value) "Insert description of WIDGET's KEY VALUE. @@ -235,11 +221,11 @@ VALUE is assumed to be a list of widgets." ;;; Keyword Printers. -(put :parent 'widget-keyword-printer 'widget-browse-widget) -(put :children 'widget-keyword-printer 'widget-browse-widgets) -(put :buttons 'widget-keyword-printer 'widget-browse-widgets) -(put :button 'widget-keyword-printer 'widget-browse-widget) -(put :args 'widget-keyword-printer 'widget-browse-sexps) +(put :parent 'widget-keyword-printer #'widget-browse-widget) +(put :children 'widget-keyword-printer #'widget-browse-widgets) +(put :buttons 'widget-keyword-printer #'widget-browse-widgets) +(put :button 'widget-keyword-printer #'widget-browse-widget) +(put :args 'widget-keyword-printer #'widget-browse-sexps) ;;; Widget Minor Mode. From afb7a23e7b914b4c3b72172ae86a5f7e63f2cfde Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 21 Mar 2024 21:35:24 +0200 Subject: [PATCH 114/155] ; Improve documentation of 'backup-by-copying' * doc/emacs/files.texi (Backup Copying): Recommend 'backup-by-copying' for files on file-hosting services. (Bug#69930) --- doc/emacs/files.texi | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 971483a6e4c..d074a55b762 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -779,6 +779,12 @@ operations typically break hard links, disconnecting the file name you visited from any alternate names for the same file. This has nothing to do with Emacs---the version control system does it. + Some file storage services support @dfn{file versioning}: they +record history of previous versions of files, and allow reverting to +those previous versions. If you want to be able to do that with files +hosted by those services when editing them with Emacs, customize +@code{backup-by-copying} to a non-@code{nil} value. + @node Customize Save @subsection Customizing Saving of Files From e95a8622263d8182e80777f87b7ca52cedbd1b28 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 21 Mar 2024 22:12:40 +0200 Subject: [PATCH 115/155] ; * lisp/keymap.el (key-parse): Fix processing of "[TAB]". (Bug#69893) --- lisp/keymap.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/keymap.el b/lisp/keymap.el index 065c59da74c..4bdf65d39fa 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -260,7 +260,7 @@ returned by \\[describe-key] (`describe-key')." (setq word (concat (match-string 1 word) (match-string 3 word))) (not (string-match - "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" + "\\<\\(NUL\\|RET\\|LFD\\|TAB\\|ESC\\|SPC\\|DEL\\)$" word)))) (setq key (list (intern word)))) ((or (equal word "REM") (string-match "^;;" word)) From 05b8de54e30fdfccda78c5cfc2481828b897614b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 18:16:41 -0400 Subject: [PATCH 116/155] byte-opt.el: Remove test that's not applicable any more * lisp/emacs-lisp/byte-opt.el: Remove left-over test for ancient byte-compiled representation. --- lisp/emacs-lisp/byte-opt.el | 1 - 1 file changed, 1 deletion(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f75be3f71ad..f6df40a2d9b 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -3116,7 +3116,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; (eval-when-compile (or (compiled-function-p (symbol-function 'byte-optimize-form)) - (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) (mapc (lambda (x) From 2000d6e0f27f9f34f343016f4aa93e09c29c8695 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 18:27:03 -0400 Subject: [PATCH 117/155] (describe-symbol-backends): Fix addition of the "type" backend That backend was added from `cl-extra.el` with no autoload, so (describe-symbol `advice) failed to show the info about the `advice` type unless `cl-extra.el` had been loaded beforehand. `C-h o RET advice RET` worked by accident because the completion table uses `cl-some` which is autoloaded from `cl-extra.el`. * lisp/help-mode.el (describe-symbol-backends): Add the "type" backend. * lisp/emacs-lisp/cl-extra.el (describe-symbol-backends): Don't add the "type" backend here. --- lisp/emacs-lisp/cl-extra.el | 7 ------- lisp/help-mode.el | 3 +++ 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index c8eaca9a77c..d43c21d3eb9 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -711,13 +711,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. (require 'help-mode) -;; FIXME: We could go crazy and add another entry so describe-symbol can be -;; used with the slot names of CL structs (and/or EIEIO objects). -(add-to-list 'describe-symbol-backends - `(nil ,#'cl-find-class ,#'cl-describe-type) - ;; Document the `cons` function before the `cons` type. - t) - (defconst cl--typedef-regexp (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" "cl-deftype" "deftype")) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index f9ec8a5cc2b..dd78342ace7 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -545,6 +545,9 @@ it does not already exist." (or (and (boundp symbol) (not (keywordp symbol))) (get symbol 'variable-documentation))) ,#'describe-variable) + ;; FIXME: We could go crazy and add another entry so describe-symbol can be + ;; used with the slot names of CL structs (and/or EIEIO objects). + ("type" ,#'cl-find-class ,#'cl-describe-type) ("face" ,#'facep ,(lambda (s _b _f) (describe-face s)))) "List of providers of information about symbols. Each element has the form (NAME TESTFUN DESCFUN) where: From c214fc9626c8b37e4d155a6d3caebe2e09fd0ab2 Mon Sep 17 00:00:00 2001 From: Jonas Bernoulli Date: Thu, 21 Mar 2024 23:55:38 +0100 Subject: [PATCH 118/155] Update to Transient v0.6.0-1-gcaef3347 --- doc/misc/transient.texi | 28 ++-- lisp/transient.el | 279 ++++++++++++++++++++++++++-------------- 2 files changed, 202 insertions(+), 105 deletions(-) diff --git a/doc/misc/transient.texi b/doc/misc/transient.texi index f76edc6b1e4..3a6486903bf 100644 --- a/doc/misc/transient.texi +++ b/doc/misc/transient.texi @@ -31,7 +31,7 @@ General Public License for more details. @finalout @titlepage @title Transient User and Developer Manual -@subtitle for version 0.5.2 +@subtitle for version 0.6.0 @author Jonas Bernoulli @page @vskip 0pt plus 1filll @@ -53,7 +53,7 @@ resource to get over that hurdle is Psionic K's interactive tutorial, available at @uref{https://github.com/positron-solutions/transient-showcase}. @noindent -This manual is for Transient version 0.5.2. +This manual is for Transient version 0.6.0. @insertcopying @end ifnottex @@ -554,7 +554,7 @@ state, you have to make sure that that state is currently active. @item @kbd{C-x a} (@code{transient-toggle-level-limit}) @kindex C-x a @findex transient-toggle-level-limit -This command toggle whether suffixes that are on levels lower than +This command toggle whether suffixes that are on levels higher than the level specified by @code{transient-default-level} are temporarily available anyway. @end table @@ -1206,9 +1206,19 @@ The returned children must have the same form as stored in the prefix's @code{transient--layout} property, but it is often more convenient to use the same form as understood by @code{transient-define-prefix}, described below. If you use the latter approach, you can use the -@code{transient-parse-child} and @code{transient-parse-children} functions to +@code{transient-parse-suffixes} and @code{transient-parse-suffix} functions to transform them from the convenient to the expected form. +If you explicitly specify children and then transform them using +@code{:setup-chilren}, then the class of the group is determined as usual, +based on explicitly specified children. + +If you do not explicitly specify children and thus rely solely on +@code{:setup-children}, then you must specify the class using @code{:class}. +For backward compatibility, if you fail to do so, @code{transient-column} +is used and a warning is displayed. This warning will eventually +be replaced with an error. + @item The boolean @code{:pad-keys} argument controls whether keys of all suffixes contained in a group are right padded, effectively aligning the @@ -1220,11 +1230,11 @@ The @var{ELEMENT}s are either all subgroups, or all suffixes and strings. subgroups with commands at the same level, though in principle there is nothing that prevents that.) -If the @var{ELEMENT}s are not subgroups, then they can be a mixture of lists -that specify commands and strings. Strings are inserted verbatim into -the buffer. The empty string can be used to insert gaps between -suffixes, which is particularly useful if the suffixes are outlined as -a table. +If the @var{ELEMENT}s are not subgroups, then they can be a mixture of +lists, which specify commands, and strings. Strings are inserted +verbatim into the buffer. The empty string can be used to insert gaps +between suffixes, which is particularly useful if the suffixes are +outlined as a table. Inside group specifications, including inside contained suffix specifications, nothing has to be quoted and quoting anyway is diff --git a/lisp/transient.el b/lisp/transient.el index bb35746e186..2d8566a3ac4 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -5,7 +5,7 @@ ;; Author: Jonas Bernoulli ;; URL: https://github.com/magit/transient ;; Keywords: extensions -;; Version: 0.5.2 +;; Version: 0.6.0 ;; SPDX-License-Identifier: GPL-3.0-or-later @@ -93,17 +93,20 @@ enclosed in a `progn' form. ELSE-FORMS may be empty." then-form (cons 'progn else-forms))) -(defmacro transient--with-emergency-exit (&rest body) +(defmacro transient--with-emergency-exit (id &rest body) (declare (indent defun)) + (unless (keywordp id) + (setq body (cons id body)) + (setq id nil)) `(condition-case err (let ((debugger #'transient--exit-and-debug)) ,(macroexp-progn body)) ((debug error) - (transient--emergency-exit) + (transient--emergency-exit ,id) (signal (car err) (cdr err))))) (defun transient--exit-and-debug (&rest args) - (transient--emergency-exit) + (transient--emergency-exit :debugger) (apply #'debug args)) ;;; Options @@ -668,6 +671,7 @@ If `transient-save-history' is nil, then do nothing." (incompatible :initarg :incompatible :initform nil) (suffix-description :initarg :suffix-description) (variable-pitch :initarg :variable-pitch :initform nil) + (column-widths :initarg :column-widths :initform nil) (unwind-suffix :documentation "Internal use." :initform nil)) "Transient prefix command. @@ -725,7 +729,8 @@ slot is non-nil." :abstract t) (defclass transient-suffix (transient-child) - ((key :initarg :key) + ((definition :allocation :class :initform nil) + (key :initarg :key) (command :initarg :command) (transient :initarg :transient) (format :initarg :format :initform " %k %d") @@ -946,7 +951,10 @@ ARGLIST. The infix arguments are usually accessed by using (pcase-let ((`(,class ,slots ,_ ,docstr ,body) (transient--expand-define-args args arglist))) `(progn - (defalias ',name (lambda ,arglist ,@body)) + (defalias ',name + ,(if (and (not body) class (oref-default class definition)) + `(oref-default ',class definition) + `(lambda ,arglist ,@body))) (put ',name 'interactive-only t) (put ',name 'function-documentation ,docstr) (put ',name 'transient--suffix @@ -997,7 +1005,7 @@ keyword. `(progn (defalias ',name #'transient--default-infix-command) (put ',name 'interactive-only t) - (put ',name 'command-modes (list 'not-a-mode)) + (put ',name 'completion-predicate #'transient--suffix-only) (put ',name 'function-documentation ,docstr) (put ',name 'transient--suffix (,(or class 'transient-switch) :command ',name ,@slots))))) @@ -1013,21 +1021,39 @@ example, sets a variable, use `transient-define-infix' instead. (defun transient--default-infix-command () ;; Most infix commands are but an alias for this command. - "Cannot show any documentation for this anonymous infix command. + "Cannot show any documentation for this transient infix command. -This infix command was defined anonymously, i.e., it was define -inside a call to `transient-define-prefix'. +When you request help for an infix command using `transient-help', that +usually shows the respective man-page and tries to jump to the location +where the respective argument is being described. -When you request help for such an infix command, then we usually -show the respective man-page and jump to the location where the -respective argument is being described. This isn't possible in -this case, because the `man-page' slot was not set in this case." +If no man-page is specified for the containing transient menu, then the +docstring is displayed instead, if any. + +If the infix command doesn't have a docstring, as is the case here, then +this docstring is displayed instead, because technically infix commands +are aliases for `transient--default-infix-command'. + +`describe-function' also shows the docstring of the infix command, +falling back to that of the same aliased command." (interactive) (let ((obj (transient-suffix-object))) (transient-infix-set obj (transient-infix-read obj))) (transient--show)) (put 'transient--default-infix-command 'interactive-only t) -(put 'transient--default-infix-command 'command-modes (list 'not-a-mode)) +(put 'transient--default-infix-command 'completion-predicate + #'transient--suffix-only) + +(defun transient--find-function-advised-original (fn func) + "Return nil instead of `transient--default-infix-command'. +When using `find-function' to jump to the definition of a transient +infix command/argument, then we want to actually jump to that, not to +the definition of `transient--default-infix-command', which all infix +commands are aliases for." + (let ((val (funcall fn func))) + (and val (not (eq val 'transient--default-infix-command)) val))) +(advice-add 'find-function-advised-original :around + #'transient--find-function-advised-original) (eval-and-compile (defun transient--expand-define-args (args &optional arglist) @@ -1056,7 +1082,8 @@ this case, because the `man-page' slot was not set in this case." args)))) (defun transient--parse-child (prefix spec) - (cl-etypecase spec + (cl-typecase spec + (null (error "Invalid transient--parse-child spec: %s" spec)) (symbol (let ((value (symbol-value spec))) (if (and (listp value) (or (listp (car value)) @@ -1065,7 +1092,8 @@ this case, because the `man-page' slot was not set in this case." (transient--parse-child prefix value)))) (vector (and-let* ((c (transient--parse-group prefix spec))) (list c))) (list (and-let* ((c (transient--parse-suffix prefix spec))) (list c))) - (string (list spec)))) + (string (list spec)) + (t (error "Invalid transient--parse-child spec: %s" spec)))) (defun transient--parse-group (prefix spec) (setq spec (append spec nil)) @@ -1086,12 +1114,16 @@ this case, because the `man-page' slot was not set in this case." (and (listp val) (not (eq (car val) 'lambda)))) (setq args (plist-put args key (macroexp-quote val)))) ((setq args (plist-put args key val)))))) + (unless (or spec class (not (plist-get args :setup-children))) + (message "WARNING: %s: When %s is used, %s must also be specified" + 'transient-define-prefix :setup-children :class)) (list 'vector (or level transient--default-child-level) - (or class - (if (vectorp car) - (quote 'transient-columns) - (quote 'transient-column))) + (cond (class) + ((or (vectorp car) + (and car (symbolp car))) + (quote 'transient-columns)) + ((quote 'transient-column))) (and args (cons 'list args)) (cons 'list (cl-mapcan (lambda (s) (transient--parse-child prefix s)) @@ -1130,14 +1162,15 @@ this case, because the `man-page' slot was not set in this case." (format "transient:%s:%s" prefix (let ((desc (plist-get args :description))) - (if (and desc (or (stringp desc) (symbolp desc))) + (if (and (stringp desc) + (length< desc 16)) desc (plist-get args :key))))))) (setq args (plist-put args :command `(prog1 ',sym (put ',sym 'interactive-only t) - (put ',sym 'command-modes (list 'not-a-mode)) + (put ',sym 'completion-predicate #'transient--suffix-only) (defalias ',sym ,(if (eq (car-safe cmd) 'lambda) cmd @@ -1160,7 +1193,7 @@ this case, because the `man-page' slot was not set in this case." args :command `(prog1 ',sym (put ',sym 'interactive-only t) - (put ',sym 'command-modes (list 'not-a-mode)) + (put ',sym 'completion-predicate #'transient--suffix-only) (defalias ',sym #'transient--default-infix-command)))) (cond ((and car (not (keywordp car))) (setq class 'transient-option) @@ -1198,12 +1231,33 @@ this case, because the `man-page' slot was not set in this case." (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg) (match-string 1 arg)))) +(defun transient-command-completion-not-suffix-only-p (symbol _buffer) + "Say whether SYMBOL should be offered as a completion. +If the value of SYMBOL's `completion-predicate' property is +`transient--suffix-only', then return nil, otherwise return t. +This is the case when a command should only ever be used as a +suffix of a transient prefix command (as opposed to bindings +in regular keymaps or by using `execute-extended-command')." + (not (eq (get symbol 'completion-predicate) 'transient--suffix-only))) + +(defalias 'transient--suffix-only #'ignore + "Ignore ARGUMENTS, do nothing, and return nil. +Also see `transient-command-completion-not-suffix-only-p'. +Only use this alias as the value of the `completion-predicate' +symbol property.") + +(when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1 + (not read-extended-command-predicate)) + (setq read-extended-command-predicate + 'transient-command-completion-not-suffix-only-p)) + (defun transient-parse-suffix (prefix suffix) "Parse SUFFIX, to be added to PREFIX. PREFIX is a prefix command, a symbol. SUFFIX is a suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." + (cl-assert (and prefix (symbolp prefix))) (eval (car (transient--parse-child prefix suffix)))) (defun transient-parse-suffixes (prefix suffixes) @@ -1212,6 +1266,7 @@ PREFIX is a prefix command, a symbol. SUFFIXES is a list of suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." + (cl-assert (and prefix (symbolp prefix))) (mapcar (apply-partially #'transient-parse-suffix prefix) suffixes)) ;;; Edit @@ -1472,7 +1527,8 @@ drawing in the transient buffer.") (defvar transient--pending-suffix nil "The suffix that is currently being processed. -This is bound while the suffix predicate is being evaluated.") +This is bound while the suffix predicate is being evaluated, +and while functions that return faces are being evaluated.") (defvar transient--pending-group nil "The group that is currently being processed. @@ -1555,33 +1611,35 @@ probably use this instead: (get COMMAND \\='transient--suffix)" (when command (cl-check-type command command)) - (if (or transient--prefix - transient-current-prefix) - (let ((suffixes - (cl-remove-if-not - (lambda (obj) - (eq (oref obj command) - (or command - (if (eq this-command 'transient-set-level) - ;; This is how it can look up for which - ;; command it is setting the level. - this-original-command - this-command)))) - (or transient--suffixes - transient-current-suffixes)))) - (or (and (cdr suffixes) - (cl-find-if - (lambda (obj) - (equal (listify-key-sequence (transient--kbd (oref obj key))) - (listify-key-sequence (this-command-keys)))) - suffixes)) - (car suffixes))) - (and-let* ((obj (transient--suffix-prototype (or command this-command))) + (cond + (transient--pending-suffix) + ((or transient--prefix + transient-current-prefix) + (let ((suffixes + (cl-remove-if-not + (lambda (obj) + (eq (oref obj command) + (or command + (if (eq this-command 'transient-set-level) + ;; This is how it can look up for which + ;; command it is setting the level. + this-original-command + this-command)))) + (or transient--suffixes + transient-current-suffixes)))) + (or (and (cdr suffixes) + (cl-find-if + (lambda (obj) + (equal (listify-key-sequence (transient--kbd (oref obj key))) + (listify-key-sequence (this-command-keys)))) + suffixes)) + (car suffixes)))) + ((and-let* ((obj (transient--suffix-prototype (or command this-command))) (obj (clone obj))) (progn ; work around debbugs#31840 (transient-init-scope obj) (transient-init-value obj) - obj)))) + obj))))) (defun transient--suffix-prototype (command) (or (get command 'transient--suffix) @@ -1762,7 +1820,10 @@ of the corresponding object." ;; an unbound key, then Emacs calls the `undefined' command ;; but does not set `this-command', `this-original-command' ;; or `real-this-command' accordingly. Instead they are nil. - "" #'transient--do-warn) + "" #'transient--do-warn + ;; Bound to the `mouse-movement' event, this command is similar + ;; to `ignore'. + "" #'transient--do-noop) (defvar transient--transient-map nil) (defvar transient--predicate-map nil) @@ -1821,7 +1882,7 @@ of the corresponding object." (defun transient--make-predicate-map () (let* ((default (transient--resolve-pre-command (oref transient--prefix transient-suffix))) - (return (and transient-current-prefix (eq default t))) + (return (and transient--stack (eq default t))) (map (make-sparse-keymap))) (set-keymap-parent map transient-predicate-map) (when (or (and (slot-boundp transient--prefix 'transient-switch-frame) @@ -1912,7 +1973,7 @@ the \"scope\" of the transient (see `transient-define-prefix'). This function is also called internally in which case LAYOUT and EDIT may be non-nil." (transient--debug 'setup) - (transient--with-emergency-exit + (transient--with-emergency-exit :setup (cond ((not name) ;; Switching between regular and edit mode. @@ -2166,7 +2227,7 @@ value. Otherwise return CHILDREN as is." (defun transient--pre-command () (transient--debug 'pre-command) - (transient--with-emergency-exit + (transient--with-emergency-exit :pre-command ;; The use of `overriding-terminal-local-map' does not prevent the ;; lookup of command remappings in the overridden maps, which can ;; lead to a suffix being remapped to a non-suffix. We have to undo @@ -2228,14 +2289,14 @@ value. Otherwise return CHILDREN as is." (when (window-live-p transient--window) (let ((remain-in-minibuffer-window (and (minibuffer-selected-window) - (selected-window))) - (buf (window-buffer transient--window))) + (selected-window)))) ;; Only delete the window if it has never shown another buffer. (unless (eq (car (window-parameter transient--window 'quit-restore)) 'other) (with-demoted-errors "Error while exiting transient: %S" (delete-window transient--window))) - (kill-buffer buf) + (when-let ((buffer (get-buffer transient--buffer-name))) + (kill-buffer buffer)) (when remain-in-minibuffer-window (select-window remain-in-minibuffer-window))))) @@ -2253,7 +2314,10 @@ value. Otherwise return CHILDREN as is." ((and transient--prefix transient--redisplay-key) (setq transient--redisplay-key nil) (when transient--showp - (transient--show)))) + (if-let ((win (minibuffer-selected-window))) + (with-selected-window win + (transient--show)) + (transient--show))))) (transient--pop-keymap 'transient--transient-map) (transient--pop-keymap 'transient--redisplay-map) (remove-hook 'pre-command-hook #'transient--pre-command) @@ -2308,7 +2372,7 @@ value. Otherwise return CHILDREN as is." (remove-hook 'minibuffer-exit-hook ,exit))) ,@body))) -(static-if (>= emacs-major-version 30) +(static-if (>= emacs-major-version 30) ;transient--wrap-command (defun transient--wrap-command () (cl-assert (>= emacs-major-version 30) nil @@ -2316,27 +2380,31 @@ value. Otherwise return CHILDREN as is." (letrec ((prefix transient--prefix) (suffix this-command) - (advice (lambda (fn &rest args) - (interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (advice-eval-interactive-spec spec) - (setq abort nil)) - (when abort - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil)))))) - (unwind-protect - (apply fn args) + (advice + (lambda (fn &rest args) + (interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) + (setq abort nil)) + (when abort (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-command) + (transient--debug 'unwind-interactive) (funcall unwind suffix)) (advice-remove suffix advice) - (oset prefix unwind-suffix nil))))) - (advice-add suffix :around advice '((depth . -99))))) + (oset prefix unwind-suffix nil)))))) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99)))))) (defun transient--wrap-command () (let* ((prefix transient--prefix) @@ -2346,7 +2414,8 @@ value. Otherwise return CHILDREN as is." (lambda (spec) (let ((abort t)) (unwind-protect - (prog1 (advice-eval-interactive-spec spec) + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) (setq abort nil)) (when abort (when-let ((unwind (oref prefix unwind-suffix))) @@ -2357,7 +2426,8 @@ value. Otherwise return CHILDREN as is." (advice-body (lambda (fn &rest args) (unwind-protect - (apply fn args) + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) (when-let ((unwind (oref prefix unwind-suffix))) (transient--debug 'unwind-command) (funcall unwind suffix)) @@ -2366,7 +2436,8 @@ value. Otherwise return CHILDREN as is." (setq advice `(lambda (fn &rest args) (interactive ,advice-interactive) (apply ',advice-body fn args))) - (advice-add suffix :around advice '((depth . -99)))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99))))))) (defun transient--premature-post-command () (and (equal (this-command-keys-vector) []) @@ -2385,7 +2456,7 @@ value. Otherwise return CHILDREN as is." (defun transient--post-command () (unless (transient--premature-post-command) (transient--debug 'post-command) - (transient--with-emergency-exit + (transient--with-emergency-exit :post-command (cond (transient--exitp (transient--post-exit)) ;; If `this-command' is the current transient prefix, then we ;; have already taken care of updating the transient buffer... @@ -2509,18 +2580,22 @@ value. Otherwise return CHILDREN as is." this-command)) (key-description (this-command-keys-vector)) transient--exitp - (cond ((stringp (car args)) + (cond ((keywordp (car args)) + (format ", from: %s" + (substring (symbol-name (car args)) 1))) + ((stringp (car args)) (concat ", " (apply #'format args))) - (args + ((functionp (car args)) (concat ", " (apply (car args) (cdr args)))) (""))) (apply #'message arg args))))) -(defun transient--emergency-exit () +(defun transient--emergency-exit (&optional id) "Exit the current transient command after an error occurred. When no transient is active (i.e., when `transient--prefix' is -nil) then do nothing." - (transient--debug 'emergency-exit) +nil) then do nothing. Optional ID is a keyword identifying the +exit." + (transient--debug 'emergency-exit id) (when transient--prefix (setq transient--stack nil) (setq transient--exitp t) @@ -2544,6 +2619,7 @@ nil) then do nothing." (defun transient--get-pre-command (&optional cmd enforce-type) (or (and (not (eq enforce-type 'non-suffix)) + (symbolp cmd) (lookup-key transient--predicate-map (vector cmd))) (and (not (eq enforce-type 'suffix)) (transient--resolve-pre-command @@ -3087,14 +3163,14 @@ infix command determines what the new value should be, based on the previous value.") (cl-defmethod transient-infix-read :around ((obj transient-infix)) - "Refresh the transient buffer buffer calling the next method. + "Refresh the transient buffer and call the next method. Also wrap `cl-call-next-method' with two macros: - `transient--with-suspended-override' allows use of minibuffer. - `transient--with-emergency-exit' arranges for the transient to be exited in case of an error." (transient--show) - (transient--with-emergency-exit + (transient--with-emergency-exit :infix-read (transient--with-suspended-override (cl-call-next-method obj)))) @@ -3176,8 +3252,10 @@ The last value is \"don't use any of these switches\"." "Elsewhere use the reader of the infix command COMMAND. Use this if you want to share an infix's history with a regular stand-alone command." - (cl-letf (((symbol-function #'transient--show) #'ignore)) - (transient-infix-read (transient--suffix-prototype command)))) + (if-let ((obj (transient--suffix-prototype command))) + (cl-letf (((symbol-function #'transient--show) #'ignore)) + (transient-infix-read obj)) + (error "Not a suffix command: `%s'" command))) ;;;; Readers @@ -3354,7 +3432,7 @@ the set, saved or default value for PREFIX." (transient--init-suffixes prefix))))) (defun transient-get-value () - (transient--with-emergency-exit + (transient--with-emergency-exit :get-value (cl-mapcan (lambda (obj) (and (or (not (slot-exists-p obj 'unsavable)) (not (oref obj unsavable))) @@ -3565,7 +3643,7 @@ have a history of their own.") (propertize "\n" 'face face 'line-height t)))) (defmacro transient-with-shadowed-buffer (&rest body) - "While in the transient buffer, temporarily make the shadowed buffer current." + "While in the transient buffer, temporarly make the shadowed buffer current." (declare (indent 0) (debug t)) `(with-current-buffer (or transient--shadowed-buffer (current-buffer)) ,@body)) @@ -3620,7 +3698,8 @@ have a history of their own.") (lambda (column) (transient--maybe-pad-keys column group) (transient-with-shadowed-buffer - (let ((rows (mapcar #'transient-format (oref column suffixes)))) + (let* ((transient--pending-group column) + (rows (mapcar #'transient-format (oref column suffixes)))) (when-let ((desc (transient-format-description column))) (push desc rows)) (flatten-tree rows)))) @@ -3629,10 +3708,15 @@ have a history of their own.") transient-align-variable-pitch)) (rs (apply #'max (mapcar #'length columns))) (cs (length columns)) - (cw (mapcar (lambda (col) - (apply #'max - (mapcar (if vp #'transient--pixel-width #'length) - col))) + (cw (mapcar (let ((widths (oref transient--prefix column-widths))) + (lambda (col) + (apply + #'max + (if-let ((min (pop widths))) + (if vp (* min (transient--pixel-width " ")) min) + 0) + (mapcar (if vp #'transient--pixel-width #'length) + col)))) columns)) (cc (transient--seq-reductions-from (apply-partially #'+ (* 3 (if vp (transient--pixel-width " ") 1))) @@ -3908,7 +3992,10 @@ If the OBJ's `key' is currently unreachable, then apply the face (face (slot-value obj slot))) (if (and (not (facep face)) (functionp face)) - (funcall face) + (let ((transient--pending-suffix obj)) + (if (= (car (func-arity face)) 1) + (funcall face obj) + (funcall face))) face))) (defun transient--key-face (&optional cmd enforce-type) From 946280365d40104dffd5329eebefc02329f72041 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 19:26:33 -0400 Subject: [PATCH 119/155] (make-help-screen): Move most of the code out to a function This avoids problems like variable-name capture and lets compiler messages point to the actual source code. * lisp/help-macro.el (help--help-screen): New function, extracted from `make-help-screen`. (make-help-screen): Use it. --- lisp/help-macro.el | 273 +++++++++++++++++++++++---------------------- 1 file changed, 139 insertions(+), 134 deletions(-) diff --git a/lisp/help-macro.el b/lisp/help-macro.el index cea8b379ec0..8a16e85a329 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -92,141 +92,146 @@ and then returns." `(defun ,fname () "Help command." (interactive) - (let ((line-prompt - (substitute-command-keys ,help-line)) - (help-buffer-under-preparation t)) - (when three-step-help - (message "%s" line-prompt)) - (let* ((help-screen ,help-text) - ;; We bind overriding-local-map for very small - ;; sections, *excluding* where we switch buffers - ;; and where we execute the chosen help command. - (local-map (make-sparse-keymap)) - (new-minor-mode-map-alist minor-mode-map-alist) - (prev-frame (selected-frame)) - config new-frame key char) - (when (string-match "%THIS-KEY%" help-screen) - (setq help-screen - (replace-match (help--key-description-fontified - (substring (this-command-keys) 0 -1)) - t t help-screen))) - (unwind-protect - (let ((minor-mode-map-alist nil)) - (setcdr local-map ,helped-map) - (define-key local-map [t] 'undefined) - ;; Make the scroll bar keep working normally. - (define-key local-map [vertical-scroll-bar] - (lookup-key global-map [vertical-scroll-bar])) - (if three-step-help - (progn - (setq key (let ((overriding-local-map local-map)) - (read-key-sequence nil))) - ;; Make the HELP key translate to C-h. - (if (lookup-key function-key-map key) - (setq key (lookup-key function-key-map key))) - (setq char (aref key 0))) - (setq char ??)) - (when (or (eq char ??) (eq char help-char) - (memq char help-event-list)) - (setq config (current-window-configuration)) - (pop-to-buffer (or ,buffer-name " *Metahelp*") nil t) - (and (fboundp 'make-frame) - (not (eq (window-frame) - prev-frame)) - (setq new-frame (window-frame) - config nil)) - (setq buffer-read-only nil) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (substitute-command-keys help-screen))) - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - (help-mode) - (variable-pitch-mode) - (setq new-minor-mode-map-alist minor-mode-map-alist)) - (goto-char (point-min)) - (while (or (memq char (append help-event-list - (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s - deletechar backspace vertical-scroll-bar - home end next prior up down)))) - (eq (car-safe char) 'switch-frame) - (equal key "\M-v")) - (condition-case nil - (cond - ((eq (car-safe char) 'switch-frame) - (handle-switch-frame char)) - ((memq char '(?\C-v ?\s next end)) - (scroll-up)) - ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home)) - (equal key "\M-v")) - (scroll-down)) - ((memq char '(down)) - (scroll-up 1)) - ((memq char '(up)) - (scroll-down 1))) - (error nil)) - (let ((cursor-in-echo-area t) - (overriding-local-map local-map)) - (frame-toggle-on-screen-keyboard (selected-frame) nil) - (setq key (read-key-sequence - (format "Type one of listed options%s: " - (if (pos-visible-in-window-p - (point-max)) - "" - (concat ", or " - (help--key-description-fontified (kbd "")) - "/" - (help--key-description-fontified (kbd "")) - "/" - (help--key-description-fontified (kbd "SPC")) - "/" - (help--key-description-fontified (kbd "DEL")) - " to scroll"))) - nil nil nil nil - ;; Disable ``text conversion''. OS - ;; input methods might otherwise chose - ;; to insert user input directly into - ;; a buffer. - t) - char (aref key 0))) + (help--help-screen ,help-line ,help-text ,helped-map ,buffer-name))) - ;; If this is a scroll bar command, just run it. - (when (eq char 'vertical-scroll-bar) - (command-execute (lookup-key local-map key) nil key)))) - ;; We don't need the prompt any more. - (message "") - ;; Mouse clicks are not part of the help feature, - ;; so reexecute them in the standard environment. - (if (listp char) - (setq unread-command-events - (cons char unread-command-events) - config nil) - (let ((defn (lookup-key local-map key))) - (if defn - (progn - (when config - (set-window-configuration config) - (setq config nil)) - ;; Temporarily rebind `minor-mode-map-alist' - ;; to `new-minor-mode-map-alist' (Bug#10454). - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - ;; `defn' must make sure that its frame is - ;; selected, so we won't iconify it below. - (call-interactively defn)) - (when new-frame - ;; Do not iconify the selected frame. - (unless (eq new-frame (selected-frame)) - (iconify-frame new-frame)) - (setq new-frame nil))) - (unless (equal (key-description key) "C-g") - (message (substitute-command-keys - (format "No help command is bound to `\\`%s''" - (key-description key)))) - (ding)))))) - (when config - (set-window-configuration config)) - (when new-frame - (iconify-frame new-frame)) - (setq minor-mode-map-alist new-minor-mode-map-alist)))))) + +;;;###autoload +(defun help--help-screen (help-line help-text helped-map buffer-name) + (let ((line-prompt + (substitute-command-keys help-line)) + (help-buffer-under-preparation t)) + (when three-step-help + (message "%s" line-prompt)) + (let* ((help-screen help-text) + ;; We bind overriding-local-map for very small + ;; sections, *excluding* where we switch buffers + ;; and where we execute the chosen help command. + (local-map (make-sparse-keymap)) + (new-minor-mode-map-alist minor-mode-map-alist) + (prev-frame (selected-frame)) + config new-frame key char) + (when (string-match "%THIS-KEY%" help-screen) + (setq help-screen + (replace-match (help--key-description-fontified + (substring (this-command-keys) 0 -1)) + t t help-screen))) + (unwind-protect + (let ((minor-mode-map-alist nil)) + (setcdr local-map helped-map) + (define-key local-map [t] #'undefined) + ;; Make the scroll bar keep working normally. + (define-key local-map [vertical-scroll-bar] + (lookup-key global-map [vertical-scroll-bar])) + (if three-step-help + (progn + (setq key (let ((overriding-local-map local-map)) + (read-key-sequence nil))) + ;; Make the HELP key translate to C-h. + (if (lookup-key function-key-map key) + (setq key (lookup-key function-key-map key))) + (setq char (aref key 0))) + (setq char ??)) + (when (or (eq char ??) (eq char help-char) + (memq char help-event-list)) + (setq config (current-window-configuration)) + (pop-to-buffer (or buffer-name " *Metahelp*") nil t) + (and (fboundp 'make-frame) + (not (eq (window-frame) + prev-frame)) + (setq new-frame (window-frame) + config nil)) + (setq buffer-read-only nil) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (substitute-command-keys help-screen))) + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + (help-mode) + (variable-pitch-mode) + (setq new-minor-mode-map-alist minor-mode-map-alist)) + (goto-char (point-min)) + (while (or (memq char (append help-event-list + (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s + deletechar backspace vertical-scroll-bar + home end next prior up down)))) + (eq (car-safe char) 'switch-frame) + (equal key "\M-v")) + (condition-case nil + (cond + ((eq (car-safe char) 'switch-frame) + (handle-switch-frame char)) + ((memq char '(?\C-v ?\s next end)) + (scroll-up)) + ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home)) + (equal key "\M-v")) + (scroll-down)) + ((memq char '(down)) + (scroll-up 1)) + ((memq char '(up)) + (scroll-down 1))) + (error nil)) + (let ((cursor-in-echo-area t) + (overriding-local-map local-map)) + (frame-toggle-on-screen-keyboard (selected-frame) nil) + (setq key (read-key-sequence + (format "Type one of listed options%s: " + (if (pos-visible-in-window-p + (point-max)) + "" + (concat ", or " + (help--key-description-fontified (kbd "")) + "/" + (help--key-description-fontified (kbd "")) + "/" + (help--key-description-fontified (kbd "SPC")) + "/" + (help--key-description-fontified (kbd "DEL")) + " to scroll"))) + nil nil nil nil + ;; Disable ``text conversion''. OS + ;; input methods might otherwise chose + ;; to insert user input directly into + ;; a buffer. + t) + char (aref key 0))) + + ;; If this is a scroll bar command, just run it. + (when (eq char 'vertical-scroll-bar) + (command-execute (lookup-key local-map key) nil key)))) + ;; We don't need the prompt any more. + (message "") + ;; Mouse clicks are not part of the help feature, + ;; so reexecute them in the standard environment. + (if (listp char) + (setq unread-command-events + (cons char unread-command-events) + config nil) + (let ((defn (lookup-key local-map key))) + (if defn + (progn + (when config + (set-window-configuration config) + (setq config nil)) + ;; Temporarily rebind `minor-mode-map-alist' + ;; to `new-minor-mode-map-alist' (Bug#10454). + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + ;; `defn' must make sure that its frame is + ;; selected, so we won't iconify it below. + (call-interactively defn)) + (when new-frame + ;; Do not iconify the selected frame. + (unless (eq new-frame (selected-frame)) + (iconify-frame new-frame)) + (setq new-frame nil))) + (unless (equal (key-description key) "C-g") + (message (substitute-command-keys + (format "No help command is bound to `\\`%s''" + (key-description key)))) + (ding)))))) + (when config + (set-window-configuration config)) + (when new-frame + (iconify-frame new-frame)) + (setq minor-mode-map-alist new-minor-mode-map-alist))))) (provide 'help-macro) From a1f8702e8345254e6898d35e554bdc06ab09c3ca Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 19:40:20 -0400 Subject: [PATCH 120/155] (help-fns-function-name): New function Consolidate code used in profiler and help--describe-command, and improve it while we're at it. Also use #' to quote a few function names along the way. * lisp/help-fns.el (help-fns--function-numbers, help-fns--function-names): New vars. (help-fns--display-function): New aux function. (help-fns-function-name): New function, inspired from `help--describe-command`. * lisp/help.el (help--describe-command): Use `help-fns-function-name`. (help--for-help-make-sections): Remove redundant "" arg to `mapconcat`. * lisp/profiler.el (profiler-format-entry, profiler-fixup-entry): Delete functions. (profiler-report-make-entry-part): Use `help-fns-function-name` instead. (profiler-report-find-entry): Use `push-button`. * lisp/transient.el (transient--debug): Use `help-fns-function-name` when available. --- etc/NEWS | 6 ++++ lisp/bind-key.el | 1 + lisp/help-fns.el | 68 +++++++++++++++++++++++++++++++++++++++++++ lisp/help.el | 44 +++++++++------------------- lisp/profiler.el | 74 +++++++++++++++++------------------------------ lisp/transient.el | 22 +++++++------- 6 files changed, 127 insertions(+), 88 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index ba0e4c80fa0..eda84d588a8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1647,6 +1647,12 @@ values. * Lisp Changes in Emacs 30.1 +** New function 'help-fns-function-name'. +For named functions, it just returns the name and otherwise +it returns a short "unique" string that identifies the function. +In either case, the string is propertized so clicking on it gives +further details. + ** New function 'cl-type-of'. This function is like 'type-of' except that it sometimes returns a more precise type. For example, for nil and t it returns 'null' diff --git a/lisp/bind-key.el b/lisp/bind-key.el index 1e59c75566a..780314fecbd 100644 --- a/lisp/bind-key.el +++ b/lisp/bind-key.el @@ -468,6 +468,7 @@ other modes. See `override-global-mode'." ((and bind-key-describe-special-forms (functionp elem) (stringp (setq doc (documentation elem)))) doc) ;;FIXME: Keep only the first line? + ;; FIXME: Use `help-fns-function-name'? ((consp elem) (if (symbolp (car elem)) (format "#<%s>" (car elem)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 15d87f9925c..422f6e9dddf 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -2448,6 +2448,74 @@ one of them returns non-nil." (setq buffer-undo-list nil) (texinfo-mode))) +(defconst help-fns--function-numbers + (make-hash-table :test 'equal :weakness 'value)) +(defconst help-fns--function-names (make-hash-table :weakness 'key)) + +(defun help-fns--display-function (function) + (cond + ((subr-primitive-p function) + (describe-function function)) + ((and (compiled-function-p function) + (not (and (fboundp 'kmacro-p) (kmacro-p function)))) + (disassemble function)) + (t + ;; FIXME: Use cl-print! + (pp-display-expression function "*Help Source*" (consp function))))) + +;;;###autoload +(defun help-fns-function-name (function) + "Return a short string representing FUNCTION." + ;; FIXME: For kmacros, should we print the key-sequence? + (cond + ((symbolp function) + (let ((name (if (eq (intern-soft (symbol-name function)) function) + (symbol-name function) + (concat "#:" (symbol-name function))))) + (if (not (fboundp function)) + name + (make-text-button name nil + 'type 'help-function + 'help-args (list function))))) + ((gethash function help-fns--function-names)) + ((subrp function) + (let ((name (subr-name function))) + ;; FIXME: For native-elisp-functions, should we use `help-function' + ;; or `disassemble'? + (format "#<%s %s>" + (cl-type-of function) + (make-text-button name nil + 'type 'help-function + ;; Let's hope the subr hasn't been redefined! + 'help-args (list (intern name)))))) + (t + (let ((type (or (oclosure-type function) + (if (consp function) + (car function) (cl-type-of function)))) + (hash (sxhash-eq function)) + ;; Use 3 digits minimum. + (mask #xfff) + name) + (while + (let* ((hex (format (concat "%0" + (number-to-string (1+ (/ (logb mask) 4))) + "X") + (logand mask hash))) + ;; FIXME: For kmacros, we don't want to `disassemble'! + (button (buttonize + hex #'help-fns--display-function function + ;; FIXME: Shouldn't `buttonize' add + ;; the "mouse-2, RET:" prefix? + "mouse-2, RET: Display the function's body"))) + (setq name (format "#<%s %s>" type button)) + (and (< mask (abs hash)) ; We can add more digits. + (gethash name help-fns--function-numbers))) + ;; Add a digit. + (setq mask (+ (ash mask 4) #x0f))) + (puthash name function help-fns--function-numbers) + (puthash function name help-fns--function-names) + name)))) + (provide 'help-fns) ;;; help-fns.el ends here diff --git a/lisp/help.el b/lisp/help.el index c6a1e3c6bd9..4171d0c57c7 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -301,6 +301,8 @@ Do not call this in the scope of `with-help-window'." (let ((first-message (cond ((or pop-up-frames + ;; FIXME: `special-display-p' is obsolete since + ;; the vars on which it depends are obsolete! (special-display-p (buffer-name standard-output))) (setq help-return-method (cons (selected-window) t)) ;; If the help output buffer is a special display buffer, @@ -382,9 +384,9 @@ Do not call this in the scope of `with-help-window'." (propertize title 'face 'help-for-help-header) "\n\n" (help--for-help-make-commands commands)))) - sections "")) + sections)) -(defalias 'help 'help-for-help) +(defalias 'help #'help-for-help) (make-help-screen help-for-help (purecopy "Type a help option: [abcCdefFgiIkKlLmnprstvw.] C-[cdefmnoptw] or ?") (concat @@ -876,7 +878,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (format "%s (translated from %s)" string otherstring)))))) (defun help--binding-undefined-p (defn) - (or (null defn) (integerp defn) (equal defn 'undefined))) + (or (null defn) (integerp defn) (equal defn #'undefined))) (defun help--analyze-key (key untranslated &optional buffer) "Get information about KEY its corresponding UNTRANSLATED events. @@ -1221,7 +1223,7 @@ appeared on the mode-line." (defun describe-minor-mode-completion-table-for-symbol () ;; In order to list up all minor modes, minor-mode-list ;; is used here instead of minor-mode-alist. - (delq nil (mapcar 'symbol-name minor-mode-list))) + (delq nil (mapcar #'symbol-name minor-mode-list))) (defun describe-minor-mode-from-symbol (symbol) "Display documentation of a minor mode given as a symbol, SYMBOL." @@ -1644,34 +1646,14 @@ Return nil if the key sequence is too long." (t value)))) (defun help--describe-command (definition &optional translation) - (cond ((symbolp definition) - (if (and (fboundp definition) - help-buffer-under-preparation) - (insert-text-button (symbol-name definition) - 'type 'help-function - 'help-args (list definition)) - (insert (symbol-name definition))) - (insert "\n")) - ((or (stringp definition) (vectorp definition)) + (cond ((or (stringp definition) (vectorp definition)) (if translation (insert (key-description definition nil) "\n") + ;; These should be rare nowadays, replaced by `kmacro's. (insert "Keyboard Macro\n"))) ((keymapp definition) (insert "Prefix Command\n")) - ((byte-code-function-p definition) - (insert (format "[%s]\n" - (buttonize "byte-code" #'disassemble definition)))) - ((and (consp definition) - (memq (car definition) '(closure lambda))) - (insert (format "[%s]\n" - (buttonize - (symbol-name (car definition)) - (lambda (_) - (pp-display-expression - definition "*Help Source*" t)) - nil "View definition")))) - (t - (insert "??\n")))) + (t (insert (help-fns-function-name definition) "\n")))) (define-obsolete-function-alias 'help--describe-translation #'help--describe-command "29.1") @@ -2011,8 +1993,8 @@ and some others." (if temp-buffer-resize-mode ;; `help-make-xrefs' may add a `back' button and thus increase the ;; text size, so `resize-temp-buffer-window' must be run *after* it. - (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append) - (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window))) + (add-hook 'temp-buffer-show-hook #'resize-temp-buffer-window 'append) + (remove-hook 'temp-buffer-show-hook #'resize-temp-buffer-window))) (defvar resize-temp-buffer-window-inhibit nil "Non-nil means `resize-temp-buffer-window' should not resize.") @@ -2256,7 +2238,7 @@ The `temp-buffer-window-setup-hook' hook is called." ;; Don't print to *Help*; that would clobber Help history. (defun help-form-show () "Display the output of a non-nil `help-form'." - (let ((msg (eval help-form))) + (let ((msg (eval help-form t))) (if (stringp msg) (with-output-to-temp-buffer " *Char Help*" (princ msg))))) @@ -2421,7 +2403,7 @@ the same names as used in the original source code, when possible." (t arg))) arglist))) -(define-obsolete-function-alias 'help-make-usage 'help--make-usage "25.1") +(define-obsolete-function-alias 'help-make-usage #'help--make-usage "25.1") (defun help--make-usage-docstring (fn arglist) (let ((print-escape-newlines t)) diff --git a/lisp/profiler.el b/lisp/profiler.el index 80f84037a63..4e02cd1d890 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -38,8 +38,7 @@ (defcustom profiler-sampling-interval 1000000 "Default sampling interval in nanoseconds." - :type 'natnum - :group 'profiler) + :type 'natnum) ;;; Utilities @@ -68,7 +67,7 @@ collect c into s do (cl-decf i) finally return - (apply 'string (if (eq (car s) ?,) (cdr s) s))) + (apply #'string (if (eq (car s) ?,) (cdr s) s))) (profiler-ensure-string number))) (defun profiler-format (fmt &rest args) @@ -76,7 +75,7 @@ for arg in args for str = (cond ((consp subfmt) - (apply 'profiler-format subfmt arg)) + (apply #'profiler-format subfmt arg)) ((stringp subfmt) (format subfmt arg)) ((and (symbolp subfmt) @@ -91,7 +90,8 @@ if (< width len) collect (progn (put-text-property (max 0 (- width 2)) len 'invisible 'profiler str) - str) into frags + str) + into frags else collect (let ((padding (make-string (max 0 (- width len)) ?\s))) @@ -100,32 +100,11 @@ (right (concat padding str)))) into frags finally return (apply #'concat frags))) - - -;;; Entries - -(defun profiler-format-entry (entry) - "Format ENTRY in human readable string. -ENTRY would be a function name of a function itself." - (cond ((memq (car-safe entry) '(closure lambda)) - (format "#" (sxhash entry))) - ((byte-code-function-p entry) - (format "#" (sxhash entry))) - ((or (subrp entry) (symbolp entry) (stringp entry)) - (format "%s" entry)) - (t - (format "#" (sxhash entry))))) - -(defun profiler-fixup-entry (entry) - (if (symbolp entry) - entry - (profiler-format-entry entry))) - ;;; Backtraces (defun profiler-fixup-backtrace (backtrace) - (apply 'vector (mapcar 'profiler-fixup-entry backtrace))) + (apply #'vector (mapcar #'help-fns-function-name backtrace))) ;;; Logs @@ -434,18 +413,15 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." (defcustom profiler-report-closed-mark "+" "An indicator of closed calltrees." - :type 'string - :group 'profiler) + :type 'string) (defcustom profiler-report-open-mark "-" "An indicator of open calltrees." - :type 'string - :group 'profiler) + :type 'string) (defcustom profiler-report-leaf-mark " " "An indicator of calltree leaves." - :type 'string - :group 'profiler) + :type 'string) (defvar profiler-report-cpu-line-format '((17 right ((12 right) @@ -474,17 +450,18 @@ Do not touch this variable directly.") (let ((string (cond ((eq entry t) "Others") - ((and (symbolp entry) - (fboundp entry)) - (propertize (symbol-name entry) - 'face 'link - 'follow-link "\r" - 'mouse-face 'highlight - 'help-echo "\ + (t (propertize (help-fns-function-name entry) + ;; Override the `button-map' which + ;; otherwise adds RET, mouse-1, and TAB + ;; bindings we don't want. :-( + 'keymap '(make-sparse-keymap) + 'follow-link "\r" + ;; FIXME: The help-echo code gets confused + ;; by the `follow-link' property and rewrites + ;; `mouse-2' to `mouse-1' :-( + 'help-echo "\ mouse-2: jump to definition\n\ -RET: expand or collapse")) - (t - (profiler-format-entry entry))))) +RET: expand or collapse"))))) (propertize string 'profiler-entry entry))) (defun profiler-report-make-name-part (tree) @@ -719,10 +696,13 @@ point." (current-buffer)) (and event (setq event (event-end event)) (posn-set-point event)) - (let ((tree (profiler-report-calltree-at-point))) - (when tree - (let ((entry (profiler-calltree-entry tree))) - (find-function entry)))))) + (save-excursion + (forward-line 0) + (let ((eol (pos-eol))) + (forward-button 1) + (if (> (point) eol) + (error "No entry found") + (push-button)))))) (defun profiler-report-describe-entry () "Describe entry at point." diff --git a/lisp/transient.el b/lisp/transient.el index 2d8566a3ac4..c3b9448e2c4 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -1249,7 +1249,7 @@ symbol property.") (when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1 (not read-extended-command-predicate)) (setq read-extended-command-predicate - 'transient-command-completion-not-suffix-only-p)) + #'transient-command-completion-not-suffix-only-p)) (defun transient-parse-suffix (prefix suffix) "Parse SUFFIX, to be added to PREFIX. @@ -1258,7 +1258,7 @@ SUFFIX is a suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." (cl-assert (and prefix (symbolp prefix))) - (eval (car (transient--parse-child prefix suffix)))) + (eval (car (transient--parse-child prefix suffix)) t)) (defun transient-parse-suffixes (prefix suffixes) "Parse SUFFIXES, to be added to PREFIX. @@ -1278,7 +1278,7 @@ Intended for use in a group's `:setup-children' function." (string suffix))) (mem (transient--layout-member loc prefix)) (elt (car mem))) - (setq suf (eval suf)) + (setq suf (eval suf t)) (cond ((not mem) (message "Cannot insert %S into %s; %s not found" @@ -1736,7 +1736,8 @@ to `transient-predicate-map'. Also see `transient-base-map'." "Hide common commands" "Show common permanently"))) (list "C-x l" "Show/hide suffixes" #'transient-set-level) - (list "C-x a" #'transient-toggle-level-limit)))))))) + (list "C-x a" #'transient-toggle-level-limit))))) + t))) (defvar-keymap transient-popup-navigation-map :doc "One of the keymaps used when popup navigation is enabled. @@ -2574,10 +2575,11 @@ value. Otherwise return CHILDREN as is." (if (symbolp arg) (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)" arg - (or (and (symbolp this-command) this-command) - (if (byte-code-function-p this-command) - "#[...]" - this-command)) + (if (fboundp 'help-fns-function-name) + (help-fns-function-name this-command) + (if (byte-code-function-p this-command) + "#[...]" + this-command)) (key-description (this-command-keys-vector)) transient--exitp (cond ((keywordp (car args)) @@ -2982,7 +2984,7 @@ transient is active." (interactive) (transient-set-value (transient-prefix-object))) -(defalias 'transient-set-and-exit 'transient-set +(defalias 'transient-set-and-exit #'transient-set "Set active transient's value for this Emacs session and exit.") (defun transient-save () @@ -2990,7 +2992,7 @@ transient is active." (interactive) (transient-save-value (transient-prefix-object))) -(defalias 'transient-save-and-exit 'transient-save +(defalias 'transient-save-and-exit #'transient-save "Save active transient's value for this and future Emacs sessions and exit.") (defun transient-reset () From 60c9702972f3cef9e6dbbce5eaad8cc90ea7f8e8 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 21:43:38 -0400 Subject: [PATCH 121/155] * lisp/help.el (help--analyze-key): Use `help-fns-function-name` --- lisp/help.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/help.el b/lisp/help.el index 4171d0c57c7..bafe6032942 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -926,7 +926,9 @@ in the selected window." (let ((key-desc (help-key-description key untranslated))) (if (help--binding-undefined-p defn) (format "%s%s is undefined" key-desc mouse-msg) - (format "%s%s runs the command %S" key-desc mouse-msg defn))) + (format "%s%s runs the command %s" key-desc mouse-msg + (if (symbolp defn) (prin1-to-string defn) + (help-fns-function-name defn))))) defn event mouse-msg))) (defun help--filter-info-list (info-list i) From 0c321ddbd3afcc821567fcb584e18e9f0dd49790 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Fri, 22 Mar 2024 15:24:28 +0800 Subject: [PATCH 122/155] Fix display of custom menus after putative cosmetic change * lisp/wid-edit.el (widget-setup): Restore version from before the previous commit. --- lisp/wid-edit.el | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index f69a3d3b05f..172da3db1e0 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1377,14 +1377,17 @@ When not inside a field, signal an error." (defun widget-setup () "Setup current buffer so editing string widgets works." (widget--allow-insertion - (dolist (field widget-field-new) - (push field widget-field-list) - (let ((from (car (widget-get field :field-overlay))) - (to (cdr (widget-get field :field-overlay)))) - (widget-specify-field field - (marker-position from) (marker-position to)) - (set-marker from nil) - (set-marker to nil)))) + (let (field) + (while widget-field-new + (setq field (car widget-field-new) + widget-field-new (cdr widget-field-new) + widget-field-list (cons field widget-field-list)) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil))))) (widget-clear-undo) (widget-add-change)) From c1530a2e4973005633ebe00d447f1f3aa1200301 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 22 Mar 2024 09:54:37 +0200 Subject: [PATCH 123/155] ; * lisp/help-fns.el (help-fns-function-name): Doc fix. --- lisp/help-fns.el | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 422f6e9dddf..638af81ded8 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -2465,7 +2465,14 @@ one of them returns non-nil." ;;;###autoload (defun help-fns-function-name (function) - "Return a short string representing FUNCTION." + "Return a short buttonized string representing FUNCTION. +The string is propertized with a button; clicking on that +provides further details about FUNCTION. +FUNCTION can be a function, a built-in, a keyboard macro, +or a compile function. +This function is intended to be used to display various +callable symbols in buffers in a way that allows the user +to find out more details about the symbols." ;; FIXME: For kmacros, should we print the key-sequence? (cond ((symbolp function) From accd79c93935b50dddfcd6fe7fb6912c80bcddb1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Mar 2024 21:08:58 -0400 Subject: [PATCH 124/155] (help-fns-function-description-header): Print functions' type Instead of choosing English words to describe the kind of function, use the actual type of the function object (from `cl-type-of`) directly, and make it a button to display info about that type. * lisp/help-fns.el (help-fns-function-description-header): Use the function's type name in the description instead of "prose". Use `insert` instead of `princ`, so as to preserve the text-properties of the button. * lisp/emacs-lisp/cl-extra.el (cl-help-type): Move to `help-mode.el` and rename to `help-type`. (cl--describe-class): Adjust accordingly. * lisp/help-mode.el (help-type): New type, moved and renamed from `cl-extra.el`. --- lisp/emacs-lisp/cl-extra.el | 11 +++-------- lisp/help-fns.el | 31 ++++++++++++++----------------- lisp/help-mode.el | 5 +++++ 3 files changed, 22 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index d43c21d3eb9..437dea2d6a9 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -720,11 +720,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (add-to-list 'find-function-regexp-alist '(define-type . cl--typedef-regexp))) -(define-button-type 'cl-help-type - :supertype 'help-function-def - 'help-function #'cl-describe-type - 'help-echo (purecopy "mouse-2, RET: describe this type")) - (define-button-type 'cl-type-definition :supertype 'help-function-def 'help-echo (purecopy "mouse-2, RET: find type definition")) @@ -777,7 +772,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (insert (symbol-name type) (substitute-command-keys " is a type (of kind `")) (help-insert-xref-button (symbol-name metatype) - 'cl-help-type metatype) + 'help-type metatype) (insert (substitute-command-keys "')")) (when location (insert (substitute-command-keys " in `")) @@ -796,7 +791,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (setq cur (cl--class-name cur)) (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) - 'cl-help-type cur) + 'help-type cur) (insert (substitute-command-keys (if pl "', " "'")))) (insert ".\n"))) @@ -808,7 +803,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" (while (setq cur (pop ch)) (insert (substitute-quotes "`")) (help-insert-xref-button (symbol-name cur) - 'cl-help-type cur) + 'help-type cur) (insert (substitute-command-keys (if ch "', " "'")))) (insert ".\n"))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 638af81ded8..a291893e9a2 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -1061,10 +1061,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (concat "an autoloaded " (if (commandp def) "interactive ")) - (if (commandp def) "an interactive " "a ")))) - - ;; Print what kind of function-like object FUNCTION is. - (princ (cond ((or (stringp def) (vectorp def)) + (if (commandp def) "an interactive " "a "))) + ;; Print what kind of function-like object FUNCTION is. + (description + (cond ((or (stringp def) (vectorp def)) "a keyboard macro") ((and (symbolp function) (get function 'reader-construct)) @@ -1073,12 +1073,6 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; aliases before functions. (aliased (format-message "an alias for `%s'" real-def)) - ((subr-native-elisp-p def) - (concat beg "native-compiled Lisp function")) - ((subrp def) - (concat beg (if (eq 'unevalled (cdr (subr-arity def))) - "special form" - "built-in function"))) ((autoloadp def) (format "an autoloaded %s" (cond @@ -1092,12 +1086,13 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; need to check macros before functions. (macrop function)) (concat beg "Lisp macro")) - ((byte-code-function-p def) - (concat beg "byte-compiled Lisp function")) - ((module-function-p def) - (concat beg "module function")) - ((memq (car-safe def) '(lambda closure)) - (concat beg "Lisp function")) + ((atom def) + (let ((type (or (oclosure-type def) (cl-type-of def)))) + (concat beg (format "%s" + (make-text-button + (symbol-name type) nil + 'type 'help-type + 'help-args (list type)))))) ((keymapp def) (let ((is-full nil) (elts (cdr-safe def))) @@ -1107,7 +1102,9 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." elts nil)) (setq elts (cdr-safe elts))) (concat beg (if is-full "keymap" "sparse keymap")))) - (t ""))) + (t "")))) + (with-current-buffer standard-output + (insert description)) (if (and aliased (not (fboundp real-def))) (princ ",\nwhich is not defined.") diff --git a/lisp/help-mode.el b/lisp/help-mode.el index dd78342ace7..48433d899ab 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -177,6 +177,11 @@ The format is (FUNCTION ARGS...).") 'help-function 'describe-variable 'help-echo (purecopy "mouse-2, RET: describe this variable")) +(define-button-type 'help-type + :supertype 'help-xref + 'help-function #'cl-describe-type + 'help-echo (purecopy "mouse-2, RET: describe this type")) + (define-button-type 'help-face :supertype 'help-xref 'help-function 'describe-face From 7269a2f1586733bd03b569608bd77112b2e6487f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 22 Mar 2024 16:46:28 -0400 Subject: [PATCH 125/155] (pp-fill): Cut before parens and dots The `pp-fill` code sometimes end up generating things like: (foo . bar) instead of (foo . bar) so make sure we cut before rather than after the dot (and open parens while we're at it). * lisp/emacs-lisp/pp.el (pp-fill): Cut before parens and dots. * test/lisp/emacs-lisp/pp-tests.el (pp-tests--dimensions): New function. (pp-tests--cut-before): New test. --- lisp/emacs-lisp/pp.el | 14 +++++++++----- test/lisp/emacs-lisp/pp-tests.el | 30 ++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index de7468b3e38..b48f44545bf 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -193,11 +193,15 @@ it inserts and pretty-prints that arg at point." (and (save-excursion (goto-char beg) - (if (save-excursion (skip-chars-backward " \t({[',") - (bolp)) - ;; The sexp was already on its own line. - nil - (skip-chars-backward " \t") + ;; We skip backward over open parens because cutting + ;; the line right after an open paren does not help + ;; reduce the indentation depth. + ;; Similarly, we prefer to cut before a "." than after + ;; it because it reduces the indentation depth. + (skip-chars-backward " \t({[',.") + (if (bolp) + ;; The sexp already starts on its own line. + (progn (goto-char beg) nil) (setq beg (copy-marker beg t)) (if paired (setq paired (copy-marker paired t))) ;; We could try to undo this insertion if it diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index b663fb365a8..7f7c798cde8 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -36,4 +36,34 @@ (ert-deftest test-indentation () (ert-test-erts-file (ert-resource-file "code-formats.erts"))) +(defun pp-tests--dimensions () + (save-excursion + (let ((width 0) + (height 0)) + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (setq height (1+ height)) + (setq width (max width (current-column))) + (forward-char 1)) + (cons width height)))) + +(ert-deftest pp-tests--cut-before () + (with-temp-buffer + (lisp-data-mode) + (pp '(1 (quite-a-long-package-name + . [(0 10 0) ((avy (0 5 0))) "Quickly switch windows." tar + ((:url . "https://github.com/abo-abo/ace-window") + (:maintainer "Oleh Krehel" . "ohwoeowho@gmail.com") + (:authors ("Oleh Krehel" . "ohwoeowho@gmail.com")) + (:keywords "window" "location"))])) + (current-buffer)) + ;; (message "Filled:\n%s" (buffer-string)) + (let ((dimensions (pp-tests--dimensions))) + (should (< (car dimensions) 80)) + (should (< (cdr dimensions) 8))) + (goto-char (point-min)) + (while (search-forward "." nil t) + (should (not (eolp)))))) + ;;; pp-tests.el ends here. From 3197d7015b854944e326d68c5307b38f0a0d2d53 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 22 Mar 2024 17:03:15 -0400 Subject: [PATCH 126/155] etc/NEWS: Document the new behavior of `describe-function` I pushed commit accd79c93935 by accident. Related to bug#69935 --- etc/NEWS | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index eda84d588a8..f4b4c30855c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -108,6 +108,12 @@ to your init: * Changes in Emacs 30.1 +** 'describe-function' now shows the type of the function object. +The text used to say things like "car is is a built-in function" +whereas it now says "car is a primitive-function" where "primitive-function" +is the symbol returned by `cl-type-of` and you can click on it to get +information about that type. + ** 'advice-remove' is now an interactive command. When called interactively, 'advice-remove' now prompts for an advised function to the advice to remove. From 7e32e8392ab77f9df08a1f11831cbba2242d721f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 22 Mar 2024 18:44:54 -0400 Subject: [PATCH 127/155] Fix recent test regressions * lisp/emacs-lisp/pp.el (pp-fill): Don't cut between `#` and `(`. * test/lisp/help-fns-tests.el (help-fns-test-built-in) (help-fns-test-interactive-built-in, help-fns-test-lisp-defun) (help-fns-test-lisp-defsubst): * test/src/emacs-module-tests.el (module/describe-function-1): Adjust tests to new wording in `describe-function`. --- lisp/emacs-lisp/pp.el | 5 ++++- test/lisp/help-fns-tests.el | 10 +++++----- test/src/emacs-module-tests.el | 2 +- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index b48f44545bf..26c77d6b047 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -198,7 +198,10 @@ it inserts and pretty-prints that arg at point." ;; reduce the indentation depth. ;; Similarly, we prefer to cut before a "." than after ;; it because it reduces the indentation depth. - (skip-chars-backward " \t({[',.") + (while (not (zerop (skip-chars-backward " \t({[',."))) + (and (memq (char-before) '(?# ?s ?f)) + (looking-back "#[sf]?" (- (point) 2)) + (goto-char (match-beginning 0)))) (if (bolp) ;; The sexp already starts on its own line. (progn (goto-char beg) nil) diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 7035c8b7773..1beeb77640c 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -48,12 +48,12 @@ Return first line of the output of (describe-function-1 FUNC)." (should (string-match regexp result)))) (ert-deftest help-fns-test-built-in () - (let ((regexp "a built-in function in .C source code") + (let ((regexp "a primitive-function in .C source code") (result (help-fns-tests--describe-function 'mapcar))) (should (string-match regexp result)))) (ert-deftest help-fns-test-interactive-built-in () - (let ((regexp "an interactive built-in function in .C source code") + (let ((regexp "an interactive primitive-function in .C source code") (result (help-fns-tests--describe-function 're-search-forward))) (should (string-match regexp result)))) @@ -64,13 +64,13 @@ Return first line of the output of (describe-function-1 FUNC)." (ert-deftest help-fns-test-lisp-defun () (let ((regexp (if (featurep 'native-compile) - "a native-compiled Lisp function in .+subr\\.el" - "a byte-compiled Lisp function in .+subr\\.el")) + "a subr-native-elisp in .+subr\\.el" + "a compiled-function in .+subr\\.el")) (result (help-fns-tests--describe-function 'last))) (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defsubst () - (let ((regexp "a byte-compiled Lisp function in .+subr\\.el") + (let ((regexp "a compiled-function in .+subr\\.el") (result (help-fns-tests--describe-function 'posn-window))) (should (string-match regexp result)))) diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index fd0647275a0..052fd83dc85 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -315,7 +315,7 @@ local reference." (replace-match "`src/emacs-module-resources/")) (should (equal (buffer-substring-no-properties 1 (point-max)) - (format "a module function in `src/emacs-module-resources/mod-test%s'. + (format "a module-function in `src/emacs-module-resources/mod-test%s'. (mod-test-sum a b) From d3ca7c68c7e4c4c86341427fc34dd1af74f1a593 Mon Sep 17 00:00:00 2001 From: john muhl Date: Tue, 19 Mar 2024 19:46:12 -0500 Subject: [PATCH 128/155] ; Open inferior Lua buffer in a window, not a frame * lisp/progmodes/lua-ts-mode.el (lua-ts-inferior-lua): Replace 'display-buffer-pop-up-window' with 'display-buffer-pop-up-frame'. (bug#69909) --- lisp/progmodes/lua-ts-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el index 25fd7792f42..b6d6e90680c 100644 --- a/lisp/progmodes/lua-ts-mode.el +++ b/lisp/progmodes/lua-ts-mode.el @@ -628,7 +628,7 @@ Calls REPORT-FN directly." nil t))) (select-window (display-buffer lua-ts-inferior-buffer '((display-buffer-reuse-window - display-buffer-pop-up-frame) + display-buffer-pop-up-window) (reusable-frames . t)))) (get-buffer-process (current-buffer))) From f412892b79dae531ace081f61ec6f3874f9270bc Mon Sep 17 00:00:00 2001 From: john muhl Date: Tue, 12 Mar 2024 11:17:15 -0500 Subject: [PATCH 129/155] ; Remove unneeded group in lua-ts-mode defcustoms * lisp/progmodes/lua-ts-mode.el (lua-ts-mode-hook): (lua-ts-indent-offset): (lua-ts-luacheck-program): (lua-ts-inferior-buffer): (lua-ts-inferior-program): (lua-ts-inferior-options): (lua-ts-inferior-startfile): (lua-ts-inferior-prompt): (lua-ts-inferior-prompt-continue): (lua-ts-inferior-history): (lua-ts-indent-continuation-lines): Remove :group. (bug#69910) --- lisp/progmodes/lua-ts-mode.el | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el index b6d6e90680c..407ef230c32 100644 --- a/lisp/progmodes/lua-ts-mode.el +++ b/lisp/progmodes/lua-ts-mode.el @@ -60,66 +60,56 @@ :options '(flymake-mode hs-minor-mode outline-minor-mode) - :group 'lua-ts :version "30.1") (defcustom lua-ts-indent-offset 4 "Number of spaces for each indentation step in `lua-ts-mode'." :type 'natnum :safe 'natnump - :group 'lua-ts :version "30.1") (defcustom lua-ts-luacheck-program "luacheck" "Location of the Luacheck program." :type '(choice (const :tag "None" nil) string) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-buffer "*Lua*" "Name of the inferior Lua buffer." :type 'string :safe 'stringp - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-program "lua" "Program to run in the inferior Lua process." :type '(choice (const :tag "None" nil) string) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-options '("-i") "Command line options for the inferior Lua process." :type '(repeat string) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-startfile nil "File to load into the inferior Lua process at startup." :type '(choice (const :tag "None" nil) (file :must-match t)) - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-prompt ">" "Prompt used by the inferior Lua process." :type 'string :safe 'stringp - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-prompt-continue ">>" "Continuation prompt used by the inferior Lua process." :type 'string :safe 'stringp - :group 'lua-ts :version "30.1") (defcustom lua-ts-inferior-history nil "File used to save command history of the inferior Lua process." :type '(choice (const :tag "None" nil) file) :safe 'string-or-null-p - :group 'lua-ts :version "30.1") (defcustom lua-ts-indent-continuation-lines t @@ -141,7 +131,6 @@ the statement: end" :type 'boolean :safe 'booleanp - :group 'lua-ts :version "30.1") (defvar lua-ts--builtins From e39cb515a108682b520e499c334a600ee634fbf6 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 23 Mar 2024 15:37:43 +0800 Subject: [PATCH 130/155] Correctly handle non-BMP characters in Android content file names * lisp/term/android-win.el (android-encode-jni) (android-decode-jni, android-jni): New coding system, for Android file names and runtime data. * src/androidterm.h (syms_of_androidvfs): New function. * src/androidvfs.c (struct android_special_vnode): New field special_coding_system. (android_saf_tree_readdir): Decode the file name using the android-jni coding system. (special_vnodes): : Specify a file name coding system. (android_vfs_convert_name): New function. (android_root_name): If a special coding system be specified for a special vnode, convert components to it before invoking its name function. (syms_of_androidvfs): New symbol Qandroid_jni. * src/emacs.c (android_emacs_init): Call syms_of_androidvfs. --- lisp/term/android-win.el | 89 +++++++++++++++++++++++++ src/androidterm.h | 5 +- src/androidvfs.c | 137 ++++++++++++++++++++++++++++++++++----- src/emacs.c | 1 + 4 files changed, 215 insertions(+), 17 deletions(-) diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index 8d262e5da98..6512ef81ff7 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -528,6 +528,95 @@ accessible to other programs." (setq url replacement-url)) (android-browse-url-internal url send)) + +;; Coding systems used by androidvfs.c. + +(define-ccl-program android-encode-jni + `(2 ((loop + (read r0) + (if (r0 < #x1) ; 0x0 is encoded specially in JNI environments. + ((write #xc0) + (write #x80)) + ((if (r0 < #x80) ; ASCII + ((write r0)) + (if (r0 < #x800) ; \u0080 - \u07ff + ((write ((r0 >> 6) | #xC0)) + (write ((r0 & #x3F) | #x80))) + ;; \u0800 - \uFFFF + (if (r0 < #x10000) + ((write ((r0 >> 12) | #xE0)) + (write (((r0 >> 6) & #x3F) | #x80)) + (write ((r0 & #x3F) | #x80))) + ;; Supplementary characters must be converted into + ;; surrogate pairs before encoding. + (;; High surrogate + (r1 = ((((r0 - #x10000) >> 10) & #x3ff) + #xD800)) + ;; Low surrogate. + (r2 = (((r0 - #x10000) & #x3ff) + #xDC00)) + ;; Write both surrogate characters. + (write ((r1 >> 12) | #xE0)) + (write (((r1 >> 6) & #x3F) | #x80)) + (write ((r1 & #x3F) | #x80)) + (write ((r2 >> 12) | #xE0)) + (write (((r2 >> 6) & #x3F) | #x80)) + (write ((r2 & #x3F) | #x80)))))))) + (repeat)))) + "Encode characters from the input buffer for Java virtual machines.") + +(define-ccl-program android-decode-jni + `(1 ((loop + ((read-if (r0 >= #x80) ; More than a one-byte sequence? + ((if (r0 < #xe0) + ;; Two-byte sequence; potentially a NULL + ;; character. + ((read r4) + (r4 &= #x3f) + (r0 = (((r0 & #x1f) << 6) | r4))) + (if (r0 < ?\xF0) + ;; Three-byte sequence, after which surrogate + ;; pairs should be processed. + ((read r4 r6) + (r4 = ((r4 & #x3f) << 6)) + (r6 &= #x3f) + (r0 = ((((r0 & #xf) << 12) | r4) | r6))) + ;; Four-byte sequences are not valid under the + ;; JVM specification, but Android produces them + ;; when encoding Emoji characters for being + ;; supposedly less of a surprise to applications. + ;; This is obviously not true of programs written + ;; to the letter of the documentation, but 50 + ;; million Frenchmen make a right (and this + ;; deviation from the norm is predictably absent + ;; from Android's documentation on the subject). + ((read r1 r4 r6) + (r1 = ((r1 & #x3f) << 12)) + (r4 = ((r4 & #x3f) << 6)) + (r6 &= #x3F) + (r0 = (((((r0 & #x07) << 18) | r1) | r4) | r6)))))))) + (if ((r0 & #xf800) == #xd800) + ;; High surrogate. + ((read-if (r2 >= #xe0) + ((r0 = ((r0 & #x3ff) << 10)) + (read r4 r6) + (r4 = ((r4 & #x3f) << 6)) + (r6 &= #x3f) + (r1 = ((((r2 & #xf) << 12) | r4) | r6)) + (r0 = (((r1 & #x3ff) | r0) + #xffff)))))) + (write r0) + (repeat)))) + "Decode JVM-encoded characters in the input buffer.") + +(define-coding-system 'android-jni + "CESU-8 based encoding for communication with the Android runtime." + :mnemonic ?J + :coding-type 'ccl + :eol-type 'unix + :ascii-compatible-p nil ; for \0 is encoded as a two-byte sequence. + :default-char ?\0 + :charset-list '(unicode) + :ccl-decoder 'android-decode-jni + :ccl-encoder 'android-encode-jni) + (provide 'android-win) ;; android-win.el ends here. diff --git a/src/androidterm.h b/src/androidterm.h index ca6929bef0e..fd4cc99f641 100644 --- a/src/androidterm.h +++ b/src/androidterm.h @@ -461,7 +461,7 @@ extern void sfntfont_android_shrink_scanline_buffer (void); extern void init_sfntfont_android (void); extern void syms_of_sfntfont_android (void); -/* Defined in androidselect.c */ +/* Defined in androidselect.c. */ #ifndef ANDROID_STUBIFY @@ -473,6 +473,9 @@ extern void android_notification_action (struct android_notification_event *, extern void init_androidselect (void); extern void syms_of_androidselect (void); +/* Defined in androidvfs.c. */ +extern void syms_of_androidvfs (void); + #endif diff --git a/src/androidvfs.c b/src/androidvfs.c index 9e3d5cab8cf..6a9ddb33c56 100644 --- a/src/androidvfs.c +++ b/src/androidvfs.c @@ -38,8 +38,10 @@ along with GNU Emacs. If not, see . */ #include #include "android.h" +#include "androidterm.h" #include "systime.h" #include "blockinput.h" +#include "coding.h" #if __ANDROID_API__ >= 9 #include @@ -248,8 +250,14 @@ struct android_special_vnode /* Function called to create the initial vnode from the rest of the component. */ struct android_vnode *(*initial) (char *, size_t); + + /* If non-nil, an encoding system into which file name buffers are to + be re-encoded before being handed to VFS functions. */ + Lisp_Object special_coding_system; }; +verify (NIL_IS_ZERO); /* special_coding_system above. */ + enum android_vnode_type { ANDROID_VNODE_UNIX, @@ -3867,7 +3875,8 @@ android_saf_root_readdir (struct android_vdir *vdir) NULL); android_exception_check_nonnull ((void *) chars, string); - /* Figure out how large it is, and then resize dirent to fit. */ + /* Figure out how large it is, and then resize dirent to fit--this + string is always ASCII. */ length = strlen (chars) + 1; size = offsetof (struct dirent, d_name) + length; dirent = xrealloc (dirent, size); @@ -5479,6 +5488,7 @@ android_saf_tree_readdir (struct android_vdir *vdir) jmethodID method; size_t length, size; const char *chars; + struct coding_system coding; dir = (struct android_saf_tree_vdir *) vdir; @@ -5526,9 +5536,25 @@ android_saf_tree_readdir (struct android_vdir *vdir) NULL); android_exception_check_nonnull ((void *) chars, d_name); - /* Figure out how large it is, and then resize dirent to fit. */ + /* Decode this JNI string into utf-8-emacs; see + android_vfs_convert_name for considerations regarding coding + systems. */ + length = strlen (chars); + setup_coding_system (Qandroid_jni, &coding); + coding.mode |= CODING_MODE_LAST_BLOCK; + coding.source = (const unsigned char *) chars; + coding.dst_bytes = 0; + coding.destination = NULL; + decode_coding_object (&coding, Qnil, 0, 0, length, length, Qnil); + + /* Release the string data and the local reference to STRING. */ + (*android_java_env)->ReleaseStringUTFChars (android_java_env, + (jstring) d_name, + chars); + + /* Resize dirent to accommodate the decoded text. */ length = strlen (chars) + 1; - size = offsetof (struct dirent, d_name) + length; + size = offsetof (struct dirent, d_name) + 1 + coding.produced; dirent = xrealloc (dirent, size); /* Clear dirent. */ @@ -5540,12 +5566,12 @@ android_saf_tree_readdir (struct android_vdir *vdir) dirent->d_off = 0; dirent->d_reclen = size; dirent->d_type = d_type ? DT_DIR : DT_UNKNOWN; - strcpy (dirent->d_name, chars); + memcpy (dirent->d_name, coding.destination, coding.produced); + dirent->d_name[coding.produced] = '\0'; + + /* Free the coding system destination buffer. */ + xfree (coding.destination); - /* Release the string data and the local reference to STRING. */ - (*android_java_env)->ReleaseStringUTFChars (android_java_env, - (jstring) d_name, - chars); ANDROID_DELETE_LOCAL_REF (d_name); return dirent; } @@ -6531,9 +6557,35 @@ static struct android_vops root_vfs_ops = static struct android_special_vnode special_vnodes[] = { { "assets", 6, android_afs_initial, }, - { "content", 7, android_content_initial, }, + { "content", 7, android_content_initial, + LISPSYM_INITIALLY (Qandroid_jni), }, }; +/* Convert the file name NAME from Emacs's internal character encoding + to CODING, and return a Lisp string with the data so produced. + + Calling this function creates an implicit assumption that + file-name-coding-system is compatible with utf-8-emacs, which is not + unacceptable as users with cause to modify file-name-coding-system + should be aware and prepared for consequences towards files stored on + different filesystems, including virtual ones. */ + +static Lisp_Object +android_vfs_convert_name (const char *name, Lisp_Object coding) +{ + Lisp_Object src_coding, name1; + + src_coding = Qutf_8_emacs; + + /* Convert the contents of the buffer after BUFFER_END + from the file name coding system to + special->special_coding_system. */ + AUTO_STRING (file_name, name); + name1 = code_convert_string_norecord (file_name, src_coding, false); + name1 = code_convert_string (name1, coding, Qt, true, true, true); + return name1; +} + static struct android_vnode * android_root_name (struct android_vnode *vnode, char *name, size_t length) @@ -6541,6 +6593,8 @@ android_root_name (struct android_vnode *vnode, char *name, char *component_end; struct android_special_vnode *special; size_t i; + Lisp_Object file_name; + struct android_vnode *vp; /* Skip any leading separator in NAME. */ @@ -6567,8 +6621,29 @@ android_root_name (struct android_vnode *vnode, char *name, if (component_end - name == special->length && !memcmp (special->name, name, special->length)) - return (*special->initial) (component_end, - length - special->length); + { + if (!NILP (special->special_coding_system)) + { + USE_SAFE_ALLOCA; + + file_name + = android_vfs_convert_name (component_end, + special->special_coding_system); + + /* Allocate a buffer and copy file_name into the same. */ + length = SBYTES (file_name) + 1; + name = SAFE_ALLOCA (length + 1); + + /* Copy the trailing NULL byte also. */ + memcpy (name, SDATA (file_name), length); + vp = (*special->initial) (name, length - 1); + SAFE_FREE (); + return vp; + } + + return (*special->initial) (component_end, + length - special->length); + } /* Detect the case where a special is named with a trailing directory separator. */ @@ -6576,9 +6651,30 @@ android_root_name (struct android_vnode *vnode, char *name, if (component_end - name == special->length + 1 && !memcmp (special->name, name, special->length) && name[special->length] == '/') - /* Make sure to include the directory separator. */ - return (*special->initial) (component_end - 1, - length - special->length); + { + if (!NILP (special->special_coding_system)) + { + USE_SAFE_ALLOCA; + + file_name + = android_vfs_convert_name (component_end - 1, + special->special_coding_system); + + /* Allocate a buffer and copy file_name into the same. */ + length = SBYTES (file_name) + 1; + name = SAFE_ALLOCA (length + 1); + + /* Copy the trailing NULL byte also. */ + memcpy (name, SDATA (file_name), length); + vp = (*special->initial) (name, length - 1); + SAFE_FREE (); + return vp; + } + + /* Make sure to include the directory separator. */ + return (*special->initial) (component_end - 1, + length - special->length); + } } /* Otherwise, continue searching for a vnode normally. */ @@ -6589,8 +6685,9 @@ android_root_name (struct android_vnode *vnode, char *name, /* File system lookup. */ -/* Look up the vnode that designates NAME, a file name that is at - least N bytes. +/* Look up the vnode that designates NAME, a file name that is at least + N bytes, converting between different file name coding systems as + necessary. NAME may be either an absolute file name or a name relative to the current working directory. It must not be longer than EMACS_PATH_MAX @@ -7605,3 +7702,11 @@ android_closedir (struct android_vdir *dirp) { return (*dirp->closedir) (dirp); } + + + +void +syms_of_androidvfs (void) +{ + DEFSYM (Qandroid_jni, "android-jni"); +} diff --git a/src/emacs.c b/src/emacs.c index f4bfb9a6bbd..87f12d3fa86 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2444,6 +2444,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #if !defined ANDROID_STUBIFY syms_of_androidfont (); syms_of_androidselect (); + syms_of_androidvfs (); syms_of_sfntfont (); syms_of_sfntfont_android (); #endif /* !ANDROID_STUBIFY */ From 6235212d736ca4f0b0a1900c42c30d82747d7798 Mon Sep 17 00:00:00 2001 From: Dionisio E Alonso Date: Wed, 20 Mar 2024 17:06:30 +0200 Subject: [PATCH 131/155] Add BasedPyright LSP server alternative for Eglot's 'python-mode' * lisp/progmodes/eglot.el (eglot-server-programs): Add BasedPyright, a new server for python, forked from the unmaintained 'pyright' LSP server. (Bug#69925) Copyright-paperwork-exempt: yes --- lisp/progmodes/eglot.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index b3fd104a227..7d2f1a55165 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -238,7 +238,8 @@ automatically)." (vimrc-mode . ("vim-language-server" "--stdio")) ((python-mode python-ts-mode) . ,(eglot-alternatives - '("pylsp" "pyls" ("pyright-langserver" "--stdio") + '("pylsp" "pyls" ("basedpyright-langserver" "--stdio") + ("pyright-langserver" "--stdio") "jedi-language-server" "ruff-lsp"))) ((js-json-mode json-mode json-ts-mode) . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio") From e52bc9ef6f7942b15d876566aca52340210ac27c Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 Mar 2024 09:51:47 +0200 Subject: [PATCH 132/155] Avoid infinite recursion in 'image-mode--display' * lisp/image-mode.el (image-mode): Suspend major mode only if it is not already 'image-mode'. (Bug#69785) --- lisp/image-mode.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 355685e70fd..fa64f1ac03e 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -654,8 +654,9 @@ Key bindings: (unless (display-images-p) (error "Display does not support images")) - (major-mode-suspend) - (setq major-mode 'image-mode) + (unless (eq major-mode 'image-mode) + (major-mode-suspend) + (setq major-mode 'image-mode)) (setq image-transform-resize image-auto-resize) ;; Bail out early if we have no image data. From 2fb6f252bfe2cd06a49975bc97a794fb70392538 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 Mar 2024 11:09:57 +0200 Subject: [PATCH 133/155] Improve support for preprocessor macros in 'c/c++-ts-mode' * lisp/progmodes/c-ts-mode.el (c-ts-mode--defun-name) (c-ts-base-mode): Support preprocessor macros as defuns. This fixes both navigation by defuns and add-log when cpp macros are at point. --- lisp/progmodes/c-ts-mode.el | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index a2e7f6fba2e..8383979a373 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -911,7 +911,8 @@ Return nil if NODE is not a defun node or doesn't have a name." t)) ((or "struct_specifier" "enum_specifier" "union_specifier" "class_specifier" - "namespace_definition") + "namespace_definition" + "preproc_def" "preproc_function_def") (treesit-node-child-by-field-name node "name")) ;; DEFUNs in Emacs sources. ("expression_statement" @@ -1205,7 +1206,9 @@ BEG and END are described in `treesit-range-rules'." "enum_specifier" "union_specifier" "class_specifier" - "namespace_definition") + "namespace_definition" + "preproc_def" + "preproc_function_def") (and c-ts-mode-emacs-sources-support '(;; DEFUN. "expression_statement" From 5769a1053087a278d48836e1f366e0bd87c95809 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 Mar 2024 11:50:55 +0200 Subject: [PATCH 134/155] ; Fix doc strings of some treesit-related functions * lisp/treesit.el (treesit-defun-tactic) (treesit-defun-name-function, treesit-thing-at-point) (treesit-defun-at-point): * lisp/progmodes/c-ts-common.el (c-ts-common-statement-offset): * lisp/progmodes/c-ts-mode.el (c-ts-mode-toggle-comment-style) (c-ts-mode-indent-style, c-ts-mode-emacs-sources-support) (c-ts-mode--syntax-propertize, c-ts-mode--anchor-prev-sibling) (c-ts-mode--standalone-parent-skip-preproc) (c-ts-mode--standalone-grandparent, c-ts-mode--else-heuristic) (c-ts-mode--declarator-identifier) (c-ts-mode--fontify-declarator, c-ts-mode--fontify-variable) (c-ts-mode--defun-valid-p) (c-ts-mode--defun-for-class-in-imenu-p) (c-ts-mode--defun-skipper, c-ts-mode--emacs-defun-p) (c-ts-mode--emacs-defun-at-point) (c-ts-mode--emacs-current-defun-name, c-ts-mode--reverse-ranges) (c-ts-mode, c++-ts-mode, c-or-c++-ts-mode): Doc fixes. --- lisp/progmodes/c-ts-common.el | 2 +- lisp/progmodes/c-ts-mode.el | 64 ++++++++++++++++++----------------- lisp/treesit.el | 21 ++++++------ 3 files changed, 44 insertions(+), 43 deletions(-) diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 0095d83e302..e48bcc64f14 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -332,7 +332,7 @@ Assumes the anchor is (point-min), i.e., the 0th column. This function basically counts the number of block nodes (i.e., brackets) (see `c-ts-common-indent-type-regexp-alist') between NODE and the root node (not counting NODE itself), and -multiply that by `c-ts-common-indent-offset'. +multiplies that by `c-ts-common-indent-offset'. To support GNU style, on each block level, this function also checks whether the opening bracket { is on its own line, if so, diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 8383979a373..3a89f0f494b 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -97,7 +97,7 @@ "Toggle the comment style between block and line comments. Optional numeric ARG, if supplied, switches to block comment style when positive, to line comment style when negative, and -just toggles it when zero or left out." +just toggles it when zero or omitted." (interactive "P") (let ((prevstate-line (string= comment-start "// "))) (when (or (not arg) @@ -147,9 +147,9 @@ symbol." "Style used for indentation. The selected style could be one of GNU, K&R, LINUX or BSD. If -one of the supplied styles doesn't suffice, a function could be -set instead. This function is expected to return a list that -follows the form of `treesit-simple-indent-rules'." +one of the supplied styles doesn't suffice, the value could be +a function instead. This function is expected to return a list +that follows the form of `treesit-simple-indent-rules'." :version "29.1" :type '(choice (symbol :tag "Gnu" gnu) (symbol :tag "K&R" k&r) @@ -202,8 +202,8 @@ To set the default indent style globally, use (if (derived-mode-p 'c-ts-mode) 'c 'cpp)))))) (defcustom c-ts-mode-emacs-sources-support t - "Whether to enable Emacs source-specific features. -This enables detection of definitions of Lisp function using + "Whether to enable Emacs source-specific C features. +This enables detection of definitions of Lisp functions via the DEFUN macro. This needs to be set before enabling `c-ts-mode'; if you change the value after enabling `c-ts-mode', toggle the mode off and on @@ -243,7 +243,7 @@ again." < and > are usually punctuation, e.g., in ->. But when used for templates, they should be considered pairs. -This function checks for < and > in the changed RANGES and apply +This function checks for < and > in the changed RANGES and applies appropriate text property to alter the syntax of template delimiters < and >'s." (goto-char beg) @@ -284,9 +284,9 @@ is actually the parent of point at the moment of indentation." "Return the start of the previous named sibling of NODE. This anchor handles the special case where the previous sibling -is a labeled_statement, in that case, return the child of the +is a labeled_statement; in that case, return the child of the labeled statement instead. (Actually, recursively go down until -the node isn't a labeled_statement.) Eg, +the node isn't a labeled_statement.) E.g., label: int x = 1; @@ -295,10 +295,11 @@ label: The anchor of \"int y = 2;\" should be \"int x = 1;\" rather than the labeled_statement. -Return nil if a) there is no prev-sibling, or 2) prev-sibling +Return nil if a) there is no prev-sibling, or b) prev-sibling doesn't have a child. -PARENT and BOL are like other anchor functions." +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 @@ -336,7 +337,7 @@ PARENT and BOL are like other anchor functions." (defun c-ts-mode--standalone-parent-skip-preproc (_n parent &rest _) "Like the standalone-parent anchor but skips preproc nodes. -PARENT is the same as other anchor functions." +PARENT is the parent of the current node." (save-excursion (treesit-node-start (treesit-parent-until @@ -353,13 +354,15 @@ PARENT is the same as other anchor functions." (defun c-ts-mode--standalone-grandparent (_node parent bol &rest args) "Like the standalone-parent anchor but pass it the grandparent. -PARENT, BOL, ARGS are the same as other anchor functions." +PARENT is NODE's parent, BOL is the beginning of non-whitespace +characters of the current line." (apply (alist-get 'standalone-parent treesit-simple-indent-presets) parent (treesit-node-parent parent) bol args)) (defun c-ts-mode--else-heuristic (node parent bol &rest _) "Heuristic matcher for when \"else\" is followed by a closing bracket. -NODE, PARENT, and BOL are the same as in other matchers." +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) @@ -757,7 +760,7 @@ MODE is either `c' or `cpp'." (defun c-ts-mode--declarator-identifier (node &optional qualified) "Return the identifier of the declarator node NODE. -If QUALIFIED is non-nil, include the names space part of the +If QUALIFIED is non-nil, include the namespace part of the identifier and return a qualified_identifier." (pcase (treesit-node-type node) ;; Recurse. @@ -782,7 +785,7 @@ identifier and return a qualified_identifier." node))) (defun c-ts-mode--fontify-declarator (node override start end &rest _args) - "Fontify a declarator (whatever under the \"declarator\" field). + "Fontify a declarator (whatever is under the \"declarator\" field). For NODE, OVERRIDE, START, END, and ARGS, see `treesit-font-lock-rules'." (let* ((identifier (c-ts-mode--declarator-identifier node)) @@ -817,7 +820,7 @@ For NODE, OVERRIDE, START, END, and ARGS, see (defun c-ts-mode--fontify-variable (node override start end &rest _) "Fontify an identifier node if it is a variable. -Don't fontify if it is a function identifier. For NODE, +Don't fontify it if it is a function identifier. For NODE, OVERRIDE, START, END, and ARGS, see `treesit-font-lock-rules'." (when (not (equal (treesit-node-type (treesit-node-parent node)) @@ -938,7 +941,7 @@ Return nil if NODE is not a defun node or doesn't have a name." (defun c-ts-mode--defun-valid-p (node) "Return non-nil if NODE is a valid defun node. -Ie, NODE is not nested." +That is, NODE is not nested." (let ((top-level-p (lambda (node) (not (treesit-node-top-level node (rx (or "function_definition" @@ -977,8 +980,7 @@ Basically, if NODE is a class, return non-nil; if NODE is a function but is under a class, return non-nil; if NODE is a top-level function, return nil. -This is for the Class subindex in -`treesit-simple-imenu-settings'." +This is for the Class subindex in `treesit-simple-imenu-settings'." (pcase (treesit-node-type node) ;; The Class subindex only has class_specifier and ;; function_definition. @@ -989,7 +991,7 @@ This is for the Class subindex in (defun c-ts-mode--defun-skipper () "Custom defun skipper for `c-ts-mode' and friends. -Structs in C ends with a semicolon, but the semicolon is not +Structs in C end with a semicolon, but the semicolon is not considered part of the struct node, so point would stop before the semicolon. This function skips the semicolon." (when (looking-at (rx (* (or " " "\t")) ";")) @@ -1009,7 +1011,7 @@ the semicolon. This function skips the semicolon." (list node parent bol))) (defun c-ts-mode--emacs-defun-p (node) - "Return non-nil if NODE is a Lisp function defined using DEFUN. + "Return non-nil if NODE is a Lisp function defined via DEFUN. This function detects Lisp primitives defined in Emacs source files using the DEFUN macro." (and (equal (treesit-node-type node) "expression_statement") @@ -1030,15 +1032,15 @@ files using the DEFUN macro." "Return the defun node at point. In addition to regular C functions, this function recognizes -definitions of Lisp primitrives in Emacs source files using DEFUN, -if `c-ts-mode-emacs-sources-support' is non-nil. +definitions of Lisp primitrives in Emacs source files defined +via DEFUN, if `c-ts-mode-emacs-sources-support' is non-nil. Note that DEFUN is parsed by tree-sitter as two separate nodes, one for the declaration and one for the body; this function returns the declaration node. If RANGE is non-nil, return (BEG . END) where BEG end END -encloses the whole defun. This is for when the entire defun +enclose the whole defun. This is for when the entire defun is required, not just the declaration part for DEFUN." (when-let* ((node (treesit-defun-at-point)) (defun-range (cons (treesit-node-start node) @@ -1067,7 +1069,7 @@ is required, not just the declaration part for DEFUN." "Return the name of the current defun. This is used for `add-log-current-defun-function'. In addition to regular C functions, this function also recognizes -Emacs primitives defined using DEFUN in Emacs sources, +Emacs primitives defined via DEFUN in Emacs sources, if `c-ts-mode-emacs-sources-support' is non-nil." (or (treesit-add-log-current-defun) (c-ts-mode--defun-name (c-ts-mode--emacs-defun-at-point)))) @@ -1145,7 +1147,7 @@ For BOL see `treesit-simple-indent-rules'." (defun c-ts-mode--reverse-ranges (ranges beg end) "Reverse RANGES and return the new ranges between BEG and END. -Positions that were included RANGES are not in the returned +Positions that were included in RANGES are not in the returned ranges, and vice versa. Return nil if RANGES is nil. This way, passing the returned @@ -1287,7 +1289,7 @@ BEG and END are described in `treesit-range-rules'." This mode is independent from the classic cc-mode.el based `c-mode', so configuration variables of that mode, like -`c-basic-offset', doesn't affect this mode. +`c-basic-offset', don't affect this mode. To use tree-sitter C/C++ modes by default, evaluate @@ -1296,7 +1298,7 @@ To use tree-sitter C/C++ modes by default, evaluate (add-to-list \\='major-mode-remap-alist \\='(c-or-c++-mode . c-or-c++-ts-mode)) -in your configuration." +in your init files." :group 'c :after-hook (c-ts-mode-set-modeline) @@ -1348,7 +1350,7 @@ To use tree-sitter C/C++ modes by default, evaluate (add-to-list \\='major-mode-remap-alist \\='(c-or-c++-mode . c-or-c++-ts-mode)) -in your configuration. +in your init files. Since this mode uses a parser, unbalanced brackets might cause some breakage in indentation/fontification. Therefore, it's @@ -1443,7 +1445,7 @@ matching on file name insufficient for detecting major mode that should be used. This function attempts to use file contents to determine whether -the code is C or C++ and based on that chooses whether to enable +the code is C or C++, and based on that chooses whether to enable `c-ts-mode' or `c++-ts-mode'." (declare (obsolete c-or-c++-mode "30.1")) (interactive) diff --git a/lisp/treesit.el b/lisp/treesit.el index fa82ad898a9..2b4893e6129 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -2237,7 +2237,7 @@ for invalid node. This is used by `treesit-beginning-of-defun' and friends.") (defvar-local treesit-defun-tactic 'nested - "Determines how does Emacs treat nested defuns. + "Determines how Emacs treats nested defuns. If the value is `top-level', Emacs only moves across top-level defuns, if the value is `nested', Emacs recognizes nested defuns.") @@ -2253,9 +2253,8 @@ If the value is nil, no skipping is performed.") (defvar-local treesit-defun-name-function nil "A function that is called with a node and returns its defun name or nil. If the node is a defun node, return the defun name, e.g., the -function name of a function. If the node is not a defun node, or -the defun node doesn't have a name, or the node is nil, return -nil.") +name of a function. If the node is not a defun node, or the +defun node doesn't have a name, or the node is nil, return nil.") (defvar-local treesit-add-log-defun-delimiter "." "The delimiter used to connect several defun names. @@ -2728,12 +2727,12 @@ function is called recursively." ;; TODO: In corporate into thing-at-point. (defun treesit-thing-at-point (thing tactic) - "Return the THING at point or nil if none is found. + "Return the THING at point, or nil if none is found. -THING can be a symbol, regexp, a predicate function, and more, +THING can be a symbol, a regexp, a predicate function, and more; see `treesit-thing-settings' for details. -Return the top-level THING if TACTIC is `top-level', return the +Return the top-level THING if TACTIC is `top-level'; return the smallest enclosing THING as POS if TACTIC is `nested'." (let ((node (treesit--thing-at (point) thing))) @@ -2742,11 +2741,11 @@ smallest enclosing THING as POS if TACTIC is `nested'." node))) (defun treesit-defun-at-point () - "Return the defun node at point or nil if none is found. + "Return the defun node at point, or nil if none is found. -Respects `treesit-defun-tactic': return the top-level defun if it -is `top-level', return the immediate parent defun if it is -`nested'. +Respects `treesit-defun-tactic': returns the top-level defun if it +is `top-level', otherwise return the immediate parent defun if it +is `nested'. Return nil if `treesit-defun-type-regexp' isn't set and `defun' isn't defined in `treesit-thing-settings'." From 023a5fe5a3bd2f20eb168bc4763fa98e14201fff Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 23 Mar 2024 18:12:56 +0800 Subject: [PATCH 135/155] Minor adjustments to last change * src/androidvfs.c (android_vfs_convert_name): Simplify. (android_saf_tree_readdir, android_root_name): Remove redundant statements. --- src/androidvfs.c | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/src/androidvfs.c b/src/androidvfs.c index 6a9ddb33c56..a9035ae53c6 100644 --- a/src/androidvfs.c +++ b/src/androidvfs.c @@ -5553,7 +5553,6 @@ android_saf_tree_readdir (struct android_vdir *vdir) chars); /* Resize dirent to accommodate the decoded text. */ - length = strlen (chars) + 1; size = offsetof (struct dirent, d_name) + 1 + coding.produced; dirent = xrealloc (dirent, size); @@ -6573,15 +6572,11 @@ static struct android_special_vnode special_vnodes[] = static Lisp_Object android_vfs_convert_name (const char *name, Lisp_Object coding) { - Lisp_Object src_coding, name1; + Lisp_Object name1; - src_coding = Qutf_8_emacs; - - /* Convert the contents of the buffer after BUFFER_END - from the file name coding system to - special->special_coding_system. */ - AUTO_STRING (file_name, name); - name1 = code_convert_string_norecord (file_name, src_coding, false); + /* Convert the contents of the buffer after BUFFER_END from the file + name coding system to special->special_coding_system. */ + name1 = build_string (name); name1 = code_convert_string (name1, coding, Qt, true, true, true); return name1; } @@ -6632,7 +6627,7 @@ android_root_name (struct android_vnode *vnode, char *name, /* Allocate a buffer and copy file_name into the same. */ length = SBYTES (file_name) + 1; - name = SAFE_ALLOCA (length + 1); + name = SAFE_ALLOCA (length); /* Copy the trailing NULL byte also. */ memcpy (name, SDATA (file_name), length); @@ -6662,7 +6657,7 @@ android_root_name (struct android_vnode *vnode, char *name, /* Allocate a buffer and copy file_name into the same. */ length = SBYTES (file_name) + 1; - name = SAFE_ALLOCA (length + 1); + name = SAFE_ALLOCA (length); /* Copy the trailing NULL byte also. */ memcpy (name, SDATA (file_name), length); From 0e83cbd90ecdf793b2422d9219886d91ea4c385a Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sat, 23 Mar 2024 18:14:12 +0800 Subject: [PATCH 136/155] Enable calling decode_coding_object with both SRC and DST_OBJECT Qnil * src/coding.c (growable_destination): A C destination is also reallocable. (produce_chars): Don't consider source and destination identical if they are EQ but Qnil. --- src/coding.c | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/src/coding.c b/src/coding.c index ff7cf56c297..3f314b46d5e 100644 --- a/src/coding.c +++ b/src/coding.c @@ -614,10 +614,11 @@ inhibit_flag (int encoded_flag, bool var) static bool growable_destination (struct coding_system *coding) { - return STRINGP (coding->dst_object) || BUFFERP (coding->dst_object); + return (STRINGP (coding->dst_object) + || BUFFERP (coding->dst_object) + || NILP (coding->dst_object)); } - /* Safely get one byte from the source text pointed by SRC which ends at SRC_END, and set C to that byte. If there are not enough bytes in the source, it jumps to 'no_more_source'. If MULTIBYTEP, @@ -7005,7 +7006,6 @@ get_translation (Lisp_Object trans, int *buf, int *buf_end, ptrdiff_t *nchars) return Qnil; } - static int produce_chars (struct coding_system *coding, Lisp_Object translation_table, bool last_block) @@ -7063,7 +7063,10 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, || ckd_add (&dst_size, dst_size, buf_end - buf)) memory_full (SIZE_MAX); dst = alloc_destination (coding, dst_size, dst); - if (EQ (coding->src_object, coding->dst_object)) + if (EQ (coding->src_object, coding->dst_object) + /* Input and output are not C buffers, which are safe to + assume to be different. */ + && !NILP (coding->src_object)) { coding_set_source (coding); dst_end = (((unsigned char *) coding->source) @@ -7098,7 +7101,10 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, const unsigned char *src = coding->source; const unsigned char *src_end = src + coding->consumed; - if (EQ (coding->dst_object, coding->src_object)) + if (EQ (coding->dst_object, coding->src_object) + /* Input and output are not C buffers, which are safe to + assume to be different. */ + && !NILP (coding->src_object)) { eassert (growable_destination (coding)); dst_end = (unsigned char *) src; @@ -7119,7 +7125,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, if (dst == dst_end) { eassert (growable_destination (coding)); - if (EQ (coding->src_object, coding->dst_object)) + if (EQ (coding->src_object, coding->dst_object) + && !NILP (coding->src_object)) dst_end = (unsigned char *) src; if (dst == dst_end) { @@ -7131,7 +7138,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, coding_set_source (coding); src = coding->source + offset; src_end = coding->source + coding->consumed; - if (EQ (coding->src_object, coding->dst_object)) + if (EQ (coding->src_object, coding->dst_object) + && !NILP (coding->src_object)) dst_end = (unsigned char *) src; } } @@ -7150,14 +7158,16 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, if (dst >= dst_end - 1) { eassert (growable_destination (coding)); - if (EQ (coding->src_object, coding->dst_object)) + if (EQ (coding->src_object, coding->dst_object) + && !NILP (coding->src_object)) dst_end = (unsigned char *) src; if (dst >= dst_end - 1) { ptrdiff_t offset = src - coding->source; ptrdiff_t more_bytes; - if (EQ (coding->src_object, coding->dst_object)) + if (EQ (coding->src_object, coding->dst_object) + && !NILP (coding->src_object)) more_bytes = ((src_end - src) / 2) + 2; else more_bytes = src_end - src + 2; @@ -7166,7 +7176,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, coding_set_source (coding); src = coding->source + offset; src_end = coding->source + coding->consumed; - if (EQ (coding->src_object, coding->dst_object)) + if (EQ (coding->src_object, coding->dst_object) + && !NILP (coding->src_object)) dst_end = (unsigned char *) src; } } @@ -7175,7 +7186,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, } else { - if (!EQ (coding->src_object, coding->dst_object)) + if (!EQ (coding->src_object, coding->dst_object) + && !NILP (coding->src_object)) { ptrdiff_t require = coding->src_bytes - coding->dst_bytes; From 8d7a3ed3495968fd3e95a6126e7c23e25b7c495f Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 Mar 2024 18:54:39 +0200 Subject: [PATCH 137/155] * src/coding.c (produce_chars): Fix a thinko (bug#69966). --- src/coding.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/coding.c b/src/coding.c index 3f314b46d5e..c51ceb95475 100644 --- a/src/coding.c +++ b/src/coding.c @@ -7186,8 +7186,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table, } else { - if (!EQ (coding->src_object, coding->dst_object) - && !NILP (coding->src_object)) + if (!(EQ (coding->src_object, coding->dst_object) + && !NILP (coding->src_object))) { ptrdiff_t require = coding->src_bytes - coding->dst_bytes; From abc2d39e0102f8bb554d89da3c0ffe57188220ff Mon Sep 17 00:00:00 2001 From: Spencer Baugh Date: Sat, 16 Mar 2024 17:11:24 +0000 Subject: [PATCH 138/155] Use 'regexp-opt' in 'dired-omit-regexp' In my benchmarking, for large dired buffers, using 'regexp-opt' provides around a 3x speedup in omitting. 'regexp-opt' takes around 5 milliseconds, so to avoid slowing down omitting in small dired buffers we cache the return value. Since omitting is now 3x faster, increase 'dired-omit-size-limit' by 3x. Also, document 'dired-omit-size-limit' better. * doc/misc/dired-x.texi (Omitting Variables): Document 'dired-omit-size-limit'. * etc/NEWS: Announce increase of 'dired-omit-size-limit'. * lisp/dired-x.el (dired-omit--extension-regexp-cache): Add. (dired-omit-regexp): Use 'regexp-opt'. (Bug#69775) (dired-omit-size-limit): Increase and improve docs. --- doc/misc/dired-x.texi | 9 +++++++++ etc/NEWS | 6 ++++++ lisp/dired-x.el | 26 ++++++++++++++++++++------ 3 files changed, 35 insertions(+), 6 deletions(-) diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi index 4cad016a0f6..726b6653d0d 100644 --- a/doc/misc/dired-x.texi +++ b/doc/misc/dired-x.texi @@ -346,6 +346,15 @@ only match against the non-directory part of the file name. Set it to match the file name relative to the buffer's top-level directory. @end defvar +@defvar dired-omit-size-limit +If non-@code{nil}, @code{dired-omit-mode} will be effectively disabled +in directories whose listing has size (in bytes) larger than the value +of this option. Since omitting can be slow for very large directories, +this avoids having to wait before seeing the directory. This variable +is ignored when @code{dired-omit-mode} is called interactively, such as +by @code{C-x M-o}, so you can still enable omitting in the directory +after the initial display. + @cindex omitting additional files @defvar dired-omit-marker-char Temporary marker used by Dired to implement omitting. Should never be used diff --git a/etc/NEWS b/etc/NEWS index f4b4c30855c..e9cb455aa40 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -705,6 +705,12 @@ marked or clicked on files according to the OS conventions. For example, on systems supporting XDG, this runs 'xdg-open' on the files. +*** The default value of 'dired-omit-size-limit' was increased. +After performance improvements to omitting in large directories, the new +default value is 300k, up from 100k. This means 'dired-omit-mode' will +omit files in directories whose directory listing is up to 300 kilobytes +in size. + +++ *** 'dired-listing-switches' handles connection-local values if exist. This allows to customize different switches for different remote machines. diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 62fdd916e69..753d3054d2f 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -77,12 +77,17 @@ files not writable by you are visited read-only." (other :tag "non-writable only" if-file-read-only)) :group 'dired-x) -(defcustom dired-omit-size-limit 100000 - "Maximum size for the \"omitting\" feature. +(defcustom dired-omit-size-limit 300000 + "Maximum buffer size for `dired-omit-mode'. + +Omitting will be disabled if the directory listing exceeds this size in +bytes. This variable is ignored when `dired-omit-mode' is called +interactively. + If nil, there is no maximum size." :type '(choice (const :tag "no maximum" nil) integer) :group 'dired-x - :version "29.1") + :version "30.1") (defcustom dired-omit-case-fold 'filesystem "Determine whether \"omitting\" patterns are case-sensitive. @@ -506,14 +511,23 @@ status message." (re-search-forward dired-re-mark nil t)))) count))) +(defvar dired-omit--extension-regexp-cache + nil + "A cache of `regexp-opt' applied to `dired-omit-extensions'. + +This is a cons whose car is a list of strings and whose cdr is a +regexp produced by `regexp-opt'.") + (defun dired-omit-regexp () + (unless (equal dired-omit-extensions (car dired-omit--extension-regexp-cache)) + (setq dired-omit--extension-regexp-cache + (cons dired-omit-extensions (regexp-opt dired-omit-extensions)))) (concat (if dired-omit-files (concat "\\(" dired-omit-files "\\)") "") (if (and dired-omit-files dired-omit-extensions) "\\|" "") (if dired-omit-extensions (concat ".";; a non-extension part should exist - "\\(" - (mapconcat 'regexp-quote dired-omit-extensions "\\|") - "\\)$") + (cdr dired-omit--extension-regexp-cache) + "$") ""))) ;; Returns t if any work was done, nil otherwise. From af1e36d0c66350113869df9e840e5f21b750ce9d Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 Mar 2024 19:10:17 +0200 Subject: [PATCH 139/155] ; * doc/misc/dired-x.texi (Omitting Variables): Fix markup. --- doc/misc/dired-x.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi index 726b6653d0d..ee0bcdb76c4 100644 --- a/doc/misc/dired-x.texi +++ b/doc/misc/dired-x.texi @@ -352,7 +352,7 @@ in directories whose listing has size (in bytes) larger than the value of this option. Since omitting can be slow for very large directories, this avoids having to wait before seeing the directory. This variable is ignored when @code{dired-omit-mode} is called interactively, such as -by @code{C-x M-o}, so you can still enable omitting in the directory +by @kbd{C-x M-o}, so you can still enable omitting in the directory after the initial display. @cindex omitting additional files From 72972118e6f5831f200108cd7b80bf86538c265e Mon Sep 17 00:00:00 2001 From: Jim Porter Date: Sun, 17 Mar 2024 12:01:59 -0700 Subject: [PATCH 140/155] Allow toggling "readable" mode in EWW Additionally, add an option to prevent adding a new history entry for each call of 'eww-readable' (bug#68254). * lisp/net/eww.el (eww-retrieve): * lisp/net/eww.el (eww-readable-adds-to-history): New option. (eww-retrieve): Make sure we call CALLBACK in all configurations. (eww-render): Simplify how to pass encoding. (eww--parse-html-region, eww-display-document): New functions, extracted from... (eww-display-html): ... here. (eww-document-base): New function. (eww-readable): Toggle "readable" mode interactively, like with a minor mode. Consult 'eww-readable-adds-to-history'. (eww-reload): Use 'eshell-display-document'. * test/lisp/net/eww-tests.el (eww-test--with-mock-retrieve): Fix indent. (eww-test/display/html, eww-test/readable/toggle-display): New tests. * doc/misc/eww.texi (Basics): Describe the new behavior. * etc/NEWS: Announce this change. --- doc/misc/eww.texi | 5 ++ etc/NEWS | 12 ++++ lisp/net/eww.el | 127 ++++++++++++++++++++++++------------- test/lisp/net/eww-tests.el | 57 ++++++++++++++++- 4 files changed, 155 insertions(+), 46 deletions(-) diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index d31fcf1802b..522034c874d 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -146,6 +146,11 @@ a new tab is created on the frame tab bar. which part of the document contains the ``readable'' text, and will only display this part. This usually gets rid of menus and the like. + When called interactively, this command toggles the display of the +readable parts. With a positive prefix argument, this command always +displays the readable parts, and with a zero or negative prefix, it +always displays the full page. + @findex eww-toggle-fonts @vindex shr-use-fonts @kindex F diff --git a/etc/NEWS b/etc/NEWS index e9cb455aa40..30eaaf40385 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1066,6 +1066,18 @@ entries newer than the current page. To change the behavior when browsing from "historical" pages, you can customize 'eww-before-browse-history-function'. ++++ +*** 'eww-readable' now toggles display of the readable parts of a web page. +When called interactively, 'eww-readable' toggles whether to display +only the readable parts of a page or the full page. With a positive +prefix argument, it always displays the readable parts, and with a zero +or negative prefix, it always displays the full page. + +--- +*** New option 'eww-readable-adds-to-history'. +When non-nil (the default), calling 'eww-readable' adds a new entry to +the EWW page history. + ** go-ts-mode +++ diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 54847bdf396..54b65d35164 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -275,6 +275,11 @@ parameter, and should return the (possibly) transformed URL." :type '(repeat function) :version "29.1") +(defcustom eww-readable-adds-to-history t + "If non-nil, calling `eww-readable' adds a new entry to the history." + :type 'boolean + :version "30.1") + (defface eww-form-submit '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) @@ -464,11 +469,11 @@ For more information, see Info node `(eww) Top'." (defun eww-retrieve (url callback cbargs) (cond ((null eww-retrieve-command) - (url-retrieve url #'eww-render cbargs)) + (url-retrieve url callback cbargs)) ((eq eww-retrieve-command 'sync) (let ((data-buffer (url-retrieve-synchronously url))) (with-current-buffer data-buffer - (apply #'eww-render nil cbargs)))) + (apply callback nil cbargs)))) (t (let ((buffer (generate-new-buffer " *eww retrieve*")) (error-buffer (generate-new-buffer " *eww error*"))) @@ -673,9 +678,9 @@ The renaming scheme is performed in accordance with (insert (format "Direct link to the document" url)) (goto-char (point-min)) - (eww-display-html charset url nil point buffer encode)) + (eww-display-html (or encode charset) url nil point buffer)) ((eww-html-p (car content-type)) - (eww-display-html charset url nil point buffer encode)) + (eww-display-html (or encode charset) url nil point buffer)) ((equal (car content-type) "application/pdf") (eww-display-pdf)) ((string-match-p "\\`image/" (car content-type)) @@ -726,34 +731,40 @@ The renaming scheme is performed in accordance with (declare-function libxml-parse-html-region "xml.c" (start end &optional base-url discard-comments)) -(defun eww-display-html (charset url &optional document point buffer encode) +(defun eww--parse-html-region (start end &optional coding-system) + "Parse the HTML between START and END, returning the DOM as an S-expression. +Use CODING-SYSTEM to decode the region; if nil, decode as UTF-8. + +This replaces the region with the preprocessed HTML." + (setq coding-system (or coding-system 'utf-8)) + (with-restriction start end + (condition-case nil + (decode-coding-region (point-min) (point-max) coding-system) + (coding-system-error nil)) + ;; Remove CRLF and replace NUL with � before parsing. + (while (re-search-forward "\\(\r$\\)\\|\0" nil t) + (replace-match (if (match-beginning 1) "" "�") t t)) + (eww--preprocess-html (point-min) (point-max)) + (libxml-parse-html-region (point-min) (point-max)))) + +(defsubst eww-document-base (url dom) + `(base ((href . ,url)) ,dom)) + +(defun eww-display-document (document &optional point buffer) (unless (fboundp 'libxml-parse-html-region) (error "This function requires Emacs to be compiled with libxml2")) + (setq buffer (or buffer (current-buffer))) (unless (buffer-live-p buffer) (error "Buffer %s doesn't exist" buffer)) ;; There should be a better way to abort loading images ;; asynchronously. (setq url-queue nil) - (let ((document - (or document - (list - 'base (list (cons 'href url)) - (progn - (setq encode (or encode charset 'utf-8)) - (condition-case nil - (decode-coding-region (point) (point-max) encode) - (coding-system-error nil)) - (save-excursion - ;; Remove CRLF and replace NUL with � before parsing. - (while (re-search-forward "\\(\r$\\)\\|\0" nil t) - (replace-match (if (match-beginning 1) "" "�") t t))) - (eww--preprocess-html (point) (point-max)) - (libxml-parse-html-region (point) (point-max)))))) - (source (and (null document) - (buffer-substring (point) (point-max))))) + (let ((url (when (eq (car document) 'base) + (alist-get 'href (cadr document))))) + (unless url + (error "Document is missing base URL")) (with-current-buffer buffer (setq bidi-paragraph-direction nil) - (plist-put eww-data :source source) (plist-put eww-data :dom document) (let ((inhibit-read-only t) (inhibit-modification-hooks t) @@ -794,6 +805,16 @@ The renaming scheme is performed in accordance with (forward-line 1))))) (eww-size-text-inputs)))) +(defun eww-display-html (charset url &optional document point buffer) + (let ((source (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (plist-put eww-data :source source))) + (eww-display-document + (or document + (eww-document-base + url (eww--parse-html-region (point) (point-max) charset))) + point buffer)) + (defun eww-handle-link (dom) (let* ((rel (dom-attr dom 'rel)) (href (dom-attr dom 'href)) @@ -1055,30 +1076,47 @@ The renaming scheme is performed in accordance with "automatic" bidi-paragraph-direction))) -(defun eww-readable () - "View the main \"readable\" parts of the current web page. +(defun eww-readable (&optional arg) + "Toggle display of only the main \"readable\" parts of the current web page. This command uses heuristics to find the parts of the web page that -contains the main textual portion, leaving out navigation menus and -the like." - (interactive nil eww-mode) +contain the main textual portion, leaving out navigation menus and the +like. + +If called interactively, toggle the display of the readable parts. If +the prefix argument is positive, display the readable parts, and if it +is zero or negative, display the full page. + +If called from Lisp, toggle the display of the readable parts if ARG is +`toggle'. Display the readable parts if ARG is nil, omitted, or is a +positive number. Display the full page if ARG is a negative number. + +When `eww-readable-adds-to-history' is non-nil, calling this function +adds a new entry to `eww-history'." + (interactive (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle)) + eww-mode) (let* ((old-data eww-data) - (dom (with-temp-buffer + (make-readable (cond + ((eq arg 'toggle) + (not (plist-get old-data :readable))) + ((and (numberp arg) (< arg 1)) + nil) + (t t))) + (dom (with-temp-buffer (insert (plist-get old-data :source)) - (condition-case nil - (decode-coding-region (point-min) (point-max) 'utf-8) - (coding-system-error nil)) - (eww--preprocess-html (point-min) (point-max)) - (libxml-parse-html-region (point-min) (point-max)))) + (eww--parse-html-region (point-min) (point-max)))) (base (plist-get eww-data :url))) - (eww-score-readability dom) - (eww-save-history) - (eww--before-browse) - (eww-display-html nil nil - (list 'base (list (cons 'href base)) - (eww-highest-readability dom)) - nil (current-buffer)) - (dolist (elem '(:source :url :title :next :previous :up :peer)) - (plist-put eww-data elem (plist-get old-data elem))) + (when make-readable + (eww-score-readability dom) + (setq dom (eww-highest-readability dom))) + (when eww-readable-adds-to-history + (eww-save-history) + (eww--before-browse) + (dolist (elem '(:source :url :title :next :previous :up :peer)) + (plist-put eww-data elem (plist-get old-data elem)))) + (eww-display-document (eww-document-base base dom)) + (plist-put eww-data :readable make-readable) (eww--after-page-change))) (defun eww-score-readability (node) @@ -1398,8 +1436,7 @@ just re-display the HTML already fetched." (if local (if (null (plist-get eww-data :dom)) (error "No current HTML data") - (eww-display-html 'utf-8 url (plist-get eww-data :dom) - (point) (current-buffer))) + (eww-display-document (plist-get eww-data :dom) (point))) (let ((parsed (url-generic-parse-url url))) (if (equal (url-type parsed) "file") ;; Use Tramp instead of url.el for files (since url.el diff --git a/test/lisp/net/eww-tests.el b/test/lisp/net/eww-tests.el index bd00893d503..a09e0a4f279 100644 --- a/test/lisp/net/eww-tests.el +++ b/test/lisp/net/eww-tests.el @@ -33,7 +33,7 @@ body.") "Evaluate BODY with a mock implementation of `eww-retrieve'. This avoids network requests during our tests. Additionally, prepare a temporary EWW buffer for our tests." - (declare (indent 1)) + (declare (indent 0)) `(cl-letf (((symbol-function 'eww-retrieve) (lambda (url callback args) (with-temp-buffer @@ -48,6 +48,24 @@ temporary EWW buffer for our tests." ;;; Tests: +(ert-deftest eww-test/display/html () + "Test displaying a simple HTML page." + (eww-test--with-mock-retrieve + (let ((eww-test--response-function + (lambda (url) + (concat "Content-Type: text/html\n\n" + (format "

Hello

%s" + url))))) + (eww "example.invalid") + ;; Check that the buffer contains the rendered HTML. + (should (equal (buffer-string) "Hello\n\n\nhttp://example.invalid/\n")) + (should (equal (get-text-property (point-min) 'face) + '(shr-text shr-h1))) + ;; Check that the DOM includes the `base'. + (should (equal (pcase (plist-get eww-data :dom) + (`(base ((href . ,url)) ,_) url)) + "http://example.invalid/"))))) + (ert-deftest eww-test/history/new-page () "Test that when visiting a new page, the previous one goes into the history." (eww-test--with-mock-retrieve @@ -176,5 +194,42 @@ This sets `eww-before-browse-history-function' to "http://one.invalid/"))) (should (= eww-history-position 0))))) +(ert-deftest eww-test/readable/toggle-display () + "Test toggling the display of the \"readable\" parts of a web page." + (eww-test--with-mock-retrieve + (let* ((shr-width most-positive-fixnum) + (shr-use-fonts nil) + (words (string-join + (make-list + 20 "All work and no play makes Jack a dull boy.") + " ")) + (eww-test--response-function + (lambda (_url) + (concat "Content-Type: text/html\n\n" + "" + "This is an uninteresting sentence." + "
" + words + "
" + "")))) + (eww "example.invalid") + ;; Make sure EWW renders the whole document. + (should-not (plist-get eww-data :readable)) + (should (string-prefix-p + "This is an uninteresting sentence." + (buffer-substring-no-properties (point-min) (point-max)))) + (eww-readable 'toggle) + ;; Now, EWW should render just the "readable" parts. + (should (plist-get eww-data :readable)) + (should (string-match-p + (concat "\\`" (regexp-quote words) "\n*\\'") + (buffer-substring-no-properties (point-min) (point-max)))) + (eww-readable 'toggle) + ;; Finally, EWW should render the whole document again. + (should-not (plist-get eww-data :readable)) + (should (string-prefix-p + "This is an uninteresting sentence." + (buffer-substring-no-properties (point-min) (point-max))))))) + (provide 'eww-tests) ;; eww-tests.el ends here From 4b0f5cdb01fbd05c8184a89fa8543eb5600fb4f8 Mon Sep 17 00:00:00 2001 From: Jim Porter Date: Mon, 18 Mar 2024 16:52:34 -0700 Subject: [PATCH 141/155] Add 'eww-readable-urls' * lisp/net/eww.el (eww-readable-urls): New option. (eww-default-readable-p): New function... (eww-display-html): ... use it. * test/lisp/net/eww-tests.el (eww-test/readable/default-readable): New test. * doc/misc/eww.texi (Basics): Document 'eww-readable-urls'. * etc/NEWS: Announce this change (bug#68254). --- doc/misc/eww.texi | 16 ++++++++++++++ etc/NEWS | 6 ++++++ lisp/net/eww.el | 43 +++++++++++++++++++++++++++++++++----- test/lisp/net/eww-tests.el | 12 +++++++++++ 4 files changed, 72 insertions(+), 5 deletions(-) diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index 522034c874d..eec6b3c3299 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -151,6 +151,22 @@ readable parts. With a positive prefix argument, this command always displays the readable parts, and with a zero or negative prefix, it always displays the full page. +@vindex eww-readable-urls + If you want EWW to render a certain page in ``readable'' mode by +default, you can add a regular expression matching its URL to +@code{eww-readable-urls}. Each entry can either be a regular expression +in string form or a cons cell of the form +@w{@code{(@var{regexp} . @var{readability})}}. If @var{readability} is +non-@code{nil}, this behaves the same as the string form; otherwise, +URLs matching @var{regexp} will never be displayed in readable mode by +default. For example, you can use this to make all pages default to +readable mode, except for a few outliers: + +@example +(setq eww-readable-urls '(("https://example\\.com/" . nil) + ".*")) +@end example + @findex eww-toggle-fonts @vindex shr-use-fonts @kindex F diff --git a/etc/NEWS b/etc/NEWS index 30eaaf40385..c6b654a9d3b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1073,6 +1073,12 @@ only the readable parts of a page or the full page. With a positive prefix argument, it always displays the readable parts, and with a zero or negative prefix, it always displays the full page. ++++ +*** New option 'eww-readable-urls'. +This is a list of regular expressions matching the URLs where EWW should +display only the readable parts by default. For more details, see +"(eww) Basics" in the EWW manual. + --- *** New option 'eww-readable-adds-to-history'. When non-nil (the default), calling 'eww-readable' adds a new entry to diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 54b65d35164..39ea964d47a 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -275,6 +275,22 @@ parameter, and should return the (possibly) transformed URL." :type '(repeat function) :version "29.1") +(defcustom eww-readable-urls nil + "A list of regexps matching URLs to display in readable mode by default. +EWW will display matching URLs using `eww-readable' (which see). + +Each element can be one of the following forms: a regular expression in +string form or a cons cell of the form (REGEXP . READABILITY). If +READABILITY is non-nil, this behaves the same as the string form; +otherwise, URLs matching REGEXP will never be displayed in readable mode +by default." + :type '(repeat (choice (string :tag "Readable URL") + (cons :tag "URL and Readability" + (string :tag "URL") + (radio (const :tag "Readable" t) + (const :tag "Non-readable" nil))))) + :version "30.1") + (defcustom eww-readable-adds-to-history t "If non-nil, calling `eww-readable' adds a new entry to the history." :type 'boolean @@ -809,11 +825,15 @@ This replaces the region with the preprocessed HTML." (let ((source (buffer-substring (point) (point-max)))) (with-current-buffer buffer (plist-put eww-data :source source))) - (eww-display-document - (or document - (eww-document-base - url (eww--parse-html-region (point) (point-max) charset))) - point buffer)) + (unless document + (let ((dom (eww--parse-html-region (point) (point-max) charset))) + (when (eww-default-readable-p url) + (eww-score-readability dom) + (setq dom (eww-highest-readability dom)) + (with-current-buffer buffer + (plist-put eww-data :readable t))) + (setq document (eww-document-base url dom)))) + (eww-display-document document point buffer)) (defun eww-handle-link (dom) (let* ((rel (dom-attr dom 'rel)) @@ -1159,6 +1179,19 @@ adds a new entry to `eww-history'." (setq result highest)))) result)) +(defun eww-default-readable-p (url) + "Return non-nil if URL should be displayed in readable mode by default. +This consults the entries in `eww-readable-urls' (which see)." + (catch 'found + (let (result) + (dolist (regexp eww-readable-urls) + (if (consp regexp) + (setq result (cdr regexp) + regexp (car regexp)) + (setq result t)) + (when (string-match regexp url) + (throw 'found result)))))) + (defvar-keymap eww-mode-map "g" #'eww-reload ;FIXME: revert-buffer-function instead! "G" #'eww diff --git a/test/lisp/net/eww-tests.el b/test/lisp/net/eww-tests.el index a09e0a4f279..b83435e0bd9 100644 --- a/test/lisp/net/eww-tests.el +++ b/test/lisp/net/eww-tests.el @@ -231,5 +231,17 @@ This sets `eww-before-browse-history-function' to "This is an uninteresting sentence." (buffer-substring-no-properties (point-min) (point-max))))))) +(ert-deftest eww-test/readable/default-readable () + "Test that EWW displays readable parts of pages by default when applicable." + (eww-test--with-mock-retrieve + (let* ((eww-test--response-function + (lambda (_url) + (concat "Content-Type: text/html\n\n" + "Hello there"))) + (eww-readable-urls '("://example\\.invalid/"))) + (eww "example.invalid") + ;; Make sure EWW uses "readable" mode. + (should (plist-get eww-data :readable))))) + (provide 'eww-tests) ;; eww-tests.el ends here From 79c758187cef7fc1f93fd525b9d81be81ee2b2cc Mon Sep 17 00:00:00 2001 From: Joseph Turner Date: Thu, 7 Mar 2024 21:55:00 -0800 Subject: [PATCH 142/155] Recompute :map when image :scale, :rotation, or :flip changes Now, when transforming an image, its :map is recomputed to fit. Image map coordinates are integers, so when computing :map, coordinates are rounded. To prevent an image from drifting from its map after repeated transformations, 'create-image' now adds a new image property :original-map, which is combined with the image's transformation parameters to recompute :map. * lisp/image.el (image-recompute-map-p): Add user option to control whether :map is recomputed when an image is transformed. (create-image): Create :map from :original-map and vice versa. (image--delayed-change-size): Fix comment. (image--change-size, image-rotate, image-flip-horizontally, image-flip-vertically): Recompute image map after transformation and mention 'image-recompute-map-p' in docstring. (image--compute-map): Add function to compute a map from original map. (image--compute-original-map): Add function to compute an original map from map. (image--scale-map): Add function to scale a map based on :scale. (image--rotate-map): Add function to rotate a map based on :rotation. (image--rotate-coord): Add function to rotate a map coordinate pair. (image--flip-map): Add function to flip a map based on :flip. (image-increase-size, image-decrease-size, image-mouse-increase-size) (image-mouse-decrease-size): Mention 'image-recompute-map-p' in docstrings. * etc/NEWS: Add NEWS entry. * doc/lispref/display.texi (Image Descriptors): Document :original-map and new user option 'image-recompute-map-p'. * test/lisp/image-tests.el (image--compute-map-and-original-map): Test 'image--compute-map' and 'image--compute-original-map'. (image-tests--map-equal): Add equality predicate to compare image maps. (image-create-image-with-map): Test that 'create-image' adds :map and/or :original-map as appropriate. (image-transform-map): Test functions related to transforming maps. (Bug#69602) --- doc/lispref/display.texi | 24 +++++ etc/NEWS | 12 +++ lisp/image.el | 221 ++++++++++++++++++++++++++++++++++++--- test/lisp/image-tests.el | 144 +++++++++++++++++++++++++ 4 files changed, 389 insertions(+), 12 deletions(-) diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index beca470d68a..b497967c445 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6056,6 +6056,30 @@ to make things match up, you should either specify @code{:scale 1.0} when creating the image, or use the result of @code{image-compute-scaling-factor} to compute the elements of the map. + +When an image's @code{:scale}, @code{:rotation}, or @code{:flip} is +changed, @code{:map} will be recomputed based on the value of +@code{:original-map} and the values of those transformation. + +@item :original-map @var{original-map} +@cindex original image map +This specifies the untransformed image map which will be used to +recompute @code{:map} after the image's @code{:scale}, @code{:rotation}, +or @code{:flip} is changed. + +If @code{:original-map} is not specified when creating an image with +@code{create-image}, it will be computed based on the supplied +@code{:map}, as well as any of @code{:scale}, @code{:rotation}, or +@code{:flip} which are non-nil. + +Conversely, if @code{:original-map} is specified but @code{:map} is not, +@code{:map} will be computed based on @code{:original-map}, +@code{:scale}, @code{:rotation}, and @code{:flip}. + +@defopt image-recompute-map-p +Set this user option to nil to prevent Emacs from automatically +recomputing an image @code{:map} based on its @code{:original-map}. +@end defopt @end table @defun image-mask-p spec &optional frame diff --git a/etc/NEWS b/etc/NEWS index c6b654a9d3b..19588fe8eeb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1368,6 +1368,18 @@ without specifying a file, like this: (notifications-notify :title "I am playing music" :app-icon 'multimedia-player) +** Image + ++++ +*** Image :map property is now recomputed when image is transformed. +Now images with clickable maps work as expected after you run commands +such as `image-increase-size', `image-decrease-size', `image-rotate', +`image-flip-horizontally', and `image-flip-vertically'. + ++++ +*** New user option 'image-recompute-map-p' +Set this option to nil to prevent Emacs from recomputing image maps. + ** Image Dired *** New user option 'image-dired-thumb-naming'. diff --git a/lisp/image.el b/lisp/image.el index c13fea6c45c..55340ea03dc 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -560,6 +560,16 @@ Images should not be larger than specified by `max-image-size'." ('t t) ('nil nil) (func (funcall func image))))))) + ;; Add original map from map. + (when (and (plist-get props :map) + (not (plist-get props :original-map))) + (setq image (nconc image (list :original-map + (image--compute-original-map image))))) + ;; Add map from original map. + (when (and (plist-get props :original-map) + (not (plist-get props :map))) + (setq image (nconc image (list :map + (image--compute-map image))))) image))) (defun image--default-smoothing (image) @@ -1208,7 +1218,10 @@ has no effect." If N is 3, then the image size will be increased by 30%. More generally, the image size is multiplied by 1 plus N divided by 10. N defaults to 2, which increases the image size by 20%. -POSITION can be a buffer position or a marker, and defaults to point." +POSITION can be a buffer position or a marker, and defaults to point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "P") (image--delayed-change-size (if n (1+ (/ (prefix-numeric-value n) 10.0)) @@ -1220,7 +1233,7 @@ POSITION can be a buffer position or a marker, and defaults to point." (defun image--delayed-change-size (size position) ;; Wait for a bit of idle-time before actually performing the change, ;; so as to batch together sequences of closely consecutive size changes. - ;; `image--change-size' just changes one value in a plist. The actual + ;; `image--change-size' just changes two values in a plist. The actual ;; image resizing happens later during redisplay. So if those ;; consecutive calls happen without any redisplay between them, ;; the costly operation of image resizing should happen only once. @@ -1231,7 +1244,10 @@ POSITION can be a buffer position or a marker, and defaults to point." If N is 3, then the image size will be decreased by 30%. More generally, the image size is multiplied by 1 minus N divided by 10. N defaults to 2, which decreases the image size by 20%. -POSITION can be a buffer position or a marker, and defaults to point." +POSITION can be a buffer position or a marker, and defaults to point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "P") (image--delayed-change-size (if n (- 1 (/ (prefix-numeric-value n) 10.0)) @@ -1243,7 +1259,10 @@ POSITION can be a buffer position or a marker, and defaults to point." (defun image-mouse-increase-size (&optional event) "Increase the image size using the mouse-gesture EVENT. This increases the size of the image at the position specified by -EVENT, if any, by the default factor used by `image-increase-size'." +EVENT, if any, by the default factor used by `image-increase-size'. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "e") (when (listp event) (save-window-excursion @@ -1253,7 +1272,10 @@ EVENT, if any, by the default factor used by `image-increase-size'." (defun image-mouse-decrease-size (&optional event) "Decrease the image size using the mouse-gesture EVENT. This decreases the size of the image at the position specified by -EVENT, if any, by the default factor used by `image-decrease-size'." +EVENT, if any, by the default factor used by `image-decrease-size'. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive "e") (when (listp event) (save-window-excursion @@ -1304,7 +1326,9 @@ POSITION can be a buffer position or a marker, and defaults to point." (new-image (image--image-without-parameters image)) (scale (image--current-scaling image new-image))) (setcdr image (cdr new-image)) - (plist-put (cdr image) :scale (* scale factor)))) + (plist-put (cdr image) :scale (* scale factor)) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image))))) (defun image--image-without-parameters (image) (cons (pop image) @@ -1331,7 +1355,10 @@ POSITION can be a buffer position or a marker, and defaults to point." If nil, ANGLE defaults to 90. Interactively, rotate the image 90 degrees clockwise with no prefix argument, and counter-clockwise with a prefix argument. Note that most image types support -rotations by only multiples of 90 degrees." +rotations by only multiples of 90 degrees. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive (and current-prefix-arg '(-90))) (let ((image (image--get-imagemagick-and-warn))) (setf (image-property image :rotation) @@ -1339,7 +1366,9 @@ rotations by only multiples of 90 degrees." (or angle 90)) ;; We don't want to exceed 360 degrees rotation, ;; because it's not seen as valid in Exif data. - 360)))) + 360))) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image)))) (set-transient-map image--repeat-map nil nil "Use %k for further adjustments")) @@ -1360,23 +1389,191 @@ changing the displayed image size does not affect the saved image." (read-file-name "Write image to file: "))))) (defun image-flip-horizontally () - "Horizontally flip the image under point." + "Horizontally flip the image under point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive) (let ((image (image--get-image))) (image-flush image) (setf (image-property image :flip) - (not (image-property image :flip))))) + (not (image-property image :flip))) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image))))) (defun image-flip-vertically () - "Vertically flip the image under point." + "Vertically flip the image under point. + +When user option `image-recompute-map-p' is non-nil, the image's `:map' +is recomputed to fit the newly transformed image." (interactive) (let ((image (image--get-image))) (image-rotate 180) (setf (image-property image :flip) - (not (image-property image :flip))))) + (not (image-property image :flip))) + (when (and (image-property image :original-map) image-recompute-map-p) + (setf (image-property image :map) (image--compute-map image))))) (define-obsolete-function-alias 'image-refresh #'image-flush "29.1") +;;; Map transformation + +(defcustom image-recompute-map-p t + "Recompute image map when scaling, rotating, or flipping an image." + :type 'boolean + :version "30.1") + +(defun image--compute-map (image) + "Compute map for IMAGE suitable to be used as its :map property. +Return a copy of :original-image 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." + (pcase-let* ((original-map (image-property image :original-map)) + (map (copy-tree original-map t)) + (scale (or (image-property image :scale) 1)) + (rotation (or (image-property image :rotation) 0)) + (flip (image-property image :flip)) + ((and size `(,width . ,height)) (image-size image t))) + (when (and ; Handle only 90-degree rotations + (zerop (mod rotation 1)) + (zerop (% (truncate rotation) 90))) + ;; SIZE fits MAP after transformations. Scale MAP before + ;; flip and rotate operations, since both need MAP to fit SIZE. + (image--scale-map map scale) + ;; In rendered images, rotation is always applied before flip. + (image--rotate-map + map rotation (if (or (= 90 rotation) (= 270 rotation)) + ;; If rotated ±90°, swap width and height. + (cons height width) + size)) + ;; After rotation, there's no need to swap width and height. + (image--flip-map map flip size)) + map)) + +(defun image--compute-original-map (image) + "Return original map for IMAGE. +If IMAGE lacks :map property, return nil. +When :rotation is not a multiple of 90, return copy of :map." + (when (image-property image :map) + (let* ((image-copy (copy-tree image t)) + (map (image-property image-copy :map)) + (scale (or (image-property image-copy :scale) 1)) + (rotation (or (image-property image-copy :rotation) 0)) + (flip (image-property image-copy :flip)) + (size (image-size image-copy t))) + (when (and ; Handle only 90-degree rotations + (zerop (mod rotation 1)) + (zerop (% (truncate rotation) 90))) + ;; In rendered images, rotation is always applied before flip. + ;; To undo the transformation, flip before rotating. + ;; SIZE fits MAP before it is transformed back to ORIGINAL-MAP. + ;; Therefore, scale MAP after flip and rotate operations, since + ;; both need MAP to fit SIZE. + (image--flip-map map flip size) + (image--rotate-map map (- rotation) size) + (image--scale-map map (/ 1.0 scale))) + map))) + +(defun image--scale-map (map scale) + "Scale MAP according to SCALE. +Destructively modifies and returns MAP." + (unless (= 1 scale) + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (setf (caar coords) (round (* (caar coords) scale))) + (setf (cdar coords) (round (* (cdar coords) scale))) + (setf (cadr coords) (round (* (cadr coords) scale))) + (setf (cddr coords) (round (* (cddr coords) scale)))) + ('circle + (setf (caar coords) (round (* (caar coords) scale))) + (setf (cdar coords) (round (* (cdar coords) scale))) + (setcdr coords (round (* (cdr coords) scale)))) + ('poly + (dotimes (i (length coords)) + (aset coords i + (round (* (aref coords i) scale)))))))) + map) + +(defun image--rotate-map (map rotation size) + "Rotate MAP according to ROTATION and SIZE. +Destructively modifies and returns MAP." + (unless (zerop rotation) + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (let ( x0 y0 ; New upper left corner + x1 y1) ; New bottom right corner + (pcase (truncate (mod rotation 360)) ; Set new corners to... + (90 ; ...old bottom left and upper right + (setq x0 (caar coords) y0 (cddr coords) + x1 (cadr coords) y1 (cdar coords))) + (180 ; ...old bottom right and upper left + (setq x0 (cadr coords) y0 (cddr coords) + x1 (caar coords) y1 (cdar coords))) + (270 ; ...old upper right and bottom left + (setq x0 (cadr coords) y0 (cdar coords) + x1 (caar coords) y1 (cddr coords)))) + (setcar coords (image--rotate-coord x0 y0 rotation size)) + (setcdr coords (image--rotate-coord x1 y1 rotation size)))) + ('circle + (setcar coords (image--rotate-coord + (caar coords) (cdar coords) rotation size))) + ('poly + (dotimes (i (length coords)) + (when (= 0 (% i 2)) + (pcase-let ((`(,x . ,y) + (image--rotate-coord + (aref coords i) (aref coords (1+ i)) rotation size))) + (aset coords i x) + (aset coords (1+ i) y)))))))) + map) + +(defun image--rotate-coord (x y angle size) + "Rotate coordinates X and Y by ANGLE in image of SIZE. +ANGLE must be a multiple of 90. Returns a cons cell of rounded +coordinates (X1 Y1)." + (pcase-let* ((radian (* (/ angle 180.0) float-pi)) + (`(,width . ,height) size) + ;; y is positive, but we are in the bottom-right quadrant + (y (- y)) + ;; Rotate clockwise + (x1 (+ (* (sin radian) y) (* (cos radian) x))) + (y1 (- (* (cos radian) y) (* (sin radian) x))) + ;; Translate image back into bottom-right quadrant + (`(,x1 . ,y1) + (pcase (truncate (mod angle 360)) + (90 ; Translate right by height + (cons (+ x1 height) y1)) + (180 ; Translate right by width and down by height + (cons (+ x1 width) (- y1 height))) + (270 ; Translate down by width + (cons x1 (- y1 width))))) + ;; Invert y1 to make both x1 and y1 positive + (y1 (- y1))) + (cons (round x1) (round y1)))) + +(defun image--flip-map (map flip size) + "Horizontally flip MAP according to FLIP and SIZE. +Destructively modifies and returns MAP." + (when flip + (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map) + (pcase-exhaustive type + ('rect + (let ((x0 (- (car size) (cadr coords))) + (y0 (cdar coords)) + (x1 (- (car size) (caar coords))) + (y1 (cddr coords))) + (setcar coords (cons x0 y0)) + (setcdr coords (cons x1 y1)))) + ('circle + (setf (caar coords) (- (car size) (caar coords)))) + ('poly + (dotimes (i (length coords)) + (when (= 0 (% i 2)) + (aset coords i (- (car size) (aref coords i))))))))) + map) + (provide 'image) ;;; image.el ends here diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index 80142d6d6de..6a5f03e38a0 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -153,4 +153,148 @@ (image-rotate -154.5) (should (equal image '(image :rotation 91.0))))) +;;;; Transforming maps + +(ert-deftest image-create-image-with-map () + "Test that `create-image' correctly adds :map and/or :original-map." + (skip-unless (display-images-p)) + (let ((data "foo") + (map '(((circle (1 . 1) . 1) a))) + (original-map '(((circle (2 . 2) . 2) a))) + (original-map-other '(((circle (3 . 3) . 3) a)))) + ;; Generate :original-map from :map. + (let* ((image (create-image data 'svg t :map map :scale 0.5)) + (got-original-map (image-property image :original-map))) + (should (equal got-original-map original-map))) + ;; Generate :map from :original-map. + (let* ((image (create-image + data 'svg t :original-map original-map :scale 0.5)) + (got-map (image-property image :map))) + (should (equal got-map map))) + ;; Use :original-map if both it and :map are specified. + (let* ((image (create-image + data 'svg t :map map + :original-map original-map-other :scale 0.5)) + (got-original-map (image-property image :original-map))) + (should (equal got-original-map original-map-other))))) + +(defun image-tests--map-equal (a b &optional tolerance) + "Return t if maps A and B have the same coordinates within TOLERANCE. +Since image sizes calculations vary on different machines, this function +allows for each image map coordinate in A to be within TOLERANCE to the +corresponding coordinate in B. When nil, TOLERANCE defaults to 5." + (unless tolerance (setq tolerance 5)) + (catch 'different + (cl-labels ((check-tolerance + (coord-a coord-b) + (unless (>= tolerance (abs (- coord-a coord-b))) + (throw 'different nil)))) + (dotimes (i (length a)) + (pcase-let ((`((,type-a . ,coords-a) ,_id ,_plist) (nth i a)) + (`((,type-b . ,coords-b) ,_id ,_plist) (nth i b))) + (unless (eq type-a type-b) + (throw 'different nil)) + (pcase-exhaustive type-a + ('rect + (check-tolerance (caar coords-a) (caar coords-b)) + (check-tolerance (cdar coords-a) (cdar coords-b)) + (check-tolerance (cadr coords-a) (cadr coords-b)) + (check-tolerance (cddr coords-a) (cddr coords-b))) + ('circle + (check-tolerance (caar coords-a) (caar coords-b)) + (check-tolerance (cdar coords-a) (cdar coords-b)) + (check-tolerance (cdar coords-a) (cdar coords-b))) + ('poly + (dotimes (i (length coords-a)) + (check-tolerance (aref coords-a i) (aref coords-b i)))))))) + t)) + +(ert-deftest image--compute-map-and-original-map () + "Test `image--compute-map' and `image--compute-original-map'." + (skip-unless (display-images-p)) + (let* ((svg-string "ABC") + (original-map + '(((circle (41 . 29) . 24) "a" (help-echo "A")) + ((rect (5 . 101) 77 . 149) "b" (help-echo "B")) + ((poly . [161 29 160 22 154 15 146 10 136 7 125 5 114 7 104 10 96 15 91 22 89 29 91 37 96 43 104 49 114 52 125 53 136 52 146 49 154 43 160 37]) "c" (help-echo "C")))) + (scaled-map + '(((circle (82 . 58) . 48) "a" (help-echo "A")) + ((rect (10 . 202) 154 . 298) "b" (help-echo "B")) + ((poly . [322 58 320 44 308 30 292 20 272 14 250 10 228 14 208 20 192 30 182 44 178 58 182 74 192 86 208 98 228 104 250 106 272 104 292 98 308 86 320 74]) "c" (help-echo "C")))) + (flipped-map + '(((circle (125 . 29) . 24) "a" (help-echo "A")) + ((rect (89 . 101) 161 . 149) "b" (help-echo "B")) + ((poly . [5 29 6 22 12 15 20 10 30 7 41 5 52 7 62 10 70 15 75 22 77 29 75 37 70 43 62 49 52 52 41 53 30 52 20 49 12 43 6 37]) "c" (help-echo "C")))) + (rotated-map + '(((circle (126 . 41) . 24) "a" (help-echo "A")) + ((rect (6 . 5) 54 . 77) "b" (help-echo "B")) + ((poly . [126 161 133 160 140 154 145 146 148 136 150 125 148 114 145 104 140 96 133 91 126 89 118 91 112 96 106 104 103 114 102 125 103 136 106 146 112 154 118 160]) "c" (help-echo "C")))) + (scaled-rotated-flipped-map + '(((circle (58 . 82) . 48) "a" (help-echo "A")) + ((rect (202 . 10) 298 . 154) "b" (help-echo "B")) + ((poly . [58 322 44 320 30 308 20 292 14 272 10 250 14 228 20 208 30 192 44 182 58 178 74 182 86 192 98 208 104 228 106 250 104 272 98 292 86 308 74 320]) "c" (help-echo "C")))) + (image (create-image svg-string 'svg t :map scaled-rotated-flipped-map + :scale 2 :rotation 90 :flip t))) + ;; Test that `image--compute-original-map' correctly generates + ;; original-map when creating an already transformed image. + (should (image-tests--map-equal (image-property image :original-map) + original-map)) + (setf (image-property image :flip) nil) + (setf (image-property image :rotation) 0) + (setf (image-property image :scale) 2) + (should (image-tests--map-equal (image--compute-map image) + scaled-map)) + (setf (image-property image :scale) 1) + (setf (image-property image :rotation) 90) + (should (image-tests--map-equal (image--compute-map image) + rotated-map)) + (setf (image-property image :rotation) 0) + (setf (image-property image :flip) t) + (should (image-tests--map-equal (image--compute-map image) + flipped-map)) + (setf (image-property image :scale) 2) + (setf (image-property image :rotation) 90) + (should (image-tests--map-equal (image--compute-map image) + scaled-rotated-flipped-map)) + + ;; Uncomment to test manually by interactively transforming the + ;; image and checking the map boundaries by hovering them. + + ;; (with-current-buffer (get-buffer-create "*test image map*") + ;; (erase-buffer) + ;; (insert-image image) + ;; (goto-char (point-min)) + ;; (pop-to-buffer (current-buffer))) + )) + +(ert-deftest image-transform-map () + "Test functions related to transforming image maps." + (let ((map '(((circle (4 . 3) . 2) "circle") + ((rect (3 . 6) 8 . 8) "rect") + ((poly . [6 11 7 13 2 14]) "poly"))) + (width 10) + (height 15)) + (should (equal (image--scale-map (copy-tree map t) 2) + '(((circle (8 . 6) . 4) "circle") + ((rect (6 . 12) 16 . 16) "rect") + ((poly . [12 22 14 26 4 28]) "poly")))) + (should (equal (image--rotate-map (copy-tree map t) 90 `(,width . ,height)) + '(((circle (12 . 4) . 2) "circle") + ((rect (7 . 3) 9 . 8) "rect") + ((poly . [4 6 2 7 1 2]) "poly")))) + (should (equal (image--flip-map (copy-tree map t) t `(,width . ,height)) + '(((circle (6 . 3) . 2) "circle") + ((rect (2 . 6) 7 . 8) "rect") + ((poly . [4 11 3 13 8 14]) "poly")))) + (let ((copy (copy-tree map t))) + (image--scale-map copy 2) + ;; Scale size because the map has been scaled. + (image--rotate-map copy 90 `(,(* 2 width) . ,(* 2 height))) + ;; Swap width and height because the map has been flipped. + (image--flip-map copy t `(,(* 2 height) . ,(* 2 width))) + (should (equal copy + '(((circle (6 . 8) . 4) "circle") + ((rect (12 . 6) 16 . 16) "rect") + ((poly . [22 12 26 14 28 4]) "poly"))))))) + ;;; image-tests.el ends here From 8578652b5b0958aaa92c99667a9ccd72cc412bd6 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 23 Mar 2024 20:15:40 +0100 Subject: [PATCH 143/155] ; Fix markup in recent change to dired-x.texi. --- doc/misc/dired-x.texi | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi index ee0bcdb76c4..e23ce3792e0 100644 --- a/doc/misc/dired-x.texi +++ b/doc/misc/dired-x.texi @@ -354,6 +354,7 @@ this avoids having to wait before seeing the directory. This variable is ignored when @code{dired-omit-mode} is called interactively, such as by @kbd{C-x M-o}, so you can still enable omitting in the directory after the initial display. +@end defvar @cindex omitting additional files @defvar dired-omit-marker-char From 0f04aa06a69cb82eb66d5ffd46700ffdbd58b8f3 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 23 Mar 2024 16:11:07 -0400 Subject: [PATCH 144/155] (describe-package-1): Fix bug#69712 * lisp/emacs-lisp/package.el (describe-package-1): Improve the test to determine if `maintainers` contains a single cons or a list of conses. --- lisp/emacs-lisp/package.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index fe7b10f569a..ab1731aeb54 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2941,7 +2941,7 @@ Helper function for `describe-package'." (insert " ")) (insert "\n")) (when maintainers - (unless (proper-list-p maintainers) + (when (stringp (car maintainers)) (setq maintainers (list maintainers))) (package--print-help-section (if (cdr maintainers) "Maintainers" "Maintainer")) From 44be4fa8e652f08cad0cd6a85abcd54c691a7c27 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Tue, 19 Mar 2024 23:51:46 -0700 Subject: [PATCH 145/155] Remove unused faces from various erc-goodies tests ; A note to anyone running ERC's test suite while bisecting and ; unlucky enough to land on this commit: apologies for the ; inconvenience. It fails because it includes adjustments for fixes ; only introduced by the subsequent commit. This is obviously ; objectionable but was done knowingly in order to duck the ; copyright-exemption threshold for new contributors. * test/lisp/erc/erc-goodies-tests.el (erc-controls-highlight--spoilers) (erc-controls-highlight--inverse): Remove all mention of stricken faces `erc-control-default-fg' and `erc-control-default-bg'. (erc-controls-highlight/default-foreground) (erc-controls-highlight/default-background): New tests. (Bug#69860) --- test/lisp/erc/erc-goodies-tests.el | 127 ++++++++++++++++++++++++++--- 1 file changed, 116 insertions(+), 11 deletions(-) diff --git a/test/lisp/erc/erc-goodies-tests.el b/test/lisp/erc/erc-goodies-tests.el index c8fb0544a72..7cbaa39d3f7 100644 --- a/test/lisp/erc/erc-goodies-tests.el +++ b/test/lisp/erc/erc-goodies-tests.el @@ -167,15 +167,13 @@ '(fg:erc-color-face1 bg:erc-color-face1)) ;; Masked in all black. (erc-goodies-tests--assert-face - 20 "BlackOnBlack" '(fg:erc-color-face1 bg:erc-color-face1) - '(erc-control-default-fg erc-control-default-bg)) + 20 "BlackOnBlack" '(fg:erc-color-face1 bg:erc-color-face1) nil) ;; Explicit "default" code ignoerd. (erc-goodies-tests--assert-face - 34 "Default" '(erc-control-default-fg erc-control-default-bg) + 34 "Default" '(erc-default-face) '(fg:erc-color-face1 bg:erc-color-face1)) (erc-goodies-tests--assert-face - 43 "END" 'erc-default-face - '(erc-control-default-bg erc-control-default-fg)))) + 43 "END" 'erc-default-face nil))) (when noninteractive (erc-tests-common-kill-buffers))) @@ -214,17 +212,124 @@ nil) ;; The inverse of `default' because reverse still in effect. (erc-goodies-tests--assert-face - 32 "ReversedDefault" '(erc-inverse-face erc-control-default-fg - erc-control-default-bg) + 32 "ReversedDefault" '(erc-inverse-face erc-default-face) '(fg:erc-color-face3 bg:erc-color-face13)) (erc-goodies-tests--assert-face - 49 "NormalDefault" '(erc-control-default-fg - erc-control-default-bg) + 49 "NormalDefault" '(erc-default-face) '(erc-inverse-face fg:erc-color-face1 bg:erc-color-face1)) (erc-goodies-tests--assert-face 64 "END" 'erc-default-face - '( erc-control-default-fg erc-control-default-bg - fg:erc-color-face0 bg:erc-color-face0)))) + '(fg:erc-color-face0 bg:erc-color-face0)))) + (when noninteractive + (erc-tests-common-kill-buffers))) + +;; This is meant to assert two behavioral properties: +;; +;; 1) The background is preserved when only a new foreground is +;; defined, in accordance with this bit from the spec: "If only the +;; foreground color is set, the background color stays the same." +;; https://modern.ircdocs.horse/formatting#color +;; +;; 2) The same holds true for a new, lone foreground of 99. Rather +;; than prepend `erc-default-face', this causes the removal of an +;; existing foreground face and likewise doesn't clobber the +;; existing background. +(ert-deftest erc-controls-highlight/default-foreground () + (should (eq t erc-interpret-controls-p)) + (erc-tests-common-make-server-buf) + (with-current-buffer (erc--open-target "#chan") + (setq-local erc-interpret-mirc-color t) + (defvar erc-fill-column) + (let ((erc-fill-column 90)) + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage + "bob" (concat "BEGIN " + "\C-c03,08 GreenOnYellow " + "\C-c99 BlackOnYellow " + "\C-o END") + nil t))) + (forward-line -1) + (should (search-forward " " nil t)) + (should (erc-tests-common-equal-with-props + (erc--remove-text-properties + (buffer-substring (point) (line-end-position))) + #("BEGIN GreenOnYellow BlackOnYellow END" + 0 6 (font-lock-face erc-default-face) + 6 21 (font-lock-face (fg:erc-color-face3 + bg:erc-color-face8 + erc-default-face)) + 21 36 (font-lock-face (bg:erc-color-face8 + erc-default-face)) + 36 40 (font-lock-face (erc-default-face))))) + (should (search-forward "BlackOnYellow")) + (let ((faces (get-text-property (point) 'font-lock-face))) + (should (equal (face-background (car faces) nil (cdr faces)) + "yellow"))) + + ;; Redefine background color alongside default foreground. + (let ((erc-fill-column 90)) + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage + "bob" (concat "BEGIN " + "\C-c03,08 GreenOnYellow " + "\C-c99,07 BlackOnOrange " + "\C-o END") + nil t))) + (should (search-forward " " nil t)) + (should (erc-tests-common-equal-with-props + (erc--remove-text-properties + (buffer-substring (point) (line-end-position))) + #("BEGIN GreenOnYellow BlackOnOrange END" + 0 6 (font-lock-face erc-default-face) + 6 21 (font-lock-face (fg:erc-color-face3 + bg:erc-color-face8 + erc-default-face)) + 21 36 (font-lock-face (bg:erc-color-face7 + erc-default-face)) + 36 40 (font-lock-face (erc-default-face))))) + (should (search-forward "BlackOnOrange")) + (let ((faces (get-text-property (point) 'font-lock-face))) + (should (equal (face-background (car faces) nil (cdr faces)) + "orange")))) ; as opposed to white or black + (when noninteractive + (erc-tests-common-kill-buffers))) + +;; This merely asserts our current interpretation of "default faces": +;; that they reflect the foreground and background exhibited by normal +;; chat messages before any control-code formatting is applied (rather +;; than, e.g., some sort of negation or no-op). +(ert-deftest erc-controls-highlight/default-background () + (should (eq t erc-interpret-controls-p)) + (erc-tests-common-make-server-buf) + (with-current-buffer (erc--open-target "#chan") + (setq-local erc-interpret-mirc-color t) + (defvar erc-fill-column) + (let ((erc-fill-column 90)) + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage + "bob" (concat "BEGIN " + "\C-c03,08 GreenOnYellow " + "\C-c05,99 BrownOnWhite " + "\C-o END") + nil t))) + (forward-line -1) + (should (search-forward " " nil t)) + (should (erc-tests-common-equal-with-props + (erc--remove-text-properties + (buffer-substring (point) (line-end-position))) + #("BEGIN GreenOnYellow BrownOnWhite END" + 0 6 (font-lock-face erc-default-face) + 6 21 (font-lock-face (fg:erc-color-face3 + bg:erc-color-face8 + erc-default-face)) + 21 35 (font-lock-face (fg:erc-color-face5 + erc-default-face)) + 35 39 (font-lock-face (erc-default-face))))) + ;; Ensure the background is white or black, rather than yellow. + (should (search-forward "BrownOnWhite")) + (let ((faces (get-text-property (point) 'font-lock-face))) + (should (equal (face-background (car faces) nil `(,@(cdr faces) default)) + (face-background 'default))))) (when noninteractive (erc-tests-common-kill-buffers))) From 525bc083155030b58de08c8716fec9db1496aa9d Mon Sep 17 00:00:00 2001 From: "F. Moukayed" Date: Sun, 17 Mar 2024 16:43:36 +0000 Subject: [PATCH 146/155] Remove mishandled erc-control-default-{fg,bg} faces Partially revert those portions of 7b4ca9e609e "Leverage inverse-video for erc-inverse-face" that introduced and managed explicit faces for the "default" 99 color code. * lisp/erc/erc-goodies.el (erc-control-default-fg) (erc-control-default-bg): Remove unused faces originally meant to be new in ERC 5.6. (erc-get-fg-color-face, erc-get-bg-color-face): Return nil for n=99. (erc-controls-interpret, erc-controls-highlight): Preserve an interval's existing background so "if only the foreground color is set, the background color stays the same," as explained by https://modern.ircdocs.horse/formatting#color. (Bug#69860) Copyright-paperwork-exempt: yes --- lisp/erc/erc-goodies.el | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index da14f5bd728..883f64d3109 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -673,14 +673,6 @@ The value `erc-interpret-controls-p' must also be t for this to work." "ERC underline face." :group 'erc-faces) -(defface erc-control-default-fg '((t :inherit default)) - "ERC foreground face for the \"default\" color code." - :group 'erc-faces) - -(defface erc-control-default-bg '((t :inherit default)) - "ERC background face for the \"default\" color code." - :group 'erc-faces) - ;; FIXME rename these to something like `erc-control-color-N-fg', ;; and deprecate the old names via `define-obsolete-face-alias'. (defface fg:erc-color-face0 '((t :foreground "White")) @@ -812,7 +804,7 @@ The value `erc-interpret-controls-p' must also be t for this to work." (intern (concat "bg:erc-color-face" (number-to-string n)))) ((< 15 n 99) (list :background (aref erc--controls-additional-colors (- n 16)))) - (t (erc-log (format " Wrong color: %s" n)) 'erc-control-default-fg)))) + (t (erc-log (format " Wrong color: %s" n)) nil)))) (defun erc-get-fg-color-face (n) "Fetches the right face for foreground color N (0-15)." @@ -828,7 +820,7 @@ The value `erc-interpret-controls-p' must also be t for this to work." (intern (concat "fg:erc-color-face" (number-to-string n)))) ((< 15 n 99) (list :foreground (aref erc--controls-additional-colors (- n 16)))) - (t (erc-log (format " Wrong color: %s" n)) 'erc-control-default-bg)))) + (t (erc-log (format " Wrong color: %s" n)) nil)))) ;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t) (define-erc-module irccontrols nil @@ -883,7 +875,7 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." (setq s (replace-match "" nil nil s 1)) (cond ((and erc-interpret-mirc-color (or fg-color bg-color)) (setq fg fg-color) - (setq bg bg-color)) + (when bg-color (setq bg bg-color))) ((string= control "\C-b") (setq boldp (not boldp))) ((string= control "\C-]") @@ -944,7 +936,7 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'." (replace-match "" nil nil nil 1) (cond ((and erc-interpret-mirc-color (or fg-color bg-color)) (setq fg fg-color) - (setq bg bg-color)) + (when bg-color (setq bg bg-color))) ((string= control "\C-b") (setq boldp (not boldp))) ((string= control "\C-]") From b9bd78f78d62383f2ff84ceecf8e490193594f17 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 10 Mar 2024 23:09:59 -0700 Subject: [PATCH 147/155] Restore leading space to right-margin stamps in ERC * lisp/erc/erc-stamp.el (erc-insert-timestamp-right): Insert a single space character immediately before right-side stamps managed by `erc-stamp--display-margin-mode'. Include it as part of the `timestamp' field. This behavior was originally present in an earlier draft of the changes for bug#60936, mainly to favor symmetry between hard-wrapped fill styles and fill-wrap with regard to stamps. It was subsequently removed to simplify management, so that the `field' and `display' intervals aligned. * test/lisp/erc/erc-stamp-tests.el (erc-stamp--display-margin-mode--right): Update expected output. ; test/lisp/erc/resources/fill/snapshots/merge-01-start.eld: Add space. ; test/lisp/erc/resources/fill/snapshots/merge-02-right.eld: Add space. ; test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld: Add space. ; test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld: ; Add space. ; test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld: ; Add space. ; test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld: Add space. ; test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld: Add space. ; test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld: Add space. ; test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld: Add space. ; test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld: Add space. --- lisp/erc/erc-stamp.el | 1 + test/lisp/erc/erc-stamp-tests.el | 16 ++++++++-------- .../resources/fill/snapshots/merge-01-start.eld | 2 +- .../resources/fill/snapshots/merge-02-right.eld | 2 +- .../resources/fill/snapshots/merge-wrap-01.eld | 2 +- .../snapshots/merge-wrap-indicator-post-01.eld | 2 +- .../snapshots/merge-wrap-indicator-pre-01.eld | 2 +- .../fill/snapshots/monospace-01-start.eld | 2 +- .../fill/snapshots/monospace-02-right.eld | 2 +- .../fill/snapshots/monospace-03-left.eld | 2 +- .../fill/snapshots/monospace-04-reset.eld | 2 +- .../resources/fill/snapshots/spacing-01-mono.eld | 2 +- 12 files changed, 19 insertions(+), 18 deletions(-) diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 44f92c5a7e2..bcb9b4aafef 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -623,6 +623,7 @@ printed just after each line's text (no alignment)." ((guard erc-stamp--display-margin-mode) (let ((s (propertize (substring-no-properties string) 'invisible erc-stamp--invisible-property))) + (insert " ") (put-text-property 0 (length string) 'display `((margin right-margin) ,s) string))) diff --git a/test/lisp/erc/erc-stamp-tests.el b/test/lisp/erc/erc-stamp-tests.el index a49173ffa2f..5fee21ec28f 100644 --- a/test/lisp/erc/erc-stamp-tests.el +++ b/test/lisp/erc/erc-stamp-tests.el @@ -168,11 +168,11 @@ (put-text-property 0 (length msg) 'wrap-prefix 10 msg) (erc-display-message nil nil (current-buffer) msg))) (goto-char (point-min)) - ;; Space not added (treated as opaque string). - (should (search-forward "msg one[" nil t)) - ;; Field covers stamp alone + ;; Leading space added as part of the stamp's field. + (should (search-forward "msg one [" nil t)) + ;; Field covers stamp and space. (should (eql ?e (char-before (field-beginning (point))))) - ;; Vanity props extended + ;; Vanity props extended. (should (get-text-property (field-beginning (point)) 'wrap-prefix)) (should (get-text-property (1+ (field-beginning (point))) 'wrap-prefix)) (should (get-text-property (1- (field-end (point))) 'wrap-prefix)) @@ -183,10 +183,10 @@ (erc-timestamp-right-column 20)) (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) (erc-display-message nil nil (current-buffer) msg))) - ;; No hard wrap - (should (search-forward "oooo[" nil t)) - ;; Field starts at format string (right bracket) - (should (eql ?\[ (char-after (field-beginning (point))))) + ;; No hard wrap. + (should (search-forward "oooo [" nil t)) + ;; Field starts at managed space before format string. + (should (eql ?\s (char-after (field-beginning (point))))) (should (eql ?\n (char-after (field-end (point))))))))) ;; This concerns a proposed partial reversal of the changes resulting diff --git a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld index 3c32719a052..6ff7af218c0 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero.[07:00]\n one.\n two.\n three.\n four.\n five.\n six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #5#) 459 466 (wrap-prefix #1# line-prefix #5#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #5# display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 (8)))) 475 480 (wrap-prefix #1# line-prefix #7#) 480 486 (wrap-prefix #1# line-prefix #7#) 487 488 (erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #8=(space :width (- 27 0)) display #9="") 488 493 (wrap-prefix #1# line-prefix #8# display #9#) 493 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 499 (wrap-prefix #1# line-prefix #8#) 500 501 (erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 501 504 (wrap-prefix #1# line-prefix #10#) 504 512 (wrap-prefix #1# line-prefix #10#) 513 514 (erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #9#) 514 517 (wrap-prefix #1# line-prefix #11# display #9#) 517 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 524 (wrap-prefix #1# line-prefix #11#) 525 526 (erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 (8)))) 526 531 (wrap-prefix #1# line-prefix #12#) 531 538 (wrap-prefix #1# line-prefix #12#) 539 540 (erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 0)) display #9#) 540 545 (wrap-prefix #1# line-prefix #13# display #9#) 545 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 551 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero. [07:00]\n one.\n two.\n three.\n four.\n five.\n six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #5#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #5# display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 (8)))) 477 482 (wrap-prefix #1# line-prefix #7#) 482 488 (wrap-prefix #1# line-prefix #7#) 489 490 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #8=(space :width (- 27 0)) display #9="") 490 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 497 (wrap-prefix #1# line-prefix #8# display #9#) 497 501 (wrap-prefix #1# line-prefix #8#) 502 503 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #9#) 516 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 521 (wrap-prefix #1# line-prefix #11# display #9#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 (8)))) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 0)) display #9#) 542 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 549 (wrap-prefix #1# line-prefix #13# display #9#) 549 553 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld index e2064b914c4..7d9822c80bc 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero.[07:00]\n one.\n two.\n three.\n four.\n five.\n six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18))) field erc-timestamp) 21 22 (wrap-prefix #1# line-prefix #2=(space :width (- 29 (4))) erc--msg notice erc--ts 0) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (wrap-prefix #1# line-prefix #2# field erc-timestamp display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (wrap-prefix #1# line-prefix #3=(space :width (- 29 (8))) erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix (space :width (- 29 (8)))) 349 350 (wrap-prefix #1# line-prefix #4=(space :width (- 29 (6))) erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (wrap-prefix #1# line-prefix (space :width (- 29 (18))) field erc-timestamp) 455 456 (wrap-prefix #1# line-prefix #5=(space :width (- 29 (6))) erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG) 456 459 (wrap-prefix #1# line-prefix #5#) 459 466 (wrap-prefix #1# line-prefix #5#) 466 473 (wrap-prefix #1# line-prefix #5# field erc-timestamp display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (wrap-prefix #1# line-prefix #7=(space :width (- 29 (8))) erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG) 475 480 (wrap-prefix #1# line-prefix #7#) 480 486 (wrap-prefix #1# line-prefix #7#) 487 488 (wrap-prefix #1# line-prefix #8=(space :width (- 29 0)) erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG display #9="") 488 493 (wrap-prefix #1# line-prefix #8# display #9#) 493 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 499 (wrap-prefix #1# line-prefix #8#) 500 501 (wrap-prefix #1# line-prefix #10=(space :width (- 29 (6))) erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG) 501 504 (wrap-prefix #1# line-prefix #10#) 504 512 (wrap-prefix #1# line-prefix #10#) 513 514 (wrap-prefix #1# line-prefix #11=(space :width (- 29 0)) erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG display #9#) 514 517 (wrap-prefix #1# line-prefix #11# display #9#) 517 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 524 (wrap-prefix #1# line-prefix #11#) 525 526 (wrap-prefix #1# line-prefix #12=(space :width (- 29 (8))) erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG) 526 531 (wrap-prefix #1# line-prefix #12#) 531 538 (wrap-prefix #1# line-prefix #12#) 539 540 (wrap-prefix #1# line-prefix #13=(space :width (- 29 0)) erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG display #9#) 540 545 (wrap-prefix #1# line-prefix #13# display #9#) 545 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 551 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero. [07:00]\n one.\n two.\n three.\n four.\n five.\n six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18))) field erc-timestamp) 21 22 (wrap-prefix #1# line-prefix #2=(space :width (- 29 (4))) erc--msg notice erc--ts 0) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (wrap-prefix #1# line-prefix #2# field erc-timestamp) 184 191 (wrap-prefix #1# line-prefix #2# field erc-timestamp display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (wrap-prefix #1# line-prefix #3=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix (space :width (- 29 (8)))) 350 351 (wrap-prefix #1# line-prefix #4=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (wrap-prefix #1# line-prefix (space :width (- 29 (18))) field erc-timestamp) 456 457 (wrap-prefix #1# line-prefix #5=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (wrap-prefix #1# line-prefix #5# field erc-timestamp) 468 475 (wrap-prefix #1# line-prefix #5# field erc-timestamp display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (wrap-prefix #1# line-prefix #7=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG) 477 482 (wrap-prefix #1# line-prefix #7#) 482 488 (wrap-prefix #1# line-prefix #7#) 489 490 (wrap-prefix #1# line-prefix #8=(space :width (- 29 0)) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG display #9="") 490 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 497 (wrap-prefix #1# line-prefix #8# display #9#) 497 501 (wrap-prefix #1# line-prefix #8#) 502 503 (wrap-prefix #1# line-prefix #10=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (wrap-prefix #1# line-prefix #11=(space :width (- 29 0)) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG display #9#) 516 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 521 (wrap-prefix #1# line-prefix #11# display #9#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (wrap-prefix #1# line-prefix #12=(space :width (- 29 (8))) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (wrap-prefix #1# line-prefix #13=(space :width (- 29 0)) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG display #9#) 542 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 549 (wrap-prefix #1# line-prefix #13# display #9#) 549 553 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld index feaba85ec90..2d0e5a5965f 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero.[07:00]\n 0.5\n* bob one.\n two.\n 2.5\n* bob three\n four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #6#) 459 466 (wrap-prefix #1# line-prefix #6#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 475 478 (wrap-prefix #1# line-prefix #7# display #8#) 478 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 483 (wrap-prefix #1# line-prefix #7#) 484 485 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 485 486 (wrap-prefix #1# line-prefix #9#) 486 489 (wrap-prefix #1# line-prefix #9#) 489 494 (wrap-prefix #1# line-prefix #9#) 495 496 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 496 499 (wrap-prefix #1# line-prefix #10#) 499 505 (wrap-prefix #1# line-prefix #10#) 506 507 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 507 510 (wrap-prefix #1# line-prefix #11# display #8#) 510 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 515 (wrap-prefix #1# line-prefix #11#) 516 517 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 517 518 (wrap-prefix #1# line-prefix #12#) 518 521 (wrap-prefix #1# line-prefix #12#) 521 527 (wrap-prefix #1# line-prefix #12#) 528 529 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 529 532 (wrap-prefix #1# line-prefix #13#) 532 539 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero. [07:00]\n 0.5\n* bob one.\n two.\n 2.5\n* bob three\n four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #10#) 501 507 (wrap-prefix #1# line-prefix #10#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 509 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 514 (wrap-prefix #1# line-prefix #11# display #8#) 514 517 (wrap-prefix #1# line-prefix #11#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #12#) 520 523 (wrap-prefix #1# line-prefix #12#) 523 529 (wrap-prefix #1# line-prefix #12#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #13#) 534 541 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld index ed1488c8595..e019e60bb26 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero.[07:00]\n 0.5\n* bob one.\n two.\n 2.5\n* bob three\n four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #6#) 459 466 (wrap-prefix #1# line-prefix #6#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 475 478 (wrap-prefix #1# line-prefix #7# display #8#) 478 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 483 (wrap-prefix #1# line-prefix #7#) 484 485 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 485 486 (wrap-prefix #1# line-prefix #9#) 486 489 (wrap-prefix #1# line-prefix #9#) 489 494 (wrap-prefix #1# line-prefix #9#) 495 496 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 496 499 (wrap-prefix #1# line-prefix #10#) 499 505 (wrap-prefix #1# line-prefix #10#) 505 506 (display #("~\n" 0 2 (font-lock-face shadow))) 506 507 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 507 510 (wrap-prefix #1# line-prefix #11# display #8#) 510 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 515 (wrap-prefix #1# line-prefix #11#) 516 517 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 517 518 (wrap-prefix #1# line-prefix #12#) 518 521 (wrap-prefix #1# line-prefix #12#) 521 527 (wrap-prefix #1# line-prefix #12#) 528 529 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 529 532 (wrap-prefix #1# line-prefix #13#) 532 539 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero. [07:00]\n 0.5\n* bob one.\n two.\n 2.5\n* bob three\n four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #10#) 501 507 (wrap-prefix #1# line-prefix #10#) 507 508 (display #("~\n" 0 2 (font-lock-face shadow))) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 509 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 514 (wrap-prefix #1# line-prefix #11# display #8#) 514 517 (wrap-prefix #1# line-prefix #11#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #12#) 520 523 (wrap-prefix #1# line-prefix #12#) 523 529 (wrap-prefix #1# line-prefix #12#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #13#) 534 541 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld index a3530a6c44d..615de982b1e 100644 --- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero.[07:00]\n 0.5\n* bob one.\n two.\n 2.5\n* bob three\n four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #6#) 459 466 (wrap-prefix #1# line-prefix #6#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 #10=(2))) display #8=#("> " 0 1 (font-lock-face shadow))) 475 478 (wrap-prefix #1# line-prefix #7# display #8#) 478 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 483 (wrap-prefix #1# line-prefix #7#) 484 485 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 485 486 (wrap-prefix #1# line-prefix #9#) 486 489 (wrap-prefix #1# line-prefix #9#) 489 494 (wrap-prefix #1# line-prefix #9#) 495 496 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 (6)))) 496 499 (wrap-prefix #1# line-prefix #11#) 499 505 (wrap-prefix #1# line-prefix #11#) 506 507 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 #10#)) display #8#) 507 510 (wrap-prefix #1# line-prefix #12# display #8#) 510 512 (wrap-prefix #1# line-prefix #12# display #8#) 512 515 (wrap-prefix #1# line-prefix #12#) 516 517 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #13=(space :width (- 27 (2)))) 517 518 (wrap-prefix #1# line-prefix #13#) 518 521 (wrap-prefix #1# line-prefix #13#) 521 527 (wrap-prefix #1# line-prefix #13#) 528 529 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #14=(space :width (- 27 (6)))) 529 532 (wrap-prefix #1# line-prefix #14#) 532 539 (wrap-prefix #1# line-prefix #14#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero. [07:00]\n 0.5\n* bob one.\n two.\n 2.5\n* bob three\n four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 #10=(2))) display #8=#("> " 0 1 (font-lock-face shadow))) 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #11#) 501 507 (wrap-prefix #1# line-prefix #11#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 #10#)) display #8#) 509 512 (wrap-prefix #1# line-prefix #12# display #8#) 512 514 (wrap-prefix #1# line-prefix #12# display #8#) 514 517 (wrap-prefix #1# line-prefix #12#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #13=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #13#) 520 523 (wrap-prefix #1# line-prefix #13#) 523 529 (wrap-prefix #1# line-prefix #13#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #14=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #14#) 534 541 (wrap-prefix #1# line-prefix #14#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld index c94629cf357..0228e716731 100644 --- a/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld +++ b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld index 127c0b29bc9..9ab89041b53 100644 --- a/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld +++ b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 29 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 29 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 29 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 29 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 29 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 29 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld index a9f3f1d1904..87ea4692d9d 100644 --- a/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld +++ b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 25) line-prefix (space :width (- 25 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 25 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 25 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 25 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 25) line-prefix (space :width (- 25 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 25 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 25 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 25 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld index c94629cf357..0228e716731 100644 --- a/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld +++ b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld index 754d7989cea..ae364accdea 100644 --- a/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld +++ b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld @@ -1 +1 @@ -#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.[00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n This buffer is for text.\n*** one two three\n*** four five six\n Somebody stop me\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 190 191 (line-spacing 0.5) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 348 349 (line-spacing 0.5) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 435 436 (line-spacing 0.5) 436 437 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 0)) display #6="") 437 440 (wrap-prefix #1# line-prefix #5# display #6#) 440 442 (wrap-prefix #1# line-prefix #5# display #6#) 442 466 (wrap-prefix #1# line-prefix #5#) 466 467 (line-spacing 0.5) 467 468 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #7=(space :width (- 27 (4)))) 468 484 (wrap-prefix #1# line-prefix #7#) 485 486 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #8=(space :width (- 27 (4)))) 486 502 (wrap-prefix #1# line-prefix #8#) 502 503 (line-spacing 0.5) 503 504 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 504 507 (wrap-prefix #1# line-prefix #9#) 507 525 (wrap-prefix #1# line-prefix #9#)) \ No newline at end of file +#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n This buffer is for text.\n*** one two three\n*** four five six\n Somebody stop me\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (line-spacing 0.5) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 349 350 (line-spacing 0.5) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 436 437 (line-spacing 0.5) 437 438 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 0)) display #6="") 438 441 (wrap-prefix #1# line-prefix #5# display #6#) 441 443 (wrap-prefix #1# line-prefix #5# display #6#) 443 467 (wrap-prefix #1# line-prefix #5#) 467 468 (line-spacing 0.5) 468 469 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #7=(space :width (- 27 (4)))) 469 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #8=(space :width (- 27 (4)))) 487 503 (wrap-prefix #1# line-prefix #8#) 503 504 (line-spacing 0.5) 504 505 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 505 508 (wrap-prefix #1# line-prefix #9#) 508 526 (wrap-prefix #1# line-prefix #9#)) \ No newline at end of file From a46789b56af05e4cd31ab90495c9f2a4492a9b19 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 10 Mar 2024 23:09:59 -0700 Subject: [PATCH 148/155] Reuse command-indicator code for script lines in ERC * lisp/erc/erc-goodies.el (erc-load-irc-script-lines): Move here from main file and rework to always use `command-indicator' instead of only partially, when available. Also use internal "send-action" and "send-message" interfaces to defer command-handler output until command lines have been inserted. * lisp/erc/erc.el (erc-process-input-line): Redo doc string. (erc-process-script-line): Fold exceptionally overlong line. (erc-load-irc-script-lines): Move to erc-goodies.el. (Bug#67032) --- lisp/erc/erc-goodies.el | 42 +++++++++++++++++++++++++++++ lisp/erc/erc.el | 58 +++++++++++------------------------------ 2 files changed, 57 insertions(+), 43 deletions(-) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 883f64d3109..fe44c3bdfcb 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -625,6 +625,48 @@ Do nothing if the variable `erc-command-indicator' is nil." erc--msg-props)))) (erc--refresh-prompt)))) +;;;###autoload +(defun erc-load-irc-script-lines (lines &optional force noexpand) + "Process a list of LINES as prompt input submissions. +If optional NOEXPAND is non-nil, do not expand script-specific +substitution sequences via `erc-process-script-line' and instead +process LINES as literal prompt input. With FORCE, bypass flood +protection." + ;; The various erc-cmd-CMDs were designed to return non-nil when + ;; their command line should be echoed. But at some point, these + ;; handlers began displaying their own output, which naturally + ;; appeared *above* the echoed command. This tries to intercept + ;; these insertions, deferring them until the command has returned + ;; and its command line has been printed. + (cl-assert (eq 'erc-mode major-mode)) + (let ((args (and erc-script-args + (if (string-match "^ " erc-script-args) + (substring erc-script-args 1) + erc-script-args)))) + (with-silent-modifications + (dolist (line lines) + (erc-log (concat "erc-load-script: CMD: " line)) + (unless (string-match (rx bot (* (syntax whitespace)) eot) line) + (unless noexpand + (setq line (erc-process-script-line line args))) + (let ((erc--current-line-input-split (erc--make-input-split line)) + calls insertp) + (add-function :around (local 'erc--send-message-nested-function) + (lambda (&rest args) (push args calls)) + '((name . erc-script-lines-fn) (depth . -80))) + (add-function :around (local 'erc--send-action-function) + (lambda (&rest args) (push args calls)) + '((name . erc-script-lines-fn) (depth . -80))) + (setq insertp + (unwind-protect (erc-process-input-line line force) + (remove-function (local 'erc--send-action-function) + 'erc-script-lines-fn) + (remove-function (local 'erc--send-message-nested-function) + 'erc-script-lines-fn))) + (when (and insertp erc-script-echo) + (erc--command-indicator-display line) + (dolist (call calls) + (apply (car call) (cdr call)))))))))) ;;; IRC control character processing. (defgroup erc-control-characters nil diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 3cc9bd54228..0750463a4e7 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -4004,17 +4004,19 @@ erc-cmd-FOO, this returns a string /FOO." command-name))) (defun erc-process-input-line (line &optional force no-command) - "Translate LINE to an RFC1459 command and send it based. -Returns non-nil if the command is actually sent to the server, and nil -otherwise. - -If the command in the LINE is not bound as a function `erc-cmd-', -it is passed to `erc-cmd-default'. If LINE is not a command (i.e. doesn't -start with /) then it is sent as a message. - -An optional FORCE argument forces sending the line when flood -protection is in effect. The optional NO-COMMAND argument prohibits -this function from interpreting the line as a command." + "Dispatch a slash-command or chat-input handler from user-input LINE. +If simplistic validation fails, print an error and return nil. +Otherwise, defer to an appropriate handler. For \"slash\" commands, +like \"/JOIN\", expect a handler, like `erc-cmd-JOIN', to return non-nil +if LINE is fit for echoing as a command line when executing scripts. +For normal chat input, expect a handler to return non-nil if a message +was successfully processed as an outgoing \"PRIVMSG\". If LINE is a +slash command, and ERC can't find a corresponding handler of the form +`erc-cmd-', pass LINE to `erc-cmd-default', treating it as a +catch-all handler. Otherwise, for normal chat input, pass LINE and the +boolean argument FORCE to `erc-send-input-line-function'. With a +non-nil NO-COMMAND, always treat LINE as normal chat input rather than a +slash command." (let ((command-list (erc-extract-command-from-line line))) (if (and command-list (not no-command)) @@ -8512,7 +8514,8 @@ and so on." ((string-match "^%[Ss]$" esc) server) ((string-match "^%[Nn]$" esc) nick) ((string-match "^%\\(.\\)$" esc) (match-string 1 esc)) - (t (erc-log (format "BUG in erc-process-script-line: bad escape sequence: %S\n" esc)) + (t (erc-log (format "Bad escape sequence in %s: %S\n" + 'erc-process-script-line esc)) (message "BUG IN ERC: esc=%S" esc) ""))) (setq line tail) @@ -8531,37 +8534,6 @@ and so on." (buffer-string)))) (erc-load-irc-script-lines (erc-split-multiline-safe str) force))) -(defun erc-load-irc-script-lines (lines &optional force noexpand) - "Load IRC script LINES (a list of strings). - -If optional NOEXPAND is non-nil, do not expand script-specific -sequences, process the lines verbatim. Use this for multiline -user input." - (let* ((cb (current-buffer)) - (s "") - (sp (or (and (bound-and-true-p erc-command-indicator-mode) - (fboundp 'erc-command-indicator) - (erc-command-indicator)) - (erc-prompt))) - (args (and (boundp 'erc-script-args) erc-script-args))) - (if (and args (string-match "^ " args)) - (setq args (substring args 1))) - ;; prepare the prompt string for echo - (erc-put-text-property 0 (length sp) - 'font-lock-face 'erc-command-indicator-face sp) - (while lines - (setq s (car lines)) - (erc-log (concat "erc-load-script: CMD: " s)) - (unless (string-match "^\\s-*$" s) - (let ((line (if noexpand s (erc-process-script-line s args)))) - (if (and (erc-process-input-line line force) - erc-script-echo) - (progn - (erc-put-text-property 0 (length line) - 'font-lock-face 'erc-input-face line) - (erc-display-line (concat sp line) cb))))) - (setq lines (cdr lines))))) - ;; authentication (defun erc--unfun (maybe-fn) From ef859d8b1b285fd22b083955a0e878a74d72ff41 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 23 Mar 2024 19:21:26 -0400 Subject: [PATCH 149/155] edebug.el: Better strip instrumentation from backtraces Rework the code that "cleans" the backtrace for `edebug-pop-to-backtrace`. The main changes are the following: - Strip instrumentation from "everywhere" rather than trying to limit the effect to "code" and leave "data" untouched. This is a worthy goal, but it is quite difficult to do since code contains data (so we ended up touching data anyway) and data can also contain code. The risk of accidentally removing something because it happens to look like instrumentation is very low, whereas it was very common for instrumentation to remain in the backtrace. - Use a global hash-table to remember the work done, instead of using separate hash-table for each element. By using a weak hash-table we avoid the risk of leaks, and save a lot of work since there's often a lot of subexpressions that appear several times in the backtrace. * lisp/emacs-lisp/edebug.el (edebug-make-enter-wrapper): Tweak code layout so the comments are more clear. (edebug-unwrap): Remove redundant patterns for `closure` and `lambda`. Add `:closure-dont-trim-context` to the `edebug-enter` pattern, so it also gets removed (this should have been done in commit 750bc57cbb8d). (edebug--unwrap-cache): New var. (edebug-unwrap*): Use it. (edebug--unwrap1): Delete function. Merged into `edebug-unwrap*`. Also apply unwrapping to the contents of byte-code functions since they can refer to lambda expressions captured by the closure. (edebug--symbol-prefixed-p): Rename from `edebug--symbol-not-prefixed-p` and adjust meaning accordingly. (edebug--strip-instrumentation): Adjust accordingly and simplify a bit by unifying the "lambda" case and the "everything else" case. (edebug--unwrap-frame): Use `cl-callf` and unwrap arguments even if they've already been evaluated. --- lisp/emacs-lisp/edebug.el | 143 +++++++++++++++++++------------------- 1 file changed, 73 insertions(+), 70 deletions(-) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 1d3db4a588d..b27ffbca908 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1229,10 +1229,12 @@ purpose by adding an entry to this alist, and setting ;; But the list will just be reversed. ,@(nreverse edebug-def-args)) 'nil) - ;; Make sure `forms' is not nil so we don't accidentally return - ;; the magic keyword. Mark the closure so we don't throw away - ;; unused vars (bug#59213). - #'(lambda () :closure-dont-trim-context ,@(or forms '(nil))))) + #'(lambda () + ;; Mark the closure so we don't throw away unused vars (bug#59213). + :closure-dont-trim-context + ;; Make sure `forms' is not nil so we don't accidentally return + ;; the magic keyword. + ,@(or forms '(nil))))) (defvar edebug-form-begin-marker) ; the mark for def being instrumented @@ -1270,55 +1272,48 @@ Does not unwrap inside vectors, records, structures, or hash tables." (pcase sexp (`(edebug-after ,_before-form ,_after-index ,form) form) - (`(lambda ,args (edebug-enter ',_sym ,_arglist - (function (lambda nil . ,body)))) - `(lambda ,args ,@body)) - (`(closure ,env ,args (edebug-enter ',_sym ,_arglist - (function (lambda nil . ,body)))) - `(closure ,env ,args ,@body)) - (`(edebug-enter ',_sym ,_args (function (lambda nil . ,body))) + (`(edebug-enter ',_sym ,_args + #'(lambda nil :closure-dont-trim-context . ,body)) (macroexp-progn body)) (_ sexp))) +(defconst edebug--unwrap-cache + (make-hash-table :test 'eq :weakness 'key) + "Hash-table containing the results of unwrapping cons cells. +These results are reused to avoid redundant work but also to avoid +infinite loops when the code/environment contains a circular object.") + (defun edebug-unwrap* (sexp) "Return the SEXP recursively unwrapped." - (let ((ht (make-hash-table :test 'eq))) - (edebug--unwrap1 sexp ht))) - -(defun edebug--unwrap1 (sexp hash-table) - "Unwrap SEXP using HASH-TABLE of things already unwrapped. -HASH-TABLE contains the results of unwrapping cons cells within -SEXP, which are reused to avoid infinite loops when SEXP is or -contains a circular object." - (let ((new-sexp (edebug-unwrap sexp))) - (while (not (eq sexp new-sexp)) - (setq sexp new-sexp - new-sexp (edebug-unwrap sexp))) - (if (consp new-sexp) - (let ((result (gethash new-sexp hash-table nil))) - (unless result - (let ((remainder new-sexp) - current) - (setq result (cons nil nil) - current result) - (while - (progn - (puthash remainder current hash-table) - (setf (car current) - (edebug--unwrap1 (car remainder) hash-table)) - (setq remainder (cdr remainder)) - (cond - ((atom remainder) - (setf (cdr current) - (edebug--unwrap1 remainder hash-table)) - nil) - ((gethash remainder hash-table nil) - (setf (cdr current) (gethash remainder hash-table nil)) - nil) - (t (setq current - (setf (cdr current) (cons nil nil))))))))) - result) - new-sexp))) + (while (not (eq sexp (setq sexp (edebug-unwrap sexp))))) + (cond + ((consp sexp) + (or (gethash sexp edebug--unwrap-cache nil) + (let ((remainder sexp) + (current (cons nil nil))) + (prog1 current + (while + (progn + (puthash remainder current edebug--unwrap-cache) + (setf (car current) + (edebug-unwrap* (car remainder))) + (setq remainder (cdr remainder)) + (cond + ((atom remainder) + (setf (cdr current) + (edebug-unwrap* remainder)) + nil) + ((gethash remainder edebug--unwrap-cache nil) + (setf (cdr current) (gethash remainder edebug--unwrap-cache nil)) + nil) + (t (setq current + (setf (cdr current) (cons nil nil))))))))))) + ((byte-code-function-p sexp) + (apply #'make-byte-code + (aref sexp 0) (aref sexp 1) + (vconcat (mapcar #'edebug-unwrap* (aref sexp 2))) + (nthcdr 3 (append sexp ())))) + (t sexp))) (defun edebug-defining-form (cursor form-begin form-end speclist) @@ -4239,13 +4234,13 @@ Remove frames for Edebug's functions and the lambdas in and after-index fields in both FRAMES and the returned list of deinstrumented frames, for those frames where the source code location is known." - (let (skip-next-lambda def-name before-index after-index results - (index (length frames))) + (let ((index (length frames)) + skip-next-lambda def-name before-index after-index results) (dolist (frame (reverse frames)) (let ((new-frame (copy-edebug--frame frame)) (fun (edebug--frame-fun frame)) (args (edebug--frame-args frame))) - (cl-decf index) + (cl-decf index) ;; FIXME: Not used? (pcase fun ('edebug-enter (setq skip-next-lambda t @@ -4255,38 +4250,46 @@ code location is known." (nth 1 (nth 0 args)) (nth 0 args)) after-index (nth 1 args))) - ((pred edebug--symbol-not-prefixed-p) - (edebug--unwrap-frame new-frame) - (edebug--add-source-info new-frame def-name before-index after-index) - (edebug--add-source-info frame def-name before-index after-index) - (push new-frame results) - (setq before-index nil - after-index nil)) - (`(,(or 'lambda 'closure) . ,_) + ;; Just skip all our own frames. + ((pred edebug--symbol-prefixed-p) nil) + (_ + (when (and skip-next-lambda + (not (memq (car-safe fun) '(closure lambda)))) + (warn "Edebug--strip-instrumentation expected an interpreted function:\n%S" fun)) (unless skip-next-lambda (edebug--unwrap-frame new-frame) - (edebug--add-source-info frame def-name before-index after-index) (edebug--add-source-info new-frame def-name before-index after-index) + (edebug--add-source-info frame def-name before-index after-index) (push new-frame results)) - (setq before-index nil + (setq before-index nil after-index nil skip-next-lambda nil))))) results)) -(defun edebug--symbol-not-prefixed-p (sym) - "Return non-nil if SYM is a symbol not prefixed by \"edebug-\"." +(defun edebug--symbol-prefixed-p (sym) + "Return non-nil if SYM is a symbol prefixed by \"edebug-\"." (and (symbolp sym) - (not (string-prefix-p "edebug-" (symbol-name sym))))) + (string-prefix-p "edebug-" (symbol-name sym)))) (defun edebug--unwrap-frame (frame) "Remove Edebug's instrumentation from FRAME. Strip it from the function and any unevaluated arguments." - (setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame))) - (unless (edebug--frame-evald frame) - (let (results) - (dolist (arg (edebug--frame-args frame)) - (push (edebug-unwrap* arg) results)) - (setf (edebug--frame-args frame) (nreverse results))))) + (cl-callf edebug-unwrap* (edebug--frame-fun frame)) + ;; We used to try to be careful to apply `edebug-unwrap' only to source + ;; expressions and not to values, so we did not apply unwrap to the arguments + ;; of the frame if they had already been evaluated. + ;; But this was not careful enough since `edebug-unwrap*' gleefully traverses + ;; its argument without paying attention to its syntactic structure so it + ;; also "mistakenly" descends into the values contained within the "source + ;; code". In practice this *very* rarely leads to undesired results. + ;; On the contrary, it's often useful to descend into values because they + ;; may contain interpreted closures and hence source code where we *do* + ;; want to apply `edebug-unwrap'. + ;; So based on this experience, we now also apply `edebug-unwrap*' to + ;; the already evaluated arguments. + ;;(unless (edebug--frame-evald frame) + (cl-callf (lambda (xs) (mapcar #'edebug-unwrap* xs)) + (edebug--frame-args frame))) (defun edebug--add-source-info (frame def-name before-index after-index) "Update FRAME with the additional info needed by an edebug--frame. From 044558766a77b1c9b8a7e6d757ca65730a88b88d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 23 Mar 2024 22:27:34 -0400 Subject: [PATCH 150/155] * doc/emacs/help.texi (Name Help): Mention buttons (bug#69935) --- doc/emacs/help.texi | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi index 05457a3f34f..d60310456ff 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -310,6 +310,13 @@ name is defined as a Lisp function. Type @kbd{C-g} to cancel the @kbd{C-h f} command if you don't really want to view the documentation. + The function's documentation displayed by @code{describe-function} +includes more than just the documentation string and the signature of +the function. It also shows auxiliary information such as its type, the +file where it was defined, whether it has been declared obsolete, and +yet further information is often reachable by clicking or typing +@key{RET} on emphasized parts of the text. + @vindex help-enable-symbol-autoload If you request help for an autoloaded function whose @code{autoload} form (@pxref{Autoload,,, elisp, The Emacs Lisp Reference Manual}) From a496378c94176930583e63ef5c95477f092a872b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 23 Mar 2024 22:48:17 -0400 Subject: [PATCH 151/155] cl-preloaded.el: Improve docstrings of "kinds" * lisp/emacs-lisp/cl-preloaded.el (cl--class): Improve the docstring. (built-in-class): Add a docstring. --- lisp/emacs-lisp/cl-preloaded.el | 4 +++- lisp/emacs-lisp/cl-print.el | 2 +- lisp/emacs-lisp/nadvice.el | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index f7757eae9c0..8428ec4beb7 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -260,7 +260,7 @@ (cl-defstruct (cl--class (:constructor nil) (:copier nil)) - "Type of descriptors for any kind of structure-like data." + "Abstract supertype of all type descriptors." ;; Intended to be shared between defstruct and defclass. (name nil :type symbol) ;The type name. (docstring nil :type string) @@ -306,6 +306,8 @@ (:constructor nil) (:constructor built-in-class--make (name docstring parents)) (:copier nil)) + "Type descriptors for built-in types. +The `slots' (and hence `index-table') are currently unused." ) (defmacro cl--define-built-in-type (name parents &optional docstring &rest slots) diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index c35353ec3d0..5e5eee1da9e 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -444,7 +444,7 @@ primitives such as `prin1'.") (defun cl-print--preprocess (object) (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0))) - (if (fboundp 'print--preprocess) + (if (fboundp 'print--preprocess) ;Emacs≥26 ;; Use the predefined C version if available. (print--preprocess object) ;Fill print-number-table! (let ((cl-print--number-index 0)) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 7524ab18e58..5326c520601 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -189,7 +189,7 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") if (cl-assert (eq 'interactive (car if))) (let ((form (cadr if))) - (if (macroexp-const-p form) + (if (macroexp-const-p form) ;Common case: a string. if ;; The interactive is expected to be run in the static context ;; that the function captured. From 2be41da38ef5432b6038058fcb0c284164fcb370 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sun, 24 Mar 2024 10:59:54 +0800 Subject: [PATCH 152/155] Improve consistency of content file name handling * java/org/gnu/emacs/EmacsService.java (getDisplayNameHash): Always encode file names as modified UTF-8, as insurance against future changes to undocumented behavior of the JVM. --- java/org/gnu/emacs/EmacsService.java | 46 +++++++++++++++++++++++----- 1 file changed, 38 insertions(+), 8 deletions(-) diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 785163c713c..07bfb525be9 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -19,6 +19,7 @@ package org.gnu.emacs; +import java.io.ByteArrayOutputStream; import java.io.FileNotFoundException; import java.io.IOException; import java.io.UnsupportedEncodingException; @@ -1041,17 +1042,46 @@ invocation of app_process (through android-emacs) can getDisplayNameHash (String string) { byte[] encoded; + ByteArrayOutputStream stream; + int i, ch; - try + /* Much of the VFS code expects file names to be encoded as modified + UTF-8 data, but Android's JNI implementation produces (while not + accepting!) regular UTF-8 sequences for all characters, even + non-Emoji ones. With no documentation to this effect, save for + two comments nestled in the source code of the Java virtual + machine, it is not sound to assume that this behavior will not be + revised in future or modified releases of Android, and as such, + encode STRING into modified UTF-8 by hand, to protect against + future changes in this respect. */ + + stream = new ByteArrayOutputStream (); + + for (i = 0; i < string.length (); ++i) { - encoded = string.getBytes ("UTF-8"); - return EmacsNative.displayNameHash (encoded); - } - catch (UnsupportedEncodingException exception) - { - /* This should be impossible. */ - return "error"; + ch = string.charAt (i); + + if (ch != 0 && ch <= 127) + stream.write (ch); + else if (ch <= 2047) + { + stream.write (0xc0 | (0x1f & (ch >> 6))); + stream.write (0x80 | (0x3f & ch)); + } + else + { + stream.write (0xe0 | (0x0f & (ch >> 12))); + stream.write (0x80 | (0x3f & (ch >> 6))); + stream.write (0x80 | (0x3f & ch)); + } } + + encoded = stream.toByteArray (); + + /* Closing a ByteArrayOutputStream has no effect. + encoded.close (); */ + + return EmacsNative.displayNameHash (encoded); } /* Build a content file name for URI. From 7206a620af2de7281d9c9299582241a10e79e1a3 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sun, 24 Mar 2024 11:02:34 +0800 Subject: [PATCH 153/155] Don't define user-ptr type when user-ptrp is not present * lisp/emacs-lisp/cl-preloaded.el (user-ptr): Condition on presence of predicate function. --- lisp/emacs-lisp/cl-preloaded.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 8428ec4beb7..f27933ed054 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -356,8 +356,10 @@ The `slots' (and hence `index-table') are currently unused." (cl--define-built-in-type tree-sitter-compiled-query atom) (cl--define-built-in-type tree-sitter-node atom) (cl--define-built-in-type tree-sitter-parser atom) -(cl--define-built-in-type user-ptr atom - nil :predicate user-ptrp) ;; FIXME: Shouldn't it be called `user-ptr-p'? +(declare-function user-ptrp "data.c") +(unless (fboundp 'user-ptrp) + (cl--define-built-in-type user-ptr atom nil + :predicate user-ptrp)) ;; FIXME: Shouldn't it be called `user-ptr-p'? (cl--define-built-in-type font-object atom) (cl--define-built-in-type font-entity atom) (cl--define-built-in-type font-spec atom) From 30b1b0d7cd8e4d46a601e9737350cda970f6bab0 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Sun, 24 Mar 2024 11:05:31 +0800 Subject: [PATCH 154/155] ; * lisp/emacs-lisp/cl-preloaded.el (user-ptr): Fix typo. Author: --- lisp/emacs-lisp/cl-preloaded.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index f27933ed054..35a8d79a1cd 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -357,9 +357,11 @@ The `slots' (and hence `index-table') are currently unused." (cl--define-built-in-type tree-sitter-node atom) (cl--define-built-in-type tree-sitter-parser atom) (declare-function user-ptrp "data.c") -(unless (fboundp 'user-ptrp) +(when (fboundp 'user-ptrp) (cl--define-built-in-type user-ptr atom nil - :predicate user-ptrp)) ;; FIXME: Shouldn't it be called `user-ptr-p'? + ;; FIXME: Shouldn't it be called + ;; `user-ptr-p'? + :predicate user-ptrp)) (cl--define-built-in-type font-object atom) (cl--define-built-in-type font-entity atom) (cl--define-built-in-type font-spec atom) From c5de73a95a6ecefe46fe1ac07da8e83032be7f5b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 24 Mar 2024 11:29:37 +0100 Subject: [PATCH 155/155] Fix native compilation for circular immediates (bug#67883) * test/src/comp-resources/comp-test-funcs.el (comp-test-67883-1-f): New function. * lisp/emacs-lisp/comp.el (comp--collect-rhs) (comp--ssa-rename-insn): Handle setimm aside to avoid unnecessary immediate manipulation. (comp--copy-insn-rec): Rename. (comp--copy-insn): New function. (comp--dead-assignments-func): Handle setimm aside to avoid unnecessary. --- lisp/emacs-lisp/comp.el | 18 +++++++++++++++--- test/src/comp-resources/comp-test-funcs.el | 3 +++ 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 1df1e3b3ddb..4ddf90349d1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1788,7 +1788,9 @@ into the C code forwarding the compilation unit." for insn in (comp-block-insns b) for (op . args) = insn if (comp--assign-op-p op) - do (comp--collect-mvars (cdr args)) + do (comp--collect-mvars (if (eq op 'setimm) + (cl-first args) + (cdr args))) else do (comp--collect-mvars args)))) @@ -2442,6 +2444,8 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn + (`(setimm ,(pred targetp) ,_imm) + (new-lvalue)) (`(,(pred comp--assign-op-p) ,(pred targetp) . ,_) (let ((mvar (comp-vec-aref frame slot-n))) (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) @@ -2545,7 +2549,7 @@ Return t when one or more block was removed, nil otherwise." ;; native compiling all Emacs code-base. "Max number of scanned insn before giving-up.") -(defun comp--copy-insn (insn) +(defun comp--copy-insn-rec (insn) "Deep copy INSN." ;; Adapted from `copy-tree'. (if (consp insn) @@ -2562,6 +2566,13 @@ Return t when one or more block was removed, nil otherwise." (copy-comp-mvar insn) insn))) +(defun comp--copy-insn (insn) + "Deep copy INSN." + (pcase insn + (`(setimm ,mvar ,imm) + `(setimm ,(copy-comp-mvar mvar) ,imm)) + (_ (comp--copy-insn-rec insn)))) + (defmacro comp--apply-in-env (func &rest args) "Apply FUNC to ARGS in the current compilation environment." `(let ((env (cl-loop @@ -2903,7 +2914,8 @@ Return the list of m-var ids nuked." for (op arg0 . rest) = insn if (comp--assign-op-p op) do (push (comp-mvar-id arg0) l-vals) - (setf r-vals (nconc (comp--collect-mvar-ids rest) r-vals)) + (unless (eq op 'setimm) + (setf r-vals (nconc (comp--collect-mvar-ids rest) r-vals))) else do (setf r-vals (nconc (comp--collect-mvar-ids insn) r-vals)))) ;; Every l-value appearing that does not appear as r-value has no right to diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el index dc4abf50767..54f339f6373 100644 --- a/test/src/comp-resources/comp-test-funcs.el +++ b/test/src/comp-resources/comp-test-funcs.el @@ -559,6 +559,9 @@ (let ((time (make-comp-test-time :unix (time-convert (current-time) 'integer)))) (comp-test-67239-0-f "%F" time))) +(defun comp-test-67883-1-f () + '#1=(1 . #1#)) + ;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests ;;