Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-06-14 04:21:24 +00:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs

Browse source
This commit is contained in:
Michael Albinus 2026-05-04 16:07:29 +02:00
commit ee1cbd9775
55 changed files with 1374 additions and 506 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
admin/MAINTAINERS
View file

@ -235,6 +235,7 @@ Philip Kaludercic
lisp/emacs-lisp/package.el
lisp/emacs-lisp/package-vc.el
lisp/emacs-lisp/compat.el
lisp/textmodes/sgml-mode.el
Yuan Fu
src/treesit.c

4
configure.ac
View file

@ -1790,7 +1790,9 @@ AS_IF([test $gl_gcc_warnings = no],
;;
esac
AS_IF([test $gl_gcc_warnings = yes],
[WERROR_CFLAGS=-Werror],
[WERROR_CFLAGS=-Werror
# Work around GCC bug 125116.
gl_WARN_ADD([-Wno-analyzer-allocation-size])],
[# Use -fanalyzer and related options only if --enable-gcc-warnings,
# as they slow GCC considerably.
nw="$nw -fanalyzer -Wno-analyzer-double-free -Wno-analyzer-malloc-leak"

61
doc/lispintro/emacs-lisp-intro.texi
View file

@ -1366,8 +1366,11 @@ following in it:
---------- Buffer: *Backtrace* ----------
Debugger entered--Lisp error: (void-function this)
(this is an unquoted list)
eval((this is an unquoted list) nil)
(progn (this is an unquoted list))
eval((progn (this is an unquoted list)) t)
elisp--eval-last-sexp(nil)
#f(compiled-function () #<bytecode ...>)()
handler-bind-1(#f(compiled-function () #<bytecode ...>) (error) eval-expression--debug)
eval-last-sexp(nil)
funcall-interactively(eval-last-sexp nil)
call-interactively(eval-last-sexp nil nil)
@ -1807,6 +1810,8 @@ Debugger entered--Lisp error: (void-function fill-column)
(fill-column)
eval((fill-column) nil)
elisp--eval-last-sexp(nil)
#f(compiled-function () #<bytecode ...>)()
handler-bind-1(#f(compiled-function () #<bytecode ...>) (error) eval-expression--debug)
eval-last-sexp(nil)
funcall-interactively(eval-last-sexp nil)
call-interactively(eval-last-sexp nil nil)
@ -1843,8 +1848,10 @@ says:
@group
---------- Buffer: *Backtrace* ----------
Debugger entered--Lisp error: (void-variable +)
eval(+)
eval(+ nil)
elisp--eval-last-sexp(nil)
#f(compiled-function () #<bytecode ...>)()
handler-bind-1(#f(compiled-function () #<bytecode ...>) (error) eval-expression--debug)
eval-last-sexp(nil)
funcall-interactively(eval-last-sexp nil)
call-interactively(eval-last-sexp nil nil)
@ -2099,15 +2106,16 @@ You will create and enter a @file{*Backtrace*} buffer that says:
@smallexample
@group
---------- Buffer: *Backtrace* ----------
Debugger entered--Lisp error:
(wrong-type-argument number-or-marker-p hello)
Debugger entered--Lisp error: (wrong-type-argument number-or-marker-p hello)
+(2 hello)
eval((+ 2 'hello) nil)
elisp--eval-last-sexp(t)
elisp--eval-last-sexp(nil)
#f(compiled-function () #<bytecode ...>)()
handler-bind-1(#f(compiled-function () #<bytecode ...>) (error) eval-expression--debug)
eval-last-sexp(nil)
funcall-interactively(eval-print-last-sexp nil)
call-interactively(eval-print-last-sexp nil nil)
command-execute(eval-print-last-sexp)
funcall-interactively(eval-last-sexp nil)
call-interactively(eval-last-sexp nil nil)
command-execute(eval-last-sexp)
---------- Buffer: *Backtrace* ----------
@end group
@end smallexample
@ -17938,13 +17946,16 @@ Debugger entered--Lisp error: (void-function 1=)
(let ((total 0)) (while (> number 0) (setq total ...)
(setq number ...)) total)
triangle-bugged(4)
eval((triangle-bugged 4) nil)
@end group
@group
eval((triangle-bugged 4) nil)
eval-expression((triangle-bugged 4) nil nil 127)
funcall-interactively(eval-expression (triangle-bugged 4) nil nil 127)
call-interactively(eval-expression nil nil)
command-execute(eval-expression)
elisp--eval-last-sexp(nil)
#f(compiled-function () #<bytecode ...>)()
handler-bind-1(#f(compiled-function () #<bytecode ...>) (error) eval-expression--debug)
eval-last-sexp(nil)
funcall-interactively(eval-last-sexp nil)
call-interactively(eval-last-sexp nil nil)
command-execute(eval-last-sexp)
---------- Buffer: *Backtrace* ----------
@end group
@end smallexample
@ -18042,10 +18053,13 @@ Debugger entered--entering a function:
eval((triangle-bugged 5) nil)
@end group
@group
eval-expression((triangle-bugged 5) nil nil 127)
funcall-interactively(eval-expression (triangle-bugged 5) nil nil 127)
call-interactively(eval-expression nil nil)
command-execute(eval-expression)
elisp--eval-last-sexp(nil)
#f(compiled-function () #<bytecode ...>)()
handler-bind-1(#f(compiled-function () #<bytecode ...>) (error) eval-expression--debug)
eval-last-sexp(nil)
funcall-interactively(eval-last-sexp nil)
call-interactively(eval-last-sexp nil nil)
command-execute(eval-last-sexp)
---------- Buffer: *Backtrace* ----------
@end group
@end smallexample
@ -18094,12 +18108,15 @@ Debugger entered--beginning evaluation of function call form:
(setq number ...)) total)
* triangle-bugged(5)
eval((triangle-bugged 5) nil)
@group
@end group
eval-expression((triangle-bugged 5) nil nil 127)
funcall-interactively(eval-expression (triangle-bugged 5) nil nil 127)
call-interactively(eval-expression nil nil)
command-execute(eval-expression)
@group
elisp--eval-last-sexp(nil)
#f(compiled-function () #<bytecode ...>)()
handler-bind-1(#f(compiled-function () #<bytecode ...>) (error) eval-expression--debug)
eval-last-sexp(nil)
funcall-interactively(eval-last-sexp nil)
call-interactively(eval-last-sexp nil nil)
command-execute(eval-last-sexp)
---------- Buffer: *Backtrace* ----------
@end group
@end smallexample

4
doc/misc/transient.texi
View file

@ -31,7 +31,7 @@ General Public License for more details.
@finalout
@titlepage
@title Transient User and Developer Manual
@subtitle for version 0.13.0
@subtitle for version 0.13.2
@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.13.0.
This manual is for Transient version 0.13.2.
@insertcopying
@end ifnottex

4
doc/translations/fr/misc/ses-fr.texi
View file

@ -58,7 +58,7 @@ modify this GNU manual.''
@top @acronym{SES}: Simple Emacs Spreadsheet
@display
@acronym{SES} est mode majeur de GNU Emacs pour éditer des fichiers
@acronym{SES} est un mode majeur de GNU Emacs pour éditer des fichiers
tableur, c.-à-d.@: des fichiers contenant une grille rectangulaire de
cellules. Les valeurs des cellules sont spécifiées par des formules
pouvant se référer aux valeurs d’autres cellules.
@ -70,7 +70,7 @@ Pour les rapports d’anomalie, utiliser @kbd{M-x report-emacs-bug}.
@insertcopying
@menu
* Boniment: Sales Pitch. Pourquoi utiliser @acronym{SES}?
* Boniment: Sales Pitch. Pourquoi utiliser @acronym{SES} ?
* Tuto: Quick Tutorial. Une introduction sommaire
* Les bases: The Basics. Les commandes de base du tableur
* Fonctions avancées: Advanced Features. Vous voulez en savoir plus ?

17
etc/ERC-NEWS
View file

@ -14,8 +14,25 @@ GNU Emacs since Emacs version 22.1.
* Changes in ERC 5.6.2
** Option 'erc-log-insert-log-on-open' can be a function.
Rather than insert redundant logs into all buffers when reconnecting,
which is what happens when this option is set to t, ERC 5.6.2 allows
users to exercise more control by specifying a predicate. The provided
'erc-log-new-target-buffer-p' tells ERC to only insert logs when
creating a new target buffer, such as when issuing a "/JOIN" or a
"/QUERY" or when connecting for the first time with autojoin configured.
** Changes in the library API.
*** Function 'erc-log-setup-logging' deprecated.
In order to ensure proper buffer-local setup, the 'log' module has
always run this function somewhat indiscriminately and overly often.
This might be fine were it not for the function's interest in the option
'erc-log-insert-log-on-open' and its consequent altering of buffer text
in a manner only conducive to buffer creation. The module now conducts
such business in a tidier and more internal fashion that no longer has
any use for the function nor its presence in 'erc-connect-pre-hook'.
*** Accessors like 'erc-channel-user-voice' may ignore assignments.
ERC now silently ignores attempts to enable certain status flags on
'erc-channel-user' objects if the connection's "PREFIX" parameter omits

5
etc/NEWS
View file

@ -976,11 +976,10 @@ It is equivalent to running 'project-any-command' with
The prompt now displays the chosen project on which to invoke a command.
---
*** 'project-prompter' values may be called with up to four arguments.
*** 'project-prompter' values may be called with up to three arguments.
These allow callers of the value of 'project-prompter' to specify a
prompt string; prompt the user to choose between a subset of all the
known projects; disallow returning arbitrary directories; and allow
returning an empty string.
known projects; and disallow returning arbitrary directories.
See the docstring of 'project-prompter' for a full specification of
these new optional arguments.

2
etc/themes/newcomers-presets-theme.el
View file

@ -19,7 +19,7 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary
;;; Commentary:
;; This theme configures user options that we can reasonably expect the
;; average, new user to want to enable, but would otherwise be unlikely

14
lib-src/emacsclient.c
View file

@ -2257,6 +2257,11 @@ main (int argc, char **argv)
char *p = recv_buf;
for (char *end_p = p; end_p < recv_buf + nrecv; p = end_p)
{
/* An unquoted newline ends a server command. Keep reading,
possibly growing the buffer, until a buffer with a newline
is received. This handles commands with arbitrary-long
arguments (actually needed in 'print' and 'error' commands,
which are followed by strings). */
end_p = memchr (p, '\n', recv_buf + nrecv - p);
if (!end_p)
break;
@ -2288,7 +2293,8 @@ main (int argc, char **argv)
}
else if (strprefix ("-print ", p))
{
/* -print STRING: Print STRING on the terminal. */
/* -print STRING: Print STRING, preceeded by a newline, on
the terminal. */
if (!suppress_output)
{
char *str = unquote_argument (p + strlen ("-print "));
@ -2299,8 +2305,10 @@ main (int argc, char **argv)
}
else if (strprefix ("-print-nonl ", p))
{
/* -print-nonl STRING: Print STRING on the terminal.
Used to continue a preceding -print command. */
/* -print-nonl STRING: Print STRING on the terminal
without a preceding newlin. Used to continue a
preceding -print command. Nowadays used only for
servers in Emacs versions before 31. */
if (!suppress_output)
{
char *str = unquote_argument (p + strlen ("-print-nonl "));

4
lisp/emacs-lisp/package.el
View file

@ -468,7 +468,7 @@ BI-DESC should be a `package--bi-desc' object."
:summary (package--bi-desc-summary bi-desc)
:dir 'builtin))
(defconst package--builtin-alist nil)
(defvar package--builtin-alist nil)
(defun package--builtin-alist ()
"Return a alist of built-in packages in the form of `package-alist'.
The alist doesn't include the pseudo-package for Emacs."
@ -2566,7 +2566,7 @@ intended for testing Emacs and/or the packages in a clean environment."
(interactive
(cl-loop for p in (append
(cl-loop for p in (package--alist) append (cdr p))
(cl-loop for p in package-archive-contents append (cdr p)))
(cl-loop for p in (package--archive-contents) append (cdr p)))
unless (package-built-in-p p)
collect (cons (package-desc-full-name p) p) into table
finally return

5
lisp/emacs-lisp/pcase.el
View file

@ -228,10 +228,9 @@ Emacs Lisp manual for more information and examples."
;;;###autoload
(defmacro pcase-exhaustive (exp &rest cases)
"The exhaustive version of `pcase' (which see).
If EXP fails to match any of the patterns in CASES, an error is
signaled.
If EXP fails to match any of the patterns in CASES, signal an error.
In contrast, `pcase' will return nil if there is no match, but
In contrast, `pcase' will return nil if there is no match, but will
not signal an error."
(declare (indent 1) (debug pcase))
(let* ((x (gensym "x"))

1
lisp/emacs-lisp/subr-x.el
View file

@ -322,6 +322,7 @@ automatically killed, which means that in a such case
buffer
(generate-new-buffer " *work*" t))))
;;;###autoload
(defun work-buffer--release (buffer)
"Release work BUFFER."
(if (buffer-live-p buffer)

79
lisp/erc/erc-log.el
View file

@ -157,8 +157,16 @@ arguments."
(const :tag "Disable logging" nil)))
(defcustom erc-log-insert-log-on-open nil
"Insert log file contents into the buffer if a log file exists."
:type 'boolean)
"Insert an existing log file's contents into its associated buffer.
A legacy value of t does so upon connecting and reconnecting in all
buffers, often in an overlapping and redundant fashion. A value of
`erc-log-new-target-buffer-p' does so in new target buffers only. If
set to an arbitrary predicate, ERC calls it with no args in the
associated buffer."
:type '(choice boolean
(function-item :tag "Only new target buffers"
erc-log-new-target-buffer-p)
(function "User-defined predicate taking no args")))
(defcustom erc-save-buffer-on-part t
"Save the channel buffer content using `erc-save-buffer-in-logs' on PART.
@ -231,10 +239,9 @@ also be a predicate function. To only log when you are not set away, use:
(add-hook 'erc-quit-hook #'erc-conditional-save-queries)
(add-hook 'erc-part-hook #'erc-conditional-save-buffer)
;; append, so that 'erc-initialize-log-marker runs first
(add-hook 'erc-connect-pre-hook #'erc-log-setup-logging 'append)
;; FIXME use proper local "setup" function and major-mode hook.
(dolist (buffer (erc-buffer-list))
(erc-log-setup-logging buffer))
(add-hook 'erc-connect-pre-hook #'erc-log--insert-log-on-open 80)
(add-hook 'erc-mode-hook #'erc-log--setup)
(unless erc--updating-modules-p (erc-buffer-do #'erc-log--setup))
(erc--modify-local-map t "C-c C-l" #'erc-save-buffer-in-logs))
;; disable
((remove-hook 'erc-insert-post-hook #'erc-save-buffer-in-logs)
@ -244,36 +251,74 @@ also be a predicate function. To only log when you are not set away, use:
(remove-hook 'kill-emacs-hook #'erc-log-save-all-buffers)
(remove-hook 'erc-quit-hook #'erc-conditional-save-queries)
(remove-hook 'erc-part-hook #'erc-conditional-save-buffer)
(remove-hook 'erc-connect-pre-hook #'erc-log-setup-logging)
(dolist (buffer (erc-buffer-list))
(erc-log-disable-logging buffer))
(remove-hook 'erc-connect-pre-hook #'erc-log--insert-log-on-open)
(remove-hook 'erc-mode-hook #'erc-log--setup)
(erc-buffer-do #'erc-log--setup)
(erc--modify-local-map nil "C-c C-l" #'erc-save-buffer-in-logs)))
;;; functionality referenced from erc.el
(defun erc-log-new-target-buffer-p ()
"Return non-nil during `erc-open' if the current buffer is a new target.
That is, return nil if it's a server buffer or a target being
reassociated from a previous session."
(and (erc-target) (null erc--target-priors)))
;; This function served double duty as the local setup function for both
;; idempotent tasks and destructive ones typically confined to
;; `erc-open'. The caller was implicitly tasked with selectively
;; inhibiting the destructive portion by binding
;; `erc-log-insert-log-on-open' to nil when calling it, which led to
;; bugs.
(defun erc-log-setup-logging (buffer)
"Setup the buffer-local logging variables in the current buffer.
This function is destined to be run from `erc-connect-pre-hook'.
The current buffer is given by BUFFER."
(when (erc-logging-enabled buffer)
(with-current-buffer buffer
(declare (obsolete "use `erc-log-mode' or mimic `erc-log--setup'" "31.1"))
(with-current-buffer buffer
(let ((erc-log-mode t))
(erc-log--setup)
(erc-log--insert-log-on-open))))
;; This module's differs from other global modules in that it allows for
;; effectively disabling itself in a subset of buffers by setting the
;; option `erc-enable-logging' locally to nil. Though not
;; permanent-local, this option's variable is never explicitly killed
;; when the module is disabled, such as via its mode command.
(defun erc-log--setup ()
"Perform buffer-local setup for ERC's log module."
(if erc-log-mode
(when (erc-logging-enabled)
;; If reconnecting, preserve `erc-last-saved-position' from prev
;; session and preempt `erc-initialize-log-marker' in `erc-open'.
(unless erc-last-saved-position
(when-let* ((priors (or erc--server-reconnecting erc--target-priors))
(val (alist-get 'erc-last-saved-position priors))
(_ (eq (current-buffer) (marker-buffer val))))
(setq erc-last-saved-position val)))
(auto-save-mode -1)
(setq buffer-file-name nil)
(add-hook 'write-file-functions #'erc-save-buffer-in-logs nil t)
(add-function :before (local 'erc--clear-function)
#'erc-log--save-on-clear '((depth . 50)))
(when erc-log-insert-log-on-open
#'erc-log--save-on-clear '((depth . 50))))
(erc-log-disable-logging (current-buffer))))
(defun erc-log--insert-log-on-open (&rest _)
"Conditionally perform insertion for `erc-log-insert-log-on-open'."
(when (if (functionp erc-log-insert-log-on-open)
(funcall erc-log-insert-log-on-open)
erc-log-insert-log-on-open)
(with-silent-modifications
(progn
(ignore-errors
(save-excursion
(goto-char (point-min))
(insert-file-contents (erc-current-logfile)))
(move-marker erc-last-saved-position
(1- (point-max))))))))
(insert-file-contents (erc-current-logfile))))))))
(defun erc-log-disable-logging (buffer)
"Disable logging in BUFFER."
(when (erc-logging-enabled buffer)
(with-current-buffer buffer
(remove-function (local 'erc--clear-function) #'erc-log--save-on-clear)
(remove-hook 'write-file-functions #'erc-save-buffer-in-logs t)
(setq buffer-offer-save nil
erc-enable-logging nil))))

5
lisp/erc/erc-pcomplete.el
View file

@ -61,6 +61,11 @@ add this string to nicks completed."
;;;###autoload(put 'completion 'erc--feature 'erc-pcomplete)
;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t)
(put 'completion 'erc-group 'erc-pcomplete)
;; For historical reasons, (the downcased version of) this module's
;; alias is the canonical name used by `erc-modules'. But user code
;; still needs to detect whether the module is enabled based on that
;; name alone, hence this variable alias.
(defvaralias 'erc-completion-mode 'erc-pcomplete-mode)
(define-erc-module pcomplete Completion
"In ERC Completion mode, the TAB key does completion whenever possible."
((add-hook 'erc-mode-hook #'pcomplete-erc-setup)

8
lisp/external-completion.el
View file

@ -67,8 +67,8 @@ may be a shell utility, an inferior process, an http server, etc.
Given a pattern string, the external tool matches it to an
arbitrarily large set of candidates. Since the full set doesn't
need to be transferred to Emacs's address space, this often
results in much faster overall experience, at the expense of the
convenience of offered by other completion styles.
results in a much faster overall experience, at the expense of the
convenience offered by other completion styles.
CATEGORY is a symbol uniquely naming the external tool. This
function links CATEGORY to the style `external', by modifying
@ -95,7 +95,7 @@ non-list.
METADATA is an alist of additional properties such as
`cycle-sort-function' to associate with CATEGORY. This means
that the caller may still retain control the sorting of the
that the caller may still retain control of the sorting of the
candidates while the tool controls the matching.
Optional TRY-COMPLETION-FUNCTION helps some frontends partially
@ -105,7 +105,7 @@ ALL-COMPLETIONS), where PATTERN and POINT are as described above
and ALL-COMPLETIONS are gathered by LOOKUP for these
arguments (this function ensures LOOKUP isn't called more than
needed). If you know the matching method that the external tool
using, TRY-COMPLETION-FUNCTION may return a cons
is using, TRY-COMPLETION-FUNCTION may return a cons
cell (EXPANDED-PATTERN . NEW-POINT). For example, if the tool is
completing by prefix, one could call `try-completion' to find the
largest common prefix in ALL-COMPLETIONS and then return that as

3
lisp/gnus/gnus-srvr.el
View file

@ -31,6 +31,7 @@
(require 'gnus-int)
(require 'gnus-range)
(require 'gnus-cloud)
(require 'gnus-sum)
(autoload 'gnus-group-read-ephemeral-search-group "nnselect")
@ -250,6 +251,8 @@ The following commands are available:
\\{gnus-server-mode-map}"
(when (gnus-visual-p 'server-menu 'menu)
(gnus-server-make-menu-bar))
(gnus-update-format-specifications nil 'server 'server-mode)
(gnus-set-mode-line 'server)
(gnus-simplify-mode-line)
(gnus-set-default-directory)
(setq mode-line-process nil)

13
lisp/gnus/gnus-sum.el
View file

@ -6161,16 +6161,19 @@ If WHERE is `summary', the summary mode line format will be used."
(symbol-value
(intern (format "gnus-%s-mode-line-format-spec" where))))
(let (mode-string)
;; We evaluate this in the summary buffer since these
;; variables are buffer-local to that buffer.
(with-current-buffer gnus-summary-buffer
;; We evaluate this in the summary or server buffer (depending on
;; WHERE) since these variables are buffer-local to these buffers.
(with-current-buffer (if (eq where 'server)
gnus-server-buffer
gnus-summary-buffer)
;; We bind all these variables that are used in the `eval' form
;; below.
(let* ((mformat (symbol-value
(intern
(format "gnus-%s-mode-line-format-spec" where))))
(gnus-tmp-group-name (gnus-mode-string-quote
gnus-newsgroup-name))
(gnus-tmp-group-name (and gnus-newsgroup-name
(gnus-mode-string-quote
gnus-newsgroup-name)))
(gnus-tmp-article-number (or gnus-current-article 0))
(gnus-tmp-unread gnus-newsgroup-unreads)
(gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads))

5
lisp/gnus/gnus.el
View file

@ -1420,7 +1420,7 @@ this variable. I think."
(gnus-redefine-select-method-widget)
(defcustom gnus-updated-mode-lines '(group article summary tree)
(defcustom gnus-updated-mode-lines '(group article summary tree server)
"List of buffers that should update their mode lines.
The list may contain the symbols `group', `article', `tree' and
`summary'. If the corresponding symbol is present, Gnus will keep
@ -1430,7 +1430,8 @@ If this variable is nil, screen refresh may be quicker."
:type '(set (const group)
(const article)
(const summary)
(const tree)))
(const tree)
(const server)))
(defcustom gnus-mode-non-string-length 30
"Max length of mode-line non-string contents.

43
lisp/jsonrpc.el
View file

@ -86,12 +86,14 @@
:documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\
a saved DEFERRED `async-request' from BUF, to be sent not later\
than TIMER as ID.")
(-sync-request-alist ; bug#67945
(-scontrol ; bug#67945
:initform nil
:accessor jsonrpc--sync-request-alist
:documentation "List of ((ID [ANXIOUS...])) where ID refers \
to a sync `jsonrpc-request' and each ANXIOUS to another completed\
request that is higher up in the stack but couldn't run.")
:accessor jsonrpc--scontrol
:documentation "List of ((KEY [ANXIOUS...])) where KEY is \
(:local ID) for an outstanding sync `jsonrpc-request', or \
(:remote ID) while a remote request with that ID is being \
dispatched. Each ANXIOUS is a completed response deferred \
until KEY's entry is popped.")
(-next-request-id
:initform 0
:accessor jsonrpc--next-request-id
@ -291,7 +293,7 @@ dispatcher in CONN."
(with-slots (last-error
(rdispatcher -request-dispatcher)
(ndispatcher -notification-dispatcher)
(sr-alist -sync-request-alist))
(scontrol -scontrol))
conn
(setf last-error error)
(cond
@ -311,23 +313,31 @@ dispatcher in CONN."
)
(;; A remote response that can't run yet (bug#67945)
(and response-p
(and sr-alist (not (eq id (caar sr-alist)))))
(and scontrol (not (equal `(:local ,id) (caar scontrol)))))
(jsonrpc--event
conn 'internal
:log-text
(format "anxious continuation to %s can't run, held up by %s"
id
(mapcar #'car sr-alist)))
(mapcar #'car scontrol)))
(push (cons cont (list result error))
(cdr (car sr-alist))))
(cdr (car scontrol))))
(;; A remote response that can continue now
response-p
(jsonrpc--continue conn id cont result error))
(jsonrpc--continue conn `(:local ,id) cont result error))
(;; A remote request
(and method id)
(let* ((debug-on-error (and debug-on-error
(not jsonrpc-inhibit-debug-on-error)))
reply)
;; While the rdispatcher runs, any arriving response to
;; a previous sync request must not fire its
;; continuation immediately: the resulting `throw' would
;; unwind through the dispatcher and trigger a spurious
;; -32603 instead of a reply. Use `jsonrpc--scontrol'
;; mechanism to defer such continuations until the end
;; of the cleanup below.
(push `((:remote ,id)) (jsonrpc--scontrol conn))
(unwind-protect
(setq
reply
@ -349,7 +359,8 @@ dispatcher in CONN."
(unless reply
(setq reply
`(:error (:code -32603 :message "Internal error"))))
(apply #'jsonrpc--reply conn id method reply))))
(apply #'jsonrpc--reply conn id method reply)
(jsonrpc--continue conn `(:remote ,id)))))
(;; A remote notification
method
(funcall ndispatcher conn (intern method) params))
@ -513,7 +524,7 @@ to the original request (normal or error) are ignored."
;; request, it might have been holding up any outer
;; "anxious" continuations. The following ensures we
;; call them.
(jsonrpc--continue connection id)))
(jsonrpc--continue connection `(:local ,id))))
(cond ((eq 'error (car retval))
(signal 'jsonrpc-error
(cons
@ -902,11 +913,11 @@ Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)"
(defun jsonrpc--continue (conn id &optional cont result error)
(pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer)
cont)
(head (pop (jsonrpc--sync-request-alist conn)))
(head (pop (jsonrpc--scontrol conn)))
(anxious (cdr head)))
(cond
(anxious
(when (not (= (car head) id)) ; sanity check
(when (not (equal (car head) id)) ; sanity check
(error "Internal error: please report this bug"))
;; If there are "anxious" `jsonrpc-request' continuations
;; that should already have been run, they should run now.
@ -998,7 +1009,7 @@ TIMEOUT is nil)."
;; Setup some control structures
;;
(when sync-request
(push (list id) (jsonrpc--sync-request-alist connection)))
(push `((:local ,id)) (jsonrpc--scontrol connection)))
(jsonrpc--schedule
connection id method
@ -1108,7 +1119,7 @@ of the API instead.")
(cl-destructuring-bind (&key method id error &allow-other-keys) message
(let* ((inhibit-read-only t)
(depth (length
(jsonrpc--sync-request-alist connection)))
(jsonrpc--scontrol connection)))
(preamble (format "[jsonrpc] %s[%s]%s "
(pcase type ('error "E") ('debug "D")
(_ (pcase origin

3
lisp/progmodes/c-ts-mode.el
View file

@ -1274,7 +1274,8 @@ if `c-ts-mode-emacs-sources-support' is non-nil."
"goto_statement"
"case_statement")))
(text ,(regexp-opt '("comment"
"raw_string_literal"))))
"raw_string_literal")))
(comment "comment"))
"`treesit-thing-settings' for both C and C++.")
;;; Support for FOR_EACH_* macros

4
lisp/progmodes/eglot.el
View file

@ -625,12 +625,12 @@ Note additionally:
:package-version '(Eglot . "1.19"))
(defcustom eglot-code-action-indicator
(cl-loop for c in '(?💡 ?⚡?✓ ?α ??)
(cl-loop for c in '(?↯ ?⭍ ?✓ ?α ??)
when (char-displayable-p c)
return (make-string 1 c))
"Indicator string for code action suggestions."
:type (let ((basic-choices
(cl-loop for c in '(?💡 ?⚡?✓ ?α ??)
(cl-loop for c in '(?↯ ?⭍ ?✓ ?α ??)
when (char-displayable-p c)
collect `(const :tag ,(format "Use `%c'" c)
,(make-string 1 c)))))

136
lisp/progmodes/project.el
View file

@ -212,8 +212,8 @@ When it is non-nil, `project-current' will always skip prompting too.")
(defcustom project-prompter #'project-prompt-project-dir
"Function to call to prompt for a project.
The function is called either with no arguments or with up to four
optional arguments: (&optional PROMPT PREDICATE REQUIRE-KNOWN ALLOW-EMPTY).
The function is called either with no arguments or with up to three
optional arguments: (&optional PROMPT PREDICATE REQUIRE-KNOWN).
PROMPT is the prompt string to use.
@ -231,12 +231,14 @@ may allow the user to input arbitrary directories. If PREDICATE and
REQUIRE-KNOWN are both non-nil, the value of `project-prompter' should
not return any project root directory for which PREDICATE returns nil.
If ALLOW-EMPTY is non-nil, then irrespective of REQUIRE-KNOWN, the user
may enter nothing (i.e., just type RET).
In this case the function should return \"\". Conventionally this is
used to allow the user to select the current project.
Callers should append something like \" (empty for current project)\" to
PROMPT when passing ALLOW-EMPTY non-nil."
The function must always return a valid project.
If there is a current project, it satisfies PREDICATE (or PREDICATE is
nil), and the method of prompting involves a default selection, then
this default selection should be the current project root. For example
if the function uses `completing-read' then the current project, if any,
should be passed as the DEF argument to `completing-read', and returned
in the case that the user replies with empty input."
:type '(choice (const :tag "Prompt for a project directory"
project-prompt-project-dir)
(const :tag "Prompt for a project name"
@ -1416,7 +1418,7 @@ directories listed in `vc-directory-exclusion-list'."
project "Find file"
all-files nil 'file-name-history
suggested-filename)))
(if (string= file "")
(if (string-empty-p file)
(user-error "You didn't specify the file")
(find-file file))))
@ -1845,7 +1847,7 @@ Return non-nil if PROJECT is not a remote project."
'(metadata . ((category . project-buffer)
(cycle-sort-function . identity))))
((and (eq action t)
(equal string "")) ;Pcm completion or empty prefix.
(string-empty-p string)) ;Pcm completion or empty prefix.
(let* ((all (complete-with-action action buffers string pred))
(non-internal (cl-remove-if (lambda (b) (= (aref b 0) ?\s)) all)))
(if (null non-internal)
@ -2222,10 +2224,10 @@ With some possible metadata (to be decided).")
"Initialize `project--list' if it isn't already initialized."
(when (eq project--list 'unset)
(project--read-project-list)
(if-let* ((pred (alist-get 'list-first-read project-prune-zombie-projects))
((consp project--list))
(inhibit-message t))
(project--delete-zombie-projects pred))))
(when-let* ((pred (alist-get 'list-first-read project-prune-zombie-projects))
((consp project--list))
(inhibit-message t))
(project--delete-zombie-projects pred))))
(defun project--write-project-list ()
"Save `project--list' in `project-list-file'."
@ -2234,10 +2236,10 @@ With some possible metadata (to be decided).")
(insert ";;; -*- lisp-data -*-\n")
(let ((print-length nil)
(print-level nil))
(if-let* ((pred (alist-get 'list-write project-prune-zombie-projects))
((consp project--list))
(inhibit-message t))
(project--delete-zombie-projects pred))
(when-let* ((pred (alist-get 'list-write project-prune-zombie-projects))
((consp project--list))
(inhibit-message t))
(project--delete-zombie-projects pred))
(pp (mapcar (lambda (elem)
(let ((name (car elem)))
(list (if (file-remote-p name) name
@ -2311,8 +2313,7 @@ the project list."
(defvar project--dir-history)
(defun project-prompt-project-dir
(&optional prompt predicate require-known allow-empty)
(defun project-prompt-project-dir (&optional prompt predicate require-known)
"Prompt the user for a directory that is one of the known project roots.
The project is chosen among projects known from the project list,
see `project-list-file'.
@ -2320,13 +2321,17 @@ If PROMPT is non-nil, use it as the prompt string.
If PREDICATE is non-nil, filter possible project choices using this
function; see `project-prompter' for more details.
Unless REQUIRE-KNOWN is non-nil, it's also possible to enter an
arbitrary directory not in the list of known projects.
If ALLOW-EMPTY is non-nil, it is possible to exit with no input."
arbitrary directory not in the list of known projects."
(project--ensure-read-project-list)
(if-let* ((pred (alist-get 'prompt project-prune-zombie-projects))
(inhibit-message t))
(project--delete-zombie-projects pred))
(when-let* ((pred (alist-get 'prompt project-prune-zombie-projects))
(inhibit-message t))
(project--delete-zombie-projects pred))
(let* ((dir-choice "... (choose a dir)")
(current (and-let* ((p (project-current))
(_ (or (null predicate)
(funcall predicate
(project-root p)))))
(project-root p)))
(choices
;; XXX: Just using this for the category (for the substring
;; completion style).
@ -2334,30 +2339,29 @@ If ALLOW-EMPTY is non-nil, it is possible to exit with no input."
(if require-known project--list
(append project--list `(,dir-choice)))))
(project--dir-history (project-known-project-roots))
pr-dir)
(cl-loop
do (setq pr-dir
(let (history-add-new-input)
(completing-read (if prompt
;; TODO: Use `format-prompt' (Emacs 28.1+)
(format "%s: " (substitute-command-keys prompt))
"Select project: ")
choices
(and predicate
(lambda (choice)
(or (equal choice dir-choice)
(funcall predicate choice))))
t nil 'project--dir-history)))
;; If the user simply pressed RET, do this again until they don't.
while (and (not allow-empty) (equal pr-dir "")))
(pr-dir ""))
(while (string-empty-p pr-dir)
;; If the user simply pressed RET (and CURRENT is nil), do this
;; again until they don't.
(setq pr-dir
(let (history-add-new-input)
(completing-read
;; Emacs 28.1+: Use `format-prompt'.
(cond (prompt (format "%s: " prompt))
(current "Select project (default current project): ")
(t "Select project: "))
choices (and predicate
(lambda (choice)
(or (equal choice dir-choice)
(funcall predicate choice))))
t nil 'project--dir-history current))))
(if (equal pr-dir dir-choice)
(read-directory-name "Select directory: " default-directory nil t)
pr-dir)))
(defvar project--name-history)
(defun project-prompt-project-name
(&optional prompt predicate require-known allow-empty)
(defun project-prompt-project-name (&optional prompt predicate require-known)
"Prompt the user for a project, by name, that is one of the known project roots.
The project is chosen among projects known from the project list,
see `project-list-file'.
@ -2365,13 +2369,17 @@ If PROMPT is non-nil, use it as the prompt string.
If PREDICATE is non-nil, filter possible project choices using this
function; see `project-prompter' for more details.
Unless REQUIRE-KNOWN is non-nil, it's also possible to enter an
arbitrary directory not in the list of known projects.
If ALLOW-EMPTY is non-nil, it is possible to exit with no input."
(if-let* ((pred (alist-get 'prompt project-prune-zombie-projects))
(inhibit-message t))
(project--delete-zombie-projects pred))
arbitrary directory not in the list of known projects."
(when-let* ((pred (alist-get 'prompt project-prune-zombie-projects))
(inhibit-message t))
(project--delete-zombie-projects pred))
(let* ((dir-choice "... (choose a dir)")
project--name-history
(current (and-let* ((p (project-current))
(_ (or (null predicate)
(funcall predicate
(project-root p)))))
(project-name p)))
(choices
(let (ret)
;; Iterate in reverse order so project--name-history is in
@ -2390,22 +2398,22 @@ If ALLOW-EMPTY is non-nil, it is possible to exit with no input."
(table (project--file-completion-table
(reverse (if require-known choices
(cons dir-choice choices)))))
pr-name)
(cl-loop
do (setq pr-name
(let (history-add-new-input)
(completing-read (if prompt
(format "%s: " prompt)
"Select project: ")
table nil t nil 'project--name-history)))
;; If the user simply pressed RET, do this again until they don't.
while (and (not allow-empty) (equal pr-name "")))
(pcase pr-name
("" "")
((pred (equal dir-choice)) (read-directory-name "Select directory: "
default-directory nil t))
(_ (let ((proj (assoc pr-name choices)))
(if (stringp proj) proj (project-root (cdr proj))))))))
(pr-name ""))
(while (string-empty-p pr-name)
;; If the user simply pressed RET (and CURRENT is nil), do this
;; again until they don't.
(setq pr-name
(let (history-add-new-input)
(completing-read
;; Emacs 28.1+: Use `format-prompt'.
(cond (prompt (format "%s: " prompt))
(current "Select project (default current project): ")
(t "Select project: "))
table nil t nil 'project--name-history current))))
(if (equal pr-name dir-choice)
(read-directory-name "Select directory: " default-directory nil t)
(let ((proj (assoc pr-name choices)))
(if (stringp proj) proj (project-root (cdr proj)))))))
;;;###autoload
(defun project-known-project-roots ()

4
lisp/server.el
View file

@ -1143,7 +1143,9 @@ The following commands are accepted by the client:
`-print-nonl STRING'
Print STRING on stdout. Used to continue a
preceding -print command that would be too big to send
in a single message.
in a single message. Unused in the server since Emacs 31;
mentioned here only for completeness, because the client
needs to support it when it connects to older Emacsen.
`-error DESCRIPTION'
Signal an error and delete process PROC.

245
lisp/textmodes/sgml-mode.el
View file

@ -4,7 +4,7 @@
;; Foundation, Inc.
;; Author: James Clark <jjc@jclark.com>
;; Maintainer: emacs-devel@gnu.org
;; Maintainer: Philip Kaludercic <philipk@posteo.net>
;; Adapted-By: ESR, Daniel Pfeiffer <occitan@esperanto.org>,
;; F.Potorti@cnuce.cnr.it
;; Keywords: text, hypermedia, comm, languages
@ -47,8 +47,8 @@
(defcustom sgml-basic-offset 2
"Specifies the basic indentation level for `sgml-indent-line'."
:type 'integer
:safe #'integerp)
:type 'natnum
:safe #'natnump)
(defcustom sgml-attribute-offset 0
"Specifies a delta for attribute indentation in `sgml-indent-line'.
@ -65,14 +65,15 @@ When 2, attribute indentation looks like this:
attribute=\"value\">
</element>"
:version "25.1"
:type 'integer
:safe #'integerp)
:type 'natnum
:safe #'natnump)
(defcustom sgml-xml-mode nil
"When non-nil, tag insertion functions will be XML-compliant.
It is set to be buffer-local when the file has
a DOCTYPE or an XML declaration."
:type 'boolean
:safe #'booleanp
:version "22.1")
(define-obsolete-variable-alias 'sgml-transformation
@ -114,49 +115,57 @@ Including ?- makes double dashes into comment delimiters, but
they are really only supposed to delimit comments within DTD
definitions. So we normally turn it off.")
(defvar sgml-quick-keys nil
"Use <, >, &, /, SPC and `sgml-specials' keys \"electrically\" when non-nil.
This takes effect when first loading the `sgml-mode' library.")
(defvar sgml-mode-map
(let ((map (make-keymap))) ;`sparse' doesn't allow binding to charsets.
(define-key map "\C-c\C-i" #'sgml-tags-invisible)
(define-key map (kbd "C-c C-i") #'sgml-tags-invisible)
(define-key map "/" #'sgml-slash)
(define-key map "\C-c\C-n" #'sgml-name-char)
(define-key map "\C-c\C-t" #'sgml-tag)
(define-key map "\C-c\C-a" #'sgml-attributes)
(define-key map "\C-c\C-b" #'sgml-skip-tag-backward)
(define-key map [?\C-c left] #'sgml-skip-tag-backward)
(define-key map "\C-c\C-f" #'sgml-skip-tag-forward)
(define-key map [?\C-c right] #'sgml-skip-tag-forward)
(define-key map "\C-c\C-d" #'sgml-delete-tag)
(define-key map "\C-c\^?" #'sgml-delete-tag)
(define-key map "\C-c?" #'sgml-tag-help)
(define-key map "\C-c]" #'sgml-close-tag)
(define-key map "\C-c/" #'sgml-close-tag)
(define-key map (kbd "C-c C-n") #'sgml-name-char)
(define-key map (kbd "C-c C-t") #'sgml-tag)
(define-key map (kbd "C-c C-a") #'sgml-attributes)
(define-key map (kbd "C-c C-b") #'sgml-skip-tag-backward)
(define-key map (kbd "C-c <left>") #'sgml-skip-tag-backward)
(define-key map (kbd "C-c C-f") #'sgml-skip-tag-forward)
(define-key map (kbd "C-c <right>") #'sgml-skip-tag-forward)
(define-key map (kbd "C-c C-d") #'sgml-delete-tag)
(define-key map (kbd "C-c ^ ?") #'sgml-delete-tag)
(define-key map (kbd "C-c ?") #'sgml-tag-help)
(define-key map (kbd "C-c ]") #'sgml-close-tag)
(define-key map (kbd "C-c /") #'sgml-close-tag)
;; Redundant keybindings, for consistency with TeX mode.
(define-key map "\C-c\C-o" #'sgml-tag)
(define-key map "\C-c\C-e" #'sgml-close-tag)
(define-key map (kbd "C-c C-o") #'sgml-tag)
(define-key map (kbd "C-c C-e") #'sgml-close-tag)
(define-key map "\C-c8" #'sgml-name-8bit-mode)
(define-key map "\C-c\C-v" #'sgml-validate)
(when sgml-quick-keys
(define-key map "&" #'sgml-name-char)
(define-key map "<" #'sgml-tag)
(define-key map " " #'sgml-auto-attributes)
(define-key map ">" #'sgml-maybe-end-tag)
(when (memq ?\" sgml-specials)
(define-key map "\"" #'sgml-name-self))
(when (memq ?' sgml-specials)
(define-key map "'" #'sgml-name-self)))
(let ((c 127)
(map (nth 1 map)))
(while (< (setq c (1+ c)) 256)
(aset map c #'sgml-maybe-name-self)))
(define-key map (kbd "C-c 8") #'sgml-name-8bit-mode)
(define-key map (kbd "C-c C-v") #'sgml-validate)
(cl-loop for c from 128 upto 255
do (define-key map (string c) #'sgml-maybe-name-self))
map)
"Keymap for SGML mode. See also `sgml-specials'.")
(defcustom sgml-quick-keys nil
"Use <, >, &, /, SPC and `sgml-specials' keys \"electrically\" when non-nil.
By setting the option to `indent', Emacs will eagerly reindent the
current line when you manually close a tag."
:set (lambda (sym val)
(set-default sym val)
(dolist (bind `(("&" . ,#'sgml-name-char)
("<" . ,#'sgml-tag)
("\s" . ,#'sgml-auto-attributes)
(">" . ,#'sgml-maybe-end-tag)
("\"" . ,(and (memq ?\" sgml-specials) #'sgml-name-self))
("'" . ,(and (memq ?' sgml-specials) #'sgml-name-self))))
(if (and val (cdr bind))
(define-key sgml-mode-map (car bind) (cdr bind))
(define-key sgml-mode-map (car bind) nil t)))
(custom-reevaluate-setting 'html-quick-keys))
:type '(choice (const :tag "Enabled" t)
(const :tag "Enabled, and indent when closing tags" indent)
;; Omit `close' because `electric-pair-mode' already
;; takes care of paring "<" and ">".
(const :tag "Disabled" nil)))
(easy-menu-define sgml-mode-menu sgml-mode-map
"Menu for SGML mode."
'("SGML"
@ -211,7 +220,7 @@ This takes effect when first loading the `sgml-mode' library.")
table)
"Syntax table used to parse SGML tags.")
(defcustom sgml-name-8bit-mode nil
(define-minor-mode sgml-name-8bit-mode
"When non-nil, insert non-ASCII characters as named entities."
:type 'boolean)
@ -277,12 +286,11 @@ Currently, only Latin-1 characters are supported.")
((executable-find "onsgmls")
;; onsgmls is the community version of `nsgmls'
;; hosted on https://openjade.sourceforge.net/
"onsgmls -s")
(t "Install (o)nsgmls, tidy, or some other SGML validator, and set `sgml-validate-command'"))
"onsgmls -s"))
"The command to validate an SGML document.
The file name of current buffer file name will be appended to this,
separated by a space."
:type 'string
:type '(choice (const :tag "Unset" nil) string)
:version "21.1")
(defvar sgml-saved-validate-command nil
@ -774,14 +782,6 @@ Uses `sgml-char-names'."
(sgml-name-char last-command-event)
(self-insert-command 1)))
(defun sgml-name-8bit-mode ()
"Toggle whether to insert named entities instead of non-ASCII characters.
This only works for Latin-1 input."
(interactive)
(setq sgml-name-8bit-mode (not sgml-name-8bit-mode))
(message "sgml name entity mode is now %s"
(if sgml-name-8bit-mode "ON" "OFF")))
;; When an element of a skeleton is a string "str", it is passed
;; through `skeleton-transformation-function' and inserted.
;; If "str" is to be inserted literally, one should obtain it as
@ -1199,13 +1199,14 @@ with output going to the buffer `*compilation*'.
You can then use the command \\[next-error] to find the next error message
and move to the line in the SGML document that caused it."
(interactive
(list (read-string "Validate command: "
(or sgml-saved-validate-command
(concat sgml-validate-command
" "
(when-let* ((name (buffer-file-name)))
(shell-quote-argument
(file-name-nondirectory name))))))))
(list (read-shell-command "Validate command: "
(or sgml-saved-validate-command
sgml-validate-command
(concat sgml-validate-command
" "
(when-let* ((name (buffer-file-name)))
(shell-quote-argument
(file-name-nondirectory name))))))))
(setq sgml-saved-validate-command command)
(save-some-buffers (not compilation-ask-about-save) nil)
(compilation-start command))
@ -1616,6 +1617,8 @@ the current start-tag or the current comment or the current cdata, ..."
(and (not sgml-xml-mode)
(assoc-string tag-name sgml-unclosed-tags 'ignore-case)))
(defvar sgml-whitespace-sensitive-tags nil
"List of tags where the contents shouldn't be reindented.")
(defun sgml-calculate-indent (&optional lcon)
"Calculate the column to which this line should be indented.
@ -1628,7 +1631,16 @@ LCON is the lexical context, if any."
(save-excursion (goto-char (cdr lcon)) (looking-at "<!--")))
(setq lcon (cons 'comment (+ (cdr lcon) 2))))
(pcase (car lcon)
(pcase-exhaustive (car lcon)
((or (guard (let ((case-fold-search t))
(cl-find (concat "\\`" (regexp-opt sgml-whitespace-sensitive-tags) "\\'")
(save-excursion (sgml-get-context))
:test #'string-match-p
:key #'sgml-tag-name)))
;; We don't know how to indent it. Let's be honest about it.
'pi 'cdata)
nil)
('string
;; Go back to previous non-empty line.
@ -1659,11 +1671,6 @@ LCON is the lexical context, if any."
(forward-char 2) (skip-chars-forward " \t"))
(current-column)))
;; We don't know how to indent it. Let's be honest about it.
('cdata nil)
;; We don't know how to indent it. Let's be honest about it.
('pi nil)
('tag
(goto-char (+ (cdr lcon) sgml-attribute-offset))
(skip-chars-forward "^ \t\n") ;Skip tag name.
@ -1732,12 +1739,7 @@ LCON is the lexical context, if any."
(t
(goto-char there)
(+ (current-column)
(* sgml-basic-offset (length context)))))))
(_
(error "Unrecognized context %s" (car lcon)))
))
(* sgml-basic-offset (length context)))))))))
(defun sgml-indent-line ()
"Indent the current line as SGML."
@ -1792,54 +1794,63 @@ Currently just returns (EMPTY-TAGS UNCLOSED-TAGS)."
:type 'hook
:options '(html-autoview-mode))
(defvar html-quick-keys sgml-quick-keys
"Use C-c X combinations for quick insertion of frequent tags when non-nil.
This defaults to `sgml-quick-keys'.
This takes effect when first loading the library.")
(defvar html-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map sgml-mode-map)
(define-key map "\C-c6" #'html-headline-6)
(define-key map "\C-c5" #'html-headline-5)
(define-key map "\C-c4" #'html-headline-4)
(define-key map "\C-c3" #'html-headline-3)
(define-key map "\C-c2" #'html-headline-2)
(define-key map "\C-c1" #'html-headline-1)
(define-key map "\C-c\r" #'html-paragraph)
(define-key map "\C-c\n" #'html-line)
(define-key map "\C-c\C-c-" #'html-horizontal-rule)
(define-key map "\C-c\C-co" #'html-ordered-list)
(define-key map "\C-c\C-cu" #'html-unordered-list)
(define-key map "\C-c\C-cr" #'html-radio-buttons)
(define-key map "\C-c\C-cc" #'html-checkboxes)
(define-key map "\C-c\C-cl" #'html-list-item)
(define-key map "\C-c\C-ch" #'html-href-anchor)
(define-key map "\C-c\C-cf" #'html-href-anchor-file)
(define-key map "\C-c\C-cn" #'html-name-anchor)
(define-key map "\C-c\C-c#" #'html-id-anchor)
(define-key map "\C-c\C-ci" #'html-image)
(when html-quick-keys
(define-key map "\C-cp" #'html-paragraph)
(define-key map "\C-c-" #'html-horizontal-rule)
(define-key map "\C-cd" #'html-div)
(define-key map "\C-co" #'html-ordered-list)
(define-key map "\C-cu" #'html-unordered-list)
(define-key map "\C-cr" #'html-radio-buttons)
(define-key map "\C-cc" #'html-checkboxes)
(define-key map "\C-cl" #'html-list-item)
(define-key map "\C-ch" #'html-href-anchor)
(define-key map "\C-cf" #'html-href-anchor-file)
(define-key map "\C-cn" #'html-name-anchor)
(define-key map "\C-c#" #'html-id-anchor)
(define-key map "\C-ci" #'html-image)
(define-key map "\C-cs" #'html-span))
(define-key map "\C-c\C-s" #'html-autoview-mode)
(define-key map "\C-c\C-v" #'browse-url-of-buffer)
(define-key map "\M-o" 'facemenu-keymap)
(set-keymap-parent map sgml-mode-map)
(define-key map (kbd "C-c 6") #'html-headline-6)
(define-key map (kbd "C-c 5") #'html-headline-5)
(define-key map (kbd "C-c 4") #'html-headline-4)
(define-key map (kbd "C-c 3") #'html-headline-3)
(define-key map (kbd "C-c 2") #'html-headline-2)
(define-key map (kbd "C-c 1") #'html-headline-1)
(define-key map (kbd "C-c C-m") #'html-paragraph)
(define-key map (kbd "C-c C-j") #'html-line)
(define-key map (kbd "C-c C-c -") #'html-horizontal-rule)
(define-key map (kbd "C-c C-c o") #'html-ordered-list)
(define-key map (kbd "C-c C-c u") #'html-unordered-list)
(define-key map (kbd "C-c C-c r") #'html-radio-buttons)
(define-key map (kbd "C-c C-c c") #'html-checkboxes)
(define-key map (kbd "C-c C-c l") #'html-list-item)
(define-key map (kbd "C-c C-c h") #'html-href-anchor)
(define-key map (kbd "C-c C-c f") #'html-href-anchor-file)
(define-key map (kbd "C-c C-c n") #'html-name-anchor)
(define-key map (kbd "C-c C-c #") #'html-id-anchor)
(define-key map (kbd "C-c C-c i") #'html-image)
(define-key map (kbd "C-c C-s") #'html-autoview-mode)
(define-key map (kbd "C-c C-v") #'browse-url-of-buffer)
(define-key map (kbd "M-o") 'facemenu-keymap)
map)
"Keymap for commands for use in HTML mode.")
(defcustom html-quick-keys sgml-quick-keys
"Use C-c X combinations for quick insertion of frequent tags when non-nil.
This defaults to `sgml-quick-keys', which see."
:set (lambda (sym val)
(set-default sym val)
(dolist (bind `((,(kbd "C-c p") . ,#'html-paragraph)
(,(kbd "C-c -") . ,#'html-horizontal-rule)
(,(kbd "C-c d") . ,#'html-div)
(,(kbd "C-c o") . ,#'html-ordered-list)
(,(kbd "C-c u") . ,#'html-unordered-list)
(,(kbd "C-c r") . ,#'html-radio-buttons)
(,(kbd "C-c c") . ,#'html-checkboxes)
(,(kbd "C-c l") . ,#'html-list-item)
(,(kbd "C-c h") . ,#'html-href-anchor)
(,(kbd "C-c f") . ,#'html-href-anchor-file)
(,(kbd "C-c n") . ,#'html-name-anchor)
(,(kbd "C-c #") . ,#'html-id-anchor)
(,(kbd "C-c i") . ,#'html-image)
(,(kbd "C-c s") . ,#'html-span)))
(if val
(define-key html-mode-map (car bind) (cdr bind))
(define-key html-mode-map (car bind) nil t))))
:set-after '(sgml-quick-keys)
:type '(choice (const :tag "Enabled" t)
(const :tag "Enabled, and indent when closing tags" indent)
;; Omit `close' because `electric-pair-mode' already
;; takes care of paring "<" and ">".
(const :tag "Disabled" nil)))
(easy-menu-define html-mode-menu html-mode-map
"Menu for HTML mode."
'("HTML"
@ -2034,10 +2045,12 @@ This takes effect when first loading the library.")
("caption" ("valign" ("top") ("bottom")))
("center" \n)
("cite")
("code" \n)
("code")
("datalist" \n)
("dd" ,(not sgml-xml-mode))
("del" nil ("cite") ("datetime"))
("details"
(\n "<summary>" (read-string "Title: ") "</summary>" \n _))
("dfn")
("div" \n ("id") ("class"))
("dl" (nil \n
@ -2099,6 +2112,7 @@ This takes effect when first loading the library.")
("param" t ("name") ("value")
("valuetype" ("data") ("ref") ("object")) ("type"))
("person") ;; Tag for person's name tag deprecated in HTML 3.2
("picture" \n) ;TODO: suggest inserting <source> and <img>
("pre" \n)
("progress" nil ("value") ("max"))
("q" nil ("cite"))
@ -2180,6 +2194,7 @@ This takes effect when first loading the library.")
("datalist" . "A set of predefined options")
("dd" . "Definition of term")
("del" . "Deleted text")
("details" . "Details disclosure")
("dfn" . "Defining instance of a term")
("dir" . "Directory list (obsolete)")
("div" . "Generic block-level container")
@ -2247,6 +2262,7 @@ This takes effect when first loading the library.")
("panel" . "Floating panel")
("param" . "Parameters for an object")
("person" . "Person's name")
("picture" . "Picture")
("pre" . "Preformatted fixed width text")
("progress" . "Completion progress of a task")
("q" . "Quotation")
@ -2399,6 +2415,7 @@ To work around that, do:
(setq-local sgml-tag-alist html-tag-alist)
(setq-local sgml-face-tag-alist html-face-tag-alist)
(setq-local sgml-tag-help html-tag-help)
(setq-local sgml-whitespace-sensitive-tags '("pre" "textarea"))
(setq-local outline-regexp "^.*<[Hh][1-6]\\>")
(setq-local outline-heading-end-regexp "</[Hh][1-6]>")
(setq-local outline-level

12
lisp/transient.el
View file

@ -5,7 +5,7 @@
;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; URL: https://github.com/magit/transient
;; Keywords: extensions
;; Version: 0.13.0
;; Version: 0.13.2
;; SPDX-License-Identifier: GPL-3.0-or-later
@ -39,7 +39,7 @@
;;; Code:
;;;; Frontmatter
(defconst transient-version "v0.13.0-10-g5b2ff26f-builtin")
(defconst transient-version "v0.13.2-10-gf7894ca4-builtin")
(require 'cl-lib)
(require 'eieio)
@ -5523,11 +5523,11 @@ search instead."
2)
lisp-imenu-generic-expression :test #'equal)
(defvar overriding-text-conversion-style)
(defun transient--suspend-text-conversion-style ()
(when (and text-conversion-style
(bound-and-true-p overriding-text-conversion-style))
(when (and (bound-and-true-p text-conversion-style)
(bound-and-true-p overriding-text-conversion-style)
;; Somehow the above does not silence the compiler.
(boundp 'overriding-text-conversion-style))
(letrec ((suspended overriding-text-conversion-style)
(fn (lambda ()
(setq overriding-text-conversion-style nil)

14
lisp/treesit.el
View file

@ -4454,12 +4454,14 @@ For BOUND, MOVE, BACKWARD, LOOKING-AT, see the descriptions in
(setq level (1+ level)))
;; Continue counting the host nodes.
(dolist (parser (mapcar #'cdr (treesit-parsers-at (point) nil t '(global local))))
(let* ((node (treesit-node-at (point) parser))
(lang (treesit-parser-language parser))
(pred (alist-get lang treesit-aggregated-outline-predicate)))
(while (setq node (treesit-parent-until node pred))
(setq level (1+ level)))))
(when treesit-aggregated-outline-predicate
(dolist (parser (mapcar #'cdr (treesit-parsers-at
(point) nil t '(global local))))
(let* ((node (treesit-node-at (point) parser))
(lang (treesit-parser-language parser))
(pred (alist-get lang treesit-aggregated-outline-predicate)))
(while (setq node (treesit-parent-until node pred))
(setq level (1+ level))))))
level))

2
lisp/vc/vc-dir.el
View file

@ -1305,7 +1305,7 @@ that file."
(defun vc-dir-resynch-file (&optional fname)
"Update the entries for FNAME in any directory buffers that list it."
(let ((file (expand-file-name (or fname buffer-file-name)))
(let ((file (file-truename (or fname buffer-file-name)))
(drop '()))
(save-current-buffer
;; look for a vc-dir buffer that might show this file.

40
lisp/vc/vc.el
View file

@ -5732,15 +5732,14 @@ When called from Lisp, BACKEND is the VC backend."
(dired directory))
(defvar project-prompter)
(declare-function project-root "project")
(defun vc--prompt-other-working-tree (backend prompt &optional allow-empty)
(defun vc--prompt-other-working-tree (backend prompt &optional allow-current)
"Invoke `project-prompter' to choose another working tree.
BACKEND is the VC backend.
PROMPT is the prompt string for `project-prompter'.
If ALLOW-EMPTY is non-nil, empty input means the current working tree.
In typical usage ALLOW-EMPTY non-nil means that it makes sense to apply
the caller's operation to the current working tree."
;; If there are no other working trees and ALLOW-EMPTY is non-nil, we
If ALLOW-CURRENT is non-nil, allow selecting the current working tree."
;; If there are no other working trees and ALLOW-CURRENT is non-nil we
;; still invoke the `project-prompter' and require the user to type
;; \\`RET', even though it's redundant. Doing it this way means that
;; invoking the command on the current working tree works the same
@ -5752,25 +5751,25 @@ the caller's operation to the current working tree."
;; stopping to look at the echo area.
(let ((trees (vc-call-backend backend 'known-other-working-trees))
res)
(unless (or trees allow-empty)
(user-error
(substitute-command-keys
"No other working trees. Use \\[vc-add-working-tree] to add one")))
(require 'project)
(cond* ((bind-and* (_ allow-current)
(p (project-current)))
(push (project-root p) trees))
((null trees)
(user-error
(substitute-command-keys
"No other working trees. Use \\[vc-add-working-tree] to add one"))))
(dolist (tree trees)
(when-let* ((p (project-current nil tree)))
(project-remember-project p nil t)))
(setq res
(funcall project-prompter
(if allow-empty
(format "%s (empty for this working tree)"
prompt)
(if allow-current
(concat prompt " (default current working tree)")
prompt)
(if trees
(lambda (k &optional _v)
(member (or (car-safe k) k) trees))
#'ignore)
t allow-empty))
(lambda (k &optional _v)
(member (or (car-safe k) k) trees))
'require-known))
(if (string-empty-p res) (vc-root-dir) res)))
(defvar project-current-directory-override)
@ -5801,7 +5800,8 @@ Prompts for the directory file name of the other working tree."
(interactive
(list
(vc--prompt-other-working-tree (vc-responsible-backend default-directory)
"Other working tree to switch to")))
"Other working tree to switch to"
'allow-current)))
(project-switch-project dir))
;;;###autoload
@ -5814,7 +5814,7 @@ BACKEND is the VC backend."
(let ((backend (vc-responsible-backend default-directory)))
(list backend
(vc--prompt-other-working-tree backend "Delete working tree"
'allow-empty))))
'allow-current))))
(let* ((delete-this (file-in-directory-p default-directory directory))
(directory (expand-file-name directory))
(default-directory
@ -5860,7 +5860,7 @@ BACKEND is the VC backend."
(let ((backend (vc-responsible-backend default-directory)))
(list backend
(vc--prompt-other-working-tree backend "Relocate working tree"
'allow-empty)
'allow-current)
(read-directory-name "New location for working tree: "
(file-name-parent-directory (vc-root-dir))))))
(let* ((move-this (file-in-directory-p default-directory from))

8
src/.gdbinit
View file

@ -41,15 +41,13 @@ handle SIGTSTP nopass
handle SIGUSR1 noprint pass
handle SIGUSR2 noprint pass
# Similarly with SIGPIPE (happens, e.g., with GnuTLS).
handle SIGPIPE nostop noprint pass
# Don't pass SIGALRM to Emacs. This makes problems when
# debugging.
handle SIGALRM ignore
# On selection send failed.
if defined_HAVE_PGTK
handle SIGPIPE nostop noprint
end
# Helper command to get the pointer to the C struct that holds the data
# of a Lisp object given as argument, by removing the GC and type-tag bits.
# Stores the result in $ptr.

5
src/androidterm.c
View file

@ -2260,10 +2260,13 @@ android_wait_for_event (struct frame *f, int eventtype)
{
pending_signals = true;
totally_unblock_input ();
/* XTread_socket is called after unblock. */
/* android_read_socket is called after unblock. */
block_input ();
interrupt_input_blocked = level;
if (!f->wait_event_type)
break;
time_now = current_timespec ();
if (timespec_cmp (tmo_at, time_now) < 0)
break;

5
src/dispnew.c
View file

@ -1937,6 +1937,11 @@ fake_current_matrices (Lisp_Object window)
{
r->used[LEFT_MARGIN_AREA] = m->left_margin_glyphs;
r->used[RIGHT_MARGIN_AREA] = m->right_margin_glyphs;
/* Non-rightmost windows have the border glyph at the
end of the right margin, if any, in addition to the
glyphs reserved for the margin itself. */
if (m->right_margin_glyphs > 0 && !WINDOW_RIGHTMOST_P (w))
r->used[RIGHT_MARGIN_AREA]++;
r->used[TEXT_AREA] = (m->matrix_w
- r->used[LEFT_MARGIN_AREA]
- r->used[RIGHT_MARGIN_AREA]);

141
src/gtkutil.c
View file

@ -1181,8 +1181,6 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
int outer_height
= height + FRAME_TOOLBAR_HEIGHT (f) + FRAME_MENUBAR_HEIGHT (f);
int outer_width = width + FRAME_TOOLBAR_WIDTH (f);
bool was_visible = false;
bool hide_child_frame;
#ifndef HAVE_PGTK
gtk_window_get_size (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
@ -1202,9 +1200,6 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
}
#endif
/* Do this before resize, as we don't know yet if we will be resized. */
FRAME_RIF (f)->clear_under_internal_border (f);
outer_height /= xg_get_scale (f);
outer_width /= xg_get_scale (f);
@ -1220,108 +1215,36 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
remain unchanged but giving the frame back its normal size will
be broken ... */
if (EQ (fullscreen, Qfullwidth) && width == FRAME_PIXEL_WIDTH (f))
#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
gwidth, outer_height);
#else
if (FRAME_GTK_OUTER_WIDGET (f))
{
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
gwidth, outer_height);
}
else
{
gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
gwidth, outer_height);
}
#endif
outer_width = gwidth;
else if (EQ (fullscreen, Qfullheight) && height == FRAME_PIXEL_HEIGHT (f))
outer_height = gheight;
else
fullscreen = Qnil;
#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, gheight);
#else
if (FRAME_GTK_OUTER_WIDGET (f))
{
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, gheight);
}
else
{
gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
outer_width, gheight);
}
#endif
else if (FRAME_PARENT_FRAME (f) && FRAME_VISIBLE_P (f))
if (FRAME_PARENT_FRAME (f))
{
was_visible = true;
#ifndef HAVE_PGTK
hide_child_frame = EQ (x_gtk_resize_child_frames, Qhide);
#else
hide_child_frame = false;
gdk_window_resize (gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
/* Resize all inner widgets and Cairo surface right away so the
next redisplay drawing isn't clipped to the old size. */
GtkAllocation alloc = {0, 0, outer_width, outer_height};
gtk_widget_size_allocate (FRAME_GTK_OUTER_WIDGET (f), &alloc);
#ifdef USE_CAIRO
x_cr_update_surface_desired_size (f, width, height);
#endif
if (outer_width != gwidth || outer_height != gheight)
{
if (hide_child_frame)
{
block_input ();
#ifndef HAVE_PGTK
gtk_widget_hide (FRAME_GTK_OUTER_WIDGET (f));
#else
gtk_widget_hide (FRAME_WIDGET (f));
#endif
unblock_input ();
}
#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
#else
if (FRAME_GTK_OUTER_WIDGET (f))
{
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
}
else
{
gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
outer_width, outer_height);
}
#endif
if (hide_child_frame)
{
block_input ();
#ifndef HAVE_PGTK
gtk_widget_show_all (FRAME_GTK_OUTER_WIDGET (f));
#else
gtk_widget_show_all (FRAME_WIDGET (f));
#endif
unblock_input ();
}
fullscreen = Qnil;
}
}
else
{
#ifndef HAVE_PGTK
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
#else
if (FRAME_GTK_OUTER_WIDGET (f))
{
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
}
else
{
gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
outer_width, outer_height);
}
if (FRAME_GTK_OUTER_WIDGET (f))
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
outer_width, outer_height);
else /* PGTK child frame. */
gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
outer_width, outer_height);
#endif
fullscreen = Qnil;
}
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
@ -1333,7 +1256,7 @@ xg_frame_set_char_size (struct frame *f, int width, int height)
size as fast as possible.
For unmapped windows, we can set rows/cols. When
the frame is mapped again we will (hopefully) get the correct size. */
if (FRAME_VISIBLE_P (f) && !was_visible)
if (FRAME_VISIBLE_P (f) && !FRAME_PARENT_FRAME (f))
{
if (CONSP (frame_size_history))
frame_size_history_extra
@ -1421,10 +1344,20 @@ xg_frame_set_size_and_position (struct frame *f, int width, int height)
#ifndef HAVE_PGTK
gdk_window_move_resize (gwin, x, y, outer_width, outer_height);
if (FRAME_PARENT_FRAME (f))
{
/* Resize all inner widgets and Cairo surface right away so the
next redisplay drawing isn't clipped to the old size. */
GtkAllocation alloc = {0, 0, outer_width, outer_height};
gtk_widget_size_allocate (FRAME_GTK_OUTER_WIDGET (f), &alloc);
#ifdef USE_CAIRO
x_cr_update_surface_desired_size (f, width, height);
#endif
}
#else
if (FRAME_GTK_OUTER_WIDGET (f))
gdk_window_move_resize (gwin, x, y, outer_width, outer_height);
else
else /* PGTK child frame. */
gtk_widget_set_size_request (FRAME_GTK_WIDGET (f),
outer_width, outer_height);
#endif
@ -1432,7 +1365,11 @@ xg_frame_set_size_and_position (struct frame *f, int width, int height)
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
if (FRAME_VISIBLE_P (f))
/* For child frames, don't wait for events — that would flush the X
buffer and might show outdated contents in the frame. Same for
invisible frames: this way is faster and x_make_frame_visible will
wait for event anyway. */
if (FRAME_VISIBLE_P (f) && !FRAME_PARENT_FRAME (f))
{
/* Must call this to flush out events */
(void)gtk_events_pending ();

2
src/pgtkfns.c
View file

@ -3778,8 +3778,6 @@ syms_of_pgtkfns (void)
DEFSYM (Qframe_title_format, "frame-title-format");
DEFSYM (Qicon_title_format, "icon-title-format");
DEFSYM (Qdark, "dark");
DEFSYM (Qhide, "hide");
DEFSYM (Qresize_mode, "resize-mode");
DEFVAR_LISP ("x-cursor-fore-pixel", Vx_cursor_fore_pixel,
doc: /* SKIP: real doc in xfns.c. */);

4
src/sfnt.c
View file

@ -5792,6 +5792,10 @@ sfnt_read_name_table (int fd, struct sfnt_offset_subtable *subtable)
if (directory->length < required)
return NULL;
/* Avoid overflow in xmalloc argument below. */
if (directory->length > UINT_MAX - sizeof *name)
return NULL;
/* Allocate enough to hold the name table and variable length
data. */
name = xmalloc (sizeof *name + directory->length);

6
src/widget.c
View file

@ -428,6 +428,10 @@ EmacsFrameResize (Widget widget)
ew->core.width, ew->core.height,
f->new_width, f->new_height);
if (FRAME_PIXEL_WIDTH (f) == ew->core.width
&& FRAME_PIXEL_HEIGHT (f) == ew->core.height)
return;
change_frame_size (f, ew->core.width, ew->core.height,
false, true, false);
@ -495,6 +499,8 @@ EmacsFrameExpose (Widget widget, XEvent *event, Region region)
expose_frame (f, event->xexpose.x, event->xexpose.y,
event->xexpose.width, event->xexpose.height);
if (event->xexpose.count == 0)
x_clear_under_internal_border (f);
flush_frame (f);
}

5
src/xdisp.c
View file

@ -31382,7 +31382,10 @@ glyph_string_containing_background_width (struct glyph_string *s)
{
if (s->cmp)
while (s->cmp_from)
s = s->prev;
{
s = s->prev;
eassume (s);
}
return s;
}

6
src/xfns.c
View file

@ -4483,7 +4483,7 @@ x_window (struct frame *f)
attributes.background_pixel = FRAME_BACKGROUND_PIXEL (f);
attributes.border_pixel = f->output_data.x->border_pixel;
attributes.bit_gravity = NorthWestGravity;
attributes.bit_gravity = StaticGravity;
attributes.backing_store = NotUseful;
attributes.save_under = True;
attributes.event_mask = STANDARD_EVENT_SET;
@ -10484,10 +10484,6 @@ default and usually works with most desktops. Some desktop environments
however, may refuse to resize a child frame when Emacs is built with
GTK3. For those environments, the two settings below are provided.
If this equals the symbol `hide', Emacs temporarily hides the child
frame during resizing. This approach seems to work reliably, may
however induce some flicker when the frame is made visible again.
If this equals the symbol `resize-mode', Emacs uses GTK's resize mode to
always trigger an immediate resize of the child frame. This method is
deprecated by GTK and may not work in future versions of that toolkit.

78
src/xterm.c
View file

@ -28455,6 +28455,9 @@ x_wait_for_event (struct frame *f, int eventtype)
block_input ();
interrupt_input_blocked = level;
if (!f->wait_event_type)
break;
FD_ZERO (&fds);
FD_SET (fd, &fds);
@ -28484,6 +28487,19 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
f->win_gravity = NorthWestGravity;
x_wm_set_size_hint (f, 0, false);
#ifdef USE_X_TOOLKIT
if (FRAME_PARENT_FRAME (f) && f->output_data.x->widget)
{
/* Resize all inner widgets and Cairo surface right away so the
next redisplay drawing isn't clipped to the old size. */
XtResizeWidget (f->output_data.x->widget,
width, height + FRAME_MENUBAR_HEIGHT (f), 0);
#ifdef USE_CAIRO
x_cr_update_surface_desired_size (f, width, height);
#endif
}
else
#endif
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
width, height + FRAME_MENUBAR_HEIGHT (f));
@ -28499,30 +28515,25 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
if (!NILP (Vx_lax_frame_positioning))
return;
/* Now, strictly speaking, we can't be sure that this is accurate,
/* Now, strictly speaking, we can't be sure that this is final,
but the window manager will get around to dealing with the size
change request eventually, and we'll hear how it went when the
ConfigureNotify event gets here.
We could just not bother storing any of this information here,
and let the ConfigureNotify event set everything up, but that
might be kind of confusing to the Lisp code, since size changes
wouldn't be reported in the frame parameters until some random
point in the future when the ConfigureNotify event arrives.
Pass true for DELAY since we can't run Lisp code inside of
a BLOCK_INPUT. */
/* But the ConfigureNotify may in fact never arrive, and then this is
not right if the frame is visible. Instead wait (with timeout)
for the ConfigureNotify. */
if (FRAME_VISIBLE_P (f))
We could just let the ConfigureNotify update everything, but
waiting creates an implicit X flush which might flicker with
outdated contents in the frame. For child frames, the window
manager is not a concern and it's better to finish quickly. */
if (FRAME_VISIBLE_P (f) && !FRAME_PARENT_FRAME (f))
{
/* The event may create delayed size change (delayed because we
can't run Lisp code inside of a BLOCK_INPUT) which will be
applied right after by do_pending_window_change. */
x_wait_for_event (f, ConfigureNotify);
if (CONSP (frame_size_history))
frame_size_history_extra
(f, build_string ("x_set_window_size_1, visible"),
(f, build_string ("x_set_window_size_1, waited for event"),
FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
f->new_width, f->new_height);
}
@ -28530,7 +28541,7 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
{
if (CONSP (frame_size_history))
frame_size_history_extra
(f, build_string ("x_set_window_size_1, invisible"),
(f, build_string ("x_set_window_size_1, not waited for event"),
FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
f->new_width, f->new_height);
@ -28561,7 +28572,8 @@ x_set_window_size (struct frame *f, bool change_gravity,
x_set_window_size_1 (f, change_gravity, width, height);
#else /* not USE_GTK */
x_set_window_size_1 (f, change_gravity, width, height);
x_clear_under_internal_border (f);
if (!FRAME_PARENT_FRAME (f))
x_clear_under_internal_border (f);
#endif /* not USE_GTK */
/* If cursor was outside the new size, mark it as off. */
@ -28586,16 +28598,35 @@ x_set_window_size_and_position_1 (struct frame *f, int width, int height)
x_wm_set_size_hint (f, 0, false);
XMoveResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
x, y, width, height + FRAME_MENUBAR_HEIGHT (f));
#ifdef USE_X_TOOLKIT
if (FRAME_PARENT_FRAME (f) && f->output_data.x->widget)
{
/* Clear widget's position coordinates because it only sends
changed values with its XConfigureWindow command. And these
are likely outdated because XtDispatchEvent does not save them.
The alternative would be to always use XtMoveWidget instead of
XMoveWindow. */
f->output_data.x->widget->core.x = -1;
f->output_data.x->widget->core.y = -1;
/* Resize all inner widgets and Cairo surface right away so the
next redisplay drawing isn't clipped to the old size. */
XtConfigureWidget (f->output_data.x->widget,
x, y, width, height + FRAME_MENUBAR_HEIGHT (f), 0);
#ifdef USE_CAIRO
x_cr_update_surface_desired_size (f, width, height);
#endif
}
else
#endif
XMoveResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
x, y, width, height + FRAME_MENUBAR_HEIGHT (f));
SET_FRAME_GARBAGED (f);
if (FRAME_VISIBLE_P (f))
/* Same as x_set_window_size_1. */
if (FRAME_VISIBLE_P (f) && !FRAME_PARENT_FRAME (f))
x_wait_for_event (f, ConfigureNotify);
else
/* Call adjust_frame_size right away as with GTK. It might be
tempting to clear out f->new_width and f->new_height here. */
adjust_frame_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, width),
FRAME_PIXEL_TO_TEXT_HEIGHT (f, height),
5, 0, Qx_set_window_size_1);
@ -28615,7 +28646,8 @@ x_set_window_size_and_position (struct frame *f, int width, int height)
x_set_window_size_and_position_1 (f, width, height);
#endif /* USE_GTK */
x_clear_under_internal_border (f);
if (!FRAME_PARENT_FRAME (f))
x_clear_under_internal_border (f);
/* If cursor was outside the new size, mark it as off. */
mark_window_cursors_off (XWINDOW (FRAME_ROOT_WINDOW (f)));

5
test/lisp/erc/erc-scenarios-keep-place-indicator.el
View file

@ -79,6 +79,7 @@
(switch-to-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))) ; lower
(other-window 1)
(switch-to-buffer "#spam") ; upper
(redisplay)
(erc-scenarios-common-say "one")
(funcall expect 10 "Ay, the heads")
@ -94,6 +95,7 @@
;; Lower window is still centered at start.
(other-window 1)
(switch-to-buffer "#chan")
(redisplay)
(save-excursion
(goto-char (window-point))
(should (looking-back (rx "<alice> tester, welcome!")))
@ -107,8 +109,10 @@
(other-window 1) ; upper still at indicator, switches first
(switch-to-buffer "#spam")
(redisplay)
(other-window 1)
(switch-to-buffer "#spam") ; lower follows, speaks to sync
(redisplay)
(erc-scenarios-common-say "two")
(funcall expect 10 "<bob> Cause they take")
(goto-char (point-max))
@ -116,6 +120,7 @@
;; Upper switches back first, finds indicator gone.
(other-window 1)
(switch-to-buffer "#chan")
(redisplay)
(save-excursion
(goto-char (window-point))
(should (looking-back (rx "<bob> tester, welcome!")))

214
test/lisp/erc/erc-scenarios-log-options.el Normal file
View file

@ -0,0 +1,214 @@
;;; erc-scenarios-log-options.el --- erc-log options scenarios -*- lexical-binding: t -*-
;; Copyright (C) 2026 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert-x)
(eval-and-compile
(let ((load-path (cons (ert-resource-directory) load-path)))
(require 'erc-scenarios-common)))
(require 'erc-log)
;; This checks that logs are only inserted in new buffers.
(defun erc-scenarios-log-options--insert-on-open (test-fn)
(erc-scenarios-common-with-cleanup
((erc-scenarios-common-dialog "join/reconnect")
(dumb-server (erc-d-run "localhost" t 'foonet 'foonet-again))
(tempdir (make-temp-file "erc-tests-log." t nil nil))
(erc-log-channels-directory tempdir)
(erc-modules `(log ,@erc-modules))
(erc-timestamp-format-left "\n[@@DATE__STAMP@@]\n")
(port (process-contact dumb-server :service))
(erc-server-auto-reconnect t)
(erc-server-flood-penalty 0.1)
(expect (erc-d-t-make-expecter))
;; Bind these so they'll be killed on teardown.
(server-log-buffer (get-buffer-create "*erc-log FooNet*"))
(chan-log-buffer (get-buffer-create "*erc-log #chan*"))
(uh-suffix (format "!tester@127.0.0.1:%d.txt" port)))
(let ((file (concat "127.0.0.1:" (number-to-string port) uh-suffix)))
(with-temp-file (expand-file-name file tempdir)
(insert "\n@@OLD__BEG@@\n" "file: " file "\n@@OLD__END@@\n\n")))
(with-temp-file (expand-file-name (concat "foonet" uh-suffix) tempdir)
(insert "\n@@OLD__BEG@@\n"
"file: " (concat "foonet" uh-suffix)
"\n@@OLD__END@@\n\n"))
(with-temp-file (expand-file-name (concat "#chan" uh-suffix) tempdir)
(insert "\n@@OLD__BEG@@\n"
"file: " (concat "#chan" uh-suffix)
"\n@@OLD__END@@\n\n"))
(ert-info ("Connect")
(with-current-buffer (erc :server "127.0.0.1"
:port port
:nick "tester"
:password "changeme"
:full-name "tester")
(funcall expect 10 "debug mode")))
(ert-info ("#chan populated")
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
(funcall expect 10 "@@DATE__STAMP@@")
(funcall expect 10 "<alice> tester, welcome")))
(ert-info ("Reconnect")
(with-current-buffer "FooNet"
(funcall expect 10 "Connection failed!")
(funcall expect 10 "Reconnecting")
(funcall expect 10 "Welcome")
(funcall expect 10 "debug mode")))
(with-current-buffer "#chan"
(funcall expect -0.01 "@@DATE__STAMP@@")
(funcall expect 10 "<alice> bob: Well, this"))
(with-current-buffer "FooNet"
(erc-scenarios-common-say "/quit")
(funcall expect 10 "ERROR"))
;; Ensure no redundant logging.
(with-current-buffer "FooNet"
(let ((file (erc-current-logfile (current-buffer))))
(with-current-buffer server-log-buffer
(insert-file-contents file)
(funcall expect 1 "@@DATE__STAMP@@")
(funcall expect -0.01 "@@DATE__STAMP@@")
;; Full output again on reconnect.
(funcall expect 1 "*** Welcome to the foonet")
(funcall expect 1 "debug mode")
(funcall expect 1 "*** Connection failed!")
(funcall expect 1 "*** Welcome to the foonet")
(funcall expect 1 "debug mode"))))
(with-current-buffer "#chan"
(let ((file (erc-current-logfile (current-buffer))))
(with-current-buffer chan-log-buffer
(insert-file-contents file)
(funcall expect 1 "@@OLD__BEG@@")
(funcall expect -0.01 "@@OLD__BEG@@") ; only appearance
(funcall expect 1 "file: #chan")
(funcall expect 1 "@@OLD__END@@")
(funcall expect 1 "@@DATE__STAMP@@")
(funcall expect -0.01 "@@DATE__STAMP@@")
;; Full output again on reconnect.
(funcall expect 1 "*** You have joined channel #chan")
(funcall expect 1 "<alice> tester, welcome!")
(funcall expect -0.01 "@@DATE__STAMP@@")
(funcall expect 1 "*** You have joined channel #chan")
(funcall expect 1 "<alice> bob: Well, this is the forest"))))
(funcall test-fn expect)
(erc-log-mode -1)
(if noninteractive
(delete-directory tempdir :recursive)
(add-hook 'kill-emacs-hook
(lambda () (delete-directory tempdir :recursive))))))
;; This shows that the legacy default value of t ends up inserting
;; existing log content on reconnect as well, leading to redundant
;; insertions.
(ert-deftest erc-scenarios-log-options--insert-on-open/default ()
(let ((erc-log-insert-log-on-open t))
(erc-scenarios-log-options--insert-on-open
(lambda (expect)
(with-current-buffer "*erc-log FooNet*"
(funcall expect 1 "@@OLD__BEG@@" (point-min))
(funcall expect -0.01 "@@OLD__BEG@@") ; not repeated
(funcall expect 1 "file: foonet")
(funcall expect 1 "@@OLD__END@@")
(funcall expect 1 "@@DATE__STAMP@@"))
;; For server buffers, the file name changes because the buffer
;; is renamed after the network is announced during the initial
;; session.
(with-current-buffer "FooNet"
(funcall expect 1 "@@OLD__BEG@@" (point-min))
;; Existing log contents inserted once per connection (most
;; recent first).
(funcall expect 1 "file: foonet")
(funcall expect 1 "@@OLD__END@@")
;; Insertion from initial connection last.
(funcall expect 1 "@@OLD__BEG@@")
(funcall expect 1 "file: 127.0.0.1")
(funcall expect -0.01 "@@OLD__BEG@@")
(funcall expect 1 "@@OLD__END@@")
(funcall expect 1 "@@DATE__STAMP@@"))
(ert-info ("Repeated in #chan")
(with-current-buffer "#chan"
(funcall expect 1 "@@OLD__BEG@@" (point-min))
(funcall expect 1 "file: #chan")
(funcall expect 1 "@@OLD__END@@")
;; Existing log is indeed repeated in full once per connection.
(funcall expect 1 "@@OLD__BEG@@")
(funcall expect -0.01 "@@OLD__BEG@@")
(funcall expect 1 "file: #chan")
(funcall expect 1 "@@OLD__END@@")
(funcall expect 1 "@@DATE__STAMP@@")))))))
(ert-deftest erc-scenarios-log-options--insert-on-open/target-p ()
(let ((erc-log-insert-log-on-open #'erc-log-new-target-buffer-p))
(erc-scenarios-log-options--insert-on-open
(lambda (expect)
(ert-info ("Absent from server buffer")
(with-current-buffer "FooNet"
;; No insertions in the server buffer.
(funcall expect -0.01 "@@OLD__BEG@@" (point-min))
(funcall expect 1 "@@DATE__STAMP@@")))
(ert-info ("Once in server log")
;; No redundancies in the server's log file, though previously
;; existing content is obviously present.
(with-current-buffer "*erc-log FooNet*"
(funcall expect 1 "@@OLD__BEG@@" (point-min))
(funcall expect -0.01 "@@OLD__BEG@@") ; no repeats
(funcall expect 1 "file: foonet")
(funcall expect 1 "@@OLD__END@@")
(funcall expect 1 "@@DATE__STAMP@@")))
;; Also, as asserted in the fixture body, the associated log file
;; for #chan has no redundancy.
(ert-info ("Not repeated in #chan")
(with-current-buffer "#chan"
(funcall expect 1 "@@OLD__BEG@@" (point-min))
(funcall expect 1 "file: #chan")
(funcall expect 1 "@@OLD__END@@")
;; Existing scrollback only inserted at most once per buffer.
(funcall expect -0.01 "@@OLD__BEG@@")
(funcall expect 1 "@@DATE__STAMP@@")))))))
(require 'erc-log)
;;; erc-scenarios-log-options.el ends here

112
test/lisp/erc/erc-scenarios-log.el
View file

@ -460,4 +460,116 @@
(erc-truncate-mode -1)
(when noninteractive (delete-directory tempdir :recursive))))
;; These tests check whether logs contain gaps when reconnecting.
(defun erc-scenarios-log--reconnect (autop)
(erc-scenarios-common-with-cleanup
((erc-scenarios-common-dialog "join/reconnect")
(dumb-server (erc-d-run "localhost" t 'foonet 'foonet-again))
(tempdir (make-temp-file "erc-tests-log." t nil nil))
(erc-log-channels-directory tempdir)
(erc-modules `(log ,@erc-modules))
(erc-timestamp-format-left "\n[@@DATE__STAMP@@]\n")
(port (process-contact dumb-server :service))
(erc-server-auto-reconnect autop)
(erc-server-flood-penalty 0.1)
(expect (erc-d-t-make-expecter))
;; Bind these so they'll be killed on teardown.
(server-log-buffer (get-buffer-create "*erc-log FooNet*"))
(chan-log-buffer (get-buffer-create "*erc-log #chan*"))
(spam-log-buffer (get-buffer-create "*erc-log #spam*")))
(ert-info ("Connect")
(with-current-buffer (erc :server "127.0.0.1"
:port port
:nick "tester"
:password "changeme"
:full-name "tester")
(funcall expect 10 "debug mode")))
(ert-info ("#chan populated")
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
(funcall expect 10 "@@DATE__STAMP@@")
(funcall expect 10 "<alice> tester, welcome")))
(ert-info ("#spam populated")
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
(funcall expect 10 "@@DATE__STAMP@@")
(funcall expect 10 "<alice> tester, welcome")))
(ert-info ("Reconnect")
(with-current-buffer "FooNet"
(funcall expect 10 "Connection failed!")
(if autop
(funcall expect 10 "Reconnecting")
(erc-scenarios-common-say "/reconnect"))
(funcall expect 10 "Welcome")
(funcall expect 10 "debug mode")))
(with-current-buffer "#chan"
(funcall expect -0.01 "@@DATE__STAMP@@")
(funcall expect 10 "<alice> bob: Well, this"))
(with-current-buffer "#spam"
(funcall expect -0.01 "@@DATE__STAMP@@")
(funcall expect 10 "<alice> bob: Our queen and all"))
(with-current-buffer "FooNet"
(erc-scenarios-common-say "/quit")
(funcall expect 10 "Quit"))
(with-current-buffer "FooNet"
(let ((file (erc-current-logfile (current-buffer))))
(with-current-buffer server-log-buffer
(insert-file-contents file)
(funcall expect 1 "@@DATE__STAMP@@")
(funcall expect 1 "*** Welcome to the foonet")
(funcall expect 1 "debug mode")
(funcall expect 1 "*** Connection failed!")
;; Full output again on reconnect.
(funcall expect -0.01 "@@DATE__STAMP@@") ; but no stamp
(funcall expect 1 "*** Welcome to the foonet")
(funcall expect 1 "debug mode"))))
(with-current-buffer "#chan"
(let ((file (erc-current-logfile (current-buffer))))
(with-current-buffer chan-log-buffer
(insert-file-contents file)
(funcall expect 1 "@@DATE__STAMP@@")
(funcall expect 1 "*** You have joined channel #chan")
(funcall expect 1 "<alice> tester, welcome!")
;; No stamp on reconnect.
(funcall expect -0.01 "@@DATE__STAMP@@")
(funcall expect 1 "*** You have joined channel #chan")
(funcall expect 1 "<alice> bob: Well, this is the forest"))))
(with-current-buffer "#spam"
(let ((file (erc-current-logfile (current-buffer))))
(with-current-buffer spam-log-buffer
(insert-file-contents file)
(funcall expect 1 "@@DATE__STAMP@@")
(funcall expect 1 "*** You have joined channel #spam")
(funcall expect 1 "<alice> tester, welcome!")
;; No stamp on reconnect.
(funcall expect -0.01 "@@DATE__STAMP@@")
(funcall expect 1 "*** You have joined channel #spam")
(funcall expect 1 "<alice> bob: Our queen and all her elves come"))))
(erc-log-mode -1)
(if noninteractive
(delete-directory tempdir :recursive)
(add-hook 'kill-emacs-hook
(lambda () (delete-directory tempdir :recursive))))))
(ert-deftest erc-scenarios-log--reconnect/auto ()
:tags '(:expensive-test)
(erc-scenarios-log--reconnect 'autop))
(ert-deftest erc-scenarios-log--reconnect/manual ()
:tags '(:expensive-test)
(erc-scenarios-log--reconnect nil))
;;; erc-scenarios-log.el ends here

113
test/lisp/erc/erc-tests.el
View file

@ -3729,11 +3729,14 @@ keyword :result."
(get-buffer-create
(concat "*" (symbol-name (ert-test-name (ert-running-test))) "*"))
(unwind-protect
(let ((proc (erc-tests-common-create-subprocess code '("-batch") nil)))
(let ((proc (erc-tests-common-create-subprocess
`(,@(butlast code) (prin1 (list :result ,@(last code))))
'("-batch") nil)))
(while (accept-process-output proc 10))
(goto-char (point-min))
(search-forward "(:result " nil t)
(unless (equal (ignore-errors (read (current-buffer))) expected)
(unless (equal (and (search-forward "(:result " nil t)
(read (current-buffer)))
expected)
(ert-fail (list "Mismatch"
:expected expected
:buffer-string (buffer-string)))))
@ -3755,18 +3758,15 @@ keyword :result."
(unless (keywordp mod)
(push (if-let* ((mode (erc--find-mode mod))) mod (list :missing mod))
moded)))
(prin1 (list :result
(sort moded (lambda (a b)
(string< (symbol-name a) (symbol-name b)))))))
(sort moded (lambda (a b) (string< (symbol-name a) (symbol-name b)))))
erc-tests--modules))
(ert-deftest erc--essential-hook-ordering ()
(erc-tests--assert-printed-in-subprocess
'(progn
(erc-update-modules)
(prin1 (list :result
(list :erc-insert-modify-hook erc-insert-modify-hook
:erc-send-modify-hook erc-send-modify-hook))))
(list :erc-insert-modify-hook erc-insert-modify-hook
:erc-send-modify-hook erc-send-modify-hook))
'( :erc-insert-modify-hook (erc-controls-highlight ; 0
erc-button-add-buttons ; 30
@ -3798,26 +3798,37 @@ keyword :result."
(should (eq (erc--find-group 'foo nil) 'erc))
(should (eq (erc--find-group 'fake 'baz) 'erc-foo))))
(ert-deftest erc--find-group--real ()
:tags '(:unstable)
(require 'erc-services)
(require 'erc-stamp)
(require 'erc-sound)
(require 'erc-page)
(require 'erc-join)
(require 'erc-capab)
(require 'erc-pcomplete)
(should (eq (erc--find-group 'services 'nickserv) 'erc-services))
(should (eq (erc--find-group 'stamp 'timestamp) 'erc-stamp))
(should (eq (erc--find-group 'sound 'ctcp-sound) 'erc-sound))
(should (eq (erc--find-group 'page 'ctcp-page) 'erc-page))
(should (eq (erc--find-group 'autojoin) 'erc-autojoin))
(should (eq (erc--find-group 'pcomplete 'Completion) 'erc-pcomplete))
(should (eq (erc--find-group 'capab-identify) 'erc-capab))
(should (eq (erc--find-group 'completion) 'erc-pcomplete))
;; No group specified.
(should (eq (erc--find-group 'smiley nil) 'erc))
(should (eq (erc--find-group 'unmorse nil) 'erc)))
(ert-deftest erc--find-group/realistic ()
(erc-tests--assert-printed-in-subprocess
'(progn
(require 'erc-services)
(require 'erc-stamp)
(require 'erc-sound)
(require 'erc-page)
(require 'erc-join)
(require 'erc-capab)
(require 'erc-pcomplete)
(list (erc--find-group 'services 'nickserv)
(erc--find-group 'stamp 'timestamp)
(erc--find-group 'sound 'ctcp-sound)
(erc--find-group 'page 'ctcp-page)
(erc--find-group 'autojoin)
(erc--find-group 'pcomplete 'Completion)
(erc--find-group 'completion)
(erc--find-group 'capab-identify)
;; No group specified.
(erc--find-group 'smiley nil)
(erc--find-group 'unmorse nil)))
'(erc-services
erc-stamp
erc-sound
erc-page
erc-autojoin
erc-pcomplete
erc-pcomplete
erc-capab
erc
erc)))
(ert-deftest erc--sort-modules ()
(should (equal (erc--sort-modules '(networks foo fill bar fill stamp bar))
@ -3920,28 +3931,32 @@ keyword :result."
"(req . explicit-feature-lib)")))))))
(ert-deftest erc--update-modules/realistic ()
(let ((calls nil)
;; Module `pcomplete' "resolves" to `completion'.
(erc-modules '(pcomplete autojoin networks)))
(cl-letf (((symbol-function 'require)
(lambda (s &rest _) (push (cons 'req s) calls)))
(erc-tests--assert-printed-in-subprocess
'(progn
(require 'ert)
(require 'erc)
(should (featurep 'erc-networks))
(should-not erc-networks-mode)
;; The pcomplete module isn't loaded, and the non-alias form of
;; its command isn't autoloaded, so `erc--find-mode' will do so.
(should-not (featurep 'erc-pcomplete))
(should-not (intern-soft "erc-pcomplete-mode"))
;; The join module is autoloaded.
(should-not (featurep 'erc-join))
(should (fboundp 'erc-autojoin-mode))
(should-not (boundp 'erc-autojoin-mode))
;; Spoof global module detection.
((symbol-function 'custom-variable-p)
(lambda (v)
(memq v '(erc-autojoin-mode erc-networks-mode
erc-completion-mode))))
;; Mock and spy real builtins.
((symbol-function 'erc-autojoin-mode)
(lambda (n) (push (cons 'autojoin n) calls)))
((symbol-function 'erc-networks-mode)
(lambda (n) (push (cons 'networks n) calls)))
((symbol-function 'erc-completion-mode)
(lambda (n) (push (cons 'completion n) calls))))
;; These are all global modules, so no return value is expected.
(let ((erc-modules (cons (seq-random-elt '(completion pcomplete))
'(networks autojoin))))
(should-not (erc--update-modules erc-modules)))
(should-not (erc--update-modules erc-modules)) ; no locals
(should (equal (nreverse calls)
'((completion . 1) (autojoin . 1) (networks . 1)))))))
(list erc-networks-mode
(featurep 'erc-pcomplete)
(featurep 'erc-join)
(symbol-value (intern-soft "erc-pcomplete-mode"))
(bound-and-true-p erc-autojoin-mode)))
'(t t t t t)))
(ert-deftest erc--merge-local-modes ()
(cl-letf (((get 'erc-b-mode 'erc-module) 'b)

28
test/lisp/erc/resources/erc-d/erc-d-t.el
View file

@ -28,22 +28,20 @@
(defun erc-d-t-kill-related-buffers ()
"Kill all erc- or erc-d- related buffers."
(let (buflist)
(dolist (buf (buffer-list))
(with-current-buffer buf
(when (or erc-d-u--process-buffer
(derived-mode-p 'erc-mode 'erc-dcc-chat-mode))
(push buf buflist))))
(dolist (buf buflist)
(when (and (boundp 'erc-server-flood-timer)
(timerp erc-server-flood-timer))
(cancel-timer erc-server-flood-timer))
(when-let* ((proc (get-buffer-process buf)))
(delete-process proc))
(when (buffer-live-p buf)
(dolist (buf (buffer-list))
(with-current-buffer buf
(when (or erc-d-u--process-buffer
(derived-mode-p 'erc-mode
'erc-dcc-chat-mode)
(string-match (rx bot
(? " ") "*erc" (in "- ") (+ nonl) "*"
eot)
(buffer-name)))
(when-let* ((proc (get-buffer-process buf)))
(delete-process proc))
(kill-buffer buf))))
(while (when-let* ((buf (pop erc-d-u--canned-buffers)))
(kill-buffer buf))))
(while-let ((buf (pop erc-d-u--canned-buffers)))
(kill-buffer buf)))
(defun erc-d-t-silence-around (orig &rest args)
"Run ORIG function with ARGS silently.

3
test/lisp/erc/resources/erc-d/erc-d.el
View file

@ -462,8 +462,7 @@ including line delimiters."
(substring string (match-end 0))))
(erc-d--log process line nil)
(ring-insert queue (erc-d-i--parse-message line nil))))
(when string
(setf (process-get process :stashed-input) string))))
(setf (process-get process :stashed-input) string)))
;; Misc process properties:
;;

7
test/lisp/erc/resources/erc-scenarios-common.el
View file

@ -267,6 +267,10 @@ Dialog resource directories are located by expanding the variable
(package-initialize))))
(require 'erc)
(cl-assert (equal erc-version ,erc-version) t)))
;; Load test-related compat shims too niche for Compat, such as
;; a <31 definition of `ert-with-buffer-selected'.
(tcompat (and (featurep 'erc-tests-compat)
(locate-library "erc-tests-compat")))
;; Make subprocess terminal bigger than controlling.
(buf (cl-letf (((symbol-function 'window-screen-lines)
(lambda () (car erc-scenarios-common--term-size)))
@ -277,6 +281,9 @@ Dialog resource directories are located by expanding the variable
nil `(,@(or init '("-Q")) "-nw"
"-eval" ,(format "%S" setup)
"-l" ,file-name
,@(and tcompat
(list "-L" (file-name-directory tcompat)
"-l" tcompat))
"-eval" ,(format "%S" cmd)))))
(proc (get-buffer-process buf))
(err (lambda ()

13
test/lisp/erc/resources/erc-tests-common.el
View file

@ -81,11 +81,18 @@ Assign the result to `erc-server-process' in the current buffer."
;; To facilitate automatic testing when a fake-server has already
;; been created by an earlier ERT test.
(kill-buffer-query-functions nil))
(dolist (buf (erc-buffer-list))
(kill-buffer buf))
(mapc #'kill-buffer
(match-buffers
`(or ,@(static-if (>= emacs-major-version 30)
'((derived-mode erc-mode erc-dcc-chat-mode))
'((major-mode . erc-mode) (major-mode . erc-dcc-chat-mode)))
,(rx bot (? ?\s) "*erc" (in "- ") (+ nonl) ?* eot))))
(named-let doit ((buffers extra-buffers))
(dolist (buf buffers)
(if (consp buf) (doit buf) (kill-buffer buf))))))
(if (consp buf)
(doit buf)
(when (buffer-live-p buf)
(kill-buffer buf)))))))
(defun erc-tests-common-with-process-input-spy (test-fn)
"Mock `erc-process-input-line' and call TEST-FN.

4
test/lisp/erc/resources/join/reconnect/foonet-again.eld
View file

@ -43,3 +43,7 @@
(0 ":irc.foonet.org 329 tester #spam 1620104779")
(0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #spam :alice: Signior Iachimo will not from it. Pray, let us follow 'em.")
(0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #spam :bob: Our queen and all her elves come here anon."))
((quit 10 "QUIT :\2ERC\2")
(0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")
(0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)"))

32
test/lisp/jsonrpc-resources/common.py Normal file
View file

@ -0,0 +1,32 @@
"""Common JSONRPC framing helpers for jsonrpc.el test servers."""
import json
import sys
def read_msg():
"""Read one Content-Length-framed JSON-RPC message from stdin."""
headers = {}
while True:
line = sys.stdin.buffer.readline()
if not line:
return None
text = line.decode('utf-8').rstrip('\r\n')
if not text:
break
if ':' in text:
k, _, v = text.partition(':')
headers[k.strip()] = v.strip()
n = int(headers.get('Content-Length', 0))
return json.loads(sys.stdin.buffer.read(n).decode('utf-8')) if n else None
def write_msg(msg):
"""Write one Content-Length-framed JSON-RPC message to stdout."""
body = json.dumps(msg, ensure_ascii=False).encode('utf-8')
sys.stdout.buffer.write(
f'Content-Length: {len(body)}\r\n\r\n'.encode('utf-8') + body
)
sys.stdout.buffer.flush()
def log(text):
"""Write a log line to stderr."""
print(f'[test-server] {text}', file=sys.stderr, flush=True)

54
test/lisp/jsonrpc-resources/server-anxious-nested.py Executable file
View file

@ -0,0 +1,54 @@
#!/usr/bin/env python3
"""Test server for scontrol-anxious-nested.
Choreography (exercises the anxious-continuation mechanism):
client -> server: LR1 (id=1)
server -> client: RR1 (id=1000)
server -> client: response LR1 "lr1-ok"
client -> server: LR2 (id=2)
server -> client: response LR2 "lr2-ok"
client -> server: response RR1 "lr2-ok"
LR2 should complete first, then RR1, then LR1.
"""
import os
import sys
sys.path.insert(0, os.path.dirname(__file__))
from common import read_msg, write_msg, log
def main():
while True:
lr1 = read_msg()
if lr1 is None:
break
mid = lr1.get('id')
method = lr1.get('method')
log(f'<- {method or "(response)"} id={mid}')
if method == 'harakiri':
log('-> very clean harakiri')
break
elif method == 'LR1':
# Send RR1, then immediately respond to LR1 without awaiting
# anything. The response-to-LR1 will be queued as anxious on the
# client while its rdispatcher blocks waiting for LR2.
write_msg({'jsonrpc': '2.0', 'id': 1000,
'method': 'RR1', 'params': {}})
log('-> RR1 id=1000')
write_msg({'jsonrpc': '2.0', 'id': mid, 'result': 'lr1-ok'})
log(f'-> (response LR1) id={mid}')
# LR2 arrives next: the client's rdispatcher for RR1
# issues it as a nested sync request.
lr2 = read_msg()
fid = lr2.get('id') if lr2 else None
log(f'<- LR2 id={fid}')
write_msg({'jsonrpc': '2.0', 'id': fid, 'result': 'lr2-ok'})
log(f'-> (response LR2) id={fid}')
# Finally collect the RR1 response (rdispatcher return value).
rr1_resp = read_msg()
log(f'<- (response RR1) id={rr1_resp.get("id") if rr1_resp else None}')
if __name__ == '__main__':
main()

24
test/lisp/jsonrpc-resources/server-harakiri.py Executable file
View file

@ -0,0 +1,24 @@
#!/usr/bin/env python3
"""Test server for shutdown-clean test.
Waits for a 'harakiri' notification and then exits cleanly.
"""
import os, sys
sys.path.insert(0, os.path.dirname(__file__))
from common import read_msg, log
def main():
while True:
msg = read_msg()
if msg is None:
break
method = msg.get('method')
log(f'<- {method or "(response)"} id={msg.get("id")}')
if method == 'harakiri':
log('-> very clean harakiri')
break
if __name__ == '__main__':
main()

42
test/lisp/jsonrpc-resources/server-remote-during-sync-1.py Executable file
View file

@ -0,0 +1,42 @@
#!/usr/bin/env python3
"""Test server for scontrol-remote-during-sync-1.
Choreography (tests bug#80623):
client -> server: LR1 (id=1)
server -> client: RR1 (id=1000)
server -> client: response LR1 "lr1-ok"
client -> server: response RR1 "rr1-ok"
"""
import os
import sys
sys.path.insert(0, os.path.dirname(__file__))
from common import read_msg, write_msg, log
def main():
while True:
msg = read_msg()
if msg is None:
break
mid = msg.get('id')
method = msg.get('method')
log(f'<- {method or "(response)"} id={mid}')
if method == 'harakiri':
log('-> very clean harakiri')
break
elif method == 'LR1':
# Send RR1 request
write_msg({'jsonrpc': '2.0', 'id': 1000,
'method': 'RR1', 'params': {}})
log('-> RR1 id=1000')
# Immediately reply to LR1
write_msg({'jsonrpc': '2.0', 'id': mid, 'result': 'lr1-ok'})
log(f'-> (response LR1) id={mid}')
# Now wait for reply to RR1
resp = read_msg()
log(f'<- (response RR1) id={resp.get("id") if resp else None}')
if __name__ == '__main__':
main()

42
test/lisp/jsonrpc-resources/server-remote-during-sync-2.py Executable file
View file

@ -0,0 +1,42 @@
#!/usr/bin/env python3
"""Test server for scontrol-remote-during-sync-2.
Choreography (tests bug#80623):
client -> server: LR1 (id=1)
server -> client: RR1 (id=1000)
client -> server: response RR1 "rr1-ok"
server -> client: response LR1 "lr1-ok"
"""
import os
import sys
sys.path.insert(0, os.path.dirname(__file__))
from common import read_msg, write_msg, log
def main():
while True:
msg = read_msg()
if msg is None:
break
mid = msg.get('id')
method = msg.get('method')
log(f'<- {method or "(response)"} id={mid}')
if method == 'harakiri':
log('-> very clean harakiri')
break
elif method == 'LR1':
# Send RR1 request
write_msg({'jsonrpc': '2.0', 'id': 1000,
'method': 'RR1', 'params': {}})
log('-> RR1 id=1000')
# Wait for reply to RR1
resp = read_msg()
log(f'<- (response RR1) id={resp.get("id") if resp else None}')
# Only NOW answer LR1
write_msg({'jsonrpc': '2.0', 'id': mid, 'result': 'lr1-ok'})
log(f'-> (response LR1) id={mid}')
if __name__ == '__main__':
main()

44
test/lisp/jsonrpc-resources/server-remote-error.py Executable file
View file

@ -0,0 +1,44 @@
#!/usr/bin/env python3
"""Test server for scontrol-remote-error.
Choreography (anxious continuation survives an rdispatcher error):
client -> server: LR1 (id=1)
server -> client: badMethod (id=1000)
server -> client: response LR1 "ok"
client -> server: error response badMethod {code: -32601}
Even though the remote-request dispatch produces an error reply, the
anxious continuation for LR1 must still fire and resolve to "ok".
"""
import os, sys
sys.path.insert(0, os.path.dirname(__file__))
from common import read_msg, write_msg, log
def main():
while True:
msg = read_msg()
if msg is None:
break
mid = msg.get('id')
method = msg.get('method')
log(f'<- {method or "(response)"} id={mid}')
if method == 'harakiri':
log('-> very clean harakiri')
break
elif method == 'LR1':
# Send badMethod BEFORE responding to LR1; the client
# rdispatcher will signal a jsonrpc-error for it.
write_msg({'jsonrpc': '2.0', 'id': 1000,
'method': 'badMethod', 'params': {}})
log('-> badMethod id=1000')
write_msg({'jsonrpc': '2.0', 'id': mid, 'result': 'ok'})
log(f'-> (response LR1) id={mid}')
# Collect the error response to badMethod.
err = read_msg()
log(f'<- (error response badMethod): {err}')
if __name__ == '__main__':
main()

137
test/lisp/jsonrpc-tests.el
View file

@ -252,5 +252,142 @@
(should (eq 2 n-deferred-2))
(should (eq 0 (hash-table-count (jsonrpc--deferred-actions conn)))))))
;;; Tests using Python subprocesses (scontrol / anxious mechanism)
;;;
(defconst jsonrpc--test-dir
(file-name-directory (or load-file-name buffer-file-name))
"Directory of this test file, captured at load time.")
(cl-defmacro jsonrpc--with-python-fixture ((script conn &rest initargs) &body body)
"Start SCRIPT under python3 as a pipe subprocess, bind connection to CONN.
SCRIPT is a path relative to this file's directory.
INITARGS are passed to `make-instance' for `jsonrpc-process-connection'."
(declare (indent 1))
`(let ((,conn nil))
(unwind-protect
(progn
(setq ,conn
(make-instance
'jsonrpc-process-connection
:name "jsonrpc-python-test"
:process (make-process
:name "jsonrpc-python-test"
:command (list "python3"
(expand-file-name
,script
jsonrpc--test-dir))
:connection-type 'pipe
:noquery t)
,@initargs))
(with-timeout (5
(when ,conn
(let ((buf (jsonrpc--events-buffer ,conn)))
(when (buffer-live-p buf)
(if noninteractive
(progn
(message "contents of `%s':" (buffer-name buf))
(princ (with-current-buffer buf (buffer-string))
#'external-debugging-output))
(message "Preserved for inspection: %s"
(buffer-name buf))))))
(ert-fail "Test timed out after 5s"))
,@body))
(when ,conn
(ignore-errors
(jsonrpc-notify ,conn 'harakiri nil)
(kill-buffer (jsonrpc--events-buffer ,conn))
(jsonrpc-shutdown ,conn))))))
(ert-deftest scontrol-remote-during-sync-1 ()
"Anxious local continuations.
Endpoint sends a remote request RR1 on LR1, then replies to LR1
immediately before waiting for RR1 to resolve.
This is what JETLS does (bug#80623)."
(skip-unless (executable-find "python3"))
(skip-when (eq system-type 'windows-nt))
(jsonrpc--with-python-fixture
("jsonrpc-resources/server-remote-during-sync-1.py" conn
:request-dispatcher
(lambda (_conn method _params)
(pcase method
('RR1 "rr1-ok")
(_ (error "unexpected method: %s" method)))))
(should (equal "lr1-ok" (jsonrpc-request conn 'LR1 [] :timeout 5)))))
(ert-deftest scontrol-remote-during-sync-2 ()
"Anxious local continuations.
Exactly the same test as 2, but different endpoint, which now still
sends RR1 on LR1 but now waits for RR1 to resolve before replying to
LR1.
This is what GoPls does (bug#80623)."
(skip-unless (executable-find "python3"))
(skip-when (eq system-type 'windows-nt))
(jsonrpc--with-python-fixture
("jsonrpc-resources/server-remote-during-sync-2.py" conn
:request-dispatcher
(lambda (_conn method _params)
(pcase method
('RR1 "rr1-ok")
(_ (error "unexpected method: %s" method)))))
(should (equal "lr1-ok" (jsonrpc-request conn 'LR1 [] :timeout 5)))))
(ert-deftest scontrol-anxious-nested ()
"Nested anxious continuations
Two local sync requests LR1 and LR2 with a remote RR1 in between.
Vaguely similar to Julia's JETLS (bug#80623), but more complex."
(skip-unless (executable-find "python3"))
(skip-when (eq system-type 'windows-nt))
(let (lr2-result completed)
(jsonrpc--with-python-fixture
("jsonrpc-resources/server-anxious-nested.py" conn
:request-dispatcher
(lambda (conn method _params)
(pcase method
('RR1
(setq lr2-result
(jsonrpc-request conn 'LR2 [] :timeout 5))
(push "lr2" completed)
(push "rr1" completed))
(_ (error "unexpected method: %s" method)))))
(should (equal "lr1-ok" (jsonrpc-request conn 'LR1 [] :timeout 5)))
(push "lr1" completed)
(should (equal "lr2-ok" lr2-result))
(should (equal '("lr1" "rr1" "lr2") completed)))))
(ert-deftest scontrol-remote-error ()
"Anxious continuation even when rdispatcher signals errors."
(skip-unless (executable-find "python3"))
(skip-when (eq system-type 'windows-nt))
(jsonrpc--with-python-fixture
("jsonrpc-resources/server-remote-error.py" conn
:request-dispatcher
(lambda (_conn method _params)
(pcase method
('badMethod
(signal 'jsonrpc-error
'((jsonrpc-error-message . "method not allowed")
(jsonrpc-error-code . -32601))))
(_ (error "unexpected method: %s" method)))))
(should (equal "ok" (jsonrpc-request conn 'LR1 [] :timeout 5)))))
(ert-deftest shutdown-clean-after-notification ()
"Server exits cleanly after harakiri notification.
`jsonrpc-shutdown' should not emit a \"Sentinel hasn't run\" warning."
(skip-unless (executable-find "python3"))
(skip-when (eq system-type 'windows-nt))
(let (warned)
(cl-letf (((symbol-function 'jsonrpc--warn)
(lambda (fmt &rest args)
(setq warned (apply #'format fmt args)))))
(jsonrpc--with-python-fixture
("jsonrpc-resources/server-harakiri.py" conn)
(jsonrpc-notify conn 'harakiri nil)
;; Give the server time to exit before shutdown checks the sentinel.
(accept-process-output nil 0.3)
(jsonrpc-shutdown conn)))
(should-not warned)))
(provide 'jsonrpc-tests)
;;; jsonrpc-tests.el ends here

8
test/src/sqlite-tests.el
View file

@ -185,6 +185,14 @@
(sqlite-close db)
(should-error (sqlite-select db "select * from test6"))))
(ert-deftest sqlite-closed-db ()
"Verify that `sqlite-close' on a closed database is a no-op."
(skip-unless (sqlite-available-p))
(let (db)
(setq db (sqlite-open))
(should (eq (sqlite-close db)
(sqlite-close db)))))
(ert-deftest sqlite-load-extension ()
(skip-unless (sqlite-available-p))
(skip-unless (fboundp 'sqlite-load-extension))