[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/pgtk 13a9a5e: Merge branch 'master' of git.sv.gnu.org:/srv/git/e
|
From: |
Yuuki Harano |
|
Subject: |
feature/pgtk 13a9a5e: Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk |
|
Date: |
Sun, 25 Jul 2021 11:30:38 -0400 (EDT) |
branch: feature/pgtk
commit 13a9a5e836cbe6e64aadaba40fe1f7eb83320d08
Merge: b242394 41a55a3
Author: Yuuki Harano <masm+github@masm11.me>
Commit: Yuuki Harano <masm+github@masm11.me>
Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs into feature/pgtk
---
admin/merge-gnulib | 2 +-
doc/emacs/custom.texi | 20 +-
doc/emacs/misc.texi | 5 +-
doc/emacs/modes.texi | 10 +-
doc/emacs/search.texi | 11 +
doc/lispref/buffers.texi | 4 +-
doc/lispref/commands.texi | 14 +-
doc/lispref/display.texi | 9 +-
doc/lispref/errors.texi | 9 +-
doc/lispref/eval.texi | 3 +-
doc/lispref/files.texi | 53 +-
doc/lispref/hooks.texi | 2 +-
doc/lispref/modes.texi | 11 +-
doc/lispref/text.texi | 9 +
doc/lispref/variables.texi | 14 +
doc/misc/gnus.texi | 2 +-
doc/misc/smtpmail.texi | 10 +
etc/NEWS | 182 ++-
lib-src/emacsclient.c | 226 +--
lib/file-has-acl.c | 510 +++++++
lib/gnulib.mk.in | 11 +
lisp/ansi-color.el | 32 +
lisp/autorevert.el | 4 +
lisp/battery.el | 4 +-
lisp/bindings.el | 2 +-
lisp/bookmark.el | 12 +-
lisp/button.el | 1 +
lisp/calendar/cal-french.el | 192 ++-
lisp/comint.el | 11 +-
lisp/cus-start.el | 42 +-
lisp/custom.el | 2 +-
lisp/desktop.el | 5 +-
lisp/dired-x.el | 50 +-
lisp/dnd.el | 1 +
lisp/emacs-lisp/byte-opt.el | 19 +-
lisp/emacs-lisp/bytecomp.el | 47 +-
lisp/emacs-lisp/cconv.el | 15 +-
lisp/emacs-lisp/cl-lib.el | 105 --
lisp/emacs-lisp/copyright.el | 15 +-
lisp/emacs-lisp/eieio-core.el | 13 +-
lisp/emacs-lisp/eieio.el | 5 +-
lisp/emacs-lisp/gv.el | 100 ++
lisp/emacs-lisp/macroexp.el | 27 +-
lisp/emacs-lisp/package.el | 21 +-
lisp/emacs-lisp/shortdoc.el | 20 +-
lisp/emacs-lisp/tabulated-list.el | 24 +
lisp/erc/erc-button.el | 5 +-
lisp/faces.el | 26 +-
lisp/files.el | 256 ++--
lisp/frame.el | 2 +-
lisp/gnus/message.el | 4 +-
lisp/help-fns.el | 12 +-
lisp/help-mode.el | 6 +-
lisp/help.el | 7 +-
lisp/icomplete.el | 18 +-
lisp/ls-lisp.el | 74 +-
lisp/mail/smtpmail.el | 80 +-
lisp/minibuffer.el | 9 +
lisp/net/rcirc.el | 1434 +++++++++++++-------
lisp/net/tramp-adb.el | 10 +-
lisp/net/tramp-compat.el | 14 +
lisp/net/tramp-gvfs.el | 2 +-
lisp/net/tramp-sh.el | 18 +-
lisp/net/tramp-smb.el | 8 +-
lisp/net/tramp-sshfs.el | 6 +-
lisp/net/tramp-sudoedit.el | 20 +-
lisp/net/tramp.el | 31 +-
lisp/newcomment.el | 20 +-
lisp/progmodes/bug-reference.el | 1 +
lisp/progmodes/compile.el | 15 +-
lisp/progmodes/elisp-mode.el | 3 +-
lisp/progmodes/gdb-mi.el | 96 +-
lisp/replace.el | 324 +++--
lisp/shadowfile.el | 21 +-
lisp/simple.el | 40 +-
lisp/startup.el | 1 +
lisp/subr.el | 11 +-
lisp/tab-bar.el | 2 +-
lisp/term.el | 30 +-
lisp/textmodes/fill.el | 11 +-
lisp/textmodes/remember.el | 18 +-
lisp/time.el | 3 +-
lisp/url/url.el | 7 +-
lisp/vc/vc-git.el | 4 +-
lisp/wdired.el | 122 +-
lisp/woman.el | 6 +-
m4/gnulib-comp.m4 | 3 +
nt/gnulib-cfg.mk | 1 +
src/buffer.c | 32 +-
src/callint.c | 5 +-
src/chartab.c | 104 +-
src/coding.c | 2 +-
src/data.c | 2 +
src/eval.c | 14 +-
src/fileio.c | 109 ++
src/filelock.c | 2 +-
src/fns.c | 12 +-
src/frame.c | 20 +-
src/frame.h | 8 +-
src/ftfont.c | 21 +
src/json.c | 25 +-
src/keyboard.c | 82 +-
src/lisp.h | 4 +-
src/macros.c | 2 +-
src/minibuf.c | 2 +-
src/xdisp.c | 86 +-
src/xfaces.c | 83 +-
src/xftfont.c | 6 +
test/lisp/calendar/cal-french-tests.el | 113 ++
test/lisp/dired-x-tests.el | 13 +
.../bytecomp-resources/warn-callargs-defsubst.el | 5 +
test/lisp/emacs-lisp/bytecomp-tests.el | 3 +
test/lisp/emacs-lisp/package-tests.el | 68 +
test/lisp/files-resources/.dir-locals.el | 5 +
test/lisp/files-resources/auto-test.zot1 | 1 +
test/lisp/files-resources/auto-test.zot2 | 1 +
test/lisp/files-resources/auto-test.zot3 | 1 +
test/lisp/files-resources/whatever.quux | 2 +
test/lisp/files-tests.el | 11 +
test/lisp/net/tramp-tests.el | 22 +-
test/lisp/progmodes/compile-tests.el | 47 +-
test/lisp/replace-tests.el | 9 +-
test/lisp/shadowfile-tests.el | 15 +-
test/lisp/time-stamp-tests.el | 11 +-
test/lisp/time-tests.el | 1 +
test/src/buffer-tests.el | 42 +-
test/src/fileio-tests.el | 22 +
127 files changed, 4186 insertions(+), 1494 deletions(-)
diff --git a/admin/merge-gnulib b/admin/merge-gnulib
index 1c8b442..c12e83d 100755
--- a/admin/merge-gnulib
+++ b/admin/merge-gnulib
@@ -33,7 +33,7 @@ GNULIB_MODULES='
crypto/md5-buffer crypto/sha1-buffer crypto/sha256-buffer
crypto/sha512-buffer
d-type diffseq double-slash-root dtoastr dtotimespec dup2
environ execinfo explicit_bzero faccessat
- fchmodat fcntl fcntl-h fdopendir
+ fchmodat fcntl fcntl-h fdopendir file-has-acl
filemode filename filevercmp flexmember fpieee
free-posix fstatat fsusage fsync futimens
getloadavg getopt-gnu getrandom gettime gettimeofday gitlog-to-changelog
diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi
index bd505d2..999234e 100644
--- a/doc/emacs/custom.texi
+++ b/doc/emacs/custom.texi
@@ -623,7 +623,7 @@ button.
the theme file and asks if you really want to load it. Because
loading a Custom theme can execute arbitrary Lisp code, you should
only say yes if you know that the theme is safe; in that case, Emacs
-offers to remember in the future that the theme is safe (this is done
+offers to remember in the future that the theme is safe(this is done
by saving the theme file's SHA-256 hash to the variable
@code{custom-safe-themes}; if you want to treat all themes as safe,
change its value to @code{t}). Themes that come with Emacs (in the
@@ -1271,7 +1271,13 @@ confirmation prompt. When Emacs encounters these
variable/value pairs
subsequently, in the same file or others, it will assume they are
safe.
+ You can also tell Emacs to permanently ignore all the variable/value
+pairs in the file, by typing @kbd{i} at the confirmation prompt --
+these pairs will thereafter be ignored in this file and in all other
+files.
+
@vindex safe-local-variable-values
+@vindex ignored-local-variable-values
@cindex risky variable
Some variables, such as @code{load-path}, are considered
particularly @dfn{risky}: there is seldom any reason to specify them
@@ -1283,6 +1289,8 @@ can enter @kbd{!} at the prompt. It applies all the
variables, but only
marks the non-risky ones as safe for the future. If you really want to
record safe values for risky variables, do it directly by customizing
@samp{safe-local-variable-values} (@pxref{Easy Customization}).
+Similarly, if you want to record values of risky variables that should
+be permanently ignored, customize @code{ignored-local-variable-values}.
@vindex enable-local-variables
The variable @code{enable-local-variables} allows you to change the
@@ -1407,6 +1415,16 @@ meanings as they would have in file local variables.
@code{coding}
cannot be specified as a directory local variable. @xref{File
Variables}.
+The special key @code{auto-mode-alist} in a @file{.dir-locals.el} lets
+you set a file's major mode. It works much like the variable
+@code{auto-mode-alist} (@pxref{Choosing Modes}). For example, here is
+how you can tell Emacs that @file{.def} source files in this directory
+should be in C mode:
+
+@example
+((auto-mode-alist . (("\\.def\\'" . c-mode))))
+@end example
+
@findex add-dir-local-variable
@findex delete-dir-local-variable
@findex copy-file-locals-to-dir-locals
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index 12cd492..aba98cf 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -1021,7 +1021,10 @@ pending in the shell buffer and not yet sent.
@findex comint-delete-output
Delete the last batch of output from a shell command
(@code{comint-delete-output}). This is useful if a shell command spews
-out lots of output that just gets in the way.
+out lots of output that just gets in the way. With a prefix argument,
+this command saves the deleted text in the @code{kill-ring}
+(@pxref{Kill Ring}), so that you could later yank it (@pxref{Yanking})
+elsewhere.
@item C-c C-s
@kindex C-c C-s @r{(Shell mode)}
diff --git a/doc/emacs/modes.texi b/doc/emacs/modes.texi
index cc25d3e..9014221 100644
--- a/doc/emacs/modes.texi
+++ b/doc/emacs/modes.texi
@@ -357,8 +357,12 @@ preferences. If you personally want to use a minor mode
for a
particular file type, it is better to enable the minor mode via a
major mode hook (@pxref{Major Modes}).
+ Second, Emacs checks whether the file's extension matches an entry
+in any directory-local @code{auto-mode-alist}. These are found using
+the @file{.dir-locals.el} facility (@pxref{Directory Variables}).
+
@vindex interpreter-mode-alist
- Second, if there is no file variable specifying a major mode, Emacs
+ Third, if there is no file variable specifying a major mode, Emacs
checks whether the file's contents begin with @samp{#!}. If so, that
indicates that the file can serve as an executable shell command,
which works by running an interpreter named on the file's first line
@@ -376,7 +380,7 @@ same is true for man pages which start with the magic string
@samp{'\"} to specify a list of troff preprocessors.
@vindex magic-mode-alist
- Third, Emacs tries to determine the major mode by looking at the
+ Fourth, Emacs tries to determine the major mode by looking at the
text at the start of the buffer, based on the variable
@code{magic-mode-alist}. By default, this variable is @code{nil} (an
empty list), so Emacs skips this step; however, you can customize it
@@ -404,7 +408,7 @@ where @var{match-function} is a Lisp function that is
called at the
beginning of the buffer; if the function returns non-@code{nil}, Emacs
set the major mode with @var{mode-function}.
- Fourth---if Emacs still hasn't found a suitable major mode---it
+ Fifth---if Emacs still hasn't found a suitable major mode---it
looks at the file's name. The correspondence between file names and
major modes is controlled by the variable @code{auto-mode-alist}. Its
value is a list in which each element has this form,
diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi
index e6b066e..a1760ad 100644
--- a/doc/emacs/search.texi
+++ b/doc/emacs/search.texi
@@ -1971,6 +1971,17 @@ it never deletes lines that are only partially contained
in the region
(a newline that ends a line counts as part of that line).
If a match is split across lines, this command keeps all those lines.
+
+@findex kill-matching-lines
+@item M-x kill-matching-lines
+Like @code{flush-lines}, but also add the matching lines to the kill
+ring. The command adds the matching lines to the kill ring as a
+single string, including the newlines that separated the lines.
+
+@findex copy-matching-lines
+@item M-x copy-matching-lines
+Like @code{kill-matching-lines}, but the matching lines are not
+removed from the buffer.
@end table
@node Search Customizations
diff --git a/doc/lispref/buffers.texi b/doc/lispref/buffers.texi
index 0d31b0b..55e9d00 100644
--- a/doc/lispref/buffers.texi
+++ b/doc/lispref/buffers.texi
@@ -1183,7 +1183,7 @@ buffer.
the base buffer effectively kills the indirect buffer in that it cannot
ever again be the current buffer.
-@deffn Command make-indirect-buffer base-buffer name &optional clone
+@deffn Command make-indirect-buffer base-buffer name &optional clone
inhibit-buffer-hooks
This creates and returns an indirect buffer named @var{name} whose
base buffer is @var{base-buffer}. The argument @var{base-buffer} may
be a live buffer or the name (a string) of an existing buffer. If
@@ -1199,6 +1199,8 @@ If @var{base-buffer} is an indirect buffer, its base
buffer is used as
the base for the new buffer. If, in addition, @var{clone} is
non-@code{nil}, the initial state is copied from the actual base
buffer, not from @var{base-buffer}.
+
+@xref{Creating Buffers}, for the meaning of @var{inhibit-buffer-hooks}.
@end deffn
@deffn Command clone-indirect-buffer newname display-flag &optional norecord
diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index f30419c..b4a8b73 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -3381,6 +3381,12 @@ nil)}. This is the same thing that quitting does. (See
@code{signal}
in @ref{Errors}.)
@end deffn
+ To quit without aborting a keyboard macro definition or execution,
+you can signal the @code{minibuffer-quit} condition. This has almost
+the same effect as the @code{quit} condition except that the error
+handling in the command loop handles it without exiting keyboard macro
+definition or execution.
+
You can specify a character other than @kbd{C-g} to use for quitting.
See the function @code{set-input-mode} in @ref{Input Modes}.
@@ -3565,12 +3571,14 @@ commands.
@code{recursive-edit}. This function contains the command loop; it also
contains a call to @code{catch} with tag @code{exit}, which makes it
possible to exit the recursive editing level by throwing to @code{exit}
-(@pxref{Catch and Throw}). If you throw a value other than @code{t},
-then @code{recursive-edit} returns normally to the function that called
-it. The command @kbd{C-M-c} (@code{exit-recursive-edit}) does this.
+(@pxref{Catch and Throw}). If you throw a @code{nil} value, then
+@code{recursive-edit} returns normally to the function that called it.
+The command @kbd{C-M-c} (@code{exit-recursive-edit}) does this.
Throwing a @code{t} value causes @code{recursive-edit} to quit, so that
control returns to the command loop one level up. This is called
@dfn{aborting}, and is done by @kbd{C-]} (@code{abort-recursive-edit}).
+You can also throw a function value. In that case,
+@code{recursive-edit} will call it without arguments before returning.
Most applications should not use recursive editing, except as part of
using the minibuffer. Usually it is more convenient for the user if you
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 3336338..13d0a1b 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -1861,9 +1861,12 @@ from the buffer.
@item keymap
@cindex keymap of character (and overlays)
@kindex keymap @r{(overlay property)}
-If this property is non-@code{nil}, it specifies a keymap for a portion of the
-text. This keymap is used when the character after point is within the
-overlay, and takes precedence over most other keymaps. @xref{Active Keymaps}.
+If this property is non-@code{nil}, it specifies a keymap for a
+portion of the text. This keymap takes precedence over most other
+keymaps (@pxref{Active Keymaps}), and it is used when point is within
+the overlay, where the front-
+and rear-advance properties define whether the boundaries are
+considered as being @emph{within} or not.
@item local-map
@kindex local-map @r{(overlay property)}
diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi
index fb393b9..f848218 100644
--- a/doc/lispref/errors.texi
+++ b/doc/lispref/errors.texi
@@ -20,8 +20,9 @@ the errors in accessing files have the condition
@code{file-error}. If
we do not say here that a certain error symbol has additional error
conditions, that means it has none.
- As a special exception, the error symbol @code{quit} does not have the
-condition @code{error}, because quitting is not considered an error.
+ As a special exception, the error symbols @code{quit} and
+@code{minibuffer-quit} don't have the condition @code{error}, because
+quitting is not considered an error.
Most of these error symbols are defined in C (mainly @file{data.c}),
but some are defined in Lisp. For example, the file @file{userlock.el}
@@ -40,6 +41,10 @@ The message is @samp{error}. @xref{Errors}.
@item quit
The message is @samp{Quit}. @xref{Quitting}.
+@item minibuffer-quit
+The message is @samp{Quit}. This is a subcategory of @code{quit}.
+@xref{Quitting}.
+
@item args-out-of-range
The message is @samp{Args out of range}. This happens when trying to
access an element beyond the range of a sequence, buffer, or other
diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi
index 448b8ae..7893895 100644
--- a/doc/lispref/eval.texi
+++ b/doc/lispref/eval.texi
@@ -350,7 +350,8 @@ Here is how you could define @code{indirect-function} in
Lisp:
@example
(defun indirect-function (function)
- (if (symbolp function)
+ (if (and function
+ (symbolp function))
(indirect-function (symbol-function function))
function))
@end example
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index c7e5537..266501d 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -2343,49 +2343,26 @@ entirely of directory separators.
@end example
@end defun
- Given a directory name, you can combine it with a relative file name
-using @code{concat}:
+@defun file-name-concat directory &rest components
+Concatenate @var{components} to @var{directory}, inserting a slash
+before the components if @var{directory} or the preceding component
+didn't end with a slash.
@example
-(concat @var{dirname} @var{relfile})
-@end example
-
-@noindent
-Be sure to verify that the file name is relative before doing that.
-If you use an absolute file name, the results could be syntactically
-invalid or refer to the wrong file.
-
- If you want to use a directory file name in making such a
-combination, you must first convert it to a directory name using
-@code{file-name-as-directory}:
-
-@example
-(concat (file-name-as-directory @var{dirfile}) @var{relfile})
-@end example
-
-@noindent
-Don't try concatenating a slash by hand, as in
-
-@example
-;;; @r{Wrong!}
-(concat @var{dirfile} "/" @var{relfile})
+@group
+(file-name-concat "/tmp" "foo")
+ @result{} "/tmp/foo"
+@end group
@end example
-@noindent
-because this is not portable. Always use
-@code{file-name-as-directory}.
-
- To avoid the issues mentioned above, or if the @var{dirname} value
-might be @code{nil} (for example, from an element of @code{load-path}),
-use:
+A @var{directory} or components that are @code{nil} or the empty
+string are ignored---they are filtered out first and do not affect the
+results in any way.
-@example
-(expand-file-name @var{relfile} @var{dirname})
-@end example
-
-However, @code{expand-file-name} expands leading @samp{~} in
-@var{relfile}, which may not be what you want. @xref{File Name
-Expansion}.
+This is almost the same as using @code{concat}, but @var{dirname} (and
+the non-final components) may or may not end with slash characters,
+and this function will not double those characters.
+@end defun
To convert a directory name to its abbreviation, use this
function:
diff --git a/doc/lispref/hooks.texi b/doc/lispref/hooks.texi
index b1c7e61..3949284 100644
--- a/doc/lispref/hooks.texi
+++ b/doc/lispref/hooks.texi
@@ -184,7 +184,7 @@ The command loop runs this soon after
@code{post-command-hook} (q.v.).
@item mouse-leave-buffer-hook
@vindex mouse-leave-buffer-hook
-Hook run when about to switch windows with a mouse command.
+Hook run when the user mouse-clicks in a window.
@item mouse-position-function
@xref{Mouse Position}.
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 7214948..b0dc0ff 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -2287,11 +2287,14 @@ enabled separately in each buffer.
@defvar global-mode-string
This variable holds a mode line construct that, by default, appears in
-the mode line just after the @code{which-function-mode} minor mode if set,
-else after @code{mode-line-modes}. The command @code{display-time} sets
+the mode line just after the @code{which-function-mode} minor mode if
+set, else after @code{mode-line-modes}. Elements that are added to
+this construct should normally end in a space (to ensure that
+consecutive @code{global-mode-string} elements display properly). For
+instance, the command @code{display-time} sets
@code{global-mode-string} to refer to the variable
-@code{display-time-string}, which holds a string containing the time and
-load information.
+@code{display-time-string}, which holds a string containing the time
+and load information.
The @samp{%M} construct substitutes the value of
@code{global-mode-string}, but that is obsolete, since the variable is
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 6fbb475..e18ba47 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -5301,11 +5301,20 @@ represents @code{@{@}}, the empty JSON object; not
@code{null},
@code{false}, or an empty array, all of which are different JSON
values.
+@defun json-available-p
+This predicate returns non-@code{nil} if Emacs has been built with
+@acronym{JSON} support, and the library is available on the current
+system.
+@end defun
+
If some Lisp object can't be represented in JSON, the serialization
functions will signal an error of type @code{wrong-type-argument}.
The parsing functions can also signal the following errors:
@table @code
+@item json-unavailable
+Signaled when the parsing library isn't available.
+
@item json-end-of-file
Signaled when encountering a premature end of the input text.
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index 62c76f0..9356fb9 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -1995,6 +1995,20 @@ Doing so adds those variable/value pairs to
file.
@end defopt
+@defopt ignored-local-variable-values
+If there are some values of particular local variables that you always
+want to ignore completely, you can use this variable. Its value has
+the same form as @code{safe-local-variable-values}; a file-local
+variable setting to the value that appears in the list will always be
+ignored when processing the local variables specified by the file. As
+with that variable, when Emacs queries the user about whether to obey
+file-local variables, the user can choose to ignore their particular
+values permanently, and that will alter this variable and save it to
+the user's custom file. Variable-value pairs that appear in this
+variable take precedence over the same pairs in
+@code{safe-local-variable-values}.
+@end defopt
+
@defun safe-local-variable-p sym val
This function returns non-@code{nil} if it is safe to give @var{sym}
the value @var{val}, based on the above criteria.
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index c9b5b2d..9cdcf39 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -16288,7 +16288,7 @@ cleaning up the headers. Functions that can be used
include:
Clear leading white space that ``helpful'' listservs have added to the
headers to make them look nice. Aaah.
-(Note that this function works on both the header on the body of all
+(Note that this function works on both the header and the body of all
messages, so it is a potentially dangerous function to use (if a body
of a message contains something that looks like a header line). So
rather than fix the bug, it is of course the right solution to make it
diff --git a/doc/misc/smtpmail.texi b/doc/misc/smtpmail.texi
index dd481d2..ca7dabe 100644
--- a/doc/misc/smtpmail.texi
+++ b/doc/misc/smtpmail.texi
@@ -338,6 +338,16 @@ not sent immediately but rather queued in the directory
@code{smtpmail-send-queued-mail} (typically when you connect to the
internet).
+@item smtpmail-store-queue-variables
+@vindex smtpmail-store-queue-variables
+ Normally the queue will be dispatched with the values of the
+@acronym{SMTP} variables that are in effect when @kbd{M-x
+smtpmail-send-queued-mail} is executed, but if
+@code{smtpmail-store-queue-variables} is non-@code{nil}, the values
+for @code{smtpmail-smtp-server} (etc.@:) will be stored when the mail is
+queued, and then used when actually sending the mail. This can be
+useful if you have a complex outgoing mail setup.
+
@item smtpmail-queue-dir
@vindex smtpmail-queue-dir
The variable @code{smtpmail-queue-dir} specifies the name of the
diff --git a/etc/NEWS b/etc/NEWS
index 88d8fbe..0d1abfd 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -92,6 +92,10 @@ proper pty support that Emacs needs.
* Startup Changes in Emacs 28.1
---
+** File names given on the command line will now be pushed onto
+'file-name-history'.
+
+---
** In GTK builds, Emacs now supports startup notification.
This means that Emacs won't steal keyboard focus upon startup
(when started via the Desktop) if the user is typing into another
@@ -114,6 +118,15 @@ avoid security issues when executing untrusted code. See
the manual
page for 'seccomp' system call, for details about Secure Computing
filters.
+** Setting 'fill-column' to nil is obsolete.
+This undocumented use of 'fill-column' is now obsolete. To disable
+auto filling, turn off 'auto-fill-mode' instead.
+
+For instance, you could add something like the following to your init
+file:
+
+ (add-hook 'foo-mode-hook (lambda () (auto-fill-mode -1))
+
* Changes in Emacs 28.1
@@ -335,6 +348,10 @@ by dragging the tab lines of their topmost windows with
the mouse.
* Editing Changes in Emacs 28.1
+---
+** Dragging a file to Emacs will now also push the name of the file
+onto 'file-name-history'.
+
+++
** A prefix arg now causes 'delete-other-frames' to only iconify frames.
@@ -476,6 +493,11 @@ highlighting on heading lines using standard outline
faces. This
works well only when there are no conflicts with faces used by the
major mode.
+** New commands 'copy-matching-lines' and 'kill-matching-lines'.
+These commands are similar to the command 'flush-lines',
+but add the matching lines to the kill ring as a single string,
+including the newlines that separate the lines.
+
* Changes in Specialized Modes and Packages in Emacs 28.1
@@ -581,6 +603,11 @@ indentation is done using SMIE or with the old ad-hoc code.
** Icomplete
+---
+*** New user option 'icomplete-matches-format'.
+This allows controlling the current/total number of matches for the
+prompt prefix.
+
+++
*** New minor mode 'icomplete-vertical-mode', alias 'fido-vertical-mode'.
This mode is intended to be used with Icomplete ('M-x icomplete-mode')
@@ -868,6 +895,12 @@ keys, add the following to your init file:
** Change Logs and VC
+*** vc-git now sets the GIT_LITERAL_PATHSPECS environment variable.
+This ensures that Git operations on files containing wildcard
+characters work as they're supposed to. However, this also affects
+scripts running from Git hooks, and these have to "unset
+GIT_LITERAL_PATHSPECS" to work as before.
+
*** More VC commands can be used from non-file buffers.
The relevant commands are those that don't change the VC state.
The non-file buffers which can use VC commands are those that have
@@ -1110,6 +1143,12 @@ take the actual screenshot, and defaults to "ImageMagick
import".
** Smtpmail
+++
+*** New user option 'smtpmail-store-queue-variables'.
+If non-nil, SMTP variables will be stored together with the queued
+messages, and will then be used when sending with
+'M-x smtpmail-send-queued-mail'.
+
++++
*** Allow direct selection of smtp authentication mechanism.
A server entry retrieved by auth-source can request a desired smtp
authentication mechanism by setting a value for the key 'smtp-auth'.
@@ -1421,6 +1460,10 @@ If non-nil, 'shell-mode' handles implicit "cd" commands,
changing the
directory if the command is a directory. Useful for shells like "zsh"
that has this feature.
++++
+*** 'comint-delete-output' can now save deleted text in the kill-ring.
+Interactively, 'C-u C-c C-o' triggers this new optional behavior.
+
** Eshell
---
@@ -1558,6 +1601,10 @@ See the new user options 'package-name-column-width',
** gdb-mi
+*** New user option 'gdb-registers-enable-filter'.
+If non-nil, apply a register filter based on
+'gdb-registers-filter-pattern-list'.
+
+++
*** gdb-mi can now store and restore window configurations.
Use 'gdb-save-window-configuration' to save window configuration to a
@@ -1592,6 +1639,14 @@ Defaults to 'libravatar', with 'unicornify' and
'gravatar' as options.
** Compilation mode
+---
+*** New function 'ansi-color-compilation-filter'.
+This function is meant to be used in 'compilation-filter-hook'.
+
+---
+*** New user option 'ansi-color-for-compilation-mode'.
+This controls what 'ansi-color-compilation-filter' does.
+
*** Regexp matching of messages is now case-sensitive by default.
The variable 'compilation-error-case-fold-search' can be set for
case-insensitive matching of messages when the old behavior is
@@ -1599,6 +1654,14 @@ required, but the recommended solution is to use a
correctly matching
regexp instead.
---
+*** New user option 'compilation-search-all-directories'.
+When doing parallel builds, directories and compilation errors may
+arrive in the "*compilation*" buffer out-of-order. If this variable is
+non-nil (the default), Emacs will now search backwards in the buffer
+for any directory the file with errors may be in. If nil, this won't
+be done (and this restores how this previously worked).
+
+---
*** Messages from ShellCheck are now recognized.
---
@@ -1986,6 +2049,27 @@ used instead. Uses of 'json-encode-list' should be
changed to call
one of 'json-encode', 'json-encode-alist', 'json-encode-plist', or
'json-encode-array' instead.
+** json.c
+
++++
+*** New function 'json-available-p'.
+This predicate returns non-nil if Emacs is built with libjansson
+support, and it is available on the current system.
+
++++
+*** Native JSON functions now signal an error if libjansson is unavailable.
+This affects 'json-serialize', 'json-insert', 'json-parse-srtring',
+and 'json-parse-buffer'. This can happen if Emacs was compiled with
+libjansson, but the DLL cannot be found and/or loaded by Emacs at run
+time. Previously, Emacs would display a message and return nil in
+these cases.
+
+*** The JSON functions 'json-serialize', 'json-insert',
+'json-parse-string', and 'json-parse-buffer' now implement some of the
+semantics of RFC 8259 instead of the earlier RFC 4627. In particular,
+these functions now accept top-level JSON values that are neither
+arrays nor objects.
+
** xml.el
*** XML serialization functions now reject invalid characters.
@@ -2214,6 +2298,28 @@ This command, called interactively, toggles the local
value of
** Miscellaneous
++++
+*** .dir-locals.el now supports setting 'auto-mode-alist'.
+The new 'auto-mode-alist' specification in .dir-local.el files can now
+be used to override the global 'auto-mode-alist' in the current
+directory tree.
+
+---
+*** New utility function 'make-separator-line'.
+
+---
+*** New face 'separator-line'.
+This is used by 'make-separator-line'.
+
++++
+*** New user option 'ignored-local-variable-values'.
+This is the opposite of 'safe-local-variable-values' -- it's an alist
+of variable-value pairs that are to be ignored when reading a
+local-variables section of a file.
+
+---
+*** 'indent-tabs-mode' is now a global minor mode instead of just a variable.
+
---
*** New user option 'save-place-abbreviate-file-names'.
@@ -2225,6 +2331,9 @@ previously no easy way to get back to the original
displayed order
after sorting, but giving a -1 numerical prefix to the sorting command
will now restore the original order.
+---
+*** 'M-left' and 'M-right' now move between columns in 'tabulated-list-mode'.
+
+++
*** New utility function 'insert-into-buffer'.
This is like 'insert-buffer-substring', but works in the opposite
@@ -2357,14 +2466,6 @@ doesn't turn on 'display-fill-column-indicator-mode' in
special-mode
buffers. This can be controlled by customizing the variable
'global-display-fill-column-indicator-modes'.
----
-*** New user option 'compilation-search-all-directories'.
-When doing parallel builds, directories and compilation errors may
-arrive in the "*compilation*" buffer out-of-order. If this variable is
-non-nil (the default), Emacs will now search backwards in the buffer
-for any directory the file with errors may be in. If nil, this won't
-be done (and this restores how this previously worked).
-
+++
*** New user option 'next-error-message-highlight'.
In addition to a fringe arrow, 'next-error' error may now optionally
@@ -2419,20 +2520,6 @@ point leaves the text. If nil, the text is not hidden
again. Instead
'M-x reveal-hide-revealed' can be used to hide all the revealed text.
+++
-*** New user options to control the look of line/column numbers in the mode
line.
-'mode-line-position-line-format' is the line number format (when
-'line-number-mode' is on), 'mode-line-position-column-format' is
-the column number format (when 'column-number-mode' is on), and
-'mode-line-position-column-line-format' is the combined format (when
-both modes are on).
-
-+++
-*** New user option 'mode-line-compact'.
-If non-nil, repeating spaces are compressed into a single space. If
-'long', this is only done when the mode line is longer than the
-current window width (in characters).
-
-+++
*** New command 'submit-emacs-patch'.
This works like 'report-emacs-bug', but is more geared towards sending
patches to the Emacs issue tracker.
@@ -2636,6 +2723,15 @@ also keep the type information of their arguments. Use
the
---
*** New face 'perl-heredoc', used for heredoc elements.
++++
+** A function can now be thrown to the 'exit' label in addition to t or nil.
+The command loop will call it with zero arguments before returning.
+
++++
+** New error symbol 'minibuffer-quit'.
+Signaling it has almost the same effect as 'quit' except that it
+doesn't cause keyboard macro termination.
+
---
*** The command 'cperl-set-style' offers the new value "PBP".
This value customizes Emacs to use the style recommended in Damian
@@ -2722,6 +2818,9 @@ similar to prefix arguments, but are more flexible and
discoverable.
* Incompatible Editing Changes in Emacs 28.1
+** 'revert-buffer' will now preserve buffer-readedness.
+It previously switched the read-only flag off.
+
** 'electric-indent-mode' now also indents inside strings and comments,
(unless the indentation function doesn't, of course).
To recover the previous behavior you can use:
@@ -2775,6 +2874,14 @@ This is to keep the same behavior as Eshell.
* Incompatible Lisp Changes in Emacs 28.1
---
+** 'kill-all-local-variables' has changed how it handles non-symbol hooks.
+The function is documented to eliminated all buffer-local bindings
+except variables with a 'permanent-local' property, or hooks that
+have elements with a 'permanent-local-hook' property. In addition, it
+would also keep lambda expressions in hooks sometimes. The latter has
+now been changed: The function will now also remove these.
+
+---
** Some floating-point numbers are now handled differently by the Lisp reader.
In previous versions of Emacs, numbers with a trailing dot and an exponent
were read as integers and the exponent ignored: 2.e6 was interpreted as the
@@ -3002,6 +3109,10 @@ The former is now declared obsolete.
* Lisp Changes in Emacs 28.1
+++
+*** New function 'file-name-concat'.
+This appends path components to a directory name and returns the result.
+
++++
*** New function 'split-string-shell-command'.
This splits a shell command string into separate components,
respecting quoting with single ('like this') and double ("like this")
@@ -3229,6 +3340,27 @@ file mode specification into symbolic form.
** The variable 'force-new-style-backquotes' has been removed.
This removes the final remaining trace of old-style backquotes.
+** Mode Lines
+
++++
+*** New user options to control the line/column numbers in the mode line.
+'mode-line-position-line-format' is the line number format (when
+'line-number-mode' is on), 'mode-line-position-column-format' is
+the column number format (when 'column-number-mode' is on), and
+'mode-line-position-column-line-format' is the combined format (when
+both modes are on).
+
++++
+*** New user option 'mode-line-compact'.
+If non-nil, repeating spaces are compressed into a single space. If
+'long', this is only done when the mode line is longer than the
+current window width (in characters).
+
++++
+*** 'global-mode-string' constructs should end with a space.
+This was previously not formalized, which led to combinations of modes
+displaying data "smushed together" on the mode line.
+
** Changes in handling dynamic modules
*** The module header 'emacs-module.h' now contains type aliases
@@ -3410,12 +3542,6 @@ locales. They are also available as aliases
'ebcdic-cp-*' (e.g.,
'cp278' for 'ibm278'). There are also new charsets 'ibm2xx' to
support these coding-systems.
-** The JSON functions 'json-serialize', 'json-insert',
-'json-parse-string', and 'json-parse-buffer' now implement some of the
-semantics of RFC 8259 instead of the earlier RFC 4627. In particular,
-these functions now accept top-level JSON values that are neither
-arrays nor objects.
-
---
** 'while-no-input-ignore-events' accepts more special events.
The special events 'dbus-event' and 'file-notify' are now ignored in
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c
index 6d3f827..8fa571f 100644
--- a/lib-src/emacsclient.c
+++ b/lib-src/emacsclient.c
@@ -80,6 +80,9 @@ char *w32_getenv (const char *);
#include <sys/stat.h>
#include <unistd.h>
+#ifndef WINDOWSNT
+# include <acl.h>
+#endif
#include <filename.h>
#include <intprops.h>
#include <min-max.h>
@@ -91,6 +94,10 @@ char *w32_getenv (const char *);
# pragma GCC diagnostic ignored "-Wformat-truncation=2"
#endif
+#if !defined O_PATH && !defined WINDOWSNT
+# define O_PATH O_SEARCH
+#endif
+
/* Name used to invoke this program. */
static char const *progname;
@@ -1133,24 +1140,74 @@ process_grouping (void)
#ifdef SOCKETS_IN_FILE_SYSTEM
-/* Return the file status of NAME, ordinarily a socket.
- It should be owned by UID. Return one of the following:
- >0 - 'stat' failed with this errno value
- -1 - isn't owned by us
- 0 - success: none of the above */
+/* A local socket address. The union avoids the need to cast. */
+union local_sockaddr
+{
+ struct sockaddr_un un;
+ struct sockaddr sa;
+};
+
+/* Relative to the directory DIRFD, connect the socket file named ADDR
+ to the socket S. Return 0 if successful, -1 if DIRFD is not
+ AT_FDCWD and DIRFD's permissions would allow a symlink attack, an
+ errno otherwise. */
static int
-socket_status (const char *name, uid_t uid)
+connect_socket (int dirfd, char const *addr, int s, uid_t uid)
{
- struct stat statbfr;
+ int sock_status = 0;
- if (stat (name, &statbfr) != 0)
- return errno;
+ union local_sockaddr server;
+ if (sizeof server.un.sun_path <= strlen (addr))
+ return ENAMETOOLONG;
+ server.un.sun_family = AF_UNIX;
+ strcpy (server.un.sun_path, addr);
- if (statbfr.st_uid != uid)
- return -1;
+ /* If -1, WDFD is not set yet. If nonnegative, WDFD is a file
+ descriptor for the initial working directory. Otherwise -1 - WDFD is
+ the error number for the initial working directory. */
+ static int wdfd = -1;
- return 0;
+ if (dirfd != AT_FDCWD)
+ {
+ /* Fail if DIRFD's permissions are bogus. */
+ struct stat st;
+ if (fstat (dirfd, &st) != 0)
+ return errno;
+ if (st.st_uid != uid || (st.st_mode & (S_IWGRP | S_IWOTH)))
+ return -1;
+
+ if (wdfd == -1)
+ {
+ /* Save the initial working directory. */
+ wdfd = open (".", O_PATH | O_CLOEXEC);
+ if (wdfd < 0)
+ wdfd = -1 - errno;
+ }
+ if (wdfd < 0)
+ return -1 - wdfd;
+ if (fchdir (dirfd) != 0)
+ return errno;
+
+ /* Fail if DIRFD has an ACL, which means its permissions are
+ almost surely bogus. */
+ int has_acl = file_has_acl (".", &st);
+ if (has_acl)
+ sock_status = has_acl < 0 ? errno : -1;
+ }
+
+ if (!sock_status)
+ sock_status = connect (s, &server.sa, sizeof server.un) == 0 ? 0 : errno;
+
+ /* Fail immediately if we cannot change back to the initial working
+ directory, as that can mess up the rest of execution. */
+ if (dirfd != AT_FDCWD && fchdir (wdfd) != 0)
+ {
+ message (true, "%s: .: %s\n", progname, strerror (errno));
+ exit (EXIT_FAILURE);
+ }
+
+ return sock_status;
}
@@ -1327,32 +1384,49 @@ act_on_signals (HSOCKET emacs_socket)
}
}
-/* Create in SOCKNAME (of size SOCKNAMESIZE) a name for a local socket.
- The first TMPDIRLEN bytes of SOCKNAME are already initialized to be
- the name of a temporary directory. Use UID and SERVER_NAME to
- concoct the name. Return the total length of the name if successful,
- -1 if it does not fit (and store a truncated name in that case).
- Fail if TMPDIRLEN is out of range. */
+enum { socknamesize = sizeof ((struct sockaddr_un *) NULL)->sun_path };
+
+/* Given a local socket S, create in *SOCKNAME a name for a local socket
+ and connect to that socket. The first TMPDIRLEN bytes of *SOCKNAME are
+ already initialized to be the name of a temporary directory.
+ Use UID and SERVER_NAME to concoct the name. Return 0 if
+ successful, -1 if the socket's parent directory is not safe, and an
+ errno if there is some other problem. */
static int
-local_sockname (char *sockname, int socknamesize, int tmpdirlen,
- uintmax_t uid, char const *server_name)
+local_sockname (int s, char sockname[socknamesize], int tmpdirlen,
+ uid_t uid, char const *server_name)
{
/* If ! (0 <= TMPDIRLEN && TMPDIRLEN < SOCKNAMESIZE) the truncated
temporary directory name is already in SOCKNAME, so nothing more
need be stored. */
- if (0 <= tmpdirlen)
- {
- int remaining = socknamesize - tmpdirlen;
- if (0 < remaining)
- {
- int suffixlen = snprintf (&sockname[tmpdirlen], remaining,
- "/emacs%"PRIuMAX"/%s", uid, server_name);
- if (0 <= suffixlen && suffixlen < remaining)
- return tmpdirlen + suffixlen;
- }
- }
- return -1;
+ if (! (0 <= tmpdirlen && tmpdirlen < socknamesize))
+ return ENAMETOOLONG;
+
+ /* Put the full address name into the buffer, since the caller might
+ need it for diagnostics. But don't overrun the buffer. */
+ uintmax_t uidmax = uid;
+ int emacsdirlen;
+ int suffixlen = snprintf (sockname + tmpdirlen, socknamesize - tmpdirlen,
+ "/emacs%"PRIuMAX"%n/%s", uidmax, &emacsdirlen,
+ server_name);
+ if (! (0 <= suffixlen && suffixlen < socknamesize - tmpdirlen))
+ return ENAMETOOLONG;
+
+ /* Make sure the address's parent directory is not a symlink and is
+ this user's directory and does not let others write to it; this
+ fends off some symlink attacks. To avoid races, keep the parent
+ directory open while checking. */
+ char *emacsdirend = sockname + tmpdirlen + emacsdirlen;
+ *emacsdirend = '\0';
+ int dir = openat (AT_FDCWD, sockname,
+ O_PATH | O_DIRECTORY | O_NOFOLLOW | O_CLOEXEC);
+ *emacsdirend = '/';
+ if (dir < 0)
+ return errno;
+ int sock_status = connect_socket (dir, server_name, s, uid);
+ close (dir);
+ return sock_status;
}
/* Create a local socket for SERVER_NAME and connect it to Emacs. If
@@ -1363,28 +1437,43 @@ local_sockname (char *sockname, int socknamesize, int
tmpdirlen,
static HSOCKET
set_local_socket (char const *server_name)
{
- union {
- struct sockaddr_un un;
- struct sockaddr sa;
- } server = {{ .sun_family = AF_UNIX }};
+ union local_sockaddr server;
+ int sock_status;
char *sockname = server.un.sun_path;
- enum { socknamesize = sizeof server.un.sun_path };
int tmpdirlen = -1;
int socknamelen = -1;
uid_t uid = geteuid ();
bool tmpdir_used = false;
+ int s = cloexec_socket (AF_UNIX, SOCK_STREAM, 0);
+ if (s < 0)
+ {
+ message (true, "%s: can't create socket: %s\n",
+ progname, strerror (errno));
+ fail ();
+ }
if (strchr (server_name, '/')
|| (ISSLASH ('\\') && strchr (server_name, '\\')))
- socknamelen = snprintf (sockname, socknamesize, "%s", server_name);
+ {
+ socknamelen = snprintf (sockname, socknamesize, "%s", server_name);
+ sock_status = (0 <= socknamelen && socknamelen < socknamesize
+ ? connect_socket (AT_FDCWD, sockname, s, 0)
+ : ENAMETOOLONG);
+ }
else
{
/* socket_name is a file name component. */
+ sock_status = ENOENT;
char const *xdg_runtime_dir = egetenv ("XDG_RUNTIME_DIR");
if (xdg_runtime_dir)
- socknamelen = snprintf (sockname, socknamesize, "%s/emacs/%s",
- xdg_runtime_dir, server_name);
- else
+ {
+ socknamelen = snprintf (sockname, socknamesize, "%s/emacs/%s",
+ xdg_runtime_dir, server_name);
+ sock_status = (0 <= socknamelen && socknamelen < socknamesize
+ ? connect_socket (AT_FDCWD, sockname, s, 0)
+ : ENAMETOOLONG);
+ }
+ if (sock_status == ENOENT)
{
char const *tmpdir = egetenv ("TMPDIR");
if (tmpdir)
@@ -1403,23 +1492,24 @@ set_local_socket (char const *server_name)
if (tmpdirlen < 0)
tmpdirlen = snprintf (sockname, socknamesize, "/tmp");
}
- socknamelen = local_sockname (sockname, socknamesize, tmpdirlen,
+ sock_status = local_sockname (s, sockname, tmpdirlen,
uid, server_name);
tmpdir_used = true;
}
}
- if (! (0 <= socknamelen && socknamelen < socknamesize))
+ if (sock_status == 0)
+ return s;
+
+ if (sock_status == ENAMETOOLONG)
{
message (true, "%s: socket-name %s... too long\n", progname, sockname);
fail ();
}
- /* See if the socket exists, and if it's owned by us. */
- int sock_status = socket_status (sockname, uid);
- if (sock_status)
+ if (tmpdir_used)
{
- /* Failing that, see if LOGNAME or USER exist and differ from
+ /* See whether LOGNAME or USER exist and differ from
our euid. If so, look for a socket based on the UID
associated with the name. This is reminiscent of the logic
that init_editfns uses to set the global Vuser_full_name. */
@@ -1436,48 +1526,26 @@ set_local_socket (char const *server_name)
if (pw && pw->pw_uid != uid)
{
/* We're running under su, apparently. */
- socknamelen = local_sockname (sockname, socknamesize, tmpdirlen,
+ sock_status = local_sockname (s, sockname, tmpdirlen,
pw->pw_uid, server_name);
- if (socknamelen < 0)
+ if (sock_status == 0)
+ return s;
+ if (sock_status == ENAMETOOLONG)
{
message (true, "%s: socket-name %s... too long\n",
progname, sockname);
exit (EXIT_FAILURE);
}
-
- sock_status = socket_status (sockname, uid);
}
}
}
- if (sock_status == 0)
- {
- HSOCKET s = cloexec_socket (AF_UNIX, SOCK_STREAM, 0);
- if (s < 0)
- {
- message (true, "%s: socket: %s\n", progname, strerror (errno));
- return INVALID_SOCKET;
- }
- if (connect (s, &server.sa, sizeof server.un) != 0)
- {
- message (true, "%s: connect: %s\n", progname, strerror (errno));
- CLOSE_SOCKET (s);
- return INVALID_SOCKET;
- }
+ close (s);
- struct stat connect_stat;
- if (fstat (s, &connect_stat) != 0)
- sock_status = errno;
- else if (connect_stat.st_uid == uid)
- return s;
- else
- sock_status = -1;
-
- CLOSE_SOCKET (s);
- }
-
- if (sock_status < 0)
- message (true, "%s: Invalid socket owner\n", progname);
+ if (sock_status == -1)
+ message (true,
+ "%s: Invalid permissions on parent directory of socket: %s\n",
+ progname, sockname);
else if (sock_status == ENOENT)
{
if (tmpdir_used)
@@ -1507,7 +1575,7 @@ set_local_socket (char const *server_name)
}
}
else
- message (true, "%s: can't stat %s: %s\n",
+ message (true, "%s: can't connect to %s: %s\n",
progname, sockname, strerror (sock_status));
return INVALID_SOCKET;
diff --git a/lib/file-has-acl.c b/lib/file-has-acl.c
new file mode 100644
index 0000000..c667ae9
--- /dev/null
+++ b/lib/file-has-acl.c
@@ -0,0 +1,510 @@
+/* Test whether a file has a nontrivial ACL. -*- coding: utf-8 -*-
+
+ Copyright (C) 2002-2003, 2005-2020 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+ Written by Paul Eggert, Andreas Grünbacher, and Bruno Haible. */
+
+/* Without this pragma, gcc 4.7.0 20120126 may suggest that the
+ file_has_acl function might be candidate for attribute 'const' */
+#if (__GNUC__ == 4 && 6 <= __GNUC_MINOR__) || 4 < __GNUC__
+# pragma GCC diagnostic ignored "-Wsuggest-attribute=const"
+#endif
+
+#include <config.h>
+
+#include "acl.h"
+
+#include "acl-internal.h"
+
+#if GETXATTR_WITH_POSIX_ACLS
+# include <sys/xattr.h>
+# include <linux/xattr.h>
+#endif
+
+/* Return 1 if NAME has a nontrivial access control list,
+ 0 if ACLs are not supported, or if NAME has no or only a base ACL,
+ and -1 (setting errno) on error. Note callers can determine
+ if ACLs are not supported as errno is set in that case also.
+ SB must be set to the stat buffer of NAME,
+ obtained through stat() or lstat(). */
+
+int
+file_has_acl (char const *name, struct stat const *sb)
+{
+#if USE_ACL
+ if (! S_ISLNK (sb->st_mode))
+ {
+
+# if GETXATTR_WITH_POSIX_ACLS
+
+ ssize_t ret;
+
+ ret = getxattr (name, XATTR_NAME_POSIX_ACL_ACCESS, NULL, 0);
+ if (ret < 0 && errno == ENODATA)
+ ret = 0;
+ else if (ret > 0)
+ return 1;
+
+ if (ret == 0 && S_ISDIR (sb->st_mode))
+ {
+ ret = getxattr (name, XATTR_NAME_POSIX_ACL_DEFAULT, NULL, 0);
+ if (ret < 0 && errno == ENODATA)
+ ret = 0;
+ else if (ret > 0)
+ return 1;
+ }
+
+ if (ret < 0)
+ return - acl_errno_valid (errno);
+ return ret;
+
+# elif HAVE_ACL_GET_FILE
+
+ /* POSIX 1003.1e (draft 17 -- abandoned) specific version. */
+ /* Linux, FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
+ int ret;
+
+ if (HAVE_ACL_EXTENDED_FILE) /* Linux */
+ {
+ /* On Linux, acl_extended_file is an optimized function: It only
+ makes two calls to getxattr(), one for ACL_TYPE_ACCESS, one for
+ ACL_TYPE_DEFAULT. */
+ ret = acl_extended_file (name);
+ }
+ else /* FreeBSD, Mac OS X, IRIX, Tru64, Cygwin >= 2.5 */
+ {
+# if HAVE_ACL_TYPE_EXTENDED /* Mac OS X */
+ /* On Mac OS X, acl_get_file (name, ACL_TYPE_ACCESS)
+ and acl_get_file (name, ACL_TYPE_DEFAULT)
+ always return NULL / EINVAL. There is no point in making
+ these two useless calls. The real ACL is retrieved through
+ acl_get_file (name, ACL_TYPE_EXTENDED). */
+ acl_t acl = acl_get_file (name, ACL_TYPE_EXTENDED);
+ if (acl)
+ {
+ ret = acl_extended_nontrivial (acl);
+ acl_free (acl);
+ }
+ else
+ ret = -1;
+# else /* FreeBSD, IRIX, Tru64, Cygwin >= 2.5 */
+ acl_t acl = acl_get_file (name, ACL_TYPE_ACCESS);
+ if (acl)
+ {
+ int saved_errno;
+
+ ret = acl_access_nontrivial (acl);
+ saved_errno = errno;
+ acl_free (acl);
+ errno = saved_errno;
+# if HAVE_ACL_FREE_TEXT /* Tru64 */
+ /* On OSF/1, acl_get_file (name, ACL_TYPE_DEFAULT) always
+ returns NULL with errno not set. There is no point in
+ making this call. */
+# else /* FreeBSD, IRIX, Cygwin >= 2.5 */
+ /* On Linux, FreeBSD, IRIX, acl_get_file (name, ACL_TYPE_ACCESS)
+ and acl_get_file (name, ACL_TYPE_DEFAULT) on a directory
+ either both succeed or both fail; it depends on the
+ file system. Therefore there is no point in making the second
+ call if the first one already failed. */
+ if (ret == 0 && S_ISDIR (sb->st_mode))
+ {
+ acl = acl_get_file (name, ACL_TYPE_DEFAULT);
+ if (acl)
+ {
+# ifdef __CYGWIN__ /* Cygwin >= 2.5 */
+ ret = acl_access_nontrivial (acl);
+ saved_errno = errno;
+ acl_free (acl);
+ errno = saved_errno;
+# else
+ ret = (0 < acl_entries (acl));
+ acl_free (acl);
+# endif
+ }
+ else
+ ret = -1;
+ }
+# endif
+ }
+ else
+ ret = -1;
+# endif
+ }
+ if (ret < 0)
+ return - acl_errno_valid (errno);
+ return ret;
+
+# elif HAVE_FACL && defined GETACL /* Solaris, Cygwin < 2.5, not HP-UX */
+
+# if defined ACL_NO_TRIVIAL
+
+ /* Solaris 10 (newer version), which has additional API declared in
+ <sys/acl.h> (acl_t) and implemented in libsec (acl_set, acl_trivial,
+ acl_fromtext, ...). */
+ return acl_trivial (name);
+
+# else /* Solaris, Cygwin, general case */
+
+ /* Solaris 2.5 through Solaris 10, Cygwin, and contemporaneous versions
+ of Unixware. The acl() call returns the access and default ACL both
+ at once. */
+ {
+ /* Initially, try to read the entries into a stack-allocated buffer.
+ Use malloc if it does not fit. */
+ enum
+ {
+ alloc_init = 4000 / sizeof (aclent_t), /* >= 3 */
+ alloc_max = MIN (INT_MAX, SIZE_MAX / sizeof (aclent_t))
+ };
+ aclent_t buf[alloc_init];
+ size_t alloc = alloc_init;
+ aclent_t *entries = buf;
+ aclent_t *malloced = NULL;
+ int count;
+
+ for (;;)
+ {
+ count = acl (name, GETACL, alloc, entries);
+ if (count < 0 && errno == ENOSPC)
+ {
+ /* Increase the size of the buffer. */
+ free (malloced);
+ if (alloc > alloc_max / 2)
+ {
+ errno = ENOMEM;
+ return -1;
+ }
+ alloc = 2 * alloc; /* <= alloc_max */
+ entries = malloced =
+ (aclent_t *) malloc (alloc * sizeof (aclent_t));
+ if (entries == NULL)
+ {
+ errno = ENOMEM;
+ return -1;
+ }
+ continue;
+ }
+ break;
+ }
+ if (count < 0)
+ {
+ if (errno == ENOSYS || errno == ENOTSUP)
+ ;
+ else
+ {
+ int saved_errno = errno;
+ free (malloced);
+ errno = saved_errno;
+ return -1;
+ }
+ }
+ else if (count == 0)
+ ;
+ else
+ {
+ /* Don't use MIN_ACL_ENTRIES: It's set to 4 on Cygwin, but Cygwin
+ returns only 3 entries for files with no ACL. But this is safe:
+ If there are more than 4 entries, there cannot be only the
+ "user::", "group::", "other:", and "mask:" entries. */
+ if (count > 4)
+ {
+ free (malloced);
+ return 1;
+ }
+
+ if (acl_nontrivial (count, entries))
+ {
+ free (malloced);
+ return 1;
+ }
+ }
+ free (malloced);
+ }
+
+# ifdef ACE_GETACL
+ /* Solaris also has a different variant of ACLs, used in ZFS and NFSv4
+ file systems (whereas the other ones are used in UFS file systems).
*/
+ {
+ /* Initially, try to read the entries into a stack-allocated buffer.
+ Use malloc if it does not fit. */
+ enum
+ {
+ alloc_init = 4000 / sizeof (ace_t), /* >= 3 */
+ alloc_max = MIN (INT_MAX, SIZE_MAX / sizeof (ace_t))
+ };
+ ace_t buf[alloc_init];
+ size_t alloc = alloc_init;
+ ace_t *entries = buf;
+ ace_t *malloced = NULL;
+ int count;
+
+ for (;;)
+ {
+ count = acl (name, ACE_GETACL, alloc, entries);
+ if (count < 0 && errno == ENOSPC)
+ {
+ /* Increase the size of the buffer. */
+ free (malloced);
+ if (alloc > alloc_max / 2)
+ {
+ errno = ENOMEM;
+ return -1;
+ }
+ alloc = 2 * alloc; /* <= alloc_max */
+ entries = malloced = (ace_t *) malloc (alloc * sizeof (ace_t));
+ if (entries == NULL)
+ {
+ errno = ENOMEM;
+ return -1;
+ }
+ continue;
+ }
+ break;
+ }
+ if (count < 0)
+ {
+ if (errno == ENOSYS || errno == EINVAL)
+ ;
+ else
+ {
+ int saved_errno = errno;
+ free (malloced);
+ errno = saved_errno;
+ return -1;
+ }
+ }
+ else if (count == 0)
+ ;
+ else
+ {
+ /* In the old (original Solaris 10) convention:
+ If there are more than 3 entries, there cannot be only the
+ ACE_OWNER, ACE_GROUP, ACE_OTHER entries.
+ In the newer Solaris 10 and Solaris 11 convention:
+ If there are more than 6 entries, there cannot be only the
+ ACE_OWNER, ACE_GROUP, ACE_EVERYONE entries, each once with
+ NEW_ACE_ACCESS_ALLOWED_ACE_TYPE and once with
+ NEW_ACE_ACCESS_DENIED_ACE_TYPE. */
+ if (count > 6)
+ {
+ free (malloced);
+ return 1;
+ }
+
+ if (acl_ace_nontrivial (count, entries))
+ {
+ free (malloced);
+ return 1;
+ }
+ }
+ free (malloced);
+ }
+# endif
+
+ return 0;
+# endif
+
+# elif HAVE_GETACL /* HP-UX */
+
+ {
+ struct acl_entry entries[NACLENTRIES];
+ int count;
+
+ count = getacl (name, NACLENTRIES, entries);
+
+ if (count < 0)
+ {
+ /* ENOSYS is seen on newer HP-UX versions.
+ EOPNOTSUPP is typically seen on NFS mounts.
+ ENOTSUP was seen on Quantum StorNext file systems (cvfs). */
+ if (errno == ENOSYS || errno == EOPNOTSUPP || errno == ENOTSUP)
+ ;
+ else
+ return -1;
+ }
+ else if (count == 0)
+ return 0;
+ else /* count > 0 */
+ {
+ if (count > NACLENTRIES)
+ /* If NACLENTRIES cannot be trusted, use dynamic memory
+ allocation. */
+ abort ();
+
+ /* If there are more than 3 entries, there cannot be only the
+ (uid,%), (%,gid), (%,%) entries. */
+ if (count > 3)
+ return 1;
+
+ {
+ struct stat statbuf;
+
+ if (stat (name, &statbuf) < 0)
+ return -1;
+
+ return acl_nontrivial (count, entries);
+ }
+ }
+ }
+
+# if HAVE_ACLV_H /* HP-UX >= 11.11 */
+
+ {
+ struct acl entries[NACLVENTRIES];
+ int count;
+
+ count = acl ((char *) name, ACL_GET, NACLVENTRIES, entries);
+
+ if (count < 0)
+ {
+ /* EOPNOTSUPP is seen on NFS in HP-UX 11.11, 11.23.
+ EINVAL is seen on NFS in HP-UX 11.31. */
+ if (errno == ENOSYS || errno == EOPNOTSUPP || errno == EINVAL)
+ ;
+ else
+ return -1;
+ }
+ else if (count == 0)
+ return 0;
+ else /* count > 0 */
+ {
+ if (count > NACLVENTRIES)
+ /* If NACLVENTRIES cannot be trusted, use dynamic memory
+ allocation. */
+ abort ();
+
+ /* If there are more than 4 entries, there cannot be only the
+ four base ACL entries. */
+ if (count > 4)
+ return 1;
+
+ return aclv_nontrivial (count, entries);
+ }
+ }
+
+# endif
+
+# elif HAVE_ACLX_GET && defined ACL_AIX_WIP /* AIX */
+
+ acl_type_t type;
+ char aclbuf[1024];
+ void *acl = aclbuf;
+ size_t aclsize = sizeof (aclbuf);
+ mode_t mode;
+
+ for (;;)
+ {
+ /* The docs say that type being 0 is equivalent to ACL_ANY, but it
+ is not true, in AIX 5.3. */
+ type.u64 = ACL_ANY;
+ if (aclx_get (name, 0, &type, aclbuf, &aclsize, &mode) >= 0)
+ break;
+ if (errno == ENOSYS)
+ return 0;
+ if (errno != ENOSPC)
+ {
+ if (acl != aclbuf)
+ {
+ int saved_errno = errno;
+ free (acl);
+ errno = saved_errno;
+ }
+ return -1;
+ }
+ aclsize = 2 * aclsize;
+ if (acl != aclbuf)
+ free (acl);
+ acl = malloc (aclsize);
+ if (acl == NULL)
+ {
+ errno = ENOMEM;
+ return -1;
+ }
+ }
+
+ if (type.u64 == ACL_AIXC)
+ {
+ int result = acl_nontrivial ((struct acl *) acl);
+ if (acl != aclbuf)
+ free (acl);
+ return result;
+ }
+ else if (type.u64 == ACL_NFS4)
+ {
+ int result = acl_nfs4_nontrivial ((nfs4_acl_int_t *) acl);
+ if (acl != aclbuf)
+ free (acl);
+ return result;
+ }
+ else
+ {
+ /* A newer type of ACL has been introduced in the system.
+ We should better support it. */
+ if (acl != aclbuf)
+ free (acl);
+ errno = EINVAL;
+ return -1;
+ }
+
+# elif HAVE_STATACL /* older AIX */
+
+ union { struct acl a; char room[4096]; } u;
+
+ if (statacl ((char *) name, STX_NORMAL, &u.a, sizeof (u)) < 0)
+ return -1;
+
+ return acl_nontrivial (&u.a);
+
+# elif HAVE_ACLSORT /* NonStop Kernel */
+
+ {
+ struct acl entries[NACLENTRIES];
+ int count;
+
+ count = acl ((char *) name, ACL_GET, NACLENTRIES, entries);
+
+ if (count < 0)
+ {
+ if (errno == ENOSYS || errno == ENOTSUP)
+ ;
+ else
+ return -1;
+ }
+ else if (count == 0)
+ return 0;
+ else /* count > 0 */
+ {
+ if (count > NACLENTRIES)
+ /* If NACLENTRIES cannot be trusted, use dynamic memory
+ allocation. */
+ abort ();
+
+ /* If there are more than 4 entries, there cannot be only the
+ four base ACL entries. */
+ if (count > 4)
+ return 1;
+
+ return acl_nontrivial (count, entries);
+ }
+ }
+
+# endif
+ }
+#endif
+
+ return 0;
+}
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index 07736f9..0b9aaf6 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -98,6 +98,7 @@
# fcntl \
# fcntl-h \
# fdopendir \
+# file-has-acl \
# filemode \
# filename \
# filevercmp \
@@ -1788,6 +1789,16 @@ EXTRA_libgnu_a_SOURCES += fdopendir.c
endif
## end gnulib module fdopendir
+## begin gnulib module file-has-acl
+ifeq (,$(OMIT_GNULIB_MODULE_file-has-acl))
+
+libgnu_a_SOURCES += file-has-acl.c
+
+EXTRA_DIST += acl-internal.h
+
+endif
+## end gnulib module file-has-acl
+
## begin gnulib module filemode
ifeq (,$(OMIT_GNULIB_MODULE_filemode))
diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index 44dc035..79dc821 100644
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -75,6 +75,7 @@
;;; Code:
(defvar comint-last-output-start)
+(defvar compilation-filter-start)
;; Customization
@@ -181,6 +182,24 @@ in shell buffers. You set this variable by calling one of:
:group 'ansi-colors
:version "23.2")
+(defcustom ansi-color-for-compilation-mode t
+ "Determines what to do with compilation output.
+If nil, do nothing.
+
+If the symbol `filter', then filter all ANSI graphical control
+sequences.
+
+If anything else (such as t), then translate ANSI graphical
+control sequences into text properties.
+
+In order for this to have any effect, `ansi-color-compilation-filter'
+must be in `compilation-filter-hook'."
+ :type '(choice (const :tag "Do nothing" nil)
+ (const :tag "Filter" filter)
+ (other :tag "Translate" t))
+ :group 'ansi-colors
+ :version "28.1")
+
(defvar ansi-color-apply-face-function #'ansi-color-apply-overlay-face
"Function for applying an Ansi Color face to text in a buffer.
This function should accept three arguments: BEG, END, and FACE,
@@ -228,6 +247,19 @@ This is a good function to put in
`comint-output-filter-functions'."
(t
(ansi-color-apply-on-region start-marker end-marker)))))
+;;;###autoload
+(defun ansi-color-compilation-filter ()
+ "Maybe translate SGR control sequences into text properties.
+This function depends on the `ansi-color-for-compilation-mode'
+variable, and is meant to be used in `compilation-filter-hook'."
+ (let ((inhibit-read-only t))
+ (pcase ansi-color-for-compilation-mode
+ ('nil nil)
+ ('filter
+ (ansi-color-filter-region compilation-filter-start (point)))
+ (_
+ (ansi-color-apply-on-region compilation-filter-start (point))))))
+
(define-obsolete-function-alias 'ansi-color-unfontify-region
'font-lock-default-unfontify-region "24.1")
diff --git a/lisp/autorevert.el b/lisp/autorevert.el
index edd4c7e..9197ead 100644
--- a/lisp/autorevert.el
+++ b/lisp/autorevert.el
@@ -391,6 +391,10 @@ disk changes.
When a buffer is reverted, a message is generated. This can be
suppressed by setting `auto-revert-verbose' to nil.
+Reverting can sometimes fail to preserve all the markers in the buffer.
+To avoid that, set `revert-buffer-insert-file-contents-function' to
+the slower function `revert-buffer-insert-file-contents-delicately'.
+
Use `global-auto-revert-mode' to automatically revert all buffers.
Use `auto-revert-tail-mode' if you know that the file will only grow
without being changed in the part that is already in the buffer."
diff --git a/lisp/battery.el b/lisp/battery.el
index 59f6987..bf864c2 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -161,9 +161,9 @@ The full `format-spec' formatting syntax is supported."
(defcustom battery-mode-line-format
(cond ((eq battery-status-function #'battery-linux-proc-acpi)
- "[%b%p%%,%d°C]")
+ "[%b%p%%,%d°C] ")
(battery-status-function
- "[%b%p%%]"))
+ "[%b%p%%] "))
"Control string formatting the string to display in the mode line.
Ordinary characters in the control string are printed as-is, while
conversion specifications introduced by a `%' character in the control
diff --git a/lisp/bindings.el b/lisp/bindings.el
index 06ba5d0..4b194c0 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -580,7 +580,7 @@ Major modes that edit things other than ordinary files may
change this
(put 'mode-line-buffer-identification 'risky-local-variable t)
(defvar mode-line-misc-info
- '((global-mode-string ("" global-mode-string " ")))
+ '((global-mode-string ("" global-mode-string)))
"Mode line construct for miscellaneous information.
By default, this shows the information specified by `global-mode-string'.")
(put 'mode-line-misc-info 'risky-local-variable t)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 52b96fd..ff9b8ab 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -561,10 +561,14 @@ old one."
(set-text-properties 0 (length stripped-name) nil stripped-name)
(if (and (not no-overwrite)
(bookmark-get-bookmark stripped-name 'noerror))
- ;; already existing bookmark under that name and
- ;; no prefix arg means just overwrite old bookmark
- ;; Use the new (NAME . ALIST) format.
- (setcdr (bookmark-get-bookmark stripped-name) alist)
+ ;; Already existing bookmark under that name and
+ ;; no prefix arg means just overwrite old bookmark.
+ (let ((bm (bookmark-get-bookmark stripped-name)))
+ ;; First clean up if previously location was fontified.
+ (when bookmark-fontify
+ (bookmark--unfontify bm))
+ ;; Modify using the new (NAME . ALIST) format.
+ (setcdr bm alist))
;; otherwise just cons it onto the front (either the bookmark
;; doesn't exist already, or there is no prefix arg. In either
diff --git a/lisp/button.el b/lisp/button.el
index 69d7054..74dfb5d 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -61,6 +61,7 @@
;; might get converted to ^M when building loaddefs.el
(define-key map [(control ?m)] 'push-button)
(define-key map [mouse-2] 'push-button)
+ (define-key map [follow-link] 'mouse-face)
;; FIXME: You'd think that for keymaps coming from text-properties on the
;; mode-line or header-line, the `mode-line' or `header-line' prefix
;; shouldn't be necessary!
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index 639bae7..1789f16 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -40,12 +40,13 @@
(defconst calendar-french-month-name-array
["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
- "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
+ "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"
+ "jour complémentaire"]
"Array of month names in the French calendar.")
(defconst calendar-french-day-name-array
["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
- "Octidi" "Nonidi" "Decadi"]
+ "Octidi" "Nonidi" "Décadi"]
"Array of day names in the French calendar.")
(define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array
@@ -56,6 +57,144 @@
"de la Révolution"]
"Array of special day names in the French calendar.")
+(defconst calendar-french-feasts-array
+ [;; Vendémiaire
+ "du Raisin" "du Safran" "de la Châtaigne"
+ "de la Colchique" "du Cheval" "de la Balsamine"
+ "de la Carotte" "de l'Amarante" "du Panais"
+ "de la Cuve" "de la Pomme de terre" "de l'Immortelle"
+ "du Potiron" "du Réséda" "de l'Âne"
+ "de la Belle de nuit" "de la Citrouille" "du Sarrasin"
+ "du Tournesol" "du Pressoir" "du Chanvre"
+ "de la Pêche" "du Navet" "de l'Amaryllis"
+ "du Bœuf" "de l'Aubergine" "du Piment"
+ "de la Tomate" "de l'Orge" "du Tonneau"
+ ;; Brumaire
+ "de la Pomme" "du Céleri" "de la Poire"
+ "de la Betterave" "de l'Oie" "de l'Héliotrope"
+ "de la Figue" "de la Scorsonère" "de l'Alisier"
+ "de la Charrue" "du Salsifis" "de la Macre"
+ "du Topinambour" "de l'Endive" "du Dindon"
+ "du Chervis" "du Cresson" "de la Dentelaire"
+ "de la Grenade" "de la Herse" "de la Bacchante"
+ "de l'Azerole" "de la Garance" "de l'Orange"
+ "du Faisan" "de la Pistache" "du Macjon"
+ "du Coing" "du Cormier" "du Rouleau"
+ ;; Frimaire
+ "de la Raiponce" "du Turneps" "de la Chicorée"
+ "de la Nèfle" "du Cochon" "de la Mâche"
+ "du Chou-fleur" "du Miel" "du Genièvre"
+ "de la Pioche" "de la Cire" "du Raifort"
+ "du Cèdre" "du Sapin" "du Chevreuil"
+ "de l'Ajonc" "du Cyprès" "du Lierre"
+ "de la Sabine" "du Hoyau" "de l'Érable-sucre"
+ "de la Bruyère" "du Roseau" "de l'Oseille"
+ "du Grillon" "du Pignon" "du Liège"
+ "de la Truffe" "de l'Olive" "de la Pelle"
+ ;; Nivôse
+ "de la Tourbe" "de la Houille" "du Bitume"
+ "du Soufre" "du Chien" "de la Lave"
+ "de la Terre végétale" "du Fumier" "du Salpêtre"
+ "du Fléau" "du Granit" "de l'Argile"
+ "de l'Ardoise" "du Grès" "du Lapin"
+ "du Silex" "de la Marne" "de la Pierre à chaux"
+ "du Marbre" "du Van" "de la Pierre à plâtre"
+ "du Sel" "du Fer" "du Cuivre"
+ "du Chat" "de l'Étain" "du Plomb"
+ "du Zinc" "du Mercure" "du Crible"
+ ;; Pluviôse
+ "de la Lauréole" "de la Mousse" "du Fragon"
+ "du Perce-neige" "du Taureau" "du Laurier-thym"
+ "de l'Amadouvier" "du Mézéréon" "du Peuplier"
+ "de la Cognée" "de l'Ellébore" "du Brocoli"
+ "du Laurier" "de l'Avelinier" "de la Vache"
+ "du Buis" "du Lichen" "de l'If"
+ "de la Pulmonaire" "de la Serpette" "du Thlaspi"
+ "du Thymelé" "du Chiendent" "de la Traînasse"
+ "du Lièvre" "de la Guède" "du Noisetier"
+ "du Cyclamen" "de la Chélidoine" "du Traîneau"
+ ;; Ventôse
+ "du Tussilage" "du Cornouiller" "du Violier"
+ "du Troène" "du Bouc" "de l'Asaret"
+ "de l'Alaterne" "de la Violette" "du Marsault"
+ "de la Bêche" "du Narcisse" "de l'Orme"
+ "de la Fumeterre" "du Vélar" "de la Chèvre"
+ "de l'Épinard" "du Doronic" "du Mouron"
+ "du Cerfeuil" "du Cordeau" "de la Mandragore"
+ "du Persil" "du Cochléaria" "de la Pâquerette"
+ "du Thon" "du Pissenlit" "de la Sylvie"
+ "du Capillaire" "du Frêne" "du Plantoir"
+ ;; Germinal
+ "de la Primevère" "du Platane" "de l'Asperge"
+ "de la Tulipe" "de la Poule" "de la Blette"
+ "du Bouleau" "de la Jonquille" "de l'Aulne"
+ "du Couvoir" "de la Pervenche" "du Charme"
+ "de la Morille" "du Hêtre" "de l'Abeille"
+ "de la Laitue" "du Mélèze" "de la Ciguë"
+ "du Radis" "de la Ruche" "du Gainier"
+ "de la Romaine" "du Marronnier" "de la Roquette"
+ "du Pigeon" "du Lilas" "de l'Anémone"
+ "de la Pensée" "de la Myrtille" "du Greffoir"
+ ;; Floréal
+ "de la Rose" "du Chêne" "de la Fougère"
+ "de l'Aubépine" "du Rossignol" "de l'Ancolie"
+ "du Muguet" "du Champignon" "de la Jacinthe"
+ "du Rateau" "de la Rhubarbe" "du Sainfoin"
+ "du Bâton-d'or" "du Chamérisier" "du Ver à soie"
+ "de la Consoude" "de la Pimprenelle" "de la Corbeille-d'or"
+ "de l'Arroche" "du Sarcloir" "du Statice"
+ "de la Fritillaire" "de la Bourrache" "de la Valériane"
+ "de la Carpe" "du Fusain" "de la Civette"
+ "de la Buglosse" "du Sénevé" "de la Houlette"
+ ;; Prairial
+ "de la Luzerne" "de l'Hémérocalle" "du Trèfle"
+ "de l'Angélique" "du Canard" "de la Mélisse"
+ "du Fromental" "du Martagon" "du Serpolet"
+ "de la Faux" "de la Fraise" "de la Bétoine"
+ "du Pois" "de l'Acacia" "de la Caille"
+ "de l'Œillet" "du Sureau" "du Pavot"
+ "du Tilleul" "de la Fourche" "du Barbeau"
+ "de la Camomille" "du Chèvrefeuille" "du Caille-lait"
+ "de la Tanche" "du Jasmin" "de la Verveine"
+ "du Thym" "de la Pivoine" "du Chariot"
+ ;; Messidor
+ "du Seigle" "de l'Avoine" "de l'Oignon"
+ "de la Véronique" "du Mulet" "du Romarin"
+ "du Concombre" "de l'Échalotte" "de l'Absinthe"
+ "de la Faucille" "de la Coriandre" "de l'Artichaut"
+ "de la Giroflée" "de la Lavande" "du Chamois"
+ "du Tabac" "de la Groseille" "de la Gesse"
+ "de la Cerise" "du Parc" "de la Menthe"
+ "du Cumin" "du Haricot" "de l'Orcanète"
+ "de la Pintade" "de la Sauge" "de l'Ail"
+ "de la Vesce" "du Blé" "de la Chalémie"
+ ;; Thermidor
+ "de l'Épautre" "du Bouillon-blanc" "du Melon"
+ "de l'Ivraie" "du Bélier" "de la Prèle"
+ "de l'Armoise" "du Carthame" "de la Mûre"
+ "de l'Arrosoir" "du Panis" "du Salicor"
+ "de l'Abricot" "du Basilic" "de la Brebis"
+ "de la Guimauve" "du Lin" "de l'Amande"
+ "de la Gentiane" "de l'Écluse" "de la Carline"
+ "du Câprier" "de la Lentille" "de l'Aunée"
+ "de la Loutre" "de la Myrte" "du Colza"
+ "du Lupin" "du Coton" "du Moulin"
+ ;; Fructidor
+ "de la Prune" "du Millet" "du Lycoperdon"
+ "de l'Escourgeon" "du Saumon" "de la Tubéreuse"
+ "du Sucrion" "de l'Apocyn" "de la Réglisse"
+ "de l'Échelle" "de la Pastèque" "du Fenouil"
+ "de l'Épine-vinette" "de la Noix" "de la Truite"
+ "du Citron" "de la Cardère" "du Nerprun"
+ "du Tagette" "de la Hotte" "de l'Églantier"
+ "de la Noisette" "du Houblon" "du Sorgho"
+ "de l'Écrevisse" "de la Bagarade" "de la Verge-d'or"
+ "du Maïs" "du Marron" "du Panier"
+ ;; jour complémentaire
+ "de la Vertu" "du Génie" "du Travail"
+ "de la Raison" "des Récompenses" "de la Révolution"]
+ "Array of day feasts in the French calendar.")
+
(defun calendar-french-accents-p ()
(declare (obsolete nil "28.1"))
t)
@@ -75,6 +214,16 @@
(declare (obsolete "use the variable of the same name instead" "28.1"))
calendar-french-special-days-array)
+(defun calendar-french-trim-feast (feast)
+ "Remove the article from the FEAST.
+E.g. \"du Raisin\" -> \"Raisin\" or \"de la Vertu\" -> \"Vertu\"."
+ (cond
+ ((equal (substring feast 0 3) "du ") (substring feast 3))
+ ((equal (substring feast 0 6) "de la ") (substring feast 6))
+ ((equal (substring feast 0 5) "de l'") (substring feast 5))
+ ((equal (substring feast 0 4) "des ") (substring feast 4))
+ (t feast)))
+
(defun calendar-french-leap-year-p (year)
"True if YEAR is a leap year on the French Revolutionary calendar.
For Gregorian years 1793 to 1805, the years of actual operation of the
@@ -162,14 +311,13 @@ Defaults to today's date if DATE is not given."
(d (calendar-extract-day french-date)))
(cond
((< y 1) "")
- ((= m 13) (format "Jour %s de l'Année %d de la Révolution"
- (aref calendar-french-special-days-array (1- d))
- y))
(t (format
- "%d %s an %d de la Révolution"
+ "%s %d %s an %d de la Révolution, jour %s"
+ (aref calendar-french-day-name-array (% (1- d) 10))
d
(aref calendar-french-month-name-array (1- m))
- y)))))
+ y
+ (aref calendar-french-feasts-array (+ -31 (* 30 m) d)))))))
;;;###cal-autoload
(defun calendar-french-print-date ()
@@ -186,7 +334,7 @@ Defaults to today's date if DATE is not given."
Echo French Revolutionary date unless NOECHO is non-nil."
(interactive
(let* ((months calendar-french-month-name-array)
- (special-days calendar-french-special-days-array)
+ (feasts calendar-french-feasts-array)
(year (progn
(calendar-read-sexp
"Année de la Révolution (>0)"
@@ -199,29 +347,31 @@ Echo French Revolutionary date unless NOECHO is non-nil."
(mapcar 'list
(append months
(if (calendar-french-leap-year-p year)
- (mapcar
- (lambda (x) (concat "Jour " x))
- calendar-french-special-days-array)
+ (mapcar #'calendar-french-trim-feast feasts)
(reverse
(cdr ; we don't want rev. day in a non-leap yr
(reverse
- (mapcar
- (lambda (x)
- (concat "Jour " x))
- special-days))))))))
+ (mapcar #'calendar-french-trim-feast
+ feasts))))))))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
- "Mois ou Sansculottide: "
+ "Mois ou \"jour complémentaire\" ou fête: "
month-list
nil t)
(calendar-make-alist month-list 1 'car) t)))
- (day (if (> month 12)
- (- month 12)
+ (last-day (calendar-french-last-day-of-month (min month 13) year))
+ (day (if (> month 13)
+ (- month 13)
(calendar-read-sexp
- "Jour (1-30)"
- (lambda (x) (and (<= 1 x) (<= x 30))))))
- (month (if (> month 12) 13 month)))
+ (format "Jour (1-%d): " last-day)
+ (lambda (x) (<= 1 x last-day)))))
+ ;; All days in Vendémiaire and numbered 1 to 365 e.g., "Pomme"
+ ;; gives 31 Vendémiaire automatically normalized to 1 Brumaire
+ ;; "Céleri" gives 32 Vnd normalized to 2 Bru, "Raiponce" gives
+ ;; 61 Vnd normalized to 1 Frimaire, etc until "Récompences" which
+ ;; gives 365 Vnd normalized to 5 jour complémentaire.
+ (month (if (> month 13) 1 month)))
(list (list month day year))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-french-to-absolute date)))
diff --git a/lisp/comint.el b/lisp/comint.el
index 9e40661..7801261 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -2471,10 +2471,13 @@ This function could be in the list
`comint-output-filter-functions'."
;; Random input hackage
-(defun comint-delete-output ()
+(defun comint-delete-output (&optional kill)
"Delete all output from interpreter since last input.
-Does not delete the prompt."
- (interactive)
+If KILL (interactively, the prefix), save the killed text in the
+kill ring.
+
+This command does not delete the prompt."
+ (interactive "P")
(let ((proc (get-buffer-process (current-buffer)))
(replacement nil)
(inhibit-read-only t))
@@ -2482,6 +2485,8 @@ Does not delete the prompt."
(let ((pmark (progn (goto-char (process-mark proc))
(forward-line 0)
(point-marker))))
+ (when kill
+ (copy-region-as-kill comint-last-input-end pmark))
(delete-region comint-last-input-end pmark)
(goto-char (process-mark proc))
(setq replacement (concat "*** output flushed ***\n"
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 3c2625a..7df70d7 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -306,8 +306,8 @@ Leaving \"Default\" unchecked is equivalent with specifying
a default of
(use-short-answers menu boolean "28.1")
(focus-follows-mouse
frames (choice
- (const :tag "Off (nil)" :value nil)
- (const :tag "On (t)" :value t)
+ (const :tag "Off" :value nil)
+ (const :tag "On" :value t)
(const :tag "Auto-raise" :value auto-raise)) "26.1")
;; fontset.c
;; FIXME nil is the initial value, fontset.el setqs it.
@@ -603,27 +603,29 @@ since it could result in memory overflow and make Emacs
crash."
(next-screen-context-lines windows integer)
(scroll-preserve-screen-position
windows (choice
- (const :tag "Off (nil)" :value nil)
- (const :tag "Full screen (t)" :value t)
- (other :tag "Always" 1)) "22.1")
+ (const :tag "Off" :value nil)
+ (const :tag "Full screen" :value t)
+ (other :tag "Always" 1))
+ "22.1")
(recenter-redisplay
windows (choice
- (const :tag "Never (nil)" :value nil)
+ (const :tag "Never" :value nil)
(const :tag "Only on ttys" :value tty)
- (other :tag "Always" t)) "23.1")
+ (other :tag "Always" t))
+ "23.1")
(window-combination-resize windows boolean "24.1")
(window-combination-limit
windows (choice
- (const :tag "Never (nil)" :value nil)
- (const :tag "If requested via buffer display alist
(window-size)"
+ (const :tag "Never" :value nil)
+ (const :tag "If requested via buffer display alist"
:value window-size)
- (const :tag "With Temp Buffer Resize mode
(temp-buffer-resize)"
+ (const :tag "With Temp Buffer Resize mode"
:value temp-buffer-resize)
- (const :tag "For temporary buffers (temp-buffer)"
+ (const :tag "For temporary buffers"
:value temp-buffer)
- (const :tag "For buffer display (display-buffer)"
+ (const :tag "For buffer display"
:value display-buffer)
- (other :tag "Always (t)" :value t))
+ (other :tag "Always" :value t))
"26.1")
(fast-but-imprecise-scrolling scrolling boolean "25.1")
(window-resize-pixelwise windows boolean "24.4")
@@ -631,6 +633,12 @@ since it could result in memory overflow and make Emacs
crash."
;; The whitespace group is for whitespace.el.
(show-trailing-whitespace editing-basics boolean nil
:safe booleanp)
+ (mode-line-compact
+ mode-line
+ (choice (const :tag "Never" :value nil)
+ (const :tag "Only if wider than window" :value long)
+ (const :tag "Always" :value t))
+ "28.1")
(scroll-step windows integer)
(scroll-conservatively windows integer)
(scroll-margin windows integer)
@@ -668,7 +676,7 @@ since it could result in memory overflow and make Emacs
crash."
(underline-minimum-offset display integer "23.1")
(mouse-autoselect-window
display (choice
- (const :tag "Off (nil)" :value nil)
+ (const :tag "Off" :value nil)
(const :tag "Immediate" :value t)
(number :tag "Delay by secs" :value 0.5)) "22.1")
(tool-bar-style
@@ -713,15 +721,15 @@ since it could result in memory overflow and make Emacs
crash."
(hourglass-delay cursor number)
(resize-mini-windows
windows (choice
- (const :tag "Off (nil)" :value nil)
- (const :tag "Fit (t)" :value t)
+ (const :tag "Off" :value nil)
+ (const :tag "Fit" :value t)
(const :tag "Grow only" :value grow-only))
"25.1")
(display-raw-bytes-as-hex display boolean "26.1")
(display-line-numbers
display-line-numbers
(choice
- (const :tag "Off (nil)" :value nil)
+ (const :tag "Off" :value nil)
(const :tag "Absolute line numbers"
:value t)
(const :tag "Relative line numbers"
diff --git a/lisp/custom.el b/lisp/custom.el
index 1db3f4f..f392bd8 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -926,7 +926,7 @@ See `custom-known-themes' for a list of known themes."
;; the value to a fake theme, `changed'. If the theme is
;; later disabled, we use this to bring back the old value.
;;
- ;; For faces, we just use `face-new-frame-defaults' to
+ ;; For faces, we just use `face--new-frame-defaults' to
;; recompute when the theme is disabled.
(when (and (eq prop 'theme-value)
(boundp symbol))
diff --git a/lisp/desktop.el b/lisp/desktop.el
index b9467c8..3b25713 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -706,8 +706,9 @@ if different)."
"\\)\\'")))
(dolist (buffer (buffer-list))
(let ((bufname (buffer-name buffer)))
- (unless (or (eq (aref bufname 0) ?\s) ;; Don't kill internal buffers
- (string-match-p preserve-regexp bufname))
+ (unless (or (null bufname)
+ (eq (aref bufname 0) ?\s) ;; Don't kill internal buffers
+ (string-match-p preserve-regexp bufname))
(kill-buffer buffer)))))
(delete-other-windows)
(when (and desktop-restore-frames
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index 8d99d1a..a7bfae7 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -972,38 +972,26 @@ REGEXP is matched case-sensitively."
(defun dired-guess-default (files)
"Return a shell command, or a list of commands, appropriate for FILES.
See `dired-guess-shell-alist-user'."
-
(let* ((case-fold-search dired-guess-shell-case-fold-search)
- ;; Prepend the user's alist to the default alist.
- (alist (append dired-guess-shell-alist-user
- dired-guess-shell-alist-default))
- (file (car files))
- (flist (cdr files))
- elt regexp cmds)
-
- ;; Find the first match in the alist for first file in FILES.
- (while alist
- (setq elt (car alist)
- regexp (car elt)
- alist (cdr alist))
- (if (string-match-p regexp file)
- (setq cmds (cdr elt)
- alist nil)))
-
- ;; If more than one file, see if all of FILES match regular expression.
- (while (and flist
- (string-match-p regexp (car flist)))
- (setq flist (cdr flist)))
-
- ;; If flist is still non-nil, then do not guess since this means that not
- ;; all the files in FILES were matched by the regexp.
- (setq cmds (and (not flist) cmds))
-
- ;; Return commands or nil if flist is still non-nil.
- ;; Evaluate the commands in order that any logical testing will be done.
- (if (cdr cmds)
- (delete-dups (mapcar (lambda (cmd) (eval cmd `((file . ,file)))) cmds))
- (eval (car cmds) `((file . ,file)))))) ; single command
+ (programs
+ (delete-dups
+ (mapcar
+ (lambda (command)
+ (eval command `((file . ,(car files)))))
+ (seq-reduce
+ #'append
+ (mapcar #'cdr
+ (seq-filter (lambda (elem)
+ (seq-every-p
+ (lambda (file)
+ (string-match-p (car elem) file))
+ files))
+ (append dired-guess-shell-alist-user
+ dired-guess-shell-alist-default)))
+ nil)))))
+ (if (length= programs 1)
+ (car programs)
+ programs)))
(defun dired-guess-shell-command (prompt files)
"Ask user with PROMPT for a shell command, guessing a default from FILES."
diff --git a/lisp/dnd.el b/lisp/dnd.el
index 7319a27..e641b28 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -180,6 +180,7 @@ An alternative for systems that do not support unc file
names is
(if dnd-open-file-other-window
(find-file-other-window f)
(find-file f))
+ (file-name-history--add f)
'private)
(error "Can not read %s" uri))))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 2fff0bd..ad9f827 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -274,6 +274,7 @@ Earlier variables shadow later ones with the same name.")
((pred byte-code-function-p)
;; (message "Inlining byte-code for %S!" name)
;; The byte-code will be really inlined in byte-compile-unfold-bcf.
+ (byte-compile--check-arity-bytecode form fn)
`(,fn ,@(cdr form)))
((or `(lambda . ,_) `(closure . ,_))
;; While byte-compile-unfold-bcf can inline dynbind byte-code into
@@ -300,7 +301,9 @@ Earlier variables shadow later ones with the same name.")
;; surrounded the `defsubst'.
(byte-compile-warnings nil))
(byte-compile name))
- `(,(symbol-function name) ,@(cdr form))))
+ (let ((bc (symbol-function name)))
+ (byte-compile--check-arity-bytecode form bc)
+ `(,bc ,@(cdr form)))))
(_ ;; Give up on inlining.
form))))
@@ -414,7 +417,7 @@ Same format as `byte-optimize--lexvars', with shared
structure and contents.")
form)))
(t form)))
(`(quote . ,v)
- (if (cdr v)
+ (if (or (not v) (cdr v))
(byte-compile-warn "malformed quote form: `%s'"
(prin1-to-string form)))
;; Map (quote nil) to nil to simplify optimizer logic.
@@ -667,8 +670,7 @@ Same format as `byte-optimize--lexvars', with shared
structure and contents.")
(byte-compile-log " %s\t==>\t%s" old new)
(setq form new)
(not (eq new old))))))))
- ;; Normalise (quote nil) to nil, for a single representation of constant nil.
- (and (not (equal form '(quote nil))) form))
+ form)
(defun byte-optimize-let-form (head form for-effect)
;; Recursively enter the optimizer for the bindings and body
@@ -969,6 +971,11 @@ See Info node `(elisp) Integer Basics'."
;; Arity errors reported elsewhere.
form)))
+(defun byte-optimize-eq (form)
+ (pcase (cdr form)
+ ((or `(,x nil) `(nil ,x)) `(not ,x))
+ (_ (byte-optimize-binary-predicate form))))
+
(defun byte-optimize-member (form)
;; Replace `member' or `memql' with `memq' if the first arg is a symbol,
;; or the second arg is a list of symbols. Same with fixnums.
@@ -1056,7 +1063,7 @@ See Info node `(elisp) Integer Basics'."
(put 'min 'byte-optimizer #'byte-optimize-min-max)
(put '= 'byte-optimizer #'byte-optimize-binary-predicate)
-(put 'eq 'byte-optimizer #'byte-optimize-binary-predicate)
+(put 'eq 'byte-optimizer #'byte-optimize-eq)
(put 'eql 'byte-optimizer #'byte-optimize-equal)
(put 'equal 'byte-optimizer #'byte-optimize-equal)
(put 'string= 'byte-optimizer #'byte-optimize-binary-predicate)
@@ -1072,7 +1079,7 @@ See Info node `(elisp) Integer Basics'."
(defun byte-optimize-quote (form)
(if (or (consp (nth 1 form))
(and (symbolp (nth 1 form))
- (not (macroexp--const-symbol-p form))))
+ (not (macroexp--const-symbol-p (nth 1 form)))))
form
(nth 1 form)))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 6970c8a..f615006 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1477,6 +1477,30 @@ when printing the error message."
(push (list f byte-compile-last-position nargs)
byte-compile-unresolved-functions)))))
+(defun byte-compile-emit-callargs-warn (name actual-args min-args max-args)
+ (byte-compile-set-symbol-position name)
+ (byte-compile-warn
+ "%s called with %d argument%s, but %s %s"
+ name actual-args
+ (if (= 1 actual-args) "" "s")
+ (if (< actual-args min-args)
+ "requires"
+ "accepts only")
+ (byte-compile-arglist-signature-string (cons min-args max-args))))
+
+(defun byte-compile--check-arity-bytecode (form bytecode)
+ "Check that the call in FORM matches that allowed by BYTECODE."
+ (when (and (byte-code-function-p bytecode)
+ (byte-compile-warning-enabled-p 'callargs))
+ (let* ((actual-args (length (cdr form)))
+ (arity (func-arity bytecode))
+ (min-args (car arity))
+ (max-args (and (numberp (cdr arity)) (cdr arity))))
+ (when (or (< actual-args min-args)
+ (and max-args (> actual-args max-args)))
+ (byte-compile-emit-callargs-warn
+ (car form) actual-args min-args max-args)))))
+
;; Warn if the form is calling a function with the wrong number of arguments.
(defun byte-compile-callargs-warn (form)
(let* ((def (or (byte-compile-fdefinition (car form) nil)
@@ -1491,16 +1515,9 @@ when printing the error message."
(setcdr sig nil))
(if sig
(when (or (< ncall (car sig))
- (and (cdr sig) (> ncall (cdr sig))))
- (byte-compile-set-symbol-position (car form))
- (byte-compile-warn
- "%s called with %d argument%s, but %s %s"
- (car form) ncall
- (if (= 1 ncall) "" "s")
- (if (< ncall (car sig))
- "requires"
- "accepts only")
- (byte-compile-arglist-signature-string sig))))
+ (and (cdr sig) (> ncall (cdr sig))))
+ (byte-compile-emit-callargs-warn
+ (car form) ncall (car sig) (cdr sig))))
(byte-compile-format-warn form)
(byte-compile-function-warn (car form) (length (cdr form)) def)))
@@ -4340,6 +4357,16 @@ Return (TAIL VAR TEST CASES), where:
(push value keys)
(push (cons (list value) (or body '(t))) cases))
t))))
+ ;; Treat (not X) as (eq X nil).
+ (`((,(or 'not 'null) ,(and var (pred symbolp))) . ,body)
+ (and (or (eq var switch-var) (not switch-var))
+ (progn
+ (setq switch-var var)
+ (setq switch-test 'eq)
+ (unless (memq nil keys)
+ (push nil keys)
+ (push (cons (list nil) (or body '(t))) cases))
+ t)))
(`((,(and fn (or 'memq 'memql 'member)) ,var ,expr) . ,body)
(and (symbolp var)
(or (eq var switch-var) (not switch-var))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index f1579cd..ea0b098 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -259,8 +259,7 @@ Returns a form where all lambdas don't have any free
variables."
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0))
;; As a special exception, ignore "ignore".
- (eq var 'ignored)
- (not (byte-compile-warning-enabled-p 'unbound var)))
+ (eq var 'ignored))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
(format "Unused lexical %s `%S'%s"
varkind var
@@ -287,7 +286,7 @@ of converted forms."
(let (and (pred stringp) msg)
(cconv--warn-unused-msg arg "argument")))
(if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed?
- (push (lambda (body) (macroexp--warn-wrap msg body)) wrappers))
+ (push (lambda (body) (macroexp--warn-wrap msg body 'lexical))
wrappers))
(_
(if (assq arg env) (push `(,arg . nil) env)))))
(setq funcbody (mapcar (lambda (form)
@@ -408,7 +407,7 @@ places where they originally did not directly appear."
`(ignore ,(cconv-convert value env extend)))
(msg (cconv--warn-unused-msg var "variable")))
(if (null msg) newval
- (macroexp--warn-wrap msg newval))))
+ (macroexp--warn-wrap msg newval 'lexical))))
;; Normal default case.
(_
@@ -507,7 +506,7 @@ places where they originally did not directly appear."
(newprotform (cconv-convert protected-form env extend)))
`(condition-case ,var
,(if msg
- (macroexp--warn-wrap msg newprotform)
+ (macroexp--warn-wrap msg newprotform 'lexical)
newprotform)
,@(mapcar
(lambda (handler)
@@ -599,14 +598,16 @@ FORM is the parent form that binds this var."
(`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_)
,_ ,_ ,_ ,_)
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
- ;; so as to give better position information.
+ ;; so as to give better position information and obey
+ ;; `byte-compile-warnings'.
(byte-compile-warn
"%s `%S' not left unused" varkind var))
((and (let (or 'let* 'let) (car form))
`((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
t nil ,_ ,_))
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
- ;; so as to give better position information.
+ ;; so as to give better position information and obey
+ ;; `byte-compile-warnings'.
(unless (not (intern-soft var))
(byte-compile-warn "Variable `%S' left uninitialized" var))))
(pcase vardata
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 7f7eb96..317a4c6 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -515,111 +515,6 @@ the process stops as soon as KEYS or VALUES run out.
If ALIST is non-nil, the new pairs are prepended to it."
(nconc (cl-mapcar 'cons keys values) alist))
-;;; Generalized variables.
-
-;; These used to be in cl-macs.el since all macros that use them (like setf)
-;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in
-;; core Elisp, they need to either be right here or be autoloaded via
-;; cl-loaddefs.el, which is more trouble than it is worth.
-
-;; Some more Emacs-related place types.
-(gv-define-simple-setter buffer-file-name set-visited-file-name t)
-(gv-define-setter buffer-modified-p (flag &optional buf)
- (macroexp-let2 nil buffer `(or ,buf (current-buffer))
- `(with-current-buffer ,buffer
- (set-buffer-modified-p ,flag))))
-(gv-define-simple-setter buffer-name rename-buffer t)
-(gv-define-setter buffer-string (store)
- `(insert (prog1 ,store (erase-buffer))))
-(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
-(gv-define-simple-setter current-buffer set-buffer)
-(gv-define-simple-setter current-column move-to-column t)
-(gv-define-simple-setter current-global-map use-global-map t)
-(gv-define-setter current-input-mode (store)
- `(progn (apply #'set-input-mode ,store) ,store))
-(gv-define-simple-setter current-local-map use-local-map t)
-(gv-define-simple-setter current-window-configuration
- set-window-configuration t)
-(gv-define-simple-setter default-file-modes set-default-file-modes t)
-(gv-define-simple-setter documentation-property put)
-(gv-define-setter face-background (x f &optional s)
- `(set-face-background ,f ,x ,s))
-(gv-define-setter face-background-pixmap (x f &optional s)
- `(set-face-background-pixmap ,f ,x ,s))
-(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s))
-(gv-define-setter face-foreground (x f &optional s)
- `(set-face-foreground ,f ,x ,s))
-(gv-define-setter face-underline-p (x f &optional s)
- `(set-face-underline ,f ,x ,s))
-(gv-define-simple-setter file-modes set-file-modes t)
-(gv-define-setter frame-height (x &optional frame)
- `(set-frame-height (or ,frame (selected-frame)) ,x))
-(gv-define-simple-setter frame-parameters modify-frame-parameters t)
-(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p)
-(gv-define-setter frame-width (x &optional frame)
- `(set-frame-width (or ,frame (selected-frame)) ,x))
-(gv-define-simple-setter getenv setenv t)
-(gv-define-simple-setter get-register set-register)
-(gv-define-simple-setter global-key-binding global-set-key)
-(gv-define-simple-setter local-key-binding local-set-key)
-(gv-define-simple-setter mark set-mark t)
-(gv-define-simple-setter mark-marker set-mark t)
-(gv-define-simple-setter marker-position set-marker t)
-(gv-define-setter mouse-position (store scr)
- `(set-mouse-position ,scr (car ,store) (cadr ,store)
- (cddr ,store)))
-(gv-define-simple-setter point goto-char)
-(gv-define-simple-setter point-marker goto-char t)
-(gv-define-setter point-max (store)
- `(progn (narrow-to-region (point-min) ,store) ,store))
-(gv-define-setter point-min (store)
- `(progn (narrow-to-region ,store (point-max)) ,store))
-(gv-define-setter read-mouse-position (store scr)
- `(set-mouse-position ,scr (car ,store) (cdr ,store)))
-(gv-define-simple-setter screen-height set-screen-height t)
-(gv-define-simple-setter screen-width set-screen-width t)
-(gv-define-simple-setter selected-window select-window)
-(gv-define-simple-setter selected-screen select-screen)
-(gv-define-simple-setter selected-frame select-frame)
-(gv-define-simple-setter standard-case-table set-standard-case-table)
-(gv-define-simple-setter syntax-table set-syntax-table)
-(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t)
-(gv-define-setter window-height (store)
- `(progn (enlarge-window (- ,store (window-height))) ,store))
-(gv-define-setter window-width (store)
- `(progn (enlarge-window (- ,store (window-width)) t) ,store))
-(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t)
-
-;; More complex setf-methods.
-
-;; This is a hack that allows (setf (eq a 7) B) to mean either
-;; (setq a 7) or (setq a nil) depending on whether B is nil or not.
-;; This is useful when you have control over the PLACE but not over
-;; the VALUE, as is the case in define-minor-mode's :variable.
-;; It turned out that :variable needed more flexibility anyway, so
-;; this doesn't seem too useful now.
-(gv-define-expander eq
- (lambda (do place val)
- (gv-letplace (getter setter) place
- (macroexp-let2 nil val val
- (funcall do `(eq ,getter ,val)
- (lambda (v)
- `(cond
- (,v ,(funcall setter val))
- ((eq ,getter ,val) ,(funcall setter `(not ,val))))))))))
-
-(gv-define-expander substring
- (lambda (do place from &optional to)
- (gv-letplace (getter setter) place
- (macroexp-let2* nil ((start from) (end to))
- (funcall do `(substring ,getter ,start ,end)
- (lambda (v)
- (macroexp-let2 nil v v
- `(progn
- ,(funcall setter `(cl--set-substring
- ,getter ,start ,end ,v))
- ,v))))))))
-
;;; Miscellaneous.
(provide 'cl-lib)
diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el
index 6ba2e78..d2e4891 100644
--- a/lisp/emacs-lisp/copyright.el
+++ b/lisp/emacs-lisp/copyright.el
@@ -144,11 +144,16 @@ This function sets the match-data that
`copyright-update-year' uses."
(with-demoted-errors "Can't update copyright: %s"
;; (1) Need the extra \\( \\) around copyright-regexp because we
;; goto (match-end 1) below. See note (2) below.
- (copyright-re-search (concat "\\(" copyright-regexp
- "\\)\\([ \t]*\n\\)?.*\\(?:"
- copyright-names-regexp "\\)")
- (copyright-limit)
- t)))
+ (let ((regexp (concat "\\(" copyright-regexp
+ "\\)\\([ \t]*\n\\)?.*\\(?:"
+ copyright-names-regexp "\\)")))
+ (when (copyright-re-search regexp (copyright-limit) t)
+ ;; We may accidentally have landed in the middle of a
+ ;; copyright line, so re-perform the search without the
+ ;; search. (Otherwise we may be inserting the new year in the
+ ;; middle of the list of years.)
+ (goto-char (match-beginning 0))
+ (copyright-re-search regexp nil t)))))
(defun copyright-find-end ()
"Possibly adjust the search performed by `copyright-find-copyright'.
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 8f1e38b..b11ed33 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -742,7 +742,8 @@ Argument FN is the function calling this verifier."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
- (format-message "Unknown slot `%S'" name) exp 'compile-only))
+ (format-message "Unknown slot `%S'" name)
+ exp nil 'compile-only))
(_ exp))))
(gv-setter eieio-oset))
(cl-check-type slot symbol)
@@ -777,12 +778,13 @@ Fills in CLASS's SLOT with its default value."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
- (format-message "Unknown slot `%S'" name) exp 'compile-only))
+ (format-message "Unknown slot `%S'" name)
+ exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
(format-message "Slot `%S' is not class-allocated" name)
- exp 'compile-only))
+ exp nil 'compile-only))
(_ exp)))))
(cl-check-type class (or eieio-object class))
(cl-check-type slot symbol)
@@ -838,12 +840,13 @@ Fills in the default value in CLASS' in SLOT with VALUE."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
- (format-message "Unknown slot `%S'" name) exp 'compile-only))
+ (format-message "Unknown slot `%S'" name)
+ exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
(format-message "Slot `%S' is not class-allocated" name)
- exp 'compile-only))
+ exp nil 'compile-only))
(_ exp)))))
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index b31ea42a..c16d8e1 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -241,7 +241,8 @@ This method is obsolete."
))
`(progn
- ,@(mapcar (lambda (w) (macroexp-warn-and-return w `(progn ',w)
'compile-only))
+ ,@(mapcar (lambda (w)
+ (macroexp-warn-and-return w `(progn ',w) nil 'compile-only))
warnings)
;; This test must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only
@@ -742,7 +743,7 @@ Called from the constructor routine."
(cl-defmethod initialize-instance ((this eieio-default-superclass)
&optional args)
- "Construct the new object THIS based on SLOTS.
+ "Construct the new object THIS based on ARGS.
ARGS is a property list where odd numbered elements are tags, and
even numbered elements are the values to store in the tagged slot.
If you overload the `initialize-instance', there you will need to
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index f08f7ac..d6272a5 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -614,5 +614,105 @@ REF must have been previously obtained with `gv-ref'."
;; (,(nth 1 vars) (v) (funcall ',setter v)))
;; ,@body)))
+;;; Generalized variables.
+
+;; Some Emacs-related place types.
+(gv-define-simple-setter buffer-file-name set-visited-file-name t)
+(gv-define-setter buffer-modified-p (flag &optional buf)
+ (macroexp-let2 nil buffer `(or ,buf (current-buffer))
+ `(with-current-buffer ,buffer
+ (set-buffer-modified-p ,flag))))
+(gv-define-simple-setter buffer-name rename-buffer t)
+(gv-define-setter buffer-string (store)
+ `(insert (prog1 ,store (erase-buffer))))
+(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
+(gv-define-simple-setter current-buffer set-buffer)
+(gv-define-simple-setter current-column move-to-column t)
+(gv-define-simple-setter current-global-map use-global-map t)
+(gv-define-setter current-input-mode (store)
+ `(progn (apply #'set-input-mode ,store) ,store))
+(gv-define-simple-setter current-local-map use-local-map t)
+(gv-define-simple-setter current-window-configuration
+ set-window-configuration t)
+(gv-define-simple-setter default-file-modes set-default-file-modes t)
+(gv-define-simple-setter documentation-property put)
+(gv-define-setter face-background (x f &optional s)
+ `(set-face-background ,f ,x ,s))
+(gv-define-setter face-background-pixmap (x f &optional s)
+ `(set-face-background-pixmap ,f ,x ,s))
+(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s))
+(gv-define-setter face-foreground (x f &optional s)
+ `(set-face-foreground ,f ,x ,s))
+(gv-define-setter face-underline-p (x f &optional s)
+ `(set-face-underline ,f ,x ,s))
+(gv-define-simple-setter file-modes set-file-modes t)
+(gv-define-setter frame-height (x &optional frame)
+ `(set-frame-height (or ,frame (selected-frame)) ,x))
+(gv-define-simple-setter frame-parameters modify-frame-parameters t)
+(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p)
+(gv-define-setter frame-width (x &optional frame)
+ `(set-frame-width (or ,frame (selected-frame)) ,x))
+(gv-define-simple-setter getenv setenv t)
+(gv-define-simple-setter get-register set-register)
+(gv-define-simple-setter global-key-binding global-set-key)
+(gv-define-simple-setter local-key-binding local-set-key)
+(gv-define-simple-setter mark set-mark t)
+(gv-define-simple-setter mark-marker set-mark t)
+(gv-define-simple-setter marker-position set-marker t)
+(gv-define-setter mouse-position (store scr)
+ `(set-mouse-position ,scr (car ,store) (cadr ,store)
+ (cddr ,store)))
+(gv-define-simple-setter point goto-char)
+(gv-define-simple-setter point-marker goto-char t)
+(gv-define-setter point-max (store)
+ `(progn (narrow-to-region (point-min) ,store) ,store))
+(gv-define-setter point-min (store)
+ `(progn (narrow-to-region ,store (point-max)) ,store))
+(gv-define-setter read-mouse-position (store scr)
+ `(set-mouse-position ,scr (car ,store) (cdr ,store)))
+(gv-define-simple-setter screen-height set-screen-height t)
+(gv-define-simple-setter screen-width set-screen-width t)
+(gv-define-simple-setter selected-window select-window)
+(gv-define-simple-setter selected-screen select-screen)
+(gv-define-simple-setter selected-frame select-frame)
+(gv-define-simple-setter standard-case-table set-standard-case-table)
+(gv-define-simple-setter syntax-table set-syntax-table)
+(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t)
+(gv-define-setter window-height (store)
+ `(progn (enlarge-window (- ,store (window-height))) ,store))
+(gv-define-setter window-width (store)
+ `(progn (enlarge-window (- ,store (window-width)) t) ,store))
+(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t)
+
+;; More complex setf-methods.
+
+;; This is a hack that allows (setf (eq a 7) B) to mean either
+;; (setq a 7) or (setq a nil) depending on whether B is nil or not.
+;; This is useful when you have control over the PLACE but not over
+;; the VALUE, as is the case in define-minor-mode's :variable.
+;; It turned out that :variable needed more flexibility anyway, so
+;; this doesn't seem too useful now.
+(gv-define-expander eq
+ (lambda (do place val)
+ (gv-letplace (getter setter) place
+ (macroexp-let2 nil val val
+ (funcall do `(eq ,getter ,val)
+ (lambda (v)
+ `(cond
+ (,v ,(funcall setter val))
+ ((eq ,getter ,val) ,(funcall setter `(not ,val))))))))))
+
+(gv-define-expander substring
+ (lambda (do place from &optional to)
+ (gv-letplace (getter setter) place
+ (macroexp-let2* nil ((start from) (end to))
+ (funcall do `(substring ,getter ,start ,end)
+ (lambda (v)
+ (macroexp-let2 nil v v
+ `(progn
+ ,(funcall setter `(cl--set-substring
+ ,getter ,start ,end ,v))
+ ,v))))))))
+
(provide 'gv)
;;; gv.el ends here
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index f4bab9c..61c1ea4 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -135,15 +135,22 @@ Other uses risk returning non-nil value that point to the
wrong file."
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
-(defun macroexp--warn-wrap (msg form)
- (let ((when-compiled (lambda () (byte-compile-warn "%s" msg))))
+(defun macroexp--warn-wrap (msg form category)
+ (let ((when-compiled (lambda ()
+ (when (byte-compile-warning-enabled-p category)
+ (byte-compile-warn "%s" msg)))))
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
(define-obsolete-function-alias 'macroexp--warn-and-return
#'macroexp-warn-and-return "28.1")
-(defun macroexp-warn-and-return (msg form &optional compile-only)
+(defun macroexp-warn-and-return (msg form &optional category compile-only)
+ "Return code equivalent to FORM labeled with warning MSG.
+CATEGORY is the category of the warning, like the categories that
+can appear in `byte-compile-warnings'.
+COMPILE-ONLY non-nil means no warning should be emitted if the code
+is executed without being compiled first."
(cond
((null msg) form)
((macroexp-compiling-p)
@@ -153,7 +160,7 @@ Other uses risk returning non-nil value that point to the
wrong file."
;; macroexpand-all gets right back to macroexpanding `form'.
form
(puthash form form macroexp--warned)
- (macroexp--warn-wrap msg form)))
+ (macroexp--warn-wrap msg form category)))
(t
(unless compile-only
(message "%sWarning: %s"
@@ -205,9 +212,7 @@ Other uses risk returning non-nil value that point to the
wrong file."
(if (and (not (eq form new-form)) ;It was a macro call.
(car-safe form)
(symbolp (car form))
- (get (car form) 'byte-obsolete-info)
- (or (not (fboundp 'byte-compile-warning-enabled-p))
- (byte-compile-warning-enabled-p 'obsolete (car form))))
+ (get (car form) 'byte-obsolete-info))
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
(macroexp-warn-and-return
@@ -215,7 +220,7 @@ Other uses risk returning non-nil value that point to the
wrong file."
fun obsolete
(if (symbolp (symbol-function fun))
"alias" "macro"))
- new-form))
+ new-form 'obsolete))
new-form)))
(defun macroexp--unfold-lambda (form &optional name)
@@ -325,10 +330,8 @@ Assumes the caller has bound
`macroexpand-all-environment'."
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
- (and (or (not (fboundp 'byte-compile-warning-enabled-p))
- (byte-compile-warning-enabled-p t))
- (format "Empty %s body" fun))
- nil t))
+ (format "Empty %s body" fun)
+ nil nil 'compile-only))
(macroexp--all-forms body))
(cdr form))
form))
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 6bbd4c9..f1daa8d 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2195,8 +2195,24 @@ Downloads and installs required packages as needed."
((derived-mode-p 'tar-mode)
(package-tar-file-info))
(t
- (save-excursion
- (package-buffer-info)))))
+ ;; Package headers should be parsed from decoded text
+ ;; (see Bug#48137) where possible.
+ (if (and (eq buffer-file-coding-system 'no-conversion)
+ buffer-file-name)
+ (let* ((package-buffer (current-buffer))
+ (decoding-system
+ (car (find-operation-coding-system
+ 'insert-file-contents
+ (cons buffer-file-name
+ package-buffer)))))
+ (with-temp-buffer
+ (insert-buffer-substring package-buffer)
+ (decode-coding-region (point-min) (point-max)
+ decoding-system)
+ (package-buffer-info)))
+
+ (save-excursion
+ (package-buffer-info))))))
(name (package-desc-name pkg-desc)))
;; Download and install the dependencies.
(let* ((requires (package-desc-reqs pkg-desc))
@@ -2222,6 +2238,7 @@ directory."
(setq default-directory file)
(dired-mode))
(insert-file-contents-literally file)
+ (set-visited-file-name file)
(when (string-match "\\.tar\\'" file) (tar-mode)))
(package-install-from-buffer)))
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 4beba1d..a74a5a4 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -32,14 +32,6 @@
"Short documentation."
:group 'lisp)
-(defface shortdoc-separator
- '((((class color) (background dark))
- :height 0.1 :background "#505050" :extend t)
- (((class color) (background light))
- :height 0.1 :background "#a0a0a0" :extend t)
- (t :height 0.1 :inverse-video t :extend t))
- "Face used to separate sections.")
-
(defface shortdoc-heading
'((t :inherit variable-pitch :height 1.3 :weight bold))
"Face used for a heading."
@@ -281,8 +273,16 @@ There can be any number of :example/:result elements."
:eval (file-relative-name "/tmp/foo" "/tmp"))
(make-temp-name
:eval (make-temp-name "/tmp/foo-"))
+ (file-name-concat
+ :eval (file-name-concat "/tmp/" "foo")
+ :eval (file-name-concat "/tmp" "foo")
+ :eval (file-name-concat "/tmp" "foo" "bar/" "zot")
+ :eval (file-name-concat "/tmp" "~"))
(expand-file-name
- :eval (expand-file-name "foo" "/tmp/"))
+ :eval (expand-file-name "foo" "/tmp/")
+ :eval (expand-file-name "foo" "/tmp///")
+ :eval (expand-file-name "foo" "/tmp/foo/.././")
+ :eval (expand-file-name "~" "/tmp/"))
(substitute-in-file-name
:eval (substitute-in-file-name "$HOME/foo"))
"Directory Functions"
@@ -1174,7 +1174,7 @@ If FUNCTION is non-nil, place point on the entry for
FUNCTION (if any)."
;; There may be functions not yet defined in the data.
((fboundp (car data))
(when prev
- (insert (propertize "\n" 'face 'shortdoc-separator)))
+ (insert (make-separator-line)))
(setq prev t)
(shortdoc--display-function data))))
(cdr (assq group shortdoc--groups))))
diff --git a/lisp/emacs-lisp/tabulated-list.el
b/lisp/emacs-lisp/tabulated-list.el
index 04f3b70..f0ee787 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -214,6 +214,8 @@ If ADVANCE is non-nil, move forward by one line afterwards."
special-mode-map))
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
+ (define-key map (kbd "M-<left>") 'tabulated-list-previous-column)
+ (define-key map (kbd "M-<right>") 'tabulated-list-next-column)
(define-key map "S" 'tabulated-list-sort)
(define-key map "}" 'tabulated-list-widen-current-column)
(define-key map "{" 'tabulated-list-narrow-current-column)
@@ -740,6 +742,28 @@ Interactively, N is the prefix numeric argument, and
defaults to
(setq-local tabulated-list--current-lnum-width lnum-width)
(tabulated-list-init-header)))))
+(defun tabulated-list-next-column (&optional arg)
+ "Go to the start of the next column after point on the current line.
+If ARG is provided, move that many columns."
+ (interactive "p")
+ (dotimes (_ (or arg 1))
+ (let ((next (or (next-single-property-change
+ (point) 'tabulated-list-column-name)
+ (point-max))))
+ (when (<= next (line-end-position))
+ (goto-char next)))))
+
+(defun tabulated-list-previous-column (&optional arg)
+ "Go to the start of the column point is in on the current line.
+If ARG is provided, move that many columns."
+ (interactive "p")
+ (dotimes (_ (or arg 1))
+ (let ((prev (or (previous-single-property-change
+ (point) 'tabulated-list-column-name)
+ 1)))
+ (unless (< prev (line-beginning-position))
+ (goto-char prev)))))
+
;;; The mode definition:
(defvar tabulated-list--original-order nil)
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index cb9af92..5953471 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -130,7 +130,8 @@ longer than `erc-fill-column'."
("<URL: *\\([^<> ]+\\) *>" 0 t browse-url-button-open-url 1)
;;; ("(\\(\\([^~\n \t@][^\n \t@]*\\)@\\([a-zA-Z0-9.:-]+\\)\\)" 1 t finger 2 3)
;; emacs internal
- ("[`]\\([a-zA-Z][-a-zA-Z_0-9]+\\)[']" 1 t erc-button-describe-symbol 1)
+ ("[`]\\([a-zA-Z][-a-zA-Z_0-9!*<=>+]+\\)[']"
+ 1 t erc-button-describe-symbol 1)
;; pseudo links
("\\bInfo:[\"]\\([^\"]+\\)[\"]" 0 t Info-goto-node 1)
("\\b\\(Ward\\|Wiki\\|WardsWiki\\|TheWiki\\):\\([A-Z][a-z]+\\([A-Z][a-z]+\\)+\\)"
@@ -299,7 +300,7 @@ specified by `erc-button-alist'."
(end (match-end (nth 1 entry)))
(form (nth 2 entry))
(fun (nth 3 entry))
- (data (mapcar #'match-string (nthcdr 4 entry))))
+ (data (mapcar #'match-string-no-properties (nthcdr 4 entry))))
(when (or (eq t form)
(eval form t))
(erc-button-add-button start end fun nil data regexp)))))
diff --git a/lisp/faces.el b/lisp/faces.el
index 301b249..136985d 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -176,10 +176,28 @@ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc."
;;; Creation, copying.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(make-obsolete-variable 'face-new-frame-defaults
+ "use `face--new-frame-defaults' or `face-alist' instead." "28.1")
+
+(defun frame-face-alist (&optional frame)
+ "Return an alist of frame-local faces defined on FRAME.
+This alist is a copy of the contents of `frame--face-hash-table'.
+For internal use only."
+ (declare (obsolete frame--face-hash-table "28.1"))
+ (let (faces)
+ (maphash (lambda (face spec)
+ (let ((face-id (car (gethash face face--new-frame-defaults))))
+ (push `(,face-id ,face . ,spec) faces)))
+ (frame--face-hash-table frame))
+ (mapcar #'cdr (sort faces (lambda (f1 f2) (< (car f1) (car f2)))))))
(defun face-list ()
"Return a list of all defined faces."
- (mapcar #'car face-new-frame-defaults))
+ (let (faces)
+ (maphash (lambda (face spec)
+ (push `(,(car spec) . ,face) faces))
+ face--new-frame-defaults)
+ (mapcar #'cdr (sort faces (lambda (f1 f2) (< (car f1) (car f2)))))))
(defun make-face (face)
"Define a new face with name FACE, a symbol.
@@ -2116,6 +2134,8 @@ the X resource \"reverseVideo\" is present, handle that."
(unwind-protect
(progn
(x-setup-function-keys frame)
+ (dolist (face (nreverse (face-list)))
+ (face-spec-recalc face frame))
(x-handle-reverse-video frame parameters)
(frame-set-background-mode frame t)
(face-set-after-frame-default frame parameters)
@@ -2146,7 +2166,7 @@ the X resource \"reverseVideo\" is present, handle that."
(defun face-set-after-frame-default (frame &optional parameters)
"Initialize the frame-local faces of FRAME.
Calculate the face definitions using the face specs, custom theme
-settings, X resources, and `face-new-frame-defaults'.
+settings, X resources, and `face--new-frame-defaults'.
Finally, apply any relevant face attributes found amongst the
frame parameters in PARAMETERS."
;; The `reverse' is so that `default' goes first.
@@ -2155,7 +2175,7 @@ frame parameters in PARAMETERS."
(progn
;; Initialize faces from face spec and custom theme.
(face-spec-recalc face frame)
- ;; Apply attributes specified by face-new-frame-defaults
+ ;; Apply attributes specified by face--new-frame-defaults
(internal-merge-in-global-face face frame))
;; Don't let invalid specs prevent frame creation.
(error nil)))
diff --git a/lisp/files.el b/lisp/files.el
index d97c93e..6088822 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -1702,6 +1702,10 @@ rather than FUN itself, to `minibuffer-setup-hook'."
(list (read-file-name prompt nil default-directory mustmatch)
t))
+(defun file-name-history--add (file)
+ "Add FILE to `file-name-history'."
+ (add-to-history 'file-name-history (abbreviate-file-name file)))
+
(defun find-file (filename &optional wildcards)
"Edit file FILENAME.
Switch to a buffer visiting file FILENAME,
@@ -3191,11 +3195,70 @@ If FUNCTION is nil, then it is not called.")
"Upper limit on `magic-mode-alist' regexp matches.
Also applies to `magic-fallback-mode-alist'.")
+(defun set-auto-mode--apply-alist (alist keep-mode-if-same dir-local)
+ "Helper function for `set-auto-mode'.
+This function takes an alist of the same form as
+`auto-mode-alist'. It then tries to find the appropriate match
+in the alist for the current buffer; setting the mode if
+possible.
+Return non-nil if the mode was set, nil otherwise.
+DIR-LOCAL non-nil means this call is via directory-locals, and
+extra checks should be done."
+ (if buffer-file-name
+ (let (mode
+ (name buffer-file-name)
+ (remote-id (file-remote-p buffer-file-name))
+ (case-insensitive-p (file-name-case-insensitive-p
+ buffer-file-name)))
+ ;; Remove backup-suffixes from file name.
+ (setq name (file-name-sans-versions name))
+ ;; Remove remote file name identification.
+ (when (and (stringp remote-id)
+ (string-match (regexp-quote remote-id) name))
+ (setq name (substring name (match-end 0))))
+ (while name
+ ;; Find first matching alist entry.
+ (setq mode
+ (if case-insensitive-p
+ ;; Filesystem is case-insensitive.
+ (let ((case-fold-search t))
+ (assoc-default name alist 'string-match))
+ ;; Filesystem is case-sensitive.
+ (or
+ ;; First match case-sensitively.
+ (let ((case-fold-search nil))
+ (assoc-default name alist 'string-match))
+ ;; Fallback to case-insensitive match.
+ (and auto-mode-case-fold
+ (let ((case-fold-search t))
+ (assoc-default name alist 'string-match))))))
+ (if (and mode
+ (consp mode)
+ (cadr mode))
+ (setq mode (car mode)
+ name (substring name 0 (match-beginning 0)))
+ (setq name nil)))
+ (when (and dir-local mode
+ (not (set-auto-mode--dir-local-valid-p mode)))
+ (message "Ignoring invalid mode `%s'" mode)
+ (setq mode nil))
+ (when mode
+ (set-auto-mode-0 mode keep-mode-if-same)
+ t))))
+
+(defun set-auto-mode--dir-local-valid-p (mode)
+ "Say whether MODE can be used in a .dir-local.el `auto-mode-alist'."
+ (and (symbolp mode)
+ (string-suffix-p "-mode" (symbol-name mode))
+ (commandp mode)
+ (not (provided-mode-derived-p mode 'special-mode))))
+
(defun set-auto-mode (&optional keep-mode-if-same)
"Select major mode appropriate for current buffer.
To find the right major mode, this function checks for a -*- mode tag
checks for a `mode:' entry in the Local Variables section of the file,
+checks if there an `auto-mode-alist' entry in `.dir-locals.el',
checks if it uses an interpreter listed in `interpreter-mode-alist',
matches the buffer beginning against `magic-mode-alist',
compares the file name against the entries in `auto-mode-alist',
@@ -3252,6 +3315,14 @@ we don't actually set it to the same mode the buffer
already has."
(or (set-auto-mode-0 mode keep-mode-if-same)
;; continuing would call minor modes again, toggling them off
(throw 'nop nil))))))
+ ;; Check for auto-mode-alist entry in dir-locals.
+ (unless done
+ (with-demoted-errors "Directory-local variables error: %s"
+ ;; Note this is a no-op if enable-local-variables is nil.
+ (let* ((mode-alist (cdr (hack-dir-local--get-variables
+ (lambda (key) (eq key 'auto-mode-alist))))))
+ (setq done (set-auto-mode--apply-alist mode-alist
+ keep-mode-if-same t)))))
(and (not done)
(setq mode (hack-local-variables t (not try-locals)))
(not (memq mode modes)) ; already tried and failed
@@ -3303,45 +3374,8 @@ we don't actually set it to the same mode the buffer
already has."
(set-auto-mode-0 done keep-mode-if-same)))
;; Next compare the filename against the entries in auto-mode-alist.
(unless done
- (if buffer-file-name
- (let ((name buffer-file-name)
- (remote-id (file-remote-p buffer-file-name))
- (case-insensitive-p (file-name-case-insensitive-p
- buffer-file-name)))
- ;; Remove backup-suffixes from file name.
- (setq name (file-name-sans-versions name))
- ;; Remove remote file name identification.
- (when (and (stringp remote-id)
- (string-match (regexp-quote remote-id) name))
- (setq name (substring name (match-end 0))))
- (while name
- ;; Find first matching alist entry.
- (setq mode
- (if case-insensitive-p
- ;; Filesystem is case-insensitive.
- (let ((case-fold-search t))
- (assoc-default name auto-mode-alist
- 'string-match))
- ;; Filesystem is case-sensitive.
- (or
- ;; First match case-sensitively.
- (let ((case-fold-search nil))
- (assoc-default name auto-mode-alist
- 'string-match))
- ;; Fallback to case-insensitive match.
- (and auto-mode-case-fold
- (let ((case-fold-search t))
- (assoc-default name auto-mode-alist
- 'string-match))))))
- (if (and mode
- (consp mode)
- (cadr mode))
- (setq mode (car mode)
- name (substring name 0 (match-beginning 0)))
- (setq name nil))
- (when mode
- (set-auto-mode-0 mode keep-mode-if-same)
- (setq done t))))))
+ (setq done (set-auto-mode--apply-alist auto-mode-alist
+ keep-mode-if-same nil)))
;; Next try matching the buffer beginning against
magic-fallback-mode-alist.
(unless done
(if (setq done (save-excursion
@@ -3435,13 +3469,27 @@ Major modes can use this to examine user-specified
local variables
in order to initialize other data structure based on them.")
(defcustom safe-local-variable-values nil
- "List variable-value pairs that are considered safe.
+ "List of variable-value pairs that are considered safe.
Each element is a cons cell (VAR . VAL), where VAR is a variable
-symbol and VAL is a value that is considered safe."
+symbol and VAL is a value that is considered safe.
+
+Also see `ignored-local-variable-values'."
:risky t
:group 'find-file
:type 'alist)
+(defcustom ignored-local-variable-values nil
+ "List of variable-value pairs that should always be ignored.
+Each element is a cons cell (VAR . VAL), where VAR is a variable
+symbol and VAL is its value; if VAR is set to VAL by a file-local
+variables section, that setting should be ignored.
+
+Also see `safe-local-variable-values'."
+ :risky t
+ :group 'find-file
+ :type 'alist
+ :version "28.1")
+
(defcustom safe-local-eval-forms
;; This should be here at least as long as Emacs supports write-file-hooks.
'((add-hook 'write-file-hooks 'time-stamp)
@@ -3592,7 +3640,9 @@ n -- to ignore the local variables list.")
(if offer-save
(insert "
! -- to apply the local variables list, and permanently mark these
- values (*) as safe (in the future, they will be set automatically.)\n\n")
+ values (*) as safe (in the future, they will be set automatically.)
+i -- to ignore the local variables list, and permanently mark these
+ values (*) as ignored\n\n")
(insert "\n\n"))
(dolist (elt all-vars)
(cond ((member elt unsafe-vars)
@@ -3616,16 +3666,24 @@ n -- to ignore the local variables list.")
(pop-to-buffer buf '(display-buffer--maybe-at-bottom))
(let* ((exit-chars '(?y ?n ?\s))
(prompt (format "Please type %s%s: "
- (if offer-save "y, n, or !" "y or n")
+ (if offer-save "y, n, ! or i" "y or n")
(if (< (line-number-at-pos (point-max))
(window-body-height))
""
", or C-v/M-v to scroll")))
char)
- (if offer-save (push ?! exit-chars))
+ (when offer-save
+ (push ?i exit-chars)
+ (push ?! exit-chars))
(setq char (read-char-choice prompt exit-chars))
- (when (and offer-save (= char ?!) unsafe-vars)
- (customize-push-and-save 'safe-local-variable-values unsafe-vars))
+ (when (and offer-save
+ (or (= char ?!) (= char ?i))
+ unsafe-vars)
+ (customize-push-and-save
+ (if (= char ?!)
+ 'safe-local-variable-values
+ 'ignored-local-variable-values)
+ unsafe-vars))
(prog1 (memq char '(?! ?\s ?y))
(quit-window t)))))))
@@ -3718,13 +3776,18 @@ If these settings come from directory-local variables,
then
DIR-NAME is the name of the associated directory. Otherwise it is nil."
;; Find those variables that we may want to save to
;; `safe-local-variable-values'.
- (let (all-vars risky-vars unsafe-vars)
+ (let (all-vars risky-vars unsafe-vars ignored)
(dolist (elt variables)
(let ((var (car elt))
(val (cdr elt)))
(cond ((memq var ignored-local-variables)
;; Ignore any variable in `ignored-local-variables'.
nil)
+ ((seq-some (lambda (elem)
+ (and (eq (car elem) var)
+ (eq (cdr elem) val)))
+ ignored-local-variable-values)
+ nil)
;; Obey `enable-local-eval'.
((eq var 'eval)
(when enable-local-eval
@@ -4133,10 +4196,13 @@ Returns the new list."
;; Need a new cons in case we setcdr later.
(push (cons variable value) variables)))))
-(defun dir-locals-collect-variables (class-variables root variables)
+(defun dir-locals-collect-variables (class-variables root variables
+ &optional predicate)
"Collect entries from CLASS-VARIABLES into VARIABLES.
ROOT is the root directory of the project.
-Return the new variables list."
+Return the new variables list.
+If PREDICATE is given, it is used to test a symbol key in the alist
+to see whether it should be considered."
(let* ((file-name (or (buffer-file-name)
;; Handle non-file buffers, too.
(expand-file-name default-directory)))
@@ -4155,9 +4221,11 @@ Return the new variables list."
(>= (length sub-file-name) (length key))
(string-prefix-p key sub-file-name))
(setq variables (dir-locals-collect-variables
- (cdr entry) root variables))))
- ((or (not key)
- (derived-mode-p key))
+ (cdr entry) root variables predicate))))
+ ((if predicate
+ (funcall predicate key)
+ (or (not key)
+ (derived-mode-p key)))
(let* ((alist (cdr entry))
(subdirs (assq 'subdirs alist)))
(if (or (not subdirs)
@@ -4454,13 +4522,13 @@ Return the new class name, which is a symbol named DIR."
(defvar hack-dir-local-variables--warned-coding nil)
-(defun hack-dir-local-variables ()
+(defun hack-dir-local--get-variables (predicate)
"Read per-directory local variables for the current buffer.
-Store the directory-local variables in `dir-local-variables-alist'
-and `file-local-variables-alist', without applying them.
-
-This does nothing if either `enable-local-variables' or
-`enable-dir-local-variables' are nil."
+Return a cons of the form (DIR . ALIST), where DIR is the
+directory name (maybe nil) and ALIST is an alist of all variables
+that might apply. These will be filtered according to the
+buffer's directory, but not according to its mode.
+PREDICATE is passed to `dir-locals-collect-variables'."
(when (and enable-local-variables
enable-dir-local-variables
(or enable-remote-dir-locals
@@ -4479,21 +4547,33 @@ This does nothing if either `enable-local-variables' or
(setq dir-name (nth 0 dir-or-cache))
(setq class (nth 1 dir-or-cache))))
(when class
- (let ((variables
- (dir-locals-collect-variables
- (dir-locals-get-class-variables class) dir-name nil)))
- (when variables
- (dolist (elt variables)
- (if (eq (car elt) 'coding)
- (unless hack-dir-local-variables--warned-coding
- (setq hack-dir-local-variables--warned-coding t)
- (display-warning 'files
- "Coding cannot be specified by
dir-locals"))
- (unless (memq (car elt) '(eval mode))
- (setq dir-local-variables-alist
- (assq-delete-all (car elt) dir-local-variables-alist)))
- (push elt dir-local-variables-alist)))
- (hack-local-variables-filter variables dir-name)))))))
+ (cons dir-name
+ (dir-locals-collect-variables
+ (dir-locals-get-class-variables class)
+ dir-name nil predicate))))))
+
+(defun hack-dir-local-variables ()
+ "Read per-directory local variables for the current buffer.
+Store the directory-local variables in `dir-local-variables-alist'
+and `file-local-variables-alist', without applying them.
+
+This does nothing if either `enable-local-variables' or
+`enable-dir-local-variables' are nil."
+ (let* ((items (hack-dir-local--get-variables nil))
+ (dir-name (car items))
+ (variables (cdr items)))
+ (when variables
+ (dolist (elt variables)
+ (if (eq (car elt) 'coding)
+ (unless hack-dir-local-variables--warned-coding
+ (setq hack-dir-local-variables--warned-coding t)
+ (display-warning 'files
+ "Coding cannot be specified by dir-locals"))
+ (unless (memq (car elt) '(eval mode))
+ (setq dir-local-variables-alist
+ (assq-delete-all (car elt) dir-local-variables-alist)))
+ (push elt dir-local-variables-alist)))
+ (hack-local-variables-filter variables dir-name))))
(defun hack-dir-local-variables-non-file-buffer ()
"Apply directory-local variables to a non-file buffer.
@@ -6245,9 +6325,6 @@ This undoes all changes since the file was visited or
saved.
With a prefix argument, offer to revert from latest auto-save file, if
that is more recent than the visited file.
-Reverting a buffer will try to preserve markers in the buffer;
-see the Info node `(elisp)Reverting' for details.
-
This command also implements an interface for special buffers
that contain text that doesn't come from a file, but reflects
some other data instead (e.g. Dired buffers, `buffer-list'
@@ -6273,7 +6350,12 @@ This function binds `revert-buffer-in-progress-p'
non-nil while it operates.
This function calls the function that `revert-buffer-function' specifies
to do the work, with arguments IGNORE-AUTO and NOCONFIRM.
The default function runs the hooks `before-revert-hook' and
-`after-revert-hook'."
+`after-revert-hook'
+
+Reverting a buffer will try to preserve markers in the buffer,
+but it cannot always preserve all of them. For better results,
+use `revert-buffer-with-fine-grain', which tries harder to
+preserve markers and overlays, at the price of being slower."
;; I admit it's odd to reverse the sense of the prefix argument, but
;; there is a lot of code out there that assumes that the first
;; argument should be t to avoid consulting the auto-save file, and
@@ -6282,7 +6364,9 @@ The default function runs the hooks `before-revert-hook'
and
;; interface, but leaving the programmatic interface the same.
(interactive (list (not current-prefix-arg)))
(let ((revert-buffer-in-progress-p t)
- (revert-buffer-preserve-modes preserve-modes))
+ (revert-buffer-preserve-modes preserve-modes)
+ ;; Preserve buffer-readedness.
+ (buffer-read-only buffer-read-only))
(funcall (or revert-buffer-function #'revert-buffer--default)
ignore-auto noconfirm)))
@@ -8043,16 +8127,16 @@ Otherwise, trash FILENAME using the freedesktop.org
conventions,
;; exists, but the file name may exist in the trash
;; directory even if there is no info file for it.
(when (file-exists-p
- (expand-file-name files-base trash-files-dir))
+ (file-name-concat trash-files-dir files-base))
(setq overwrite t
files-base (file-name-nondirectory
(make-temp-file
- (expand-file-name
- files-base trash-files-dir)
+ (file-name-concat
+ trash-files-dir files-base)
is-directory))))
- (setq info-fn (expand-file-name
- (concat files-base ".trashinfo")
- trash-info-dir))
+ (setq info-fn (file-name-concat
+ trash-info-dir
+ (concat files-base ".trashinfo")))
;; Re-check the existence (sort of).
(condition-case nil
(write-region nil nil info-fn nil 'quiet info-fn 'excl)
@@ -8061,14 +8145,14 @@ Otherwise, trash FILENAME using the freedesktop.org
conventions,
;; like Emacs-style backup file names. E.g.:
;; https://bugs.kde.org/170956
(setq info-fn (make-temp-file
- (expand-file-name files-base trash-info-dir)
+ (file-name-concat trash-info-dir files-base)
nil ".trashinfo"))
(setq files-base (substring (file-name-nondirectory info-fn)
0 (- (length ".trashinfo"))))
(write-region nil nil info-fn nil 'quiet info-fn)))
;; Finally, try to move the file to the trashcan.
(let ((delete-by-moving-to-trash nil)
- (new-fn (expand-file-name files-base trash-files-dir)))
+ (new-fn (file-name-concat trash-files-dir files-base)))
(rename-file fn new-fn overwrite)))))))))
(defsubst file-attribute-type (attributes)
diff --git a/lisp/frame.el b/lisp/frame.el
index 302993e..db33087 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -1231,7 +1231,7 @@ face specs for the new background mode."
;; during startup with -rv on the command
;; line for the initial frame, because frames
;; are not recorded in the pdump file.
- (assq face (frame-face-alist frame))
+ (gethash face (frame--face-hash-table))
(face-spec-match-p face
(face-user-default-spec face)
frame)))
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index cdabdef..9baf09b 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -4922,6 +4922,7 @@ Each line should be no more than 79 characters long."
(defvar smtpmail-smtp-service)
(defvar smtpmail-smtp-user)
(defvar smtpmail-stream-type)
+(defvar smtpmail-store-queue-variables)
(defun message-multi-smtp-send-mail ()
"Send the current buffer to `message-send-mail-function'.
@@ -4937,7 +4938,8 @@ that instead."
(message-send-mail-with-sendmail))
((equal (car method) "smtp")
(require 'smtpmail)
- (let* ((smtpmail-smtp-server (nth 1 method))
+ (let* ((smtpmail-store-queue-variables t)
+ (smtpmail-smtp-server (nth 1 method))
(service (nth 2 method))
(port (string-to-number service))
;; If we're talking to the TLS SMTP port, then force a
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index cb248b1..d7fb038 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1078,6 +1078,9 @@ it is displayed along with the global value."
(with-current-buffer standard-output
(setq help-mode--current-data
(list :symbol variable
+ :type (if (eq file-name 'C-source)
+ 'variable
+ 'defvar)
:file file-name))
(save-excursion
(re-search-backward (substitute-command-keys
@@ -1089,7 +1092,8 @@ it is displayed along with the global value."
"It is void as a variable."
"Its "))
(with-current-buffer standard-output
- (setq help-mode--current-data (list :symbol
variable)))
+ (setq help-mode--current-data (list :symbol variable
+ :type 'variable)))
(if valvoid
" is void as a variable."
(substitute-command-keys "'s ")))))
@@ -1573,11 +1577,7 @@ current buffer and the selected frame, respectively."
(insert doc)
(delete-region (point)
(progn (skip-chars-backward " \t\n") (point)))
- (insert "\n\n"
- (eval-when-compile
- (propertize "\n" 'face
- '(:height 0.1 :inverse-video t :extend t)))
- "\n")
+ (insert "\n\n" (make-separator-line) "\n")
(when name
(insert (symbol-name symbol)
" is also a " name "." "\n\n"))))
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index 4e73551..3976a9a 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -738,8 +738,10 @@ See `help-make-xrefs'."
(interactive nil help-mode)
(unless (plist-get help-mode--current-data :file)
(error "Source file for the current help item is not defined"))
- (help-function-def--button-function (plist-get help-mode--current-data
:symbol)
- (plist-get help-mode--current-data
:file)))
+ (help-function-def--button-function
+ (plist-get help-mode--current-data :symbol)
+ (plist-get help-mode--current-data :file)
+ (plist-get help-mode--current-data :type)))
(defun help-goto-info ()
"View the *info* node of the current help item."
diff --git a/lisp/help.el b/lisp/help.el
index 1bb1b30..ba27fc5 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -943,12 +943,7 @@ current buffer."
(when defn
(when (> (length info-list) 1)
(with-current-buffer standard-output
- (insert "\n\n"
- ;; FIXME: Can't use eval-when-compile because purified
- ;; strings lose their text properties :-(
- (propertize "\n" 'face
- '(:height 0.1 :inverse-video t :extend t))
- "\n")))
+ (insert "\n\n" (make-separator-line) "\n")))
(princ brief-desc)
(when locus
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index 576fced..adea150 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -97,6 +97,12 @@ Otherwise this should be a list of the completion tables
(e.g.,
:type '(choice (const :tag "All" t)
(repeat function)))
+(defcustom icomplete-matches-format "%s/%s "
+ "Format of the current/total number of matches for the prompt prefix."
+ :version "28.1"
+ :type '(choice (const :tag "No prefix" nil)
+ (string :tag "Prefix format string")))
+
(defface icomplete-first-match '((t :weight bold))
"Face used by Icomplete for highlighting first match."
:version "24.4")
@@ -696,12 +702,12 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
(overlay-put
icomplete-overlay 'before-string
(and icomplete-scroll
- (let ((past (length icomplete--scrolled-past)))
- (format
- "%s/%s "
- (1+ past)
- (+ past
- (safe-length completion-all-sorted-completions))))))
+ icomplete-matches-format
+ (let* ((past (length icomplete--scrolled-past))
+ (current (1+ past))
+ (total (+ past (safe-length
+
completion-all-sorted-completions))))
+ (format icomplete-matches-format current total))))
(overlay-put icomplete-overlay 'after-string text))))))))
(defun icomplete--affixate (md prospects)
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index 24d49ea..9041b9a 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -276,7 +276,9 @@ supports ordinary shell wildcards if
`ls-lisp-support-shell-wildcards'
is non-nil; otherwise, it interprets wildcards as regular expressions
to match file names. It does not support all `ls' switches -- those
that work are: A a B C c F G g h i n R r S s t U u v X. The l switch
-is assumed to be always present and cannot be turned off."
+is assumed to be always present and cannot be turned off.
+Long variants of the above switches, as documented for GNU `ls',
+are also supported; unsupported long options are silently ignored."
(if ls-lisp-use-insert-directory-program
(funcall orig-fun
file switches wildcard full-directory-p)
@@ -284,13 +286,21 @@ is assumed to be always present and cannot be turned off."
(let ((handler (find-file-name-handler (expand-file-name file)
'insert-directory))
(orig-file file)
- wildcard-regexp)
+ wildcard-regexp
+ (ls-lisp-dirs-first
+ (or ls-lisp-dirs-first
+ (string-match "--group-directories-first" switches))))
(if handler
(funcall handler 'insert-directory file switches
wildcard full-directory-p)
- ;; Remove --dired switch
- (if (string-match "--dired " switches)
- (setq switches (replace-match "" nil nil switches)))
+ (when (string-match "--group-directories-first" switches)
+ ;; if ls-lisp-dirs-first is nil, dirs are grouped but come out in
+ ;; reverse order:
+ (setq ls-lisp-dirs-first t)
+ (setq switches (replace-match "" nil nil switches)))
+ ;; Remove unrecognized long options, and convert the
+ ;; recognized ones to their short variants.
+ (setq switches (ls-lisp--sanitize-switches switches))
;; Convert SWITCHES to a list of characters.
(setq switches (delete ?\ (delete ?- (append switches nil))))
;; Sometimes we get ".../foo*/" as FILE. While the shell and
@@ -890,6 +900,60 @@ All ls time options, namely c, t and u, are handled."
;; Continue standard unloading.
nil)
+(defun ls-lisp--sanitize-switches (switches)
+ "Convert long options of GNU 'ls' to their short form.
+Conversion is done only for flags supported by ls-lisp.
+Long options not supported by ls-lisp are removed.
+Supported options are: A a B C c F G g h i n R r S s t U u v X.
+The l switch is assumed to be always present and cannot be turned off."
+ (let ((lsflags '(("-a" . "--all")
+ ("-A" . "--almost-all")
+ ("-B" . "--ignore-backups")
+ ("-C" . "--color")
+ ("-F" . "--classify")
+ ("-G" . "--no-group")
+ ("-h" . "--human-readable")
+ ("-H" . "--dereference-command-line")
+ ("-i" . "--inode")
+ ("-n" . "--numeric-uid-gid")
+ ("-r" . "--reverse")
+ ("-R" . "--recursive")
+ ("-s" . "--size")
+ ("-S" . "--sort.*[ \\\t]")
+ ("" . "--group-directories-first")
+ ("" . "--author")
+ ("" . "--escape")
+ ("" . "--directory")
+ ("" . "--dired")
+ ("" . "--file-type")
+ ("" . "--format")
+ ("" . "--full-time")
+ ("" . "--si")
+ ("" . "--dereference-command-line-symlink-to-dir")
+ ("" . "--hide")
+ ("" . "--hyperlink")
+ ("" . "--ignore")
+ ("" . "--kibibytes")
+ ("" . "--dereference")
+ ("" . "--literal")
+ ("" . "--hide-control-chars")
+ ("" . "--show-control-chars")
+ ("" . "--quote-name")
+ ("" . "--context")
+ ("" . "--help")
+ ;; ("" . "--indicator-style.*[ \\\t]")
+ ;; ("" . "--quoting-style.*[ \t\\]")
+ ;; ("" . "--time.*[ \\\t]")
+ ;; ("" . "--time-style.*[ \\\t]")
+ ;; ("" . "--tabsize.*[ \\\t]")
+ ;; ("" . "--width.*[ \\\t]")
+ ("" . "--.*=.*[ \\\t\n]?") ;; catch all with '=' sign in
+ ("" . "--version"))))
+ (dolist (f lsflags)
+ (if (string-match (cdr f) switches)
+ (setq switches (replace-match (car f) nil nil switches))))
+ (string-trim switches)))
+
(provide 'ls-lisp)
;;; ls-lisp.el ends here
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index c1e2280..133a2e1 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -135,8 +135,9 @@ Used for the value of `sendmail-coding-system' when
(defcustom smtpmail-queue-mail nil
"Non-nil means mail is queued; otherwise it is sent immediately.
-If queued, it is stored in the directory `smtpmail-queue-dir'
-and sent with `smtpmail-send-queued-mail'."
+If queued, it is stored in the directory `smtpmail-queue-dir' and
+sent with `smtpmail-send-queued-mail'. Also see
+`smtpmail-store-queue-variables'."
:type 'boolean)
(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
@@ -173,10 +174,21 @@ mean \"try again\"."
:type 'integer
:version "27.1")
+(defcustom smtpmail-store-queue-variables nil
+ "If non-nil, store SMTP variables when queueing mail.
+These will then be used when sending the queue."
+ :type 'boolean
+ :version "28.1")
+
;;; Variables
(defvar smtpmail-address-buffer)
-(defvar smtpmail-recipient-address-list)
+(defvar smtpmail-recipient-address-list nil)
+(defvar smtpmail--stored-queue-variables
+ '(smtpmail-smtp-server
+ smtpmail-stream-type
+ smtpmail-smtp-service
+ smtpmail-smtp-user))
(defvar smtpmail-queue-counter 0)
@@ -387,11 +399,17 @@ for `smtpmail-try-auth-method'.")
nil t)
(insert-buffer-substring tembuf)
(write-file file-data)
- (write-region
- (concat "(setq smtpmail-recipient-address-list '"
- (prin1-to-string smtpmail-recipient-address-list)
- ")\n")
- nil file-elisp nil 'silent)
+ (let ((coding-system-for-write 'utf-8))
+ (with-temp-buffer
+ (insert "(setq ")
+ (dolist (var (cons 'smtpmail-recipient-address-list
+ ;; Perhaps store the server etc.
+ (and smtpmail-store-queue-variables
+ smtpmail--stored-queue-variables)))
+ (insert (format " %s %S\n" var (symbol-value var))))
+ (insert ")\n")
+ (write-region (point-min) (point-max) file-elisp
+ nil 'silent)))
(write-region (concat file-data "\n") nil
(expand-file-name smtpmail-queue-index-file
smtpmail-queue-dir)
@@ -411,26 +429,30 @@ for `smtpmail-try-auth-method'.")
(let (file-data file-elisp
(qfile (expand-file-name smtpmail-queue-index-file
smtpmail-queue-dir))
+ (stored (cons 'smtpmail-recipient-address-list
+ smtpmail--stored-queue-variables))
+ smtpmail-recipient-address-list
+ (smtpmail-smtp-server smtpmail-smtp-server)
+ (smtpmail-stream-type smtpmail-stream-type)
+ (smtpmail-smtp-service smtpmail-smtp-service)
+ (smtpmail-smtp-user smtpmail-smtp-user)
result)
(insert-file-contents qfile)
(goto-char (point-min))
(while (not (eobp))
(setq file-data (buffer-substring (point) (line-end-position)))
(setq file-elisp (concat file-data ".el"))
- ;; FIXME: Avoid `load' which can execute arbitrary code and is hence
- ;; a source of security holes. Better read the file and extract the
- ;; data "by hand".
- ;;(load file-elisp)
- (with-temp-buffer
- (insert-file-contents file-elisp)
- (goto-char (point-min))
- (pcase (read (current-buffer))
- (`(setq smtpmail-recipient-address-list ',v)
- (skip-chars-forward " \n\t")
- (unless (eobp) (message "Ignoring trailing text in %S"
- file-elisp))
- (setq smtpmail-recipient-address-list v))
- (sexp (error "Unexpected code in %S: %S" file-elisp sexp))))
+ (let ((coding-system-for-read 'utf-8))
+ (with-temp-buffer
+ (insert-file-contents file-elisp)
+ (let ((form (read (current-buffer))))
+ (when (or (not (consp form))
+ (not (eq (car form) 'setq))
+ (not (consp (cdr form))))
+ (error "Unexpected code in %S: %S" file-elisp form))
+ (cl-loop for (var val) on (cdr form) by #'cddr
+ when (memq var stored)
+ do (set var val)))))
;; Insert the message literally: it is already encoded as per
;; the MIME headers, and code conversions might guess the
;; encoding wrongly.
@@ -445,13 +467,13 @@ for `smtpmail-try-auth-method'.")
(message-narrow-to-headers)
(mail-envelope-from)))
user-mail-address)))
- (if (not (null smtpmail-recipient-address-list))
- (when (setq result (smtpmail-via-smtp
- smtpmail-recipient-address-list
- (current-buffer)))
- (error "Sending failed: %s"
- (smtpmail--sanitize-error-message result)))
- (error "Sending failed; no recipients"))))
+ (if (not smtpmail-recipient-address-list)
+ (error "Sending failed; no recipients")
+ (when (setq result (smtpmail-via-smtp
+ smtpmail-recipient-address-list
+ (current-buffer)))
+ (error "Sending failed: %s"
+ (smtpmail--sanitize-error-message result))))))
(delete-file file-data)
(delete-file file-elisp)
(delete-region (point-at-bol) (point-at-bol 2)))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 813ce14..1578ab8 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2328,6 +2328,15 @@ variables.")
(setq deactivate-mark nil)
(throw 'exit nil))
+(defun minibuffer-quit-recursive-edit ()
+ "Quit the command that requested this recursive edit without error.
+Like `abort-recursive-edit' without aborting keyboard macro
+execution."
+ ;; See Info node `(elisp)Recursive Editing' for an explanation of
+ ;; throwing a function to `exit'.
+ (throw 'exit (lambda ()
+ (signal 'minibuffer-quit nil))))
+
(defun self-insert-and-exit ()
"Terminate minibuffer input."
(interactive)
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index 6c660d2..f11f36e 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -25,7 +25,7 @@
;;; Commentary:
;; Internet Relay Chat (IRC) is a form of instant communication over
-;; the Internet. It is mainly designed for group (many-to-many)
+;; the Internet. It is mainly designed for group (many-to-many)
;; communication in discussion forums called channels, but also allows
;; one-to-one communication.
@@ -44,7 +44,10 @@
(require 'cl-lib)
(require 'ring)
(require 'time-date)
+(require 'auth-source)
+(require 'parse-time)
(eval-when-compile (require 'subr-x))
+(eval-when-compile (require 'rx))
(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version))
@@ -56,10 +59,10 @@
:group 'applications)
(defcustom rcirc-server-alist
- '(("irc.libera.chat" :channels ("#rcirc")
- ;; Don't use the TLS port by default, in case gnutls is not available.
- ;; :port 6697 :encryption tls
- ))
+ (if (gnutls-available-p)
+ '(("irc.libera.chat" :channels ("#rcirc")
+ :port 6697 :encryption tls))
+ '(("irc.libera.chat" :channels ("#rcirc"))))
"An alist of IRC connections to establish when running `rcirc'.
Each element looks like (SERVER-NAME PARAMETERS).
@@ -108,8 +111,9 @@ for connections using SSL/TLS.
`:server-alias'
-VALUE must be a string that will be used instead of the server name for
-display purposes. If absent, the real server name will be displayed instead."
+VALUE must be a string that will be used instead of the server
+name for display purposes. If absent, the real server name will
+be displayed instead."
:type '(alist :key-type string
:value-type (plist :options
((:nick string)
@@ -120,7 +124,8 @@ display purposes. If absent, the real server name will be
displayed instead."
(:channels (repeat string))
(:encryption (choice (const tls)
(const plain)))
- (:server-alias string)))))
+ (:server-alias string))))
+ :version "28.1")
(defcustom rcirc-default-port 6667
"The default port to connect to."
@@ -179,17 +184,29 @@ If nil, no maximum is applied."
(integer :tag "Number of characters")))
(defvar-local rcirc-ignore-buffer-activity-flag nil
- "If non-nil, ignore activity in this buffer.")
+ "Non-nil means ignore activity in this buffer.")
(defvar-local rcirc-low-priority-flag nil
- "If non-nil, activity in this buffer is considered low priority.")
+ "Non-nil means activity in this buffer is considered low priority.")
(defcustom rcirc-omit-responses
'("JOIN" "PART" "QUIT" "NICK")
"Responses which will be hidden when `rcirc-omit-mode' is enabled."
:type '(repeat string))
-(defvar rcirc-prompt-start-marker nil)
+(defcustom rcirc-omit-after-reconnect
+ '("JOIN" "TOPIC" "NAMES")
+ "Types of messages to hide right after reconnecting."
+ :type '(repeat string)
+ :version "28.1")
+
+(defvar-local rcirc-reconncting nil
+ "Non-nil means we have just reconnected.
+This is used to hide the message types enumerated in
+`rcirc-supress-after-reconnect'.")
+
+(defvar-local rcirc-prompt-start-marker nil
+ "Marker indicating the beginning of the message prompt.")
(define-minor-mode rcirc-omit-mode
"Toggle the hiding of \"uninteresting\" lines.
@@ -228,8 +245,7 @@ number. If zero or nil, no truncating is done."
(integer :tag "Number of lines")))
(defcustom rcirc-scroll-show-maximum-output t
- "If non-nil, scroll buffer to keep the point at the bottom of
-the window."
+ "Non-nil means scroll to keep the point at the bottom of the window."
:type 'boolean)
(defcustom rcirc-authinfo nil
@@ -296,8 +312,9 @@ The following replacements are made:
%s is the server.
%t is the buffer target, a channel or a user.
-Setting this alone will not affect the prompt;
-use either M-x customize or also call `rcirc-update-prompt'."
+Setting this alone will not affect the prompt; use either
+\\[execute-extended-command] customize or also call
+`rcirc-update-prompt'."
:type 'string
:set #'rcirc-set-changed
:initialize 'custom-initialize-default)
@@ -391,13 +408,21 @@ will be killed."
:version "24.3"
:type 'boolean)
-(defvar rcirc-nick nil)
+(defcustom rcirc-nick-filter #'identity
+ "Function applied to nicknames before displaying."
+ :version "28.1"
+ :type 'function)
+
+(defvar-local rcirc-nick nil
+ "The nickname used for the current connection.")
-(defvar rcirc-prompt-end-marker nil)
+(defvar-local rcirc-prompt-end-marker nil
+ "Marker indicating the end of the message prompt.")
-(defvar rcirc-nick-table nil)
+(defvar-local rcirc-nick-table nil
+ "Hash table mapping nicks to channels.")
-(defvar rcirc-recent-quit-alist nil
+(defvar-local rcirc-recent-quit-alist nil
"Alist of nicks that have recently quit or parted the channel.")
(defvar rcirc-nick-syntax-table
@@ -408,8 +433,8 @@ will be killed."
table)
"Syntax table which includes all nick characters as word constituents.")
-;; each process has an alist of (target . buffer) pairs
-(defvar rcirc-buffer-alist nil)
+(defvar-local rcirc-buffer-alist nil
+ "Alist of (TARGET . BUFFER) pairs.")
(defvar rcirc-activity nil
"List of buffers with unviewed activity.")
@@ -418,16 +443,16 @@ will be killed."
"String displayed in mode line representing `rcirc-activity'.")
(put 'rcirc-activity-string 'risky-local-variable t)
-(defvar rcirc-server-buffer nil
+(defvar-local rcirc-server-buffer nil
"The server buffer associated with this channel buffer.")
-(defvar rcirc-server-parameters nil
+(defvar-local rcirc-server-parameters nil
"List of parameters received from the server.")
-(defvar rcirc-target nil
+(defvar-local rcirc-target nil
"The channel or user associated with this buffer.")
-(defvar rcirc-urls nil
+(defvar-local rcirc-urls nil
"List of URLs seen in the current buffer and their start positions.")
(put 'rcirc-urls 'permanent-local t)
@@ -435,7 +460,8 @@ will be killed."
"Kill connection after this many seconds if there is no activity.")
-(defvar rcirc-startup-channels nil)
+(defvar-local rcirc-startup-channels nil
+ "List of channel names to join after authenticating.")
(defvar rcirc-server-name-history nil
"History variable for \\[rcirc] call.")
@@ -505,6 +531,12 @@ If ARG is non-nil, instead prompt for connection
parameters."
(encryption (plist-get (cdr c) :encryption))
(server-alias (plist-get (cdr c) :server-alias))
contact)
+ (when-let (((not password))
+ (auth (auth-source-search :host server
+ :user user-name
+ :port port))
+ (fn (plist-get (car auth) :secret)))
+ (setq password (funcall fn)))
(when server
(let (connected)
(dolist (p (rcirc-process-list))
@@ -536,20 +568,53 @@ If ARG is non-nil, instead prompt for connection
parameters."
(defalias 'irc 'rcirc)
-(defvar rcirc-process-output nil)
-(defvar rcirc-topic nil)
-(defvar rcirc-keepalive-timer nil)
-(defvar rcirc-last-server-message-time nil)
-(defvar rcirc-server nil) ; server provided by server
-(defvar rcirc-server-name nil) ; server name given by 001 response
-(defvar rcirc-timeout-timer nil)
-(defvar rcirc-user-authenticated nil)
-(defvar rcirc-user-disconnect nil)
-(defvar rcirc-connecting nil)
-(defvar rcirc-connection-info nil)
-(defvar rcirc-process nil)
+(defvar-local rcirc-process-output nil
+ "Partial message response.")
+(defvar-local rcirc-topic nil
+ "Topic of the current channel.")
+(defvar rcirc-keepalive-timer nil
+ "Timer for sending KEEPALIVE message.")
+(defvar-local rcirc-last-server-message-time nil
+ "Timestamp for the last server response.")
+(defvar-local rcirc-server nil
+ "Server provided by server.")
+(defvar-local rcirc-server-name nil
+ "Server name given by 001 response.")
+(defvar-local rcirc-timeout-timer nil
+ "Timer for determining a network timeout.")
+(defvar-local rcirc-user-authenticated nil
+ "Flag indicating if the user is authenticated.")
+(defvar-local rcirc-user-disconnect nil
+ "Flag indicating if the connection was broken.")
+(defvar-local rcirc-connecting nil
+ "Flag indicating if the connection is being established.")
+(defvar-local rcirc-connection-info nil
+ "Information about the current connection.
+If defined, it is a list of this form (SERVER PORT NICK USER-NAME
+FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS).
+See `rcirc-connect' for more details on these variables.")
+(defvar-local rcirc-process nil
+ "Network process for the current connection.")
+
+;;; IRCv3 capability negotiation
(https://ircv3.net/specs/extensions/capability-negotiation)
+(defvar rcirc-implemented-capabilities
+ '("message-tags"
;https://ircv3.net/specs/extensions/message-tags
+ "server-time"
;https://ircv3.net/specs/extensions/server-time
+ "batch"
;https://ircv3.net/specs/extensions/batch
+ "message-ids"
;https://ircv3.net/specs/extensions/message-ids
+ "invite-notify"
;https://ircv3.net/specs/extensions/invite-notify
+ "sasl"
;https://ircv3.net/specs/extensions/sasl-3.1
+ )
+ "A list of capabilities that rcirc supports.")
+(defvar-local rcirc-requested-capabilities nil
+ "A list of capabilities that client has requested.")
+(defvar-local rcirc-acked-capabilities nil
+ "A list of capabilities that the server supports.")
+(defvar-local rcirc-finished-sasl t
+ "Check whether SASL authentication has completed")
(defun rcirc-get-server-method (server)
+ "Return authentication method for SERVER."
(catch 'method
(dolist (i rcirc-authinfo)
(let ((server-i (car i))
@@ -558,6 +623,7 @@ If ARG is non-nil, instead prompt for connection
parameters."
(throw 'method method))))))
(defun rcirc-get-server-password (server)
+ "Return password for SERVER."
(catch 'pass
(dolist (i rcirc-authinfo)
(let ((server-i (car i))
@@ -569,6 +635,11 @@ If ARG is non-nil, instead prompt for connection
parameters."
(defun rcirc-connect (server &optional port nick user-name
full-name startup-channels password encryption
server-alias)
+ "Connect to SERVER.
+The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD,
+ENCRYPTION, SERVER-ALIAS are interpreted as in
+`rcirc-server-alist'. STARTUP-CHANNELS is a list of channels
+that are joined after authentication."
(save-excursion
(message "Connecting to %s..." (or server-alias server))
(let* ((inhibit-eol-conversion)
@@ -589,44 +660,42 @@ If ARG is non-nil, instead prompt for connection
parameters."
(set-process-coding-system process 'raw-text 'raw-text)
(switch-to-buffer (rcirc-generate-new-buffer-name process nil))
(set-process-buffer process (current-buffer))
- (rcirc-mode process nil)
+ (unless (eq major-mode 'rcirc-mode)
+ (rcirc-mode process nil))
(set-process-sentinel process 'rcirc-sentinel)
(set-process-filter process 'rcirc-filter)
- (setq-local rcirc-connection-info
- (list server port nick user-name full-name startup-channels
- password encryption server-alias))
- (setq-local rcirc-process process)
- (setq-local rcirc-server server)
- (setq-local rcirc-server-name
- (or server-alias server)) ; Update when we get 001 response.
- (setq-local rcirc-buffer-alist nil)
- (setq-local rcirc-nick-table (make-hash-table :test 'equal))
- (setq-local rcirc-nick nick)
- (setq-local rcirc-process-output nil)
- (setq-local rcirc-startup-channels startup-channels)
- (setq-local rcirc-last-server-message-time (current-time))
-
- (setq-local rcirc-timeout-timer nil)
- (setq-local rcirc-user-disconnect nil)
- (setq-local rcirc-user-authenticated nil)
- (setq-local rcirc-connecting t)
- (setq-local rcirc-server-parameters nil)
+ (setq rcirc-connection-info
+ (list server port nick user-name full-name startup-channels
+ password encryption server-alias))
+ (setq rcirc-process process)
+ (setq rcirc-server server)
+ (setq rcirc-server-name (or server-alias server)) ; Update when we get
001 response.
+ (setq rcirc-nick-table (make-hash-table :test 'equal))
+ (setq rcirc-nick nick)
+ (setq rcirc-startup-channels startup-channels)
+ (setq rcirc-last-server-message-time (current-time))
+
+ (setq rcirc-connecting t)
(add-hook 'auto-save-hook 'rcirc-log-write)
(when use-sasl
(rcirc-send-string process "CAP REQ sasl"))
+ (when use-sasl
+ (setq-local rcirc-finished-sasl nil))
;; identify
+ (dolist (cap rcirc-implemented-capabilities)
+ (rcirc-send-string process "CAP" "REQ" : cap)
+ (push cap rcirc-requested-capabilities))
(unless (zerop (length password))
- (rcirc-send-string process (concat "PASS " password)))
- (rcirc-send-string process (concat "NICK " nick))
- (rcirc-send-string process (concat "USER " user-name
- " 0 * :" full-name))
+ (rcirc-send-string process "PASS" password))
+ (rcirc-send-string process "NICK" nick)
+ (rcirc-send-string process "USER" user-name "0" "*" : full-name)
;; Setup sasl, and initiate authentication.
(when (and rcirc-auto-authenticate-flag
use-sasl)
- (rcirc-send-string process "AUTHENTICATE PLAIN"))
+ (rcirc-send-string process "AUTHENTICATE" "PLAIN"))
;; setup ping timer if necessary
(unless rcirc-keepalive-timer
@@ -634,31 +703,33 @@ If ARG is non-nil, instead prompt for connection
parameters."
(run-at-time 0 (/ rcirc-timeout-seconds 2) 'rcirc-keepalive)))
(message "Connecting to %s...done" (or server-alias server))
+ (setq mode-line-process nil)
;; return process object
process)))
(defmacro with-rcirc-process-buffer (process &rest body)
+ "Evaluate BODY in the buffer of PROCESS."
(declare (indent 1) (debug t))
`(with-current-buffer (process-buffer ,process)
,@body))
(defmacro with-rcirc-server-buffer (&rest body)
+ "Evaluate BODY in the server buffer of the current channel."
(declare (indent 0) (debug t))
- `(with-current-buffer rcirc-server-buffer
- ,@body))
+ `(if (buffer-live-p rcirc-server-buffer)
+ (with-current-buffer rcirc-server-buffer
+ ,@body)
+ (user-error "Server buffer was killed")))
(define-obsolete-function-alias 'rcirc-float-time 'float-time "26.1")
(defun rcirc-prompt-for-encryption (server-plist)
"Prompt the user for the encryption method to use.
SERVER-PLIST is the property list for the server."
- (let ((choices '("plain" "tls"))
- (default (or (plist-get server-plist :encryption)
- "plain")))
- (intern
- (completing-read (format-prompt "Encryption" default)
- choices nil t nil nil default))))
+ (if (or (eq (plist-get server-plist :encryption) 'plain)
+ (yes-or-no-p "Encrypt connection?"))
+ 'tls 'plain))
(defun rcirc-keepalive ()
"Send keep alive pings to active rcirc processes.
@@ -679,14 +750,18 @@ last ping."
(setq rcirc-keepalive-timer nil)))
(defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message)
+ "Uptime header in PROCESS buffer.
+MESSAGE should contain a timestamp, indicating when the KEEPALIVE
+message was generated."
(with-rcirc-process-buffer process
(setq header-line-format
(format "%f" (float-time
(time-since (string-to-number message)))))))
-(defvar rcirc-debug-buffer "*rcirc debug*")
+(defvar rcirc-debug-buffer "*rcirc debug*"
+ "Buffer name for debugging messages.")
(defvar rcirc-debug-flag nil
- "If non-nil, write information to `rcirc-debug-buffer'.")
+ "Non-nil means write information to `rcirc-debug-buffer'.")
(defun rcirc-debug (process text)
"Add an entry to the debug log including PROCESS and TEXT.
Debug text is appended to `rcirc-debug-buffer' if `rcirc-debug-flag'
@@ -720,7 +795,7 @@ When 0, do not auto-reconnect."
:version "25.1"
:type 'integer)
-(defvar rcirc-last-connect-time nil
+(defvar-local rcirc-last-connect-time nil
"The last time the buffer was connected.")
(defun rcirc-sentinel (process sentinel)
@@ -748,6 +823,8 @@ When 0, do not auto-reconnect."
(run-hook-with-args 'rcirc-sentinel-functions process sentinel))))
(defun rcirc-disconnect-buffer (&optional buffer)
+ "Disconnect BUFFER.
+If BUFFER is nil, default to the current buffer."
(with-current-buffer (or buffer (current-buffer))
;; set rcirc-target to nil for each channel so cleanup
;; doesn't happen when we reconnect
@@ -785,19 +862,19 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS
and LINE.")
(rcirc-process-server-response process line))))))
(defun rcirc-reschedule-timeout (process)
+ "Update timeout indicator for PROCESS."
(with-rcirc-process-buffer process
(when (not rcirc-connecting)
(with-rcirc-process-buffer process
(when rcirc-timeout-timer (cancel-timer rcirc-timeout-timer))
(setq rcirc-timeout-timer (run-at-time rcirc-timeout-seconds nil
- 'rcirc-delete-process
+ 'delete-process
process))))))
-(defun rcirc-delete-process (process)
- (delete-process process))
-
-(defvar rcirc-trap-errors-flag t)
+(defvar rcirc-trap-errors-flag t
+ "Non-nil means Lisp errors are degraded to error messages.")
(defun rcirc-process-server-response (process text)
+ "Parse TEXT as received from PROCESS."
(if rcirc-trap-errors-flag
(condition-case err
(rcirc-process-server-response-1 process text)
@@ -806,17 +883,91 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS
and LINE.")
(format "\"%s\" %s" text err) t)))
(rcirc-process-server-response-1 process text)))
+(defconst rcirc-process-regexp
+ (rx-let ((message-tag ; message tags as specified in
+ ; https://ircv3.net/specs/extensions/message-tags
+ (: (? "+")
+ (? (+ (or alnum "-")) (+ "." (+ (or alnum "-"))) "/")
+ (+ (any alnum "-"))
+ (? "="
+ (* (not (any 0 ?\n ?\r ?\; ?\s)))))))
+ (rx line-start
+ (optional "@" (group message-tag (* ";" message-tag)) (+ space))
+ ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1.
+ ;; We're a bit more accepting than the RFC: We allow any non-space
+ ;; characters in the command name, multiple spaces between
+ ;; arguments, and allow the last argument to omit the leading ":",
+ ;; even if there are less than 15 arguments.
+ (optional
+ (group ":" (group (one-or-more (not (any " ")))) " "))
+ (group (one-or-more (not (any " "))))))
+ "Regular expression used for parsing server response.")
+
+(defconst rcirc-tag-regexp
+ (rx bos
+ (group
+ (? "+")
+ (? (+ (or alnum "-")) (+ "." (+ (or alnum "-"))) "/")
+ (+ (any alnum "-")))
+ (? "=" (group (* (not (any 0 ?\n ?\r ?\; ?\s)))))
+ eos)
+ "Regular expression used for destructing a tag.")
+
+(defvar rcirc-message-tags nil
+ "Alist of parsed message tags.")
+
+(defvar rcirc-supported-batch-types
+ '()
+ "List of recognized batch types.
+Each element has the form (TYPE HANDLE), where TYPE is a string
+and HANDLE is either the symbol `immediate' or `deferred'.
+Messages in an immediate batch are handled just like regular
+messages, while deferred messages are stored in
+`rcirc-batch-messages'.")
+
+(defvar-local rcirc-batch-attributes nil
+ "Alist mapping batch IDs to parameters.")
+
+(defvar-local rcirc-batched-messages nil
+ "Alist mapping batch IDs to deferred messages.
+Note that the messages are stored in reverse order.")
+
+(defsubst rcirc-get-tag (key &optional default)
+ "Return tag value for KEY or DEFAULT."
+ (alist-get key rcirc-message-tags default nil #'string=))
+
(defun rcirc-process-server-response-1 (process text)
- ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1. We're a
- ;; bit more accepting than the RFC: We allow any non-space
- ;; characters in the command name, multiple spaces between
- ;; arguments, and allow the last argument to omit the leading ":",
- ;; even if there are less than 15 arguments.
- (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\)" text)
- (let* ((user (match-string 2 text))
+ "Parse TEXT as received from PROCESS."
+ (if (string-match rcirc-process-regexp text)
+ (let* ((rcirc-message-tags
+ (append
+ (and-let* ((tag-data (match-string 1 text)))
+ (save-match-data
+ (mapcar
+ (lambda (tag)
+ (unless (string-match rcirc-tag-regexp tag)
+ ;; This should not happen, unless there is
+ ;; a mismatch between this regular
+ ;; expression and `rcirc-process-regexp'.
+ (error "Malformed tag %S" tag))
+ (cons (match-string 1 tag)
+ (replace-regexp-in-string
+ (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n))
+ (lambda (rep)
+ (concat (substring rep 0 -2)
+ (cl-case (aref rep (1- (length rep)))
+ (?: ";")
+ (?s " ")
+ (?\\ "\\\\")
+ (?r "\r")
+ (?n "\n"))))
+ (match-string 2 tag))))
+ (split-string tag-data ";"))))
+ rcirc-message-tags))
+ (user (match-string 3 text))
(sender (rcirc-user-nick user))
- (cmd (match-string 3 text))
- (cmd-end (match-end 3))
+ (cmd (match-string 4 text))
+ (cmd-end (match-end 4))
(args nil)
(handler (intern-soft (concat "rcirc-handler-" cmd))))
(cl-loop with i = cmd-end
@@ -829,9 +980,18 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and
LINE.")
(push (substring text (match-end 0)) args)
(cl-assert (= i (length text))))
(cl-callf nreverse args)))
- (if (not (fboundp handler))
- (rcirc-handler-generic process cmd sender args text)
- (funcall handler process sender args text))
+ (cond ((and-let* ((batch-id (rcirc-get-tag "batch"))
+ (type (cadr (assoc batch-id rcirc-batch-attributes)))
+ (attr (assoc type rcirc-supported-batch-types))
+ ((eq (cadr attr) 'deferred)))
+ ;; handle deferred batch messages later
+ (push (list cmd process sender args text rcirc-message-tags)
+ (alist-get batch-id rcirc-batched-messages
+ nil nil #'string=))
+ t))
+ ((not (fboundp handler))
+ (rcirc-handler-generic process cmd sender args text))
+ ((funcall handler process sender args text)))
(run-hook-with-args 'rcirc-receive-message-functions
process cmd sender args text))
(message "UNHANDLED: %s" text)))
@@ -840,17 +1000,34 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS
and LINE.")
"Responses that don't trigger activity in the mode-line indicator.")
(defun rcirc-handler-generic (process response sender args _text)
- "Generic server response handler."
+ "Generic server response handler.
+This handler is called, when no more specific handler could be
+found. PROCESS, SENDER and RESPONSE are passed on to
+`rcirc-print'. ARGS are concatenated into a single string and
+used as the message body."
(rcirc-print process sender response nil
(mapconcat 'identity (cdr args) " ")
(not (member response rcirc-responses-no-activity))))
(defun rcirc--connection-open-p (process)
+ "Check if PROCESS is open or running."
(memq (process-status process) '(run open)))
-(defun rcirc-send-string (process string)
- "Send PROCESS a STRING plus a newline."
- (let ((string (concat (encode-coding-string string
rcirc-encode-coding-system)
+(defun rcirc-send-string (process &rest parts)
+ "Send PROCESS a PARTS plus a newline.
+PARTS may contain a `:' symbol, to designate that the next string
+is the message, that should be prefixed by a colon. If the last
+element in PARTS is a list, append it to PARTS."
+ (let ((last (car (last parts))))
+ (when (listp last)
+ (setf parts (append (butlast parts) last))))
+ (when-let (message (memq : parts))
+ (cl-check-type (cadr message) string)
+ (setf (cadr message) (concat ":" (cadr message))
+ parts (remq : parts)))
+ (let ((string (concat (encode-coding-string
+ (mapconcat #'identity parts " ")
+ rcirc-encode-coding-system)
"\n")))
(unless (rcirc--connection-open-p process)
(error "Network connection to %s is not open"
@@ -859,13 +1036,17 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS
and LINE.")
(process-send-string process string)))
(defun rcirc-send-privmsg (process target string)
+ "Send TARGET the message in STRING via PROCESS."
(cl-check-type target string)
- (rcirc-send-string process (format "PRIVMSG %s :%s" target string)))
+ (rcirc-send-string process "PRIVMSG" target : string))
+
+(defun rcirc-ctcp-wrap (&rest args)
+ "Join ARGS into a string wrapped by ASCII 1 charterers."
+ (concat "\C-a" (string-join (delq nil args) " ") "\C-a"))
(defun rcirc-send-ctcp (process target request &optional args)
- (let ((args (if args (concat " " args) "")))
- (rcirc-send-privmsg process target
- (format "\C-a%s%s\C-a" request args))))
+ "Send TARGET a REQUEST via PROCESS."
+ (rcirc-send-privmsg process target (rcirc-ctcp-wrap request args)))
(defun rcirc-buffer-process (&optional buffer)
"Return the process associated with channel BUFFER.
@@ -891,7 +1072,7 @@ With no argument or nil as argument, use the current
buffer."
"Return the nick associated with BUFFER.
With no argument or nil as argument, use the current buffer."
(with-current-buffer (or buffer (current-buffer))
- (with-current-buffer rcirc-server-buffer
+ (with-rcirc-server-buffer
(or rcirc-nick rcirc-default-nick))))
(defvar rcirc-max-message-length 420
@@ -924,17 +1105,22 @@ If SILENT is non-nil, do not print the message in any
irc buffer."
(let ((response (if noticep "NOTICE" "PRIVMSG")))
(rcirc-get-buffer-create process target)
(dolist (msg (rcirc-split-message message))
- (rcirc-send-string process (concat response " " target " :" msg))
+ (rcirc-send-string process response target : msg)
(unless silent
(rcirc-print process (rcirc-nick process) response target msg)))))
-(defvar rcirc-input-ring nil)
-(defvar rcirc-input-ring-index 0)
+(defvar-local rcirc-input-ring nil
+ "Ring object for input.")
+
+(defvar-local rcirc-input-ring-index 0
+ "Current position in the input ring.")
(defun rcirc-prev-input-string (arg)
+ "Move ARG elements ahead in the input ring."
(ring-ref rcirc-input-ring (+ rcirc-input-ring-index arg)))
(defun rcirc-insert-prev-input ()
+ "Insert previous element in input ring."
(interactive)
(when (<= rcirc-prompt-end-marker (point))
(delete-region rcirc-prompt-end-marker (point-max))
@@ -942,6 +1128,7 @@ If SILENT is non-nil, do not print the message in any irc
buffer."
(setq rcirc-input-ring-index (1+ rcirc-input-ring-index))))
(defun rcirc-insert-next-input ()
+ "Insert next element in input ring."
(interactive)
(when (<= rcirc-prompt-end-marker (point))
(delete-region rcirc-prompt-end-marker (point-max))
@@ -975,63 +1162,62 @@ The list is updated automatically by
`defun-rcirc-command'.")
(if (re-search-backward "[[:space:]@]"
rcirc-prompt-end-marker t)
(1+ (point))
rcirc-prompt-end-marker)))
- (table (if (and (= beg rcirc-prompt-end-marker)
- (eq (char-after beg) ?/))
- (delete-dups
- (nconc (sort (copy-sequence rcirc-client-commands)
- 'string-lessp)
- (sort (copy-sequence rcirc-server-commands)
- 'string-lessp)))
- (rcirc-channel-nicks (rcirc-buffer-process)
- rcirc-target))))
- (list beg (point) table))))
-
-(defvar rcirc-completions nil)
-(defvar rcirc-completion-start nil)
-
-(defun rcirc-complete ()
- "Cycle through completions from list of nicks in channel or IRC commands.
-IRC command completion is performed only if `/' is the first input char."
- (interactive)
- (unless (rcirc-looking-at-input)
- (error "Point not located after rcirc prompt"))
- (if (eq last-command this-command)
- (setq rcirc-completions
- (append (cdr rcirc-completions) (list (car rcirc-completions))))
- (let ((completion-ignore-case t)
- (table (rcirc-completion-at-point)))
- (setq rcirc-completion-start (car table))
- (setq rcirc-completions
- (and rcirc-completion-start
- (all-completions (buffer-substring rcirc-completion-start
- (cadr table))
- (nth 2 table))))))
- (let ((completion (car rcirc-completions)))
- (when completion
- (delete-region rcirc-completion-start (point))
- (insert
- (cond
- ((= (aref completion 0) ?/) (concat completion " "))
- ((= rcirc-completion-start rcirc-prompt-end-marker)
- (format rcirc-nick-completion-format completion))
- (t completion))))))
-
-(defun set-rcirc-decode-coding-system (coding-system)
- "Set the decode coding system used in this channel."
+ (table (cond
+ ;; No completion before the prompt
+ ((< beg rcirc-prompt-end-marker) nil)
+ ;; Only complete nicks mid-message
+ ((> beg rcirc-prompt-end-marker)
+ (mapcar rcirc-nick-filter
+ (rcirc-channel-nicks
+ (rcirc-buffer-process)
+ rcirc-target)))
+ ;; Complete commands at the beginning of the
+ ;; message, when the first character is a dash
+ ((eq (char-after beg) ?/)
+ (mapcar
+ (lambda (cmd) (concat cmd " "))
+ (nconc (sort (copy-sequence rcirc-client-commands)
+ 'string-lessp)
+ (sort (copy-sequence rcirc-server-commands)
+ 'string-lessp))))
+ ;; Complete usernames right after the prompt by
+ ;; appending a colon after the name
+ ((mapcar
+ (lambda (str) (concat (funcall rcirc-nick-filter str)
": "))
+ (rcirc-channel-nicks (rcirc-buffer-process)
+ rcirc-target))))))
+ (list beg (point)
+ (lambda (str pred action)
+ (if (eq action 'metadata)
+ '(metadata (cycle-sort-function . identity))
+ (complete-with-action action table str pred)))))))
+
+(defun rcirc-set-decode-coding-system (coding-system)
+ "Set the decode CODING-SYSTEM used in this channel."
(interactive "zCoding system for incoming messages: ")
(setq-local rcirc-decode-coding-system coding-system))
-(defun set-rcirc-encode-coding-system (coding-system)
- "Set the encode coding system used in this channel."
+(define-obsolete-function-alias
+ 'rcirc-set-decode-coding-system
+ 'set-rcirc-decode-coding-system
+ "28.1")
+
+(defun rcirc-set-encode-coding-system (coding-system)
+ "Set the encode CODING-SYSTEM used in this channel."
(interactive "zCoding system for outgoing messages: ")
(setq-local rcirc-encode-coding-system coding-system))
+(define-obsolete-function-alias
+ 'rcirc-set-encode-coding-system
+ 'set-rcirc-encode-coding-system
+ "28.1")
+
(defvar rcirc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") 'rcirc-send-input)
(define-key map (kbd "M-p") 'rcirc-insert-prev-input)
(define-key map (kbd "M-n") 'rcirc-insert-next-input)
- (define-key map (kbd "TAB") 'rcirc-complete)
+ (define-key map (kbd "TAB") 'completion-at-point)
(define-key map (kbd "C-c C-b") 'rcirc-browse-url)
(define-key map (kbd "C-c C-c") 'rcirc-edit-multiline)
(define-key map (kbd "C-c C-j") 'rcirc-cmd-join)
@@ -1054,34 +1240,35 @@ IRC command completion is performed only if `/' is the
first input char."
map)
"Keymap for rcirc mode.")
-(defvar rcirc-short-buffer-name nil
+(defvar-local rcirc-short-buffer-name nil
"Generated abbreviation to use to indicate buffer activity.")
(defvar rcirc-mode-hook nil
"Hook run when setting up rcirc buffer.")
-(defvar rcirc-last-post-time nil)
+(defvar-local rcirc-last-post-time nil
+ "Timestamp indicating last user action.")
(defvar rcirc-log-alist nil
"Alist of lines to log to disk when `rcirc-log-flag' is non-nil.
Each element looks like (FILENAME . TEXT).")
-(defvar rcirc-current-line 0
+(defvar-local rcirc-current-line 0
"The current number of responses printed in this channel.
This number is independent of the number of lines in the buffer.")
(defun rcirc-mode (process target)
- ;; FIXME: Use define-derived-mode.
"Major mode for IRC channel buffers.
\\{rcirc-mode-map}"
+ ;; FIXME: Use define-derived-mode.
(kill-all-local-variables)
(use-local-map rcirc-mode-map)
(setq mode-name "rcirc")
(setq major-mode 'rcirc-mode)
(setq mode-line-process nil)
- (setq-local rcirc-input-ring
+ (setq rcirc-input-ring
;; If rcirc-input-ring is already a ring with desired
;; size do not re-initialize.
(if (and (ring-p rcirc-input-ring)
@@ -1089,18 +1276,14 @@ This number is independent of the number of lines in
the buffer.")
rcirc-input-ring-size))
rcirc-input-ring
(make-ring rcirc-input-ring-size)))
- (setq-local rcirc-server-buffer (process-buffer process))
- (setq-local rcirc-target target)
- (setq-local rcirc-topic nil)
- (setq-local rcirc-last-post-time (current-time))
+ (setq rcirc-server-buffer (process-buffer process))
+ (setq rcirc-target target)
+ (setq rcirc-last-post-time (current-time))
(setq-local fill-paragraph-function 'rcirc-fill-paragraph)
- (setq-local rcirc-recent-quit-alist nil)
- (setq-local rcirc-current-line 0)
- (setq-local rcirc-last-connect-time (current-time))
+ (setq rcirc-current-line 0)
+ (setq rcirc-last-connect-time (current-time))
(use-hard-newlines t)
- (setq-local rcirc-short-buffer-name nil)
- (setq-local rcirc-urls nil)
;; setup for omitting responses
(setq buffer-invisibility-spec '())
@@ -1121,8 +1304,8 @@ This number is independent of the number of lines in the
buffer.")
(if (consp (cdr i)) (cddr i) (cdr i))))))
;; setup the prompt and markers
- (setq-local rcirc-prompt-start-marker (point-max-marker))
- (setq-local rcirc-prompt-end-marker (point-max-marker))
+ (setq rcirc-prompt-start-marker (point-max-marker))
+ (setq rcirc-prompt-end-marker (point-max-marker))
(rcirc-update-prompt)
(goto-char rcirc-prompt-end-marker)
@@ -1143,6 +1326,7 @@ This number is independent of the number of lines in the
buffer.")
(add-hook 'completion-at-point-functions
'rcirc-completion-at-point nil 'local)
+ (setq-local completion-cycle-threshold t)
(run-mode-hooks 'rcirc-mode-hook))
@@ -1181,7 +1365,7 @@ If ALL is non-nil, update prompts in all IRC buffers."
'front-sticky t 'rear-nonsticky t))))))))
(defun rcirc-set-changed (option value)
- "Set OPTION to VALUE and do updates after a customization change."
+ "Set OPTION to VALUE and update after a customization change."
(set-default option value)
(cond ((eq option 'rcirc-prompt)
(rcirc-update-prompt 'all))
@@ -1224,10 +1408,11 @@ with it."
(kill-buffer (cdr channel))))))
(defun rcirc-change-major-mode-hook ()
- "Part the channel when changing the major-mode."
+ "Part the channel when changing the major mode."
(rcirc-clean-up-buffer "Changed major mode"))
(defun rcirc-clean-up-buffer (reason)
+ "Clean up current buffer and part with REASON."
(let ((buffer (current-buffer)))
(rcirc-clear-activity buffer)
(when (and (rcirc-buffer-process)
@@ -1238,7 +1423,7 @@ with it."
(rcirc-update-short-buffer-names)
(if (rcirc-channel-p rcirc-target)
(rcirc-send-string (rcirc-buffer-process)
- (concat "PART " rcirc-target " :" reason))
+ "PART" rcirc-target : reason)
(when rcirc-target
(rcirc-remove-nick-channel (rcirc-buffer-process)
(rcirc-buffer-nick)
@@ -1278,9 +1463,11 @@ Create the buffer if it doesn't exist."
(let ((new-buffer (get-buffer-create
(rcirc-generate-new-buffer-name process target))))
(with-current-buffer new-buffer
- (rcirc-mode process target)
+ (unless (eq major-mode 'rcirc-mode)
+ (rcirc-mode process target)))
+ (setq mode-line-process nil)
(rcirc-put-nick-channel process (rcirc-nick process) target
- rcirc-current-line))
+ rcirc-current-line)
new-buffer)))))
(defun rcirc-send-input ()
@@ -1316,6 +1503,8 @@ Create the buffer if it doesn't exist."
(setq rcirc-input-ring-index 0))))))
(defun rcirc-fill-paragraph (&optional justify)
+ "Implementation for `fill-paragraph-function'.
+The argument JUSTIFY is passed on to `fill-region'."
(interactive "P")
(when (> (point) rcirc-prompt-end-marker)
(save-restriction
@@ -1324,13 +1513,15 @@ Create the buffer if it doesn't exist."
(fill-region (point-min) (point-max) justify)))))
(defun rcirc-process-input-line (line)
- (if (string-match "^/\\([^ ]+\\) ?\\(.*\\)$" line)
+ "Process LINE as a message or a command."
+ (if (string-match "^/\\([^/ ][^ ]*\\) ?\\(.*\\)$" line)
(rcirc-process-command (match-string 1 line)
(match-string 2 line)
line)
(rcirc-process-message line)))
(defun rcirc-process-message (line)
+ "Process LINE as a message to be sent."
(if (not rcirc-target)
(message "Not joined (no target)")
(delete-region rcirc-prompt-end-marker (point))
@@ -1338,28 +1529,31 @@ Create the buffer if it doesn't exist."
(setq rcirc-last-post-time (current-time))))
(defun rcirc-process-command (command args line)
- (if (eq (aref command 0) ?/)
- ;; "//text" will send "/text" as a message
- (rcirc-process-message (substring line 1))
- (let ((fun (intern-soft (concat "rcirc-cmd-" command)))
- (process (rcirc-buffer-process)))
- (newline)
- (with-current-buffer (current-buffer)
- (delete-region rcirc-prompt-end-marker (point))
- (if (string= command "me")
- (rcirc-print process (rcirc-buffer-nick)
- "ACTION" rcirc-target args)
+ "Process COMMAND with arguments ARGS.
+LINE is the raw input, from which COMMAND and ARGS was
+extracted."
+ (let ((fun (intern-soft (concat "rcirc-cmd-" command)))
+ (process (rcirc-buffer-process)))
+ (newline)
+ (with-current-buffer (current-buffer)
+ (delete-region rcirc-prompt-end-marker (point))
+ (if (string= command "me")
(rcirc-print process (rcirc-buffer-nick)
- "COMMAND" rcirc-target line))
- (set-marker rcirc-prompt-end-marker (point))
- (if (fboundp fun)
- (funcall fun args process rcirc-target)
- (rcirc-send-string process
- (concat command " :" args)))))))
-
-(defvar-local rcirc-parent-buffer nil)
+ "ACTION" rcirc-target args)
+ (rcirc-print process (rcirc-buffer-nick)
+ "COMMAND" rcirc-target line))
+ (set-marker rcirc-prompt-end-marker (point))
+ (if (fboundp fun)
+ (funcall fun args process rcirc-target)
+ (rcirc-send-string process command : args)))))
+
+(defvar-local rcirc-parent-buffer nil
+ "Message buffer that requested a multiline buffer.")
(put 'rcirc-parent-buffer 'permanent-local t)
-(defvar rcirc-window-configuration nil)
+
+(defvar rcirc-window-configuration nil
+ "Window configuration before creating multiline buffer.")
+
(defun rcirc-edit-multiline ()
"Move current edit to a dedicated buffer."
(interactive)
@@ -1455,9 +1649,10 @@ the of the following escape sequences replaced by the
described values:
:value-type string))
(defun rcirc-format-response-string (process sender response target text)
- "Return a nicely-formatted response string, incorporating TEXT
-\(and perhaps other arguments). The specific formatting used
-is found by looking up RESPONSE in `rcirc-response-formats'."
+ "Return a formatted response string from SENDER, incorporating TEXT.
+The specific formatting used is found by looking up RESPONSE in
+`rcirc-response-formats'. PROCESS is the process object used for
+communication."
(with-temp-buffer
(insert (or (cdr (assoc response rcirc-response-formats))
(cdr (assq t rcirc-response-formats))))
@@ -1466,7 +1661,7 @@ is found by looking up RESPONSE in
`rcirc-response-formats'."
(sender (if (or (not sender)
(string= (rcirc-server-name process) sender))
""
- sender))
+ (funcall rcirc-nick-filter sender)))
face)
(while (re-search-forward "%\\(\\(f\\(.\\)\\)\\|\\(.\\)\\)" nil t)
(rcirc-add-face start (match-beginning 0) face)
@@ -1511,7 +1706,8 @@ is found by looking up RESPONSE in
`rcirc-response-formats'."
(buffer-substring (point-min) (point-max))))
(defun rcirc-target-buffer (process sender response target _text)
- "Return a buffer to print the server response."
+ "Return a buffer to print the server response from SENDER.
+PROCESS is the process object for the current connection."
(cl-assert (not (bufferp target)))
(with-rcirc-process-buffer process
(cond ((not target)
@@ -1527,8 +1723,9 @@ is found by looking up RESPONSE in
`rcirc-response-formats'."
((or (rcirc-get-buffer process target)
(rcirc-any-buffer process))))))
-(defvar-local rcirc-activity-types nil)
(defvar-local rcirc-last-sender nil)
+(defvar-local rcirc-activity-types nil
+ "List of symbols designating kinds of activities in a buffer.")
(defcustom rcirc-omit-threshold 100
"Lines since last activity from a nick before `rcirc-omit-responses' are
omitted."
@@ -1541,14 +1738,16 @@ is found by looking up RESPONSE in
`rcirc-response-formats'."
(defun rcirc-last-quit-line (process nick target)
"Return the line number where NICK left TARGET.
-Returns nil if the information is not recorded."
+Returns nil if the information is not recorded.
+PROCESS is the process object for the current connection."
(let ((chanbuf (rcirc-get-buffer process target)))
(when chanbuf
(cdr (assoc-string nick (with-current-buffer chanbuf
rcirc-recent-quit-alist))))))
(defun rcirc-last-line (process nick target)
- "Return the line from the last activity from NICK in TARGET."
+ "Return the line from the last activity from NICK in TARGET.
+PROCESS is the process object for the current connection."
(let ((line (or (cdr (assoc-string target
(gethash nick (with-rcirc-server-buffer
rcirc-nick-table)) t))
@@ -1559,7 +1758,8 @@ Returns nil if the information is not recorded."
nil)))
(defun rcirc-elapsed-lines (process nick target)
- "Return the number of lines since activity from NICK in TARGET."
+ "Return the number of lines since activity from NICK in TARGET.
+PROCESS is the process object for the current connection."
(let ((last-activity-line (rcirc-last-line process nick target)))
(when (and last-activity-line
(> last-activity-line 0))
@@ -1567,11 +1767,12 @@ Returns nil if the information is not recorded."
(defvar rcirc-markup-text-functions
'(rcirc-markup-attributes
+ rcirc-color-attributes
+ rcirc-remove-markup-codes
rcirc-markup-my-nick
rcirc-markup-urls
rcirc-markup-keywords
rcirc-markup-bright-nicks)
-
"List of functions used to manipulate text before it is printed.
Each function takes two arguments, SENDER, and RESPONSE. The
@@ -1581,7 +1782,8 @@ at the beginning of the `rcirc-text' propertized text.")
(defun rcirc-print (process sender response target text &optional activity)
"Print TEXT in the buffer associated with TARGET.
Format based on SENDER and RESPONSE. If ACTIVITY is non-nil,
-record activity."
+record activity. PROCESS is the process object for the current
+connection."
(or text (setq text ""))
(unless (and (or (member sender rcirc-ignore-list)
(member (with-syntax-table rcirc-nick-syntax-table
@@ -1591,11 +1793,13 @@ record activity."
;; do not ignore if we sent the message
(not (string= sender (rcirc-nick process))))
(let* ((buffer (rcirc-target-buffer process sender response target text))
+ (time (if-let ((time (rcirc-get-tag "time")))
+ (parse-iso8601-time-string time)
+ (current-time)))
(inhibit-read-only t))
(with-current-buffer buffer
(let ((moving (= (point) rcirc-prompt-end-marker))
- (old-point (point-marker))
- (fill-start (marker-position rcirc-prompt-start-marker)))
+ (old-point (point-marker)))
(setq text (decode-coding-string text rcirc-decode-coding-system))
(unless (string= sender (rcirc-nick process))
@@ -1609,25 +1813,32 @@ record activity."
;; temporarily set the marker insertion-type because
;; insert-before-markers results in hidden text in new buffers
(goto-char rcirc-prompt-start-marker)
+ (catch 'exit
+ (while (not (bobp))
+ (goto-char (or (previous-single-property-change (point) 'hard)
+ (point-min)))
+ (when (let ((then (get-text-property (point) 'rcirc-time)))
+ (and then (not (time-less-p time then))))
+ (next-single-property-change (point) 'hard)
+ (forward-char 1)
+ (throw 'exit nil))))
(set-marker-insertion-type rcirc-prompt-start-marker t)
(set-marker-insertion-type rcirc-prompt-end-marker t)
- (let ((start (point)))
- (insert (rcirc-format-response-string process sender response nil
- text)
- (propertize "\n" 'hard t))
-
- ;; squeeze spaces out of text before rcirc-text
- (fill-region fill-start
- (1- (or (next-single-property-change fill-start
- 'rcirc-text)
- rcirc-prompt-end-marker)))
-
- ;; run markup functions
- (save-excursion
- (save-restriction
- (narrow-to-region start rcirc-prompt-start-marker)
- (goto-char (or (next-single-property-change start 'rcirc-text)
+ ;; run markup functions
+ (cl-assert (bolp))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert (propertize (rcirc-format-response-string process sender
response
+ nil text)
+ 'rcirc-msgid (rcirc-get-tag "msgid"))
+ (propertize "\n" 'hard t))
+
+ ;; squeeze spaces out of text before rcirc-text
+ (fill-region (point-min) (point-max))
+
+ (goto-char (or (next-single-property-change (point-min)
'rcirc-text)
(point)))
(when (rcirc-buffer-process)
(save-excursion (rcirc-markup-timestamp sender response))
@@ -1638,14 +1849,21 @@ record activity."
(when rcirc-read-only-flag
(add-text-properties (point-min) (point-max)
- '(read-only t front-sticky t))))
- ;; make text omittable
+ '(read-only t front-sticky t)))
+
+ (add-text-properties (point-min) (point-max)
+ (list 'rcirc-time time))
+
+ ;; make text omittable
(let ((last-activity-lines (rcirc-elapsed-lines process sender
target)))
(if (and (not (string= (rcirc-nick process) sender))
- (member response rcirc-omit-responses)
+ (or (member response rcirc-omit-responses)
+ (if (member response rcirc-omit-after-reconnect)
+ rcirc-reconncting
+ (setq rcirc-reconncting nil)))
(or (not last-activity-lines)
(< rcirc-omit-threshold last-activity-lines)))
- (put-text-property (1- start) (1- rcirc-prompt-start-marker)
+ (put-text-property (point-min) (point-max)
'invisible 'rcirc-omit)
;; otherwise increment the line count
(setq rcirc-current-line (1+ rcirc-current-line))))))
@@ -1667,11 +1885,11 @@ record activity."
(window-buffer w))
(>= (window-point w)
rcirc-prompt-end-marker))
- (set-window-point w (point-max))))
+ (set-window-point w (point-max))))
nil t)
;; restore the point
- (goto-char (if moving rcirc-prompt-end-marker old-point))
+ (goto-char (if moving rcirc-prompt-end-marker old-point)))
;; keep window on bottom line if it was already there
(when rcirc-scroll-show-maximum-output
@@ -1688,28 +1906,29 @@ record activity."
;; flush undo (can we do something smarter here?)
(buffer-disable-undo)
- (buffer-enable-undo))
-
- ;; record mode line activity
- (when (and activity
- (not rcirc-ignore-buffer-activity-flag)
- (not (and rcirc-dim-nicks sender
- (string-match (regexp-opt rcirc-dim-nicks) sender)
- (rcirc-channel-p target))))
- (rcirc-record-activity (current-buffer)
- (when (not (rcirc-channel-p rcirc-target))
- 'nick)))
-
- (when (and rcirc-log-flag
- (or target
- rcirc-log-process-buffers))
- (rcirc-log process sender response target text))
-
- (sit-for 0) ; displayed text before hook
- (run-hook-with-args 'rcirc-print-functions
- process sender response target text)))))
+ (buffer-enable-undo)
+
+ ;; record mode line activity
+ (when (and activity
+ (not rcirc-ignore-buffer-activity-flag)
+ (not (and rcirc-dim-nicks sender
+ (string-match (regexp-opt rcirc-dim-nicks) sender)
+ (rcirc-channel-p target))))
+ (rcirc-record-activity (current-buffer)
+ (when (not (rcirc-channel-p rcirc-target))
+ 'nick)))
+
+ (when (and rcirc-log-flag
+ (or target
+ rcirc-log-process-buffers))
+ (rcirc-log process sender response target text))
+
+ (sit-for 0) ; displayed text before hook
+ (run-hook-with-args 'rcirc-print-functions
+ process sender response target text)))))
(defun rcirc-generate-log-filename (process target)
+ "Return filename for log file based on PROCESS and TARGET."
(if target
(rcirc-generate-new-buffer-name process target)
(process-name process)))
@@ -1731,11 +1950,15 @@ guarantee valid filenames for the current OS."
:type 'function)
(defun rcirc-log (process sender response target text)
- "Record line in `rcirc-log', to be later written to disk."
- (let ((filename (funcall rcirc-log-filename-function process target)))
+ "Record TEXT from SENDER to TARGET to be logged.
+The message is logged in `rcirc-log', and is later written to
+disk. PROCESS is the process object for the current connection."
+ (let ((filename (funcall rcirc-log-filename-function process target))
+ (time (and-let* ((time (rcirc-get-tag "time")))
+ (parse-iso8601-time-string time))))
(unless (null filename)
(let ((cell (assoc-string filename rcirc-log-alist))
- (line (concat (format-time-string rcirc-time-format)
+ (line (concat (format-time-string rcirc-time-format time)
(substring-no-properties
(rcirc-format-response-string process sender
response target text))
@@ -1770,14 +1993,17 @@ log-files with absolute names (see
`rcirc-log-filename-function')."
rcirc-log-directory)))
(defun rcirc-join-channels (process channels)
- "Join CHANNELS."
+ "Join CHANNELS.
+PROCESS is the process object for the current connection."
(save-window-excursion
(dolist (channel channels)
(with-rcirc-process-buffer process
(rcirc-cmd-join channel process)))))
;;; nick management
-(defvar rcirc-nick-prefix-chars "~&@%+")
+(defvar rcirc-nick-prefix-chars '(?~ ?& ?@ ?% ?+)
+ "List of junk characters to strip from nick prefixes.")
+
(defun rcirc-user-nick (user)
"Return the nick from USER. Remove any non-nick junk."
(save-match-data
@@ -1787,7 +2013,8 @@ log-files with absolute names (see
`rcirc-log-filename-function')."
user)))
(defun rcirc-nick-channels (process nick)
- "Return list of channels for NICK."
+ "Return list of channels for NICK.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(mapcar (lambda (x) (car x))
(gethash nick rcirc-nick-table))))
@@ -1797,7 +2024,7 @@ log-files with absolute names (see
`rcirc-log-filename-function')."
Update the associated linestamp if LINE is non-nil.
If the record doesn't exist, and LINE is nil, set the linestamp
-to zero."
+to zero. PROCESS is the process object for the current connection."
(let ((nick (rcirc-user-nick nick)))
(with-rcirc-process-buffer process
(let* ((chans (gethash nick rcirc-nick-table))
@@ -1809,12 +2036,14 @@ to zero."
rcirc-nick-table))))))
(defun rcirc-nick-remove (process nick)
- "Remove NICK from table."
+ "Remove NICK from table.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(remhash nick rcirc-nick-table)))
(defun rcirc-remove-nick-channel (process nick channel)
- "Remove the CHANNEL from list associated with NICK."
+ "Remove the CHANNEL from list associated with NICK.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(let* ((chans (gethash nick rcirc-nick-table))
(newchans
@@ -1828,7 +2057,8 @@ to zero."
(remhash nick rcirc-nick-table)))))
(defun rcirc-channel-nicks (process target)
- "Return the list of nicks associated with TARGET sorted by last activity."
+ "Return the list of nicks associated with TARGET sorted by last activity.
+PROCESS is the process object for the current connection."
(when target
(if (rcirc-channel-p target)
(with-rcirc-process-buffer process
@@ -1847,8 +2077,9 @@ to zero."
(list target))))
(defun rcirc-ignore-update-automatic (nick)
- "Remove NICK from `rcirc-ignore-list'
-if NICK is also on `rcirc-ignore-list-automatic'."
+ "Check if NICK is in `rcirc-ignore-list-automatic'.
+If so, remove from `rcirc-ignore-list'. PROCESS is the process
+object for the current connection."
(when (member nick rcirc-ignore-list-automatic)
(setq rcirc-ignore-list-automatic
(delete nick rcirc-ignore-list-automatic)
@@ -1856,7 +2087,7 @@ if NICK is also on `rcirc-ignore-list-automatic'."
(delete nick rcirc-ignore-list))))
(defun rcirc-nickname< (s1 s2)
- "Return t if IRC nickname S1 is less than S2, and nil otherwise.
+ "Return non-nil if IRC nickname S1 is less than S2, and nil otherwise.
Operator nicknames (@) are considered less than voiced
nicknames (+). Any other nicknames are greater than voiced
nicknames. The comparison is case-insensitive."
@@ -1878,7 +2109,7 @@ INPUT is a string containing nicknames separated by SEP.
This function does not alter the INPUT string."
(let* ((parts (split-string input sep t))
(sorted (sort parts 'rcirc-nickname<)))
- (mapconcat 'identity sorted sep)))
+ (mapconcat rcirc-nick-filter sorted sep)))
;;; activity tracking
(defvar rcirc-track-minor-mode-map
@@ -1906,12 +2137,8 @@ This function does not alter the INPUT string."
(remove-hook 'window-configuration-change-hook
'rcirc-window-configuration-change)))
-(or (assq 'rcirc-ignore-buffer-activity-flag minor-mode-alist)
- (setq minor-mode-alist
- (cons '(rcirc-ignore-buffer-activity-flag " Ignore")
minor-mode-alist)))
-(or (assq 'rcirc-low-priority-flag minor-mode-alist)
- (setq minor-mode-alist
- (cons '(rcirc-low-priority-flag " LowPri") minor-mode-alist)))
+(add-to-list 'minor-mode-alist '(rcirc-ignore-buffer-activity-flag " Ignore"))
+(add-to-list 'minor-mode-alist '(rcirc-low-priority-flag " LowPri"))
(defun rcirc-toggle-ignore-buffer-activity ()
"Toggle the value of `rcirc-ignore-buffer-activity-flag'."
@@ -1936,9 +2163,7 @@ This function does not alter the INPUT string."
(defun rcirc-switch-to-server-buffer ()
"Switch to the server buffer associated with current channel buffer."
(interactive)
- (unless (buffer-live-p rcirc-server-buffer)
- (error "No such buffer"))
- (switch-to-buffer rcirc-server-buffer))
+ (switch-to-buffer (with-rcirc-server-buffer (current-buffer))))
(defun rcirc-jump-to-first-unread-line ()
"Move the point to the first unread line in this buffer."
@@ -1974,7 +2199,8 @@ With prefix ARG, go to the next low priority buffer with
activity."
(concat
" Type C-u " (key-description (this-command-keys))
" for low priority activity.")
- "")))))
+ ""))))
+ (rcirc-update-activity-string))
(define-obsolete-variable-alias 'rcirc-activity-hooks
'rcirc-activity-functions "24.3")
@@ -2030,7 +2256,6 @@ activity. Only run if the buffer is not visible and
(defvar rcirc-update-activity-string-hook nil
"Hook run whenever the activity string is updated.")
-;; TODO: add mouse properties
(defun rcirc-update-activity-string ()
"Update mode-line string."
(let* ((pair (rcirc-split-activity rcirc-activity))
@@ -2049,19 +2274,26 @@ activity. Only run if the buffer is not visible and
((not (null (rcirc-process-list)))
"[]")
(t "[]")))
- (run-hooks 'rcirc-update-activity-string-hook)))
+ (run-hooks 'rcirc-update-activity-string-hook)
+ (force-mode-line-update t)))
(defun rcirc-activity-string (buffers)
+ "Generate activity string for all BUFFERS."
(mapconcat (lambda (b)
(let ((s (substring-no-properties (rcirc-short-buffer-name b))))
(with-current-buffer b
(dolist (type rcirc-activity-types)
- (rcirc-add-face 0 (length s)
- (cl-case type
+ (rcirc-facify s (cl-case type
(nick 'rcirc-track-nick)
- (keyword 'rcirc-track-keyword))
- s)))
- s))
+ (keyword 'rcirc-track-keyword)))))
+ (let ((map (make-mode-line-mouse-map
+ 'mouse-1
+ (lambda ()
+ (interactive)
+ (pop-to-buffer b)))))
+ (propertize s
+ 'mouse-face 'mode-line-highlight
+ 'local-map map))))
buffers ","))
(defun rcirc-short-buffer-name (buffer)
@@ -2070,7 +2302,7 @@ activity. Only run if the buffer is not visible and
(or rcirc-short-buffer-name (buffer-name))))
(defun rcirc-visible-buffers ()
- "Return a list of the visible buffers that are in rcirc-mode."
+ "Return a list of the visible buffers that are in `rcirc-mode'."
(let (acc)
(walk-windows (lambda (w)
(with-current-buffer (window-buffer w)
@@ -2078,13 +2310,16 @@ activity. Only run if the buffer is not visible and
(push (current-buffer) acc)))))
acc))
-(defvar rcirc-visible-buffers nil)
+(defvar rcirc-visible-buffers nil
+ "List of visible IRC buffers.")
+
(defun rcirc-window-configuration-change ()
+ "Clear activity and overlay arrows, unless minibuffer is active."
(unless (minibuffer-window-active-p (minibuffer-window))
(rcirc-window-configuration-change-1)))
(defun rcirc-window-configuration-change-1 ()
- ;; clear activity and overlay arrows
+ "Clear activity and overlay arrows."
(let* ((old-activity rcirc-activity)
(hidden-buffers rcirc-visible-buffers))
@@ -2110,6 +2345,7 @@ activity. Only run if the buffer is not visible and
;;; buffer name abbreviation
(defun rcirc-update-short-buffer-names ()
+ "Update variable `rcirc-short-buffer-name' for IRC buffers."
(let ((bufalist
(apply 'append (mapcar (lambda (process)
(with-rcirc-process-buffer process
@@ -2121,10 +2357,15 @@ activity. Only run if the buffer is not visible and
(setq rcirc-short-buffer-name (car i)))))))
(defun rcirc-abbreviate (pairs)
+ "Generate alist of abbreviated buffer names to buffers.
+PAIRS is the concatenated value of all `rcirc-buffer-alist'
+values, from each process."
(apply 'append (mapcar 'rcirc-rebuild-tree (rcirc-make-trees pairs))))
-(defun rcirc-rebuild-tree (tree &optional acc)
- (let ((ch (char-to-string (car tree))))
+(defun rcirc-rebuild-tree (tree)
+ "Merge prefix TREE into alist of unique prefixes to buffers."
+ (let ((ch (char-to-string (car tree)))
+ acc)
(dolist (x (cdr tree))
(if (listp x)
(setq acc (append acc
@@ -2136,6 +2377,12 @@ activity. Only run if the buffer is not visible and
acc))
(defun rcirc-make-trees (pairs)
+ "Generate tree prefix tree of buffer names.
+PAIRS is a list of (TARGET . BUFFER) entries. The resulting tree
+is a list of (CHAR . CHILDREN) cons-cells, where CHAR is the
+leading character and CHILDREN is either BUFFER when a unique
+prefix could be found or another tree if it shares the same
+prefix with another element in PAIRS."
(let (alist)
(mapc (lambda (pair)
(if (consp pair)
@@ -2168,50 +2415,85 @@ activity. Only run if the buffer is not visible and
;; the current buffer/channel/user, and ARGS, which is a string
;; containing the text following the /cmd.
-(defmacro defun-rcirc-command (command argument docstring interactive-form
- &rest body)
- "Define a command."
- `(progn
- (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command)))
- (defun ,(intern (concat "rcirc-cmd-" (symbol-name command)))
- (,@argument &optional process target)
- ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values
given"
- "\nby `rcirc-buffer-process' and `rcirc-target' will be used.")
- ,interactive-form
- (let ((process (or process (rcirc-buffer-process)))
- (target (or target rcirc-target)))
- (ignore target) ; mark `target' variable as ignorable
- ,@body))))
-
-(defun-rcirc-command msg (message)
- "Send private MESSAGE to TARGET."
- (interactive "i")
- (if (null message)
- (progn
- (setq target (completing-read "Message nick: "
+(defmacro rcirc-define-command (command arguments &rest body)
+ "Define a new client COMMAND in BODY that takes ARGUMENTS.
+ARGUMENTS may designate optional arguments using a single
+`&optional' symbol. Just like `defun', a string at the beginning
+of BODY is interpreted as the documentation string. Following
+that, an interactive form can specified."
+ (declare (debug (symbolp (&rest symbolp) def-body))
+ (indent defun))
+ (cl-check-type command symbol)
+ (cl-check-type arguments list)
+ (let* ((fn-name (intern (concat "rcirc-cmd-" (symbol-name command))))
+ (total (length (remq '&optional arguments)))
+ (required (- (length arguments) (length (memq '&optional arguments))))
+ (optional (- total required))
+ (regexp (with-temp-buffer
+ (insert "\\`")
+ (when arguments
+ (dotimes (_ (1- (length arguments)))
+ (insert "\\(?:\\(.+?\\)[[:space:]]+"))
+ (dotimes (i (1- (length arguments)))
+ (if (< i optional)
+ (insert "\\)?")
+ (insert "\\)"))))
+ (insert "\\(.*?\\)")
+ (insert "[[:space:]]*\\'")
+ (buffer-string)))
+ (argument (gensym))
+ documentation
+ interactive-spec)
+ (when (stringp (car body))
+ (setq documentation (pop body)))
+ (when (eq (car-safe (car-safe body)) 'interactive)
+ (setq interactive-spec (cdr (pop body))))
+ `(progn
+ (defun ,fn-name (,argument &optional process target)
+ ,(concat documentation
+ "\n\nNote: If PROCESS or TARGET are nil, the values given"
+ "\nby `rcirc-buffer-process' and `rcirc-target' will be
used.")
+ (interactive (list ,@interactive-spec))
+ (unless (if (listp ,argument)
+ (<= ,required (length ,argument) ,total)
+ (string-match ,regexp ,argument))
+ (user-error "Malformed input (%s): %S" ',command ',argument))
+ (let ((process (or process (rcirc-buffer-process)))
+ (target (or target rcirc-target)))
+ (ignore target process)
+ (let (,@(cl-loop
+ for i from 0 for arg in (delq '&optional arguments)
+ collect `(,arg (if (listp ,argument)
+ (nth ,i ,argument)
+ (match-string ,(1+ i) ,argument)))))
+ ,@body)))
+ (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name
command))))))
+
+(define-obsolete-function-alias
+ 'defun-rcirc-command
+ 'rcirc-define-command
+ "28.1")
+
+(rcirc-define-command msg (chan-or-nick message)
+ "Send MESSAGE to CHAN-OR-NICK."
+ (interactive (list (completing-read "Message nick: "
(with-rcirc-server-buffer
- rcirc-nick-table)))
- (when (> (length target) 0)
- (setq message (read-string (format "Message %s: " target)))
- (when (> (length message) 0)
- (rcirc-send-message process target message))))
- (if (not (string-match "\\([^ ]+\\) \\(.+\\)" message))
- (message "Not enough args, or something.")
- (setq target (match-string 1 message)
- message (match-string 2 message))
- (rcirc-send-message process target message))))
-
-(defun-rcirc-command query (nick)
+ rcirc-nick-table))
+ (read-string "Message: ")))
+ (rcirc-send-message process chan-or-nick message))
+
+(rcirc-define-command query (nick)
"Open a private chat buffer to NICK."
(interactive (list (completing-read "Query nick: "
- (with-rcirc-server-buffer
rcirc-nick-table))))
+ (with-rcirc-server-buffer
+ rcirc-nick-table))))
(let ((existing-buffer (rcirc-get-buffer process nick)))
(switch-to-buffer (or existing-buffer
(rcirc-get-buffer-create process nick)))
(when (not existing-buffer)
(rcirc-cmd-whois nick))))
-(defun-rcirc-command join (channels)
+(rcirc-define-command join (channels)
"Join CHANNELS.
CHANNELS is a comma- or space-separated string of channel names."
(interactive "sJoin channels: ")
@@ -2220,46 +2502,35 @@ CHANNELS is a comma- or space-separated string of
channel names."
(rcirc-get-buffer-create process ch))
split-channels))
(channels (mapconcat 'identity split-channels ",")))
- (rcirc-send-string process (concat "JOIN " channels))
+ (rcirc-send-string process "JOIN" channels)
(when (not (eq (selected-window) (minibuffer-window)))
(dolist (b buffers) ;; order the new channel buffers in the buffer list
(switch-to-buffer b)))))
-(defun-rcirc-command invite (nick-channel)
+(rcirc-define-command invite (nick channel)
"Invite NICK to CHANNEL."
(interactive (list
- (concat
- (completing-read "Invite nick: "
- (with-rcirc-server-buffer rcirc-nick-table))
- " "
- (read-string "Channel: "))))
- (rcirc-send-string process (concat "INVITE " nick-channel)))
-
-(defun-rcirc-command part (channel)
+ (completing-read "Invite nick: "
+ (with-rcirc-server-buffer rcirc-nick-table))
+ (read-string "Channel: ")))
+ (rcirc-send-string process "INVITE" nick channel))
+
+(rcirc-define-command part (&optional channel reason)
"Part CHANNEL.
CHANNEL should be a string of the form \"#CHANNEL-NAME REASON\".
If omitted, CHANNEL-NAME defaults to TARGET, and REASON defaults
to `rcirc-default-part-reason'."
- (interactive "sPart channel: ")
- (let ((channel (if (> (length channel) 0) channel target))
- (msg rcirc-default-part-reason))
- (when (string-match "\\`\\([&#+!]\\S-+\\)?\\s-*\\(.+\\)?\\'" channel)
- (when (match-beginning 2)
- (setq msg (match-string 2 channel)))
- (setq channel (if (match-beginning 1)
- (match-string 1 channel)
- target)))
- (rcirc-send-string process (concat "PART " channel " :" msg))))
-
-(defun-rcirc-command quit (reason)
+ (interactive "sPart channel: \nsReason: ")
+ (rcirc-send-string process "PART" (or channel target)
+ : (or reason rcirc-default-part-reason)))
+
+(rcirc-define-command quit (&optional reason)
"Send a quit message to server with REASON."
(interactive "sQuit reason: ")
- (rcirc-send-string process (concat "QUIT :"
- (if (not (zerop (length reason)))
- reason
- rcirc-default-quit-reason))))
+ (rcirc-send-string process "QUIT"
+ : (or reason rcirc-default-quit-reason)))
-(defun-rcirc-command reconnect (_)
+(rcirc-define-command reconnect ()
"Reconnect to current server."
(interactive "i")
(with-rcirc-server-buffer
@@ -2270,79 +2541,73 @@ to `rcirc-default-part-reason'."
(setf (nth 5 conn-info)
(cl-remove-if-not #'rcirc-channel-p
(mapcar #'car rcirc-buffer-alist)))
+ (dolist (buf (nth 5 conn-info))
+ (with-current-buffer (cdr (assoc buf rcirc-buffer-alist))
+ (setq rcirc-reconncting t)))
(apply #'rcirc-connect conn-info))))))
-(defun-rcirc-command nick (nick)
+(rcirc-define-command nick (nick)
"Change nick to NICK."
- (interactive "i")
- (when (null nick)
- (setq nick (read-string "New nick: " (rcirc-nick process))))
- (rcirc-send-string process (concat "NICK " nick)))
+ (interactive (list (read-string "New nick: ")))
+ (rcirc-send-string process "NICK" nick))
-(defun-rcirc-command names (channel)
+(rcirc-define-command names (&optional channel)
"Display list of names in CHANNEL or in current channel if CHANNEL is nil.
If called interactively, prompt for a channel when prefix arg is supplied."
- (interactive "P")
- (if (called-interactively-p 'interactive)
- (if channel
- (setq channel (read-string "List names in channel: " target))))
- (let ((channel (if (> (length channel) 0)
- channel
- target)))
- (rcirc-send-string process (concat "NAMES " channel))))
-
-(defun-rcirc-command topic (topic)
+ (interactive (list (and current-prefix-arg
+ (read-string "List names in channel: "))))
+ (rcirc-send-string process "NAMES" (or channel target)))
+
+(rcirc-define-command topic (topic)
"List TOPIC for the TARGET channel.
With a prefix arg, prompt for new topic."
- (interactive "P")
- (if (and (called-interactively-p 'interactive) topic)
- (setq topic (read-string "New Topic: " rcirc-topic)))
- (rcirc-send-string process (concat "TOPIC " target
- (when (> (length topic) 0)
- (concat " :" topic)))))
+ (interactive (list (and current-prefix-arg
+ (read-string "List names in channel: "))))
+ (if (> (length topic) 0)
+ (rcirc-send-string process "TOPIC" : topic)
+ (rcirc-send-string process "TOPIC")))
-(defun-rcirc-command whois (nick)
+(rcirc-define-command whois (nick)
"Request information from server about NICK."
- (interactive (list
- (completing-read "Whois: "
- (with-rcirc-server-buffer rcirc-nick-table))))
- (rcirc-send-string process (concat "WHOIS " nick)))
-
-(defun-rcirc-command mode (args)
- "Set mode with ARGS."
- (interactive (list (concat (read-string "Mode nick or channel: ")
- " " (read-string "Mode: "))))
- (rcirc-send-string process (concat "MODE " args)))
-
-(defun-rcirc-command list (channels)
+ (interactive (list (completing-read
+ "Whois: "
+ (with-rcirc-server-buffer rcirc-nick-table))))
+ (rcirc-send-string process "WHOIS" nick))
+
+(rcirc-define-command mode (nick-or-chan mode)
+ "Set NICK-OR-CHAN mode to MODE."
+ (interactive (list (read-string "Mode nick or channel: ")
+ (read-string "Mode: ")))
+ (rcirc-send-string process "MODE" nick-or-chan mode))
+
+(rcirc-define-command list (channels)
"Request information on CHANNELS from server."
(interactive "sList Channels: ")
- (rcirc-send-string process (concat "LIST " channels)))
+ (rcirc-send-string process "LIST" channels))
-(defun-rcirc-command oper (args)
+(rcirc-define-command oper (args)
"Send operator command to server."
(interactive "sOper args: ")
- (rcirc-send-string process (concat "OPER " args)))
+ (rcirc-send-string process "OPER" args))
-(defun-rcirc-command quote (message)
+(rcirc-define-command quote (message)
"Send MESSAGE literally to server."
(interactive "sServer message: ")
(rcirc-send-string process message))
-(defun-rcirc-command kick (arg)
+(rcirc-define-command kick (nick reason)
"Kick NICK from current channel."
(interactive (list
- (concat (completing-read "Kick nick: "
- (rcirc-channel-nicks
- (rcirc-buffer-process)
- rcirc-target))
- (read-from-minibuffer "Kick reason: "))))
- (let* ((arglist (split-string arg))
- (argstring (concat (car arglist) " :"
- (mapconcat 'identity (cdr arglist) " "))))
- (rcirc-send-string process (concat "KICK " target " " argstring))))
+ (completing-read "Kick nick: "
+ (rcirc-channel-nicks
+ (rcirc-buffer-process)
+ rcirc-target))
+ (read-from-minibuffer "Kick reason: ")))
+ (rcirc-send-string process "KICK" target nick : reason))
(defun rcirc-cmd-ctcp (args &optional process _target)
+ "Handle ARGS as a CTCP command.
+PROCESS is the process object for the current connection."
(if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args)
(let* ((target (match-string 1 args))
(request (upcase (match-string 2 args)))
@@ -2354,14 +2619,18 @@ With a prefix arg, prompt for new topic."
"usage: /ctcp NICK REQUEST")))
(defun rcirc-ctcp-sender-PING (process target _request)
- "Send a CTCP PING message to TARGET."
+ "Send a CTCP PING message to TARGET.
+PROCESS is the process object for the current connection."
(let ((timestamp (format-time-string "%s")))
(rcirc-send-ctcp process target "PING" timestamp)))
(defun rcirc-cmd-me (args process target)
+ "Send an action message ARGS to TARGET.
+PROCESS is the process object for the current connection."
(when target (rcirc-send-ctcp process target "ACTION" args)))
(defun rcirc-add-or-remove (set &rest elements)
+ "Toggle membership of ELEMENTS in SET."
(dolist (elt elements)
(if (and elt (not (string= "" elt)))
(setq set (if (member-ignore-case elt set)
@@ -2369,7 +2638,8 @@ With a prefix arg, prompt for new topic."
(cons elt set)))))
set)
-(defun-rcirc-command ignore (nick)
+
+(rcirc-define-command ignore (nick)
"Manage the ignore list.
Ignore NICK, unignore NICK if already ignored, or list ignored
nicks when no NICK is given. When listing ignored nicks, the
@@ -2386,7 +2656,7 @@ ones added to the list automatically are marked with an
asterisk."
"*" "")))
rcirc-ignore-list " ")))
-(defun-rcirc-command bright (nick)
+(rcirc-define-command bright (nick)
"Manage the bright nick list."
(interactive "sToggle emphasis of nick: ")
(setq rcirc-bright-nicks
@@ -2395,7 +2665,7 @@ ones added to the list automatically are marked with an
asterisk."
(rcirc-print process nil "BRIGHT" target
(mapconcat 'identity rcirc-bright-nicks " ")))
-(defun-rcirc-command dim (nick)
+(rcirc-define-command dim (nick)
"Manage the dim nick list."
(interactive "sToggle deemphasis of nick: ")
(setq rcirc-dim-nicks
@@ -2404,7 +2674,7 @@ ones added to the list automatically are marked with an
asterisk."
(rcirc-print process nil "DIM" target
(mapconcat 'identity rcirc-dim-nicks " ")))
-(defun-rcirc-command keyword (keyword)
+(rcirc-define-command keyword (keyword)
"Manage the keyword list.
Mark KEYWORD, unmark KEYWORD if already marked, or list marked
keywords when no KEYWORD is given."
@@ -2479,28 +2749,85 @@ If ARG is given, opens the URL in a new browser window."
arg)))
(defun rcirc-markup-timestamp (_sender _response)
+ "Insert a timestamp."
(goto-char (point-min))
- (insert (rcirc-facify (format-time-string rcirc-time-format)
- 'rcirc-timestamp)))
+ (let ((time (and-let* ((time (rcirc-get-tag "time")))
+ (parse-iso8601-time-string time))))
+ (insert (rcirc-facify (format-time-string rcirc-time-format time)
+ 'rcirc-timestamp))))
(defun rcirc-markup-attributes (_sender _response)
- (while (re-search-forward "\\([\C-b\C-_\C-v]\\).*?\\(\\1\\|\C-o\\)" nil t)
+ "Highlight IRC markup, indicated by ASCII control codes."
+ (while (re-search-forward
+ (rx (group (or #x02 #x1d #x1f #x1e #x11))
+ (*? nonl)
+ (group (or (backref 1) (+ #x0f) eol)))
+ nil t)
(rcirc-add-face (match-beginning 0) (match-end 0)
- (cl-case (char-after (match-beginning 1))
- (?\C-b 'bold)
- (?\C-v 'italic)
- (?\C-_ 'underline)))
- ;; keep the ^O since it could terminate other attributes
- (when (not (eq ?\C-o (char-before (match-end 2))))
- (delete-region (match-beginning 2) (match-end 2)))
- (delete-region (match-beginning 1) (match-end 1))
- (goto-char (match-beginning 1)))
- ;; remove the ^O characters now
- (goto-char (point-min))
- (while (re-search-forward "\C-o+" nil t)
+ (cl-case (char-after (match-beginning 0))
+ (#x02 'bold)
+ (#x1d 'italic)
+ (#x1f 'underline)
+ (#x1e '(:strike-through t))
+ (#x11 'rcirc-monospace-text)))
+ (goto-char (1+ (match-beginning 0)))))
+
+(defconst rcirc-color-codes
+ ;; Taken from https://modern.ircdocs.horse/formatting.html
+ ["white" "black" "blue" "green" "red" "brown" "magenta"
+ "orange" "yellow" "light green" "cyan" "light cyan"
+ "light blue" "pink" "grey" "light grey"
+ "#470000" "#472100" "#474700" "#324700" "#004700" "#00472c"
+ "#004747" "#002747" "#000047" "#2e0047" "#470047" "#47002a"
+ "#740000" "#743a00" "#747400" "#517400" "#007400" "#007449"
+ "#007474" "#004074" "#000074" "#4b0074" "#740074" "#740045"
+ "#b50000" "#b56300" "#b5b500" "#7db500" "#00b500" "#00b571"
+ "#00b5b5" "#0063b5" "#0000b5" "#7500b5" "#b500b5" "#b5006b"
+ "#ff0000" "#ff8c00" "#ffff00" "#b2ff00" "#00ff00" "#00ffa0"
+ "#00ffff" "#008cff" "#0000ff" "#a500ff" "#ff00ff" "#ff0098"
+ "#ff5959" "#ffb459" "#ffff71" "#cfff60" "#6fff6f" "#65ffc9"
+ "#6dffff" "#59b4ff" "#5959ff" "#c459ff" "#ff66ff" "#ff59bc"
+ "#ff9c9c" "#ffd39c" "#ffff9c" "#e2ff9c" "#9cff9c" "#9cffdb"
+ "#9cffff" "#9cd3ff" "#9c9cff" "#dc9cff" "#ff9cff" "#ff94d3"
+ "#000000" "#131313" "#282828" "#363636" "#4d4d4d" "#656565"
+ "#818181" "#9f9f9f" "#bcbcbc" "#e2e2e2" "#ffffff"]
+ "Vector of colors for each IRC color code.")
+
+(defun rcirc-color-attributes (_sender _response)
+ "Highlight IRC color-codes, indicated by ASCII control codes."
+ (while (re-search-forward
+ (rx #x03
+ (? (group (= 2 digit)) (? "," (group (= 2 digit))))
+ (*? nonl)
+ (or #x03 #x0f eol))
+ nil t)
+ (let (foreground background)
+ (when-let ((fg-raw (match-string 1))
+ (fg (string-to-number fg-raw))
+ ((<= 0 fg (1- (length rcirc-color-codes)))))
+ (setq foreground (aref rcirc-color-codes fg)))
+ (when-let ((bg-raw (match-string 2))
+ (bg (string-to-number bg-raw))
+ ((<= 0 bg (1- (length rcirc-color-codes)))))
+ (setq background (aref rcirc-color-codes bg)))
+ (rcirc-add-face (match-beginning 0) (match-end 0)
+ `(face (:foreground
+ ,foreground
+ :background
+ ,background))))))
+
+(defun rcirc-remove-markup-codes (_sender _response)
+ "Remove ASCII control codes used to designate markup."
+ (while (re-search-forward
+ (rx (or #x02 #x1d #x1f #x1e #x11 #x0f
+ (: #x03 (? (= 2 digit) (? "," (= 2 digit))))))
+ nil t)
(delete-region (match-beginning 0) (match-end 0))))
(defun rcirc-markup-my-nick (_sender response)
+ "Highlight the users nick.
+If RESPONSE indicates that the nick was mentioned in a message,
+highlight the entire line and record the activity."
(with-syntax-table rcirc-nick-syntax-table
(while (re-search-forward (concat "\\b"
(regexp-quote (rcirc-nick
@@ -2515,6 +2842,7 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-record-activity (current-buffer) 'nick)))))
(defun rcirc-markup-urls (_sender _response)
+ "Highlight and activate URLs."
(while (and rcirc-url-regexp ; nil means disable URL catching.
(re-search-forward rcirc-url-regexp nil t))
(let* ((start (match-beginning 0))
@@ -2538,6 +2866,10 @@ If ARG is given, opens the URL in a new browser window."
(push (cons url start) rcirc-urls)))))
(defun rcirc-markup-keywords (sender response)
+ "Highlight keywords as specified by `rcirc-keywords'.
+Keywords are only highlighted in messages (as indicated by
+RESPONSE) when they were not written by the user (as indicated by
+SENDER)."
(when (and (string= response "PRIVMSG")
(not (string= sender (rcirc-nick (rcirc-buffer-process)))))
(let* ((target (or rcirc-target ""))
@@ -2552,6 +2884,9 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-record-activity (current-buffer) 'keyword))))))
(defun rcirc-markup-bright-nicks (_sender response)
+ "Highlight nicks brightly as specified by `rcirc-bright-nicks'.
+This highlighting only takes place in name lists (as indicated by
+RESPONSE)."
(when (and rcirc-bright-nicks
(string= response "NAMES"))
(with-syntax-table rcirc-nick-syntax-table
@@ -2560,6 +2895,8 @@ If ARG is given, opens the URL in a new browser window."
'rcirc-bright-nick)))))
(defun rcirc-markup-fill (_sender response)
+ "Fill messages as configured by `rcirc-fill-column'.
+MOTD messages are not filled (as indicated by RESPONSE)."
(when (not (string= response "372")) ; /motd
(let ((fill-prefix
(or rcirc-fill-prefix
@@ -2577,8 +2914,11 @@ If ARG is given, opens the URL in a new browser window."
;; server or a user, depending on the command, the ARGS, which is a
;; list of strings, and the TEXT, which is the original server text,
;; verbatim
-(defun rcirc-handler-001 (process sender args text)
- (rcirc-handler-generic process "001" sender args text)
+(defun rcirc-handler-001 (process sender args _text)
+ "Handle welcome message.
+SENDER and ARGS are used to initialize the current connection.
+PROCESS is the process object for the current connection."
+ (rcirc-handler-generic process "001" sender args nil)
(with-rcirc-process-buffer process
(setq rcirc-connecting nil)
(rcirc-reschedule-timeout process)
@@ -2602,11 +2942,16 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-join-channels process rcirc-startup-channels))))
(defun rcirc-join-channels-post-auth (process)
- "Join `rcirc-startup-channels' after authenticating."
+ "Join `rcirc-startup-channels' after authenticating.
+PROCESS is the process object for the current connection."
(with-rcirc-process-buffer process
(rcirc-join-channels process rcirc-startup-channels)))
(defun rcirc-handler-PRIVMSG (process sender args text)
+ "Handle a (private) message from SENDER.
+ARGS should have the form (TARGET MESSAGE). TEXT is the verbatim
+message as received from the server. PROCESS is the process
+object for the current connection."
(rcirc-check-auth-status process sender args text)
(let ((target (if (rcirc-channel-p (car args))
(car args)
@@ -2620,6 +2965,10 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-put-nick-channel process sender target rcirc-current-line))))
(defun rcirc-handler-NOTICE (process sender args text)
+ "Handle a notice message from SENDER.
+ARGS should have the form (TARGET MESSAGE).
+TEXT is the verbatim message as received from the server.
+PROCESS is the process object for the current connection."
(rcirc-check-auth-status process sender args text)
(let ((target (car args))
(message (cadr args)))
@@ -2629,7 +2978,7 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-print process sender "NOTICE"
(cond ((rcirc-channel-p target)
target)
- ;;; -ChanServ- [#gnu] Welcome...
+ ;; -ChanServ- [#gnu] Welcome...
((string-match "\\[\\(#[^] ]+\\)\\]" message)
(match-string 1 message))
(sender
@@ -2641,7 +2990,9 @@ If ARG is given, opens the URL in a new browser window."
(defun rcirc-check-auth-status (process sender args _text)
"Check if the user just authenticated.
If authenticated, runs `rcirc-authenticated-hook' with PROCESS as
-the only argument."
+the only argument. ARGS should have the form (TARGET MESSAGE).
+SENDER is used the determine the authentication method. PROCESS
+is the process object for the current connection."
(with-rcirc-process-buffer process
(when (and (not rcirc-user-authenticated)
rcirc-authenticate-before-join
@@ -2671,9 +3022,17 @@ the only argument."
(remove-hook 'rcirc-authenticated-hook
'rcirc-join-channels-post-auth t))))))
(defun rcirc-handler-WALLOPS (process sender args _text)
+ "Handle WALLOPS message from SENDER.
+ARGS should have the form (MESSAGE).
+PROCESS is the process object for the current
+connection."
(rcirc-print process sender "WALLOPS" sender (car args) t))
(defun rcirc-handler-JOIN (process sender args _text)
+ "Handle JOIN message from SENDER.
+ARGS should have the form (CHANNEL).
+PROCESS is the process object for the current
+connection."
(let ((channel (car args)))
(with-current-buffer (rcirc-get-buffer-create process channel)
;; when recently rejoining, restore the linestamp
@@ -2695,6 +3054,8 @@ the only argument."
;; PART and KICK are handled the same way
(defun rcirc-handler-PART-or-KICK (process _response channel _sender nick
_args)
+ "Remove NICK from CHANNEL.
+PROCESS is the process object for the current connection."
(rcirc-ignore-update-automatic nick)
(if (not (string= nick (rcirc-nick process)))
;; this is someone else leaving
@@ -2712,6 +3073,9 @@ the only argument."
(rcirc-disconnect-buffer buffer)))))
(defun rcirc-handler-PART (process sender args _text)
+ "Handle PART message from SENDER.
+ARGS should have the form (CHANNEL REASON).
+PROCESS is the process object for the current connection."
(let* ((channel (car args))
(reason (cadr args))
(message (concat channel " " reason)))
@@ -2723,6 +3087,9 @@ the only argument."
(rcirc-handler-PART-or-KICK process "PART" channel sender sender reason)))
(defun rcirc-handler-KICK (process sender args _text)
+ "Handle PART message from SENDER.
+ARGS should have the form (CHANNEL NICK REASON).
+PROCESS is the process object for the current connection."
(let* ((channel (car args))
(nick (cadr args))
(reason (nth 2 args))
@@ -2735,7 +3102,8 @@ the only argument."
(rcirc-handler-PART-or-KICK process "KICK" channel sender nick reason)))
(defun rcirc-maybe-remember-nick-quit (process nick channel)
- "Remember NICK as leaving CHANNEL if they recently spoke."
+ "Remember NICK as leaving CHANNEL if they recently spoke.
+PROCESS is the process object for the current connection."
(let ((elapsed-lines (rcirc-elapsed-lines process nick channel)))
(when (and elapsed-lines
(< elapsed-lines rcirc-omit-threshold))
@@ -2751,6 +3119,8 @@ the only argument."
rcirc-recent-quit-alist))))))))))
(defun rcirc-handler-QUIT (process sender args _text)
+ "Handle QUIT message from SENDER.
+PROCESS is the process object for the current connection."
(rcirc-ignore-update-automatic sender)
(mapc (lambda (channel)
;; broadcast quit message each channel
@@ -2761,6 +3131,9 @@ the only argument."
(rcirc-nick-remove process sender))
(defun rcirc-handler-NICK (process sender args _text)
+ "Handle NICK message from SENDER.
+ARGS should have the form (NEW-NICK).
+PROCESS is the process object for the current connection."
(let* ((old-nick sender)
(new-nick (car args))
(channels (rcirc-nick-channels process old-nick)))
@@ -2792,21 +3165,30 @@ the only argument."
(when rcirc-auto-authenticate-flag (rcirc-authenticate))))))
(defun rcirc-handler-PING (process _sender args _text)
- (rcirc-send-string process (concat "PONG :" (car args))))
+ "Respond to a PING with a PONG.
+ARGS should have the form (MESSAGE). MESSAGE is relayed back to
+the server. PROCESS is the process object for the current
+connection."
+ (rcirc-send-string process "PONG" : (car args)))
(defun rcirc-handler-PONG (_process _sender _args _text)
- ;; do nothing
- )
+ "Ignore all incoming PONG messages.")
(defun rcirc-handler-TOPIC (process sender args _text)
+ "Note the topic change from SENDER.
+PROCESS is the process object for the current connection."
(let ((topic (cadr args)))
(rcirc-print process sender "TOPIC" (car args) topic)
(with-current-buffer (rcirc-get-buffer process (car args))
(setq rcirc-topic topic))))
-(defvar rcirc-nick-away-alist nil)
+(defvar rcirc-nick-away-alist nil
+ "Alist from nicks to away messages.")
+
(defun rcirc-handler-301 (process _sender args text)
- "RPL_AWAY"
+ "Handle away messages (RPL_AWAY).
+ARGS should have the form (NICK AWAY-MESSAGE).
+PROCESS is the process object for the current connection."
(let* ((nick (cadr args))
(rec (assoc-string nick rcirc-nick-away-alist))
(away-message (nth 2 args)))
@@ -2820,7 +3202,9 @@ the only argument."
rcirc-nick-away-alist))))))
(defun rcirc-handler-317 (process sender args _text)
- "RPL_WHOISIDLE"
+ "Handle idle messages from SENDER (RPL_WHOISIDLE).
+ARGS should have the form (NICK IDLE-SECS SIGNON-TIME).
+PROCESS is the process object for the current connection."
(let* ((nick (nth 1 args))
(idle-secs (string-to-number (nth 2 args)))
(idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs))
@@ -2831,15 +3215,20 @@ the only argument."
(rcirc-print process sender "317" nil message t)))
(defun rcirc-handler-332 (process _sender args _text)
- "RPL_TOPIC"
+ "Update topic when notified by server (RPL_TOPIC).
+ARGS should have the form (CHANNEL TOPIC).
+PROCESS is the process object for the current connection."
(let ((buffer (or (rcirc-get-buffer process (cadr args))
(rcirc-get-temp-buffer-create process (cadr args)))))
(with-current-buffer buffer
(setq rcirc-topic (nth 2 args)))))
(defun rcirc-handler-333 (process sender args _text)
- "333 says who set the topic and when.
-Not in rfc1459.txt"
+ "Update when and who set the current topic.
+ARGS has the form (CHANNEL SETTER TIME). SENDER is passed on to
+`rcirc-print'. PROCESS is the process object for the current
+connection. This is a non-standard extension, not specified in
+RFC1459."
(let ((buffer (or (rcirc-get-buffer process (cadr args))
(rcirc-get-temp-buffer-create process (cadr args)))))
(with-current-buffer buffer
@@ -2850,10 +3239,17 @@ Not in rfc1459.txt"
(format "%s (%s on %s)" rcirc-topic setter time))))))
(defun rcirc-handler-477 (process sender args _text)
- "ERR_NOCHANMODES"
+ "Notify user that CHANNEL does not support modes (ERR_NOCHANMODES).
+ARGS has the form (CHANNEL MESSAGE). SENDER is passed on to
+`rcirc-print'. PROCESS is the process object for the current
+connection."
(rcirc-print process sender "477" (cadr args) (nth 2 args)))
(defun rcirc-handler-MODE (process sender args _text)
+ "Handle MODE messages.
+ARGS should have the form (TARGET . MESSAGE-LIST).
+SENDER is passed on to `rcirc-print'.
+PROCESS is the process object for the current connection."
(let ((target (car args))
(msg (mapconcat 'identity (cdr args) " ")))
(rcirc-print process sender "MODE"
@@ -2874,7 +3270,9 @@ Not in rfc1459.txt"
(get-buffer-create tmpnam)))
(defun rcirc-handler-353 (process _sender args _text)
- "RPL_NAMREPLY"
+ "Start handling list of users (RPL_NAMREPLY).
+ARGS should have the form (TYPE CHANNEL . NICK-LIST).
+PROCESS is the process object for the current connection."
(let ((channel (nth 2 args))
(names (or (nth 3 args) "")))
(mapc (lambda (nick)
@@ -2887,7 +3285,9 @@ Not in rfc1459.txt"
(insert (car (last args)) " "))))
(defun rcirc-handler-366 (process sender args _text)
- "RPL_ENDOFNAMES"
+ "Handle end of user list (RPL_ENDOFNAMES).
+SENDER is passed on to `rcirc-print'.
+PROCESS is the process object for the current connection."
(let* ((channel (cadr args))
(buffer (rcirc-get-temp-buffer-create process channel)))
(with-current-buffer buffer
@@ -2897,7 +3297,10 @@ Not in rfc1459.txt"
(kill-buffer buffer)))
(defun rcirc-handler-433 (process sender args text)
- "ERR_NICKNAMEINUSE"
+ "Warn user that nick is used (ERR_NICKNAMEINUSE).
+ARGS should have the form (NICK CHANNEL WARNING).
+SENDER is passed on to `rcirc-handler-generic'.
+PROCESS is the process object for the current connection."
(rcirc-handler-generic process "433" sender args text)
(with-rcirc-process-buffer process
(let* ((length (string-to-number
@@ -2906,8 +3309,10 @@ Not in rfc1459.txt"
(rcirc-cmd-nick (rcirc--make-new-nick (cadr args) length) nil process))))
(defun rcirc--make-new-nick (nick length)
- ;; If we already have some ` chars at the end, then shorten the
- ;; non-` bit of the name.
+ "Attempt to create a unused nickname out of NICK.
+A new nick may at most be LENGTH characters long. If we already
+have some ` chars at the end, then shorten the non-` bit of the
+name."
(when (= (length nick) length)
(setq nick (replace-regexp-in-string "[^`]\\(`+\\)\\'" "\\1" nick)))
(concat
@@ -2917,7 +3322,14 @@ Not in rfc1459.txt"
"`"))
(defun rcirc-handler-005 (process sender args text)
- "ERR_NICKNAMEINUSE"
+ "Register supported server features (RPL_ISUPPORT).
+ARGS should be a list of string feature parameters, either of the
+form \"PARAMETER\" to enable a feature, \"PARAMETER=VALUE\" to
+configure a specific option or \"-PARAMETER\" to disable a
+previously specified feature. SENDER is passed on to
+`rcirc-handler-generic'. PROCESS is the process object for the
+current connection. Note that this is not the behaviour as
+specified in RFC2812, where 005 stood for RPL_BOUNCE."
(rcirc-handler-generic process "005" sender args text)
(with-rcirc-process-buffer process
(setq rcirc-server-parameters (append rcirc-server-parameters args))))
@@ -2963,12 +3375,37 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(format "AUTH %s %s" nick (car args))))))))))
(defun rcirc-handler-INVITE (process sender args _text)
- (rcirc-print process sender "INVITE" nil (mapconcat 'identity args " ") t))
+ "Notify user of an invitation from SENDER.
+ARGS should have the form (TARGET CHANNEL). PROCESS is the
+process object for the current connection."
+ (let ((self (buffer-local-value 'rcirc-nick rcirc-process))
+ (target (car args))
+ (chan (cadr args)))
+ (if (string= target self)
+ (rcirc-print process sender "INVITE" nil
+ (format "%s invited you to %s"
+ sender chan)
+ t)
+ (rcirc-print process sender "INVITE" chan
+ (format "%s invited %s"
+ sender target)
+ t))))
(defun rcirc-handler-ERROR (process sender args _text)
+ "Print a error message.
+SENDER and ARGS (in concatenated form) are passed on to
+`rcirc-print'. PROCESS is the process object for the current
+connection."
(rcirc-print process sender "ERROR" nil (mapconcat 'identity args " ")))
(defun rcirc-handler-CTCP (process target sender text)
+ "Handle Client-To-Client-Protocol message TEXT.
+The message is addressed from SENDER to TARGET. Attempt to find
+an appropriate handler, by invoicing the function
+`rcirc-handler-ctcp-REQUEST', where REQUEST is the message type
+as extracted from TEXT. If no handler was found, an error
+message will be printed. PROCESS is the process object for the
+current connection."
(if (string-match "^\\([^ ]+\\) *\\(.*\\)$" text)
(let* ((request (upcase (match-string 1 text)))
(args (match-string 2 text))
@@ -2983,31 +3420,117 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(rcirc-print process sender "CTCP" target
(format "%s" text) t))))))
-(defun rcirc-handler-ctcp-VERSION (process _target sender _args)
- (rcirc-send-string process
- (concat "NOTICE " sender
- " :\C-aVERSION " rcirc-id-string
- "\C-a")))
+(defun rcirc-handler-ctcp-VERSION (process _target sender _message)
+ "Handle a CTCP VERSION message from SENDER.
+PROCESS is the process object for the current connection."
+ (rcirc-send-string process "NOTICE" sender :
+ (rcirc-ctcp-wrap "VERSION" rcirc-id-string)))
-(defun rcirc-handler-ctcp-ACTION (process target sender args)
- (rcirc-print process sender "ACTION" target args t))
+(defun rcirc-handler-ctcp-ACTION (process target sender message)
+ "Handle a CTCP ACTION MESSAGE from SENDER to TARGET.
+PROCESS is the process object for the current connection."
+ (rcirc-print process sender "ACTION" target message t))
-(defun rcirc-handler-ctcp-TIME (process _target sender _args)
- (rcirc-send-string process
- (concat "NOTICE " sender
- " :\C-aTIME " (current-time-string) "\C-a")))
+(defun rcirc-handler-ctcp-TIME (process _target sender _message)
+ "Respond to CTCP TIME message from SENDER.
+PROCESS is the process object for the current connection."
+ (rcirc-send-string process "NOTICE" sender :
+ (rcirc-ctcp-wrap "TIME" (current-time-string))))
(defun rcirc-handler-CTCP-response (process _target sender message)
+ "Handle CTCP response MESSAGE from SENDER.
+PROCESS is the process object for the current connection."
(rcirc-print process sender "CTCP" nil message t))
+
+(defun rcirc-handler-CAP (process _sender args _text)
+ "Handle capability negotiation messages.
+ARGS should have the form (USER SUBCOMMAND . ARGUMENTS). PROCESS
+is the process object for the current connection."
+ (with-rcirc-process-buffer process
+ (let ((subcmd (cadr args)))
+ (dolist (cap (cddr args))
+ (cond ((string= subcmd "ACK")
+ (push cap rcirc-acked-capabilities)
+ (setq rcirc-requested-capabilities
+ (delete cap rcirc-requested-capabilities)))
+ ((string= subcmd "NAK")
+ (setq rcirc-requested-capabilities
+ (delete cap rcirc-requested-capabilities))))))
+ (when (and (null rcirc-requested-capabilities) rcirc-finished-sasl)
+ ;; All requested capabilities have been responded to
+ (rcirc-send-string process "CAP" "END"))))
+
+(defun rcirc-handler-TAGMSG (process sender _args _text)
+ "Handle a empty tag message from SENDER.
+PROCESS is the process object for the current connection."
+ (dolist (tag rcirc-message-tags)
+ (when-let ((handler (intern-soft (concat "rcirc-tag-handler-" (car tag))))
+ ((fboundp handler)))
+ (funcall handler process sender (cdr tag)))))
+
+(defun rcirc-handler-BATCH (process _sender args _text)
+ "Open or close a batch.
+ARGS should have the form (tag type . parameters) when starting a
+batch, or (tag) when closing a batch. PROCESS is the process
+object for the current connection."
+ (with-rcirc-process-buffer process
+ (let ((type (cadr args))
+ (id (substring (car args) 1)))
+ (cond
+ ((= (aref (car args) 0) ?+) ;start a new batch
+ (when (assoc id rcirc-batch-attributes)
+ (error "Starting batch with already used ID"))
+ (setf (alist-get id rcirc-batch-attributes nil nil #'string=)
+ (cons type (cddr args))))
+ ((= (aref (car args) 0) ?-) ;close a batch
+ (unless (assoc id rcirc-batch-attributes)
+ (error "Closing a unknown batch"))
+ (let ((type (car (alist-get id rcirc-batch-attributes
+ nil nil #'string=))))
+ (when (eq (car (alist-get type rcirc-supported-batch-types
+ nil nil #'string=))
+ 'deferred)
+ (let ((messages (alist-get id rcirc-batched-messages
+ nil nil #'string=))
+ (bhandler (intern-soft (concat "rcirc-batch-handler-"
type))))
+ (if (fboundp bhandler)
+ (funcall bhandler process id (nreverse messages))
+ (dolist (message (nreverse messages))
+ (let ((cmd (nth 0 message))
+ (process (nth 1 message))
+ (sender (nth 2 message))
+ (args (nth 3 message))
+ (text (nth 4 message))
+ (rcirc-message-tags (nth 5 message)))
+ (if-let (handler (intern-soft (concat "rcirc-handler-"
cmd)))
+ (funcall handler process sender args text)
+ (rcirc-handler-generic process cmd sender args
text))))))))
+ (setq rcirc-batch-attributes
+ (delq (assoc id rcirc-batch-attributes)
+ rcirc-batch-attributes)
+ rcirc-batched-messages
+ (delq (assoc id rcirc-batched-messages)
+ rcirc-batched-messages)))))))
+
(defun rcirc-handler-AUTHENTICATE (process _cmd _args _text)
+ "Respond to authentication request.
+PROCESS is the process object for the current connection."
(rcirc-send-string
process
- (format "AUTHENTICATE %s"
- (base64-encode-string
- ;; use connection user-name
- (concat "\0" (nth 3 rcirc-connection-info)
- "\0" (rcirc-get-server-password rcirc-server))))))
+ "AUTHENTICATE"
+ (base64-encode-string
+ ;; use connection user-name
+ (concat "\0" (nth 3 rcirc-connection-info)
+ "\0" (rcirc-get-server-password rcirc-server)))))
+
+(defun rcirc-handler-900 (process sender args _text)
+ "Respond to a successful authentication response."
+ (rcirc-handler-generic process "900" sender args nil)
+ (when (not rcirc-finished-sasl)
+ (setq-local rcirc-finished-sasl t)
+ (rcirc-send-string process "CAP" "END"))
+ (rcirc-join-channels-post-auth process))
(defgroup rcirc-faces nil
@@ -3015,6 +3538,10 @@ Passwords are stored in `rcirc-authinfo' (which see)."
:group 'rcirc
:group 'faces)
+(defface rcirc-monospace-text
+ '((t :family "Monospace"))
+ "Face used for monospace text in messages.")
+
(defface rcirc-my-nick ; font-lock-function-name-face
'((((class color) (min-colors 88) (background light)) :foreground "Blue1")
(((class color) (min-colors 88) (background dark)) :foreground
"LightSkyBlue")
@@ -3124,11 +3651,12 @@ Passwords are stored in `rcirc-authinfo' (which see)."
;; When using M-x flyspell-mode, only check words after the prompt
(put 'rcirc-mode 'flyspell-mode-predicate 'rcirc-looking-at-input)
(defun rcirc-looking-at-input ()
- "Return true if point is past the input marker."
+ "Return non-nil if point is past the input marker."
(>= (point) rcirc-prompt-end-marker))
(defun rcirc-server-parameter-value (parameter)
+ "Traverse `rcirc-server-parameters' for PARAMETER."
(cl-loop for elem in rcirc-server-parameters
for setting = (split-string elem "=")
when (and (= (length setting) 2)
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 8138d9a..5e0accc 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -327,9 +327,9 @@ arguments to pass to the OPERATION."
v (format "%s -d -a -l %s %s"
(tramp-adb-get-ls-command v)
(tramp-shell-quote-argument
- (concat (file-name-as-directory localname) "."))
+ (tramp-compat-file-name-concat localname "."))
(tramp-shell-quote-argument
- (concat (file-name-as-directory localname) ".."))))
+ (tramp-compat-file-name-concat localname ".."))))
(widen)))
(tramp-adb-sh-fix-ls-output)
(let ((result (tramp-do-parse-file-attributes-with-ls
@@ -549,14 +549,14 @@ But handle the case, if the \"test\" command is not
available."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let (file-locked
+ (let ((file-locked (eq (file-locked-p lockname) t))
(curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory
filename)))
(file-remote-p lockname)
- (not (eq (file-locked-p lockname) t)))
+ (not file-locked))
(setq file-locked t)
;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname))
@@ -592,7 +592,7 @@ But handle the case, if the \"test\" command is not
available."
(current-time))))
;; Unlock file.
- (when (and file-locked (eq (file-locked-p lockname) t))
+ (when file-locked
;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname))
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 9d5e5f7..6e46407 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -363,6 +363,20 @@ A nil value for either argument stands for the current
time."
".#" (file-name-nondirectory filename))
(file-name-directory filename)))))
+;; Function `file-name-concat' is new in Emacs 28.1.
+(defalias 'tramp-compat-file-name-concat
+ (if (fboundp 'file-name-concat)
+ #'file-name-concat
+ (lambda (directory &rest components)
+ (unless (null directory)
+ (let ((components (delq nil components))
+ file-name-handler-alist)
+ (if (null components)
+ directory
+ (tramp-compat-file-name-concat
+ (concat (file-name-as-directory directory) (car components))
+ (cdr components))))))))
+
(dolist (elt (all-completions "tramp-compat-" obarray 'functionp))
(put (intern elt) 'tramp-suppress-trace t))
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 022fdee..db561b4 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -1142,7 +1142,7 @@ file names."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
(tramp-run-real-handler #'expand-file-name (list name nil))
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index e6bd42a..7cf90b9 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -519,6 +519,7 @@ shell from reading its init file."
(tramp-yn-prompt-regexp tramp-action-yn)
(tramp-terminal-prompt-regexp tramp-action-terminal)
(tramp-antispoof-regexp tramp-action-confirm-message)
+ (tramp-yubikey-regexp tramp-action-show-and-confirm-message)
(tramp-process-alive-regexp tramp-action-process-alive))
"List of pattern/action pairs.
Whenever a pattern matches, the corresponding action is performed.
@@ -536,6 +537,7 @@ corresponding PATTERN matches, the ACTION function is
called.")
'((tramp-password-prompt-regexp tramp-action-password)
(tramp-wrong-passwd-regexp tramp-action-permission-denied)
(tramp-copy-failed-regexp tramp-action-permission-denied)
+ (tramp-yubikey-regexp tramp-action-show-and-confirm-message)
(tramp-process-alive-regexp tramp-action-out-of-band))
"List of pattern/action pairs.
This list is used for copying/renaming with out-of-band methods.
@@ -1944,7 +1946,7 @@ file names."
(length (tramp-compat-file-attribute-size
(file-attributes (file-truename filename))))
(attributes (and preserve-extended-attributes
- (apply #'file-extended-attributes (list filename))))
+ (file-extended-attributes filename)))
(msg-operation (if (eq op 'copy) "Copying" "Renaming")))
(with-parsed-tramp-file-name (if t1 filename newname) nil
@@ -2020,7 +2022,7 @@ file names."
;; errors, because ACL strings could be incompatible.
(when attributes
(ignore-errors
- (apply #'set-file-extended-attributes (list newname attributes))))
+ (set-file-extended-attributes newname attributes)))
;; In case of `rename', we must flush the cache of the source file.
(when (and t1 (eq op 'rename))
@@ -2679,7 +2681,7 @@ the result will be a local, non-Tramp, file name."
(tramp-run-real-handler #'expand-file-name (list name dir))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
;; If connection is not established yet, run the real handler.
(if (not (tramp-connectable-p name))
(tramp-run-real-handler #'expand-file-name (list name nil))
@@ -3249,7 +3251,7 @@ implementation will be used."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let (file-locked
+ (let ((file-locked (eq (file-locked-p lockname) t))
(uid (or (tramp-compat-file-attribute-user-id
(file-attributes filename 'integer))
(tramp-get-remote-uid v 'integer)))
@@ -3260,7 +3262,7 @@ implementation will be used."
;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory
filename)))
(file-remote-p lockname)
- (not (eq (file-locked-p lockname) t)))
+ (not file-locked))
(setq file-locked t)
;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname))
@@ -3481,7 +3483,7 @@ implementation will be used."
(tramp-set-file-uid-gid filename uid gid))
;; Unlock file.
- (when (and file-locked (eq (file-locked-p lockname) t))
+ (when file-locked
;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname))
@@ -4782,7 +4784,9 @@ Goes through the list `tramp-inline-compress-commands'."
(with-temp-buffer
(tramp-call-process vec "scp" nil t nil "-T")
(goto-char (point-min))
- (unless (search-forward-regexp "unknown option -- T" nil t)
+ (unless
+ (search-forward-regexp
+ "\\(illegal\\|unknown\\) option -- T" nil t)
(setq tramp-scp-strict-file-name-checking "-T")))))))
tramp-scp-strict-file-name-checking)))
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 4008c25..3d5be61 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -722,7 +722,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are
completely ignored."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
(tramp-run-real-handler #'expand-file-name (list name nil))
@@ -1589,14 +1589,14 @@ errors for shares like \"C$/\", which are common in
Microsoft Windows."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let (file-locked
+ (let ((file-locked (eq (file-locked-p lockname) t))
(curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory
filename)))
(file-remote-p lockname)
- (not (eq (file-locked-p lockname) t)))
+ (not file-locked))
(setq file-locked t)
;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname))
@@ -1635,7 +1635,7 @@ errors for shares like \"C$/\", which are common in
Microsoft Windows."
(current-time))))
;; Unlock file.
- (when (and file-locked (eq (file-locked-p lockname) t))
+ (when file-locked
;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname))
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 99f4063..c5b84a6 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -295,12 +295,12 @@ arguments to pass to the OPERATION."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let (file-locked)
+ (let ((file-locked (eq (file-locked-p lockname) t)))
;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory
filename)))
(file-remote-p lockname)
- (not (eq (file-locked-p lockname) t)))
+ (not file-locked))
(setq file-locked t)
;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname))
@@ -311,7 +311,7 @@ arguments to pass to the OPERATION."
(tramp-flush-file-properties v localname))
;; Unlock file.
- (when (and file-locked (eq (file-locked-p lockname) t))
+ (when file-locked
;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname))
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index 45d9fab..e4d90dd 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -237,7 +237,7 @@ absolute file names."
(file-attributes filename)))
(file-modes (tramp-default-file-modes filename))
(attributes (and preserve-extended-attributes
- (apply #'file-extended-attributes (list filename))))
+ (file-extended-attributes filename)))
(sudoedit-operation
(cond
((and (eq op 'copy) preserve-uid-gid) '("cp" "-f" "-p"))
@@ -293,7 +293,7 @@ absolute file names."
;; errors, because ACL strings could be incompatible.
(when attributes
(ignore-errors
- (apply #'set-file-extended-attributes (list newname attributes))))
+ (set-file-extended-attributes newname attributes)))
(when (and t1 (eq op 'rename))
(with-parsed-tramp-file-name filename v1
@@ -353,7 +353,7 @@ the result will be a local, non-Tramp, file name."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
(with-parsed-tramp-file-name name nil
;; Tilde expansion if necessary. We cannot accept "~/", because
;; under sudo "~/" is expanded to the local user home directory
@@ -726,13 +726,14 @@ ID-FORMAT valid values are `string' and `integer'."
(file-attributes filename 'integer))
(tramp-get-remote-gid v 'integer)))
(flag (and (eq mustbenew 'excl) 'nofollow))
- (modes (tramp-default-file-modes filename flag)))
+ (modes (tramp-default-file-modes filename flag))
+ (attributes (file-extended-attributes filename)))
(prog1
(tramp-handle-write-region
start end filename append visit lockname mustbenew)
- ;; Set the ownership and modes. This is not performed in
- ;; `tramp-handle-write-region'.
+ ;; Set the ownership, modes and extended attributes. This is
+ ;; not performed in `tramp-handle-write-region'.
(unless (and (= (tramp-compat-file-attribute-user-id
(file-attributes filename 'integer))
uid)
@@ -740,7 +741,12 @@ ID-FORMAT valid values are `string' and `integer'."
(file-attributes filename 'integer))
gid))
(tramp-set-file-uid-gid filename uid gid))
- (tramp-compat-set-file-modes filename modes flag)))))
+ (tramp-compat-set-file-modes filename modes flag)
+ ;; We ignore possible errors, because ACL strings could be
+ ;; incompatible.
+ (when attributes
+ (ignore-errors
+ (set-file-extended-attributes filename attributes)))))))
;; Internal functions.
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 736c7ef..4db0b2e 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -698,6 +698,15 @@ The regexp should match at end of buffer."
:version "27.1"
:type 'regexp)
+;; Yubikey requires the user physically to touch the device with their
+;; finger. We must tell it to the user.
+(defcustom tramp-yubikey-regexp
+ "Confirm user presence for key .*"
+ "Regular expression matching yubikey confirmation message.
+The regexp should match at end of buffer."
+ :version "28.1"
+ :type 'regexp)
+
(defcustom tramp-operation-not-permitted-regexp
(concat "\\(" "preserving times.*" "\\|" "set mode" "\\)" ":\\s-*"
(regexp-opt '("Operation not permitted") t))
@@ -3337,7 +3346,7 @@ User is always nil."
(when (zerop (length name)) (setq name "."))
;; Unless NAME is absolute, concat DIR and NAME.
(unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
+ (setq name (tramp-compat-file-name-concat dir name)))
;; If NAME is not a Tramp file, run the real handler.
(if (not (tramp-tramp-file-p name))
(tramp-run-real-handler #'expand-file-name (list name nil))
@@ -4463,7 +4472,7 @@ of."
(format "File %s exists; overwrite anyway? " filename)))))
(tramp-error v 'file-already-exists filename))
- (let (file-locked
+ (let ((file-locked (eq (file-locked-p lockname) t))
(tmpfile (tramp-compat-make-temp-file filename))
(modes (tramp-default-file-modes
filename (and (eq mustbenew 'excl) 'nofollow)))
@@ -4477,7 +4486,7 @@ of."
;; Lock file.
(when (and (not (auto-save-file-name-p (file-name-nondirectory
filename)))
(file-remote-p lockname)
- (not (eq (file-locked-p lockname) t)))
+ (not file-locked))
(setq file-locked t)
;; `lock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'lock-file lockname))
@@ -4515,7 +4524,7 @@ of."
(tramp-set-file-uid-gid filename uid gid)
;; Unlock file.
- (when (and file-locked (eq (file-locked-p lockname) t))
+ (when file-locked
;; `unlock-file' exists since Emacs 28.1.
(tramp-compat-funcall 'unlock-file lockname))
@@ -4669,6 +4678,20 @@ The terminal type can be configured with
`tramp-terminal-type'."
(tramp-send-string vec tramp-local-end-of-line)
t)
+(defun tramp-action-show-and-confirm-message (_proc vec)
+ "Show the user a message for confirmation.
+Wait, until the user has entered RET."
+ (save-window-excursion
+ (let ((enable-recursive-minibuffers t)
+ (stimers (with-timeout-suspend)))
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (tramp-message vec 6 "\n%s" (buffer-string))
+ (pop-to-buffer (current-buffer)))
+ (read-string "Press ENTER to continue")
+ ;; Reenable the timers.
+ (with-timeout-unsuspend stimers)))
+ t)
+
(defun tramp-action-process-alive (proc _vec)
"Check, whether a process has finished."
(unless (process-live-p proc)
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index a5bfb06..57a52ef 100644
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
@@ -840,9 +840,13 @@ Ensure that `comment-normalize-vars' has been called
before you use this."
(make-string (min comment-padding
(- (match-end 0) (match-end 1)))
?\s)
- (substring comment-padding ;additional right padding
- (min (- (match-end 0) (match-end 1))
- (length comment-padding))))))
+ (if (not (string-match-p "\\`\\s-" comment-padding))
+ ;; If the padding isn't spaces, then don't
+ ;; shorten the padding.
+ comment-padding
+ (substring comment-padding ;additional right padding
+ (min (- (match-end 0) (match-end 1))
+ (length comment-padding)))))))
;; We can only duplicate C if the comment-end has multiple chars
;; or if comments can be nested, else the comment-end `}' would
;; be turned into `}}}' where only the first ends the comment
@@ -876,9 +880,13 @@ Ensure that `comment-normalize-vars' has been called
before you use this."
;; Only separate the left pad because we assume there is no right pad.
(string-match "\\`\\s-*" str)
(let ((s (substring str (match-end 0)))
- (pad (concat (substring comment-padding
- (min (- (match-end 0) (match-beginning 0))
- (length comment-padding)))
+ (pad (concat (if (not (string-match-p "\\`\\s-" comment-padding))
+ ;; If the padding isn't spaces, then don't
+ ;; shorten the padding.
+ comment-padding
+ (substring comment-padding
+ (min (- (match-end 0) (match-beginning 0))
+ (length comment-padding))))
(match-string 0 str)))
(c (aref str (match-end 0))) ;the first non-space char of STR
;; We can only duplicate C if the comment-end has multiple chars
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 755211b..9b9c58e 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -345,6 +345,7 @@ and set it if applicable."
(defvar gnus-article-buffer)
(defvar gnus-original-article-buffer)
(defvar gnus-summary-buffer)
+(defvar bug-reference-mode)
(defun bug-reference--try-setup-gnus-article ()
(when (and bug-reference-mode ;; Only if enabled in article buffers.
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 7a02c3a..02d1c58 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -1248,11 +1248,14 @@ POS and RES.")
(setq col (match-string-no-properties col))
(string-to-number col))))
(setq end-col
- (or (if (functionp end-col) (funcall end-col)
- (and end-col
- (setq end-col (match-string-no-properties end-col))
- (- (string-to-number end-col) -1)))
- (and end-line -1)))
+ (let ((ec (if (functionp end-col)
+ (funcall end-col)
+ (and end-col (match-beginning end-col)
+ (string-to-number
+ (match-string-no-properties end-col))))))
+ (if ec
+ (1+ ec) ; Add one to get an exclusive upper bound.
+ (and end-line -1))))
(if (consp type) ; not a static type, check what it is.
(setq type (or (and (car type) (match-end (car type)) 1)
(and (cdr type) (match-end (cdr type)) 0)
@@ -1540,7 +1543,7 @@ to `compilation-error-regexp-alist' if RULES is nil."
file line end-line col end-col
(or type 2) fmt rule))
- (when (integerp file)
+ (when file
(let ((this-type (if (consp type)
(compilation-type type)
(or type 2))))
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index a56c709..7ed2d3d 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -1325,8 +1325,7 @@ Reinitialize the face according to the `defface'
specification."
((eq (car form) 'custom-declare-face)
;; Reset the face.
(let ((face-symbol (eval (nth 1 form) lexical-binding)))
- (setq face-new-frame-defaults
- (assq-delete-all face-symbol face-new-frame-defaults))
+ (remhash face-symbol face--new-frame-defaults)
(put face-symbol 'face-defface-spec nil)
(put face-symbol 'face-override-spec nil))
form)
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index aa33652..38dd0a7 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -581,6 +581,23 @@ stopped thread is already selected."
:group 'gdb-buffers
:version "23.2")
+(defcustom gdb-registers-enable-filter nil
+ "If non-nil, enable register name filter in register buffer.
+Use `gdb-registers-filter-pattern-list' to control what register to
+filter."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "28.1")
+
+(defcustom gdb-registers-filter-pattern-list nil
+ "Patterns for names that are displayed in register buffer.
+Each pattern is a regular expression. GDB displays registers
+whose name matches any pattern in the list. Refresh the register
+buffer for the change to take effect."
+ :type 'list
+ :group 'gdb-buffers
+ :version "28.1")
+
(defvar gdb-debug-log nil
"List of commands sent to and replies received from GDB.
Most recent commands are listed first. This list stores only the last
@@ -4393,6 +4410,26 @@ member."
'gdb-registers-mode
'gdb-invalidate-registers)
+(defun gdb-header-click-event-handler (function)
+ "Return a function that handles clicking event on gdb header buttons.
+
+This function switches to the window where the header locates and
+executes FUNCTION."
+ (lambda (event)
+ (interactive "e")
+ (save-selected-window
+ ;; Make sure we are in the right buffer.
+ (select-window (posn-window (event-start event)))
+ (funcall function))))
+
+(defun gdb-registers-toggle-filter ()
+ "Toggle register filter."
+ (interactive)
+ (setq gdb-registers-enable-filter
+ (not gdb-registers-enable-filter))
+ ;; Update the register buffer.
+ (gdb-invalidate-registers 'update))
+
(defun gdb-registers-handler-custom ()
(when gdb-register-names
(let ((register-values
@@ -4403,17 +4440,27 @@ member."
(value (gdb-mi--field register 'value))
(register-name (nth (string-to-number register-number)
gdb-register-names)))
- (gdb-table-add-row
- table
- (list
- (propertize register-name
- 'font-lock-face font-lock-variable-name-face)
- (if (member register-number gdb-changed-registers)
- (propertize value 'font-lock-face font-lock-warning-face)
- value))
- `(mouse-face highlight
- help-echo "mouse-2: edit value"
- gdb-register-name ,register-name))))
+ ;; Add register if `gdb-registers-filter-pattern-list' is nil;
+ ;; or any pattern that `gdb-registers-filter-pattern-list'
+ ;; matches.
+ (when (or (null gdb-registers-enable-filter)
+ ;; Return t if any register name matches a pattern.
+ (cl-loop for pattern
+ in gdb-registers-filter-pattern-list
+ if (string-match pattern register-name)
+ return t
+ finally return nil))
+ (gdb-table-add-row
+ table
+ (list
+ (propertize register-name
+ 'font-lock-face font-lock-variable-name-face)
+ (if (member register-number gdb-changed-registers)
+ (propertize value 'font-lock-face font-lock-warning-face)
+ value))
+ `(mouse-face highlight
+ help-echo "mouse-2: edit value"
+ gdb-register-name ,register-name)))))
(insert (gdb-table-string table " ")))
(setq mode-name
(gdb-current-context-mode-name "Registers"))))
@@ -4441,6 +4488,7 @@ member."
(gdb-get-buffer-create
'gdb-locals-buffer
gdb-thread-number) t)))
+ (define-key map "f" #'gdb-registers-toggle-filter)
map))
(defvar gdb-registers-header
@@ -4450,7 +4498,31 @@ member."
mode-line-inactive)
" "
(gdb-propertize-header "Registers" gdb-registers-buffer
- nil nil mode-line)))
+ nil nil mode-line)
+ " "
+ '(:eval
+ (format
+ "[filter %s %s]"
+ (propertize
+ (if gdb-registers-enable-filter "[on]" "[off]")
+ 'face (if gdb-registers-enable-filter
+ '(:weight bold :inherit success)
+ 'shadow)
+ 'help-echo "mouse-1: toggle filter"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1 (gdb-header-click-event-handler
+ #'gdb-registers-toggle-filter)))
+ (propertize
+ "[set]"
+ 'face 'mode-line
+ 'help-echo "mouse-1: Customize filter patterns"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1 (lambda ()
+ (interactive)
+ (customize-variable-other-window
+ 'gdb-registers-filter-pattern-list))))))))
(define-derived-mode gdb-registers-mode gdb-parent-mode "Registers"
"Major mode for gdb registers."
diff --git a/lisp/replace.el b/lisp/replace.el
index ed81097..09bdf28 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -792,12 +792,8 @@ which will run faster and will not set the mark or print
anything."
Maximum length of the history list is determined by the value
of `history-length', which see.")
-(defvar occur-highlight-regexp t
- "Regexp matching part of visited source lines to highlight temporarily.
-Highlight entire line if t; don't highlight source lines if nil.")
-
-(defvar occur-highlight-overlay nil
- "Overlay used to temporarily highlight occur matches.")
+(defvar occur-highlight-overlays nil
+ "Overlays used to temporarily highlight occur matches.")
(defvar occur-collect-regexp-history '("\\1")
"History of regexp for occur's collect operation")
@@ -1054,6 +1050,130 @@ also print the number."
count))
count))
+(defun kill-matching-lines (regexp &optional rstart rend interactive)
+ "Kill lines containing matches for REGEXP.
+
+When called from Lisp (and usually when called interactively as
+well, see below), applies to the part of the buffer after point.
+The line point is in is killed if and only if it contains a match
+for REGEXP starting after point.
+
+If REGEXP contains upper case characters (excluding those
+preceded by `\\') and `search-upper-case' is non-nil, the
+matching is case-sensitive.
+
+Second and third args RSTART and REND specify the region to
+operate on. Lines partially contained in this region are killed
+if and only if they contain a match entirely contained in the
+region.
+
+Interactively, in Transient Mark mode when the mark is active,
+operate on the contents of the region. Otherwise, operate from
+point to the end of (the accessible portion of) the buffer.
+
+If a match is split across lines, all the lines it lies in are
+killed. They are killed _before_ looking for the next match.
+Hence, a match starting on the same line at which another match
+ended is ignored.
+
+Return the number of killed matching lines. When called
+interactively, also print the number."
+ (interactive
+ (progn
+ (barf-if-buffer-read-only)
+ (keep-lines-read-args "Kill lines containing match for regexp")))
+ (if rstart
+ (progn
+ (goto-char (min rstart rend))
+ (setq rend (copy-marker (max rstart rend))))
+ (if (and interactive (use-region-p))
+ (setq rstart (region-beginning)
+ rend (copy-marker (region-end)))
+ (setq rstart (point)
+ rend (point-max-marker)))
+ (goto-char rstart))
+ (let ((count 0)
+ (case-fold-search
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)))
+ (save-excursion
+ (while (and (< (point) rend)
+ (re-search-forward regexp rend t))
+ (unless (zerop count)
+ (setq last-command 'kill-region))
+ (kill-region (save-excursion (goto-char (match-beginning 0))
+ (forward-line 0)
+ (point))
+ (progn (forward-line 1) (point)))
+ (setq count (1+ count))))
+ (set-marker rend nil)
+ (when interactive (message (ngettext "Killed %d matching line"
+ "Killed %d matching lines"
+ count)
+ count))
+ count))
+
+(defun copy-matching-lines (regexp &optional rstart rend interactive)
+ "Copy lines containing matches for REGEXP to the kill ring.
+
+When called from Lisp (and usually when called interactively as
+well, see below), applies to the part of the buffer after point.
+The line point is in is copied if and only if it contains a match
+for REGEXP starting after point.
+
+If REGEXP contains upper case characters (excluding those
+preceded by `\\') and `search-upper-case' is non-nil, the
+matching is case-sensitive.
+
+Second and third args RSTART and REND specify the region to
+operate on. Lines partially contained in this region are copied
+if and only if they contain a match entirely contained in the
+region.
+
+Interactively, in Transient Mark mode when the mark is active,
+operate on the contents of the region. Otherwise, operate from
+point to the end of (the accessible portion of) the buffer.
+
+If a match is split across lines, all the lines it lies in are
+copied.
+
+Return the number of copied matching lines. When called
+interactively, also print the number."
+ (interactive
+ (keep-lines-read-args "Copy lines containing match for regexp"))
+ (if rstart
+ (progn
+ (goto-char (min rstart rend))
+ (setq rend (copy-marker (max rstart rend))))
+ (if (and interactive (use-region-p))
+ (setq rstart (region-beginning)
+ rend (copy-marker (region-end)))
+ (setq rstart (point)
+ rend (point-max-marker)))
+ (goto-char rstart))
+ (let ((count 0)
+ (case-fold-search
+ (if (and case-fold-search search-upper-case)
+ (isearch-no-upper-case-p regexp t)
+ case-fold-search)))
+ (save-excursion
+ (while (and (< (point) rend)
+ (re-search-forward regexp rend t))
+ (unless (zerop count)
+ (setq last-command 'kill-region))
+ (copy-region-as-kill (save-excursion (goto-char (match-beginning 0))
+ (forward-line 0)
+ (point))
+ (progn (forward-line 1) (point)))
+ (setq count (1+ count))))
+ (set-marker rend nil)
+ (when interactive (message (ngettext "Copied %d matching line"
+ "Copied %d matching lines"
+ count)
+ count))
+ count))
+
(defun how-many (regexp &optional rstart rend interactive)
"Print and return number of matches for REGEXP following point.
When called from Lisp and INTERACTIVE is omitted or nil, just return
@@ -1233,18 +1353,27 @@ To return to ordinary Occur mode, use
\\[occur-cease-edit]."
(occur-mode)
(message "Switching to Occur mode.")))
+(defun occur--targets-start (targets)
+ "First marker of the `occur-target' property value TARGETS."
+ (if (consp targets)
+ (caar targets)
+ ;; Tolerate an `occur-target' value that is a single marker for
+ ;; compatibility.
+ targets))
+
(defun occur-after-change-function (beg end length)
(save-excursion
(goto-char beg)
(let* ((line-beg (line-beginning-position))
- (m (get-text-property line-beg 'occur-target))
+ (targets (get-text-property line-beg 'occur-target))
+ (m (occur--targets-start targets))
(buf (marker-buffer m))
col)
(when (and (get-text-property line-beg 'occur-prefix)
(not (get-text-property end 'occur-prefix)))
(when (= length 0)
;; Apply occur-target property to inserted (e.g. yanked) text.
- (put-text-property beg end 'occur-target m)
+ (put-text-property beg end 'occur-target targets)
;; Did we insert a newline? Occur Edit mode can't create new
;; Occur entries; just discard everything after the newline.
(save-excursion
@@ -1269,8 +1398,27 @@ To return to ordinary Occur mode, use
\\[occur-cease-edit]."
(recenter line)
(if readonly
(message "Buffer `%s' is read only." buf)
- (delete-region (line-beginning-position) (line-end-position))
- (insert text))
+ ;; Replace the line, but make the change as small as
+ ;; possible by shrink-wrapping. That way, we avoid
+ ;; disturbing markers unnecessarily.
+ (let* ((beg-pos (line-beginning-position))
+ (end-pos (line-end-position))
+ (buf-str (buffer-substring-no-properties beg-pos end-pos))
+ (common-prefix
+ (lambda (s1 s2)
+ (let ((c (compare-strings s1 nil nil s2 nil nil)))
+ (if (zerop c)
+ (length s1)
+ (1- (abs c))))))
+ (prefix-len (funcall common-prefix buf-str text))
+ (suffix-len (funcall common-prefix
+ (reverse buf-str) (reverse text))))
+ (setq beg-pos (+ beg-pos prefix-len))
+ (setq end-pos (- end-pos suffix-len))
+ (setq text (substring text prefix-len (- suffix-len)))
+ (delete-region beg-pos end-pos)
+ (goto-char beg-pos)
+ (insert text)))
(move-to-column col)))))))
@@ -1278,35 +1426,38 @@ To return to ordinary Occur mode, use
\\[occur-cease-edit]."
"Handle `revert-buffer' for Occur mode buffers."
(apply #'occur-1 (append occur-revert-arguments (list (buffer-name)))))
-(defun occur-mode-find-occurrence ()
- (let ((pos (get-text-property (point) 'occur-target)))
- (unless pos
+(defun occur-mode--find-occurrences ()
+ ;; The `occur-target' property value is a list of (BEG . END) for each
+ ;; match on the line, or (for compatibility) a single marker to the start
+ ;; of the first match.
+ (let* ((targets (get-text-property (point) 'occur-target))
+ (start (occur--targets-start targets)))
+ (unless targets
(error "No occurrence on this line"))
- (unless (buffer-live-p (marker-buffer pos))
+ (unless (buffer-live-p (marker-buffer start))
(error "Buffer for this occurrence was killed"))
- pos))
+ targets))
(defalias 'occur-mode-mouse-goto 'occur-mode-goto-occurrence)
(defun occur-mode-goto-occurrence (&optional event)
"Go to the occurrence specified by EVENT, a mouse click.
If not invoked by a mouse click, go to occurrence on the current line."
(interactive (list last-nonmenu-event))
- (let ((buffer (when event (current-buffer)))
- (pos
- (if (null event)
- ;; Actually `event-end' works correctly with a nil argument as
- ;; well, so we could dispense with this test, but let's not
- ;; rely on this undocumented behavior.
- (occur-mode-find-occurrence)
- (with-current-buffer (window-buffer (posn-window (event-end event)))
- (save-excursion
- (goto-char (posn-point (event-end event)))
- (occur-mode-find-occurrence)))))
- (regexp occur-highlight-regexp))
+ (let* ((buffer (when event (current-buffer)))
+ (targets
+ (if (null event)
+ ;; Actually `event-end' works correctly with a nil argument as
+ ;; well, so we could dispense with this test, but let's not
+ ;; rely on this undocumented behavior.
+ (occur-mode--find-occurrences)
+ (with-current-buffer (window-buffer (posn-window (event-end
event)))
+ (save-excursion
+ (goto-char (posn-point (event-end event)))
+ (occur-mode--find-occurrences)))))
+ (pos (occur--targets-start targets)))
(pop-to-buffer (marker-buffer pos))
(goto-char pos)
- (let ((end-mk (save-excursion (re-search-forward regexp nil t))))
- (occur--highlight-occurrence pos end-mk))
+ (occur--highlight-occurrences targets)
(when buffer (next-error-found buffer (current-buffer)))
(run-hooks 'occur-mode-find-occurrence-hook)))
@@ -1314,15 +1465,15 @@ If not invoked by a mouse click, go to occurrence on
the current line."
"Go to the occurrence the current line describes, in another window."
(interactive)
(let ((buffer (current-buffer))
- (pos (occur-mode-find-occurrence)))
+ (pos (occur--targets-start (occur-mode--find-occurrences))))
(switch-to-buffer-other-window (marker-buffer pos))
(goto-char pos)
(next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook)))
-;; Stolen from compile.el
(defun occur-goto-locus-delete-o ()
- (delete-overlay occur-highlight-overlay)
+ (mapc #'delete-overlay occur-highlight-overlays)
+ (setq occur-highlight-overlays nil)
;; Get rid of timer and hook that would try to do this again.
(if (timerp next-error-highlight-timer)
(cancel-timer next-error-highlight-timer))
@@ -1330,64 +1481,55 @@ If not invoked by a mouse click, go to occurrence on
the current line."
#'occur-goto-locus-delete-o))
;; Highlight the current visited occurrence.
-;; Adapted from `compilation-goto-locus'.
-(defun occur--highlight-occurrence (mk end-mk)
- (let ((highlight-regexp occur-highlight-regexp))
- (if (timerp next-error-highlight-timer)
- (cancel-timer next-error-highlight-timer))
- (unless occur-highlight-overlay
- (setq occur-highlight-overlay
- (make-overlay (point-min) (point-min)))
- (overlay-put occur-highlight-overlay 'face 'next-error))
- (with-current-buffer (marker-buffer mk)
- (save-excursion
- (if end-mk (goto-char end-mk) (end-of-line))
- (let ((end (point)))
- (if mk (goto-char mk) (beginning-of-line))
- (if (and (stringp highlight-regexp)
- (re-search-forward highlight-regexp end t))
- (progn
- (goto-char (match-beginning 0))
- (move-overlay occur-highlight-overlay
- (match-beginning 0) (match-end 0)
- (current-buffer)))
- (move-overlay occur-highlight-overlay
- (point) end (current-buffer)))
- (if (or (eq next-error-highlight t)
- (numberp next-error-highlight))
- ;; We want highlighting: delete overlay on next input.
- (add-hook 'pre-command-hook
- #'occur-goto-locus-delete-o)
- ;; We don't want highlighting: delete overlay now.
- (delete-overlay occur-highlight-overlay))
- ;; We want highlighting for a limited time:
- ;; set up a timer to delete it.
- (when (numberp next-error-highlight)
- (setq next-error-highlight-timer
- (run-at-time next-error-highlight nil
- 'occur-goto-locus-delete-o))))))
- (when (eq next-error-highlight 'fringe-arrow)
- ;; We want a fringe arrow (instead of highlighting).
- (setq next-error-overlay-arrow-position
- (copy-marker (line-beginning-position))))))
+(defun occur--highlight-occurrences (targets)
+ (let ((start-marker (occur--targets-start targets)))
+ (occur-goto-locus-delete-o)
+ (with-current-buffer (marker-buffer start-marker)
+ (when (or (eq next-error-highlight t)
+ (numberp next-error-highlight))
+ (setq occur-highlight-overlays
+ (mapcar (lambda (target)
+ (let ((o (make-overlay (car target) (cdr target))))
+ (overlay-put o 'face 'next-error)
+ o))
+ (if (listp targets)
+ targets
+ ;; `occur-target' compatibility: when we only
+ ;; have a single starting point, highlight the
+ ;; rest of the line.
+ (let ((end-pos (save-excursion
+ (goto-char start-marker)
+ (line-end-position))))
+ (list (cons start-marker end-pos))))))
+ (add-hook 'pre-command-hook #'occur-goto-locus-delete-o)
+ (when (numberp next-error-highlight)
+ ;; We want highlighting for a limited time:
+ ;; set up a timer to delete it.
+ (setq next-error-highlight-timer
+ (run-at-time next-error-highlight nil
+ 'occur-goto-locus-delete-o))))
+
+ (when (eq next-error-highlight 'fringe-arrow)
+ ;; We want a fringe arrow (instead of highlighting).
+ (setq next-error-overlay-arrow-position
+ (copy-marker (line-beginning-position)))))))
(defun occur-mode-display-occurrence ()
"Display in another window the occurrence the current line describes."
(interactive)
- (let ((buffer (current-buffer))
- (pos (occur-mode-find-occurrence))
- (regexp occur-highlight-regexp)
- (next-error-highlight next-error-highlight-no-select)
- (display-buffer-overriding-action
- '(nil (inhibit-same-window . t)))
- window)
+ (let* ((buffer (current-buffer))
+ (targets (occur-mode--find-occurrences))
+ (pos (occur--targets-start targets))
+ (next-error-highlight next-error-highlight-no-select)
+ (display-buffer-overriding-action
+ '(nil (inhibit-same-window . t)))
+ window)
(setq window (display-buffer (marker-buffer pos) t))
;; This is the way to set point in the proper window.
(save-selected-window
(select-window window)
(goto-char pos)
- (let ((end-mk (save-excursion (re-search-forward regexp nil t))))
- (occur--highlight-occurrence pos end-mk))
+ (occur--highlight-occurrences targets)
(next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook))))
@@ -1744,7 +1886,6 @@ See also `multi-occur'."
(buffer-undo-list t)
(occur--final-pos nil))
(erase-buffer)
- (setq-local occur-highlight-regexp regexp)
(let ((count
(if (stringp nlines)
;; Treat nlines as a regexp to collect.
@@ -1844,7 +1985,7 @@ See also `multi-occur'."
(origpt nil)
(begpt nil)
(endpt nil)
- (marker nil)
+ markers ; list of (BEG-MARKER . END-MARKER)
(curstring "")
(ret nil)
;; The following binding is for when case-fold-search
@@ -1870,8 +2011,7 @@ See also `multi-occur'."
(setq endpt (line-end-position)))
;; Sum line numbers up to the first match line.
(setq curr-line (+ curr-line (count-lines origpt begpt)))
- (setq marker (make-marker))
- (set-marker marker matchbeg)
+ (setq markers nil)
(setq curstring (occur-engine-line begpt endpt
keep-props))
;; Highlight the matches
(let ((len (length curstring))
@@ -1893,6 +2033,11 @@ See also `multi-occur'."
(setq orig-line-shown-p t)))
(while (and (< start len)
(string-match regexp curstring start))
+ (push (cons (set-marker (make-marker)
+ (+ begpt (match-beginning
0)))
+ (set-marker (make-marker)
+ (+ begpt (match-end 0))))
+ markers)
(setq matches (1+ matches))
(add-text-properties
(match-beginning 0) (match-end 0)
@@ -1905,6 +2050,7 @@ See also `multi-occur'."
;; Avoid infloop (Bug#7593).
(let ((end (match-end 0)))
(setq start (if (= start end) (1+ start) end)))))
+ (setq markers (nreverse markers))
;; Generate the string to insert for this match
(let* ((match-prefix
;; Using 7 digits aligns tabs properly.
@@ -1918,7 +2064,7 @@ See also `multi-occur'."
;; (for Occur Edit mode).
front-sticky t
rear-nonsticky t
- occur-target ,marker
+ occur-target ,markers
follow-link t
help-echo "mouse-2: go to
this occurrence"))))
(match-str
@@ -1926,7 +2072,7 @@ See also `multi-occur'."
;; because that loses. And don't put it
;; on context lines to reduce flicker.
(propertize curstring
- 'occur-target marker
+ 'occur-target markers
'follow-link t
'help-echo
"mouse-2: go to this occurrence"))
@@ -1945,8 +2091,8 @@ See also `multi-occur'."
;; get a contiguous highlight.
(propertize (concat match-prefix match-str)
'mouse-face 'highlight))
- ;; Add marker at eol, but no mouse props.
- (propertize "\n" 'occur-target marker)))
+ ;; Add markers at eol, but no mouse props.
+ (propertize "\n" 'occur-target markers)))
(data
(if (= nlines 0)
;; The simple display style
diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el
index f39f173..f67b0b9 100644
--- a/lisp/shadowfile.el
+++ b/lisp/shadowfile.el
@@ -128,7 +128,7 @@ Default: ~/.emacs.d/shadow_todo"
(defvar shadow-system-name (concat "/" (system-name) ":")
"The identification for local files on this machine.")
-(defvar shadow-homedir "~"
+(defvar shadow-homedir "~/"
"Your home directory on this machine.")
;;;
@@ -284,9 +284,13 @@ Argument can be a simple name, remote file name, or
already a
(defsubst shadow-make-fullname (hup &optional host name)
"Make a Tramp style fullname out of HUP, a `tramp-file-name' structure.
-Replace HOST, and NAME when non-nil."
+Replace HOST, and NAME when non-nil. HOST can also be a remote file name."
(let ((hup (copy-tramp-file-name hup)))
- (when host (setf (tramp-file-name-host hup) host))
+ (when host
+ (if (file-remote-p host)
+ (setq name (or name (and hup (tramp-file-name-localname hup)))
+ hup (tramp-dissect-file-name (file-remote-p host)))
+ (setf (tramp-file-name-host hup) host)))
(when name (setf (tramp-file-name-localname hup) name))
(if (null (tramp-file-name-method hup))
(format
@@ -348,15 +352,16 @@ Will return the name bare if it is a local file."
(defun shadow-contract-file-name (file)
"Simplify FILE.
-Do so by replacing (when possible) home directory with ~, and hostname
-with cluster name that includes it. Filename should be absolute and
-true."
+Do so by replacing (when possible) home directory with ~/, and
+hostname with cluster name that includes it. Filename should be
+absolute and true."
(let* ((hup (shadow-parse-name file))
(homedir (if (shadow-local-file hup)
shadow-homedir
(file-name-as-directory
(file-local-name
- (expand-file-name (shadow-make-fullname hup nil "~"))))))
+ (expand-file-name
+ (shadow-make-fullname hup nil shadow-homedir))))))
(suffix (shadow-suffix homedir (tramp-file-name-localname hup)))
(cluster (shadow-site-cluster (shadow-make-fullname hup nil ""))))
(when cluster
@@ -365,7 +370,7 @@ true."
(shadow-make-fullname
hup nil
(if suffix
- (concat "~/" suffix)
+ (concat shadow-homedir suffix)
(tramp-file-name-localname hup)))))
(defun shadow-same-site (pattern file)
diff --git a/lisp/simple.el b/lisp/simple.el
index f4d28c9..9d7c076 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -695,6 +695,30 @@ When called from Lisp code, ARG may be a prefix string to
copy."
(indent-to col 0)
(goto-char pos)))
+(defface separator-line
+ '((((type graphic) (background dark))
+ :height 0.1 :background "#505050")
+ (((type graphic) (background light))
+ :height 0.1 :background "#a0a0a0")
+ (t :foreground "ForestGreen"))
+ "Face for separator lines."
+ :version "28.1"
+ :group 'text)
+
+(defun make-separator-line (&optional length)
+ "Make a string appropriate for usage as a visual separator line.
+This uses the `separator-line' face.
+
+If LENGTH is nil, use the window width."
+ (if (display-graphic-p)
+ (if length
+ (concat (propertize (make-string length ?\s) 'face 'separator-line)
+ "\n")
+ (propertize "\n" 'face '(:inherit separator-line :extend t)))
+ (concat (propertize (make-string (or length (1- (window-width))) ?-)
+ 'face 'separator-line)
+ "\n")))
+
(defun delete-indentation (&optional arg beg end)
"Join this line to previous and fix up whitespace at join.
If there is a fill prefix, delete it from the beginning of this
@@ -2855,8 +2879,10 @@ Go to the history element by the absolute history
position HIST-POS."
The same as `command-error-default-function' but display error messages
at the end of the minibuffer using `minibuffer-message' to not obscure
the minibuffer contents."
- (discard-input)
- (ding)
+ (if (memq 'minibuffer-quit (get (car data) 'error-conditions))
+ (ding t)
+ (discard-input)
+ (ding))
(let ((string (error-message-string data)))
;; If we know from where the error was signaled, show it in
;; *Messages*.
@@ -6682,6 +6708,10 @@ or \"mark.*active\" at the prompt."
;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
:variable (default-value 'transient-mark-mode))
+(define-minor-mode indent-tabs-mode
+ "Toggle whether indentation can insert TAB characters."
+ :global t :group 'indent :variable indent-tabs-mode)
+
(defvar widen-automatically t
"Non-nil means it is ok for commands to call `widen' when they want to.
Some commands will do this in order to go to positions outside
@@ -9505,9 +9535,9 @@ call `normal-erase-is-backspace-mode' (which see)
instead."
:set (lambda (symbol value)
;; The fboundp is because of a problem with :set when
;; dumping Emacs. It doesn't really matter.
- (if (fboundp 'normal-erase-is-backspace-mode)
- (normal-erase-is-backspace-mode (or value 0))
- (set-default symbol value))))
+ (when (fboundp 'normal-erase-is-backspace-mode)
+ (normal-erase-is-backspace-mode (or value 0)))
+ (set-default symbol value)))
(defun normal-erase-is-backspace-setup-frame (&optional frame)
"Set up `normal-erase-is-backspace-mode' on FRAME, if necessary."
diff --git a/lisp/startup.el b/lisp/startup.el
index 3c3f791..c13846a 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -2393,6 +2393,7 @@ nil default-directory" name)
(command-line-normalize-file-name name)
dir))
(buf (find-file-noselect file)))
+ (file-name-history--add file)
(setq displayable-buffers (cons buf displayable-buffers))
;; Set the file buffer to the current buffer so
;; that it will be used with "--eval" and
diff --git a/lisp/subr.el b/lisp/subr.el
index c7e1864..59a1af0 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -31,7 +31,8 @@
"Tell the byte-compiler that function FN is defined, in FILE.
The FILE argument is not used by the byte-compiler, but by the
`check-declare' package, which checks that FILE contains a
-definition for FN.
+definition for FN. (FILE can be nil, and that disables this
+check.)
FILE can be either a Lisp file (in which case the \".el\"
extension is optional), or a C file. C files are expanded
@@ -6311,4 +6312,12 @@ of fill.el (for example `fill-region')."
This is intended for internal use only."
(internal--fill-string-single-line (apply #'format string objects)))
+(defun json-available-p ()
+ "Return non-nil if Emacs has libjansson support."
+ (and (fboundp 'json-serialize)
+ (condition-case nil
+ (json-serialize t)
+ (:success t)
+ (json-unavailable nil))))
+
;;; subr.el ends here
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index 41d565a..c63ef20 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -136,7 +136,7 @@ Possible modifier keys are `control', `meta', `shift',
`hyper', `super' and
;; Replace default value with a condition that supports displaying
;; global-mode-string in the tab bar instead of the mode line.
(when (and (memq 'tab-bar-format-global tab-bar-format)
- (member '(global-mode-string ("" global-mode-string " "))
+ (member '(global-mode-string ("" global-mode-string))
mode-line-misc-info))
(setf (alist-get 'global-mode-string mode-line-misc-info)
'(("" (:eval (if (and tab-bar-mode
diff --git a/lisp/term.el b/lisp/term.el
index d41895a..27f0bb1 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -864,8 +864,30 @@ is buffer-local."
["Paging" term-pager-toggle :style toggle :selected term-pager-count
:help "Toggle paging feature"]))
+(defun term--update-term-menu (&optional force)
+ (when (and (lookup-key term-mode-map [menu-bar terminal])
+ (or force (frame-or-buffer-changed-p)))
+ (let ((buffer-list
+ (seq-filter
+ (lambda (buffer)
+ (provided-mode-derived-p (buffer-local-value 'major-mode buffer)
+ 'term-mode))
+ (buffer-list))))
+ (easy-menu-change
+ '("Terminal")
+ "Terminal Buffers"
+ (mapcar
+ (lambda (buffer)
+ (vector (format "%s (%s)" (buffer-name buffer)
+ (abbreviate-file-name
+ (buffer-local-value 'default-directory buffer)))
+ (lambda ()
+ (interactive)
+ (switch-to-buffer buffer))))
+ buffer-list)))))
+
(easy-menu-define term-signals-menu
- (list term-mode-map term-raw-map term-pager-break-map)
+ (list term-mode-map term-raw-map term-pager-break-map)
"Signals menu for Term mode."
'("Signals"
["BREAK" term-interrupt-subjob :active t
@@ -1076,6 +1098,7 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(setq-local term-pending-delete-marker (make-marker))
(make-local-variable 'term-current-face)
(term-ansi-reset)
+ (add-hook 'menu-bar-update-hook 'term--update-term-menu)
(setq-local term-pending-frame nil)
;; Cua-mode's keybindings interfere with the term keybindings, disable it.
(setq-local cua-mode nil)
@@ -1275,7 +1298,10 @@ without any interpretation."
(defun term-char-mode ()
"Switch to char (\"raw\") sub-mode of term mode.
Each character you type is sent directly to the inferior without
-intervention from Emacs, except for the escape character (usually C-c)."
+intervention from Emacs, except for the escape character (usually C-c).
+
+This command will send existing partial lines to the terminal
+process."
(interactive)
;; FIXME: Emit message? Cfr ilisp-raw-message
(when (term-in-line-mode)
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index 3914bde..f394171 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -133,6 +133,8 @@ A nil return value means the function has not determined
the fill prefix."
(defvar fill-indent-according-to-mode nil ;Screws up CC-mode's filling tricks.
"Whether or not filling should try to use the major mode's indentation.")
+(defvar current-fill-column--has-warned nil)
+
(defun current-fill-column ()
"Return the fill-column to use for this line.
The fill-column to use for a buffer is stored in the variable `fill-column',
@@ -158,7 +160,14 @@ number equals or exceeds the local fill-column -
right-margin difference."
(< col fill-col)))
(setq here change
here-col col))
- (max here-col fill-col)))))
+ (max here-col fill-col))
+ ;; This warning was added in 28.1. It should be removed later,
+ ;; and this function changed to never return nil.
+ (unless current-fill-column--has-warned
+ (lwarn '(fill-column) :warning
+ "Setting this variable to nil is obsolete; use `(auto-fill-mode
-1)' instead")
+ (setq current-fill-column--has-warned t))
+ most-positive-fixnum)))
(defun canonically-space-region (beg end)
"Remove extra spaces between words in region.
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index 4acdc9f..fbb66fe 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -223,8 +223,10 @@ recorded somewhere by that function."
;;; Internal Variables:
-(defvar remember-buffer "*Remember*"
- "The name of the remember data entry buffer.")
+(defcustom remember-buffer "*Remember*"
+ "The name of the remember data entry buffer."
+ :version "28.1"
+ :type 'string)
(defcustom remember-save-after-remembering t
"Non-nil means automatically save after remembering."
@@ -240,10 +242,10 @@ recorded somewhere by that function."
(defvar remember-annotation nil
"Current annotation.")
(defvar remember-initial-contents nil
- "Initial contents to place into *Remember* buffer.")
+ "Initial contents to place into `remember-buffer'.")
(defcustom remember-before-remember-hook nil
- "Functions run before switching to the *Remember* buffer."
+ "Functions run before switching to the `remember-buffer'."
:type 'hook)
(defcustom remember-run-all-annotation-functions-flag nil
@@ -253,8 +255,8 @@ recorded somewhere by that function."
;;;###autoload
(defun remember (&optional initial)
"Remember an arbitrary piece of data.
-INITIAL is the text to initially place in the *Remember* buffer,
-or nil to bring up a blank *Remember* buffer.
+INITIAL is the text to initially place in the `remember-buffer',
+or nil to bring up a blank `remember-buffer'.
With a prefix or a visible region, use the region as INITIAL."
(interactive
@@ -422,7 +424,7 @@ return the text to be remembered."
(defun remember-region (&optional beg end)
"Remember the data from BEG to END.
-It is called from within the *Remember* buffer to save the text
+It is called from within the `remember-buffer' to save the text
that was entered.
If BEG and END are nil, the entire buffer will be remembered.
@@ -478,7 +480,7 @@ Most useful for remembering things from other applications."
(remember-region (point-min) (point-max)))
(defun remember-destroy ()
- "Destroy the current *Remember* buffer."
+ "Destroy the current `remember-buffer'."
(interactive)
(when (equal remember-buffer (buffer-name))
(kill-buffer (current-buffer))
diff --git a/lisp/time.el b/lisp/time.el
index fd53f63..9f25f99 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -205,7 +205,8 @@ depend on `display-time-day-and-date' and
`display-time-24hr-format'."
'mouse-face 'mode-line-highlight
'local-map (make-mode-line-mouse-map 'mouse-2
read-mail-command)))
- ""))
+ "")
+ " ")
"List of expressions governing display of the time in the mode line.
For most purposes, you can control the time format using `display-time-format'
which is a more standard interface.
diff --git a/lisp/url/url.el b/lisp/url/url.el
index 8daf9f0..a6565e2 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -208,9 +208,10 @@ URL-encoded before it's used."
(url-find-proxy-for-url url (url-host url))))
(buffer nil)
(asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
- (if url-using-proxy
- (setq asynch t
- loader #'url-proxy))
+ (when url-using-proxy
+ (setf asynch t
+ loader #'url-proxy
+ (url-asynchronous url) t))
(if asynch
(let ((url-current-object url))
(setq buffer (funcall loader url callback cbargs)))
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 89f9800..1430871 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -375,7 +375,7 @@ in the order given by `git status'."
"Return a string for `vc-mode-line' to put in the mode line for FILE."
(let* ((rev (vc-working-revision file 'Git))
(disp-rev (or (vc-git--symbolic-ref file)
- (substring rev 0 7)))
+ (and rev (substring rev 0 7))))
(def-ml (vc-default-mode-line-string 'Git file))
(help-echo (get-text-property 0 'help-echo def-ml))
(face (get-text-property 0 'face def-ml)))
@@ -1772,6 +1772,7 @@ The difference to vc-do-command is that this function
always invokes
(process-environment
(append
`("GIT_DIR"
+ "GIT_LITERAL_PATHSPECS=1"
;; Avoid repository locking during background operations
;; (bug#21559).
,@(when revert-buffer-in-progress-p
@@ -1806,6 +1807,7 @@ The difference to vc-do-command is that this function
always invokes
(process-environment
(append
`("GIT_DIR"
+ "GIT_LITERAL_PATHSPECS=1"
;; Avoid repository locking during background operations
;; (bug#21559).
,@(when revert-buffer-in-progress-p
diff --git a/lisp/wdired.el b/lisp/wdired.el
index 22c1ceb..fd549ba 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -297,26 +297,28 @@ or \\[wdired-abort-changes] to abort changes")))
(defun wdired--before-change-fn (beg end)
(save-match-data
(save-excursion
- ;; Make sure to process entire lines.
- (goto-char end)
- (setq end (line-end-position))
- (goto-char beg)
- (forward-line 0)
-
- (while (< (point) end)
- (unless (wdired--line-preprocessed-p)
+ (save-restriction
+ (widen)
+ ;; Make sure to process entire lines.
+ (goto-char end)
+ (setq end (line-end-position))
+ (goto-char beg)
+ (forward-line 0)
+
+ (while (< (point) end)
+ (unless (wdired--line-preprocessed-p)
+ (with-silent-modifications
+ (put-text-property (point) (1+ (point)) 'front-sticky t)
+ (wdired--preprocess-files)
+ (when wdired-allow-to-change-permissions
+ (wdired--preprocess-perms))
+ (when (fboundp 'make-symbolic-link)
+ (wdired--preprocess-symlinks))))
+ (forward-line))
+ (when (eobp)
(with-silent-modifications
- (put-text-property (point) (1+ (point)) 'front-sticky t)
- (wdired--preprocess-files)
- (when wdired-allow-to-change-permissions
- (wdired--preprocess-perms))
- (when (fboundp 'make-symbolic-link)
- (wdired--preprocess-symlinks))))
- (forward-line))
- (when (eobp)
- (with-silent-modifications
- ;; Is this good enough? Assumes no extra white lines from dired.
- (put-text-property (1- (point-max)) (point-max) 'read-only t))))))
+ ;; Is this good enough? Assumes no extra white lines from dired.
+ (put-text-property (1- (point-max)) (point-max) 'read-only t)))))))
(defun wdired-isearch-filter-read-only (beg end)
"Skip matches that have a read-only property."
@@ -700,47 +702,49 @@ Optional arguments are ignored."
(defun wdired--restore-properties (beg end _len)
(save-match-data
(save-excursion
- (let ((lep (line-end-position))
- (used-F (dired-check-switches
- dired-actual-switches
- "F" "classify")))
- ;; Deleting the space between the link name and the arrow (a
- ;; noop) also deletes the end-name property, so restore it.
- (when (and (save-excursion
- (re-search-backward dired-permission-flags-regexp nil t)
- (looking-at "l"))
- (get-text-property (1- (point)) 'dired-filename)
- (not (get-text-property (point) 'dired-filename))
- (not (get-text-property (point) 'end-name)))
+ (save-restriction
+ (widen)
+ (let ((lep (line-end-position))
+ (used-F (dired-check-switches
+ dired-actual-switches
+ "F" "classify")))
+ ;; Deleting the space between the link name and the arrow (a
+ ;; noop) also deletes the end-name property, so restore it.
+ (when (and (save-excursion
+ (re-search-backward dired-permission-flags-regexp nil t)
+ (looking-at "l"))
+ (get-text-property (1- (point)) 'dired-filename)
+ (not (get-text-property (point) 'dired-filename))
+ (not (get-text-property (point) 'end-name)))
(put-text-property (point) (1+ (point)) 'end-name t))
- (beginning-of-line)
- (when (re-search-forward
- directory-listing-before-filename-regexp lep t)
- (setq beg (point)
- end (if (or
- ;; If the file is a symlink, put the
- ;; dired-filename property only on the link
- ;; name. (Using (file-symlink-p
- ;; (dired-get-filename)) fails in
- ;; wdired-mode, bug#32673.)
- (and (re-search-backward
- dired-permission-flags-regexp nil t)
- (looking-at "l")
- ;; macOS and Ultrix adds "@" to the end
- ;; of symlinks when using -F.
- (if (and used-F
- dired-ls-F-marks-symlinks)
- (re-search-forward "@? -> " lep t)
- (search-forward " -> " lep t)))
- ;; When dired-listing-switches includes "F"
- ;; or "classify", don't treat appended
- ;; indicator characters as part of the file
- ;; name (bug#34915).
- (and used-F
- (re-search-forward "[*/@|=>]$" lep t)))
- (goto-char (match-beginning 0))
- lep))
- (put-text-property beg end 'dired-filename t))))))
+ (beginning-of-line)
+ (when (re-search-forward
+ directory-listing-before-filename-regexp lep t)
+ (setq beg (point)
+ end (if (or
+ ;; If the file is a symlink, put the
+ ;; dired-filename property only on the link
+ ;; name. (Using (file-symlink-p
+ ;; (dired-get-filename)) fails in
+ ;; wdired-mode, bug#32673.)
+ (and (re-search-backward
+ dired-permission-flags-regexp nil t)
+ (looking-at "l")
+ ;; macOS and Ultrix adds "@" to the end
+ ;; of symlinks when using -F.
+ (if (and used-F
+ dired-ls-F-marks-symlinks)
+ (re-search-forward "@? -> " lep t)
+ (search-forward " -> " lep t)))
+ ;; When dired-listing-switches includes "F"
+ ;; or "classify", don't treat appended
+ ;; indicator characters as part of the file
+ ;; name (bug#34915).
+ (and used-F
+ (re-search-forward "[*/@|=>]$" lep t)))
+ (goto-char (match-beginning 0))
+ lep))
+ (put-text-property beg end 'dired-filename t)))))))
(defun wdired-next-line (arg)
"Move down lines then position at filename or the current column.
diff --git a/lisp/woman.el b/lisp/woman.el
index d9aa573..0bc992d 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -1274,9 +1274,11 @@ cache to be re-read."
;; Complete topic more carefully, i.e. use the completion
;; rather than the string entered by the user:
((setq files (all-completions topic woman-topic-all-completions))
- (while (/= (length topic) (length (car files)))
+ (while (and files
+ (/= (length topic) (length (car files))))
(setq files (cdr files)))
- (setq files (woman-file-name-all-completions (car files)))))
+ (when files
+ (setq files (woman-file-name-all-completions (car files))))))
(cond
((null files) nil) ; no file found for topic.
((null (cdr files)) (car (car files))) ; only 1 file for topic.
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index cd6f7b4..05e7faa 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -89,6 +89,7 @@ AC_DEFUN([gl_EARLY],
# Code from module fcntl:
# Code from module fcntl-h:
# Code from module fdopendir:
+ # Code from module file-has-acl:
# Code from module filemode:
# Code from module filename:
# Code from module filevercmp:
@@ -287,6 +288,7 @@ AC_DEFUN([gl_INIT],
fi
gl_DIRENT_MODULE_INDICATOR([fdopendir])
gl_MODULE_INDICATOR([fdopendir])
+ gl_FILE_HAS_ACL
gl_FILEMODE
AC_C_FLEXIBLE_ARRAY_MEMBER
gl_FUNC_FPENDING
@@ -1045,6 +1047,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/fcntl.c
lib/fcntl.in.h
lib/fdopendir.c
+ lib/file-has-acl.c
lib/filemode.c
lib/filemode.h
lib/filename.h
diff --git a/nt/gnulib-cfg.mk b/nt/gnulib-cfg.mk
index 5cdbde6..c85b915 100644
--- a/nt/gnulib-cfg.mk
+++ b/nt/gnulib-cfg.mk
@@ -68,3 +68,4 @@ OMIT_GNULIB_MODULE_fchmodat = true
OMIT_GNULIB_MODULE_lchmod = true
OMIT_GNULIB_MODULE_futimens = true
OMIT_GNULIB_MODULE_utimensat = true
+OMIT_GNULIB_MODULE_file-has-acl = true
diff --git a/src/buffer.c b/src/buffer.c
index 02ca23e..b177c5e 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -781,15 +781,22 @@ fetch_buffer_markers (struct buffer *b)
DEFUN ("make-indirect-buffer", Fmake_indirect_buffer, Smake_indirect_buffer,
- 2, 3,
+ 2, 4,
"bMake indirect buffer (to buffer): \nBName of indirect buffer: ",
doc: /* Create and return an indirect buffer for buffer BASE-BUFFER,
named NAME.
BASE-BUFFER should be a live buffer, or the name of an existing buffer.
+
NAME should be a string which is not the name of an existing buffer.
Optional argument CLONE non-nil means preserve BASE-BUFFER's state,
such as major and minor modes, in the indirect buffer.
-CLONE nil means the indirect buffer's state is reset to default values. */)
- (Lisp_Object base_buffer, Lisp_Object name, Lisp_Object clone)
+
+CLONE nil means the indirect buffer's state is reset to default values.
+
+If optional argument INHIBIT-BUFFER-HOOKS is non-nil, the new buffer
+does not run the hooks `kill-buffer-hook',
+`kill-buffer-query-functions', and `buffer-list-update-hook'. */)
+ (Lisp_Object base_buffer, Lisp_Object name, Lisp_Object clone,
+ Lisp_Object inhibit_buffer_hooks)
{
Lisp_Object buf, tem;
struct buffer *b;
@@ -834,6 +841,7 @@ CLONE nil means the indirect buffer's state is reset to
default values. */)
b->pt_byte = b->base_buffer->pt_byte;
b->begv_byte = b->base_buffer->begv_byte;
b->zv_byte = b->base_buffer->zv_byte;
+ b->inhibit_buffer_hooks = !NILP (inhibit_buffer_hooks);
b->newline_cache = 0;
b->width_run_cache = 0;
@@ -1076,12 +1084,12 @@ reset_buffer_local_variables (struct buffer *b, bool
permanent_too)
for (newlist = Qnil; CONSP (list); list = XCDR (list))
{
Lisp_Object elt = XCAR (list);
- /* Preserve element ELT if it's t,
- if it is a function with a `permanent-local-hook'
property,
- or if it's not a symbol. */
- if (! SYMBOLP (elt)
- || EQ (elt, Qt)
- || !NILP (Fget (elt, Qpermanent_local_hook)))
+ /* Preserve element ELT if it's t, or if it is a
+ function with a `permanent-local-hook'
+ property. */
+ if (EQ (elt, Qt)
+ || (SYMBOLP (elt)
+ && !NILP (Fget (elt, Qpermanent_local_hook))))
newlist = Fcons (elt, newlist);
}
newlist = Fnreverse (newlist);
@@ -4214,7 +4222,11 @@ OVERLAY. */)
DEFUN ("overlays-at", Foverlays_at, Soverlays_at, 1, 2, 0,
doc: /* Return a list of the overlays that contain the character at POS.
-If SORTED is non-nil, then sort them by decreasing priority. */)
+If SORTED is non-nil, then sort them by decreasing priority.
+
+Zero-length overlays that start and stop at POS are not included in
+the return value. Instead use `overlays-in' if those overlays are of
+interest. */)
(Lisp_Object pos, Lisp_Object sorted)
{
ptrdiff_t len, noverlays;
diff --git a/src/callint.c b/src/callint.c
index 1862463..6f8a7f1 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -892,7 +892,10 @@ behave as if the mark were still active. */);
Vmark_even_if_inactive = Qt;
DEFVAR_LISP ("mouse-leave-buffer-hook", Vmouse_leave_buffer_hook,
- doc: /* Hook to run when about to switch windows with a mouse
command.
+ doc: /* Hook run when the user mouse-clicks in a window.
+It can be run both before and after switching windows, or even when
+not actually switching windows.
+
Its purpose is to give temporary modes such as Isearch mode
a way to turn themselves off when a mouse command switches windows. */);
Vmouse_leave_buffer_hook = Qnil;
diff --git a/src/chartab.c b/src/chartab.c
index 331e859..6f0bc28 100644
--- a/src/chartab.c
+++ b/src/chartab.c
@@ -62,6 +62,9 @@ typedef Lisp_Object (*uniprop_encoder_t) (Lisp_Object,
Lisp_Object);
static Lisp_Object uniprop_table_uncompress (Lisp_Object, int);
static uniprop_decoder_t uniprop_get_decoder (Lisp_Object);
+static Lisp_Object
+sub_char_table_ref_and_range (Lisp_Object, int, int *, int *,
+ Lisp_Object, bool);
/* 1 iff TABLE is a uniprop table. */
#define UNIPROP_TABLE_P(TABLE) \
@@ -247,6 +250,23 @@ char_table_ref (Lisp_Object table, int c)
return val;
}
+static inline Lisp_Object
+char_table_ref_simple (Lisp_Object table, int idx, int c, int *from, int *to,
+ Lisp_Object defalt, bool is_uniprop, bool is_subtable)
+{
+ Lisp_Object val = is_subtable ?
+ XSUB_CHAR_TABLE (table)->contents[idx]:
+ XCHAR_TABLE (table)->contents[idx];
+ if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
+ val = uniprop_table_uncompress (table, idx);
+ if (SUB_CHAR_TABLE_P (val))
+ val = sub_char_table_ref_and_range (val, c, from, to,
+ defalt, is_uniprop);
+ else if (NILP (val))
+ val = defalt;
+ return val;
+}
+
static Lisp_Object
sub_char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to,
Lisp_Object defalt, bool is_uniprop)
@@ -254,31 +274,18 @@ sub_char_table_ref_and_range (Lisp_Object table, int c,
int *from, int *to,
struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
int depth = tbl->depth, min_char = tbl->min_char;
int chartab_idx = CHARTAB_IDX (c, depth, min_char), idx;
- Lisp_Object val;
-
- val = tbl->contents[chartab_idx];
- if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
- val = uniprop_table_uncompress (table, chartab_idx);
- if (SUB_CHAR_TABLE_P (val))
- val = sub_char_table_ref_and_range (val, c, from, to, defalt, is_uniprop);
- else if (NILP (val))
- val = defalt;
+ Lisp_Object val
+ = char_table_ref_simple (table, chartab_idx, c, from, to,
+ defalt, is_uniprop, true);
idx = chartab_idx;
while (idx > 0 && *from < min_char + idx * chartab_chars[depth])
{
- Lisp_Object this_val;
-
c = min_char + idx * chartab_chars[depth] - 1;
idx--;
- this_val = tbl->contents[idx];
- if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
- this_val = uniprop_table_uncompress (table, idx);
- if (SUB_CHAR_TABLE_P (this_val))
- this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt,
- is_uniprop);
- else if (NILP (this_val))
- this_val = defalt;
+ Lisp_Object this_val
+ = char_table_ref_simple (table, idx, c, from, to,
+ defalt, is_uniprop, true);
if (! EQ (this_val, val))
{
@@ -290,17 +297,11 @@ sub_char_table_ref_and_range (Lisp_Object table, int c,
int *from, int *to,
< chartab_chars[depth - 1])
&& (c += min_char) <= *to)
{
- Lisp_Object this_val;
-
chartab_idx++;
- this_val = tbl->contents[chartab_idx];
- if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
- this_val = uniprop_table_uncompress (table, chartab_idx);
- if (SUB_CHAR_TABLE_P (this_val))
- this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt,
- is_uniprop);
- else if (NILP (this_val))
- this_val = defalt;
+ Lisp_Object this_val
+ = char_table_ref_simple (table, chartab_idx, c, from, to,
+ defalt, is_uniprop, true);
+
if (! EQ (this_val, val))
{
*to = c - 1;
@@ -321,37 +322,26 @@ Lisp_Object
char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to)
{
struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
- int chartab_idx = CHARTAB_IDX (c, 0, 0), idx;
- Lisp_Object val;
+ int chartab_idx = CHARTAB_IDX (c, 0, 0);
bool is_uniprop = UNIPROP_TABLE_P (table);
- val = tbl->contents[chartab_idx];
if (*from < 0)
*from = 0;
if (*to < 0)
*to = MAX_CHAR;
- if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
- val = uniprop_table_uncompress (table, chartab_idx);
- if (SUB_CHAR_TABLE_P (val))
- val = sub_char_table_ref_and_range (val, c, from, to, tbl->defalt,
- is_uniprop);
- else if (NILP (val))
- val = tbl->defalt;
- idx = chartab_idx;
+
+ Lisp_Object val
+ = char_table_ref_simple (table, chartab_idx, c, from, to,
+ tbl->defalt, is_uniprop, false);
+
+ int idx = chartab_idx;
while (*from < idx * chartab_chars[0])
{
- Lisp_Object this_val;
-
c = idx * chartab_chars[0] - 1;
idx--;
- this_val = tbl->contents[idx];
- if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
- this_val = uniprop_table_uncompress (table, idx);
- if (SUB_CHAR_TABLE_P (this_val))
- this_val = sub_char_table_ref_and_range (this_val, c, from, to,
- tbl->defalt, is_uniprop);
- else if (NILP (this_val))
- this_val = tbl->defalt;
+ Lisp_Object this_val
+ = char_table_ref_simple (table, idx, c, from, to,
+ tbl->defalt, is_uniprop, false);
if (! EQ (this_val, val))
{
@@ -361,18 +351,12 @@ char_table_ref_and_range (Lisp_Object table, int c, int
*from, int *to)
}
while (*to >= (chartab_idx + 1) * chartab_chars[0])
{
- Lisp_Object this_val;
-
chartab_idx++;
c = chartab_idx * chartab_chars[0];
- this_val = tbl->contents[chartab_idx];
- if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
- this_val = uniprop_table_uncompress (table, chartab_idx);
- if (SUB_CHAR_TABLE_P (this_val))
- this_val = sub_char_table_ref_and_range (this_val, c, from, to,
- tbl->defalt, is_uniprop);
- else if (NILP (this_val))
- this_val = tbl->defalt;
+ Lisp_Object this_val
+ = char_table_ref_simple (table, chartab_idx, c, from, to,
+ tbl->defalt, is_uniprop, false);
+
if (! EQ (this_val, val))
{
*to = c - 1;
diff --git a/src/coding.c b/src/coding.c
index 46e7fca..87b55ae 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -9476,7 +9476,7 @@ not fully specified.) */)
}
/* Whether STRING only contains chars in the 0..127 range. */
-static bool
+bool
string_ascii_p (Lisp_Object string)
{
ptrdiff_t nbytes = SBYTES (string);
diff --git a/src/data.c b/src/data.c
index 9adfafa..ffca7e7 100644
--- a/src/data.c
+++ b/src/data.c
@@ -3901,6 +3901,7 @@ syms_of_data (void)
DEFSYM (Qerror, "error");
DEFSYM (Quser_error, "user-error");
DEFSYM (Qquit, "quit");
+ DEFSYM (Qminibuffer_quit, "minibuffer-quit");
DEFSYM (Qwrong_length_argument, "wrong-length-argument");
DEFSYM (Qwrong_type_argument, "wrong-type-argument");
DEFSYM (Qargs_out_of_range, "args-out-of-range");
@@ -3973,6 +3974,7 @@ syms_of_data (void)
Fput (sym, Qerror_message, build_pure_c_string (msg))
PUT_ERROR (Qquit, Qnil, "Quit");
+ PUT_ERROR (Qminibuffer_quit, pure_cons (Qquit, Qnil), "Quit");
PUT_ERROR (Quser_error, error_tail, "");
PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
diff --git a/src/eval.c b/src/eval.c
index b76ced7..48104bd 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2026,6 +2026,18 @@ skip_debugger (Lisp_Object conditions, Lisp_Object data)
return 0;
}
+/* Say whether SIGNAL is a `quit' symbol (or inherits from it). */
+bool
+signal_quit_p (Lisp_Object signal)
+{
+ Lisp_Object list;
+
+ return EQ (signal, Qquit)
+ || (!NILP (Fsymbolp (signal))
+ && CONSP (list = Fget (signal, Qerror_conditions))
+ && !NILP (Fmemq (Qquit, list)));
+}
+
/* Call the debugger if calling it is currently enabled for CONDITIONS.
SIG and DATA describe the signal. There are two ways to pass them:
= SIG is the error symbol, and DATA is the rest of the data.
@@ -2044,7 +2056,7 @@ maybe_call_debugger (Lisp_Object conditions, Lisp_Object
sig, Lisp_Object data)
! input_blocked_p ()
&& NILP (Vinhibit_debugger)
/* Does user want to enter debugger for this kind of error? */
- && (EQ (sig, Qquit)
+ && (signal_quit_p (sig)
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
&& ! skip_debugger (conditions, combined_data)
diff --git a/src/fileio.c b/src/fileio.c
index 04c9d7d..13c99be 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -749,6 +749,114 @@ For that reason, you should normally use `make-temp-file'
instead. */)
empty_unibyte_string, Qnil);
}
+DEFUN ("file-name-concat", Ffile_name_concat, Sfile_name_concat, 1, MANY, 0,
+ doc: /* Append COMPONENTS to DIRECTORY and return the resulting string.
+Elements in COMPONENTS must be a string or nil.
+DIRECTORY or the non-final elements in COMPONENTS may or may not end
+with a slash -- if they don't end with a slash, a slash will be
+inserted before contatenating.
+usage: (record DIRECTORY &rest COMPONENTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t chars = 0, bytes = 0, multibytes = 0, eargs = 0;
+ Lisp_Object *elements = args;
+ Lisp_Object result;
+ ptrdiff_t i;
+
+ /* First go through the list to check the types and see whether
+ they're all of the same multibytedness. */
+ for (i = 0; i < nargs; i++)
+ {
+ Lisp_Object arg = args[i];
+ /* Skip empty and nil elements. */
+ if (NILP (arg))
+ continue;
+ CHECK_STRING (arg);
+ if (SCHARS (arg) == 0)
+ continue;
+ eargs++;
+ /* Multibyte and non-ASCII. */
+ if (STRING_MULTIBYTE (arg) && SCHARS (arg) != SBYTES (arg))
+ multibytes++;
+ /* We're not adding a slash to the final part. */
+ if (i == nargs - 1
+ || IS_DIRECTORY_SEP (*(SSDATA (arg) + SBYTES (arg) - 1)))
+ {
+ bytes += SBYTES (arg);
+ chars += SCHARS (arg);
+ }
+ else
+ {
+ bytes += SBYTES (arg) + 1;
+ chars += SCHARS (arg) + 1;
+ }
+ }
+
+ /* Convert if needed. */
+ if ((multibytes != 0 && multibytes != nargs)
+ || eargs != nargs)
+ {
+ int j = 0;
+ elements = xmalloc (eargs * sizeof *elements);
+ bytes = 0;
+ chars = 0;
+
+ /* Filter out nil/"". */
+ for (i = 0; i < nargs; i++)
+ {
+ Lisp_Object arg = args[i];
+ if (!NILP (arg) && SCHARS (arg) != 0)
+ elements[j++] = arg;
+ }
+
+ for (i = 0; i < eargs; i++)
+ {
+ Lisp_Object arg = elements[i];
+ /* Use multibyte or all-ASCII strings as is. */
+ if (!STRING_MULTIBYTE (arg) && !string_ascii_p (arg))
+ elements[i] = Fstring_to_multibyte (arg);
+ arg = elements[i];
+ /* We have to recompute the number of bytes. */
+ if (i == eargs - 1
+ || IS_DIRECTORY_SEP (*(SSDATA (arg) + SBYTES (arg) - 1)))
+ {
+ bytes += SBYTES (arg);
+ chars += SCHARS (arg);
+ }
+ else
+ {
+ bytes += SBYTES (arg) + 1;
+ chars += SCHARS (arg) + 1;
+ }
+ }
+ }
+
+ /* Allocate an empty string. */
+ if (multibytes == 0)
+ result = make_uninit_string (chars);
+ else
+ result = make_uninit_multibyte_string (chars, bytes);
+ /* Null-terminate the string. */
+ *(SSDATA (result) + SBYTES (result)) = 0;
+
+ /* Copy over the data. */
+ char *p = SSDATA (result);
+ for (i = 0; i < eargs; i++)
+ {
+ Lisp_Object arg = elements[i];
+ memcpy (p, SSDATA (arg), SBYTES (arg));
+ p += SBYTES (arg);
+ /* The last element shouldn't have a slash added at the end. */
+ if (i < eargs - 1 && !IS_DIRECTORY_SEP (*(p - 1)))
+ *p++ = DIRECTORY_SEP;
+ }
+
+ if (elements != args)
+ xfree (elements);
+
+ return result;
+}
+
/* NAME must be a string. */
static bool
file_name_absolute_no_tilde_p (Lisp_Object name)
@@ -6488,6 +6596,7 @@ This includes interactive calls to `delete-file' and
defsubr (&Sdirectory_file_name);
defsubr (&Smake_temp_file_internal);
defsubr (&Smake_temp_name);
+ defsubr (&Sfile_name_concat);
defsubr (&Sexpand_file_name);
defsubr (&Ssubstitute_in_file_name);
defsubr (&Scopy_file);
diff --git a/src/filelock.c b/src/filelock.c
index 106633f..cc185d9 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -673,7 +673,7 @@ lock_file (Lisp_Object fn)
Lisp_Object subject_buf = get_truename_buffer (fn);
if (!NILP (subject_buf)
&& NILP (Fverify_visited_file_modtime (subject_buf))
- && !NILP (Ffile_exists_p (lock_filename))
+ && !NILP (Ffile_exists_p (fn))
&& current_lock_owner (NULL, lfname) != -2)
call1 (intern ("userlock--ask-user-about-supersession-threat"), fn);
diff --git a/src/fns.c b/src/fns.c
index a178216..932800a 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -3955,7 +3955,7 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t
length,
if (c == '=')
continue;
- if (v1 < 0)
+ if (v1 == 0)
return -1;
value += v1 - 1;
@@ -5769,16 +5769,6 @@ characters. */ )
return list3 (make_int (lines), make_int (longest), make_float (mean));
}
-static bool
-string_ascii_p (Lisp_Object string)
-{
- ptrdiff_t nbytes = SBYTES (string);
- for (ptrdiff_t i = 0; i < nbytes; i++)
- if (SREF (string, i) > 127)
- return false;
- return true;
-}
-
DEFUN ("string-search", Fstring_search, Sstring_search, 2, 3, 0,
doc: /* Search for the string NEEDLE in the string HAYSTACK.
The return value is the position of the first occurrence of NEEDLE in
diff --git a/src/frame.c b/src/frame.c
index 3c7c407..94e0073 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -1021,6 +1021,10 @@ make_frame (bool mini_p)
rw->total_lines = FRAME_LINES (f) - (mini_p ? 1 : 0);
rw->pixel_height = rw->total_lines * FRAME_LINE_HEIGHT (f);
+ fset_face_hash_table
+ (f, make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
+ DEFAULT_REHASH_THRESHOLD, Qnil, false));
+
if (mini_p)
{
mw->top_line = rw->total_lines;
@@ -1329,7 +1333,7 @@ affects all frames on the same terminal device. */)
{
struct frame *f;
struct terminal *t = NULL;
- Lisp_Object frame, tem;
+ Lisp_Object frame;
struct frame *sf = SELECTED_FRAME ();
#ifdef MSDOS
@@ -1411,14 +1415,16 @@ affects all frames on the same terminal device. */)
store_in_alist (&parms, Qminibuffer, Qt);
Fmodify_frame_parameters (frame, parms);
- /* Make the frame face alist be frame-specific, so that each
+ /* Make the frame face hash be frame-specific, so that each
frame could change its face definitions independently. */
- fset_face_alist (f, Fcopy_alist (sf->face_alist));
- /* Simple Fcopy_alist isn't enough, because we need the contents of
- the vectors which are the CDRs of associations in face_alist to
+ fset_face_hash_table (f, Fcopy_hash_table (sf->face_hash_table));
+ /* Simple copy_hash_table isn't enough, because we need the contents of
+ the vectors which are the values in face_hash_table to
be copied as well. */
- for (tem = f->face_alist; CONSP (tem); tem = XCDR (tem))
- XSETCDR (XCAR (tem), Fcopy_sequence (XCDR (XCAR (tem))));
+ ptrdiff_t idx = 0;
+ struct Lisp_Hash_Table *table = XHASH_TABLE (f->face_hash_table);
+ for (idx = 0; idx < table->count; ++idx)
+ set_hash_value_slot (table, idx, Fcopy_sequence (HASH_VALUE (table, idx)));
f->can_set_window_size = true;
f->after_make_frame = true;
diff --git a/src/frame.h b/src/frame.h
index d3ae548..9856890 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -158,8 +158,8 @@ struct frame
There are four additional elements of nil at the end, to terminate. */
Lisp_Object menu_bar_items;
- /* Alist of elements (FACE-NAME . FACE-VECTOR-DATA). */
- Lisp_Object face_alist;
+ /* Hash table of FACE-NAME keys and FACE-VECTOR-DATA values. */
+ Lisp_Object face_hash_table;
/* A vector that records the entire structure of this frame's menu bar.
For the format of the data, see extensive comments in xmenu.c.
@@ -673,9 +673,9 @@ fset_condemned_scroll_bars (struct frame *f, Lisp_Object
val)
f->condemned_scroll_bars = val;
}
INLINE void
-fset_face_alist (struct frame *f, Lisp_Object val)
+fset_face_hash_table (struct frame *f, Lisp_Object val)
{
- f->face_alist = val;
+ f->face_hash_table = val;
}
#if defined (HAVE_WINDOW_SYSTEM)
INLINE void
diff --git a/src/ftfont.c b/src/ftfont.c
index 0603dd9..12d0d72 100644
--- a/src/ftfont.c
+++ b/src/ftfont.c
@@ -2798,10 +2798,31 @@ ftfont_shape_by_flt (Lisp_Object lgstring, struct font
*font,
if (gstring.used > LGSTRING_GLYPH_LEN (lgstring))
return Qnil;
+
+ /* mflt_run may fail to set g->g.to (which must be a valid index
+ into lgstring) correctly if the font has an OTF table that is
+ different from what the m17n library expects. */
for (i = 0; i < gstring.used; i++)
{
MFLTGlyphFT *g = (MFLTGlyphFT *) (gstring.glyphs) + i;
+ if (g->g.to >= len)
+ {
+ /* Invalid g->g.to. */
+ g->g.to = len - 1;
+ int from = g->g.from;
+ /* Fix remaining glyphs. */
+ for (++i; i < gstring.used; i++)
+ {
+ g = (MFLTGlyphFT *) (gstring.glyphs) + i;
+ g->g.from = from;
+ g->g.to = len - 1;
+ }
+ }
+ }
+ for (i = 0; i < gstring.used; i++)
+ {
+ MFLTGlyphFT *g = (MFLTGlyphFT *) (gstring.glyphs) + i;
g->g.from = LGLYPH_FROM (LGSTRING_GLYPH (lgstring, g->g.from));
g->g.to = LGLYPH_TO (LGSTRING_GLYPH (lgstring, g->g.to));
}
diff --git a/src/json.c b/src/json.c
index 3f1d27a..b0779b9 100644
--- a/src/json.c
+++ b/src/json.c
@@ -595,10 +595,8 @@ usage: (json-serialize OBJECT &rest ARGS) */)
Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
}
if (!json_initialized)
- {
- message1 ("jansson library not found");
- return Qnil;
- }
+ Fsignal (Qjson_unavailable,
+ list1 (build_unibyte_string ("jansson library not found")));
#endif
struct json_configuration conf =
@@ -706,10 +704,8 @@ usage: (json-insert OBJECT &rest ARGS) */)
Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
}
if (!json_initialized)
- {
- message1 ("jansson library not found");
- return Qnil;
- }
+ Fsignal (Qjson_unavailable,
+ list1 (build_unibyte_string ("jansson library not found")));
#endif
struct json_configuration conf =
@@ -965,10 +961,8 @@ usage: (json-parse-string STRING &rest ARGS) */)
Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
}
if (!json_initialized)
- {
- message1 ("jansson library not found");
- return Qnil;
- }
+ Fsignal (Qjson_unavailable,
+ list1 (build_unibyte_string ("jansson library not found")));
#endif
Lisp_Object string = args[0];
@@ -1064,10 +1058,8 @@ usage: (json-parse-buffer &rest args) */)
Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
}
if (!json_initialized)
- {
- message1 ("jansson library not found");
- return Qnil;
- }
+ Fsignal (Qjson_unavailable,
+ list1 (build_unibyte_string ("jansson library not found")));
#endif
struct json_configuration conf =
@@ -1129,6 +1121,7 @@ syms_of_json (void)
DEFSYM (Qjson_end_of_file, "json-end-of-file");
DEFSYM (Qjson_trailing_content, "json-trailing-content");
DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
+ DEFSYM (Qjson_unavailable, "json-unavailable");
define_error (Qjson_error, "generic JSON error", Qerror);
define_error (Qjson_out_of_memory,
"not enough memory for creating JSON object", Qjson_error);
diff --git a/src/keyboard.c b/src/keyboard.c
index 7d04564..5b828ca 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -725,6 +725,9 @@ recursive_edit_1 (void)
if (STRINGP (val))
xsignal1 (Qerror, val);
+ if (FUNCTIONP (val))
+ call0 (val);
+
return unbind_to (count, Qnil);
}
@@ -921,6 +924,7 @@ static Lisp_Object
cmd_error (Lisp_Object data)
{
Lisp_Object old_level, old_length;
+ Lisp_Object conditions;
char macroerror[sizeof "After..kbd macro iterations: "
+ INT_STRLEN_BOUND (EMACS_INT)];
@@ -940,10 +944,15 @@ cmd_error (Lisp_Object data)
else
*macroerror = 0;
+ conditions = Fget (XCAR (data), Qerror_conditions);
+ if (NILP (Fmemq (Qminibuffer_quit, conditions)))
+ {
+ Vexecuting_kbd_macro = Qnil;
+ executing_kbd_macro = Qnil;
+ }
+
Vstandard_output = Qt;
Vstandard_input = Qt;
- Vexecuting_kbd_macro = Qnil;
- executing_kbd_macro = Qnil;
kset_prefix_arg (current_kboard, Qnil);
kset_last_prefix_arg (current_kboard, Qnil);
cancel_echoing ();
@@ -976,7 +985,7 @@ cmd_error_internal (Lisp_Object data, const char *context)
{
/* The immediate context is not interesting for Quits,
since they are asynchronous. */
- if (EQ (XCAR (data), Qquit))
+ if (signal_quit_p (XCAR (data)))
Vsignaling_function = Qnil;
Vquit_flag = Qnil;
@@ -998,6 +1007,7 @@ Default value of `command-error-function'. */)
(Lisp_Object data, Lisp_Object context, Lisp_Object signal)
{
struct frame *sf = SELECTED_FRAME ();
+ Lisp_Object conditions;
CHECK_STRING (context);
@@ -1024,17 +1034,27 @@ Default value of `command-error-function'. */)
}
else
{
+ conditions = Fget (XCAR (data), Qerror_conditions);
+
clear_message (1, 0);
- Fdiscard_input ();
message_log_maybe_newline ();
- bitch_at_user ();
+
+ if (!NILP (Fmemq (Qminibuffer_quit, conditions)))
+ {
+ Fding (Qt);
+ }
+ else
+ {
+ Fdiscard_input ();
+ bitch_at_user ();
+ }
print_error_message (data, Qt, SSDATA (context), signal);
}
return Qnil;
}
-static Lisp_Object command_loop_2 (Lisp_Object);
+static Lisp_Object command_loop_1 (void);
static Lisp_Object top_level_1 (Lisp_Object);
/* Entry to editor-command-loop.
@@ -1062,7 +1082,7 @@ command_loop (void)
if (command_loop_level > 0 || minibuf_level > 0)
{
Lisp_Object val;
- val = internal_catch (Qexit, command_loop_2, Qnil);
+ val = internal_catch (Qexit, command_loop_2, Qerror);
executing_kbd_macro = Qnil;
return val;
}
@@ -1070,7 +1090,7 @@ command_loop (void)
while (1)
{
internal_catch (Qtop_level, top_level_1, Qnil);
- internal_catch (Qtop_level, command_loop_2, Qnil);
+ internal_catch (Qtop_level, command_loop_2, Qerror);
executing_kbd_macro = Qnil;
/* End of file in -batch run causes exit here. */
@@ -1083,15 +1103,16 @@ command_loop (void)
editing loop, and reenter the editing loop.
When there is an error, cmd_error runs and returns a non-nil
value to us. A value of nil means that command_loop_1 itself
- returned due to end of file (or end of kbd macro). */
+ returned due to end of file (or end of kbd macro). HANDLERS is a
+ list of condition names, passed to internal_condition_case. */
-static Lisp_Object
-command_loop_2 (Lisp_Object ignore)
+Lisp_Object
+command_loop_2 (Lisp_Object handlers)
{
register Lisp_Object val;
do
- val = internal_condition_case (command_loop_1, Qerror, cmd_error);
+ val = internal_condition_case (command_loop_1, handlers, cmd_error);
while (!NILP (val));
return Qnil;
@@ -1234,7 +1255,7 @@ static int read_key_sequence (Lisp_Object *, Lisp_Object,
bool, bool, bool, bool);
static void adjust_point_for_property (ptrdiff_t, bool);
-Lisp_Object
+static Lisp_Object
command_loop_1 (void)
{
modiff_count prev_modiff = 0;
@@ -6630,8 +6651,11 @@ DEFUN ("event-convert-list", Fevent_convert_list,
Sevent_convert_list, 1, 1, 0,
EVENT-DESC should contain one base event type (a character or symbol)
and zero or more modifier names (control, meta, hyper, super, shift, alt,
drag, down, double or triple). The base must be last.
-The return value is an event type (a character or symbol) which
-has the same base event type and all the specified modifiers. */)
+
+The return value is an event type (a character or symbol) which has
+essentially the same base event type and all the specified modifiers.
+(Some compatibility base types, like symbols that represent a
+character, are not returned verbatim.) */)
(Lisp_Object event_desc)
{
Lisp_Object base = Qnil;
@@ -7618,7 +7642,7 @@ menu_item_eval_property_1 (Lisp_Object arg)
{
/* If we got a quit from within the menu computation,
quit all the way out of it. This takes care of C-] in the debugger. */
- if (CONSP (arg) && EQ (XCAR (arg), Qquit))
+ if (CONSP (arg) && signal_quit_p (XCAR (arg)))
quit ();
return Qnil;
@@ -9603,17 +9627,23 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object
prompt,
(interrupted_kboard,
Fcons (make_lispy_switch_frame (frame),
KVAR (interrupted_kboard, kbd_queue)));
+ mock_input = 0;
+ }
+ else
+ {
+ if (FIXNUMP (key) && XFIXNUM (key) != -2)
+ {
+ /* If interrupted while initializing terminal, we
+ need to replay the interrupting key. See
+ Bug#5095 and Bug#37782. */
+ mock_input = 1;
+ keybuf[0] = key;
+ }
+ else
+ {
+ mock_input = 0;
+ }
}
- if (FIXNUMP (key) && XFIXNUM (key) != -2)
- {
- /* If interrupted while initializing terminal, we
- need to replay the interrupting key. See
- Bug#5095 and Bug#37782. */
- mock_input = 1;
- keybuf[0] = key;
- }
- else
- mock_input = 0;
goto replay_entire_sequence;
}
}
diff --git a/src/lisp.h b/src/lisp.h
index 1795b9d..15a42a4 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3586,6 +3586,7 @@ extern Lisp_Object detect_coding_system (const unsigned
char *, ptrdiff_t,
extern void init_coding (void);
extern void init_coding_once (void);
extern void syms_of_coding (void);
+extern bool string_ascii_p (Lisp_Object);
/* Defined in character.c. */
extern ptrdiff_t chars_in_text (const unsigned char *, ptrdiff_t);
@@ -4116,6 +4117,7 @@ extern Lisp_Object Vautoload_queue;
extern Lisp_Object Vrun_hooks;
extern Lisp_Object Vsignaling_function;
extern Lisp_Object inhibit_lisp_code;
+extern bool signal_quit_p (Lisp_Object);
/* To run a normal hook, use the appropriate function from the list below.
The calling convention:
@@ -4417,7 +4419,7 @@ extern bool detect_input_pending_ignore_squeezables
(void);
extern bool detect_input_pending_run_timers (bool);
extern void safe_run_hooks (Lisp_Object);
extern void cmd_error_internal (Lisp_Object, const char *);
-extern Lisp_Object command_loop_1 (void);
+extern Lisp_Object command_loop_2 (Lisp_Object);
extern Lisp_Object read_menu_command (void);
extern Lisp_Object recursive_edit_1 (void);
extern void record_auto_save (void);
diff --git a/src/macros.c b/src/macros.c
index 60d0766..0752a5b 100644
--- a/src/macros.c
+++ b/src/macros.c
@@ -324,7 +324,7 @@ buffer before the macro is executed. */)
break;
}
- command_loop_1 ();
+ command_loop_2 (list1 (Qminibuffer_quit));
executing_kbd_macro_iterations = ++success_count;
diff --git a/src/minibuf.c b/src/minibuf.c
index 1b842b7..0f4349e 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -496,7 +496,7 @@ confirm the aborting of the current minibuffer and all
contained ones. */)
}
}
else
- Fthrow (Qexit, Qt);
+ CALLN (Ffuncall, intern ("minibuffer-quit-recursive-edit"));
return Qnil;
}
diff --git a/src/xdisp.c b/src/xdisp.c
index 34e4640..b81b274 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -4557,11 +4557,13 @@ face_before_or_after_it_pos (struct it *it, bool
before_p)
ptrdiff_t bufpos, charpos;
int base_face_id;
- /* No face change past the end of the string (for the case
- we are padding with spaces). No face change before the
- string start. */
+ /* No face change past the end of the string (for the case we
+ are padding with spaces). No face change before the string
+ start. Ignore face changes before the first visible
+ character on this display line. */
if (IT_STRING_CHARPOS (*it) >= SCHARS (it->string)
- || (IT_STRING_CHARPOS (*it) == 0 && before_p))
+ || (IT_STRING_CHARPOS (*it) == 0 && before_p)
+ || it->current_x <= it->first_visible_x)
return it->face_id;
if (!it->bidi_p)
@@ -4580,51 +4582,47 @@ face_before_or_after_it_pos (struct it *it, bool
before_p)
}
else
{
- if (before_p)
- {
- /* With bidi iteration, the character before the current
- in the visual order cannot be found by simple
- iteration, because "reverse" reordering is not
- supported. Instead, we need to start from the string
- beginning and go all the way to the current string
- position, remembering the previous position. */
- /* Ignore face changes before the first visible
- character on this display line. */
- if (it->current_x <= it->first_visible_x)
- return it->face_id;
- SAVE_IT (it_copy, *it, it_copy_data);
- IT_STRING_CHARPOS (it_copy) = 0;
- bidi_init_it (0, 0, FRAME_WINDOW_P (it_copy.f), &it_copy.bidi_it);
-
- do
- {
- charpos = IT_STRING_CHARPOS (it_copy);
- if (charpos >= SCHARS (it->string))
- break;
- bidi_move_to_visually_next (&it_copy.bidi_it);
- }
- while (IT_STRING_CHARPOS (it_copy) != IT_STRING_CHARPOS (*it));
+ /* With bidi iteration, the character before the current in
+ the visual order cannot be found by simple iteration,
+ because "reverse" reordering is not supported. Instead,
+ we need to start from the string beginning and go all the
+ way to the current string position, remembering the
+ visually-previous position. We need to start from the
+ string beginning for the character after the current as
+ well, since the iterator state in IT may have been
+ pushed, and the bidi cache is no longer coherent with the
+ string's text. */
+ SAVE_IT (it_copy, *it, it_copy_data);
+ IT_STRING_CHARPOS (it_copy) = 0;
+ bidi_init_it (0, 0, FRAME_WINDOW_P (it_copy.f), &it_copy.bidi_it);
- RESTORE_IT (it, it, it_copy_data);
+ do
+ {
+ charpos = it_copy.bidi_it.charpos;
+ if (charpos >= SCHARS (it->string))
+ break;
+ bidi_move_to_visually_next (&it_copy.bidi_it);
}
- else
+ while (it_copy.bidi_it.charpos != IT_STRING_CHARPOS (*it));
+
+ if (!before_p)
{
/* Set charpos to the string position of the character
that comes after IT's current position in the visual
order. */
int n = (it->what == IT_COMPOSITION ? it->cmp_it.nchars : 1);
-
- it_copy = *it;
- /* If this is the first display element,
+ /* If this is the first string character,
bidi_move_to_visually_next will deliver character at
current position without moving, so we need to enlarge N. */
- if (it->bidi_it.first_elt)
+ if (it_copy.bidi_it.first_elt)
n++;
while (n--)
bidi_move_to_visually_next (&it_copy.bidi_it);
charpos = it_copy.bidi_it.charpos;
}
+
+ RESTORE_IT (it, it, it_copy_data);
}
eassert (0 <= charpos && charpos <= SCHARS (it->string));
@@ -22765,6 +22763,22 @@ get_it_property (struct it *it, Lisp_Object prop)
return Fget_char_property (position, prop, object);
}
+/* Return the line-prefix/wrap-prefix property, checking both the
+ current IT->OBJECT and the underlying buffer text. */
+
+static Lisp_Object
+get_line_prefix_it_property (struct it *it, Lisp_Object prop)
+{
+ Lisp_Object prefix = get_it_property (it, prop);
+
+ /* If we are looking at a display or overlay string, check also the
+ underlying buffer text. */
+ if (NILP (prefix) && it->sp > 0 && STRINGP (it->object))
+ return Fget_char_property (make_fixnum (IT_CHARPOS (*it)), prop,
+ it->w->contents);
+ return prefix;
+}
+
/* See if there's a line- or wrap-prefix, and if so, push it on IT. */
static void
@@ -22774,13 +22788,13 @@ handle_line_prefix (struct it *it)
if (it->continuation_lines_width > 0)
{
- prefix = get_it_property (it, Qwrap_prefix);
+ prefix = get_line_prefix_it_property (it, Qwrap_prefix);
if (NILP (prefix))
prefix = Vwrap_prefix;
}
else
{
- prefix = get_it_property (it, Qline_prefix);
+ prefix = get_line_prefix_it_property (it, Qline_prefix);
if (NILP (prefix))
prefix = Vline_prefix;
}
diff --git a/src/xfaces.c b/src/xfaces.c
index 2bd2f4b..37ad11b 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -95,9 +95,10 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
with the symbol `face' in slot 0, and a slot for each of the face
attributes mentioned above.
- There is also a global face alist `Vface_new_frame_defaults'. Face
- definitions from this list are used to initialize faces of newly
- created frames.
+ There is also a global face map `Vface_new_frame_defaults',
+ containing conses of (FACE_ID . FACE_DEFINITION). Face definitions
+ from this table are used to initialize faces of newly created
+ frames.
A face doesn't have to specify all attributes. Those not specified
have a value of `unspecified'. Faces specifying all attributes but
@@ -1989,13 +1990,11 @@ lface_from_face_name_no_resolve (struct frame *f,
Lisp_Object face_name,
Lisp_Object lface;
if (f)
- lface = assq_no_quit (face_name, f->face_alist);
+ lface = Fgethash (face_name, f->face_hash_table, Qnil);
else
- lface = assq_no_quit (face_name, Vface_new_frame_defaults);
+ lface = CDR (Fgethash (face_name, Vface_new_frame_defaults, Qnil));
- if (CONSP (lface))
- lface = XCDR (lface);
- else if (signal_p)
+ if (signal_p && NILP (lface))
signal_error ("Invalid face", face_name);
check_lface (lface);
@@ -2894,11 +2893,6 @@ Value is a vector of face attributes. */)
/* Add a global definition if there is none. */
if (NILP (global_lface))
{
- global_lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified);
- ASET (global_lface, 0, Qface);
- Vface_new_frame_defaults = Fcons (Fcons (face, global_lface),
- Vface_new_frame_defaults);
-
/* Assign the new Lisp face a unique ID. The mapping from Lisp
face id to Lisp face is given by the vector lface_id_to_name.
The mapping from Lisp face to Lisp face id is given by the
@@ -2908,9 +2902,14 @@ Value is a vector of face attributes. */)
xpalloc (lface_id_to_name, &lface_id_to_name_size, 1, MAX_FACE_ID,
sizeof *lface_id_to_name);
+ Lisp_Object face_id = make_fixnum (next_lface_id);
lface_id_to_name[next_lface_id] = face;
- Fput (face, Qface, make_fixnum (next_lface_id));
+ Fput (face, Qface, face_id);
++next_lface_id;
+
+ global_lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified);
+ ASET (global_lface, 0, Qface);
+ Fputhash (face, Fcons (face_id, global_lface), Vface_new_frame_defaults);
}
else if (f == NULL)
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
@@ -2923,7 +2922,7 @@ Value is a vector of face attributes. */)
{
lface = make_vector (LFACE_VECTOR_SIZE, Qunspecified);
ASET (lface, 0, Qface);
- fset_face_alist (f, Fcons (Fcons (face, lface), f->face_alist));
+ Fputhash (face, lface, f->face_hash_table);
}
else
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
@@ -3084,7 +3083,7 @@ FRAME 0 means change the face on all frames, and change
the default
f = NULL;
lface = lface_from_face_name (NULL, face, true);
- /* When updating face-new-frame-defaults, we put :ignore-defface
+ /* When updating face--new-frame-defaults, we put :ignore-defface
where the caller wants `unspecified'. This forces the frame
defaults to ignore the defface value. Otherwise, the defface
will take effect, which is generally not what is intended.
@@ -3669,7 +3668,7 @@ update_face_from_frame_parameter (struct frame *f,
Lisp_Object param,
/* If there are no faces yet, give up. This is the case when called
from Fx_create_frame, and we do the necessary things later in
face-set-after-frame-defaults. */
- if (NILP (f->face_alist))
+ if (XFIXNAT (Fhash_table_count (f->face_hash_table)) == 0)
return;
if (EQ (param, Qforeground_color))
@@ -4335,14 +4334,13 @@ If FRAME is omitted or nil, use the selected frame. */)
return i == LFACE_VECTOR_SIZE ? Qt : Qnil;
}
-
-DEFUN ("frame-face-alist", Fframe_face_alist, Sframe_face_alist,
+DEFUN ("frame--face-hash-table", Fframe_face_hash_table,
Sframe_face_hash_table,
0, 1, 0,
- doc: /* Return an alist of frame-local faces defined on FRAME.
+ doc: /* Return a hash table of frame-local faces defined on FRAME.
For internal use only. */)
(Lisp_Object frame)
{
- return decode_live_frame (frame)->face_alist;
+ return decode_live_frame (frame)->face_hash_table;
}
@@ -6859,30 +6857,32 @@ DEFUN ("show-face-resources", Fshow_face_resources,
Sshow_face_resources,
#ifdef HAVE_PDUMPER
/* All the faces defined during loadup are recorded in
- face-new-frame-defaults, with the last face first in the list. We
- need to set next_lface_id to the next face ID number, so that any
- new faces defined in this session will have face IDs different from
- those defined during loadup. We also need to set up the
- lface_id_to_name[] array for the faces that were defined during
- loadup. */
+ face-new-frame-defaults. We need to set next_lface_id to the next
+ face ID number, so that any new faces defined in this session will
+ have face IDs different from those defined during loadup. We also
+ need to set up the lface_id_to_name[] array for the faces that were
+ defined during loadup. */
void
init_xfaces (void)
{
- if (CONSP (Vface_new_frame_defaults))
+ int nfaces = XFIXNAT (Fhash_table_count (Vface_new_frame_defaults));
+ if (nfaces > 0)
{
/* Allocate the lface_id_to_name[] array. */
- lface_id_to_name_size = next_lface_id =
- XFIXNAT (Flength (Vface_new_frame_defaults));
+ lface_id_to_name_size = next_lface_id = nfaces;
lface_id_to_name = xnmalloc (next_lface_id, sizeof *lface_id_to_name);
/* Store the faces. */
- Lisp_Object tail;
- int i = next_lface_id - 1;
- for (tail = Vface_new_frame_defaults; CONSP (tail); tail = XCDR (tail))
+ struct Lisp_Hash_Table* table = XHASH_TABLE (Vface_new_frame_defaults);
+ for (ptrdiff_t idx = 0; idx < nfaces; ++idx)
{
- Lisp_Object lface = XCAR (tail);
- eassert (i >= 0);
- lface_id_to_name[i--] = XCAR (lface);
+ Lisp_Object lface = HASH_KEY (table, idx);
+ Lisp_Object face_id = CAR (HASH_VALUE (table, idx));
+ if (FIXNATP (face_id)) {
+ int id = XFIXNAT (face_id);
+ eassert (id >= 0);
+ lface_id_to_name[id] = lface;
+ }
}
}
face_attr_sym[0] = Qface;
@@ -7038,7 +7038,7 @@ syms_of_xfaces (void)
defsubr (&Sinternal_copy_lisp_face);
defsubr (&Sinternal_merge_in_global_face);
defsubr (&Sface_font);
- defsubr (&Sframe_face_alist);
+ defsubr (&Sframe_face_hash_table);
defsubr (&Sdisplay_supports_face_attributes_p);
defsubr (&Scolor_distance);
defsubr (&Sinternal_set_font_selection_order);
@@ -7062,9 +7062,12 @@ This variable is intended for use only by code that
evaluates
the "specifity" of a face specification and should be let-bound
only for this purpose. */);
- DEFVAR_LISP ("face-new-frame-defaults", Vface_new_frame_defaults,
- doc: /* List of global face definitions (for internal use only.) */);
- Vface_new_frame_defaults = Qnil;
+ DEFVAR_LISP ("face--new-frame-defaults", Vface_new_frame_defaults,
+ doc: /* Hash table of global face definitions (for internal use only.)
*/);
+ Vface_new_frame_defaults =
+ /* 33 entries is enough to fit all basic faces */
+ make_hash_table (hashtest_eq, 33, DEFAULT_REHASH_SIZE,
+ DEFAULT_REHASH_THRESHOLD, Qnil, false);
DEFVAR_LISP ("face-default-stipple", Vface_default_stipple,
doc: /* Default stipple pattern used on monochrome displays.
diff --git a/src/xftfont.c b/src/xftfont.c
index f734931..d8ad403 100644
--- a/src/xftfont.c
+++ b/src/xftfont.c
@@ -33,6 +33,12 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "ftfont.h"
#include "pdumper.h"
+#ifndef FC_LCD_FILTER
+/* Older fontconfig versions don't have FC_LCD_FILTER. */
+# define FC_LCD_FILTER "lcdfilter"
+#endif
+
+
/* Xft font driver. */
/* Structure pointed by (struct face *)->extra */
diff --git a/test/lisp/calendar/cal-french-tests.el
b/test/lisp/calendar/cal-french-tests.el
new file mode 100644
index 0000000..ab62c1e
--- /dev/null
+++ b/test/lisp/calendar/cal-french-tests.el
@@ -0,0 +1,113 @@
+;;; cal-french-tests.el --- tests for cal-french.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 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/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'cal-french)
+
+(defconst cal-french-test-cases
+ '(
+ (1792 9 22 "Primidi 1 Vendémiaire an 1 de la Révolution, jour du Raisin")
+ (1793 10 23 "Duodi 2 Brumaire an 2 de la Révolution, jour du Céleri")
+ (1794 7 27 "Nonidi 9 Thermidor an 2 de la Révolution, jour de la Mûre")
+ (1794 11 23 "Tridi 3 Frimaire an 3 de la Révolution, jour de la Chicorée")
+ (1795 10 5 "Tridi 13 Vendémiaire an 4 de la Révolution, jour du Potiron")
+ (1795 12 25 "Quartidi 4 Nivôse an 4 de la Révolution, jour du Soufre")
+ (1797 1 24 "Quintidi 5 Pluviôse an 5 de la Révolution, jour du Taureau")
+ (1798 2 24 "Sextidi 6 Ventôse an 6 de la Révolution, jour de l'Asaret")
+ (1799 11 9 "Octidi 18 Brumaire an 8 de la Révolution, jour de la Dentelaire")
+ (1801 3 29 "Octidi 8 Germinal an 9 de la Révolution, jour de la Jonquille")
+ (1804 4 30 "Décadi 10 Floréal an 12 de la Révolution, jour du Rateau")
+ (1807 6 1 "Duodi 12 Prairial an 15 de la Révolution, jour de la Bétoine")
+ (1810 7 3 "Quartidi 14 Messidor an 18 de la Révolution, jour de la Lavande")
+ (1813 8 4 "Sextidi 16 Thermidor an 21 de la Révolution, jour de la
Guimauve")
+ (1816 9 4 "Octidi 18 Fructidor an 24 de la Révolution, jour du Nerprun")
+ (2000 1 1 "Duodi 12 Nivôse an 208 de la Révolution, jour de l'Argile")
+ (2021 7 11 "Tridi 23 Messidor an 229 de la Révolution, jour du Haricot")
+ (2001 5 11 "Duodi 22 Floréal an 209 de la Révolution, jour de la
Fritillaire")
+ (1792 9 22 "Primidi 1 Vendémiaire an 1 de la Révolution, jour du Raisin")
+ (1793 9 21 "Quintidi 5 jour complémentaire an 1 de la Révolution, jour des
Récompenses")
+ (1793 9 22 "Primidi 1 Vendémiaire an 2 de la Révolution, jour du Raisin")
+ (1794 9 21 "Quintidi 5 jour complémentaire an 2 de la Révolution, jour des
Récompenses")
+ (1794 9 22 "Primidi 1 Vendémiaire an 3 de la Révolution, jour du Raisin")
+ (1795 9 22 "Sextidi 6 jour complémentaire an 3 de la Révolution, jour de la
Révolution")
+ (1795 9 23 "Primidi 1 Vendémiaire an 4 de la Révolution, jour du Raisin")
+ (1796 9 21 "Quintidi 5 jour complémentaire an 4 de la Révolution, jour des
Récompenses")
+ (1796 9 22 "Primidi 1 Vendémiaire an 5 de la Révolution, jour du Raisin")
+ (1797 9 21 "Quintidi 5 jour complémentaire an 5 de la Révolution, jour des
Récompenses")
+ (1797 9 22 "Primidi 1 Vendémiaire an 6 de la Révolution, jour du Raisin")
+ (1799 9 22 "Sextidi 6 jour complémentaire an 7 de la Révolution, jour de la
Révolution")
+ (1799 9 23 "Primidi 1 Vendémiaire an 8 de la Révolution, jour du Raisin")
+ (1800 9 22 "Quintidi 5 jour complémentaire an 8 de la Révolution, jour des
Récompenses")
+ (1800 9 23 "Primidi 1 Vendémiaire an 9 de la Révolution, jour du Raisin")
+ (1801 9 22 "Quintidi 5 jour complémentaire an 9 de la Révolution, jour des
Récompenses")
+ (1801 9 23 "Primidi 1 Vendémiaire an 10 de la Révolution, jour du Raisin")
+ (1823 9 22 "Quintidi 5 jour complémentaire an 31 de la Révolution, jour des
Récompenses")
+ (1823 9 23 "Primidi 1 Vendémiaire an 32 de la Révolution, jour du Raisin")
+ (1824 9 22 "Sextidi 6 jour complémentaire an 32 de la Révolution, jour de la
Révolution")
+ (1824 9 23 "Primidi 1 Vendémiaire an 33 de la Révolution, jour du Raisin")
+ (1825 9 22 "Quintidi 5 jour complémentaire an 33 de la Révolution, jour des
Récompenses")
+ (1825 9 23 "Primidi 1 Vendémiaire an 34 de la Révolution, jour du Raisin")
+ (1892 9 21 "Quintidi 5 jour complémentaire an 100 de la Révolution, jour des
Récompenses")
+ (1892 9 22 "Primidi 1 Vendémiaire an 101 de la Révolution, jour du Raisin")
+ (1900 9 22 "Sextidi 6 jour complémentaire an 108 de la Révolution, jour de
la Révolution")
+ (1900 9 23 "Primidi 1 Vendémiaire an 109 de la Révolution, jour du Raisin")
+ (1992 9 21 "Quintidi 5 jour complémentaire an 200 de la Révolution, jour des
Récompenses")
+ (1992 9 22 "Primidi 1 Vendémiaire an 201 de la Révolution, jour du Raisin")
+ (2000 9 21 "Sextidi 6 jour complémentaire an 208 de la Révolution, jour de
la Révolution")
+ (2000 9 22 "Primidi 1 Vendémiaire an 209 de la Révolution, jour du Raisin")
+ (2092 9 20 "Quintidi 5 jour complémentaire an 300 de la Révolution, jour des
Récompenses")
+ (2092 9 21 "Primidi 1 Vendémiaire an 301 de la Révolution, jour du Raisin")
+ (2100 9 21 "Sextidi 6 jour complémentaire an 308 de la Révolution, jour de
la Révolution")
+ (2100 9 22 "Primidi 1 Vendémiaire an 309 de la Révolution, jour du Raisin")
+ (2192 9 21 "Sextidi 6 jour complémentaire an 400 de la Révolution, jour de
la Révolution")
+ (2192 9 22 "Primidi 1 Vendémiaire an 401 de la Révolution, jour du Raisin")
+ (2193 9 21 "Quintidi 5 jour complémentaire an 401 de la Révolution, jour des
Récompenses")
+ (2199 9 22 "Primidi 1 Vendémiaire an 408 de la Révolution, jour du Raisin")
+ (2200 9 22 "Sextidi 6 jour complémentaire an 408 de la Révolution, jour de
la Révolution")
+ (2791 9 23 "Primidi 1 Vendémiaire an 1000 de la Révolution, jour du Raisin")
+ (2792 9 22 "Primidi 1 Vendémiaire an 1001 de la Révolution, jour du Raisin")
+ (3000 1 1 "Duodi 12 Nivôse an 1208 de la Révolution, jour de l'Argile")
+ (3001 1 1 "Primidi 11 Nivôse an 1209 de la Révolution, jour du Granit")
+ (3791 9 22 "Primidi 1 Vendémiaire an 2000 de la Révolution, jour du Raisin")
+ (3792 9 22 "Primidi 1 Vendémiaire an 2001 de la Révolution, jour du Raisin")
+ (4000 1 1 "Duodi 12 Nivôse an 2208 de la Révolution, jour de l'Argile")
+ (4001 1 1 "Duodi 12 Nivôse an 2209 de la Révolution, jour de l'Argile")
+ (4320 9 10 "Quartidi 24 Fructidor an 2528 de la Révolution, jour du Sorgho")
+ (4320 9 11 "Quintidi 25 Fructidor an 2528 de la Révolution, jour de
l'Écrevisse")
+ (4791 9 23 "Primidi 1 Vendémiaire an 3000 de la Révolution, jour du Raisin")
+ (4792 9 22 "Primidi 1 Vendémiaire an 3001 de la Révolution, jour du Raisin")
+ (5000 1 1 "Duodi 12 Nivôse an 3208 de la Révolution, jour de l'Argile")
+ (5001 1 1 "Primidi 11 Nivôse an 3209 de la Révolution, jour du Granit")
+ (5791 9 22 "Primidi 1 Vendémiaire an 4000 de la Révolution, jour du Raisin")
+ (5792 9 21 "Primidi 1 Vendémiaire an 4001 de la Révolution, jour du Raisin")
+ (6000 1 1 "Tridi 13 Nivôse an 4208 de la Révolution, jour de l'Ardoise")
+ (6001 1 1 "Tridi 13 Nivôse an 4209 de la Révolution, jour de l'Ardoise")
+ (6791 9 22 "Primidi 1 Vendémiaire an 5000 de la Révolution, jour du Raisin")
+ (6792 9 21 "Primidi 1 Vendémiaire an 5001 de la Révolution, jour du Raisin")
+ (7791 9 21 "Primidi 1 Vendémiaire an 6000 de la Révolution, jour du Raisin")
+ (7792 9 21 "Primidi 1 Vendémiaire an 6001 de la Révolution, jour du Raisin")
+ ))
+
+(ert-deftest cal-french-tests ()
+ (pcase-dolist (`(,y ,m ,d ,str) cal-french-test-cases)
+ (should (equal (calendar-french-date-string (list m d y)) str))))
+
+(provide 'cal-french-tests)
diff --git a/test/lisp/dired-x-tests.el b/test/lisp/dired-x-tests.el
index 5b51c99..003923d 100644
--- a/test/lisp/dired-x-tests.el
+++ b/test/lisp/dired-x-tests.el
@@ -49,5 +49,18 @@
(sort (dired-get-marked-files 'local) #'string<))))
(delete-directory dir 'recursive))))
+(ert-deftest dired-guess-default ()
+ (let ((dired-guess-shell-alist-user nil)
+ (dired-guess-shell-alist-default
+ '(("\\.png\\'" "display")
+ ("\\.gif\\'" "display" "xloadimage")
+ ("\\.gif\\'" "feh")
+ ("\\.jpe?g\\'" "xloadimage"))))
+ (should (equal (dired-guess-default '("/tmp/foo.png")) "display"))
+ (should (equal (dired-guess-default '("/tmp/foo.gif"))
+ '("display" "xloadimage" "feh")))
+ (should (equal (dired-guess-default '("/tmp/foo.png" "/tmp/foo.txt"))
+ nil))))
+
(provide 'dired-x-tests)
;; dired-x-tests.el ends here
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el
b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el
new file mode 100644
index 0000000..3a29128
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el
@@ -0,0 +1,5 @@
+;;; -*- lexical-binding: t -*-
+(defsubst warn-callargs-defsubst-f1 (_x)
+ nil)
+(defun warn-callargs-defsubst-f2 ()
+ (warn-callargs-defsubst-f1 1 2))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 33413f5..7c40f7e 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -700,6 +700,9 @@ byte-compiled. Run with dynamic binding."
(bytecomp--define-warning-file-test "warn-callargs.el"
"with 2 arguments, but accepts only 1")
+(bytecomp--define-warning-file-test "warn-callargs-defsubst.el"
+ "with 2 arguments, but accepts only 1")
+
(bytecomp--define-warning-file-test "warn-defcustom-nogroup.el"
"fails to specify containing group")
diff --git a/test/lisp/emacs-lisp/package-tests.el
b/test/lisp/emacs-lisp/package-tests.el
index 67d647d..2943579 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -263,6 +263,74 @@ Must called from within a `tar-mode' buffer."
(should (file-exists-p autoloads-file))
(should-not (get-file-buffer autoloads-file)))))
+(ert-deftest package-test-install-file ()
+ "Install files with `package-install-file'."
+ (with-package-test (:basedir (ert-resource-directory))
+ (package-initialize)
+ (let* ((pkg-el "simple-single-1.3.el")
+ (source-file (expand-file-name pkg-el (ert-resource-directory))))
+ (should-not (package-installed-p 'simple-single))
+ (package-install-file source-file)
+ (should (package-installed-p 'simple-single))
+ (package-delete (cadr (assq 'simple-single package-alist)))
+ (should-not (package-installed-p 'simple-single)))
+
+ (let* ((pkg-el "multi-file-0.2.3.tar")
+ (source-file (expand-file-name pkg-el (ert-resource-directory))))
+ (package-initialize)
+ (should-not (package-installed-p 'multie-file))
+ (package-install-file source-file)
+ (should (package-installed-p 'multi-file))
+ (package-delete (cadr (assq 'multi-file package-alist))))
+ ))
+
+(ert-deftest package-test-install-file-EOLs ()
+ "Install same file multiple time with `package-install-file'
+but with a different end of line convention (bug#48137)."
+ (with-package-test (:basedir (ert-resource-directory))
+ (package-initialize)
+ (let* ((pkg-el "simple-single-1.3.el")
+ (source-file (expand-file-name pkg-el (ert-resource-directory))))
+
+ (with-temp-buffer
+ (insert-file-contents source-file)
+
+ (let (hashes)
+ (dolist (coding '(unix dos mac) hashes)
+ (let* ((eol-file (expand-file-name pkg-el package-test-user-dir)))
+ ;; save package with this EOL convention.
+ (set-buffer-file-coding-system coding)
+ (write-region (point-min) (point-max) eol-file)
+
+ (should-not (package-installed-p 'simple-single))
+ (package-install-file eol-file)
+ (should (package-installed-p 'simple-single))
+
+ ;; check the package file has been installed unmodified.
+ (let ((eol-hash (with-temp-buffer
+ (insert-file-contents-literally eol-file)
+ (buffer-hash))))
+ ;; also perform an additional check that the package
+ ;; file created with this EOL convention is different
+ ;; than all the others created so far.
+ (should-not (member eol-hash hashes))
+ (setq hashes (cons eol-hash hashes))
+
+ (let* ((descr (cadr (assq 'simple-single package-alist)))
+ (pkg-dir (package-desc-dir descr))
+ (dest-file (expand-file-name "simple-single.el" pkg-dir
))
+ (dest-hash (with-temp-buffer
+ (insert-file-contents-literally dest-file)
+ (buffer-hash))))
+
+ (should (string= dest-hash eol-hash))))
+
+ (package-delete (cadr (assq 'simple-single package-alist)))
+ (should-not (package-installed-p 'simple-single))
+ (delete-file eol-file)
+ (should-not (file-exists-p eol-file))
+ )))))))
+
(ert-deftest package-test-install-dependency ()
"Install a package which includes a dependency."
(with-package-test ()
diff --git a/test/lisp/files-resources/.dir-locals.el
b/test/lisp/files-resources/.dir-locals.el
new file mode 100644
index 0000000..84393aa
--- /dev/null
+++ b/test/lisp/files-resources/.dir-locals.el
@@ -0,0 +1,5 @@
+;; This is used by files-tests.el.
+((auto-mode-alist . (("\\.quux\\'" . tcl-mode)
+ ("\\.zot1\\'" . foobar)
+ ("\\.zot2\\'" . (lambda ()))
+ ("\\.zot3\\'" . dired-mode))))
diff --git a/test/lisp/files-resources/auto-test.zot1
b/test/lisp/files-resources/auto-test.zot1
new file mode 100644
index 0000000..80acfcc
--- /dev/null
+++ b/test/lisp/files-resources/auto-test.zot1
@@ -0,0 +1 @@
+zot1
diff --git a/test/lisp/files-resources/auto-test.zot2
b/test/lisp/files-resources/auto-test.zot2
new file mode 100644
index 0000000..975fc76
--- /dev/null
+++ b/test/lisp/files-resources/auto-test.zot2
@@ -0,0 +1 @@
+zot2
diff --git a/test/lisp/files-resources/auto-test.zot3
b/test/lisp/files-resources/auto-test.zot3
new file mode 100644
index 0000000..faa0715
--- /dev/null
+++ b/test/lisp/files-resources/auto-test.zot3
@@ -0,0 +1 @@
+zot3
diff --git a/test/lisp/files-resources/whatever.quux
b/test/lisp/files-resources/whatever.quux
new file mode 100644
index 0000000..595583b
--- /dev/null
+++ b/test/lisp/files-resources/whatever.quux
@@ -0,0 +1,2 @@
+# Used by files-test.el.
+# Due to .dir-locals.el this should end up in Tcl mode.
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index a6b0c90..a5c8236 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -1534,5 +1534,16 @@ The door of all subtleties!
(should-error (file-name-with-extension "Jack" "."))
(should-error (file-name-with-extension "/is/a/directory/" "css")))
+(ert-deftest files-test-dir-locals-auto-mode-alist ()
+ "Test an `auto-mode-alist' entry in `.dir-locals.el'"
+ (find-file (ert-resource-file "whatever.quux"))
+ (should (eq major-mode 'tcl-mode))
+ (find-file (ert-resource-file "auto-test.zot1"))
+ (should (eq major-mode 'fundamental-mode))
+ (find-file (ert-resource-file "auto-test.zot2"))
+ (should (eq major-mode 'fundamental-mode))
+ (find-file (ert-resource-file "auto-test.zot3"))
+ (should (eq major-mode 'fundamental-mode)))
+
(provide 'files-tests)
;;; files-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 3dd22ac..052c030 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2466,7 +2466,8 @@ This checks also `file-name-as-directory',
`file-name-directory',
"^\\'")
tramp--test-messages))))))))
- ;; We do not test lockname here. See `tramp-test39-lock-file'.
+ ;; We do not test lockname here. See
+ ;; `tramp-test39-make-lock-file-name'.
;; Do not overwrite if excluded.
(cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always)
@@ -4095,7 +4096,7 @@ This tests also `make-symbolic-link', `file-truename' and
`add-name-to-file'."
(write-region "foo" nil tmp-name1)
(should (file-exists-p tmp-name1))
(should (file-selinux-context tmp-name1))
- (copy-file tmp-name1 tmp-name2)
+ (copy-file tmp-name1 tmp-name2 nil nil nil 'preserve-permissions)
(should (file-selinux-context tmp-name2))
(should
(equal
@@ -5746,8 +5747,8 @@ Use direct async.")
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)))))
;; The functions were introduced in Emacs 28.1.
-(ert-deftest tramp-test39-lock-file ()
- "Check `lock-file', `unlock-file' and `file-locked-p'."
+(ert-deftest tramp-test39-make-lock-file-name ()
+ "Check `make-lock-file-name', `lock-file', `unlock-file' and
`file-locked-p'."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-ange-ftp-p)))
;; Since Emacs 28.1.
@@ -5770,6 +5771,7 @@ Use direct async.")
(append
(and (tramp--test-fuse-p) '(tramp-fuse-unmount))
tramp-cleanup-connection-hook))
+ auto-save-default
noninteractive)
(unwind-protect
@@ -5783,6 +5785,15 @@ Use direct async.")
(with-no-warnings (lock-file tmp-name1))
(should (eq (with-no-warnings (file-locked-p tmp-name1)) t))
+ ;; `save-buffer' removes the lock.
+ (with-temp-buffer
+ (set-visited-file-name tmp-name1)
+ (insert "foo")
+ (save-buffer))
+ (should-not (with-no-warnings (file-locked-p tmp-name1)))
+ (with-no-warnings (lock-file tmp-name1))
+ (should (eq (with-no-warnings (file-locked-p tmp-name1)) t))
+
;; A new connection changes process id, and also the
;; lockname contents.
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
@@ -5838,8 +5849,7 @@ Use direct async.")
(should-error
(set-visited-file-name tmp-name1)
:type 'file-locked)))
- (should (stringp (with-no-warnings (file-locked-p tmp-name1))))
- (should-not (file-exists-p tmp-name1)))
+ (should (stringp (with-no-warnings (file-locked-p tmp-name1)))))
;; Cleanup.
(ignore-errors (delete-file tmp-name1))
diff --git a/test/lisp/progmodes/compile-tests.el
b/test/lisp/progmodes/compile-tests.el
index da6a1e6..2a3bb3d 100644
--- a/test/lisp/progmodes/compile-tests.el
+++ b/test/lisp/progmodes/compile-tests.el
@@ -31,9 +31,6 @@
(require 'compile)
(defconst compile-tests--test-regexps-data
- ;; The computed column numbers are zero-indexed, so subtract 1 from
- ;; what's reported in the string. The end column numbers are for
- ;; the character after, so it matches what's reported in the string.
'(;; absoft
(absoft
"Error on line 3 of t.f: Execution error unclassifiable statement"
@@ -61,7 +58,7 @@
(ant "[javac] /src/DataBaseTestCase.java:49: warning: finally clause
cannot complete normally"
13 nil 49 "/src/DataBaseTestCase.java" 1)
(ant "[jikes] foo.java:3:5:7:9: blah blah"
- 14 (5 . 10) (3 . 7) "foo.java" 2)
+ 14 (5 . 9) (3 . 7) "foo.java" 2)
(ant "[javac] c:/cygwin/Test.java:12: error: foo: bar"
9 nil 12 "c:/cygwin/Test.java" 2)
(ant "[javac] c:\\cygwin\\Test.java:87: error: foo: bar"
@@ -86,10 +83,10 @@
;; caml
(python-tracebacks-and-caml
"File \"foobar.ml\", lines 5-8, characters 20-155: blah blah"
- 1 (20 . 156) (5 . 8) "foobar.ml")
+ 1 (20 . 155) (5 . 8) "foobar.ml")
(python-tracebacks-and-caml
"File \"F:\\ocaml\\sorting.ml\", line 65, characters 2-145:\nWarning 26:
unused variable equ."
- 1 (2 . 146) 65 "F:\\ocaml\\sorting.ml")
+ 1 (2 . 145) 65 "F:\\ocaml\\sorting.ml")
(python-tracebacks-and-caml
"File \"/usr/share/gdesklets/display/TargetGauge.py\", line 41, in
add_children"
1 nil 41 "/usr/share/gdesklets/display/TargetGauge.py")
@@ -231,12 +228,12 @@
(gnu "foo.c:8.23: note: message" 1 23 8 "foo.c")
(gnu "foo.c:8.23: info: message" 1 23 8 "foo.c")
(gnu "foo.c:8:23:information: message" 1 23 8 "foo.c")
- (gnu "foo.c:8.23-45: Informational: message" 1 (23 . 46) (8 . nil) "foo.c")
+ (gnu "foo.c:8.23-45: Informational: message" 1 (23 . 45) (8 . nil) "foo.c")
(gnu "foo.c:8-23: message" 1 nil (8 . 23) "foo.c")
;; The next one is not in the GNU standards AFAICS.
;; Here we seem to interpret it as LINE1-LINE2.COL2.
- (gnu "foo.c:8-45.3: message" 1 (nil . 4) (8 . 45) "foo.c")
- (gnu "foo.c:8.23-9.1: message" 1 (23 . 2) (8 . 9) "foo.c")
+ (gnu "foo.c:8-45.3: message" 1 (nil . 3) (8 . 45) "foo.c")
+ (gnu "foo.c:8.23-9.1: message" 1 (23 . 1) (8 . 9) "foo.c")
(gnu "jade:dbcommon.dsl:133:17:E: missing argument for function call"
1 17 133 "dbcommon.dsl")
(gnu "G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be
found."
@@ -472,8 +469,11 @@ can only work with the NUL byte to disambiguate colons.")
(when file
(should (equal (caar (compilation--loc->file-struct loc)) file)))
(when end-col
+ ;; The computed END-COL is exclusive; subtract one to get the
+ ;; number in the error message.
(should (equal
- (car (cadr (nth 2 (compilation--loc->file-struct loc))))
+ (1- (car (cadr
+ (nth 2 (compilation--loc->file-struct loc)))))
end-col)))
(should (equal (car (nth 2 (compilation--loc->file-struct loc)))
(or end-line line)))
@@ -515,4 +515,31 @@ The test data is in
`compile-tests--grep-regexp-testcases'."
(compile--test-error-line testcase))
(should (eq compilation-num-errors-found 8))))
+(ert-deftest compile-test-functions ()
+ "Test rules using functions instead of regexp group numbers."
+ (let* ((file-fun (lambda () '("my-file")))
+ (line-start-fun (lambda () 123))
+ (line-end-fun (lambda () 134))
+ (col-start-fun (lambda () 39))
+ (col-end-fun (lambda () 24))
+ (compilation-error-regexp-alist-alist
+ `((my-rule
+ ,(rx bol "My error message")
+ ,file-fun
+ (,line-start-fun . ,line-end-fun)
+ (,col-start-fun . ,col-end-fun))))
+ (compilation-error-regexp-alist '(my-rule)))
+ (with-temp-buffer
+ (font-lock-mode -1)
+ (let ((compilation-num-errors-found 0)
+ (compilation-num-warnings-found 0)
+ (compilation-num-infos-found 0))
+ (compile--test-error-line
+ '(my-rule
+ "My error message"
+ 1 (39 . 24) (123 . 134) "my-file" 2))
+ (should (eq compilation-num-errors-found 1))
+ (should (eq compilation-num-warnings-found 0))
+ (should (eq compilation-num-infos-found 0))))))
+
;;; compile-tests.el ends here
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index 6d004e6..7f62a41 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -465,7 +465,12 @@ Return the last evalled form in BODY."
;; isearch-lazy-highlight-new-loop and sit-for (bug#36328)
((symbol-function 'replace-highlight)
(lambda (&rest _args)
- (string-match "[A-Z ]" "ForestGreen"))))
+ (string-match "[A-Z ]" "ForestGreen")))
+ ;; Override `sit-for' and `ding' so that we don't have
+ ;; to wait and listen to bells when running the test.
+ ((symbol-function 'sit-for)
+ (lambda (&rest _args) (redisplay)))
+ ((symbol-function 'ding) 'ignore))
(perform-replace ,from ,to t
replace-tests-perform-replace-regexp-flag nil))
,@body))))
@@ -584,7 +589,7 @@ bound to HIGHLIGHT-LOCUS."
(replace-tests-with-highlighted-occurrence highlight-locus
(occur-mode-display-occurrence)
(with-current-buffer (marker-buffer
- (get-text-property (point) 'occur-target))
+ (caar (get-text-property (point) 'occur-target)))
(should (funcall check-overlays has-overlay)))))))
(ert-deftest replace-regexp-bug45973 ()
diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el
index 268bb64..c571dc3 100644
--- a/test/lisp/shadowfile-tests.el
+++ b/test/lisp/shadowfile-tests.el
@@ -69,12 +69,15 @@
(format "/mock::%s" temporary-file-directory)))
"Temporary directory for Tramp tests.")
-(setq password-cache-expiry nil
+(setq auth-source-save-behavior nil
+ password-cache-expiry nil
shadow-debug (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
- tramp-verbose 0
;; When the remote user id is 0, Tramp refuses unsafe temporary files.
tramp-allow-unsafe-temporary-files
(or tramp-allow-unsafe-temporary-files noninteractive)
+ tramp-cache-read-persistent-data t ;; For auth-sources.
+ tramp-persistency-file-name nil
+ tramp-verbose 0
;; On macOS, `temporary-file-directory' is a symlinked directory.
temporary-file-directory (file-truename temporary-file-directory)
shadow-test-remote-temporary-file-directory
@@ -643,7 +646,9 @@ guaranteed by the originator of a cluster definition."
(expand-file-name
"shadowfile-tests"
shadow-test-remote-temporary-file-directory))
- mocked-input `(,cluster1 ,file1 ,cluster2 ,file2 ,(kbd "RET")))
+ mocked-input
+ `(,cluster1 ,file1 ,cluster2 ,file2
+ ,primary ,file1 ,(kbd "RET")))
(with-temp-buffer
(set-visited-file-name file1)
(call-interactively #'shadow-define-literal-group)
@@ -657,7 +662,9 @@ guaranteed by the originator of a cluster definition."
(should (member (format "/%s:%s" cluster1 (file-local-name file1))
(car shadow-literal-groups)))
(should (member (format "/%s:%s" cluster2 (file-local-name file2))
- (car shadow-literal-groups))))
+ (car shadow-literal-groups)))
+ ;; Bug#49596.
+ (should (member (concat primary file1) (car shadow-literal-groups))))
;; Cleanup.
(shadow--tests-cleanup))))
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index e42a58a..0d64320 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -904,17 +904,23 @@ the other expected results for hours greater than 99 with
non-zero seconds."
ert-test-list
(list
`(ert-deftest ,(intern (concat "formatz-" form-string "-hhmm")) ()
+ ,(concat "Tests time-stamp format " form-string
+ " with whole hours or minutes.")
(should (equal (formatz ,form-string (fz-make+zone 0))
,(car hour-mod)))
(formatz-hours-exact-helper ,form-string ',(cdr hour-mod))
(should (equal (formatz ,form-string (fz-make+zone 0 30))
,(car mins-mod)))
(formatz-nonzero-minutes-helper ,form-string ',(cdr mins-mod)))
- `(ert-deftest ,(intern (concat "formatz-" form-string "-secs")) ()
+ `(ert-deftest ,(intern (concat "formatz-" form-string "-seconds")) ()
+ ,(concat "Tests time-stamp format " form-string
+ " with offsets that have non-zero seconds.")
(should (equal (formatz ,form-string (fz-make+zone 0 0 30))
,(car secs-mod)))
(formatz-nonzero-seconds-helper ,form-string ',(cdr secs-mod)))
- `(ert-deftest ,(intern (concat "formatz-" form-string "-big")) ()
+ `(ert-deftest ,(intern (concat "formatz-" form-string "-threedigit"))
()
+ ,(concat "Tests time-stamp format " form-string
+ " with offsets that are 100 hours or greater.")
(should (equal (formatz ,form-string (fz-make+zone 100))
,(car big-mod)))
(formatz-hours-big-helper ,form-string ',(cdr big-mod))
@@ -954,6 +960,7 @@ the other expected results for hours greater than 99 with
non-zero seconds."
;; The legacy exception for %z in time-stamp will need to remain
;; through at least 2024 and Emacs 28.
(ert-deftest formatz-%z-spotcheck ()
+ "Spot-checks internal implementation of time-stamp format %z."
(should (equal (format-time-offset "%z" (fz-make+zone 0)) "+0000"))
(should (equal (format-time-offset "%z" (fz-make+zone 0 30)) "+0030"))
(should (equal (format-time-offset "%z" (fz-make+zone 0 0 30)) "+000030"))
diff --git a/test/lisp/time-tests.el b/test/lisp/time-tests.el
index 3cf8b54..88b7638 100644
--- a/test/lisp/time-tests.el
+++ b/test/lisp/time-tests.el
@@ -50,6 +50,7 @@
(? (| "AM" "PM"))
" " (+ (| digit "."))
(? " Mail")
+ " "
string-end)
display-time-string))))
diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el
index 123f2e8..11f842e 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -1345,8 +1345,8 @@ with parameters from the *Messages* buffer modification."
(add-hook 'kill-buffer-hook kbh nil t)
(add-hook 'kill-buffer-query-functions kbqf nil t)
(kill-buffer))
- (with-temp-buffer)
- (with-output-to-string)
+ (with-temp-buffer (ignore))
+ (with-output-to-string (ignore))
(should-not run-bluh)
(should-not run-kbh)
(should-not run-kbqf)
@@ -1361,4 +1361,42 @@ with parameters from the *Messages* buffer modification."
(should run-kbqf))
(remove-hook 'buffer-list-update-hook bluh))))
+(ert-deftest buffer-tests-inhibit-buffer-hooks-indirect ()
+ "Indirect buffers do not call `get-buffer-create'."
+ (dolist (inhibit '(nil t))
+ (let ((base (get-buffer-create "foo" inhibit)))
+ (unwind-protect
+ (dotimes (_i 11)
+ (let* (flag*
+ (flag (lambda () (prog1 t (setq flag* t))))
+ (indirect (make-indirect-buffer base "foo[indirect]" nil
+ inhibit)))
+ (unwind-protect
+ (progn
+ (with-current-buffer indirect
+ (add-hook 'kill-buffer-query-functions flag nil t))
+ (kill-buffer indirect)
+ (if inhibit
+ (should-not flag*)
+ (should flag*)))
+ (let (kill-buffer-query-functions)
+ (when (buffer-live-p indirect)
+ (kill-buffer indirect))))))
+ (let (kill-buffer-query-functions)
+ (when (buffer-live-p base)
+ (kill-buffer base)))))))
+
+(ert-deftest zero-length-overlays-and-not ()
+ (with-temp-buffer
+ (insert "hello")
+ (let ((long-overlay (make-overlay 2 4))
+ (zero-overlay (make-overlay 3 3)))
+ ;; Exclude.
+ (should (= (length (overlays-at 3)) 1))
+ (should (eq (car (overlays-at 3)) long-overlay))
+ ;; Include.
+ (should (= (length (overlays-in 3 3)) 2))
+ (should (memq long-overlay (overlays-in 3 3)))
+ (should (memq zero-overlay (overlays-in 3 3))))))
+
;;; buffer-tests.el ends here
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index b989c97..f4d123b 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -160,4 +160,26 @@ Also check that an encoding error can appear in a symlink."
(should-error (file-exists-p "/foo\0bar")
:type 'wrong-type-argument))
+(ert-deftest fileio-tests/file-name-concat ()
+ (should (equal (file-name-concat "foo" "bar") "foo/bar"))
+ (should (equal (file-name-concat "foo" "bar") "foo/bar"))
+ (should (equal (file-name-concat "foo" "bar" "zot") "foo/bar/zot"))
+ (should (equal (file-name-concat "foo/" "bar") "foo/bar"))
+ (should (equal (file-name-concat "foo//" "bar") "foo//bar"))
+ (should (equal (file-name-concat "foo/" "bar/" "zot") "foo/bar/zot"))
+ (should (equal (file-name-concat "fóo" "bar") "fóo/bar"))
+ (should (equal (file-name-concat "foo" "bár") "foo/bár"))
+ (should (equal (file-name-concat "fóo" "bár") "fóo/bár"))
+ (let ((string (make-string 5 ?a)))
+ (should (not (multibyte-string-p string)))
+ (aset string 2 255)
+ (should (not (multibyte-string-p string)))
+ (should (equal (file-name-concat "fóo" string) "fóo/aa\377aa")))
+ (should (equal (file-name-concat "foo") "foo"))
+ (should (equal (file-name-concat "foo/") "foo/"))
+ (should (equal (file-name-concat "foo" "") "foo"))
+ (should (equal (file-name-concat "foo" "" "" "" nil) "foo"))
+ (should (equal (file-name-concat "" "bar") "bar"))
+ (should (equal (file-name-concat "" "") "")))
+
;;; fileio-tests.el ends here