[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp c324e02 12/12: Merge remote-tracking branch 'savahnn
|
From: |
Andrea Corallo |
|
Subject: |
feature/native-comp c324e02 12/12: Merge remote-tracking branch 'savahnna/master' into dev |
|
Date: |
Sun, 21 Jun 2020 18:37:18 -0400 (EDT) |
branch: feature/native-comp
commit c324e02f758550d007ceb55c7168e8734a1d27fa
Merge: f0e9fdd 9fe2bdb
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Merge remote-tracking branch 'savahnna/master' into dev
---
doc/emacs/cmdargs.texi | 9 +-
doc/emacs/files.texi | 6 +-
doc/emacs/frames.texi | 21 +-
doc/emacs/misc.texi | 6 +-
doc/lispref/control.texi | 2 +-
doc/lispref/debugging.texi | 2 +-
doc/lispref/errors.texi | 5 +-
doc/lispref/files.texi | 2 +-
doc/lispref/frames.texi | 2 +-
doc/lispref/nonascii.texi | 6 +-
doc/lispref/os.texi | 2 +-
doc/lispref/strings.texi | 35 +-
doc/lispref/text.texi | 2 +-
doc/misc/dbus.texi | 826 ++++++++++++++++----------------
doc/misc/efaq-w32.texi | 14 +-
doc/misc/efaq.texi | 35 +-
doc/misc/emacs-gnutls.texi | 2 +-
doc/misc/gnus-faq.texi | 5 +-
doc/misc/message.texi | 4 +-
doc/misc/tramp.texi | 13 +-
etc/NEWS | 56 ++-
etc/NEWS.27 | 4 +-
lisp/battery.el | 675 +++++++++++++++-----------
lisp/cedet/semantic/complete.el | 8 +-
lisp/dired-aux.el | 16 +-
lisp/emacs-lisp/benchmark.el | 2 +-
lisp/emacs-lisp/generator.el | 8 +-
lisp/emacs-lisp/gv.el | 2 +-
lisp/emacs-lisp/package.el | 12 +-
lisp/emacs-lisp/rx.el | 2 +-
lisp/emulation/cua-base.el | 2 +-
lisp/emulation/cua-rect.el | 6 +-
lisp/erc/erc-match.el | 19 +-
lisp/erc/erc.el | 21 +-
lisp/eshell/em-pred.el | 8 +-
lisp/faces.el | 35 +-
lisp/format-spec.el | 183 +++----
lisp/gnus/gnus-cloud.el | 54 +--
lisp/gnus/gnus-eform.el | 18 +-
lisp/gnus/gnus-sieve.el | 10 +-
lisp/gnus/gssapi.el | 11 +-
lisp/gnus/mail-source.el | 30 +-
lisp/gnus/message.el | 137 +++---
lisp/icomplete.el | 5 +-
lisp/image-dired.el | 1 -
lisp/image-mode.el | 32 +-
lisp/net/dbus.el | 499 +++++++++----------
lisp/net/eww.el | 18 +-
lisp/net/imap.el | 30 +-
lisp/net/network-stream.el | 13 +-
lisp/net/shr.el | 25 +-
lisp/net/tramp-adb.el | 102 +---
lisp/net/tramp-archive.el | 4 +-
lisp/net/tramp-compat.el | 17 +-
lisp/net/tramp-crypt.el | 206 +++++---
lisp/net/tramp-gvfs.el | 74 ++-
lisp/net/tramp-rclone.el | 7 +-
lisp/net/tramp-sh.el | 180 ++-----
lisp/net/tramp-smb.el | 13 +-
lisp/net/tramp-sudoedit.el | 37 +-
lisp/net/tramp.el | 105 ++--
lisp/obsolete/tls.el | 16 +-
lisp/progmodes/bug-reference.el | 221 +++++++++
lisp/progmodes/project.el | 204 ++++++--
lisp/progmodes/python.el | 4 +-
lisp/progmodes/sql.el | 2 +-
lisp/progmodes/verilog-mode.el | 10 +-
lisp/progmodes/xref.el | 6 +-
lisp/simple.el | 16 +-
lisp/tab-bar.el | 15 +-
lisp/tab-line.el | 16 +-
lisp/term/tty-colors.el | 58 +--
lisp/textmodes/bibtex.el | 10 +-
lisp/textmodes/tex-mode.el | 3 -
lisp/vc/vc-bzr.el | 9 +
lisp/vc/vc-git.el | 29 +-
lisp/vc/vc-hg.el | 8 +
lisp/vc/vc-svn.el | 9 +-
lisp/vc/vc.el | 17 +-
src/dispextern.h | 2 +
src/lisp.h | 16 +-
src/nsterm.m | 59 +--
src/term.c | 9 +
src/w32fns.c | 157 +-----
src/xfaces.c | 116 +++++
src/xterm.c | 51 +-
test/lisp/autoinsert-tests.el | 8 +-
test/lisp/battery-tests.el | 106 +++-
test/lisp/calendar/lunar-tests.el | 5 +
test/lisp/emacs-lisp/generator-tests.el | 9 +
test/lisp/emacs-lisp/gv-tests.el | 19 +
test/lisp/emacs-lisp/package-tests.el | 27 +-
test/lisp/format-spec-tests.el | 135 +++++-
test/lisp/imenu-tests.el | 15 +-
test/lisp/net/dbus-tests.el | 4 +-
test/lisp/net/tramp-tests.el | 9 +
test/lisp/progmodes/sql-tests.el | 8 +-
test/lisp/vc/vc-tests.el | 9 +-
test/manual/etags/tex-src/gzip.texi | 2 +-
test/src/undo-tests.el | 2 +-
test/src/xfaces-tests.el | 23 +
101 files changed, 2858 insertions(+), 2272 deletions(-)
diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi
index 2c13116..3dd1fe9 100644
--- a/doc/emacs/cmdargs.texi
+++ b/doc/emacs/cmdargs.texi
@@ -495,7 +495,14 @@ variables to be set, but it uses their values if they are
set.
@item CDPATH
@vindex CDPATH@r{, environment variable}
Used by the @code{cd} command to search for the directory you specify,
-when you specify a relative directory,
+when you specify a relative directory.
+@item COLORTERM
+@vindex COLORTERM@r{, environment variable}
+If this variable is set to the value @samp{truecolor}, it tells Emacs
+to use 24-bit true color on text-mode displays even if the terminfo
+database is not installed. Emacs will use built-in commands to
+request true color by RGB values instead of the missing terminfo
+information.
@item DBUS_SESSION_BUS_ADDRESS
@vindex DBUS_SESSION_BUS_ADDRESS@r{, environment variable}
Used by D-Bus when Emacs is compiled with it. Usually, there is no
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index 56ce7fd..5998326 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -1003,7 +1003,7 @@ variable @code{auto-revert-remote-files} to
non-@code{nil}.
@vindex auto-revert-use-notify
@vindex auto-revert-interval
By default, Auto Revert mode works using @dfn{file notifications},
-whereby changes in the filesystem are reported to Emacs by the OS.
+whereby changes in the filesystem are reported to Emacs by the OS@.
You can disable use of file notifications by customizing the variable
@code{auto-revert-use-notify} to a @code{nil} value, then Emacs will
check for file changes by polling every five seconds. You can change
@@ -2098,8 +2098,8 @@ recently-opened files, reading file names from a buffer.
If you enable Recentf mode, with @kbd{M-x recentf-mode}, the
@samp{File} menu includes a submenu containing a list of recently
opened files. @kbd{M-x recentf-save-list} saves the current
-@code{recent-file-list} to a file, and @kbd{M-x recentf-edit-list}
-edits it.
+@code{recentf-list} to a file, and @kbd{M-x recentf-edit-list} edits
+it.
@c FIXME partial-completion-mode (complete.el) is obsolete.
The @kbd{M-x ffap} command generalizes @code{find-file} with more
diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi
index 8f448e1..e0eabe3 100644
--- a/doc/emacs/frames.texi
+++ b/doc/emacs/frames.texi
@@ -1362,15 +1362,16 @@ a recently used tab.
@findex tab-next
Switch to the next tab. If you repeat this command, it cycles through
all the tabs on the selected frame. With a positive numeric argument
-N, it switches to the next Nth tab; with a negative argument −N, it
-switches back to the previous Nth tab.
+@var{n}, it switches to the next @var{n}th tab; with a negative
+argument @minus{}@var{n}, it switches back to the previous @var{n}th
+tab.
@item S-C-@key{TAB}
@kindex S-C-TAB
@findex tab-previous
-Switch to the previous tab. With a positive numeric argument N, it
-switches to the previous Nth tab; with a negative argument −N, it
-switches back to the next Nth tab.
+Switch to the previous tab. With a positive numeric argument @var{n},
+it switches to the previous @var{n}th tab; with a negative argument
+@minus{}@var{n}, it switches back to the next @var{n}th tab.
@item C-x t @key{RET} @var{tabname} @key{RET}
Switch to the tab by its name, with completion on all tab names.
@@ -1392,7 +1393,7 @@ to select the tab by its number.
@findex tab-recent
Switch to the recent tab. The key combination is the modifier key
defined by @code{tab-bar-select-tab-modifiers} and the key @kbd{0}.
-With a numeric argument N, switch to the Nth recent tab.
+With a numeric argument @var{n}, switch to the @var{n}th recent tab.
@end table
The following commands can be used to operate on tabs:
@@ -1406,9 +1407,9 @@ variable @code{tab-bar-tab-name-function}.
@item C-x t m
@findex tab-move
-Move the current tab N positions to the right with a positive numeric
-argument N. With a negative argument −N, move the current tab
-N positions to the left.
+Move the current tab @var{n} positions to the right with a positive
+numeric argument @var{n}. With a negative argument @minus{}@var{n},
+move the current tab @var{n} positions to the left.
@end table
@findex tab-bar-history-mode
@@ -1621,7 +1622,7 @@ again.
enable mouse support. You must have the gpm server installed and
running on your system in order for this to work. Note that when
this mode is enabled, you cannot use the mouse to transfer text
-between Emacs and other programs which use GPM. This is due to
+between Emacs and other programs which use GPM@. This is due to
limitations in GPM and the Linux kernel.
@iftex
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index 1336da1..e7547eb 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -1968,12 +1968,12 @@ evaluate, @emph{not} as a list of files to visit.
@item -f @var{server-file}
@itemx --server-file=@var{server-file}
Specify a server file (@pxref{TCP Emacs server}) for connecting to an
-Emacs server via TCP. Alternatively, you can set the
+Emacs server via TCP@. Alternatively, you can set the
@env{EMACS_SERVER_FILE} environment variable to point to the server
file. (The command-line option overrides the environment variable.)
An Emacs server usually uses a local socket to listen for connections,
-but also supports connections over TCP. To connect to a TCP Emacs
+but also supports connections over TCP@. To connect to a TCP Emacs
server, @command{emacsclient} needs to read a @dfn{server file}
containing the connection details of the Emacs server. The name of
this file is specified with this option, either as a file name
@@ -2882,7 +2882,7 @@ widget. The URL normally defaults to the URL at or
before point, but
if there is an active region (@pxref{Mark}), the default URL comes
from the region instead, after removing any whitespace from it. The
command then creates a new buffer with the embedded browser showing
-the specified URL. The buffer is put in the Xwidget-WebKit mode
+the specified URL@. The buffer is put in the Xwidget-WebKit mode
(similar to Image mode, @pxref{Image Mode}), which provides
one-key commands for scrolling the widget, changing its size, and
reloading it. Type @w{@kbd{C-h b}} in that buffer to see the key
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 58f9336..01ae94e 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -835,7 +835,7 @@ the second and subsequent occurrences do not expand to
re-binding,
but instead expand to an equality test using @code{eq}.
The following example features a @code{pcase} form
-with two clauses and two @var{seqpat}, A and B.
+with two clauses and two @var{seqpat}, A and B@.
Both A and B first check that @var{expval} is a
pair (using @code{pred}),
and then bind symbols to the @code{car} and @code{cdr}
diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi
index 24ec656..29a0ab7 100644
--- a/doc/lispref/debugging.texi
+++ b/doc/lispref/debugging.texi
@@ -402,7 +402,7 @@ assumptions are false if the debugger is running
interpreted.
@cindex backtrace buffer
Debugger mode is derived from Backtrace mode, which is also used to
-show backtraces by Edebug and ERT. (@pxref{Edebug}, and @ref{Top,the
+show backtraces by Edebug and ERT@. (@pxref{Edebug}, and @ref{Top,the
ERT manual,, ert, ERT: Emacs Lisp Regression Testing}.)
@cindex stack frame
diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi
index dc6877c..cd8694b 100644
--- a/doc/lispref/errors.texi
+++ b/doc/lispref/errors.texi
@@ -79,9 +79,8 @@ The message is @samp{Symbol's chain of variable indirections
contains
a loop}. @xref{Variable Aliases}.
@item dbus-error
-The message is @samp{D-Bus error}. This is only defined if Emacs was
-compiled with D-Bus support. @xref{Errors and Events,,, dbus, D-Bus
-integration in Emacs}.
+The message is @samp{D-Bus error}. @xref{Errors and Events,,, dbus,
+D-Bus integration in Emacs}.
@item end-of-buffer
The message is @samp{End of buffer}. @xref{Character Motion}.
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 574c7e5..92cbc2a 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -1197,7 +1197,7 @@ inconclusive, the function returns @code{t} on Cygwin and
@code{nil}
on macOS.
Currently this function always returns @code{nil} on platforms other
-than MS-DOS, MS-Windows, Cygwin, and macOS. It does not detect
+than MS-DOS, MS-Windows, Cygwin, and macOS@. It does not detect
case-insensitivity of mounted filesystems, such as Samba shares or
NFS-mounted Windows volumes. On remote hosts, it assumes @code{t} for
the @samp{smb} method. For all other connection methods, runtime
diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index 966f620..a82b585 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -2173,7 +2173,7 @@ it on an undecorated frame.
@item override-redirect
@cindex override redirect frames
If non-@code{nil}, this means that this is an @dfn{override redirect}
-frame---a frame not handled by window managers under X. Override
+frame---a frame not handled by window managers under X@. Override
redirect frames have no window manager decorations, can be positioned
and resized only via Emacs' positioning and resizing functions and are
usually drawn on top of all other frames. Setting this parameter has
diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi
index 51831a0..c6c78ec 100644
--- a/doc/lispref/nonascii.texi
+++ b/doc/lispref/nonascii.texi
@@ -1823,9 +1823,9 @@ than all the rest.
@defmac with-coding-priority coding-systems &rest body
This macro executes @var{body}, like @code{progn} does
-(@pxref{Sequencing}), with @var{coding-systems} at the front of the
-priority list for coding systems. @var{coding-systems} should be a
-list of coding systems to prefer during execution of @var{body}.
+(@pxref{Sequencing, progn}), with @var{coding-systems} at the front of
+the priority list for coding systems. @var{coding-systems} should be
+a list of coding systems to prefer during execution of @var{body}.
@end defmac
@node Explicit Encoding
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index 67e4467..9189452 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -1989,7 +1989,7 @@ The result is @code{nil} if either argument is a NaN.
This returns the time difference @var{t1} @minus{} @var{t2} between
two time values, as a Lisp time value. The result is exact and its clock
resolution is no worse than the worse of its two arguments' resolutions.
-The result is floating-point only if it is infinite or a NaN.
+The result is floating-point only if it is infinite or a NaN@.
If you need the difference in units
of elapsed seconds, you can convert it with @code{time-convert} or
@code{float-time}. @xref{Time Conversion}.
diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi
index 4a7bda5..2ef88b9 100644
--- a/doc/lispref/strings.texi
+++ b/doc/lispref/strings.texi
@@ -1152,7 +1152,7 @@ The function @code{format-spec} described in this section
performs a
similar function to @code{format}, except it operates on format
control strings that use arbitrary specification characters.
-@defun format-spec template spec-alist &optional only-present
+@defun format-spec template spec-alist &optional ignore-missing
This function returns a string produced from the format string
@var{template} according to conversions specified in @var{spec-alist},
which is an alist (@pxref{Association Lists}) of the form
@@ -1185,12 +1185,15 @@ The order of specifications in @var{template} need not
correspond to
the order of associations in @var{spec-alist}.
@end itemize
-The optional argument @var{only-present} indicates how to handle
+The optional argument @var{ignore-missing} indicates how to handle
specification characters in @var{template} that are not found in
@var{spec-alist}. If it is @code{nil} or omitted, the function
-signals an error. Otherwise, those format specifications and any
-occurrences of @samp{%%} in @var{template} are left verbatim in the
-output, including their text properties, if any.
+signals an error; if it is @code{ignore}, those format specifications
+are left verbatim in the output, including their text properties, if
+any; if it is @code{delete}, those format specifications are removed
+from the output; any other non-@code{nil} value is handled like
+@code{ignore}, but any occurrences of @samp{%%} are also left verbatim
+in the output.
@end defun
The syntax of format specifications accepted by @code{format-spec} is
@@ -1238,7 +1241,7 @@ the right rather than the left.
@item <
This flag causes the substitution to be truncated on the left to the
-given width, if specified.
+given width and precision, if specified.
@item >
This flag causes the substitution to be truncated on the right to the
@@ -1257,9 +1260,12 @@ The result of using contradictory flags (for instance,
both upper and
lower case) is undefined.
As is the case with @code{format}, a format specification can include
-a width, which is a decimal number that appears after any flags. If a
-substitution contains fewer characters than its specified width, it is
-padded on the left:
+a width, which is a decimal number that appears after any flags, and a
+precision, which is a decimal-point @samp{.} followed by a decimal
+number that appears after any flags and width.
+
+If a substitution contains fewer characters than its specified width,
+it is padded on the left:
@example
@group
@@ -1269,6 +1275,17 @@ padded on the left:
@end group
@end example
+If a substitution contains more characters than its specified
+precision, it is truncated on the right:
+
+@example
+@group
+(format-spec "%.2a is truncated on the right"
+ '((?a . "alpha")))
+ @result{} "al is truncated on the right"
+@end group
+@end example
+
Here is a more complicated example that combines several
aforementioned features:
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index d765c95..10e8246 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -5219,7 +5219,7 @@ Signaled when encountering invalid JSON syntax.
@end table
Only top-level values (arrays and objects) can be serialized to
-JSON. The subobjects within these top-level values can be of any
+JSON@. The subobjects within these top-level values can be of any
type. Likewise, the parsing functions will only return vectors,
hashtables, alists, and plists.
diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi
index 9e5f1cc..167d2bd 100644
--- a/doc/misc/dbus.texi
+++ b/doc/misc/dbus.texi
@@ -167,7 +167,7 @@ default) or the symbol @code{:session}. An activatable
service is
described in a service registration file. Under GNU/Linux, such files
are located at @file{/usr/share/dbus-1/system-services/} (for the
@code{:system} bus) or @file{/usr/share/dbus-1/services/}. An
-activatable service is not necessarily registered at @var{bus} at already.
+activatable service is not necessarily registered at @var{bus} already.
The result is a list of strings, which is @code{nil} when there are no
activatable service names at all. Example:
@@ -180,8 +180,8 @@ activatable service names at all. Example:
@end defun
@defun dbus-list-names bus
-All service names, which are registered at D-Bus @var{bus}, are
-returned. The result is a list of strings, which is @code{nil} when
+This function returns all service names, which are registered at D-Bus
+@var{bus}. The result is a list of strings, which is @code{nil} when
there are no registered service names at all. Well known names are
strings like @samp{org.freedesktop.DBus}. Names starting with
@samp{:} are unique names for services.
@@ -191,10 +191,10 @@ strings like @samp{org.freedesktop.DBus}. Names starting
with
@end defun
@defun dbus-list-known-names bus
-Retrieves all registered services which correspond to a known name in
@var{bus}.
-A service has a known name if it doesn't start with @samp{:}. The
-result is a list of strings, which is @code{nil} when there are no
-known names at all.
+This function retrieves all registered services which correspond to a
+known name in @var{bus}. A service has a known name if it doesn't
+start with @samp{:}. The result is a list of strings, which is
+@code{nil} when there are no known names at all.
@var{bus} must be either the symbol @code{:system} or the symbol
@code{:session}.
@@ -202,9 +202,9 @@ known names at all.
@defun dbus-list-queued-owners bus service
For a given service, registered at D-Bus @var{bus} under the name
-@var{service}, all queued unique names are returned. The result is a
-list of strings, or @code{nil} when there are no queued names for
-@var{service} at all.
+@var{service}, this function returns all queued unique names. The
+result is a list of strings, or @code{nil} when there are no queued
+names for @var{service} at all.
@var{bus} must be either the symbol @code{:system} or the symbol
@code{:session}. @var{service} must be a known service name as
@@ -213,9 +213,9 @@ string.
@defun dbus-get-name-owner bus service
For a given service, registered at D-Bus @var{bus} under the name
-@var{service}, the unique name of the name owner is returned. The
-result is a string, or @code{nil} when there exist no name owner of
-@var{service}.
+@var{service}, this function returns the unique name of the name
+owner. The result is a string, or @code{nil} when there is no name
+owner of @var{service}.
@var{bus} must be either the symbol @code{:system} or the symbol
@code{:session}. @var{service} must be a known service name as
@@ -223,26 +223,28 @@ string.
@end defun
@defun dbus-ping bus service &optional timeout
-Check whether the service name @var{service} is registered at D-Bus
-@var{bus}. @var{service} might not have been started yet, it is
-autostarted if possible. The result is either @code{t} or @code{nil}.
+This function checks whether the service name @var{service} is
+registered at D-Bus @var{bus}. If @var{service} has not yet started,
+it is autostarted if possible. The result is either @code{t} or
+@code{nil}.
@var{bus} must be either the symbol @code{:system} or the symbol
@code{:session}. @var{service} must be a string. @var{timeout}, a
nonnegative integer, specifies the maximum number of milliseconds
-@code{dbus-ping} must return. The default value is 25,000. Example:
+before @code{dbus-ping} must return. The default value is 25,000.
+Example:
@lisp
(message
- "%s screensaver on board."
- (cond
- ((dbus-ping :session "org.gnome.ScreenSaver" 100) "Gnome")
- ((dbus-ping :session "org.freedesktop.ScreenSaver" 100) "KDE")
- (t "No")))
+ "%s screensaver on board."
+ (cond
+ ((dbus-ping :session "org.gnome.ScreenSaver" 100) "Gnome")
+ ((dbus-ping :session "org.freedesktop.ScreenSaver" 100) "KDE")
+ (t "No")))
@end lisp
-If it shall be checked whether @var{service} is already running
-without autostarting it, one shall apply
+To check whether @var{service} is already running without autostarting
+it, you can instead write:
@lisp
(member service (dbus-list-known-names bus))
@@ -250,8 +252,9 @@ without autostarting it, one shall apply
@end defun
@defun dbus-get-unique-name bus
-The unique name, under which Emacs is registered at D-Bus @var{bus},
-is returned as string.
+@anchor{dbus-get-unique-name}
+This function returns the unique name, under which Emacs is registered
+at D-Bus @var{bus}, as a string.
@var{bus} must be either the symbol @code{:system} or the symbol
@code{:session}.
@@ -380,8 +383,8 @@ format. Example:
@lisp
(dbus-introspect
- :system "org.freedesktop.Hal"
- "/org/freedesktop/Hal/devices/computer")
+ :system "org.freedesktop.Hal"
+ "/org/freedesktop/Hal/devices/computer")
@result{} "<!DOCTYPE node PUBLIC
"-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
@@ -420,46 +423,51 @@ the HAL specification}.}
@end defun
@defun dbus-introspect-xml bus service path
-This function has the same intention as function
+This function serves a similar purpose to the function
@code{dbus-introspect}. The returned value is a parsed XML tree,
which can be used for further analysis. Example:
@lisp
(dbus-introspect-xml
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main")
@result{} (node ((name . "/org/freedesktop/xesam/searcher/main"))
- (interface ((name . "org.freedesktop.xesam.Search"))
- (method ((name . "GetHitData"))
- (arg ((name . "search") (type . "s") (direction . "in")))
- (arg ((name . "hit_ids") (type . "au") (direction . "in")))
- (arg ((name . "fields") (type . "as") (direction . "in")))
- (arg ((name . "hit_data") (type . "aav") (direction . "out")))
- )
- @dots{}
- (signal ((name . "HitsAdded"))
- (arg ((name . "search") (type . "s")))
- (arg ((name . "count") (type . "u")))
- )
- )
- @dots{}
- )
+ (interface ((name . "org.freedesktop.xesam.Search"))
+ (method ((name . "GetHitData"))
+ (arg ((name . "search")
+ (type . "s")
+ (direction . "in")))
+ (arg ((name . "hit_ids")
+ (type . "au")
+ (direction . "in")))
+ (arg ((name . "fields")
+ (type . "as")
+ (direction . "in")))
+ (arg ((name . "hit_data")
+ (type . "aav")
+ (direction . "out"))))
+ @dots{}
+ (signal ((name . "HitsAdded"))
+ (arg ((name . "search") (type . "s")))
+ (arg ((name . "count") (type . "u")))))
+ @dots{})
@end lisp
@end defun
@defun dbus-introspect-get-attribute object attribute
-It returns the @var{attribute} value of a D-Bus introspection
-@var{object}. @var{object} can be every subtree of a parsed XML tree
-as retrieved with @code{dbus-introspect-xml}. @var{attribute} must be
-a string according to the attribute names in the D-Bus specification.
-Example:
+This function returns the @var{attribute} value of a D-Bus
+introspection @var{object}. The value of @var{object} can be any
+subtree of a parsed XML tree as retrieved with
+@code{dbus-introspect-xml}. @var{attribute} must be a string
+according to the attribute names in the D-Bus specification. Example:
@lisp
(dbus-introspect-get-attribute
- (dbus-introspect-xml :system "org.freedesktop.SystemToolsBackends"
- "/org/freedesktop/SystemToolsBackends/UsersConfig")
- "name")
+ (dbus-introspect-xml
+ :system "org.freedesktop.SystemToolsBackends"
+ "/org/freedesktop/SystemToolsBackends/UsersConfig")
+ "name")
@result{} "/org/freedesktop/SystemToolsBackends/UsersConfig"
@end lisp
@@ -476,12 +484,12 @@ The first elements, to be introspected for a D-Bus
object, are further
object paths and interfaces.
@defun dbus-introspect-get-node-names bus service path
-All node names of @var{service} in D-Bus @var{bus} at object path
-@var{path} are returned as list of strings. Example:
+This function returns all node names of @var{service} in D-Bus
+@var{bus} at object path @var{path} as a list of strings. Example:
@lisp
(dbus-introspect-get-node-names
- :session "org.gnome.seahorse" "/org/gnome/seahorse")
+ :session "org.gnome.seahorse" "/org/gnome/seahorse")
@result{} ("crypto" "keys")
@end lisp
@@ -512,9 +520,10 @@ Example:
@end defun
@defun dbus-introspect-get-interface-names bus service path
-There will be returned a list strings of all interface names of
+This function returns a list strings of all interface names of
@var{service} in D-Bus @var{bus} at object path @var{path}. This list
-will contain the default interface @samp{org.freedesktop.DBus.Introspectable}.
+will contain the default interface
+@samp{org.freedesktop.DBus.Introspectable}.
Another default interface is @samp{org.freedesktop.DBus.Properties}.
If present, @code{interface} elements can also have @code{property}
@@ -522,8 +531,8 @@ children. Example:
@lisp
(dbus-introspect-get-interface-names
- :system "org.freedesktop.Hal"
- "/org/freedesktop/Hal/devices/computer")
+ :system "org.freedesktop.Hal"
+ "/org/freedesktop/Hal/devices/computer")
@result{} ("org.freedesktop.DBus.Introspectable"
"org.freedesktop.Hal.Device"
@@ -533,30 +542,27 @@ children. Example:
@end defun
@defun dbus-introspect-get-interface bus service path interface
-Return @var{interface} of @var{service} in D-Bus @var{bus} at object
-path @var{path}. The return value is an XML element. @var{interface}
-must be a string, element of the list returned by
-@code{dbus-introspect-get-interface-names}. Example:
+This function returns @var{interface} of @var{service} in D-Bus
+@var{bus} at object path @var{path}. The return value is an XML
+element. @var{interface} must be a string and a member of the list
+returned by @code{dbus-introspect-get-interface-names}. Example:
@lisp
(dbus-introspect-get-interface
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search")
@result{} (interface ((name . "org.freedesktop.xesam.Search"))
(method ((name . "GetHitData"))
(arg ((name . "search") (type . "s") (direction . "in")))
(arg ((name . "hit_ids") (type . "au") (direction . "in")))
(arg ((name . "fields") (type . "as") (direction . "in")))
- (arg ((name . "hit_data") (type . "aav") (direction . "out")))
- )
+ (arg ((name . "hit_data") (type . "aav") (direction . "out"))))
@dots{}
(signal ((name . "HitsAdded"))
(arg ((name . "search") (type . "s")))
- (arg ((name . "count") (type . "u")))
- )
- )
+ (arg ((name . "count") (type . "u")))))
@end lisp
@end defun
@@ -565,7 +571,8 @@ With these functions, it is possible to retrieve all
introspection
data from a running system:
@lisp
-(with-current-buffer (switch-to-buffer "*introspect*")
+(progn
+ (pop-to-buffer "*introspect*")
(erase-buffer)
(dolist (service (dbus-list-known-names :session))
(dolist (path (dbus-introspect-get-all-nodes :session service "/"))
@@ -574,7 +581,7 @@ data from a running system:
(when (delete
"org.freedesktop.DBus.Introspectable"
(dbus-introspect-get-interface-names :session service path))
- (insert (message "\nservice: \"%s\" path: \"%s\"\n" service path)
+ (insert (format "\nservice: \"%s\" path: \"%s\"\n" service path)
(dbus-introspect :session service path))
(redisplay t)))))
@end lisp
@@ -587,14 +594,15 @@ Methods and signals are the communication means to D-Bus.
The
following functions return their specifications.
@defun dbus-introspect-get-method-names bus service path interface
-Return a list of strings of all method names of @var{interface} of
-@var{service} in D-Bus @var{bus} at object path @var{path}. Example:
+This function returns a list of strings of all method names of
+@var{interface} of @var{service} in D-Bus @var{bus} at object path
+@var{path}. Example:
@lisp
(dbus-introspect-get-method-names
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search")
@result{} ("GetState" "StartSearch" "GetHitCount" "GetHits" "NewSession"
"CloseSession" "GetHitData" "SetProperty" "NewSearch"
@@ -603,35 +611,36 @@ Return a list of strings of all method names of
@var{interface} of
@end defun
@defun dbus-introspect-get-method bus service path interface method
-This function returns @var{method} of @var{interface} as XML element.
-It must be located at @var{service} in D-Bus @var{bus} at object path
-@var{path}. @var{method} must be a string, element of the list
-returned by @code{dbus-introspect-get-method-names}. Example:
+This function returns @var{method} of @var{interface} as an XML
+element. It must be located at @var{service} in D-Bus @var{bus} at
+object path @var{path}. @var{method} must be a string and a member of
+the list returned by @code{dbus-introspect-get-method-names}.
+Example:
@lisp
(dbus-introspect-get-method
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search" "GetHitData")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search" "GetHitData")
@result{} (method ((name . "GetHitData"))
(arg ((name . "search") (type . "s") (direction . "in")))
(arg ((name . "hit_ids") (type . "au") (direction . "in")))
(arg ((name . "fields") (type . "as") (direction . "in")))
- (arg ((name . "hit_data") (type . "aav") (direction . "out")))
- )
+ (arg ((name . "hit_data") (type . "aav") (direction . "out"))))
@end lisp
@end defun
@defun dbus-introspect-get-signal-names bus service path interface
-Return a list of strings of all signal names of @var{interface} of
-@var{service} in D-Bus @var{bus} at object path @var{path}. Example:
+This function returns a list of strings of all signal names of
+@var{interface} of @var{service} in D-Bus @var{bus} at object path
+@var{path}. Example:
@lisp
(dbus-introspect-get-signal-names
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search")
@result{} ("StateChanged" "SearchDone" "HitsModified"
"HitsRemoved" "HitsAdded")
@@ -639,21 +648,21 @@ Return a list of strings of all signal names of
@var{interface} of
@end defun
@defun dbus-introspect-get-signal bus service path interface signal
-This function returns @var{signal} of @var{interface} as XML element.
-It must be located at @var{service} in D-Bus @var{bus} at object path
-@var{path}. @var{signal} must be a string, element of the list
-returned by @code{dbus-introspect-get-signal-names}. Example:
+This function returns @var{signal} of @var{interface} as an XML
+element. It must be located at @var{service} in D-Bus @var{bus} at
+object path @var{path}. @var{signal} must be a string and a member of
+the list returned by @code{dbus-introspect-get-signal-names}.
+Example:
@lisp
(dbus-introspect-get-signal
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search" "HitsAdded")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search" "HitsAdded")
@result{} (signal ((name . "HitsAdded"))
(arg ((name . "search") (type . "s")))
- (arg ((name . "count") (type . "u")))
- )
+ (arg ((name . "count") (type . "u"))))
@end lisp
@end defun
@@ -664,8 +673,8 @@ returned by @code{dbus-introspect-get-signal-names}.
Example:
Interfaces can have properties. These can be exposed via the
@samp{org.freedesktop.DBus.Properties} interface@footnote{See
@uref{https://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-properties}}.
-That is, properties can be retrieved and changed during lifetime of an
-element.
+That is, properties can be retrieved and changed during the lifetime
+of an element.
A generalized interface is
@samp{org.freedesktop.DBus.Objectmanager}@footnote{See
@@ -678,13 +687,14 @@ Often, they are used to instruct generators, how to
generate code from
the interface for a given language binding.
@defun dbus-introspect-get-property-names bus service path interface
-Return a list of strings with all property names of @var{interface} of
-@var{service} in D-Bus @var{bus} at object path @var{path}. Example:
+This function returns a list of strings with all property names of
+@var{interface} of @var{service} in D-Bus @var{bus} at object path
+@var{path}. Example:
@lisp
(dbus-introspect-get-property-names
- :session "org.kde.kded" "/modules/networkstatus"
- "org.kde.Solid.Networking.Client")
+ :session "org.kde.kded" "/modules/networkstatus"
+ "org.kde.Solid.Networking.Client")
@result{} ("Status")
@end lisp
@@ -694,26 +704,26 @@ also the @samp{org.freedesktop.DBus.Properties} interface.
@end defun
@defun dbus-introspect-get-property bus service path interface property
-This function returns @var{property} of @var{interface} as XML element.
-It must be located at @var{service} in D-Bus @var{bus} at object path
-@var{path}. @var{property} must be a string, element of the list
-returned by @code{dbus-introspect-get-property-names}.
+This function returns @var{property} of @var{interface} as an XML
+element. It must be located at @var{service} in D-Bus @var{bus} at
+object path @var{path}. @var{property} must be a string and a member
+of the list returned by @code{dbus-introspect-get-property-names}.
A @var{property} value can be retrieved by the function
@code{dbus-introspect-get-attribute}. Example:
@lisp
(dbus-introspect-get-property
- :session "org.kde.kded" "/modules/networkstatus"
- "org.kde.Solid.Networking.Client" "Status")
+ :session "org.kde.kded" "/modules/networkstatus"
+ "org.kde.Solid.Networking.Client" "Status")
@result{} (property ((access . "read") (type . "u") (name . "Status")))
(dbus-introspect-get-attribute
- (dbus-introspect-get-property
- :session "org.kde.kded" "/modules/networkstatus"
- "org.kde.Solid.Networking.Client" "Status")
- "access")
+ (dbus-introspect-get-property
+ :session "org.kde.kded" "/modules/networkstatus"
+ "org.kde.Solid.Networking.Client" "Status")
+ "access")
@result{} "read"
@end lisp
@@ -727,23 +737,23 @@ result can be any valid D-Bus value, or @code{nil} if
there is no
@lisp
(dbus-get-property
- :session "org.kde.kded" "/modules/networkstatus"
- "org.kde.Solid.Networking.Client" "Status")
+ :session "org.kde.kded" "/modules/networkstatus"
+ "org.kde.Solid.Networking.Client" "Status")
@result{} 4
@end lisp
@end defun
@defun dbus-set-property bus service path interface property value
-Set value of @var{property} of @var{interface} to @var{value}. It
-will be checked at @var{bus}, @var{service}, @var{path}. When the
-value has been set successful, the result is @var{value}. Otherwise,
-@code{nil} is returned. Example:
+This function sets the value of @var{property} of @var{interface} to
+@var{value}. It will be checked at @var{bus}, @var{service},
+@var{path}. When the value is successfully set, this function returns
+@var{value}. Otherwise, it returns @code{nil}. Example:
@lisp
(dbus-set-property
- :session "org.kde.kaccess" "/MainApplication"
- "com.trolltech.Qt.QApplication" "doubleClickInterval" 500)
+ :session "org.kde.kaccess" "/MainApplication"
+ "com.trolltech.Qt.QApplication" "doubleClickInterval" 500)
@result{} 500
@end lisp
@@ -757,8 +767,8 @@ If there are no properties, @code{nil} is returned.
Example:
@lisp
(dbus-get-all-properties
- :session "org.kde.kaccess" "/MainApplication"
- "com.trolltech.Qt.QApplication")
+ :session "org.kde.kaccess" "/MainApplication"
+ "com.trolltech.Qt.QApplication")
@result{} (("cursorFlashTime" . 1000) ("doubleClickInterval" . 500)
("keyboardInputInterval" . 400) ("wheelScrollLines" . 3)
@@ -773,13 +783,13 @@ This function returns all objects at @var{bus},
@var{service},
@var{path}, and the children of @var{path}. The result is a list of
objects. Every object is a cons of an existing path name, and the
list of available interface objects. An interface object is another
-cons, which car is the interface name, and the cdr is the list of
+cons, whose car is the interface name and cdr is the list of
properties as returned by @code{dbus-get-all-properties} for that path
-and interface. Example:
+and interface. Example:
@lisp
(dbus-get-all-managed-objects
- :session "org.gnome.SettingsDaemon" "/")
+ :session "org.gnome.SettingsDaemon" "/")
@result{} (("/org/gnome/SettingsDaemon/MediaKeys"
("org.gnome.SettingsDaemon.MediaKeys")
@@ -809,31 +819,28 @@ An overview of all existing object paths, their
interfaces and
properties could be retrieved by the following code:
@lisp
-(with-current-buffer (switch-to-buffer "*objectmanager*")
+(let ((result (mapcar (lambda (service)
+ (cons service
+ (dbus-get-all-managed-objects
+ :session service "/")))
+ (dbus-list-known-names :session))))
+ (pop-to-buffer "*objectmanager*")
(erase-buffer)
- (let (result)
- (dolist (service (dbus-list-known-names :session) result)
- (message "%s" service)
- (add-to-list
- 'result
- (cons service
- (dbus-get-all-managed-objects :session service "/"))))
- (insert (message "%s" (pp result)))
- (redisplay t)))
+ (pp result (current-buffer)))
@end lisp
@end defun
@defun dbus-introspect-get-annotation-names bus service path interface
&optional name
-Return a list of all annotation names as list of strings. If
-@var{name} is @code{nil}, the annotations are children of
+This function returns a list of all annotation names as list of
+strings. If @var{name} is @code{nil}, the annotations are children of
@var{interface}, otherwise @var{name} must be a @code{method},
@code{signal}, or @code{property} XML element, where the annotations
belong to. Example:
@lisp
(dbus-introspect-get-annotation-names
- :session "de.berlios.Pinot" "/de/berlios/Pinot"
- "de.berlios.Pinot" "GetStatistics")
+ :session "de.berlios.Pinot" "/de/berlios/Pinot"
+ "de.berlios.Pinot" "GetStatistics")
@result{} ("de.berlios.Pinot.GetStatistics")
@end lisp
@@ -855,29 +862,30 @@ If set, don't expect a reply to the @code{method} call;
defaults to @code{nil}
@end defun
@defun dbus-introspect-get-annotation bus service path interface name
annotation
-Return annotation @var{ANNOTATION} as XML object. If @var{name} is
-@code{nil}, @var{ANNOTATION} is a child of @var{interface}, otherwise
-@var{name} must be the name of a @code{method}, @code{signal}, or
-@code{property} XML element, where the @var{ANNOTATION} belongs to.
+This function returns @var{annotation} as an XML object. If
+@var{name} is @code{nil}, @var{annotation} is a child of
+@var{interface}, otherwise @var{name} must be the name of a
+@code{method}, @code{signal}, or @code{property} XML element, where
+the @var{annotation} belongs to.
An attribute value can be retrieved by
@code{dbus-introspect-get-attribute}. Example:
@lisp
(dbus-introspect-get-annotation
- :session "de.berlios.Pinot" "/de/berlios/Pinot"
- "de.berlios.Pinot" "GetStatistics"
- "de.berlios.Pinot.GetStatistics")
+ :session "de.berlios.Pinot" "/de/berlios/Pinot"
+ "de.berlios.Pinot" "GetStatistics"
+ "de.berlios.Pinot.GetStatistics")
@result{} (annotation ((name . "de.berlios.Pinot.GetStatistics")
(value . "pinotDBus")))
(dbus-introspect-get-attribute
- (dbus-introspect-get-annotation
- :session "de.berlios.Pinot" "/de/berlios/Pinot"
- "de.berlios.Pinot" "GetStatistics"
- "de.berlios.Pinot.GetStatistics")
- "value")
+ (dbus-introspect-get-annotation
+ :session "de.berlios.Pinot" "/de/berlios/Pinot"
+ "de.berlios.Pinot" "GetStatistics"
+ "de.berlios.Pinot.GetStatistics")
+ "value")
@result{} "pinotDBus"
@end lisp
@@ -891,39 +899,41 @@ Methods and signals have arguments. They are described
in the
@code{arg} XML elements.
@defun dbus-introspect-get-argument-names bus service path interface name
-Return a list of all argument names as list of strings. @var{name}
-must be a @code{method} or @code{signal} XML element. Example:
+This function returns a list of all argument names as strings.
+@var{name} must be a @code{method} or @code{signal} XML element.
+Example:
@lisp
(dbus-introspect-get-argument-names
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search" "GetHitData")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search" "GetHitData")
@result{} ("search" "hit_ids" "fields" "hit_data")
@end lisp
-Argument names are optional; the function can return @code{nil}
-therefore, even if the method or signal has arguments.
+Argument names are optional; the function can therefore return
+@code{nil}, even if the method or signal has arguments.
@end defun
@defun dbus-introspect-get-argument bus service path interface name arg
-Return argument @var{ARG} as XML object. @var{name}
-must be a @code{method} or @code{signal} XML element. Example:
+This function returns the argument @var{arg} as an XML object.
+@var{name} must be a @code{method} or @code{signal} XML element.
+Example:
@lisp
(dbus-introspect-get-argument
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search" "GetHitData" "search")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search" "GetHitData" "search")
@result{} (arg ((name . "search") (type . "s") (direction . "in")))
@end lisp
@end defun
@defun dbus-introspect-get-signature bus service path interface name &optional
direction
-Return signature of a @code{method} or @code{signal}, represented by
-@var{name}, as string.
+This function returns the signature of a @code{method} or
+@code{signal}, represented by @var{name}, as a string.
If @var{name} is a @code{method}, @var{direction} can be either
@samp{in} or @samp{out}. If @var{direction} is @code{nil}, @samp{in}
@@ -934,16 +944,16 @@ non-@code{nil}, @var{direction} must be @samp{out}.
Example:
@lisp
(dbus-introspect-get-signature
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search" "GetHitData" "in")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search" "GetHitData" "in")
@result{} "sauas"
(dbus-introspect-get-signature
- :session "org.freedesktop.xesam.searcher"
- "/org/freedesktop/xesam/searcher/main"
- "org.freedesktop.xesam.Search" "HitsAdded")
+ :session "org.freedesktop.xesam.searcher"
+ "/org/freedesktop/xesam/searcher/main"
+ "org.freedesktop.xesam.Search" "HitsAdded")
@result{} "su"
@end lisp
@@ -998,30 +1008,27 @@ types are represented by the type symbols @code{:byte},
Example:
@lisp
-(dbus-call-method @dots{} @var{NAT-NUMBER} @var{STRING})
+(dbus-call-method @dots{} @var{nat-number} @var{string})
@end lisp
is equivalent to
@lisp
-(dbus-call-method @dots{} :uint32 @var{NAT-NUMBER} :string @var{STRING})
+(dbus-call-method @dots{} :uint32 @var{nat-number} :string @var{string})
@end lisp
but different to
@lisp
-(dbus-call-method @dots{} :int32 @var{NAT-NUMBER} :signature @var{STRING})
+(dbus-call-method @dots{} :int32 @var{nat-number} :signature @var{string})
@end lisp
The value for a byte D-Bus type can be any integer in the range 0
through 255. If a character is used as argument, modifiers
represented outside this range are stripped off. For example,
@code{:byte ?x} is equal to @code{:byte ?\M-x}, but it is not equal to
-@code{:byte ?\C-x} or @code{:byte ?\M-\C-x}.
-
-Signed and unsigned integer D-Bus types expect a corresponding integer
-value. If the value does not fit Emacs's integer range, it is also
-possible to use an equivalent floating point number.
+@code{:byte ?\C-x} or @code{:byte ?\M-\C-x}. Signed and unsigned
+integer D-Bus types expect a corresponding integer value.
A D-Bus compound type is always represented as a list. The @sc{car}
of this list can be the type symbol @code{:array}, @code{:variant},
@@ -1036,13 +1043,13 @@ D-Bus compound type rules.
@item An array must contain only elements of the same D-Bus type. It
can be empty.
-@item A variant must contain only one single element.
+@item A variant must contain only a single element.
-@item A dictionary entry must be element of an array, and it must
+@item A dictionary entry must be an element of an array, and it must
contain only a key-value pair of two elements, with a basic D-Bus type
key.
-@item There is no restriction for structs.
+@item There are no restrictions for structs.
@end itemize
If an empty array needs an element D-Bus type other than string, it
@@ -1052,27 +1059,27 @@ elements of this array. Example:
@lisp
(dbus-call-method
- :session "org.freedesktop.Notifications"
- "/org/freedesktop/Notifications"
- "org.freedesktop.Notifications" "Notify"
- "GNU Emacs" ;; Application name.
- 0 ;; No replacement of other notifications.
- "" ;; No icon.
- "Notification summary" ;; Summary.
- (format ;; Body.
- "This is a test notification, raised from\n%S" (emacs-version))
- '(:array) ;; No actions (empty array of strings).
- '(:array :signature "@{sv@}") ;; No hints
- ;; (empty array of dictionary entries).
- :int32 -1) ;; Default timeout.
+ :session "org.freedesktop.Notifications"
+ "/org/freedesktop/Notifications"
+ "org.freedesktop.Notifications" "Notify"
+ "GNU Emacs" ; Application name.
+ 0 ; No replacement of other notifications.
+ "" ; No icon.
+ "Notification summary" ; Summary.
+ (format ; Body.
+ "This is a test notification, raised from\n%S" (emacs-version))
+ '(:array) ; No actions (empty array of strings).
+ '(:array :signature "@{sv@}") ; No hints
+ ; (empty array of dictionary entries).
+ :int32 -1) ; Default timeout.
@result{} 3
@end lisp
@defun dbus-string-to-byte-array string
Sometimes, D-Bus methods require as input parameter an array of bytes,
-instead of a string. If it is guaranteed, that @var{string} is an
-UTF8 string, this function performs the conversion. Example:
+instead of a string. If it is guaranteed, that @var{string} is a
+UTF-8 string, this function performs the conversion. Example:
@lisp
(dbus-string-to-byte-array "/etc/hosts")
@@ -1083,10 +1090,10 @@ UTF8 string, this function performs the conversion.
Example:
@end defun
@defun dbus-escape-as-identifier string
-Escape an arbitrary @var{string} so it follows the rules for a C
-identifier. The escaped string can be used as object path component,
-interface element component, bus name component or member name in
-D-Bus.
+This function escapes an arbitrary @var{string} so it follows the
+rules for a C identifier. The escaped string can be used as object
+path component, interface element component, bus name component or
+member name in D-Bus.
The escaping consists of replacing all non-alphanumerics, and the
first character if it's a digit, with an underscore and two
@@ -1107,18 +1114,18 @@ Output parameters of D-Bus methods and signals are
mapped to Lisp
objects.
@example
-@multitable {DBUS_TYPE_OBJECT_PATH} {@expansion{}} {natural number or float}
+@multitable {DBUS_TYPE_OBJECT_PATH} {@expansion{}} {natural number}
@item D-Bus type @tab @tab Lisp type
@item
@item DBUS_TYPE_BOOLEAN @tab @expansion{} @tab @code{t} or @code{nil}
@item DBUS_TYPE_BYTE @tab @expansion{} @tab natural number
@item DBUS_TYPE_UINT16 @tab @expansion{} @tab natural number
@item DBUS_TYPE_INT16 @tab @expansion{} @tab integer
-@item DBUS_TYPE_UINT32 @tab @expansion{} @tab natural number or float
-@item DBUS_TYPE_UNIX_FD @tab @expansion{} @tab natural number or float
-@item DBUS_TYPE_INT32 @tab @expansion{} @tab integer or float
-@item DBUS_TYPE_UINT64 @tab @expansion{} @tab natural number or float
-@item DBUS_TYPE_INT64 @tab @expansion{} @tab integer or float
+@item DBUS_TYPE_UINT32 @tab @expansion{} @tab natural number
+@item DBUS_TYPE_UNIX_FD @tab @expansion{} @tab natural number
+@item DBUS_TYPE_INT32 @tab @expansion{} @tab integer
+@item DBUS_TYPE_UINT64 @tab @expansion{} @tab natural number
+@item DBUS_TYPE_INT64 @tab @expansion{} @tab integer
@item DBUS_TYPE_DOUBLE @tab @expansion{} @tab float
@item DBUS_TYPE_STRING @tab @expansion{} @tab string
@item DBUS_TYPE_OBJECT_PATH @tab @expansion{} @tab string
@@ -1130,26 +1137,21 @@ objects.
@end multitable
@end example
-A float object in case of @code{DBUS_TYPE_UINT32},
-@code{DBUS_TYPE_INT32}, @code{DBUS_TYPE_UINT64},
-@code{DBUS_TYPE_INT64} and @code{DBUS_TYPE_UNIX_FD} is returned, when
-the C value exceeds the Emacs number size range.
-
The resulting list of the last 4 D-Bus compound types contains as
elements the elements of the D-Bus container, mapped according to the
same rules.
-The signal @code{PropertyModified}, discussed as example in
+The signal @code{PropertyModified}, discussed as an example in
@ref{Inspection}, would offer as Lisp data the following object
-(@var{BOOL} stands here for either @code{nil} or @code{t}):
+(@var{bool} stands here for either @code{nil} or @code{t}):
@lisp
-(@var{INTEGER} ((@var{STRING} @var{BOOL} @var{BOOL}) (@var{STRING} @var{BOOL}
@var{BOOL}) @dots{}))
+(@var{integer} ((@var{string} @var{bool} @var{bool}) (@var{string} @var{bool}
@var{bool}) @dots{}))
@end lisp
@defun dbus-byte-array-to-string byte-array &optional multibyte
If a D-Bus method or signal returns an array of bytes, which are known
-to represent an UTF8 string, this function converts @var{byte-array}
+to represent a UTF-8 string, this function converts @var{byte-array}
to the corresponding string. The string is unibyte encoded, unless
@var{multibyte} is non-@code{nil}. Example:
@@ -1161,9 +1163,9 @@ to the corresponding string. The string is unibyte
encoded, unless
@end defun
@defun dbus-unescape-from-identifier string
-Retrieve the original string from the encoded @var{string} as unibyte
-string. @var{string} must have been encoded with
-@code{dbus-escape-as-identifier}. Example:
+This function retrieves the original string from the encoded
+@var{string} as a unibyte string. The value of @var{string} must have
+been encoded with @code{dbus-escape-as-identifier}. Example:
@lisp
(dbus-unescape-from-identifier "_30123abc_5fxyz_01_ff")
@@ -1177,9 +1179,9 @@ that string:
@lisp
(string-equal
- (dbus-unescape-from-identifier
- (dbus-escape-as-identifier "Grüß Göttin"))
- "Grüß Göttin")
+ (dbus-unescape-from-identifier
+ (dbus-escape-as-identifier "Grüß Göttin"))
+ "Grüß Göttin")
@result{} nil
@end lisp
@@ -1196,12 +1198,13 @@ that string:
Methods can be called synchronously (@dfn{blocking}) or asynchronously
(@dfn{non-blocking}).
-At D-Bus level, a method call consist of two messages: one message
+At the D-Bus level, a method call consist of two messages: one message
which carries the input parameters to the object owning the method to
be called, and a reply message returning the resulting output
parameters from the object.
@defun dbus-call-method bus service path interface method &optional :timeout
timeout &rest args
+@anchor{dbus-call-method}
This function calls @var{method} on the D-Bus @var{bus}. @var{bus} is
either the symbol @code{:system} or the symbol @code{:session}.
@@ -1210,14 +1213,14 @@ D-Bus object path, @var{service} is registered at.
@var{interface} is
an interface offered by @var{service}. It must provide @var{method}.
If the parameter @code{:timeout} is given, the following integer
-@var{timeout} specifies the maximum number of milliseconds the method
-call must return. The default value is 25,000. If the method call
-doesn't return in time, a D-Bus error is raised (@pxref{Errors and
-Events}).
+@var{timeout} specifies the maximum number of milliseconds before the
+method call must return. The default value is 25,000. If the method
+call doesn't return in time, a D-Bus error is raised (@pxref{Errors
+and Events}).
-All other arguments args are passed to @var{method} as arguments.
-They are converted into D-Bus types as described in @ref{Type
-Conversion}.
+The remaining arguments @var{args} are passed to @var{method} as
+arguments. They are converted into D-Bus types as described in
+@ref{Type Conversion}.
The function returns the resulting values of @var{method} as a list of
Lisp objects, according to the type conversion rules described in
@@ -1225,9 +1228,9 @@ Lisp objects, according to the type conversion rules
described in
@lisp
(dbus-call-method
- :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
- "org.gnome.seahorse.Keys" "GetKeyField"
- "openpgp:657984B8C7A966DD" "simple-name")
+ :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
+ "org.gnome.seahorse.Keys" "GetKeyField"
+ "openpgp:657984B8C7A966DD" "simple-name")
@result{} (t ("Philip R. Zimmermann"))
@end lisp
@@ -1238,10 +1241,10 @@ object. Example:
@lisp
(dbus-call-method
- :system "org.freedesktop.Hal"
- "/org/freedesktop/Hal/devices/computer"
- "org.freedesktop.Hal.Device" "GetPropertyString"
- "system.kernel.machine")
+ :system "org.freedesktop.Hal"
+ "/org/freedesktop/Hal/devices/computer"
+ "org.freedesktop.Hal.Device" "GetPropertyString"
+ "system.kernel.machine")
@result{} "i686"
@end lisp
@@ -1257,17 +1260,17 @@ emulate the @code{lshal} command on GNU/Linux systems:
@lisp
(dolist (device
- (dbus-call-method
- :system "org.freedesktop.Hal"
- "/org/freedesktop/Hal/Manager"
- "org.freedesktop.Hal.Manager" "GetAllDevices"))
+ (dbus-call-method
+ :system "org.freedesktop.Hal"
+ "/org/freedesktop/Hal/Manager"
+ "org.freedesktop.Hal.Manager" "GetAllDevices"))
(message "\nudi = %s" device)
(dolist (properties
- (dbus-call-method
- :system "org.freedesktop.Hal" device
- "org.freedesktop.Hal.Device" "GetAllProperties"))
+ (dbus-call-method
+ :system "org.freedesktop.Hal" device
+ "org.freedesktop.Hal.Device" "GetAllProperties"))
(message " %s = %S"
- (car properties) (or (caar (cdr properties)) ""))))
+ (car properties) (or (caadr properties) ""))))
@print{} "udi = /org/freedesktop/Hal/devices/computer
info.addons = (\"hald-addon-acpi\")
@@ -1304,34 +1307,35 @@ D-Bus object path, @var{service} is registered at.
@var{interface} is
an interface offered by @var{service}. It must provide @var{method}.
@var{handler} is a Lisp function, which is called when the
-corresponding return message has arrived. If @var{handler} is
-@code{nil}, no return message will be expected.
+corresponding return message arrives. If @var{handler} is @code{nil},
+no return message will be expected.
If the parameter @code{:timeout} is given, the following integer
-@var{timeout} specifies the maximum number of milliseconds a reply
-message must arrive. The default value is 25,000. If there is no
-reply message in time, a D-Bus error is raised (@pxref{Errors and
+@var{timeout} specifies the maximum number of milliseconds before a
+reply message must arrive. The default value is 25,000. If there is
+no reply message in time, a D-Bus error is raised (@pxref{Errors and
Events}).
-All other arguments args are passed to @var{method} as arguments.
-They are converted into D-Bus types as described in @ref{Type
-Conversion}.
+The remaining arguments @var{args} are passed to @var{method} as
+arguments. They are converted into D-Bus types as described in
+@ref{Type Conversion}.
If @var{handler} is a Lisp function, the function returns a key into
the hash table @code{dbus-registered-objects-table}. The
corresponding entry in the hash table is removed, when the return
-message has been arrived, and @var{handler} is called. Example:
+message arrives, and @var{handler} is called. Example:
@lisp
(dbus-call-method-asynchronously
- :system "org.freedesktop.Hal"
- "/org/freedesktop/Hal/devices/computer"
- "org.freedesktop.Hal.Device" "GetPropertyString" 'message
- "system.kernel.machine")
-
-@result{} (:serial :system 2)
+ :system "org.freedesktop.Hal"
+ "/org/freedesktop/Hal/devices/computer"
+ "org.freedesktop.Hal.Device" "GetPropertyString"
+ (lambda (msg) (message "%s" msg))
+ "system.kernel.machine")
@print{} i686
+
+@result{} (:serial :system 2)
@end lisp
@end defun
@@ -1347,7 +1351,8 @@ clients. Names on the D-Bus can be registered and
unregistered using
the following functions:
@defun dbus-register-service bus service &rest flags
-Register the known name @var{service} on D-Bus @var{bus}.
+This function registers the known name @var{service} on D-Bus
+@var{bus}.
@var{bus} is either the symbol @code{:system} or the symbol
@code{:session}.
@@ -1357,36 +1362,33 @@ must be a known name.
@var{flags} is a subset of the following keywords:
-@itemize
-@item @code{:allow-replacement}: Allow another service to become the primary
-owner if requested.
-
-@item @code{:replace-existing}: Request to replace the current primary owner.
-
-@item @code{:do-not-queue}: If we can not become the primary owner do not
-place us in the queue.
-@end itemize
+@table @code
+@item :allow-replacement
+Allow another service to become the primary owner if requested.
+@item :replace-existing
+Request to replace the current primary owner.
+@item :do-not-queue
+If we can not become the primary owner do not place us in the queue.
+@end table
One of the following keywords is returned:
-@itemize
-
-@item @code{:primary-owner}: We have become the primary owner of the name
-@var{service}.
-
-@item @code{:in-queue}: We could not become the primary owner and
-have been placed in the queue.
-
-@item @code{:exists}: We already are in the queue.
-
-@item @code{:already-owner}: We already are the primary
-owner.
-@end itemize
+@table @code
+@item :primary-owner
+We have become the primary owner of the name @var{service}.
+@item :in-queue
+We could not become the primary owner and have been placed in the
+queue.
+@item :exists
+We already are in the queue.
+@item :already-owner
+We already are the primary owner.
+@end table
@end defun
@defun dbus-unregister-service bus service
-Unregister all objects from D-Bus @var{bus}, registered by Emacs for
-@var{service}.
+This function unregisters all objects from D-Bus @var{bus}, that were
+registered by Emacs for @var{service}.
@var{bus} is either the symbol @code{:system} or the symbol
@code{:session}.
@@ -1397,24 +1399,27 @@ D-Bus.
One of the following keywords is returned:
-@itemize
-@item @code{:released}: We successfully released the name @var{service}.
-@item @code{:non-existent}: The name @var{service} does not exist on the bus.
-@item @code{:not-owner}: We are not an owner of the name @var{service}.
-@end itemize
+@table @code
+@item :released
+We successfully released the name @var{service}.
+@item :non-existent
+The name @var{service} does not exist on the bus.
+@item :not-owner
+We are not an owner of the name @var{service}.
+@end table
@end defun
-When a name has been chosen, Emacs can offer own methods, which can be
-called by other applications. These methods could be an
+When a name has been chosen, Emacs can offer its own methods, which
+can be called by other applications. These methods could be an
implementation of an interface of a well known service, like
@samp{org.freedesktop.TextEditor}.
-It could be also an implementation of an own interface. In this case,
-the service name must be @samp{org.gnu.Emacs}. The object path shall
-begin with @samp{/org/gnu/Emacs/@strong{Application}}, and the
-interface name shall be @code{org.gnu.Emacs.@strong{Application}}.
-@samp{@strong{Application}} is the name of the application which
-provides the interface.
+They could also be an implementation of its own interface. In this
+case, the service name must be @samp{org.gnu.Emacs}. The object path
+shall begin with @samp{/org/gnu/Emacs/@var{application}}, and the
+interface name shall be @code{org.gnu.Emacs.@var{application}}, where
+@var{application} is the name of the application which provides the
+interface.
@deffn Constant dbus-service-emacs
The well known service name @samp{org.gnu.Emacs} of Emacs.
@@ -1436,10 +1441,10 @@ With this function, an application registers
@var{method} on the D-Bus
@code{:session}.
@var{service} is the D-Bus service name of the D-Bus object
-@var{method} is registered for. It must be a known name (See
+@var{method} is registered for. It must be a known name (see
discussion of @var{dont-register-service} below).
-@var{path} is the D-Bus object path @var{service} is registered (See
+@var{path} is the D-Bus object path @var{service} is registered (see
discussion of @var{dont-register-service} below).
@var{interface} is the interface offered by @var{service}. It must
@@ -1456,8 +1461,8 @@ If @var{handler} wants to return just one Lisp object and
it is not a
cons cell, @var{handler} can return this object directly, instead of
returning a list containing the object.
-In case @var{handler} shall return a reply message with an empty
-argument list, @var{handler} must return the symbol @code{:ignore}.
+If @var{handler} returns a reply message with an empty argument list,
+@var{handler} must return the symbol @code{:ignore}.
When @var{dont-register-service} is non-@code{nil}, the known name
@var{service} is not registered. This means that other D-Bus clients
@@ -1468,7 +1473,7 @@ clients from discovering the still incomplete interface.
The default D-Bus timeout when waiting for a message reply is 25
seconds. This value could be even smaller, depending on the calling
-client. Therefore, @var{handler} shall not last longer than
+client. Therefore, @var{handler} should not last longer than
absolutely necessary.
@code{dbus-register-method} returns a Lisp object, which can be used
@@ -1477,18 +1482,14 @@ registration for @var{method}. Example:
@lisp
(defun my-dbus-method-handler (filename)
- (let (result)
- (if (find-file filename)
- (setq result '(:boolean t))
- (setq result '(:boolean nil)))
- result))
-
-@result{} my-dbus-method-handler
+ (if (find-file filename)
+ '(:boolean t)
+ '(:boolean nil)))
(dbus-register-method
- :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
- "org.freedesktop.TextEditor" "OpenFile"
- 'my-dbus-method-handler)
+ :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
+ "org.freedesktop.TextEditor" "OpenFile"
+ #'my-dbus-method-handler)
@result{} ((:method :session "org.freedesktop.TextEditor" "OpenFile")
("org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
@@ -1496,9 +1497,9 @@ registration for @var{method}. Example:
@end lisp
If you invoke the method @samp{org.freedesktop.TextEditor.OpenFile}
-from another D-Bus application with a filename as parameter, the file
+from another D-Bus application with a file name as parameter, the file
is opened in Emacs, and the method returns either @var{true} or
-@var{false}, indicating the success of the method. As test tool one
+@var{false}, indicating the success of the method. As a test tool one
could use the command line tool @code{dbus-send} in a shell:
@example
@@ -1522,11 +1523,9 @@ You can indicate an error by raising the Emacs signal
(find-file (car args))
(error (signal 'dbus-error (cdr err))))
t)
-
-@result{} my-dbus-method-handler
@end lisp
-The test runs then
+The test then runs
@example
# dbus-send --session --print-reply \
@@ -1550,7 +1549,7 @@ With this function, an application declares a
@var{property} on the D-Bus
@var{service} is the D-Bus service name of the D-Bus. It must be a
known name.
-@var{path} is the D-Bus object path @var{service} is registered (See
+@var{path} is the D-Bus object path @var{service} is registered (see
discussion of @var{dont-register-service} below).
@var{interface} is the name of the interface used at @var{path},
@@ -1559,7 +1558,7 @@ discussion of @var{dont-register-service} below).
@var{access} indicates, whether the property can be changed by other
services via D-Bus. It must be either the symbol @code{:read} or
@code{:readwrite}. @var{value} is the initial value of the property,
-it can be of any valid type (see @code{dbus-call-method} for details).
+it can be of any valid type (@xref{dbus-call-method}, for details).
If @var{property} already exists on @var{path}, it will be
overwritten. For properties with access type @code{:read} this is the
@@ -1584,15 +1583,15 @@ clients from discovering the still incomplete interface.
@lisp
(dbus-register-property
- :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
- "org.freedesktop.TextEditor" "name" :read "GNU Emacs")
+ :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
+ "org.freedesktop.TextEditor" "name" :read "GNU Emacs")
@result{} ((:property :session "org.freedesktop.TextEditor" "name")
("org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"))
(dbus-register-property
- :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
- "org.freedesktop.TextEditor" "version" :readwrite emacs-version t)
+ :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
+ "org.freedesktop.TextEditor" "version" :readwrite emacs-version t)
@result{} ((:property :session "org.freedesktop.TextEditor" "version")
("org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"))
@@ -1623,28 +1622,28 @@ possible via the command line tool @code{dbus-send} in
a shell:
]
@end example
-It is also possible, to apply the @code{dbus-get-property},
+It is also possible to apply the @code{dbus-get-property},
@code{dbus-get-all-properties} and @code{dbus-set-property} functions
(@pxref{Properties and Annotations}).
@lisp
(dbus-set-property
- :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
- "org.freedesktop.TextEditor" "version" "23.1.50")
+ :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
+ "org.freedesktop.TextEditor" "version" "23.1.50")
@result{} "23.1.50"
(dbus-get-property
- :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
- "org.freedesktop.TextEditor" "version")
+ :session "org.freedesktop.TextEditor" "/org/freedesktop/TextEditor"
+ "org.freedesktop.TextEditor" "version")
@result{} "23.1.50"
@end lisp
@end defun
@defun dbus-unregister-object object
-Unregister @var{object} from the D-Bus. @var{object} must be the
-result of a preceding @code{dbus-register-method},
+This function unregisters @var{object} from the D-Bus. @var{object}
+must be the result of a preceding @code{dbus-register-method},
@code{dbus-register-property} or @code{dbus-register-signal} call
(@pxref{Signals}). It returns @code{t} if @var{object} has been
unregistered, @code{nil} otherwise.
@@ -1672,22 +1671,22 @@ doesn't matter whether another object has registered
for @var{signal}.
Signals can be unicast or broadcast messages. For broadcast messages,
@var{service} must be @code{nil}. Otherwise, @var{service} is the
-D-Bus service name the signal is sent to as unicast
+D-Bus service name the signal is sent to as a unicast
message.@footnote{For backward compatibility, a broadcast message is
also emitted if @var{service} is the known or unique name Emacs is
registered at D-Bus @var{bus}.} @var{path} is the D-Bus object path
@var{signal} is sent from. @var{interface} is an interface available
at @var{path}. It must provide @var{signal}.
-All other arguments args are passed to @var{signal} as arguments.
-They are converted into D-Bus types as described in @ref{Type
-Conversion}. Example:
+The remaining arguments @var{args} are passed to @var{signal} as
+arguments. They are converted into D-Bus types as described in
+@ref{Type Conversion}. Example:
@lisp
(dbus-send-signal
- :session nil dbus-path-emacs
- (concat dbus-interface-emacs ".FileManager") "FileModified"
- "/home/albinus/.emacs")
+ :session nil dbus-path-emacs
+ (concat dbus-interface-emacs ".FileManager") "FileModified"
+ "/home/albinus/.emacs")
@end lisp
@end defun
@@ -1702,11 +1701,11 @@ With this function, an application registers for a
signal on the D-Bus
object. It can be either a known name or the unique name of the D-Bus
object sending the signal. A known name will be mapped onto the
unique name of the object, owning @var{service} at registration time.
-When the corresponding D-Bus object disappears, signals won't be
-received any longer.
+When the corresponding D-Bus object disappears, signals will no longer
+be received.
-@var{path} is the corresponding D-Bus object path, @var{service} is
-registered at. @var{interface} is an interface offered by
+@var{path} is the corresponding D-Bus object path that @var{service}
+is registered at. @var{interface} is an interface offered by
@var{service}. It must provide @var{signal}.
@var{service}, @var{path}, @var{interface} and @var{signal} can be
@@ -1721,30 +1720,31 @@ The remaining arguments @var{args} can be keywords or
keyword string
pairs.@footnote{For backward compatibility, the arguments @var{args}
can also be just strings. They stand for the respective arguments of
@var{signal} in their order, and are used for filtering as well. A
-@code{nil} argument might be used to preserve the order.} The meaning
-is as follows:
-
-@itemize
-@item @code{:argN} @var{string}:@*
-@code{:pathN} @var{string}:@*
-This stands for the Nth argument of the signal. @code{:pathN}
-arguments can be used for object path wildcard matches as specified by
-D-Bus, while an @code{:argN} argument requires an exact match.
-
-@item @code{:arg-namespace} @var{string}:@*
-Register for the signals, which first argument defines the service or
-interface namespace @var{string}.
-
-@item @code{:path-namespace} @var{string}:@*
+@code{nil} argument might be used to preserve the order.} Their
+meaning is as follows:
+
+@table @code
+@item :arg@var{n} @var{string}
+@item :path@var{n} @var{string}
+This stands for the @var{n}th argument of the signal.
+@code{:path@var{n}} arguments can be used for object path wildcard
+matches as specified by D-Bus, while an @code{:argN} argument requires
+an exact match.
+
+@item :arg-namespace @var{string}
+Register for those signals, whose first argument names a service or
+interface within the namespace @var{string}.
+
+@item :path-namespace @var{string}
Register for the object path namespace @var{string}. All signals sent
from an object path, which has @var{string} as the preceding string,
are matched. This requires @var{path} to be @code{nil}.
-@item @code{:eavesdrop}:@*
+@item :eavesdrop
Register for unicast signals which are not directed to the D-Bus
object Emacs is registered at D-Bus BUS, if the security policy of BUS
allows this. Otherwise, this argument is ignored.
-@end itemize
+@end table
@code{dbus-register-signal} returns a Lisp object, which can be used
as argument in @code{dbus-unregister-object} for removing the
@@ -1754,12 +1754,10 @@ registration for @var{signal}. Example:
(defun my-dbus-signal-handler (device)
(message "Device %s added" device))
-@result{} my-dbus-signal-handler
-
(dbus-register-signal
- :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
- "org.freedesktop.Hal.Manager" "DeviceAdded"
- 'my-dbus-signal-handler)
+ :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
+ "org.freedesktop.Hal.Manager" "DeviceAdded"
+ #'my-dbus-signal-handler)
@result{} ((:signal :system "org.freedesktop.Hal.Manager" "DeviceAdded")
("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
@@ -1769,8 +1767,8 @@ registration for @var{signal}. Example:
As we know from the introspection data of interface
@samp{org.freedesktop.Hal.Manager}, the signal @samp{DeviceAdded}
provides one single parameter, which is mapped into a Lisp string.
-The callback function @code{my-dbus-signal-handler} must define one
-single string argument therefore. Plugging an USB device to your
+The callback function @code{my-dbus-signal-handler} must therefore
+define a single string argument. Plugging a USB device into your
machine, when registered for signal @samp{DeviceAdded}, will show you
which objects the GNU/Linux @code{hal} daemon adds.
@@ -1781,7 +1779,7 @@ for a dummy signal, and check the result:
@lisp
(dbus-ignore-errors
(dbus-register-signal
- :system nil nil nil nil 'ignore :path-namespace "/invalid/path"))
+ :system nil nil nil nil #'ignore :path-namespace "/invalid/path"))
@result{} nil
@end lisp
@@ -1796,14 +1794,14 @@ for a dummy signal, and check the result:
Until now, we have spoken about the system and the session buses,
which are the default buses to be connected to. However, it is
-possible to connect to any bus, from which the address is known. This
-is a UNIX domain or TCP/IP socket. Everywhere, where a @var{bus} is
-mentioned as argument of a function (the symbol @code{:system} or the
-symbol @code{:session}), this address can be used instead. The
-connection to this bus must be initialized first.
+possible to connect to any bus with a known address. This is a UNIX
+domain or TCP/IP socket. Everywhere, where a @var{bus} is mentioned
+as argument of a function (the symbol @code{:system} or the symbol
+@code{:session}), this address can be used instead. The connection to
+this bus must be initialized first.
@defun dbus-init-bus bus &optional private
-Establish the connection to D-Bus @var{bus}.
+This function establishes the connection to D-Bus @var{bus}.
@var{bus} can be either the symbol @code{:system} or the symbol
@code{:session}, or it can be a string denoting the address of the
@@ -1811,12 +1809,12 @@ corresponding bus. For the system and session buses,
this function
is called when loading @file{dbus.el}, there is no need to call it
again.
-The function returns a number, which counts the connections this Emacs
-session has established to the @var{bus} under the same unique name
-(see @code{dbus-get-unique-name}). It depends on the libraries Emacs
-is linked with, and on the environment Emacs is running. For example,
-if Emacs is linked with the GTK+ toolkit, and it runs in a GTK+-aware
-environment like Gnome, another connection might already be
+The function returns the number of connections this Emacs session has
+established to the @var{bus} under the same unique name
+(@pxref{dbus-get-unique-name}). It depends on the libraries Emacs is
+linked with, and on the environment Emacs is running. For example, if
+Emacs is linked with the GTK+ toolkit, and it runs in a GTK+-aware
+environment like GNOME, another connection might already be
established.
When @var{private} is non-@code{nil}, a new connection is established
@@ -1831,9 +1829,9 @@ Example: You initialize a connection to the AT-SPI bus on
your host:
@lisp
(setq my-bus
- (dbus-call-method
- :session "org.a11y.Bus" "/org/a11y/bus"
- "org.a11y.Bus" "GetAddress"))
+ (dbus-call-method
+ :session "org.a11y.Bus" "/org/a11y/bus"
+ "org.a11y.Bus" "GetAddress"))
@result{}
"unix:abstract=/tmp/dbus-2yzWHOCdSD,guid=a490dd26625870ca1298b6e10000fd7f"
@@ -1848,7 +1846,7 @@ Example: You initialize a connection to the AT-SPI bus on
your host:
@result{} ":1.19"
-;; Open a new connection to the same bus. This obsoletes the
+;; Open a new connection to the same bus. This supersedes the
;; previous one.
(dbus-init-bus my-bus 'private)
@@ -1859,14 +1857,14 @@ Example: You initialize a connection to the AT-SPI bus
on your host:
@result{} ":1.20"
@end lisp
-D-Bus addresses can specify different transport. A possible address
-could be based on TCP/IP sockets, see next example. However, it
-depends on the bus daemon configuration, which transport is supported.
+D-Bus addresses can specify a different transport. A possible address
+could be based on TCP/IP sockets, see next example. Which transport
+is supported depends on the bus daemon configuration, however.
@end defun
@defun dbus-setenv bus variable value
-Set the value of the @var{bus} environment variable @var{variable} to
-@var{value}.
+This function sets the value of the @var{bus} environment
+@var{variable} to @var{value}.
@var{bus} is either a Lisp symbol, @code{:system} or @code{:session},
or a string denoting the bus address. Both @var{variable} and
@@ -1877,7 +1875,7 @@ function adds to or modifies that environment when
activating services.
Some bus instances, such as @code{:system}, may disable setting the
environment. In such cases, or if this feature is not available in
-older D-Bus versions, a @code{dbus-error} error is raised.
+older D-Bus versions, this function signals a @code{dbus-error}.
As an example, it might be desirable to start X11 enabled services on
a remote host's bus on the same X11 server the local Emacs is
@@ -1916,7 +1914,7 @@ Input parameters of @code{dbus-call-method},
@code{dbus-register-method}, @code{dbus-register-property} and
@code{dbus-register-signal} are checked for correct D-Bus types. If
there is a type mismatch, the Lisp error @code{wrong-type-argument}
-@code{D-Bus ARG} is raised.
+@code{D-Bus @var{arg}} is raised.
All errors raised by D-Bus are signaled with the error symbol
@code{dbus-error}. If possible, error messages from D-Bus are
@@ -1967,35 +1965,39 @@ There exist convenience functions which could be called
inside a
callback function in order to retrieve the information from the event.
@defun dbus-event-bus-name event
-Returns the bus name @var{event} is coming from.
-The result is either the symbol @code{:system} or the symbol @code{:session}.
+This function returns the bus name @var{event} is coming from. The
+result is either the symbol @code{:system} or the symbol
+@code{:session}.
@end defun
@defun dbus-event-message-type event
-Returns the message type of the corresponding D-Bus message. The
-result is a natural number.
+This function returns the message type of the corresponding D-Bus
+message. The result is a natural number.
@end defun
@defun dbus-event-serial-number event
-Returns the serial number of the corresponding D-Bus message.
-The result is a natural number.
+This function returns the serial number of the corresponding D-Bus
+message. The result is a natural number.
@end defun
@defun dbus-event-service-name event
-Returns the unique name of the D-Bus object @var{event} is coming from.
+This function returns the unique name of the D-Bus object @var{event}
+is coming from.
@end defun
@defun dbus-event-path-name event
-Returns the object path of the D-Bus object @var{event} is coming from.
+This function returns the object path of the D-Bus object @var{event}
+is coming from.
@end defun
@defun dbus-event-interface-name event
-Returns the interface name of the D-Bus object @var{event} is coming from.
+This function returns the interface name of the D-Bus object
+@var{event} is coming from.
@end defun
@defun dbus-event-member-name event
-Returns the member name of the D-Bus object @var{event} is coming
-from. It is either a signal name or a method name.
+This function returns the member name of the D-Bus object @var{event}
+is coming from. It is either a signal name or a method name.
@end defun
D-Bus errors are not propagated during event handling, because it is
@@ -2009,7 +2011,7 @@ D-Bus error happens in the event handler. Every function
must accept
two arguments, the event and the error variable caught in
@code{condition-case} by @code{dbus-error}.
-Such functions can be used the adapt the error signal to be raised.
+Such functions can be used to adapt the error signal to be raised.
Example:
@lisp
@@ -2019,12 +2021,12 @@ Example:
(message "my-dbus-event-error-handler: %S %S" event error)
(signal 'file-error (cdr error))))
-(add-hook 'dbus-event-error-functions 'my-dbus-event-error-handler)
+(add-hook 'dbus-event-error-functions #'my-dbus-event-error-handler)
@end lisp
@end defvar
-Hook functions shall take into account, that there might be other
-D-Bus applications running. Therefore, they shall check carefully,
+Hook functions should take into account that there might be other
+D-Bus applications running. They should therefore check carefully,
whether a given D-Bus error is related to them.
diff --git a/doc/misc/efaq-w32.texi b/doc/misc/efaq-w32.texi
index 83dd176..bbfc86b 100644
--- a/doc/misc/efaq-w32.texi
+++ b/doc/misc/efaq-w32.texi
@@ -143,7 +143,7 @@ executable, using the MinGW GCC compiler and development
tools.
@cindex DOS port
@cindex Windows 3.11 port
-Emacs can also be compiled for MSDOS. When run on recent MS Windows,
+Emacs can also be compiled for MSDOS@. When run on recent MS Windows,
it supports long file names, and uses the Windows clipboard.
See the @file{msdos} directory in the Emacs sources for building
instructions (requires DJGPP).
@@ -222,7 +222,7 @@ specific notes about debugging Emacs.
@cindex debugging Emacs with GDB
GDB is the GNU debugger, which can be used to debug Emacs when it has
-been compiled with MinGW GCC. The best results will be obtained if
+been compiled with MinGW GCC@. The best results will be obtained if
you start gdb from the @file{src} directory as @kbd{gdb ./emacs.exe}.
This will load the init file @file{.gdbinit}@footnote{
Latest versions of GDB might refuse to load the init file for security
@@ -592,7 +592,7 @@ Subject: Re: Re[2]: problem with caps/ctrl swap on NT 4.0
@end ignore
@smallexample
It's a binary value that lets you map keystrokes in the low-level keyboard
-drivers in NT. As a result you don't have to worry about applications
+drivers in NT@. As a result you don't have to worry about applications
bypassing mappings that you've done at a higher level (i.e., it just works).
Here's the format of the value:
@@ -1187,7 +1187,7 @@ A lot of effort has gone into making it easier to print
from Emacs on
MS Windows, but this has still been insufficient to keep up with
changes in printing technology from text and postscript based printers
connected via ports that can be accessed directly, to graphical
-printers that are only accessible via USB. For details, see
+printers that are only accessible via USB@. For details, see
@uref{http://www.emacswiki.org/emacs/PrintingFromEmacs, Emacs
Wiki}, @uref{http://www.emacswiki.org/emacs/PrintWithWebBrowser}, and
@uref{http://www.emacswiki.org/emacs/PrintFromWindowsExplorer}.
@@ -1398,7 +1398,7 @@ default shell in Emacs, you can place the following in
your init file:
@end example
WARNING: Some versions of bash set and use the environment variable
-PID. For some as yet unknown reason, if @env{PID} is set and Emacs
+PID@. For some as yet unknown reason, if @env{PID} is set and Emacs
passes it on to bash subshells, bash dies (Emacs can inherit the
@env{PID} variable if it's started from a bash shell). If you clear
the @env{PID} variable in your init file, you should be able to
@@ -1890,9 +1890,9 @@ need to use.
@node MSVC
@section How do I use Emacs with Microsoft Visual C++
-There are two ways you can use Emacs in conjunction with MSVC. You
+There are two ways you can use Emacs in conjunction with MSVC@. You
can use Emacs as the editor, and do everything else in the DevStudio
-IDE. Or you can use Emacs as an IDE, calling the MSVC command line
+IDE@. Or you can use Emacs as an IDE, calling the MSVC command line
tools to build your project.
@menu
diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi
index be1ffc0..8f7ed71 100644
--- a/doc/misc/efaq.texi
+++ b/doc/misc/efaq.texi
@@ -1125,7 +1125,7 @@ scanning of @code{#define}d symbols.
@cindex xref
@item
-New package Xref replaces Etags's front-end and UI. Xref provides a
+New package Xref replaces Etags's front-end and UI@. Xref provides a
generic framework and new commands to find and move to definitions of
functions, macros, data structures etc., as well as go back to the
location where you were before moving to a definition. It supersedes
@@ -1595,6 +1595,10 @@ xterm-direct2 xterm with direct-color indexing (old)
xterm-direct xterm with direct-color indexing
@end example
+If Terminfo database is not available, but 24-bit direct color mode is
+supported, it can still be enabled by defining the environment
+variable @env{COLORTERM} to @samp{truecolor}.
+
Terminals with @samp{RGB} capability treat pixels #000001 - #000007 as
indexed colors to maintain backward compatibility with applications
that are unaware of direct color mode. Therefore the seven darkest
@@ -3463,16 +3467,25 @@ see @ref{Packages that do not come with Emacs}.
@cindex Emacs Lisp List
@cindex Emacs Lisp Archive
-We distribute many packages that extend Emacs, in the
-@uref{https://elpa.gnu.org, GNU ELPA} (``Emacs Lisp Package
-Archive''). The command @kbd{M-x list-packages} contacts the GNU ELPA
-server and fetches the list of packages that it distributes. These
-GNU packages are designed for use with Emacs, but we distribute them
-separately from Emacs itself, for reasons of space, and convenience of
-development. You can browse the resulting @file{*Packages*} buffer to
-see what is available, and then Emacs can automatically download and
-install the packages that you select. @xref{Packages,,, emacs, The
-GNU Emacs Manual}.
+The easiest way to add more features to your Emacs is to use the
+command @kbd{M-x list-packages}. This contacts the
+@uref{https://elpa.gnu.org, GNU ELPA} (``Emacs Lisp Package Archive'')
+server and fetches the list of additional packages that it offers.
+These are GNU packages that are available for use with Emacs, but are
+distributed separately from Emacs itself, for reasons of space, etc.
+You can browse the resulting @file{*Packages*} buffer to see what is
+available, and then Emacs can automatically download and install the
+packages that you select. @xref{Packages,,, emacs, The GNU Emacs Manual}.
+
+There are other, non-GNU, Emacs Lisp package servers, including:
+@uref{https://melpa.org, MELPA}; and
+@uref{https://marmalade-repo.org, Marmalade}. To use additional
+package servers, customize the @code{package-archives} variable. Be
+aware that installing a package can run arbitrary code, so only add
+sources that you trust. Also, packages hosted on non-GNU package
+servers may encourage or require you to install and use non-free
+software; for example, MELPA is known to host some packages that do
+this.
The @uref{https://lists.gnu.org/mailman/listinfo/gnu-emacs-sources,
GNU Emacs sources mailing list}, which is gatewayed to the
diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi
index c3e6917..bb13ebd 100644
--- a/doc/misc/emacs-gnutls.texi
+++ b/doc/misc/emacs-gnutls.texi
@@ -134,7 +134,7 @@ order: @file{/etc/ssl/certs/ca-certificates.crt} for
Debian, Ubuntu,
Gentoo and Arch Linux; @file{/etc/pki/tls/certs/ca-bundle.crt} for
Fedora and RHEL; @file{/etc/ssl/ca-bundle.pem} for Suse;
@file{/usr/ssl/certs/ca-bundle.crt} for Cygwin;
-@file{/usr/local/share/certs/ca-root-nss.crt} for FreeBSD. You can
+@file{/usr/local/share/certs/ca-root-nss.crt} for FreeBSD@. You can
easily customize @code{gnutls-trustfiles} to be something else, but
let us know if you do, so we can make the change to benefit the other
users of that platform.
diff --git a/doc/misc/gnus-faq.texi b/doc/misc/gnus-faq.texi
index fd28539..9c1d2d0 100644
--- a/doc/misc/gnus-faq.texi
+++ b/doc/misc/gnus-faq.texi
@@ -689,8 +689,9 @@ retrieves via POP3?
@subsubheading Answer
Yes, if the POP3 server supports the UIDL control (maybe almost servers
-do it nowadays). To do that, add a @code{:leave VALUE} pair to each
-POP3 mail source. @xref{Mail Source Specifiers}, for details on VALUE.
+do it nowadays). To do that, add a @code{:leave @var{value}} pair to
+each POP3 mail source. @xref{Mail Source Specifiers}, for details on
+@var{value}.
@node FAQ 4 - Reading messages
@subsection Reading messages
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index f9527ee..bdd31b1 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -1116,7 +1116,7 @@ is used.
The choice between EasyPG and OpenSSL is controlled by the variable
@code{mml-smime-use}, which needs to be set to the value @code{epg}
-for EasyPG. Depending on your version of Emacs that value may be the
+for EasyPG@. Depending on your version of Emacs that value may be the
default; if not, you can either customize that variable or place the
following line in your @file{.emacs} file (that line needs to be
placed above other code related to message/gnus/encryption):
@@ -1232,7 +1232,7 @@ decryption/sign operation. @xref{Agent Options, , ,
gnupg, Using the
GNU Privacy Guard}.
How to use @command{gpg-agent} in Emacs depends on your version of
-GnuPG. With GnuPG version 2.1, @command{gpg-agent} is started
+GnuPG@. With GnuPG version 2.1, @command{gpg-agent} is started
automatically if necessary. With older versions you may need to run
the following command from the shell before starting Emacs.
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 176d3a5..feead3d 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -1185,9 +1185,6 @@ for accessing the system storage, you shall prefer this.
@ref{GVFS-based methods} for example, methods @option{gdrive} and
@option{nextcloud}.
-@strong{Note}: The @option{rclone} method is experimental, don't use
-it in production systems!
-
@end table
@@ -1732,6 +1729,7 @@ Convenience method to access vagrant boxes. It is often
used in
multi-hop file names like
@file{@value{prefix}vagrant@value{postfixhop}box|sudo@value{postfixhop}box@value{postfix}/path/to/file},
where @samp{box} is the name of the vagrant box.
+
@end table
@@ -2048,6 +2046,12 @@ reestablished. A value of @code{nil} disables this
feature. Most of
the methods do not set this property except the @option{sudo} and
@option{doas} methods, which use predefined values.
+@item @t{"tmpdir"}
+
+The temporary directory on the remote host. If not specified, the
+default value is @t{"/data/local/tmp"} for the @option{adb} method,
+@t{"/C$/Temp"} for the @option{smb} method, and @t{"/tmp"} otherwise.
+
@item @t{"posix"}
Connections using the @option{smb} method check, whether the remote
@@ -2655,6 +2659,9 @@ to direct all auto saves to that location.
@section Protect remote files by encryption
@cindex Encrypt remote directories
+@strong{Note}: File encryption in @value{tramp} is experimental, don't
+use it in production systems!
+
Sometimes, it is desirable to protect files located on remote
directories, like cloud storages. In order to do this, you might
instruct @value{tramp} to encrypt all files copied to a given remote
diff --git a/etc/NEWS b/etc/NEWS
index b0c5236..5a46e71 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -61,6 +61,12 @@ It was declared obsolete in Emacs 27.1.
* Startup Changes in Emacs 28.1
+** Emacs can support 24-bit color TTY without terminfo database.
+If your text-mode terminal supports 24-bit true color, but your system
+lacks the terminfo database, you can instruct Emacs to support 24-bit
+true color by setting COLORTERM=truecolor in the environment. This is
+useful on systems such as FreeBSD which ships only with 'etc/termcap'.
+
* Changes in Emacs 28.1
@@ -140,6 +146,7 @@ displayed and which are kept hidden.
** Emacs Lisp mode
*** The mode-line now indicates whether we're using lexical or dynamic scoping.
+
*** A space between an open paren and a symbol changes the indentation rule.
The presence of a space between an open paren and a symbol now is
taken as a statement by the programmer that this should be indented
@@ -230,6 +237,12 @@ changes.
*** New connection method "media", which allows accessing media devices
like cell phones, tablets or cameras.
++++
+*** New command 'tramp-crypt-add-directory'.
+This command marks a remote directory to contain only encrypted files.
+See the "(tramp) Keeping files encrypted" node of the Tramp manual for
+details. This feature is experimental.
+
** Tempo
---
@@ -420,9 +433,9 @@ information, see the related entry about 'shr-browse-url'
above.
all commands that prompt for a project directory.
+++
-*** New commands 'project-dired', 'project-vc-dir', 'project-shell',
'project-eshell'.
-These commands run Dired/VC-Dir and Shell/Eshell in a project's root directory,
-respectively.
+*** New commands 'project-dired', 'project-vc-dir', 'project-shell',
+'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in
+a project's root directory, respectively.
*** New command 'project-compile', which runs compilation.
@@ -449,7 +462,25 @@ Previously 'xml-print' would produce invalid XML when
given a string
with characters that are not valid in XML (see
https://www.w3.org/TR/xml/#charsets). Now it rejects such strings.
-** The metamail.el library is now marked obsolete.
+** Battery
+
+---
+*** UPower is now the default battery status backend when available.
+UPower support via the function 'battery-upower' was added in Emacs
+26.1, but was disabled by default. It is now the default value of
+'battery-status-function' when the system provides a UPower D-Bus
+service. The user options 'battery-upower-device' and
+'battery-upower-subscribe' control which power sources to query and
+whether to respond to status change notifications in addition to
+polling, respectively.
+
+---
+*** A richer syntax can be used to format battery status information.
+The user options 'battery-mode-line-format' and
+'battery-echo-area-format' now support the full formatting syntax of
+the function 'format-spec' documented under node "(elisp) Custom Format
+Strings". The new syntax includes specifiers for padding and
+truncation, amongst other things.
* New Modes and Packages in Emacs 28.1
@@ -506,6 +537,16 @@ This is no longer supported, and setting this variable has
no effect.
** The macro 'with-displayed-buffer-window' is now obsolete.
Use macro 'with-current-buffer-window' with action alist entry 'body-function'.
+** The metamail.el library is now marked obsolete.
+
+---
+** Some obsolete variable and function aliases in dbus.el have been removed.
+In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to
+'dbus-event-error-functions' and the function
+'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'.
+The old names, which were kept as obsolete aliases of the new names,
+have now been removed.
+
---
** Some libraries obsolete since Emacs 23 have been removed:
'ledit.el', 'lmenu.el', 'lucid.el and 'old-whitespace.el'.
@@ -568,6 +609,13 @@ for encoding and decoding without having to bind
It controls, whether 'process-file' returns a string when a remote
process is interrupted by a signal.
++++
+** The behavior of 'format-spec' is now closer to that of 'format'.
+In order for the two functions to behave more consistently,
+'format-spec' now pads and truncates based on string width rather than
+length, and also supports format specifications that include a
+truncating precision field, such as '%.2a'.
+
* Changes in Emacs 28.1 on Non-Free Operating Systems
diff --git a/etc/NEWS.27 b/etc/NEWS.27
index 58bd491..10a6e39 100644
--- a/etc/NEWS.27
+++ b/etc/NEWS.27
@@ -956,8 +956,8 @@ displays the buffer from the next command in that window.
For example,
'S-M-right C-h i' displays the "*Info*" buffer in the right window,
creating the window if necessary. A special key can be customized to
display the buffer in the same window, for example, 'S-M-0 C-h e'
-displays the "*Messages*" buffer in the same window. 'S-M-t C-h C-n'
-displays NEWS in a new tab.
+displays the "*Messages*" buffer in the same window. 'S-M-t C-h r'
+displays the Emacs manual in a new tab.
+++
*** Windmove also supports directional window deletion.
diff --git a/lisp/battery.el b/lisp/battery.el
index b8855a8..e568ab5 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -23,18 +23,18 @@
;;; Commentary:
-;; There is at present support for GNU/Linux, macOS, and Windows.
+;; There is at present support for GNU/Linux, BSD, macOS, and Windows.
;; This library supports:
;; - UPower (https://upower.freedesktop.org) via D-Bus API.
-;; - the `/sys/class/power_supply/' files of Linux >= 2.6.39.
-;; - the `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6.
-;; - the `/proc/apm' file format of Linux version 1.3.58 or newer.
+;; - The `/sys/class/power_supply/' files of Linux >= 2.6.39.
+;; - The `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6.
+;; - The `/proc/apm' file format of Linux version 1.3.58 or newer.
+;; - BSD by using the `apm' program.
;; - Darwin (macOS) by using the `pmset' program.
;; - Windows via the GetSystemPowerStatus API call.
;;; Code:
-(require 'timer)
(require 'dbus)
(eval-when-compile (require 'cl-lib))
@@ -44,53 +44,74 @@
:group 'hardware)
(defcustom battery-upower-device nil
- "UPower device of the `:battery' type.
-Use `battery-upower-device-list' to list all available UPower devices.
-If set to nil, then autodetect `:battery' device."
+ "Preferred UPower device name(s).
+When `battery-status-function' is set to `battery-upower', this
+user option specifies which power sources to query for status
+information and merge into a single report.
+
+When nil (the default), `battery-upower' queries all present
+battery and line power devices as determined by the UPower
+EnumerateDevices method. A string or a nonempty list of strings
+names particular devices to query instead. UPower battery and
+line power device names typically follow the patterns
+\"battery_BATN\" and \"line_power_ACN\", respectively, with N
+starting at 0 when present. Device names should not include the
+leading D-Bus path \"/org/freedesktop/UPower/devices/\"."
:version "28.1"
- :type '(choice string (const :tag "Autodetect" nil)))
-
-(defcustom battery-upower-line-power-device nil
- "UPower device of the `:line-power' type.
-Use `battery-upower-device-list' to list all available UPower devices.
-If set to nil, then autodetect `:battery' device."
+ :type '(choice (const :tag "Autodetect all devices" nil)
+ (string :tag "Device")
+ (repeat :tag "Devices" string)))
+
+(defcustom battery-upower-subscribe t
+ "Whether to subscribe to UPower device change signals.
+When nil, battery status information is polled every
+`battery-update-interval' seconds. When non-nil (the default),
+the battery status is also updated whenever a power source is
+added or removed, or when the system starts or stops running on
+battery power.
+
+This only takes effect when `battery-status-function' is set to
+`battery-upower' before enabling `display-battery-mode'."
:version "28.1"
- :type '(choice string (const :tag "Autodetect" nil)))
+ :type 'boolean)
+
+(defconst battery-upower-service "org.freedesktop.UPower"
+ "Well-known name of the UPower D-Bus service.
+See URL `https://upower.freedesktop.org/docs/ref-dbus.html'.")
-(defconst battery-upower-dbus-service "org.freedesktop.UPower"
- "Well-known UPower service name for the D-Bus system.")
+(defun battery--files (dir)
+ "Return a list of absolute file names in DIR or nil on error.
+Value does not include \".\" or \"..\"."
+ (ignore-errors (directory-files dir t directory-files-no-dot-files-regexp)))
(defun battery--find-linux-sysfs-batteries ()
- (let ((dirs nil))
- (dolist (file (directory-files "/sys/class/power_supply/" t))
- (when (and (or (file-directory-p file)
- (file-symlink-p file))
- (file-exists-p (expand-file-name "capacity" file)))
- (push file dirs)))
+ "Return a list of all sysfs battery directories."
+ (let (dirs)
+ (dolist (dir (battery--files "/sys/class/power_supply/"))
+ (when (file-exists-p (expand-file-name "capacity" dir))
+ (push dir dirs)))
(nreverse dirs)))
(defcustom battery-status-function
- (cond ((dbus-ping :system battery-upower-dbus-service)
+ (cond ((member battery-upower-service (dbus-list-activatable-names))
#'battery-upower)
((and (eq system-type 'gnu/linux)
- (file-readable-p "/proc/apm"))
- #'battery-linux-proc-apm)
+ (battery--find-linux-sysfs-batteries))
+ #'battery-linux-sysfs)
((and (eq system-type 'gnu/linux)
(file-directory-p "/proc/acpi/battery"))
#'battery-linux-proc-acpi)
((and (eq system-type 'gnu/linux)
- (file-directory-p "/sys/class/power_supply/")
- (battery--find-linux-sysfs-batteries))
- #'battery-linux-sysfs)
+ (file-readable-p "/proc/apm"))
+ #'battery-linux-proc-apm)
((and (eq system-type 'berkeley-unix)
(file-executable-p "/usr/sbin/apm"))
#'battery-bsd-apm)
((and (eq system-type 'darwin)
- (condition-case nil
- (with-temp-buffer
- (and (eq (call-process "pmset" nil t nil "-g" "ps") 0)
- (> (buffer-size) 0)))
- (error nil)))
+ (ignore-errors
+ (with-temp-buffer
+ (and (eq (call-process "pmset" nil t nil "-g" "ps") 0)
+ (not (bobp))))))
#'battery-pmset)
((fboundp 'w32-battery-status)
#'w32-battery-status))
@@ -102,6 +123,7 @@ Its cons cells are of the form
CONVERSION is the character code of a \"conversion specification\"
introduced by a `%' character in a control string."
+ :version "28.1"
:type '(choice (const nil) function))
(defcustom battery-echo-area-format
@@ -113,15 +135,19 @@ string are substituted as defined by the current value of
the variable
`battery-status-function'. Here are the ones generally available:
%c Current capacity (mAh or mWh)
%r Current rate of charge or discharge
+%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status: empty means high, `-' means low,
`!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
-%L AC line status (verbose)
%p Battery load percentage
+%s Remaining time (to charge or discharge) in seconds
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
-%t Remaining time (to charge or discharge) in the form `h:min'"
+%t Remaining time (to charge or discharge) in the form `h:min'
+
+The full `format-spec' formatting syntax is supported."
+ :link '(info-link "(elisp) Custom Format Strings")
:type '(choice string (const nil)))
(defvar battery-mode-line-string nil
@@ -134,7 +160,7 @@ string are substituted as defined by the current value of
the variable
:type 'integer)
(defcustom battery-mode-line-format
- (cond ((eq battery-status-function 'battery-linux-proc-acpi)
+ (cond ((eq battery-status-function #'battery-linux-proc-acpi)
"[%b%p%%,%d°C]")
(battery-status-function
"[%b%p%%]"))
@@ -145,15 +171,19 @@ string are substituted as defined by the current value of
the variable
`battery-status-function'. Here are the ones generally available:
%c Current capacity (mAh or mWh)
%r Current rate of charge or discharge
+%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status: empty means high, `-' means low,
`!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
-%L AC line status (verbose)
%p Battery load percentage
+%s Remaining time (to charge or discharge) in seconds
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
-%t Remaining time (to charge or discharge) in the form `h:min'"
+%t Remaining time (to charge or discharge) in the form `h:min'
+
+The full `format-spec' formatting syntax is supported."
+ :link '(info-link "(elisp) Custom Format Strings")
:type '(choice string (const nil)))
(defcustom battery-update-interval 60
@@ -170,6 +200,18 @@ A battery load percentage below this number is considered
low."
A battery load percentage below this number is considered critical."
:type 'integer)
+(defface battery-load-low
+ '((t :inherit warning))
+ "Face used in mode line string when battery load is low.
+See the option `battery-load-low'."
+ :version "28.1")
+
+(defface battery-load-critical
+ '((t :inherit error))
+ "Face used in mode line string when battery load is critical.
+See the option `battery-load-critical'."
+ :version "28.1")
+
(defvar battery-update-timer nil
"Interval timer object.")
@@ -196,13 +238,17 @@ seconds."
(setq battery-mode-line-string "")
(or global-mode-string (setq global-mode-string '("")))
(and battery-update-timer (cancel-timer battery-update-timer))
+ (battery--upower-unsubscribe)
(if (and battery-status-function battery-mode-line-format)
(if (not display-battery-mode)
(setq global-mode-string
(delq 'battery-mode-line-string global-mode-string))
(add-to-list 'global-mode-string 'battery-mode-line-string t)
+ (and (eq battery-status-function #'battery-upower)
+ battery-upower-subscribe
+ (battery--upower-subsribe))
(setq battery-update-timer (run-at-time nil battery-update-interval
- 'battery-update-handler))
+ #'battery-update-handler))
(battery-update))
(message "Battery status not available")
(setq display-battery-mode nil)))
@@ -214,34 +260,42 @@ seconds."
(defun battery-update ()
"Update battery status information in the mode line."
(let* ((data (and battery-status-function (funcall battery-status-function)))
- (percentage (car (read-from-string (cdr (assq ?p data))))))
- (setq battery-mode-line-string
- (propertize (if (and battery-mode-line-format
- (numberp percentage)
- (<= percentage battery-mode-line-limit))
- (battery-format battery-mode-line-format data)
- "")
- 'face
- (and (numberp percentage)
- (<= percentage battery-load-critical)
- 'error)
- 'help-echo "Battery status information")))
- (force-mode-line-update))
+ (percentage (car (read-from-string (cdr (assq ?p data)))))
+ (res (and battery-mode-line-format
+ (or (not (numberp percentage))
+ (<= percentage battery-mode-line-limit))
+ (battery-format battery-mode-line-format data)))
+ (len (length res)))
+ (unless (zerop len)
+ (cond ((not (numberp percentage)))
+ ((< percentage battery-load-critical)
+ (add-face-text-property 0 len 'battery-load-critical t res))
+ ((< percentage battery-load-low)
+ (add-face-text-property 0 len 'battery-load-low t res)))
+ (put-text-property 0 len 'help-echo "Battery status information" res))
+ (setq battery-mode-line-string (or res "")))
+ (force-mode-line-update t))
+
;;; `/proc/apm' interface for Linux.
-(defconst battery-linux-proc-apm-regexp
- (concat "^\\([^ ]+\\)" ; Driver version.
- " \\([^ ]+\\)" ; APM BIOS version.
- " 0x\\([0-9a-f]+\\)" ; APM BIOS flags.
- " 0x\\([0-9a-f]+\\)" ; AC line status.
- " 0x\\([0-9a-f]+\\)" ; Battery status.
- " 0x\\([0-9a-f]+\\)" ; Battery flags.
- " \\(-?[0-9]+\\)%" ; Load percentage.
- " \\(-?[0-9]+\\)" ; Remaining time.
- " \\(.*\\)" ; Time unit.
- "$")
+;; Regular expression matching contents of `/proc/apm'.
+(rx-define battery--linux-proc-apm
+ (: bol (group (+ (not ?\s))) ; Driver version.
+ " " (group (+ (not ?\s))) ; APM BIOS version.
+ " 0x" (group (+ xdigit)) ; APM BIOS flags.
+ " 0x" (group (+ xdigit)) ; AC line status.
+ " 0x" (group (+ xdigit)) ; Battery status.
+ " 0x" (group (+ xdigit)) ; Battery flags.
+ " " (group (? ?-) (+ digit)) ?% ; Load percentage.
+ " " (group (? ?-) (+ digit)) ; Remaining time.
+ " " (group (* nonl)) ; Time unit
+ eol))
+
+(defconst battery-linux-proc-apm-regexp (rx battery--linux-proc-apm)
"Regular expression matching contents of `/proc/apm'.")
+(make-obsolete-variable 'battery-linux-proc-apm-regexp
+ "it is no longer used." "28.1")
(defun battery-linux-proc-apm ()
"Get APM status information from Linux (the kernel).
@@ -261,12 +315,12 @@ The following %-sequences are provided:
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
%t Remaining time (to charge or discharge) in the form `h:min'"
- (let (driver-version bios-version bios-interface line-status
- battery-status battery-status-symbol load-percentage
- seconds minutes hours remaining-time tem)
+ (let ( driver-version bios-version bios-interface line-status
+ battery-status battery-status-symbol load-percentage
+ seconds minutes hours remaining-time tem )
(with-temp-buffer
(ignore-errors (insert-file-contents "/proc/apm"))
- (when (re-search-forward battery-linux-proc-apm-regexp)
+ (when (re-search-forward (rx battery--linux-proc-apm) nil t)
(setq driver-version (match-string 1))
(setq bios-version (match-string 2))
(setq tem (string-to-number (match-string 3) 16))
@@ -279,9 +333,7 @@ The following %-sequences are provided:
(cond ((= tem 0) (setq line-status "off-line"))
((= tem 1) (setq line-status "on-line"))
((= tem 2) (setq line-status "on backup")))
- (setq tem (string-to-number (match-string 6) 16))
- (if (= tem 255)
- (setq battery-status "N/A")
+ (unless (= (string-to-number (match-string 6) 16) 255)
(setq tem (string-to-number (match-string 5) 16))
(cond ((= tem 0) (setq battery-status "high"
battery-status-symbol ""))
@@ -298,7 +350,7 @@ The following %-sequences are provided:
(setq minutes (/ seconds 60)
hours (/ seconds 3600))
(setq remaining-time
- (format "%d:%02d" hours (- minutes (* 60 hours))))))))
+ (format "%d:%02d" hours (% minutes 60)))))))
(list (cons ?v (or driver-version "N/A"))
(cons ?V (or bios-version "N/A"))
(cons ?I (or bios-interface "N/A"))
@@ -306,27 +358,31 @@ The following %-sequences are provided:
(cons ?B (or battery-status "N/A"))
(cons ?b (or battery-status-symbol ""))
(cons ?p (or load-percentage "N/A"))
- (cons ?s (or (and seconds (number-to-string seconds)) "N/A"))
- (cons ?m (or (and minutes (number-to-string minutes)) "N/A"))
- (cons ?h (or (and hours (number-to-string hours)) "N/A"))
+ (cons ?s (if seconds (number-to-string seconds) "N/A"))
+ (cons ?m (if minutes (number-to-string minutes) "N/A"))
+ (cons ?h (if hours (number-to-string hours) "N/A"))
(cons ?t (or remaining-time "N/A")))))
;;; `/proc/acpi/' interface for Linux.
+(rx-define battery--acpi-rate (&rest hour)
+ (: (group (+ digit)) " " (group ?m (in "AW") hour)))
+(rx-define battery--acpi-capacity (battery--acpi-rate ?h))
+
(defun battery-linux-proc-acpi ()
"Get ACPI status information from Linux (the kernel).
-This function works only with the `/proc/acpi/' format introduced
-in Linux version 2.4.20 and 2.6.0.
+This function works only with the `/proc/acpi/' interface
+introduced in Linux version 2.4.20 and 2.6.0.
The following %-sequences are provided:
%c Current capacity (mAh)
-%r Current rate
+%r Current rate of charge or discharge
+%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status, empty means high, `-' means low,
`!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
-%L AC line status (verbose)
%p Battery load percentage
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
@@ -342,45 +398,51 @@ The following %-sequences are provided:
;; information together since displaying for a variable amount of
;; batteries seems overkill for format-strings.
(with-temp-buffer
- (dolist (dir (ignore-errors (directory-files "/proc/acpi/battery/"
- t "\\`[^.]")))
- (erase-buffer)
- (ignore-errors (insert-file-contents (expand-file-name "state" dir)))
- (when (re-search-forward "present: +yes$" nil t)
- (and (re-search-forward "charging state: +\\(.*\\)$" nil t)
+ (dolist (dir (battery--files "/proc/acpi/battery/"))
+ (ignore-errors
+ (insert-file-contents (expand-file-name "state" dir) nil nil nil t))
+ (goto-char (point-min))
+ (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t)
+ (and (re-search-forward (rx "charging state:" (+ space)
+ (group (not space) (* nonl)) eol)
+ nil t)
(member charging-state '("unknown" "charged" nil))
;; On most multi-battery systems, most of the time only one
;; battery is "charging"/"discharging", the others are
;; "unknown".
(setq charging-state (match-string 1)))
- (when (re-search-forward "present rate: +\\([0-9]+\\) \\(m[AW]\\)$"
+ (when (re-search-forward (rx "present rate:" (+ space)
+ (battery--acpi-rate) eol)
nil t)
(setq rate (+ (or rate 0) (string-to-number (match-string 1))))
(when (> rate 0)
- (setq rate-type (or (and rate-type
- (if (string= rate-type (match-string 2))
- rate-type
- (error
- "Inconsistent rate types (%s vs. %s)"
- rate-type (match-string 2))))
- (match-string 2)))))
- (when (re-search-forward "remaining capacity: +\\([0-9]+\\) m[AW]h$"
+ (cond ((not rate-type)
+ (setq rate-type (match-string 2)))
+ ((not (string= rate-type (match-string 2)))
+ (error "Inconsistent rate types (%s vs. %s)"
+ rate-type (match-string 2))))))
+ (when (re-search-forward (rx "remaining capacity:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(setq capacity
(+ (or capacity 0) (string-to-number (match-string 1))))))
(goto-char (point-max))
(ignore-errors (insert-file-contents (expand-file-name "info" dir)))
- (when (re-search-forward "present: +yes$" nil t)
- (when (re-search-forward "design capacity: +\\([0-9]+\\) m[AW]h$"
+ (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t)
+ (when (re-search-forward (rx "design capacity:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(cl-incf design-capacity (string-to-number (match-string 1))))
- (when (re-search-forward "last full capacity: +\\([0-9]+\\) m[AW]h$"
+ (when (re-search-forward (rx "last full capacity:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(cl-incf last-full-capacity (string-to-number (match-string 1))))
- (when (re-search-forward
- "design capacity warning: +\\([0-9]+\\) m[AW]h$" nil t)
+ (when (re-search-forward (rx "design capacity warning:" (+ space)
+ battery--acpi-capacity eol)
+ nil t)
(cl-incf warn (string-to-number (match-string 1))))
- (when (re-search-forward "design capacity low: +\\([0-9]+\\) m[AW]h$"
+ (when (re-search-forward (rx "design capacity low:" (+ space)
+ battery--acpi-capacity eol)
nil t)
(cl-incf low (string-to-number (match-string 1)))))))
(setq full-capacity (if (> last-full-capacity 0)
@@ -394,79 +456,70 @@ The following %-sequences are provided:
60)
rate))
hours (/ minutes 60)))
- (list (cons ?c (or (and capacity (number-to-string capacity)) "N/A"))
+ (list (cons ?c (if capacity (number-to-string capacity) "N/A"))
(cons ?L (or (battery-search-for-one-match-in-files
- (mapcar (lambda (e) (concat e "/state"))
- (ignore-errors
- (directory-files "/proc/acpi/ac_adapter/"
- t "\\`[^.]")))
- "state: +\\(.*\\)$" 1)
-
+ (mapcar (lambda (d) (expand-file-name "state" d))
+ (battery--files "/proc/acpi/ac_adapter/"))
+ (rx "state:" (+ space) (group (not space) (* nonl))
eol)
+ 1)
"N/A"))
(cons ?d (or (battery-search-for-one-match-in-files
- (mapcar (lambda (e) (concat e "/temperature"))
- (ignore-errors
- (directory-files "/proc/acpi/thermal_zone/"
- t "\\`[^.]")))
- "temperature: +\\([0-9]+\\) C$" 1)
-
+ (mapcar (lambda (d) (expand-file-name "temperature" d))
+ (battery--files "/proc/acpi/thermal_zone/"))
+ (rx "temperature:" (+ space) (group (+ digit)) " C"
eol)
+ 1)
"N/A"))
- (cons ?r (or (and rate (concat (number-to-string rate) " "
- rate-type)) "N/A"))
+ (cons ?r (if rate
+ (concat (number-to-string rate) " " rate-type)
+ "N/A"))
(cons ?B (or charging-state "N/A"))
- (cons ?b (or (and (string= charging-state "charging") "+")
- (and capacity (< capacity low) "!")
- (and capacity (< capacity warn) "-")
- ""))
- (cons ?h (or (and hours (number-to-string hours)) "N/A"))
- (cons ?m (or (and minutes (number-to-string minutes)) "N/A"))
- (cons ?t (or (and minutes
- (format "%d:%02d" hours (- minutes (* 60 hours))))
- "N/A"))
- (cons ?p (or (and full-capacity capacity
- (> full-capacity 0)
- (number-to-string
- (floor (* 100 capacity) full-capacity)))
- "N/A")))))
+ (cons ?b (cond ((string= charging-state "charging") "+")
+ ((and capacity (< capacity low)) "!")
+ ((and capacity (< capacity warn)) "-")
+ ("")))
+ (cons ?h (if hours (number-to-string hours) "N/A"))
+ (cons ?m (if minutes (number-to-string minutes) "N/A"))
+ (cons ?t (if minutes (format "%d:%02d" hours (% minutes 60)) "N/A"))
+ (cons ?p (if (and full-capacity capacity (> full-capacity 0))
+ (number-to-string (floor (* 100 capacity)
full-capacity))
+ "N/A")))))
;;; `/sys/class/power_supply/BATN' interface for Linux.
(defun battery-linux-sysfs ()
- "Get ACPI status information from Linux kernel.
+ "Get sysfs status information from Linux kernel.
This function works only with the new `/sys/class/power_supply/'
-format introduced in Linux version 2.4.25.
+interface introduced in Linux version 2.4.25.
The following %-sequences are provided:
%c Current capacity (mAh or mWh)
-%r Current rate
+%r Current rate of charge or discharge
+%L Power source (verbose)
%B Battery status (verbose)
%b Battery status, empty means high, `-' means low,
`!' means critical, and `+' means charging
%d Temperature (in degrees Celsius)
%p Battery load percentage
-%L AC line status (verbose)
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
%t Remaining time (to charge or discharge) in the form `h:min'"
- (let (charging-state temperature hours percentage-now
- ;; Some batteries report charges and current, other energy and power.
+ (let (;; Some batteries report charges and current, others energy and power.
;; In order to reliably be able to combine those data, we convert them
;; all to energy/power (since we can't combine different charges if
;; they're not at the same voltage).
(energy-full 0.0)
(energy-now 0.0)
(power-now 0.0)
- (voltage-now 10.8)) ;Arbitrary default, in case the info is missing.
+ (voltage-now 10.8) ; Arbitrary default, in case the info is missing.
+ charging-state temperature hours percentage-now)
;; SysFS provides information about each battery present in the
;; system in a separate subdirectory. We are going to merge the
;; available information together.
(with-temp-buffer
- (dolist (dir (ignore-errors
- (battery--find-linux-sysfs-batteries)))
- (erase-buffer)
- (ignore-errors (insert-file-contents
- (expand-file-name "uevent" dir)))
+ (dolist (dir (battery--find-linux-sysfs-batteries))
+ (ignore-errors
+ (insert-file-contents (expand-file-name "uevent" dir) nil nil nil t))
(goto-char (point-min))
(when (re-search-forward
"POWER_SUPPLY_VOLTAGE_NOW=\\([0-9]*\\)$" nil t)
@@ -502,7 +555,7 @@ The following %-sequences are provided:
voltage-now))
(cl-incf energy-now (* (string-to-number now-string)
voltage-now)))
- ((and (progn (goto-char (point-min)) t)
+ ((and (goto-char (point-min))
(re-search-forward
"POWER_SUPPLY_ENERGY_FULL=\\([0-9]*\\)$" nil t)
(setq full-string (match-string 1))
@@ -511,7 +564,6 @@ The following %-sequences are provided:
(setq now-string (match-string 1)))
(cl-incf energy-full (string-to-number full-string))
(cl-incf energy-now (string-to-number now-string)))))
- (goto-char (point-min))
(unless (zerop power-now)
(let ((remaining (if (string= charging-state "Discharging")
energy-now
@@ -519,9 +571,9 @@ The following %-sequences are provided:
(setq hours (/ remaining power-now)))))))
(when (and (> energy-full 0) (> energy-now 0))
(setq percentage-now (/ (* 100 energy-now) energy-full)))
- (list (cons ?c (cond ((or (> energy-full 0) (> energy-now 0))
- (number-to-string (/ energy-now voltage-now)))
- (t "N/A")))
+ (list (cons ?c (if (or (> energy-full 0) (> energy-now 0))
+ (number-to-string (/ energy-now voltage-now))
+ "N/A"))
(cons ?r (if (> power-now 0.0)
(format "%.1f" (/ power-now 1000000.0))
"N/A"))
@@ -532,162 +584,205 @@ The following %-sequences are provided:
"N/A"))
(cons ?d (or temperature "N/A"))
(cons ?B (or charging-state "N/A"))
- (cons ?b (or (and (string= charging-state "Charging") "+")
- (and percentage-now (< percentage-now
battery-load-critical) "!")
- (and percentage-now (< percentage-now battery-load-low)
"-")
- ""))
- (cons ?p (cond
- ((and percentage-now (format "%.1f" percentage-now)))
- (t "N/A")))
- (cons ?L (cond
- ((battery-search-for-one-match-in-files
- (list "/sys/class/power_supply/AC/online"
- "/sys/class/power_supply/ACAD/online"
- "/sys/class/power_supply/ADP1/online")
- "1" 0)
- "AC")
- ((battery-search-for-one-match-in-files
- (list "/sys/class/power_supply/AC/online"
- "/sys/class/power_supply/ACAD/online"
- "/sys/class/power_supply/ADP1/online")
- "0" 0)
- "BAT")
- (t "N/A"))))))
+ (cons ?b (cond ((string= charging-state "Charging") "+")
+ ((not percentage-now) "")
+ ((< percentage-now battery-load-critical) "!")
+ ((< percentage-now battery-load-low) "-")
+ ("")))
+ (cons ?p (if percentage-now (format "%.1f" percentage-now) "N/A"))
+ (cons ?L (pcase (battery-search-for-one-match-in-files
+ '("/sys/class/power_supply/AC/online"
+ "/sys/class/power_supply/ACAD/online"
+ "/sys/class/power_supply/ADP1/online")
+ (rx (in "01")) 0)
+ ("0" "BAT")
+ ("1" "AC")
+ (_ "N/A"))))))
-;;; `upowerd' interface.
-(defconst battery-upower-dbus-interface "org.freedesktop.UPower"
- "The interface to UPower.
-See URL `https://upower.freedesktop.org/docs/'.")
+;;; UPower interface.
+
+(defconst battery-upower-interface "org.freedesktop.UPower"
+ "Name of the UPower D-Bus interface.
+See URL `https://upower.freedesktop.org/docs/UPower.html'.")
-(defconst battery-upower-dbus-path "/org/freedesktop/UPower"
- "D-Bus path to talk to UPower service.")
+(defconst battery-upower-path "/org/freedesktop/UPower"
+ "D-Bus object providing `battery-upower-interface'.")
-(defconst battery-upower-dbus-device-interface
- (concat battery-upower-dbus-interface ".Device")
- "The Device interface of the UPower.
+(defconst battery-upower-device-interface "org.freedesktop.UPower.Device"
+ "Name of the UPower Device D-Bus interface.
See URL `https://upower.freedesktop.org/docs/Device.html'.")
-(defconst battery-upower-dbus-device-path
- (concat battery-upower-dbus-path "/devices")
- "D-Bus path to talk to devices part of the UPower service.")
-
-(defconst battery-upower-types
- '((0 . :unknown) (1 . :line-power) (2 . :battery)
- (3 . :ups) (4 . :monitor) (5 . :mouse)
- (6 . :keyboard) (7 . :pda) (8 . :phone))
- "Type of the device.")
-
-(defconst battery-upower-states
- '((0 . "unknown") (1 . "charging") (2 . "discharging")
- (3 . "empty") (4 . "fully-charged") (5 . "pending-charge")
- (6 . "pending-discharge"))
- "Alist of battery power states.
-Only valid for `:battery' devices.")
-
-(defun battery-upower-device-property (device property)
- "Get value of the single PROPERTY for the UPower DEVICE."
- (dbus-get-property
- :system battery-upower-dbus-service
- (expand-file-name device battery-upower-dbus-device-path)
- battery-upower-dbus-device-interface
- property))
-
-(defun battery-upower-device-all-properties (device)
+(defconst battery-upower-device-path "/org/freedesktop/UPower/devices"
+ "D-Bus object providing `battery-upower-device-interface'.")
+
+(defvar battery--upower-signals nil
+ "Handles for UPower signal subscriptions.")
+
+(defun battery--upower-signal-handler (&rest _)
+ "Update battery status on receiving a UPower D-Bus signal."
+ (timer-event-handler battery-update-timer))
+
+(defun battery--upower-props-changed (_interface changed _invalidated)
+ "Update status when system starts/stops running on battery.
+Intended as a UPower PropertiesChanged signal handler."
+ (when (assoc "OnBattery" changed)
+ (battery--upower-signal-handler)))
+
+(defun battery--upower-unsubscribe ()
+ "Unsubscribe from UPower device change signals."
+ (mapc #'dbus-unregister-object battery--upower-signals)
+ (setq battery--upower-signals ()))
+
+(defun battery--upower-subsribe ()
+ "Subscribe to UPower device change signals."
+ (push (dbus-register-signal :system battery-upower-service
+ battery-upower-path
+ dbus-interface-properties
+ "PropertiesChanged"
+ #'battery--upower-props-changed)
+ battery--upower-signals)
+ (dolist (method '("DeviceAdded" "DeviceRemoved"))
+ (push (dbus-register-signal :system battery-upower-service
+ battery-upower-path
+ battery-upower-interface
+ method #'battery--upower-signal-handler)
+ battery--upower-signals)))
+
+(defun battery--upower-device-properties (device)
"Return value for all available properties for the UPower DEVICE."
(dbus-get-all-properties
- :system battery-upower-dbus-service
- (expand-file-name device battery-upower-dbus-device-path)
- battery-upower-dbus-device-interface))
-
-(defun battery-upower-device-list ()
- "Return list of all available UPower devices.
-Each element is the cons cell in form: (DEVICE . DEVICE-TYPE)."
- (mapcar (lambda (device-path)
- (let* ((device (file-relative-name
- device-path battery-upower-dbus-device-path))
- (type-num (battery-upower-device-property device "Type")))
- (cons device (or (cdr (assq type-num battery-upower-types))
- :unknown))))
- (dbus-call-method :system battery-upower-dbus-service
- battery-upower-dbus-path
- battery-upower-dbus-interface
- "EnumerateDevices")))
-
-(defun battery-upower-device-autodetect (device-type)
- "Return first matching UPower device of DEVICE-TYPE."
- (car (rassq device-type (battery-upower-device-list))))
+ :system battery-upower-service
+ (expand-file-name device battery-upower-device-path)
+ battery-upower-device-interface))
+
+(defun battery--upower-devices ()
+ "List all UPower devices according to `battery-upower-device'."
+ (cond ((stringp battery-upower-device)
+ (list battery-upower-device))
+ (battery-upower-device)
+ ((dbus-call-method :system battery-upower-service
+ battery-upower-path
+ battery-upower-interface
+ "EnumerateDevices"))))
+
+(defun battery--upower-state (props state)
+ "Merge the UPower battery state in PROPS with STATE.
+This is an extension of the UPower DisplayDevice algorithm for
+merging multiple battery states into one. PROPS is an alist of
+battery properties from `battery-upower-device-interface', and
+STATE is a symbol representing the state to merge with."
+ ;; Map UPower enum into our printable symbols.
+ (let* ((new (pcase (cdr (assoc "State" props))
+ (1 'charging)
+ (2 'discharging)
+ (3 'empty)
+ (4 'fully-charged)
+ (5 'pending-charge)
+ (6 'pending-discharge)))
+ ;; Unknown state represented by nil.
+ (either (delq nil (list new state))))
+ ;; Earlier states override later ones.
+ (car (cond ((memq 'charging either))
+ ((memq 'discharging either))
+ ((memq 'pending-charge either))
+ ((memq 'pending-discharge either))
+ ;; Only options left are full or empty,
+ ;; but if they conflict return nil.
+ ((null (cdr either)) either)
+ ((apply #'eq either) either)))))
(defun battery-upower ()
- "Get battery status from dbus Upower interface.
-This function works only in systems with `upowerd' daemon
-running.
+ "Get battery status from UPower D-Bus interface.
+This function works only in systems that provide a UPower D-Bus
+service.
The following %-sequences are provided:
%c Current capacity (mWh)
-%p Battery load percentage
-%r Current rate
+%r Current rate of charge or discharge
+%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status: empty means high, `-' means low,
`!' means critical, and `+' means charging
-%L AC line status (verbose)
+%d Temperature (in degrees Celsius)
+%p Battery load percentage
%s Remaining time (to charge or discharge) in seconds
%m Remaining time (to charge or discharge) in minutes
%h Remaining time (to charge or discharge) in hours
%t Remaining time (to charge or discharge) in the form `h:min'"
- (let* ((bat-device (or battery-upower-device
- (battery-upower-device-autodetect :battery)))
- (bat-props (when bat-device
- (battery-upower-device-all-properties bat-device)))
- (percents (cdr (assoc "Percentage" bat-props)))
- (time-to-empty (cdr (assoc "TimeToEmpty" bat-props)))
- (time-to-full (cdr (assoc "TimeToFull" bat-props)))
- (state (cdr (assoc "State" bat-props)))
- (level (cdr (assoc "BatteryLevel" bat-props)))
- (energy (cdr (assoc "Energy" bat-props)))
- (energy-rate (cdr (assoc "EnergyRate" bat-props)))
- (lp-device (or battery-upower-line-power-device
- (battery-upower-device-autodetect :line-power)))
- (online-p (when lp-device
- (battery-upower-device-property lp-device "Online")))
- (seconds (if online-p time-to-full time-to-empty))
- (minutes (when seconds (/ seconds 60)))
- (hours (when minutes (/ minutes 60)))
- (remaining-time (when hours
- (format "%d:%02d" hours (mod minutes 60)))))
- (list (cons ?c (if energy (number-to-string (round (* 1000 energy)))
"N/A"))
- (cons ?p (if percents (number-to-string (round percents)) "N/A"))
- (cons ?r (if energy-rate
- (concat (number-to-string energy-rate) " W")
+ (let ((count 0) props type line-status state load temperature
+ secs mins hrs total-energy total-rate total-tte total-ttf)
+ ;; Merge information from all available or specified UPower
+ ;; devices like other `battery-status-function's.
+ (dolist (device (battery--upower-devices))
+ (setq props (battery--upower-device-properties device))
+ (setq type (cdr (assoc "Type" props)))
+ (cond
+ ((and (eq type 1) (not (eq line-status 'online)))
+ ;; It's a line power device: `online' if currently providing
+ ;; power, any other non-nil value if simply present.
+ (setq line-status (if (cdr (assoc "Online" props)) 'online t)))
+ ((and (eq type 2) (cdr (assoc "IsPresent" props)))
+ ;; It's a battery.
+ (setq count (1+ count))
+ (setq state (battery--upower-state props state))
+ (let ((energy (cdr (assoc "Energy" props)))
+ (rate (cdr (assoc "EnergyRate" props)))
+ (percent (cdr (assoc "Percentage" props)))
+ (temp (cdr (assoc "Temperature" props)))
+ (tte (cdr (assoc "TimeToEmpty" props)))
+ (ttf (cdr (assoc "TimeToFull" props))))
+ (when energy (setq total-energy (+ (or total-energy 0) energy)))
+ (when rate (setq total-rate (+ (or total-rate 0) rate)))
+ (when percent (setq load (+ (or load 0) percent)))
+ (when temp (setq temperature (+ (or temperature 0) temp)))
+ (when tte (setq total-tte (+ (or total-tte 0) tte)))
+ (when ttf (setq total-ttf (+ (or total-ttf 0) ttf)))))))
+ (when (> count 1)
+ ;; Averages over multiple batteries.
+ (when load (setq load (/ load count)))
+ (when temperature (setq temperature (/ temperature count))))
+ (when (setq secs (if (eq line-status 'online) total-ttf total-tte))
+ (setq mins (/ secs 60))
+ (setq hrs (/ secs 3600)))
+ (list (cons ?c (if total-energy
+ (format "%.0f" (* total-energy 1000))
"N/A"))
- (cons ?B (if state
- (cdr (assq state battery-upower-states))
- "unknown"))
- (cons ?b (cond ((= level 3) "-")
- ((= level 4) "!")
- (online-p "+")
- (t "")))
- (cons ?L (if online-p "on-line" (if lp-device "off-line" "unknown")))
- (cons ?s (if seconds (number-to-string seconds) "N/A"))
- (cons ?m (if minutes (number-to-string minutes) "N/A"))
- (cons ?h (if hours (number-to-string hours) "N/A"))
- (cons ?t (or remaining-time "N/A")))))
+ (cons ?r (if total-rate (format "%.1f W" total-rate) "N/A"))
+ (cons ?L (cond ((eq line-status 'online) "on-line")
+ (line-status "off-line")
+ ("N/A")))
+ (cons ?B (format "%s" (or state 'unknown)))
+ (cons ?b (cond ((eq state 'charging) "+")
+ ((and load (< load battery-load-critical)) "!")
+ ((and load (< load battery-load-low)) "-")
+ ("")))
+ ;; Zero usually means unknown.
+ (cons ?d (if (and temperature (/= temperature 0))
+ (format "%.0f" temperature)
+ "N/A"))
+ (cons ?p (if load (format "%.0f" load) "N/A"))
+ (cons ?s (if secs (number-to-string secs) "N/A"))
+ (cons ?m (if mins (number-to-string mins) "N/A"))
+ (cons ?h (if hrs (number-to-string hrs) "N/A"))
+ (cons ?t (if hrs (format "%d:%02d" hrs (% mins 60)) "N/A")))))
;;; `apm' interface for BSD.
+
(defun battery-bsd-apm ()
"Get APM status information from BSD apm binary.
The following %-sequences are provided:
+%P Advanced power saving mode state (verbose)
%L AC line status (verbose)
%B Battery status (verbose)
%b Battery status, empty means high, `-' means low,
- `!' means critical, and `+' means charging
-%P Advanced power saving mode state (verbose)
-%p Battery charge percentage
-%s Remaining battery charge time in seconds
-%m Remaining battery charge time in minutes
-%h Remaining battery charge time in hours
-%t Remaining battery charge time in the form `h:min'"
+ `!' means critical, and `+' means charging
+%p Battery load percentage
+%s Remaining time (to charge or discharge) in seconds
+%m Remaining time (to charge or discharge) in minutes
+%h Remaining time (to charge or discharge) in hours
+%t Remaining time (to charge or discharge) in the form `h:min'"
(let* ((os-name (car (split-string
;; FIXME: Can't we use something like `system-type'?
(shell-command-to-string "/usr/bin/uname"))))
@@ -753,7 +848,7 @@ The following %-sequences are provided:
(setq seconds (string-to-number battery-life)
minutes (truncate seconds 60)))
(setq hours (truncate minutes 60)
- remaining-time (format "%d:%02d" hours (mod minutes 60))))
+ remaining-time (format "%d:%02d" hours (% minutes 60))))
(list (cons ?L (or line-status "N/A"))
(cons ?B (or (car battery-status) "N/A"))
(cons ?b (or (cdr battery-status) "N/A"))
@@ -761,9 +856,9 @@ The following %-sequences are provided:
"N/A"
battery-percentage))
(cons ?P (or apm-mode "N/A"))
- (cons ?s (or (and seconds (number-to-string seconds)) "N/A"))
- (cons ?m (or (and minutes (number-to-string minutes)) "N/A"))
- (cons ?h (or (and hours (number-to-string hours)) "N/A"))
+ (cons ?s (if seconds (number-to-string seconds) "N/A"))
+ (cons ?m (if minutes (number-to-string minutes) "N/A"))
+ (cons ?h (if hours (number-to-string hours) "N/A"))
(cons ?t (or remaining-time "N/A")))))
@@ -778,21 +873,25 @@ The following %-sequences are provided:
%b Battery status, empty means high, `-' means low,
`!' means critical, and `+' means charging
%p Battery load percentage
-%h Remaining time in hours
-%m Remaining time in minutes
-%t Remaining time in the form `h:min'"
- (let (power-source load-percentage battery-status battery-status-symbol
- remaining-time hours minutes)
+%m Remaining time (to charge or discharge) in minutes
+%h Remaining time (to charge or discharge) in hours
+%t Remaining time (to charge or discharge) in the form `h:min'"
+ (let ( power-source load-percentage battery-status battery-status-symbol
+ remaining-time hours minutes )
(with-temp-buffer
(ignore-errors (call-process "pmset" nil t nil "-g" "ps"))
(goto-char (point-min))
- (when (re-search-forward "\\(?:Currentl?y\\|Now\\) drawing from
'\\(AC\\|Battery\\) Power'" nil t)
+ (when (re-search-forward ;; Handle old typo in output.
+ "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'"
+ nil t)
(setq power-source (match-string 1))
- (when (re-search-forward "^ -InternalBattery-0\\([ \t]+(id=[0-9]+)\\)*[
\t]+" nil t)
+ (when (re-search-forward (rx bol " -InternalBattery-0" (+ space)
+ (* "(id=" (+ digit) ")" (+ space)))
+ nil t)
(when (looking-at "\\([0-9]\\{1,3\\}\\)%")
(setq load-percentage (match-string 1))
(goto-char (match-end 0))
- (cond ((looking-at "; charging")
+ (cond ((looking-at-p "; charging")
(setq battery-status "charging"
battery-status-symbol "+"))
((< (string-to-number load-percentage) battery-load-critical)
@@ -823,13 +922,7 @@ The following %-sequences are provided:
(defun battery-format (format alist)
"Substitute %-sequences in FORMAT."
- (replace-regexp-in-string
- "%."
- (lambda (str)
- (let ((char (aref str 1)))
- (if (eq char ?%) "%"
- (or (cdr (assoc char alist)) ""))))
- format t t))
+ (format-spec format alist 'delete))
(defun battery-search-for-one-match-in-files (files regexp match-num)
"Search REGEXP in the content of the files listed in FILES.
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
index 7abc436..b262ab7 100644
--- a/lisp/cedet/semantic/complete.el
+++ b/lisp/cedet/semantic/complete.el
@@ -1635,10 +1635,10 @@ This will not happen if you directly set this variable
via `setq'."
:group 'semantic
:version "24.3"
:type 'integer
- :set '(lambda (sym var)
- (set-default sym var)
- (when (boundp 'x-max-tooltip-size)
- (setcdr x-max-tooltip-size (max (1+ var) (cdr
x-max-tooltip-size))))))
+ :set (lambda (sym var)
+ (set-default sym var)
+ (when (boundp 'x-max-tooltip-size)
+ (setcdr x-max-tooltip-size (max (1+ var) (cdr
x-max-tooltip-size))))))
(defclass semantic-displayer-tooltip (semantic-displayer-traditional)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 24ebfa4..efb2140 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1064,8 +1064,6 @@ corresponding command.
Within CMD, %i denotes the input file(s), and %o denotes the
output file. %i path(s) are relative, while %o is absolute.")
-(declare-function format-spec "format-spec.el" (format specification))
-
;;;###autoload
(defun dired-do-compress-to ()
"Compress selected files and directories to an archive.
@@ -1073,7 +1071,6 @@ Prompt for the archive file name.
Choose the archiving command based on the archive file-name extension
and `dired-compress-files-alist'."
(interactive)
- (require 'format-spec)
(let* ((in-files (dired-get-marked-files nil nil nil nil t))
(out-file (expand-file-name (read-file-name "Compress to: ")))
(rule (cl-find-if
@@ -1093,12 +1090,12 @@ and `dired-compress-files-alist'."
(when (zerop
(dired-shell-command
(format-spec (cdr rule)
- `((?\o . ,(shell-quote-argument out-file))
- (?\i . ,(mapconcat
- (lambda (file-desc)
- (shell-quote-argument
(file-name-nondirectory
-
file-desc)))
- in-files " "))))))
+ `((?o . ,(shell-quote-argument out-file))
+ (?i . ,(mapconcat
+ (lambda (in-file)
+ (shell-quote-argument
+ (file-name-nondirectory in-file)))
+ in-files " "))))))
(message (ngettext "Compressed %d file to %s"
"Compressed %d files to %s"
(length in-files))
@@ -3087,6 +3084,7 @@ in the Dired buffer."
(declare-function vc-compatible-state "vc")
+;;;###autoload
(defun dired-vc-deduce-fileset (&optional state-model-only-files
not-state-changing)
(let ((backend (vc-responsible-backend default-directory))
(files (dired-get-marked-files nil nil nil nil t))
diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el
index a7fcc5c..2fa5a87 100644
--- a/lisp/emacs-lisp/benchmark.el
+++ b/lisp/emacs-lisp/benchmark.el
@@ -81,7 +81,7 @@ result. The overhead of the `lambda's is accounted for."
(gcs (make-symbol "gcs"))
(gc (make-symbol "gc"))
(code (byte-compile `(lambda () ,@forms)))
- (lambda-code (byte-compile '(lambda ()))))
+ (lambda-code (byte-compile '(lambda ()))))
`(let ((,gc gc-elapsed)
(,gcs gcs-done))
(list ,(if (or (symbolp repetitions) (> repetitions 1))
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index ba344eb..c95c758 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -673,7 +673,7 @@ When called as a function, NAME returns an iterator value
that
encapsulates the state of a computation that produces a sequence
of values. Callers can retrieve each value using `iter-next'."
(declare (indent defun)
- (debug (&define name lambda-list lambda-doc def-body))
+ (debug (&define name lambda-list lambda-doc &rest sexp))
(doc-string 3))
(cl-assert lexical-binding)
(let* ((parsed-body (macroexp-parse-body body))
@@ -687,14 +687,14 @@ of values. Callers can retrieve each value using
`iter-next'."
"Return a lambda generator.
`iter-lambda' is to `iter-defun' as `lambda' is to `defun'."
(declare (indent defun)
- (debug (&define lambda-list lambda-doc def-body)))
+ (debug (&define lambda-list lambda-doc &rest sexp)))
(cl-assert lexical-binding)
`(lambda ,arglist
,(cps-generate-evaluator body)))
(defmacro iter-make (&rest body)
"Return a new iterator."
- (declare (debug t))
+ (declare (debug (&rest sexp)))
(cps-generate-evaluator body))
(defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil))
@@ -720,7 +720,7 @@ is blocked."
Evaluate BODY with VAR bound to each value from ITERATOR.
Return the value with which ITERATOR finished iteration."
(declare (indent 1)
- (debug ((symbolp form) body)))
+ (debug ((symbolp form) &rest sexp)))
(let ((done-symbol (cps--gensym "iter-do-iterator-done"))
(condition-symbol (cps--gensym "iter-do-condition"))
(it-symbol (cps--gensym "iter-do-iterator"))
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 096036a..513bd32 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -224,7 +224,7 @@ The first arg in ARGLIST (the one that receives VAL)
receives an expression
which can do arbitrary things, whereas the other arguments are all guaranteed
to be pure and copyable. Example use:
(gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))"
- (declare (indent 2) (debug (&define name sexp def-body)))
+ (declare (indent 2) (debug (&define name :name gv-setter sexp def-body)))
`(gv-define-expander ,name
(lambda (do &rest args)
(declare-function
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 0171fd5..c349b5d 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -441,9 +441,9 @@ synchronously."
&aux
(name (intern name-string))
(version (version-to-list version-string))
- (reqs (mapcar #'(lambda (elt)
- (list (car elt)
- (version-to-list (cadr elt))))
+ (reqs (mapcar (lambda (elt)
+ (list (car elt)
+ (version-to-list (cadr elt))))
(if (eq 'quote (car requirements))
(nth 1 requirements)
requirements)))
@@ -3900,9 +3900,9 @@ If VERSION is nil or the empty string, show all packages."
(package-menu--generate t t)
(package-menu--filter-by
(let ((fun (pcase predicate
- ('= 'version-list-=)
- ('< 'version-list-<)
- ('> '(lambda (a b) (not (version-list-<= a b))))
+ ('= #'version-list-=)
+ ('< #'version-list-<)
+ ('> (lambda (a b) (not (version-list-<= a b))))
(_ (error "Unknown predicate: %s" predicate))))
(ver (version-to-list version)))
(lambda (pkg-desc)
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index aa4b2ad..88bb0a8 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -1381,7 +1381,7 @@ To make local rx extensions, use `rx-let' for `rx',
For more details, see Info node `(elisp) Extending Rx'.
\(fn NAME [(ARGS...)] RX)"
- (declare (indent 1))
+ (declare (indent defun))
`(eval-and-compile
(put ',name 'rx-definition ',(rx--make-binding name definition))
',name))
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index 26a1a89..c4dcb76 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -860,7 +860,7 @@ With numeric prefix arg, copy to register 0-9 instead."
(defun cua-cancel ()
"Cancel the active region, rectangle, or global mark."
(interactive)
- (setq mark-active nil)
+ (deactivate-mark)
(if (fboundp 'cua--cancel-rectangle)
(cua--cancel-rectangle)))
diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el
index e99bb33..663995a 100644
--- a/lisp/emulation/cua-rect.el
+++ b/lisp/emulation/cua-rect.el
@@ -1412,7 +1412,7 @@ With prefix arg, indent to that column."
(add-function :around region-extract-function
#'cua--rectangle-region-extract)
(add-function :around region-insert-function
- #'cua--insert-rectangle)
+ #'cua--rectangle-region-insert)
(add-function :around redisplay-highlight-region-function
#'cua--rectangle-highlight-for-redisplay)
@@ -1422,6 +1422,10 @@ With prefix arg, indent to that column."
;; already do it elsewhere.
(funcall redisplay-unhighlight-region-function (nth 3 args))))
+(defun cua--rectangle-region-insert (orig &rest args)
+ (if (not cua--rectangle) (apply orig args)
+ (funcall #'cua--insert-rectangle (car args))))
+
(defun cua--rectangle-region-extract (orig &optional delete)
(cond
((not cua--rectangle)
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index 3107ff2..0e98f2b 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -555,16 +555,15 @@ See `erc-log-match-format'."
(and (eq erc-log-matches-flag 'away)
(erc-away-time)))
match-buffer-name)
- (let ((line (format-spec erc-log-match-format
- (format-spec-make
- ?n nick
- ?t (format-time-string
- (or (and (boundp 'erc-timestamp-format)
- erc-timestamp-format)
- "[%Y-%m-%d %H:%M] "))
- ?c (or (erc-default-target) "")
- ?m message
- ?u nickuserhost))))
+ (let ((line (format-spec
+ erc-log-match-format
+ `((?n . ,nick)
+ (?t . ,(format-time-string
+ (or (bound-and-true-p erc-timestamp-format)
+ "[%Y-%m-%d %H:%M] ")))
+ (?c . ,(or (erc-default-target) ""))
+ (?m . ,message)
+ (?u . ,nickuserhost)))))
(with-current-buffer (erc-log-matches-make-buffer match-buffer-name)
(let ((inhibit-read-only t))
(goto-char (point-max))
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index cfde84e..3880778 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -6391,17 +6391,16 @@ if `erc-away' is non-nil."
(defun erc-update-mode-line-buffer (buffer)
"Update the mode line in a single ERC buffer BUFFER."
(with-current-buffer buffer
- (let ((spec (format-spec-make
- ?a (erc-format-away-status)
- ?l (erc-format-lag-time)
- ?m (erc-format-channel-modes)
- ?n (or (erc-current-nick) "")
- ?N (erc-format-network)
- ?o (or (erc-controls-strip erc-channel-topic) "")
- ?p (erc-port-to-string erc-session-port)
- ?s (erc-format-target-and/or-server)
- ?S (erc-format-target-and/or-network)
- ?t (erc-format-target)))
+ (let ((spec `((?a . ,(erc-format-away-status))
+ (?l . ,(erc-format-lag-time))
+ (?m . ,(erc-format-channel-modes))
+ (?n . ,(or (erc-current-nick) ""))
+ (?N . ,(erc-format-network))
+ (?o . ,(or (erc-controls-strip erc-channel-topic) ""))
+ (?p . ,(erc-port-to-string erc-session-port))
+ (?s . ,(erc-format-target-and/or-server))
+ (?S . ,(erc-format-target-and/or-network))
+ (?t . ,(erc-format-target))))
(process-status (cond ((and (erc-server-process-alive)
(not erc-server-connected))
":connecting")
diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el
index 7219af4..c26f654 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -451,11 +451,9 @@ resultant list of strings."
`(lambda (file)
(let ((attrs (file-attributes file)))
(if attrs
- (,(if (eq qual ?-)
- 'time-less-p
- (if (eq qual ?+)
- '(lambda (a b) (time-less-p b a))
- 'time-equal-p))
+ (,(cond ((eq qual ?-) #'time-less-p)
+ ((eq qual ?+) (lambda (a b) (time-less-p b a)))
+ (#'time-equal-p))
,when (nth ,attr-index attrs)))))))
(defun eshell-pred-file-type (type)
diff --git a/lisp/faces.el b/lisp/faces.el
index 8c3e464..ba85973 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1794,6 +1794,12 @@ on which one provides better contrast with COLOR."
(color-values color)))
"#ffffff" "black"))
+(defconst color-luminance-dark-limit 0.325
+ "The relative luminance below which a color is considered 'dark'.
+A 'dark' color in this sense provides better contrast with white
+than with black; see `color-dark-p'.
+This value was determined experimentally.")
+
(defun color-dark-p (rgb)
"Whether RGB is more readable against white than black.
RGB is a 3-element list (R G B), each component in the range [0,1].
@@ -1814,7 +1820,7 @@ contrast colour with RGB as background and as foreground."
(g (expt sg 2.2))
(b (expt sb 2.2))
(y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))
- (< y (eval-when-compile (expt 0.6 2.2)))))
+ (< y color-luminance-dark-limit)))
(declare-function xw-color-defined-p "xfns.c" (color &optional frame))
@@ -2758,6 +2764,33 @@ Note: Other faces cannot inherit from the cursor face."
:version "21.1"
:group 'basic-faces)
+(defface tab-bar
+ '((((class color) (min-colors 88))
+ :inherit variable-pitch
+ :background "grey85"
+ :foreground "black")
+ (((class mono))
+ :background "grey")
+ (t
+ :inverse-video t))
+ "Tab bar face."
+ :version "27.1"
+ :group 'basic-faces)
+
+(defface tab-line
+ '((((class color) (min-colors 88))
+ :inherit variable-pitch
+ :height 0.9
+ :background "grey85"
+ :foreground "black")
+ (((class mono))
+ :background "grey")
+ (t
+ :inverse-video t))
+ "Tab line face."
+ :version "27.1"
+ :group 'basic-faces)
+
(defface menu
'((((type tty))
:inverse-video t)
diff --git a/lisp/format-spec.el b/lisp/format-spec.el
index 9278bd7..6af79a4 100644
--- a/lisp/format-spec.el
+++ b/lisp/format-spec.el
@@ -1,4 +1,4 @@
-;;; format-spec.el --- functions for formatting arbitrary formatting strings
+;;; format-spec.el --- format arbitrary formatting strings -*-
lexical-binding: t -*-
;; Copyright (C) 1999-2020 Free Software Foundation, Inc.
@@ -24,10 +24,8 @@
;;; Code:
-(eval-when-compile
- (require 'subr-x))
-
-(defun format-spec (format specification &optional only-present)
+;;;###autoload
+(defun format-spec (format specification &optional ignore-missing)
"Return a string based on FORMAT and SPECIFICATION.
FORMAT is a string containing `format'-like specs like \"su - %u %k\".
SPECIFICATION is an alist mapping format specification characters
@@ -39,22 +37,22 @@ For instance:
\\=`((?u . ,(user-login-name))
(?l . \"ls\")))
-Each %-spec may contain optional flag and width modifiers, as
-follows:
+Each %-spec may contain optional flag, width, and precision
+modifiers, as follows:
- %<flags><width>character
+ %<flags><width><precision>character
The following flags are allowed:
* 0: Pad to the width, if given, with zeros instead of spaces.
* -: Pad to the width, if given, on the right instead of the left.
-* <: Truncate to the width, if given, on the left.
-* >: Truncate to the width, if given, on the right.
+* <: Truncate to the width and precision, if given, on the left.
+* >: Truncate to the width and precision, if given, on the right.
* ^: Convert to upper case.
* _: Convert to lower case.
-The width modifier behaves like the corresponding one in `format'
-when applied to %s.
+The width and truncation modifiers behave like the corresponding
+ones in `format' when applied to %s.
For example, \"%<010b\" means \"substitute into the output the
value associated with ?b in SPECIFICATION, either padding it with
@@ -64,89 +62,108 @@ characters wide\".
Any text properties of FORMAT are copied to the result, with any
text properties of a %-spec itself copied to its substitution.
-ONLY-PRESENT indicates how to handle %-spec characters not
+IGNORE-MISSING indicates how to handle %-spec characters not
present in SPECIFICATION. If it is nil or omitted, emit an
-error; otherwise leave those %-specs and any occurrences of
-\"%%\" in FORMAT verbatim in the result, including their text
-properties, if any."
+error; if it is the symbol `ignore', leave those %-specs verbatim
+in the result, including their text properties, if any; if it is
+the symbol `delete', remove those %-specs from the result;
+otherwise do the same as for the symbol `ignore', but also leave
+any occurrences of \"%%\" in FORMAT verbatim in the result."
(with-temp-buffer
(insert format)
(goto-char (point-min))
(while (search-forward "%" nil t)
(cond
- ;; Quoted percent sign.
- ((eq (char-after) ?%)
- (unless only-present
- (delete-char 1)))
- ;; Valid format spec.
- ((looking-at "\\([-0 _^<>]*\\)\\([0-9.]*\\)\\([a-zA-Z]\\)")
- (let* ((modifiers (match-string 1))
- (num (match-string 2))
- (spec (string-to-char (match-string 3)))
- (val (assq spec specification)))
- (if (not val)
- (unless only-present
- (error "Invalid format character: `%%%c'" spec))
- (setq val (cdr val)
- modifiers (format-spec--parse-modifiers modifiers))
- ;; Pad result to desired length.
- (let ((text (format "%s" val)))
- (when num
- (setq num (string-to-number num))
- (setq text (format-spec--pad text num modifiers))
- (when (> (length text) num)
- (cond
- ((memq :chop-left modifiers)
- (setq text (substring text (- (length text) num))))
- ((memq :chop-right modifiers)
- (setq text (substring text 0 num))))))
- (when (memq :uppercase modifiers)
- (setq text (upcase text)))
- (when (memq :lowercase modifiers)
- (setq text (downcase text)))
- ;; Insert first, to preserve text properties.
- (insert-and-inherit text)
- ;; Delete the specifier body.
- (delete-region (+ (match-beginning 0) (length text))
- (+ (match-end 0) (length text)))
- ;; Delete the percent sign.
- (delete-region (1- (match-beginning 0)) (match-beginning 0))))))
- ;; Signal an error on bogus format strings.
- (t
- (unless only-present
- (error "Invalid format string")))))
+ ;; Quoted percent sign.
+ ((= (following-char) ?%)
+ (when (memq ignore-missing '(nil ignore delete))
+ (delete-char 1)))
+ ;; Valid format spec.
+ ((looking-at (rx (? (group (+ (in " 0<>^_-"))))
+ (? (group (+ digit)))
+ (? (group ?. (+ digit)))
+ (group alpha)))
+ (let* ((beg (point))
+ (end (match-end 0))
+ (flags (match-string 1))
+ (width (match-string 2))
+ (trunc (match-string 3))
+ (char (string-to-char (match-string 4)))
+ (text (assq char specification)))
+ (cond (text
+ ;; Handle flags.
+ (setq text (format-spec--do-flags
+ (format "%s" (cdr text))
+ (format-spec--parse-flags flags)
+ (and width (string-to-number width))
+ (and trunc (car (read-from-string trunc 1)))))
+ ;; Insert first, to preserve text properties.
+ (insert-and-inherit text)
+ ;; Delete the specifier body.
+ (delete-region (point) (+ end (length text)))
+ ;; Delete the percent sign.
+ (delete-region (1- beg) beg))
+ ((eq ignore-missing 'delete)
+ ;; Delete the whole format spec.
+ (delete-region (1- beg) end))
+ ((not ignore-missing)
+ (error "Invalid format character: `%%%c'" char)))))
+ ;; Signal an error on bogus format strings.
+ ((not ignore-missing)
+ (error "Invalid format string"))))
(buffer-string)))
-(defun format-spec--pad (text total-length modifiers)
- (if (> (length text) total-length)
- ;; The text is longer than the specified length; do nothing.
- text
- (let ((padding (make-string (- total-length (length text))
- (if (memq :zero-pad modifiers)
- ?0
- ?\s))))
- (if (memq :right-pad modifiers)
- (concat text padding)
- (concat padding text)))))
-
-(defun format-spec--parse-modifiers (modifiers)
+(defun format-spec--do-flags (str flags width trunc)
+ "Return STR formatted according to FLAGS, WIDTH, and TRUNC.
+FLAGS is a list of keywords as returned by
+`format-spec--parse-flags'. WIDTH and TRUNC are either nil or
+string widths corresponding to `format-spec' modifiers."
+ (let (diff str-width)
+ ;; Truncate original string first, like `format' does.
+ (when trunc
+ (setq str-width (string-width str))
+ (when (> (setq diff (- str-width trunc)) 0)
+ (setq str (if (memq :chop-left flags)
+ (truncate-string-to-width str str-width diff)
+ (format (format "%%.%ds" trunc) str))
+ ;; We know the new width so save it for later.
+ str-width trunc)))
+ ;; Pad or chop to width.
+ (when width
+ (setq str-width (or str-width (string-width str))
+ diff (- width str-width))
+ (cond ((zerop diff))
+ ((> diff 0)
+ (let ((pad (make-string diff (if (memq :pad-zero flags) ?0 ?\s))))
+ (setq str (if (memq :pad-right flags)
+ (concat str pad)
+ (concat pad str)))))
+ ((memq :chop-left flags)
+ (setq str (truncate-string-to-width str str-width (- diff))))
+ ((memq :chop-right flags)
+ (setq str (format (format "%%.%ds" width) str))))))
+ ;; Fiddle case.
+ (cond ((memq :upcase flags)
+ (upcase str))
+ ((memq :downcase flags)
+ (downcase str))
+ (str)))
+
+(defun format-spec--parse-flags (flags)
+ "Convert sequence of FLAGS to list of human-readable keywords."
(mapcan (lambda (char)
- (when-let ((modifier
- (pcase char
- (?0 :zero-pad)
- (?\s :space-pad)
- (?^ :uppercase)
- (?_ :lowercase)
- (?- :right-pad)
- (?< :chop-left)
- (?> :chop-right))))
- (list modifier)))
- modifiers))
+ (pcase char
+ (?0 (list :pad-zero))
+ (?- (list :pad-right))
+ (?< (list :chop-left))
+ (?> (list :chop-right))
+ (?^ (list :upcase))
+ (?_ (list :downcase))))
+ flags))
(defun format-spec-make (&rest pairs)
"Return an alist suitable for use in `format-spec' based on PAIRS.
-PAIRS is a list where every other element is a character and a value,
-starting with a character."
+PAIRS is a property list with characters as keys."
(let (alist)
(while pairs
(unless (cdr pairs)
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index da6231d..5028da5 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -223,13 +223,10 @@ easy interactive way to set this from the Server buffer."
(t
(gnus-message 1 "Unknown type %s; ignoring" type))))))
-(defun gnus-cloud-update-newsrc-data (group elem &optional force-older)
- "Update the newsrc data for GROUP from ELEM.
-Use old data if FORCE-OLDER is not nil."
+(defun gnus-cloud-update-newsrc-data (group elem)
+ "Update the newsrc data for GROUP from ELEM."
(let* ((contents (plist-get elem :contents))
(date (or (plist-get elem :timestamp) "0"))
- (now (gnus-cloud-timestamp nil))
- (newer (string-lessp date now))
(group-info (gnus-get-info group)))
(if (and contents
(stringp (nth 0 contents))
@@ -238,15 +235,13 @@ Use old data if FORCE-OLDER is not nil."
(if (equal (format "%S" group-info)
(format "%S" contents))
(gnus-message 3 "Skipping cloud update of group %s, the info
is the same" group)
- (if (and newer (not force-older))
- (gnus-message 3 "Skipping outdated cloud info for group %s,
the info is from %s (now is %s)" group date now)
- (when (or (not gnus-cloud-interactive)
- (gnus-y-or-n-p
- (format "%s has older different info in the cloud
as of %s, update it here? "
- group date)))
- (gnus-message 2 "Installing cloud update of group %s" group)
- (gnus-set-info group contents)
- (gnus-group-update-group group))))
+ (when (or (not gnus-cloud-interactive)
+ (gnus-y-or-n-p
+ (format "%s has different info in the cloud from %s,
update it here? "
+ group date)))
+ (gnus-message 2 "Installing cloud update of group %s" group)
+ (gnus-set-info group contents)
+ (gnus-group-update-group group)))
(gnus-error 1 "Sorry, group %s is not subscribed" group))
(gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data
%S)"
group elem))))
@@ -380,8 +375,9 @@ When FULL is t, upload everything, not just a difference
from the last full."
(gnus-cloud-files-to-upload full)
(gnus-cloud-collect-full-newsrc)))
(group (gnus-group-full-name gnus-cloud-group-name
gnus-cloud-method)))
+ (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
(insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n"
- (or gnus-cloud-sequence "UNKNOWN")
+ gnus-cloud-sequence
(if full :full :partial)
gnus-cloud-storage-method))
(insert "From: nobody@gnus.cloud.invalid\n")
@@ -390,7 +386,6 @@ When FULL is t, upload everything, not just a difference
from the last full."
(if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method
t t)
(progn
- (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0)))
(gnus-cloud-add-timestamps elems)
(gnus-message 3 "Uploaded Gnus Cloud data successfully to %s"
group)
(gnus-group-refresh-group group))
@@ -459,18 +454,21 @@ instead of `gnus-cloud-sequence'.
When UPDATE is t, returns the result of calling `gnus-cloud-update-all'.
Otherwise, returns the Gnus Cloud data chunks."
(let ((articles nil)
+ (highest-sequence-seen gnus-cloud-sequence)
chunks)
(dolist (header (gnus-cloud-available-chunks))
- (when (> (gnus-cloud-chunk-sequence (mail-header-subject header))
- (or sequence-override gnus-cloud-sequence -1))
-
- (if (string-match (format "storage-method: %s"
gnus-cloud-storage-method)
- (mail-header-subject header))
- (push (mail-header-number header) articles)
- (gnus-message 1 "Skipping article %s because it didn't match the
Gnus Cloud method %s: %s"
- (mail-header-number header)
- gnus-cloud-storage-method
- (mail-header-subject header)))))
+ (let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject
header))))
+ (when (> this-sequence (or sequence-override gnus-cloud-sequence -1))
+
+ (if (string-match (format "storage-method: %s"
gnus-cloud-storage-method)
+ (mail-header-subject header))
+ (progn
+ (push (mail-header-number header) articles)
+ (setq highest-sequence-seen (max highest-sequence-seen
this-sequence)))
+ (gnus-message 1 "Skipping article %s because it didn't match the
Gnus Cloud method %s: %s"
+ (mail-header-number header)
+ gnus-cloud-storage-method
+ (mail-header-subject header))))))
(when articles
(nnimap-request-articles (nreverse articles) gnus-cloud-group-name)
(with-current-buffer nntp-server-buffer
@@ -480,7 +478,9 @@ Otherwise, returns the Gnus Cloud data chunks."
(push (gnus-cloud-parse-chunk) chunks)
(forward-line 1))))
(if update
- (mapcar #'gnus-cloud-update-all chunks)
+ (progn
+ (mapc #'gnus-cloud-update-all chunks)
+ (setq gnus-cloud-sequence highest-sequence-seen))
chunks)))
(defun gnus-cloud-server-p (server)
diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el
index 54118aa..1bc1261e 100644
--- a/lisp/gnus/gnus-eform.el
+++ b/lisp/gnus/gnus-eform.el
@@ -50,13 +50,13 @@
(defvar gnus-edit-form-buffer "*Gnus edit form*")
(defvar gnus-edit-form-done-function nil)
-(defvar gnus-edit-form-mode-map nil)
-(unless gnus-edit-form-mode-map
- (setq gnus-edit-form-mode-map (make-sparse-keymap))
- (set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map)
- (gnus-define-keys gnus-edit-form-mode-map
- "\C-c\C-c" gnus-edit-form-done
- "\C-c\C-k" gnus-edit-form-exit))
+(defvar gnus-edit-form-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map emacs-lisp-mode-map)
+ (gnus-define-keys map
+ "\C-c\C-c" gnus-edit-form-done
+ "\C-c\C-k" gnus-edit-form-exit)
+ map))
(defun gnus-edit-form-make-menu-bar ()
(unless (boundp 'gnus-edit-form-menu)
@@ -67,9 +67,9 @@
["Exit" gnus-edit-form-exit t]))
(gnus-run-hooks 'gnus-edit-form-menu-hook)))
-(define-derived-mode gnus-edit-form-mode fundamental-mode "Edit Form"
+(define-derived-mode gnus-edit-form-mode lisp-data-mode "Edit Form"
"Major mode for editing forms.
-It is a slightly enhanced emacs-lisp-mode.
+It is a slightly enhanced `lisp-data-mode'.
\\{gnus-edit-form-mode-map}"
(when (gnus-visual-p 'group-menu 'menu)
diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el
index 278e3a5..5d8f9b5 100644
--- a/lisp/gnus/gnus-sieve.el
+++ b/lisp/gnus/gnus-sieve.el
@@ -29,8 +29,6 @@
(require 'gnus)
(require 'gnus-sum)
-(require 'format-spec)
-(autoload 'sieve-mode "sieve-mode")
(eval-when-compile
(require 'sieve))
@@ -88,10 +86,10 @@ See the documentation for these variables and functions for
details."
(save-buffer)
(shell-command
(format-spec gnus-sieve-update-shell-command
- (format-spec-make ?f gnus-sieve-file
- ?s (or (cadr (gnus-server-get-method
- nil gnus-sieve-select-method))
- "")))))
+ `((?f . ,gnus-sieve-file)
+ (?s . ,(or (cadr (gnus-server-get-method
+ nil gnus-sieve-select-method))
+ ""))))))
;;;###autoload
(defun gnus-sieve-generate ()
diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el
index 218a154..485d58a 100644
--- a/lisp/gnus/gssapi.el
+++ b/lisp/gnus/gssapi.el
@@ -25,8 +25,6 @@
;;; Code:
-(require 'format-spec)
-
(defcustom gssapi-program (list
(concat "gsasl %s %p "
"--mechanism GSSAPI "
@@ -53,12 +51,9 @@ tried until a successful connection is made."
(coding-system-for-write 'binary)
(process (start-process
name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?p (number-to-string port)
- ?l user))))
+ (format-spec cmd `((?s . ,server)
+ (?p . ,(number-to-string port))
+ (?l . ,user)))))
response)
(when process
(while (and (memq (process-status process) '(open run))
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index acf35a3..4318072 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -24,7 +24,6 @@
;;; Code:
-(require 'format-spec)
(eval-when-compile
(require 'cl-lib)
(require 'imap))
@@ -769,14 +768,14 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff
bfile)
"Fetcher for single-file sources."
(mail-source-bind (file source)
(mail-source-run-script
- prescript (format-spec-make ?t mail-source-crash-box)
+ prescript `((?t . ,mail-source-crash-box))
prescript-delay)
(let ((mail-source-string (format "file:%s" path)))
(if (mail-source-movemail path mail-source-crash-box)
(prog1
(mail-source-callback callback path)
(mail-source-run-script
- postscript (format-spec-make ?t mail-source-crash-box))
+ postscript `((?t . ,mail-source-crash-box)))
(mail-source-delete-crash-box))
0))))
@@ -784,7 +783,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff
bfile)
"Fetcher for directory sources."
(mail-source-bind (directory source)
(mail-source-run-script
- prescript (format-spec-make ?t path) prescript-delay)
+ prescript `((?t . ,path)) prescript-delay)
(let ((found 0)
(mail-source-string (format "directory:%s" path)))
(dolist (file (directory-files
@@ -793,7 +792,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff
bfile)
(funcall predicate file)
(mail-source-movemail file mail-source-crash-box))
(cl-incf found (mail-source-callback callback file))
- (mail-source-run-script postscript (format-spec-make ?t path))
+ (mail-source-run-script postscript `((?t . ,path)))
(mail-source-delete-crash-box)))
found)))
@@ -803,8 +802,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff
bfile)
;; fixme: deal with stream type in format specs
(mail-source-run-script
prescript
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user)
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user))
prescript-delay)
(let ((from (format "%s:%s:%s" server user port))
(mail-source-string (format "pop:%s@%s" user server))
@@ -825,8 +824,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff
bfile)
(mail-source-fetch-with-program
(format-spec
program
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user))))
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))))
(function
(funcall function mail-source-crash-box))
;; The default is to use pop3.el.
@@ -863,8 +862,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff
bfile)
(setq mail-source-new-mail-available nil))
(mail-source-run-script
postscript
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user))
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))
(mail-source-delete-crash-box)))
;; We nix out the password in case the error
;; was because of a wrong password being given.
@@ -1077,8 +1076,9 @@ This only works when `display-time' is enabled."
"Fetcher for imap sources."
(mail-source-bind (imap source)
(mail-source-run-script
- prescript (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user)
+ prescript
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user))
prescript-delay)
(let ((from (format "%s:%s:%s" server user port))
(found 0)
@@ -1143,8 +1143,8 @@ This only works when `display-time' is enabled."
(kill-buffer buf)
(mail-source-run-script
postscript
- (format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user))
+ `((?p . ,password) (?t . ,mail-source-crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))
found)))
(provide 'mail-source)
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 5a6827a..fb560f0 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -42,13 +42,12 @@
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(require 'format-spec)
(require 'dired)
(require 'mm-util)
(require 'rfc2047)
(require 'puny)
-(require 'rmc) ; read-multiple-choice
-(eval-when-compile (require 'subr-x)) ; when-let*
+(require 'rmc) ; read-multiple-choice
+(eval-when-compile (require 'subr-x))
(autoload 'mailclient-send-it "mailclient")
@@ -440,8 +439,8 @@ whitespace)."
(defcustom message-elide-ellipsis "\n[...]\n\n"
"The string which is inserted for elided text.
-This is a format-spec string, and you can use %l to say how many
-lines were removed, and %c to say how many characters were
+This is a `format-spec' string, and you can use %l to say how
+many lines were removed, and %c to say how many characters were
removed."
:type 'string
:link '(custom-manual "(message)Various Commands")
@@ -3977,7 +3976,6 @@ This function uses `mail-citation-hook' if that is
non-nil."
"Cite function in the standard Message manner."
(message-cite-original-1 nil))
-(autoload 'format-spec "format-spec")
(autoload 'gnus-date-get-time "gnus-util")
(defun message-insert-formatted-citation-line (&optional from date tz)
@@ -4002,20 +4000,18 @@ See `message-citation-line-format'."
(when (or message-reply-headers (and from date))
(unless from
(setq from (mail-header-from message-reply-headers)))
- (let* ((data (condition-case ()
- (funcall (if (boundp 'gnus-extract-address-components)
- gnus-extract-address-components
- 'mail-extract-address-components)
- from)
- (error nil)))
+ (let* ((data (ignore-errors
+ (funcall (or (bound-and-true-p
+ gnus-extract-address-components)
+ #'mail-extract-address-components)
+ from)))
(name (car data))
(fname name)
(lname name)
- (net (car (cdr data)))
- (name-or-net (or (car data)
- (car (cdr data)) from))
+ (net (cadr data))
+ (name-or-net (or name net from))
(time
- (when (string-match "%[^fnNFL]" message-citation-line-format)
+ (when (string-match-p "%[^FLNfn]" message-citation-line-format)
(cond ((numberp (car-safe date)) date) ;; backward compatibility
(date (gnus-date-get-time date))
(t
@@ -4024,68 +4020,53 @@ See `message-citation-line-format'."
(tz (or tz
(when (stringp date)
(nth 8 (parse-time-string date)))))
- (flist
- (let ((i ?A) lst)
- (when (stringp name)
- ;; Guess first name and last name:
- (let* ((names (delq
- nil
- (mapcar
- (lambda (x)
- (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'"
- x)
- x
- nil))
- (split-string name "[ \t]+"))))
- (count (length names)))
- (cond ((= count 1)
- (setq fname (car names)
- lname ""))
- ((or (= count 2) (= count 3))
- (setq fname (car names)
- lname (mapconcat 'identity (cdr names) " ")))
- ((> count 3)
- (setq fname (mapconcat 'identity
- (butlast names (- count 2))
- " ")
- lname (mapconcat 'identity
- (nthcdr 2 names)
- " "))))
- (when (string-match "\\(.*\\),\\'" fname)
- (let ((newlname (match-string 1 fname)))
- (setq fname lname lname newlname)))))
- ;; The following letters are not used in `format-time-string':
- (push ?E lst) (push "<E>" lst)
- (push ?F lst) (push (or fname name-or-net) lst)
- ;; We might want to use "" instead of "<X>" later.
- (push ?J lst) (push "<J>" lst)
- (push ?K lst) (push "<K>" lst)
- (push ?L lst) (push lname lst)
- (push ?N lst) (push name-or-net lst)
- (push ?O lst) (push "<O>" lst)
- (push ?P lst) (push "<P>" lst)
- (push ?Q lst) (push "<Q>" lst)
- (push ?f lst) (push from lst)
- (push ?i lst) (push "<i>" lst)
- (push ?n lst) (push net lst)
- (push ?o lst) (push "<o>" lst)
- (push ?q lst) (push "<q>" lst)
- (push ?t lst) (push "<t>" lst)
- (push ?v lst) (push "<v>" lst)
- ;; Delegate the rest to `format-time-string':
- (while (<= i ?z)
- (when (and (not (memq i lst))
- ;; Skip (Z,a)
- (or (<= i ?Z)
- (>= i ?a)))
- (push i lst)
- (push (condition-case nil
- (format-time-string (format "%%%c" i) time tz)
- (error (format ">%c<" i)))
- lst))
- (setq i (1+ i)))
- (reverse lst)))
- (spec (apply 'format-spec-make flist)))
+ spec)
+ (when (stringp name)
+ ;; Guess first name and last name:
+ (let* ((names (seq-filter
+ (lambda (s)
+ (string-match-p (rx bos (+ (in word ?. ?-)) eos) s))
+ (split-string name "[ \t]+")))
+ (count (length names)))
+ (cond ((= count 1)
+ (setq fname (car names)
+ lname ""))
+ ((or (= count 2) (= count 3))
+ (setq fname (car names)
+ lname (string-join (cdr names) " ")))
+ ((> count 3)
+ (setq fname (string-join (butlast names (- count 2))
+ " ")
+ lname (string-join (nthcdr 2 names) " "))))
+ (when (string-match "\\(.*\\),\\'" fname)
+ (let ((newlname (match-string 1 fname)))
+ (setq fname lname lname newlname)))))
+ ;; The following letters are not used in `format-time-string':
+ (push (cons ?E "<E>") spec)
+ (push (cons ?F (or fname name-or-net)) spec)
+ ;; We might want to use "" instead of "<X>" later.
+ (push (cons ?J "<J>") spec)
+ (push (cons ?K "<K>") spec)
+ (push (cons ?L lname) spec)
+ (push (cons ?N name-or-net) spec)
+ (push (cons ?O "<O>") spec)
+ (push (cons ?P "<P>") spec)
+ (push (cons ?Q "<Q>") spec)
+ (push (cons ?f from) spec)
+ (push (cons ?i "<i>") spec)
+ (push (cons ?n net) spec)
+ (push (cons ?o "<o>") spec)
+ (push (cons ?q "<q>") spec)
+ (push (cons ?t "<t>") spec)
+ (push (cons ?v "<v>") spec)
+ ;; Delegate the rest to `format-time-string':
+ (dolist (c (nconc (number-sequence ?A ?Z)
+ (number-sequence ?a ?z)))
+ (unless (assq c spec)
+ (push (cons c (condition-case nil
+ (format-time-string (format "%%%c" c) time tz)
+ (error (format ">%c<" c))))
+ spec)))
(insert (format-spec message-citation-line-format spec)))
(newline)))
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index 60ef024..3747ae3 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -300,7 +300,10 @@ if that doesn't produce a completion match."
(interactive)
(if (and (eq (char-before) ?/)
(eq (icomplete--category) 'file))
- (zap-up-to-char -1 ?/)
+ (save-excursion
+ (goto-char (1- (point)))
+ (when (search-backward "/" (point-min) t)
+ (delete-region (1+ (point)) (point-max))))
(call-interactively 'backward-delete-char)))
(defvar icomplete-fido-mode-map
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index 1cc38ba..6f29767 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -149,7 +149,6 @@
;;; Code:
(require 'dired)
-(require 'format-spec)
(require 'image-mode)
(require 'widget)
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 480b2e6..1bb213c 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -456,6 +456,7 @@ call."
(define-key map "sb" 'image-transform-fit-both)
(define-key map "ss" 'image-transform-set-scale)
(define-key map "sr" 'image-transform-set-rotation)
+ (define-key map "so" 'image-transform-original)
(define-key map "s0" 'image-transform-reset)
;; Multi-frame keys
@@ -521,8 +522,10 @@ call."
:help "Rotate the image"]
["Set Rotation..." image-transform-set-rotation
:help "Set rotation angle of the image"]
- ["Reset Transformations" image-transform-reset
- :help "Reset all image transformations"]
+ ["Original Size" image-transform-original
+ :help "Reset image to actual size"]
+ ["Reset to Default Size" image-transform-reset
+ :help "Reset all image transformations to initial size"]
"--"
["Show Thumbnails"
(lambda ()
@@ -807,8 +810,12 @@ was inserted."
filename))
;; If we have a `fit-width' or a `fit-height', don't limit
;; the size of the image to the window size.
- (edges (and (eq image-transform-resize t)
- (window-inside-pixel-edges (get-buffer-window))))
+ (edges (when (eq image-transform-resize t)
+ (window-inside-pixel-edges (get-buffer-window))))
+ (max-width (when edges
+ (- (nth 2 edges) (nth 0 edges))))
+ (max-height (when edges
+ (- (nth 3 edges) (nth 1 edges))))
(type (if (image--imagemagick-wanted-p filename)
'imagemagick
(image-type file-or-data nil data-p)))
@@ -824,14 +831,18 @@ was inserted."
(ignore-error exif-error
(exif-parse-buffer)))
0.0)))
+ ;; Swap width and height when changing orientation
+ ;; between portrait and landscape.
+ (when (and edges (zerop (mod (+ image-transform-rotation 90) 180)))
+ (setq max-width (prog1 max-height (setq max-height max-width))))
;; :scale 1: If we do not set this, create-image will apply
;; default scaling based on font size.
(setq image (if (not edges)
(create-image file-or-data type data-p :scale 1)
(create-image file-or-data type data-p :scale 1
- :max-width (- (nth 2 edges) (nth 0 edges))
- :max-height (- (nth 3 edges) (nth 1 edges)))))
+ :max-width max-width
+ :max-height max-height)))
;; Discard any stale image data before looking it up again.
(image-flush image)
@@ -1382,8 +1393,15 @@ ROTATION should be in degrees."
(setq image-transform-rotation (float (mod rotation 360)))
(image-toggle-display-image))
+(defun image-transform-original ()
+ "Display the current image with the original (actual) size and rotation."
+ (interactive)
+ (setq image-transform-resize nil
+ image-transform-scale 1)
+ (image-toggle-display-image))
+
(defun image-transform-reset ()
- "Display the current image with the default size and rotation."
+ "Display the current image with the default (initial) size and rotation."
(interactive)
(setq image-transform-resize image-auto-resize
image-transform-rotation 0.0
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 4538399..fdd726f 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -51,9 +51,6 @@
(unless (boundp 'dbus-debug)
(defvar dbus-debug nil))
-;; Pacify byte compiler.
-(eval-when-compile (require 'cl-lib))
-
(require 'xml)
(defconst dbus-service-dbus "org.freedesktop.DBus"
@@ -169,10 +166,7 @@ Otherwise, return result of last form in BODY, or all
other errors."
`(condition-case err
(progn ,@body)
(dbus-error (when dbus-debug (signal (car err) (cdr err))))))
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
-(define-obsolete-variable-alias 'dbus-event-error-hooks
- 'dbus-event-error-functions "24.3")
(defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors)
"Functions to be called when a D-Bus error happens in the event handler.
Every function must accept two arguments, the event and the error variable
@@ -181,8 +175,8 @@ caught in `condition-case' by `dbus-error'.")
;;; Basic D-Bus message functions.
-(defvar dbus-return-values-table (make-hash-table :test 'equal)
- "Hash table for temporary storing arguments of reply messages.
+(defvar dbus-return-values-table (make-hash-table :test #'equal)
+ "Hash table for temporarily storing arguments of reply messages.
A key in this hash table is a list (:serial BUS SERIAL), like in
`dbus-registered-objects-table'. BUS is either a Lisp symbol,
`:system' or `:session', or a string denoting the bus address.
@@ -225,10 +219,10 @@ SERVICE is the D-Bus service name to be used. PATH is
the D-Bus
object path SERVICE is registered at. INTERFACE is an interface
offered by SERVICE. It must provide METHOD.
-If the parameter `:timeout' is given, the following integer TIMEOUT
-specifies the maximum number of milliseconds the method call must
-return. The default value is 25,000. If the method call doesn't
-return in time, a D-Bus error is raised.
+If the parameter `:timeout' is given, the following integer
+TIMEOUT specifies the maximum number of milliseconds before the
+method call must return. The default value is 25,000. If the
+method call doesn't return in time, a D-Bus error is raised.
All other arguments ARGS are passed to METHOD as arguments. They are
converted into D-Bus types via the following rules:
@@ -248,14 +242,14 @@ Lisp objects. The type conversion happens the other
direction as for
input arguments. It follows the mapping rules:
DBUS_TYPE_BOOLEAN => t or nil
- DBUS_TYPE_BYTE => number
- DBUS_TYPE_UINT16 => number
+ DBUS_TYPE_BYTE => natural number
+ DBUS_TYPE_UINT16 => natural number
DBUS_TYPE_INT16 => integer
- DBUS_TYPE_UINT32 => number or float
- DBUS_TYPE_UNIX_FD => number or float
- DBUS_TYPE_INT32 => integer or float
- DBUS_TYPE_UINT64 => number or float
- DBUS_TYPE_INT64 => integer or float
+ DBUS_TYPE_UINT32 => natural number
+ DBUS_TYPE_UNIX_FD => natural number
+ DBUS_TYPE_INT32 => integer
+ DBUS_TYPE_UINT64 => natural number
+ DBUS_TYPE_INT64 => integer
DBUS_TYPE_DOUBLE => float
DBUS_TYPE_STRING => string
DBUS_TYPE_OBJECT_PATH => string
@@ -268,9 +262,9 @@ input arguments. It follows the mapping rules:
Example:
\(dbus-call-method
- :session \"org.gnome.seahorse\" \"/org/gnome/seahorse/keys/openpgp\"
- \"org.gnome.seahorse.Keys\" \"GetKeyField\"
- \"openpgp:657984B8C7A966DD\" \"simple-name\")
+ :session \"org.gnome.seahorse\" \"/org/gnome/seahorse/keys/openpgp\"
+ \"org.gnome.seahorse.Keys\" \"GetKeyField\"
+ \"openpgp:657984B8C7A966DD\" \"simple-name\")
=> (t (\"Philip R. Zimmermann\"))
@@ -278,9 +272,9 @@ If the result of the METHOD call is just one value, the
converted Lisp
object is returned instead of a list containing this single Lisp object.
\(dbus-call-method
- :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
- \"org.freedesktop.Hal.Device\" \"GetPropertyString\"
- \"system.kernel.machine\")
+ :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
+ \"org.freedesktop.Hal.Device\" \"GetPropertyString\"
+ \"system.kernel.machine\")
=> \"i686\""
@@ -301,8 +295,8 @@ object is returned instead of a list containing this single
Lisp object.
(check-interval 0.001)
(key
(apply
- 'dbus-message-internal dbus-message-type-method-call
- bus service path interface method 'dbus-call-method-handler args))
+ #'dbus-message-internal dbus-message-type-method-call
+ bus service path interface method #'dbus-call-method-handler args))
(result (cons :pending nil)))
;; Wait until `dbus-call-method-handler' has put the result into
@@ -338,10 +332,6 @@ object is returned instead of a list containing this
single Lisp object.
(cdr result))
(remhash key dbus-return-values-table))))
-;; `dbus-call-method' works non-blocking now.
-(defalias 'dbus-call-method-non-blocking 'dbus-call-method)
-(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3")
-
(defun dbus-call-method-asynchronously
(bus service path interface method handler &rest args)
"Call METHOD on the D-Bus BUS asynchronously.
@@ -357,10 +347,10 @@ HANDLER is a Lisp function, which is called when the
corresponding
return message has arrived. If HANDLER is nil, no return message
will be expected.
-If the parameter `:timeout' is given, the following integer TIMEOUT
-specifies the maximum number of milliseconds the method call must
-return. The default value is 25,000. If the method call doesn't
-return in time, a D-Bus error is raised.
+If the parameter `:timeout' is given, the following integer
+TIMEOUT specifies the maximum number of milliseconds before the
+method call must return. The default value is 25,000. If the
+method call doesn't return in time, a D-Bus error is raised.
All other arguments ARGS are passed to METHOD as arguments. They are
converted into D-Bus types via the following rules:
@@ -377,19 +367,19 @@ type symbols, see Info node `(dbus)Type Conversion'.
If HANDLER is a Lisp function, the function returns a key into the
hash table `dbus-registered-objects-table'. The corresponding entry
-in the hash table is removed, when the return message has been arrived,
+in the hash table is removed, when the return message arrives,
and HANDLER is called.
Example:
\(dbus-call-method-asynchronously
- :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
- \"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message
- \"system.kernel.machine\")
+ :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\"
+ \"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message
+ \"system.kernel.machine\")
- => (:serial :system 2)
+ -| i686
- -| i686"
+ => (:serial :system 2)"
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
@@ -406,7 +396,7 @@ Example:
(or (null handler) (functionp handler)
(signal 'wrong-type-argument (list 'functionp handler)))
- (apply 'dbus-message-internal dbus-message-type-method-call
+ (apply #'dbus-message-internal dbus-message-type-method-call
bus service path interface method handler args))
(defun dbus-send-signal (bus service path interface signal &rest args)
@@ -438,8 +428,8 @@ type symbols, see Info node `(dbus)Type Conversion'.
Example:
\(dbus-send-signal
- :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\"
- \"FileModified\" \"/home/albinus/.emacs\")"
+ :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\"
+ \"FileModified\" \"/home/albinus/.emacs\")"
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
@@ -454,7 +444,7 @@ Example:
(or (stringp signal)
(signal 'wrong-type-argument (list 'stringp signal)))
- (apply 'dbus-message-internal dbus-message-type-signal
+ (apply #'dbus-message-internal dbus-message-type-signal
bus service path interface signal args))
(defun dbus-method-return-internal (bus service serial &rest args)
@@ -470,7 +460,7 @@ This is an internal function, it shall not be used outside
dbus.el."
(or (natnump serial)
(signal 'wrong-type-argument (list 'natnump serial)))
- (apply 'dbus-message-internal dbus-message-type-method-return
+ (apply #'dbus-message-internal dbus-message-type-method-return
bus service serial args))
(defun dbus-method-error-internal (bus service serial &rest args)
@@ -486,7 +476,7 @@ This is an internal function, it shall not be used outside
dbus.el."
(or (natnump serial)
(signal 'wrong-type-argument (list 'natnump serial)))
- (apply 'dbus-message-internal dbus-message-type-error
+ (apply #'dbus-message-internal dbus-message-type-error
bus service serial args))
@@ -552,13 +542,13 @@ placed in the queue.
`:already-owner': Service is already the primary owner."
;; Add Peer handler.
- (dbus-register-method
- bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler
'dont-register)
+ (dbus-register-method bus service nil dbus-interface-peer "Ping"
+ #'dbus-peer-handler 'dont-register)
;; Add ObjectManager handler.
(dbus-register-method
bus service nil dbus-interface-objectmanager "GetManagedObjects"
- 'dbus-managed-objects-handler 'dont-register)
+ #'dbus-managed-objects-handler 'dont-register)
(let ((arg 0)
reply)
@@ -625,17 +615,17 @@ SERVICE is the D-Bus service name used by the sending
D-Bus object.
It can be either a known name or the unique name of the D-Bus object
sending the signal.
-PATH is the D-Bus object path SERVICE is registered. INTERFACE
-is an interface offered by SERVICE. It must provide SIGNAL.
-HANDLER is a Lisp function to be called when the signal is
-received. It must accept as arguments the values SIGNAL is
+PATH is the D-Bus object path SERVICE is registered at.
+INTERFACE is an interface offered by SERVICE. It must provide
+SIGNAL. HANDLER is a Lisp function to be called when the signal
+is received. It must accept as arguments the values SIGNAL is
sending.
SERVICE, PATH, INTERFACE and SIGNAL can be nil. This is
interpreted as a wildcard for the respective argument.
The remaining arguments ARGS can be keywords or keyword string pairs.
-The meaning is as follows:
+Their meaning is as follows:
`:argN' STRING:
`:pathN' STRING: This stands for the Nth argument of the
@@ -643,8 +633,9 @@ signal. `:pathN' arguments can be used for object path
wildcard
matches as specified by D-Bus, while an `:argN' argument
requires an exact match.
-`:arg-namespace' STRING: Register for the signals, which first
-argument defines the service or interface namespace STRING.
+`:arg-namespace' STRING: Register for those signals, whose first
+argument names a service or interface within the namespace
+STRING.
`:path-namespace' STRING: Register for the object path namespace
STRING. All signals sent from an object path, which has STRING as
@@ -660,8 +651,8 @@ Example:
(message \"Device %s added\" device))
\(dbus-register-signal
- :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\"
- \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler)
+ :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\"
+ \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler)
=> ((:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\")
(\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\"
my-signal-handler))
@@ -680,7 +671,7 @@ Example:
(if (and (stringp service)
(not (zerop (length service)))
(not (string-equal service dbus-service-dbus))
- (not (string-match "^:" service)))
+ (/= (string-to-char service) ?:))
(setq uname (dbus-get-name-owner bus service))
(setq uname service))
@@ -709,7 +700,7 @@ Example:
;; `:arg0' .. `:arg63', `:path0' .. `:path63'.
((and (keywordp key)
(string-match
- "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$"
+ "\\`:\\(arg\\|path\\)\\([[:digit:]]+\\)\\'"
(symbol-name key)))
(setq counter (match-string 2 (symbol-name key))
args (cdr args)
@@ -725,9 +716,7 @@ Example:
"path" "")
value))
;; `:arg-namespace', `:path-namespace'.
- ((and (keywordp key)
- (string-match
- "^:\\(arg\\|path\\)-namespace$" (symbol-name key)))
+ ((memq key '(:arg-namespace :path-namespace))
(setq args (cdr args)
value (car args))
(unless (stringp value)
@@ -735,8 +724,7 @@ Example:
(list "Wrong argument" key value)))
(format
",%s='%s'"
- (if (string-equal (match-string 1 (symbol-name key)) "path")
- "path_namespace" "arg0namespace")
+ (if (eq key :path-namespace) "path_namespace"
"arg0namespace")
value))
;; `:eavesdrop'.
((eq key :eavesdrop)
@@ -750,11 +738,11 @@ Example:
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"AddMatch" rule)
(dbus-error
- (if (not (string-match "eavesdrop" rule))
+ (if (not (string-match-p "eavesdrop" rule))
(signal (car err) (cdr err))
;; The D-Bus spec says we shall fall back to a rule without eavesdrop.
(when dbus-debug (message "Removing eavesdrop from rule %s" rule))
- (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule))
+ (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule t t))
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"AddMatch" rule))))
@@ -773,24 +761,24 @@ Example:
(defun dbus-register-method
(bus service path interface method handler &optional dont-register-service)
- "Register for method METHOD on the D-Bus BUS.
+ "Register METHOD on the D-Bus BUS.
BUS is either a Lisp symbol, `:system' or `:session', or a string
denoting the bus address.
SERVICE is the D-Bus service name of the D-Bus object METHOD is
-registered for. It must be a known name (See discussion of
+registered for. It must be a known name (see discussion of
DONT-REGISTER-SERVICE below).
-PATH is the D-Bus object path SERVICE is registered (See discussion of
-DONT-REGISTER-SERVICE below). INTERFACE is the interface offered by
-SERVICE. It must provide METHOD.
+PATH is the D-Bus object path SERVICE is registered at (see
+discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
+interface offered by SERVICE. It must provide METHOD.
HANDLER is a Lisp function to be called when a method call is
received. It must accept the input arguments of METHOD. The return
value of HANDLER is used for composing the returning D-Bus message.
-In case HANDLER shall return a reply message with an empty argument
-list, HANDLER must return the symbol `:ignore'.
+If HANDLER returns a reply message with an empty argument list,
+HANDLER must return the symbol `:ignore'.
When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not
registered. This means that other D-Bus clients have no way of
@@ -888,26 +876,21 @@ association to the service from D-Bus."
;;; D-Bus type conversion.
(defun dbus-string-to-byte-array (string)
- "Transform STRING to list (:array :byte c1 :byte c2 ...).
-STRING shall be UTF8 coded."
+ "Transform STRING to list (:array :byte C1 :byte C2 ...).
+STRING shall be UTF-8 coded."
(if (zerop (length string))
'(:array :signature "y")
- (let (result)
- (dolist (elt (string-to-list string) (append '(:array) result))
- (setq result (append result (list :byte elt)))))))
+ (cons :array (mapcan (lambda (c) (list :byte c)) string))))
(defun dbus-byte-array-to-string (byte-array &optional multibyte)
- "Transform BYTE-ARRAY into UTF8 coded string.
+ "Transform BYTE-ARRAY into UTF-8 coded string.
BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte
array as produced by `dbus-string-to-byte-array'. The resulting
string is unibyte encoded, unless MULTIBYTE is non-nil."
(apply
- (if multibyte 'string 'unibyte-string)
- (if (equal byte-array '(:array :signature "y"))
- nil
- (let (result)
- (dolist (elt byte-array result)
- (when (characterp elt) (setq result (append result `(,elt)))))))))
+ (if multibyte #'string #'unibyte-string)
+ (unless (equal byte-array '(:array :signature "y"))
+ (seq-filter #'characterp byte-array))))
(defun dbus-escape-as-identifier (string)
"Escape an arbitrary STRING so it follows the rules for a C identifier.
@@ -920,18 +903,18 @@ lower-case hex digits:
\"0123abc_xyz\\x01\\xff\" -> \"_30123abc_5fxyz_01_ff\"
-i.e. similar to URI encoding, but with \"_\" taking the role of \"%\",
-and a smaller allowed set. As a special case, \"\" is escaped to
-\"_\".
+i.e. similar to URI encoding, but with \"_\" taking the role of
+\"%\", and a smaller allowed set. As a special case, \"\" is
+escaped to \"_\".
Returns the escaped string. Algorithm taken from
telepathy-glib's `tp_escape_as_identifier'."
(if (zerop (length string))
"_"
(replace-regexp-in-string
- "^[0-9]\\|[^A-Za-z0-9]"
+ "\\`[0-9]\\|[^A-Za-z0-9]"
(lambda (x) (format "_%2x" (aref x 0)))
- string)))
+ string nil t)))
(defun dbus-unescape-from-identifier (string)
"Retrieve the original string from the encoded STRING as unibyte string.
@@ -941,7 +924,7 @@ STRING must have been encoded with
`dbus-escape-as-identifier'."
(replace-regexp-in-string
"_.."
(lambda (x) (byte-to-string (string-to-number (substring x 1) 16)))
- string)))
+ string nil t)))
;;; D-Bus events.
@@ -963,8 +946,8 @@ the function which has been registered for this message.
ARGS
are the arguments passed to HANDLER, when it is called during
event handling in `dbus-handle-event'.
-This function raises a `dbus-error' signal in case the event is
-not well formed."
+This function signals a `dbus-error' if the event is not well
+formed."
(when dbus-debug (message "DBus-Event %s" event))
(unless (and (listp event)
(eq (car event) 'dbus-event)
@@ -1019,7 +1002,7 @@ If the HANDLER returns a `dbus-error', it is propagated
as return message."
(if (eq result :ignore)
(dbus-method-return-internal
(nth 1 event) (nth 4 event) (nth 3 event))
- (apply 'dbus-method-return-internal
+ (apply #'dbus-method-return-internal
(nth 1 event) (nth 4 event) (nth 3 event)
(if (consp result) result (list result)))))))
;; Error handling.
@@ -1038,16 +1021,16 @@ If the HANDLER returns a `dbus-error', it is propagated
as return message."
"Return the bus name the event is coming from.
The result is either a Lisp symbol, `:system' or `:session', or a
string denoting the bus address. EVENT is a D-Bus event, see
-`dbus-check-event'. This function raises a `dbus-error' signal
-in case the event is not well formed."
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
(dbus-check-event event)
(nth 1 event))
(defun dbus-event-message-type (event)
"Return the message type of the corresponding D-Bus message.
The result is a number. EVENT is a D-Bus event, see
-`dbus-check-event'. This function raises a `dbus-error' signal
-in case the event is not well formed."
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
(dbus-check-event event)
(nth 2 event))
@@ -1055,41 +1038,40 @@ in case the event is not well formed."
"Return the serial number of the corresponding D-Bus message.
The result is a number. The serial number is needed for
generating a reply message. EVENT is a D-Bus event, see
-`dbus-check-event'. This function raises a `dbus-error' signal
-in case the event is not well formed."
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
(dbus-check-event event)
(nth 3 event))
(defun dbus-event-service-name (event)
"Return the name of the D-Bus object the event is coming from.
The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
-This function raises a `dbus-error' signal in case the event is
-not well formed."
+This function signals a `dbus-error' if the event is not well
+formed."
(dbus-check-event event)
(nth 4 event))
(defun dbus-event-path-name (event)
"Return the object path of the D-Bus object the event is coming from.
The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
-This function raises a `dbus-error' signal in case the event is
-not well formed."
+This function signals a `dbus-error' if the event is not well
+formed."
(dbus-check-event event)
(nth 5 event))
(defun dbus-event-interface-name (event)
"Return the interface name of the D-Bus object the event is coming from.
The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
-This function raises a `dbus-error' signal in case the event is
-not well formed."
+This function signals a `dbus-error' if the event is not well
+formed."
(dbus-check-event event)
(nth 6 event))
(defun dbus-event-member-name (event)
"Return the member name the event is coming from.
-It is either a signal name or a method name. The result is a
+It is either a signal name or a method name. The result is a
string. EVENT is a D-Bus event, see `dbus-check-event'. This
-function raises a `dbus-error' signal in case the event is not
-well formed."
+function signals a `dbus-error' if the event is not well formed."
(dbus-check-event event)
(nth 7 event))
@@ -1097,10 +1079,10 @@ well formed."
;;; D-Bus registered names.
(defun dbus-list-activatable-names (&optional bus)
- "Return the D-Bus service names which can be activated as list.
-If BUS is left nil, `:system' is assumed. The result is a list
-of strings, which is nil when there are no activatable service
-names at all."
+ "Return a list of the D-Bus service names which can be activated.
+BUS defaults to `:system' when nil or omitted. The result is a
+list of strings, which is nil when there are no activatable
+service names at all."
(dbus-ignore-errors
(dbus-call-method
(or bus :system) dbus-service-dbus
@@ -1119,15 +1101,14 @@ unique names for services."
(defun dbus-list-known-names (bus)
"Retrieve all services which correspond to a known name in BUS.
A service has a known name if it doesn't start with \":\"."
- (let (result)
- (dolist (name (dbus-list-names bus) (nreverse result))
- (unless (string-equal ":" (substring name 0 1))
- (push name result)))))
+ (seq-remove (lambda (name)
+ (= (string-to-char name) ?:))
+ (dbus-list-names bus)))
(defun dbus-list-queued-owners (bus service)
"Return the unique names registered at D-Bus BUS and queued for SERVICE.
-The result is a list of strings, or nil when there are no
-queued name owners service names at all."
+The result is a list of strings, or nil when there are no queued
+name owner service names at all."
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus
@@ -1144,13 +1125,13 @@ The result is either a string, or nil if there is no
name owner."
(defun dbus-ping (bus service &optional timeout)
"Check whether SERVICE is registered for D-Bus BUS.
TIMEOUT, a nonnegative integer, specifies the maximum number of
-milliseconds `dbus-ping' must return. The default value is 25,000.
+milliseconds before `dbus-ping' must return. The default value
+is 25,000.
-Note, that this autoloads SERVICE if it is not running yet. If
-it shall be checked whether SERVICE is already running, one shall
-apply
+Note, that this autoloads SERVICE if it is not running yet. To
+check whether SERVICE is already running, you can instead write
- (member service \(dbus-list-known-names bus))"
+ (member service (dbus-list-known-names bus))"
;; "Ping" raises a D-Bus error if SERVICE does not exist.
;; Otherwise, it returns silently with nil.
(condition-case nil
@@ -1182,6 +1163,18 @@ It will be registered for all objects created by
`dbus-register-service'."
;;; D-Bus introspection.
+(defsubst dbus--introspect-names (object tag)
+ "Return the names of the children of OBJECT with TAG."
+ (mapcar (lambda (elt)
+ (dbus-introspect-get-attribute elt "name"))
+ (xml-get-children object tag)))
+
+(defsubst dbus--introspect-name (object tag name)
+ "Return the first child of OBJECT with TAG, whose name is NAME."
+ (seq-find (lambda (elt)
+ (string-equal (dbus-introspect-get-attribute elt "name") name))
+ (xml-get-children object tag)))
+
(defun dbus-introspect (bus service path)
"Return all interfaces and sub-nodes of SERVICE,
registered at object path PATH at bus BUS.
@@ -1197,17 +1190,25 @@ XML format."
bus service path dbus-interface-introspectable "Introspect"
:timeout 1000)))
+(defalias 'dbus--parse-xml-buffer
+ (if (libxml-available-p)
+ (lambda ()
+ (xml-remove-comments (point-min) (point-max))
+ (libxml-parse-xml-region (point-min) (point-max)))
+ (lambda ()
+ (car (xml-parse-region (point-min) (point-max)))))
+ "Compatibility shim for `libxml-parse-xml-region'.")
+
(defun dbus-introspect-xml (bus service path)
"Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
The data are a parsed list. The root object is a \"node\",
representing the object path PATH. The root object can contain
\"interface\" and further \"node\" objects."
- ;; We don't want to raise errors.
- (xml-node-name
- (ignore-errors
- (with-temp-buffer
- (insert (dbus-introspect bus service path))
- (xml-parse-region (point-min) (point-max))))))
+ (with-temp-buffer
+ ;; We don't want to raise errors.
+ (ignore-errors
+ (insert (dbus-introspect bus service path))
+ (dbus--parse-xml-buffer))))
(defun dbus-introspect-get-attribute (object attribute)
"Return the ATTRIBUTE value of D-Bus introspection OBJECT.
@@ -1219,190 +1220,137 @@ the D-Bus specification."
"Return all node names of SERVICE in D-Bus BUS at object path PATH.
It returns a list of strings. The node names stand for further
object paths of the D-Bus service."
- (let ((object (dbus-introspect-xml bus service path))
- result)
- (dolist (elt (xml-get-children object 'node) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names (dbus-introspect-xml bus service path) 'node))
(defun dbus-introspect-get-all-nodes (bus service path)
"Return all node names of SERVICE in D-Bus BUS at object path PATH.
It returns a list of strings, which are further object paths of SERVICE."
- (let ((result (list path)))
- (dolist (elt
- (dbus-introspect-get-node-names bus service path)
- result)
- (setq elt (expand-file-name elt path))
- (setq result
- (append result (dbus-introspect-get-all-nodes bus service elt))))))
+ (cons path (mapcan (lambda (elt)
+ (setq elt (expand-file-name elt path))
+ (dbus-introspect-get-all-nodes bus service elt))
+ (dbus-introspect-get-node-names bus service path))))
(defun dbus-introspect-get-interface-names (bus service path)
"Return all interface names of SERVICE in D-Bus BUS at object path PATH.
It returns a list of strings.
-There will be always the default interface
-\"org.freedesktop.DBus.Introspectable\". Another default
-interface is \"org.freedesktop.DBus.Properties\". If present,
-\"interface\" objects can also have \"property\" objects as
-children, beside \"method\" and \"signal\" objects."
- (let ((object (dbus-introspect-xml bus service path))
- result)
- (dolist (elt (xml-get-children object 'interface) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+The default interface \"org.freedesktop.DBus.Introspectable\" is
+always present. Another default interface is
+\"org.freedesktop.DBus.Properties\". If present, \"interface\"
+objects can also have \"property\" objects as children, beside
+\"method\" and \"signal\" objects."
+ (dbus--introspect-names (dbus-introspect-xml bus service path) 'interface))
(defun dbus-introspect-get-interface (bus service path interface)
"Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH.
-The return value is an XML object. INTERFACE must be a string,
-element of the list returned by `dbus-introspect-get-interface-names'.
-The resulting \"interface\" object can contain \"method\", \"signal\",
+The return value is an XML object. INTERFACE must be a string
+and a member of the list returned by
+`dbus-introspect-get-interface-names'. The resulting
+\"interface\" object can contain \"method\", \"signal\",
\"property\" and \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-xml bus service path) 'interface)))
- (while (and elt
- (not (string-equal
- interface
- (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name (dbus-introspect-xml bus service path)
+ 'interface interface))
(defun dbus-introspect-get-method-names (bus service path interface)
"Return a list of strings of all method names of INTERFACE.
SERVICE is a service of D-Bus BUS at object path PATH."
- (let ((object (dbus-introspect-get-interface bus service path interface))
- result)
- (dolist (elt (xml-get-children object 'method) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (dbus-introspect-get-interface bus service path interface) 'method))
(defun dbus-introspect-get-method (bus service path interface method)
- "Return method METHOD of interface INTERFACE as XML object.
+ "Return method METHOD of interface INTERFACE as an XML object.
It must be located at SERVICE in D-Bus BUS at object path PATH.
-METHOD must be a string, element of the list returned by
+METHOD must be a string and a member of the list returned by
`dbus-introspect-get-method-names'. The resulting \"method\"
object can contain \"arg\" and \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-get-interface bus service path interface)
- 'method)))
- (while (and elt
- (not (string-equal
- method (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (dbus-introspect-get-interface bus service path interface)
+ 'method method))
(defun dbus-introspect-get-signal-names (bus service path interface)
"Return a list of strings of all signal names of INTERFACE.
SERVICE is a service of D-Bus BUS at object path PATH."
- (let ((object (dbus-introspect-get-interface bus service path interface))
- result)
- (dolist (elt (xml-get-children object 'signal) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (dbus-introspect-get-interface bus service path interface) 'signal))
(defun dbus-introspect-get-signal (bus service path interface signal)
- "Return signal SIGNAL of interface INTERFACE as XML object.
+ "Return signal SIGNAL of interface INTERFACE as an XML object.
It must be located at SERVICE in D-Bus BUS at object path PATH.
SIGNAL must be a string, element of the list returned by
`dbus-introspect-get-signal-names'. The resulting \"signal\"
object can contain \"arg\" and \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-get-interface bus service path interface)
- 'signal)))
- (while (and elt
- (not (string-equal
- signal (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (dbus-introspect-get-interface bus service path interface)
+ 'signal signal))
(defun dbus-introspect-get-property-names (bus service path interface)
"Return a list of strings of all property names of INTERFACE.
SERVICE is a service of D-Bus BUS at object path PATH."
- (let ((object (dbus-introspect-get-interface bus service path interface))
- result)
- (dolist (elt (xml-get-children object 'property) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (dbus-introspect-get-interface bus service path interface) 'property))
(defun dbus-introspect-get-property (bus service path interface property)
- "Return PROPERTY of INTERFACE as XML object.
+ "Return PROPERTY of INTERFACE as an XML object.
It must be located at SERVICE in D-Bus BUS at object path PATH.
-PROPERTY must be a string, element of the list returned by
+PROPERTY must be a string and a member of the list returned by
`dbus-introspect-get-property-names'. The resulting PROPERTY
object can contain \"annotation\" children."
- (let ((elt (xml-get-children
- (dbus-introspect-get-interface bus service path interface)
- 'property)))
- (while (and elt
- (not (string-equal
- property
- (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (dbus-introspect-get-interface bus service path interface)
+ 'property property))
(defun dbus-introspect-get-annotation-names
(bus service path interface &optional name)
- "Return all annotation names as list of strings.
+ "Return all annotation names as a list of strings.
If NAME is nil, the annotations are children of INTERFACE,
otherwise NAME must be a \"method\", \"signal\", or \"property\"
object, where the annotations belong to."
- (let ((object
- (if name
- (or (dbus-introspect-get-method bus service path interface name)
- (dbus-introspect-get-signal bus service path interface name)
- (dbus-introspect-get-property bus service path interface name))
- (dbus-introspect-get-interface bus service path interface)))
- result)
- (dolist (elt (xml-get-children object 'annotation) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (if name
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name)
+ (dbus-introspect-get-property bus service path interface name))
+ (dbus-introspect-get-interface bus service path interface))
+ 'annotation))
(defun dbus-introspect-get-annotation
(bus service path interface name annotation)
- "Return ANNOTATION as XML object.
+ "Return ANNOTATION as an XML object.
If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise
NAME must be the name of a \"method\", \"signal\", or
\"property\" object, where the ANNOTATION belongs to."
- (let ((elt (xml-get-children
- (if name
- (or (dbus-introspect-get-method
- bus service path interface name)
- (dbus-introspect-get-signal
- bus service path interface name)
- (dbus-introspect-get-property
- bus service path interface name))
- (dbus-introspect-get-interface bus service path interface))
- 'annotation)))
- (while (and elt
- (not (string-equal
- annotation
- (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+ (dbus--introspect-name
+ (if name
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name)
+ (dbus-introspect-get-property bus service path interface name))
+ (dbus-introspect-get-interface bus service path interface))
+ 'annotation annotation))
(defun dbus-introspect-get-argument-names (bus service path interface name)
- "Return a list of all argument names as list of strings.
+ "Return a list of all argument names as a list of strings.
NAME must be a \"method\" or \"signal\" object.
Argument names are optional, the function can return nil
therefore, even if the method or signal has arguments."
- (let ((object
- (or (dbus-introspect-get-method bus service path interface name)
- (dbus-introspect-get-signal bus service path interface name)))
- result)
- (dolist (elt (xml-get-children object 'arg) (nreverse result))
- (push (dbus-introspect-get-attribute elt "name") result))))
+ (dbus--introspect-names
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name))
+ 'arg))
(defun dbus-introspect-get-argument (bus service path interface name arg)
"Return argument ARG as XML object.
-NAME must be a \"method\" or \"signal\" object. ARG must be a string,
-element of the list returned by `dbus-introspect-get-argument-names'."
- (let ((elt (xml-get-children
- (or (dbus-introspect-get-method bus service path interface name)
- (dbus-introspect-get-signal bus service path interface name))
- 'arg)))
- (while (and elt
- (not (string-equal
- arg (dbus-introspect-get-attribute (car elt) "name"))))
- (setq elt (cdr elt)))
- (car elt)))
+NAME must be a \"method\" or \"signal\" object. ARG must be a
+string and a member of the list returned by
+`dbus-introspect-get-argument-names'."
+ (dbus--introspect-name
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name))
+ 'arg arg))
(defun dbus-introspect-get-signature
(bus service path interface name &optional direction)
- "Return signature of a `method' or `signal', represented by NAME, as string.
+ "Return signature of a `method' or `signal' represented by NAME as a string.
If NAME is a `method', DIRECTION can be either \"in\" or \"out\".
If DIRECTION is nil, \"in\" is assumed.
@@ -1450,9 +1398,8 @@ valid D-Bus value, or nil if there is no PROPERTY."
(defun dbus-set-property (bus service path interface property value)
"Set value of PROPERTY of INTERFACE to VALUE.
-It will be checked at BUS, SERVICE, PATH. When the value has
-been set successful, the result is VALUE. Otherwise, nil is
-returned."
+It will be checked at BUS, SERVICE, PATH. When the value is
+successfully set return VALUE. Otherwise, return nil."
(dbus-ignore-errors
;; "Set" requires a variant.
(dbus-call-method
@@ -1468,26 +1415,23 @@ name of the property, and its value. If there are no
properties,
nil is returned."
(dbus-ignore-errors
;; "GetAll" returns "a{sv}".
- (let (result)
- (dolist (dict
- (dbus-call-method
- bus service path dbus-interface-properties
- "GetAll" :timeout 500 interface)
- (nreverse result))
- (push (cons (car dict) (cl-caadr dict)) result)))))
+ (mapcar (lambda (dict)
+ (cons (car dict) (caadr dict)))
+ (dbus-call-method bus service path dbus-interface-properties
+ "GetAll" :timeout 500 interface))))
(defun dbus-register-property
(bus service path interface property access value
&optional emits-signal dont-register-service)
- "Register property PROPERTY on the D-Bus BUS.
+ "Register PROPERTY on the D-Bus BUS.
BUS is either a Lisp symbol, `:system' or `:session', or a string
denoting the bus address.
SERVICE is the D-Bus service name of the D-Bus. It must be a
-known name (See discussion of DONT-REGISTER-SERVICE below).
+known name (see discussion of DONT-REGISTER-SERVICE below).
-PATH is the D-Bus object path SERVICE is registered (See
+PATH is the D-Bus object path SERVICE is registered at (see
discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
name of the interface used at PATH, PROPERTY is the name of the
property of INTERFACE. ACCESS indicates, whether the property
@@ -1519,13 +1463,13 @@ clients from discovering the still incomplete
interface."
;; Add handlers for the three property-related methods.
(dbus-register-method
bus service path dbus-interface-properties "Get"
- 'dbus-property-handler 'dont-register)
+ #'dbus-property-handler 'dont-register)
(dbus-register-method
bus service path dbus-interface-properties "GetAll"
- 'dbus-property-handler 'dont-register)
+ #'dbus-property-handler 'dont-register)
(dbus-register-method
bus service path dbus-interface-properties "Set"
- 'dbus-property-handler 'dont-register)
+ #'dbus-property-handler 'dont-register)
;; Register SERVICE.
(unless (or dont-register-service (member service (dbus-list-names bus)))
@@ -1625,8 +1569,8 @@ It will be registered for all objects created by
`dbus-register-property'."
"Return all objects at BUS, SERVICE, PATH, and the children of PATH.
The result is a list of objects. Every object is a cons of an
existing path name, and the list of available interface objects.
-An interface object is another cons, which car is the interface
-name, and the cdr is the list of properties as returned by
+An interface object is another cons, whose car is the interface
+name and cdr is the list of properties as returned by
`dbus-get-all-properties' for that path and interface. Example:
\(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\")
@@ -1672,7 +1616,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is
slow."
(if (cadr entry2)
;; "sv".
(dolist (entry3 (cadr entry2))
- (setcdr entry3 (cl-caadr entry3)))
+ (setcdr entry3 (caadr entry3)))
(setcdr entry2 nil)))))
;; Fallback: collect the information. Slooow!
@@ -1729,7 +1673,7 @@ It will be registered for all objects created by
`dbus-register-service'."
(append
(butlast last-input-event 4)
(list object dbus-interface-properties
- "GetAll" 'dbus-property-handler))))
+ "GetAll" #'dbus-property-handler))))
(dbus-property-handler interface))))
(cdr (assoc object result)))))))))
dbus-registered-objects-table)
@@ -1782,12 +1726,13 @@ can be a string denoting the address of the
corresponding bus. For
the system and session buses, this function is called when loading
`dbus.el', there is no need to call it again.
-The function returns a number, which counts the connections this Emacs
-session has established to the BUS under the same unique name (see
-`dbus-get-unique-name'). It depends on the libraries Emacs is linked
-with, and on the environment Emacs is running. For example, if Emacs
-is linked with the gtk toolkit, and it runs in a GTK-aware environment
-like Gnome, another connection might already be established.
+The function returns the number of connections this Emacs session
+has established to the BUS under the same unique name (see
+`dbus-get-unique-name'). It depends on the libraries Emacs is
+linked with, and on the environment Emacs is running. For
+example, if Emacs is linked with the GTK+ toolkit, and it runs in
+a GTK+-aware environment like GNOME, another connection might
+already be established.
When PRIVATE is non-nil, a new connection is established instead of
reusing an existing one. It results in a new unique name at the bus.
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 2a70560..2f6528d 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -25,14 +25,14 @@
;;; Code:
(require 'cl-lib)
-(require 'format-spec)
+(require 'mm-url)
+(require 'puny)
(require 'shr)
+(require 'text-property-search)
+(require 'thingatpt)
(require 'url)
(require 'url-queue)
-(require 'thingatpt)
-(require 'mm-url)
-(require 'puny)
-(eval-when-compile (require 'subr-x)) ;; for string-trim
+(eval-when-compile (require 'subr-x))
(defgroup eww nil
"Emacs Web Wowser"
@@ -543,10 +543,10 @@ Currently this means either text/html or
application/xhtml+xml."
(goto-char point))
(shr-target-id
(goto-char (point-min))
- (let ((point (next-single-property-change
- (point-min) 'shr-target-id)))
- (when point
- (goto-char point))))
+ (let ((match (text-property-search-forward
+ 'shr-target-id shr-target-id t)))
+ (when match
+ (goto-char (prop-match-beginning match)))))
(t
(goto-char (point-min))
;; Don't leave point inside forms, because the normal eww
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index aa10f02..a492dc8 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -136,7 +136,6 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
-(require 'format-spec)
(require 'utf7)
(require 'rfc2104)
;; Hmm... digest-md5 is not part of Emacs.
@@ -517,12 +516,9 @@ sure of changing the value of `foo'."
(process-connection-type imap-process-connection-type)
(process (start-process
name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?p (number-to-string port)
- ?l imap-default-user))))
+ (format-spec cmd `((?s . ,server)
+ (?p . ,(number-to-string port))
+ (?l . ,imap-default-user)))))
response)
(when process
(with-current-buffer buffer
@@ -583,12 +579,9 @@ sure of changing the value of `foo'."
(process-connection-type imap-process-connection-type)
(process (start-process
name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?p (number-to-string port)
- ?l imap-default-user))))
+ (format-spec cmd `((?s . ,server)
+ (?p . ,(number-to-string port))
+ (?l . ,imap-default-user)))))
response)
(when process
(with-current-buffer buffer
@@ -701,13 +694,10 @@ sure of changing the value of `foo'."
(process-connection-type imap-process-connection-type)
(process (start-process
name buffer shell-file-name shell-command-switch
- (format-spec
- cmd
- (format-spec-make
- ?s server
- ?g imap-shell-host
- ?p (number-to-string port)
- ?l imap-default-user)))))
+ (format-spec cmd `((?s . ,server)
+ (?g . ,imap-shell-host)
+ (?p . ,(number-to-string port))
+ (?l . ,imap-default-user))))))
(when process
(while (and (memq (process-status process) '(open run))
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 1d5cf38..1c371f5 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -170,8 +170,8 @@ a greeting from the server.
:nowait, if non-nil, says the connection should be made
asynchronously, if possible.
-:shell-command is a format-spec string that can be used if :type
-is `shell'. It has two specs, %s for host and %p for port
+:shell-command is a `format-spec' string that can be used if
+:type is `shell'. It has two specs, %s for host and %p for port
number. Example: \"ssh gateway nc %s %p\".
:tls-parameters is a list that should be supplied if you're
@@ -453,11 +453,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(network-stream-command stream capability-command eo-capa)
'tls)))))))
-(declare-function format-spec "format-spec" (format spec))
-(declare-function format-spec-make "format-spec" (&rest pairs))
-
(defun network-stream-open-shell (name buffer host service parameters)
- (require 'format-spec)
(let* ((capability-command (plist-get parameters :capability-command))
(eoc (plist-get parameters :end-of-command))
(start (with-current-buffer buffer (point)))
@@ -467,9 +463,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
shell-command-switch
(format-spec
(plist-get parameters :shell-command)
- (format-spec-make
- ?s host
- ?p service))))))
+ `((?s . ,host)
+ (?p . ,service)))))))
(when coding (if (consp coding)
(set-process-coding-system stream
(car coding)
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 03260c9..a3f0496 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -185,13 +185,15 @@ and other things:
(defvar shr-depth 0)
(defvar shr-warning nil)
(defvar shr-ignore-cache nil)
-(defvar shr-target-id nil)
(defvar shr-table-separator-length 1)
(defvar shr-table-separator-pixel-width 0)
(defvar shr-table-id nil)
(defvar shr-current-font nil)
(defvar shr-internal-bullet nil)
+(defvar shr-target-id nil
+ "Target fragment identifier anchor.")
+
(defvar shr-map
(let ((map (make-sparse-keymap)))
(define-key map "a" 'shr-show-alt-text)
@@ -526,13 +528,13 @@ size, and full-buffer size."
(funcall function dom))
(t
(shr-generic dom)))
- (when (and shr-target-id
- (equal (dom-attr dom 'id) shr-target-id))
+ (when-let* ((id (dom-attr dom 'id)))
;; If the element was empty, we don't have anything to put the
;; anchor on. So just insert a dummy character.
(when (= start (point))
- (insert "*"))
- (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+ (insert ?*)
+ (put-text-property (1- (point)) (point) 'display ""))
+ (put-text-property start (1+ start) 'shr-target-id id))
;; If style is set, then this node has set the color.
(when style
(shr-colorize-region
@@ -1486,14 +1488,13 @@ ones, in case fg and bg are nil."
(start (point))
shr-start)
(shr-generic dom)
- (when (and shr-target-id
- (equal (dom-attr dom 'name) shr-target-id))
- ;; We have a zero-length <a name="foo"> element, so just
- ;; insert... something.
+ (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'.
+ (dom-attr dom 'name)))) ; Obsolete since HTML5.
+ ;; We have an empty element, so just insert... something.
(when (= start (point))
- (shr-ensure-newline)
- (insert " "))
- (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+ (insert ?\s)
+ (put-text-property (1- (point)) (point) 'display ""))
+ (put-text-property start (1+ start) 'shr-target-id id))
(when url
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index b4a080e..a7a5047 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -136,7 +136,7 @@ It is used for TCP/IP devices."
(file-selinux-context . tramp-handle-file-selinux-context)
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-adb-handle-file-system-info)
- (file-truename . tramp-adb-handle-file-truename)
+ (file-truename . tramp-handle-file-truename)
(file-writable-p . tramp-adb-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -160,6 +160,8 @@ It is used for TCP/IP devices."
(start-file-process . tramp-handle-start-file-process)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
@@ -227,104 +229,6 @@ ARGUMENTS to pass to the OPERATION."
(string-to-number (match-string 2))))
(* 1024 (string-to-number (match-string 3)))))))))
-;; This is derived from `tramp-sh-handle-file-truename'. Maybe the
-;; code could be shared?
-(defun tramp-adb-handle-file-truename (filename)
- "Like `file-truename' for Tramp files."
- ;; Preserve trailing "/".
- (funcall
- (if (directory-name-p filename) #'file-name-as-directory #'identity)
- ;; Quote properly.
- (funcall
- (if (tramp-compat-file-name-quoted-p filename)
- #'tramp-compat-file-name-quote #'identity)
- (with-parsed-tramp-file-name
- (tramp-compat-file-name-unquote (expand-file-name filename)) nil
- (tramp-make-tramp-file-name
- v
- (with-tramp-file-property v localname "file-truename"
- (let (result) ; result steps in reverse order
- (tramp-message v 4 "Finding true name for `%s'" filename)
- (let* ((steps (split-string localname "/" 'omit))
- (localnamedir (tramp-run-real-handler
- 'file-name-as-directory (list localname)))
- (is-dir (string= localname localnamedir))
- (thisstep nil)
- (numchase 0)
- ;; Don't make the following value larger than
- ;; necessary. People expect an error message in a
- ;; timely fashion when something is wrong; otherwise
- ;; they might think that Emacs is hung. Of course,
- ;; correctness has to come first.
- (numchase-limit 20)
- symlink-target)
- (while (and steps (< numchase numchase-limit))
- (setq thisstep (pop steps))
- (tramp-message
- v 5 "Check %s"
- (string-join
- (append '("") (reverse result) (list thisstep)) "/"))
- (setq symlink-target
- (tramp-compat-file-attribute-type
- (file-attributes
- (tramp-make-tramp-file-name
- v
- (string-join
- (append
- '("") (reverse result) (list thisstep)) "/")))))
- (cond ((string= "." thisstep)
- (tramp-message v 5 "Ignoring step `.'"))
- ((string= ".." thisstep)
- (tramp-message v 5 "Processing step `..'")
- (pop result))
- ((stringp symlink-target)
- ;; It's a symlink, follow it.
- (tramp-message v 5 "Follow symlink to %s" symlink-target)
- (setq numchase (1+ numchase))
- (when (file-name-absolute-p symlink-target)
- (setq result nil))
- ;; If the symlink was absolute, we'll get a string
- ;; like "/user@host:/some/target"; extract the
- ;; "/some/target" part from it.
- (when (tramp-tramp-file-p symlink-target)
- (unless (tramp-equal-remote filename symlink-target)
- (tramp-error
- v 'file-error
- "Symlink target `%s' on wrong host" symlink-target))
- (setq symlink-target localname))
- (setq steps
- (append (split-string symlink-target "/" 'omit)
- steps)))
- (t
- ;; It's a file.
- (setq result (cons thisstep result)))))
- (when (>= numchase numchase-limit)
- (tramp-error
- v 'file-error
- "Maximum number (%d) of symlinks exceeded" numchase-limit))
- (setq result (reverse result))
- ;; Combine list to form string.
- (setq result
- (if result
- (string-join (cons "" result) "/")
- "/"))
- (when (and is-dir (or (string-empty-p result)
- (not (string= (substring result -1) "/"))))
- (setq result (concat result "/"))))
-
- ;; Detect cycle.
- (when (and (file-symlink-p filename)
- (string-equal result localname))
- (tramp-error
- v 'file-error
- "Apparent cycle of symbolic links for %s" filename))
- ;; If the resulting localname looks remote, we must quote it
- ;; for security reasons.
- (when (file-remote-p result)
- (setq result (tramp-compat-file-name-quote result 'top)))
- (tramp-message v 4 "True name of `%s' is `%s'" localname result)
- result)))))))
-
(defun tramp-adb-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
(unless id-format (setq id-format 'integer))
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 24ee6fa..9502cc3 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -279,7 +279,9 @@ It must be supported by libarchive(3).")
(start-file-process . tramp-archive-handle-not-implemented)
;; `substitute-in-file-name' performed by default handler.
(temporary-file-directory . tramp-archive-handle-temporary-file-directory)
- ;; `tramp-set-file-uid-gid' performed by default handler.
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
+ (tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index f0131d5..218594b 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -43,6 +43,7 @@
;; `temporary-file-directory' as function is introduced with Emacs 26.1.
(declare-function tramp-handle-temporary-file-directory "tramp")
+(defvar tramp-temp-name-prefix)
;; For not existing functions, obsolete functions, or functions with a
;; changed argument list, there are compiler warnings. We want to
@@ -61,15 +62,19 @@ It is the default value of `temporary-file-directory'."
;; into an infloop.
(eval (car (get 'temporary-file-directory 'standard-value))))
+(defsubst tramp-compat-make-temp-name ()
+ "Generate a local temporary file name (compat function)."
+ (make-temp-name
+ (expand-file-name
+ tramp-temp-name-prefix (tramp-compat-temporary-file-directory))))
+
(defsubst tramp-compat-make-temp-file (f &optional dir-flag)
"Create a local temporary file (compat function).
Add the extension of F, if existing."
- (let* (file-name-handler-alist
- (prefix (expand-file-name
- (symbol-value 'tramp-temp-name-prefix)
- (tramp-compat-temporary-file-directory)))
- (extension (file-name-extension f t)))
- (make-temp-file prefix dir-flag extension)))
+ (make-temp-file
+ (expand-file-name
+ tramp-temp-name-prefix (tramp-compat-temporary-file-directory))
+ dir-flag (file-name-extension f t)))
;; `temporary-file-directory' as function is introduced with Emacs 26.1.
(defalias 'tramp-compat-temporary-file-directory-function
diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el
index 664f441..c9788fc 100644
--- a/lisp/net/tramp-crypt.el
+++ b/lisp/net/tramp-crypt.el
@@ -24,7 +24,7 @@
;;; Commentary:
;; Access functions for crypted remote files. It uses encfs to
-;; encrypt/ decrypt the files on a remote directory. A remote
+;; encrypt / decrypt the files on a remote directory. A remote
;; directory, which shall include crypted files, must be declared in
;; `tramp-crypt-directories' via command `tramp-crypt-add-directory'.
;; All files in that directory, including all subdirectories, are
@@ -145,8 +145,8 @@ If NAME doesn't belong to a crypted remote directory, retun
nil."
;; New handlers should be added here.
;;;###tramp-autoload
(defconst tramp-crypt-file-name-handler-alist
- '(;; (access-file . tramp-crypt-handle-access-file)
- ;; (add-name-to-file . tramp-crypt-handle-not-implemented)
+ '((access-file . tramp-crypt-handle-access-file)
+ (add-name-to-file . tramp-handle-add-name-to-file)
;; `byte-compiler-base-file-name' performed by default handler.
(copy-directory . tramp-handle-copy-directory)
(copy-file . tramp-crypt-handle-copy-file)
@@ -182,15 +182,15 @@ If NAME doesn't belong to a crypted remote directory,
retun nil."
(file-notify-add-watch . ignore)
(file-notify-rm-watch . ignore)
(file-notify-valid-p . ignore)
- ;; (file-ownership-preserved-p . ignore)
+ (file-ownership-preserved-p .
tramp-crypt-handle-file-ownership-preserved-p)
(file-readable-p . tramp-crypt-handle-file-readable-p)
(file-regular-p . tramp-handle-file-regular-p)
;; `file-remote-p' performed by default handler.
(file-selinux-context . ignore)
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-crypt-handle-file-system-info)
- ;; (file-truename . tramp-crypt-handle-file-truename)
- ;; (file-writable-p . ignore)
+ ;; `file-truename' performed by default handler.
+ (file-writable-p . tramp-crypt-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
(insert-directory . tramp-crypt-handle-insert-directory)
@@ -198,8 +198,8 @@ If NAME doesn't belong to a crypted remote directory, retun
nil."
(load . tramp-handle-load)
(make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
(make-directory . tramp-crypt-handle-make-directory)
- ;; (make-directory-internal . tramp-crypt-handle-not-implemented)
- ;; (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-directory-internal . ignore)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
(make-symbolic-link . tramp-handle-make-symbolic-link)
(process-file . ignore)
@@ -212,9 +212,11 @@ If NAME doesn't belong to a crypted remote directory,
retun nil."
(shell-command . ignore)
(start-file-process . ignore)
;; `substitute-in-file-name' performed by default handler.
- ;; (temporary-file-directory . tramp-crypt-handle-temporary-file-directory)
+ (temporary-file-directory . tramp-handle-temporary-file-directory)
+ ;; `tramp-get-remote-gid' performed by default handler.
+ ;; `tramp-get-remote-uid' performed by default handler.
(tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid)
- ;; (unhandled-file-name-directory . ignore)
+ (unhandled-file-name-directory . ignore)
(vc-registered . ignore)
(verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
(write-region . tramp-handle-write-region))
@@ -223,9 +225,14 @@ Operations not mentioned here will be handled by the
default Emacs primitives.")
(defsubst tramp-crypt-file-name-for-operation (operation &rest args)
"Like `tramp-file-name-for-operation', but for crypted remote files."
- (cl-letf (((symbol-function #'tramp-tramp-file-p)
- #'tramp-crypt-file-name-p))
- (apply #'tramp-file-name-for-operation operation args)))
+ (let ((tfnfo (apply #'tramp-file-name-for-operation operation args)))
+ ;; `tramp-file-name-for-operation' returns already the first argument
+ ;; if it is remote. So we check a possible second argument.
+ (unless (tramp-crypt-file-name-p tfnfo)
+ (setq tfnfo (apply
+ #'tramp-file-name-for-operation operation
+ (cons (tramp-compat-temporary-file-directory) (cdr args)))))
+ tfnfo))
(defun tramp-crypt-run-real-handler (operation args)
"Invoke normal file name handler for OPERATION.
@@ -244,7 +251,8 @@ arguments to pass to the OPERATION."
"Invoke the crypted remote file related OPERATION.
First arg specifies the OPERATION, second arg ARGS is a list of
arguments to pass to the OPERATION."
- (if-let ((filename (apply #'tramp-file-name-for-operation operation args))
+ (if-let ((filename
+ (apply #'tramp-crypt-file-name-for-operation operation args))
(fn (and (tramp-crypt-file-name-p filename)
(assoc operation tramp-crypt-file-name-handler-alist))))
(save-match-data (apply (cdr fn) args))
@@ -351,10 +359,11 @@ connection if a previous connection has died for some
reason."
(defun tramp-crypt-send-command (vec &rest args)
"Send encfsctl command to connection VEC.
-ARGS are the arguments."
+ARGS are the arguments. It returns t if ran successful, and nil otherwise."
(tramp-crypt-maybe-open-connection vec)
(with-current-buffer (tramp-get-connection-buffer vec)
- (erase-buffer))
+ (erase-buffer)
+ (set-buffer-multibyte nil))
(with-temp-buffer
(let* (;; Don't check for a proper method.
(non-essential t)
@@ -380,11 +389,12 @@ ARGS are the arguments."
;; Save the password.
(ignore-errors
(and (functionp tramp-password-save-function)
- (funcall tramp-password-save-function)))))))
+ (funcall tramp-password-save-function)))
+ t))))
(defun tramp-crypt-do-encrypt-or-decrypt-file-name (op name)
- "Return encrypted/ decrypted NAME if NAME belongs to a crypted directory.
-OP must be `encrypt' or `decrypt'.
+ "Return encrypted / decrypted NAME if NAME belongs to a crypted directory.
+OP must be `encrypt' or `decrypt'. Raise an error if this fails.
Otherwise, return NAME."
(if-let ((tramp-crypt-enabled t)
(dir (tramp-crypt-file-name-p name))
@@ -399,9 +409,12 @@ Otherwise, return NAME."
(unless (string-equal localname "/")
(with-tramp-file-property
crypt-vec localname (concat (symbol-name op) "-file-name")
- (tramp-crypt-send-command
- crypt-vec (if (eq op 'encrypt) "encode" "decode")
- (tramp-compat-temporary-file-directory) localname)
+ (unless (tramp-crypt-send-command
+ crypt-vec (if (eq op 'encrypt) "encode" "decode")
+ (tramp-compat-temporary-file-directory) localname)
+ (tramp-error
+ crypt-vec 'file-error "%s of file name %s failed."
+ (if (eq op 'encrypt) "Encoding" "Decoding") name))
(with-current-buffer (tramp-get-connection-buffer crypt-vec)
(goto-char (point-min))
(buffer-substring (point-min) (point-at-eol)))))))
@@ -419,9 +432,10 @@ Otherwise, return NAME."
(tramp-crypt-do-encrypt-or-decrypt-file-name 'decrypt name))
(defun tramp-crypt-do-encrypt-or-decrypt-file (op root infile outfile)
- "Encrypt/ decrypt file INFILE to OUTFILE according to crypted directory ROOT.
+ "Encrypt / decrypt file INFILE to OUTFILE according to crypted directory
ROOT.
Both files must be local files. OP must be `encrypt' or `decrypt'.
-If OP ist `decrypt', the basename of INFILE must be an encrypted file name."
+If OP ist `decrypt', the basename of INFILE must be an encrypted file name.
+Raise an error if this fails."
(when-let ((tramp-crypt-enabled t)
(dir (tramp-crypt-file-name-p root))
(crypt-vec (tramp-crypt-dissect-file-name dir)))
@@ -429,10 +443,13 @@ If OP ist `decrypt', the basename of INFILE must be an
encrypted file name."
(if (eq op 'decrypt) 'binary coding-system-for-read))
(coding-system-for-write
(if (eq op 'encrypt) 'binary coding-system-for-write)))
- (tramp-crypt-send-command
- crypt-vec "cat" (and (eq op 'encrypt) "--reverse")
- (file-name-directory infile)
- (concat "/" (file-name-nondirectory infile)))
+ (unless (tramp-crypt-send-command
+ crypt-vec "cat" (and (eq op 'encrypt) "--reverse")
+ (file-name-directory infile)
+ (concat "/" (file-name-nondirectory infile)))
+ (tramp-error
+ crypt-vec 'file-error "%s of file %s failed."
+ (if (eq op 'encrypt) "Encrypting" "Decrypting") infile))
(with-current-buffer (tramp-get-connection-buffer crypt-vec)
(write-region nil nil outfile)))))
@@ -457,6 +474,8 @@ directory. File names will be also encrypted."
(tramp-user-error nil "Feature is not enabled."))
(unless (and (tramp-tramp-file-p name) (file-directory-p name))
(tramp-user-error nil "%s must be an existing remote directory." name))
+ (when (tramp-compat-file-name-quoted-p name)
+ (tramp-user-error nil "%s must not be quoted." name))
(setq name (file-name-as-directory (expand-file-name name)))
(unless (member name tramp-crypt-directories)
(setq tramp-crypt-directories (cons name tramp-crypt-directories)))
@@ -499,6 +518,21 @@ localname."
;; File name primitives.
+(defun tramp-crypt-handle-access-file (filename string)
+ "Like `access-file' for Tramp files."
+ (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename))
+ (encrypt-regexp (concat (regexp-quote encrypt-filename) "\\'"))
+ tramp-crypt-enabled)
+ (condition-case err
+ (access-file encrypt-filename string)
+ (error
+ (when (and (eq (car err) 'file-missing) (stringp (cadr err))
+ (string-match-p encrypt-regexp (cadr err)))
+ (setcar
+ (cdr err)
+ (replace-regexp-in-string encrypt-regexp filename (cadr err))))
+ (signal (car err) (cdr err))))))
+
(defun tramp-crypt-do-copy-or-rename-file
(op filename newname &optional ok-if-already-exists keep-date
preserve-uid-gid preserve-extended-attributes)
@@ -520,16 +554,17 @@ absolute file names."
(error "Unknown operation `%s', must be `copy' or `rename'" op))
(setq filename (file-truename filename))
- (if (file-directory-p filename)
- (progn
- (copy-directory filename newname keep-date t)
- (when (eq op 'rename) (delete-directory filename 'recursive)))
-
- (let ((t1 (tramp-crypt-file-name-p filename))
- (t2 (tramp-crypt-file-name-p newname))
- (encrypt-filename (tramp-crypt-encrypt-file-name filename))
- (encrypt-newname (tramp-crypt-encrypt-file-name newname))
- (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+ (let ((t1 (tramp-crypt-file-name-p filename))
+ (t2 (tramp-crypt-file-name-p newname))
+ (encrypt-filename (tramp-crypt-encrypt-file-name filename))
+ (encrypt-newname (tramp-crypt-encrypt-file-name newname))
+ (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+
+ (if (file-directory-p filename)
+ (progn
+ (copy-directory filename newname keep-date t)
+ (when (eq op 'rename)
+ (delete-directory filename 'recursive)))
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless (file-exists-p filename)
@@ -563,6 +598,14 @@ absolute file names."
(file-name-nondirectory encrypt-newname) tmpdir))
tramp-crypt-enabled)
(cond
+ ;; Source and target file are on a crypted remote directory.
+ ((and t1 t2)
+ (if (eq op 'copy)
+ (copy-file
+ encrypt-filename encrypt-newname ok-if-already-exists
+ keep-date preserve-uid-gid preserve-extended-attributes)
+ (rename-file
+ encrypt-filename encrypt-newname ok-if-already-exists)))
;; Source file is on a crypted remote directory.
(t1
(if (eq op 'copy)
@@ -581,15 +624,15 @@ absolute file names."
(rename-file filename tmpfile1 t))
(tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2)
(rename-file tmpfile2 encrypt-newname ok-if-already-exists)))
- (delete-directory tmpdir 'recursive)))
+ (delete-directory tmpdir 'recursive))))))
- (when (and t1 (eq op 'rename))
- (with-parsed-tramp-file-name filename v1
- (tramp-flush-file-properties v1 v1-localname)))
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-properties v1 v1-localname)))
- (when t2
- (with-parsed-tramp-file-name newname v2
- (tramp-flush-file-properties v2 v2-localname))))))))
+ (when t2
+ (with-parsed-tramp-file-name newname v2
+ (tramp-flush-file-properties v2 v2-localname)))))
(defun tramp-crypt-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
@@ -621,8 +664,8 @@ absolute file names."
"Like `delete-file' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name filename) nil
(tramp-flush-file-properties v localname)
- (tramp-crypt-run-real-handler
- #'delete-file (list (tramp-crypt-encrypt-file-name filename) trash))))
+ (let (tramp-crypt-enabled)
+ (delete-file (tramp-crypt-encrypt-file-name filename) trash))))
(defun tramp-crypt-handle-directory-files (directory &optional full match
nosort)
"Like `directory-files' for Tramp files."
@@ -657,8 +700,8 @@ absolute file names."
(defun tramp-crypt-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
- (tramp-crypt-run-real-handler
- #'file-attributes (list (tramp-crypt-encrypt-file-name filename)
id-format)))
+ (let (tramp-crypt-enabled)
+ (file-attributes (tramp-crypt-encrypt-file-name filename) id-format)))
(defun tramp-crypt-handle-file-executable-p (filename)
"Like `file-executable-p' for Tramp files."
@@ -685,43 +728,56 @@ absolute file names."
(let (tramp-crypt-enabled)
(file-readable-p (tramp-crypt-encrypt-file-name filename))))
+(defun tramp-crypt-handle-file-ownership-preserved-p (filename &optional group)
+ "Like `file-ownership-preserved-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-ownership-preserved-p (tramp-crypt-encrypt-file-name filename)
group)))
+
(defun tramp-crypt-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
- (tramp-crypt-run-real-handler
- ;; `file-system-info' exists since Emacs 27.1. Then, we can use
- ;; #'file-system-info.
- 'file-system-info (list (tramp-crypt-encrypt-file-name filename))))
+ (let (tramp-crypt-enabled)
+ ;; `file-system-info' exists since Emacs 27.1.
+ (tramp-compat-funcall
+ 'file-system-info (tramp-crypt-encrypt-file-name filename))))
+
+(defun tramp-crypt-handle-file-writable-p (filename)
+ "Like `file-writable-p' for Tramp files."
+ (let (tramp-crypt-enabled)
+ (file-writable-p (tramp-crypt-encrypt-file-name filename))))
(defun tramp-crypt-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
- "Like `insert-directory' for Tramp files."
- (let (tramp-crypt-enabled)
- (tramp-handle-insert-directory
- (tramp-crypt-encrypt-file-name filename)
- switches wildcard full-directory-p)
- (let* ((filename (file-name-as-directory filename))
- (enc (tramp-crypt-encrypt-file-name filename))
- match string)
- (goto-char (point-min))
- (while (setq match (text-property-search-forward 'dired-filename t t))
- (setq string
- (buffer-substring
- (prop-match-beginning match) (prop-match-end match))
- string (if (file-name-absolute-p string)
- (tramp-crypt-decrypt-file-name string)
- (substring
- (tramp-crypt-decrypt-file-name (concat enc string))
- (length filename))))
- (delete-region (prop-match-beginning match) (prop-match-end match))
- (insert (propertize string 'dired-filename t))))))
+ "Like `insert-directory' for Tramp files.
+WILDCARD is not supported."
+ ;; This package has been added to Emacs 27.1.
+ (when (load "text-property-search" 'noerror 'nomessage)
+ (let (tramp-crypt-enabled)
+ (tramp-handle-insert-directory
+ (tramp-crypt-encrypt-file-name filename)
+ switches wildcard full-directory-p)
+ (let* ((filename (file-name-as-directory filename))
+ (enc (tramp-crypt-encrypt-file-name filename))
+ match string)
+ (goto-char (point-min))
+ (while (setq match (text-property-search-forward 'dired-filename t t))
+ (setq string
+ (buffer-substring
+ (prop-match-beginning match) (prop-match-end match))
+ string (if (file-name-absolute-p string)
+ (tramp-crypt-decrypt-file-name string)
+ (substring
+ (tramp-crypt-decrypt-file-name (concat enc string))
+ (length filename))))
+ (delete-region (prop-match-beginning match) (prop-match-end match))
+ (insert (propertize string 'dired-filename t)))))))
(defun tramp-crypt-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name dir) nil
(when (and (null parents) (file-exists-p dir))
(tramp-error v 'file-already-exists "Directory already exists %s" dir))
- (tramp-crypt-run-real-handler
- #'make-directory (list (tramp-crypt-encrypt-file-name dir) parents))
+ (let (tramp-crypt-enabled)
+ (make-directory (tramp-crypt-encrypt-file-name dir) parents))
;; When PARENTS is non-nil, DIR could be a chain of non-existent
;; directories a/b/c/... Instead of checking, we simply flush the
;; whole cache.
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 704d65c..dce6edd 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -821,6 +821,8 @@ It has been changed in GVFS 1.14.")
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid)
+ (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
@@ -949,6 +951,10 @@ is no information where to trace the message.")
(tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err))))
(add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error)
+(add-hook 'tramp-gvfs-unload-hook
+ (lambda ()
+ (remove-hook 'dbus-event-error-functions
+ #'tramp-gvfs-dbus-event-error)))
;; File name primitives.
@@ -1506,7 +1512,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
;; If the user is different from what we guess to be
;; the user, we don't know. Let's check, whether
;; access is restricted explicitly.
- (and (/= (tramp-gvfs-get-remote-uid v 'integer)
+ (and (/= (tramp-get-remote-uid v 'integer)
(tramp-compat-file-attribute-user-id
(file-attributes filename 'integer)))
(not
@@ -1589,7 +1595,27 @@ If FILE-SYSTEM is non-nil, return file system
attributes."
(current-time)
time)))))
-(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid)
+(defun tramp-gvfs-handle-get-remote-uid (vec id-format)
+ "The uid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (if (equal id-format 'string)
+ (tramp-file-name-user vec)
+ (when-let
+ ((localname (tramp-get-connection-property vec "default-location" nil)))
+ (tramp-compat-file-attribute-user-id
+ (file-attributes
+ (tramp-make-tramp-file-name vec localname) id-format)))))
+
+(defun tramp-gvfs-handle-get-remote-gid (vec id-format)
+ "The gid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (when-let
+ ((localname (tramp-get-connection-property vec "default-location" nil)))
+ (tramp-compat-file-attribute-group-id
+ (file-attributes
+ (tramp-make-tramp-file-name vec localname) id-format))))
+
+(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid)
"Like `tramp-set-file-uid-gid' for Tramp files."
(with-parsed-tramp-file-name filename nil
(tramp-flush-file-properties v localname)
@@ -2057,39 +2083,6 @@ and
\"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals."
;; Connection functions.
-(defun tramp-gvfs-get-remote-uid (vec id-format)
- "The uid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "uid-%s" id-format)
- (let ((user (tramp-file-name-user vec))
- (localname
- (tramp-get-connection-property vec "default-location" nil)))
- (cond
- ((and (equal id-format 'string) user))
- (localname
- (tramp-compat-file-attribute-user-id
- (file-attributes
- (tramp-make-tramp-file-name vec localname) id-format)))
- ((equal id-format 'integer) tramp-unknown-id-integer)
- ((equal id-format 'string) tramp-unknown-id-string)))))
-
-(defun tramp-gvfs-get-remote-gid (vec id-format)
- "The gid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "gid-%s" id-format)
- (let ((localname
- (tramp-get-connection-property vec "default-location" nil)))
- (cond
- (localname
- (tramp-compat-file-attribute-group-id
- (file-attributes
- (tramp-make-tramp-file-name vec localname) id-format)))
- ((equal id-format 'integer) tramp-unknown-id-integer)
- ((equal id-format 'string) tramp-unknown-id-string)))))
-
-(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil
- "Indication, that remote uid and gid determination is in progress.")
-
(defun tramp-gvfs-get-remote-prefix (vec)
"The prefix of the remote connection VEC.
This is relevant for GNOME Online Accounts."
@@ -2229,16 +2222,7 @@ connection if a previous connection has died for some
reason."
;; Mark it as connected.
(tramp-set-connection-property
- (tramp-get-connection-process vec) "connected" t))))
-
- ;; In `tramp-check-cached-permissions', the connection properties
- ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
- (unless tramp-gvfs-get-remote-uid-gid-in-progress
- (let ((tramp-gvfs-get-remote-uid-gid-in-progress t))
- (tramp-gvfs-get-remote-uid vec 'integer)
- (tramp-gvfs-get-remote-gid vec 'integer)
- (tramp-gvfs-get-remote-uid vec 'string)
- (tramp-gvfs-get-remote-gid vec 'string))))
+ (tramp-get-connection-process vec) "connected" t)))))
(defun tramp-gvfs-gio-tool-p (vec)
"Check, whether the gio tool is available."
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 08bba33..3701bfc 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -135,6 +135,8 @@
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
@@ -457,7 +459,7 @@ file names."
;; to cache a nil result.
(or (tramp-get-connection-property
(tramp-get-connection-process vec) "mounted" nil)
- (let* ((default-directory temporary-file-directory)
+ (let* ((default-directory (tramp-compat-temporary-file-directory))
(mount (shell-command-to-string "mount -t fuse.rclone")))
(tramp-message vec 6 "%s" "mount -t fuse.rclone")
(tramp-message vec 6 "\n%s" mount)
@@ -483,7 +485,8 @@ file names."
;; crash Emacs for some processes. So we use
;; "pidof", which might not work everywhere.
(if (<= emacs-major-version 25)
- (let ((default-directory temporary-file-directory))
+ (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
(mapcar
#'string-to-number
(split-string
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index a3ce436..89e5dc9 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -1039,6 +1039,8 @@ of command line.")
(start-file-process . tramp-handle-start-file-process)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid)
+ (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
(vc-registered . tramp-sh-handle-vc-registered)
@@ -1153,59 +1155,9 @@ component is used as the target of the symlink."
(tramp-shell-quote-argument localname)))))
;; Do it yourself.
- (t (let ((steps (split-string localname "/" 'omit))
- (thisstep nil)
- (numchase 0)
- ;; Don't make the following value larger than
- ;; necessary. People expect an error message in a
- ;; timely fashion when something is wrong;
- ;; otherwise they might think that Emacs is hung.
- ;; Of course, correctness has to come first.
- (numchase-limit 20)
- symlink-target)
- (while (and steps (< numchase numchase-limit))
- (setq thisstep (pop steps))
- (tramp-message
- v 5 "Check %s"
- (string-join
- (append '("") (reverse result) (list thisstep)) "/"))
- (setq symlink-target
- (tramp-compat-file-attribute-type
- (file-attributes
- (tramp-make-tramp-file-name
- v
- (string-join
- (append
- '("") (reverse result) (list thisstep)) "/")
- 'nohop))))
- (cond ((string= "." thisstep)
- (tramp-message v 5 "Ignoring step `.'"))
- ((string= ".." thisstep)
- (tramp-message v 5 "Processing step `..'")
- (pop result))
- ((stringp symlink-target)
- ;; It's a symlink, follow it.
- (tramp-message
- v 5 "Follow symlink to %s" symlink-target)
- (setq numchase (1+ numchase))
- (when (file-name-absolute-p symlink-target)
- (setq result nil))
- (setq steps
- (append
- (split-string symlink-target "/" 'omit)
- steps)))
- (t
- ;; It's a file.
- (setq result (cons thisstep result)))))
- (when (>= numchase numchase-limit)
- (tramp-error
- v 'file-error
- "Maximum number (%d) of symlinks exceeded" numchase-limit))
- (setq result (reverse result)
- ;; Combine list to form string.
- result
- (if result (string-join (cons "" result) "/") "/"))
- (when (string-empty-p result) (setq result "/")))))
+ (t (setq
+ result
+ (tramp-file-local-name (tramp-handle-file-truename filename)))))
;; Detect cycle.
(when (and (file-symlink-p filename)
@@ -1379,18 +1331,11 @@ component is used as the target of the symlink."
(format
(eval-when-compile
(concat
- ;; On Opsware, pdksh (which is the true name of ksh there)
- ;; doesn't parse correctly the sequence "((". Therefore, we
- ;; add a space. Apostrophes in the stat output are masked as
+ ;; Apostrophes in the stat output are masked as
;; `tramp-stat-marker', in order to make a proper shell escape
;; of them in file names.
- "( (%s %s || %s -h %s) && (%s -c "
- "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' "
- "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)"))
- (tramp-get-file-exists-command vec)
- (tramp-shell-quote-argument localname)
- (tramp-get-test-command vec)
- (tramp-shell-quote-argument localname)
+ "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |"
+ " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')"))
(tramp-get-remote-stat vec)
tramp-stat-marker tramp-stat-marker
(if (eq id-format 'integer)
@@ -1401,7 +1346,8 @@ component is used as the target of the symlink."
(eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker)))
tramp-stat-marker tramp-stat-marker
(tramp-shell-quote-argument localname)
- tramp-stat-quoted-marker)))
+ tramp-stat-quoted-marker)
+ 'noerror))
(defun tramp-sh-handle-set-visited-file-modtime (&optional time-list)
"Like `set-visited-file-modtime' for Tramp files."
@@ -1517,6 +1463,26 @@ of."
(if (eq flag 'nofollow) "-h" "")
(tramp-shell-quote-argument localname)))))))
+(defun tramp-sh-handle-get-remote-uid (vec id-format)
+ "The uid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (ignore-errors
+ (cond
+ ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format))
+ ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec
id-format))
+ ((tramp-get-remote-python vec)
+ (tramp-get-remote-uid-with-python vec id-format)))))
+
+(defun tramp-sh-handle-get-remote-gid (vec id-format)
+ "The gid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (ignore-errors
+ (cond
+ ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format))
+ ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec
id-format))
+ ((tramp-get-remote-python vec)
+ (tramp-get-remote-gid-with-python vec id-format)))))
+
(defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid)
"Like `tramp-set-file-uid-gid' for Tramp files."
;; Modern Unices allow chown only for root. So we might need
@@ -1719,8 +1685,10 @@ of."
(defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group)
"Like `file-ownership-preserved-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (with-tramp-file-property v localname "file-ownership-preserved-p"
- (let ((attributes (file-attributes filename)))
+ (with-tramp-file-property
+ v localname
+ (format "file-ownership-preserved-p%s" (if group "-group" ""))
+ (let ((attributes (file-attributes filename 'integer)))
;; Return t if the file doesn't exist, since it's true that no
;; information would be lost by an (attempted) delete and create.
(or (null attributes)
@@ -3024,16 +2992,16 @@ STDERR can also be a file name."
;; the process is deleted.
(when (bufferp stderr)
(with-current-buffer stderr
- (insert-file-contents-literally
- remote-tmpstderr 'visit))
+ (insert-file-contents-literally remote-tmpstderr))
;; Delete tmpstderr file.
(add-function
:after (process-sentinel p)
(lambda (_proc _msg)
- (with-current-buffer stderr
- (insert-file-contents-literally
- remote-tmpstderr 'visit nil nil 'replace))
- (delete-file remote-tmpstderr))))
+ (when (file-exists-p remote-tmpstderr)
+ (with-current-buffer stderr
+ (insert-file-contents-literally
+ remote-tmpstderr nil nil nil 'replace))
+ (delete-file remote-tmpstderr)))))
;; Return process.
p)))
@@ -4636,11 +4604,7 @@ Goes through the list `tramp-local-coding-commands' and
?o (tramp-get-remote-od vec)))
value (replace-regexp-in-string "%" "%%" value)))
(when (string-match-p "\\(^\\|[^%]\\)%t" value)
- (setq tmpfile
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-get-remote-tmpdir vec)))
+ (setq tmpfile (tramp-make-tramp-temp-name vec)
value
(format-spec
value
@@ -5079,10 +5043,7 @@ connection if a previous connection has died for some
reason."
(tmpfile
(with-tramp-connection-property
(tramp-get-process vec) "temp-file"
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-compat-temporary-file-directory)))))
+ (tramp-compat-make-temp-name)))
spec r-shell)
;; Add arguments for asynchronous processes.
@@ -5302,7 +5263,10 @@ raises an error."
command marker (buffer-string))))))
;; Read the expression.
(condition-case nil
- (prog1 (read (current-buffer))
+ (prog1
+ (let ((signal-hook-function
+ (unless noerror signal-hook-function)))
+ (read (current-buffer)))
;; Error handling.
(when (re-search-forward "\\S-" (point-at-eol) t)
(error nil)))
@@ -5710,10 +5674,7 @@ This command is returned only if
`delete-by-moving-to-trash' is non-nil."
(tramp-message vec 5 "Finding a suitable `touch' command")
(let ((result (tramp-find-executable
vec "touch" (tramp-get-remote-path vec)))
- (tmpfile
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))))
+ (tmpfile (tramp-make-tramp-temp-name vec)))
;; Busyboxes do support the "-t" option only when they have been
;; built with the DESKTOP config option. Let's check it.
(when result
@@ -5828,27 +5789,6 @@ This command is returned only if
`delete-by-moving-to-trash' is non-nil."
"import os; print (os.getuid())"
"import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] +
'\\\"')"))))
-(defun tramp-get-remote-uid (vec id-format)
- "The uid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "uid-%s" id-format)
- (let ((res
- (ignore-errors
- (cond
- ((tramp-get-remote-id vec)
- (tramp-get-remote-uid-with-id vec id-format))
- ((tramp-get-remote-perl vec)
- (tramp-get-remote-uid-with-perl vec id-format))
- ((tramp-get-remote-python vec)
- (tramp-get-remote-uid-with-python vec id-format))))))
- ;; Ensure there is a valid result.
- (cond
- ((and (equal id-format 'integer) (not (integerp res)))
- tramp-unknown-id-integer)
- ((and (equal id-format 'string) (not (stringp res)))
- tramp-unknown-id-string)
- (t res)))))
-
(defun tramp-get-remote-gid-with-id (vec id-format)
"Implement `tramp-get-remote-gid' for Tramp files using `id'."
(tramp-send-command-and-read
@@ -5879,27 +5819,6 @@ ID-FORMAT valid values are `string' and `integer'."
"import os; print (os.getgid())"
"import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] +
'\\\"')"))))
-(defun tramp-get-remote-gid (vec id-format)
- "The gid of the remote connection VEC, in ID-FORMAT.
-ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "gid-%s" id-format)
- (let ((res
- (ignore-errors
- (cond
- ((tramp-get-remote-id vec)
- (tramp-get-remote-gid-with-id vec id-format))
- ((tramp-get-remote-perl vec)
- (tramp-get-remote-gid-with-perl vec id-format))
- ((tramp-get-remote-python vec)
- (tramp-get-remote-gid-with-python vec id-format))))))
- ;; Ensure there is a valid result.
- (cond
- ((and (equal id-format 'integer) (not (integerp res)))
- tramp-unknown-id-integer)
- ((and (equal id-format 'string) (not (stringp res)))
- tramp-unknown-id-string)
- (t res)))))
-
(defun tramp-get-remote-busybox (vec)
"Determine remote `busybox' command."
(with-tramp-connection-property vec "busybox"
@@ -5945,10 +5864,7 @@ ID-FORMAT valid values are `string' and `integer'."
"Check whether remote `chmod' supports nofollow argument."
(with-tramp-connection-property vec "chmod-h"
(tramp-message vec 5 "Finding a suitable `chmod' command with nofollow")
- (let ((tmpfile
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))))
+ (let ((tmpfile (tramp-make-tramp-temp-name vec)))
(prog1
(tramp-send-command-and-check
vec
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 2088d23..357e9a2 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -293,6 +293,8 @@ See `tramp-actions-before-shell' for more info.")
(start-file-process . tramp-smb-handle-start-file-process)
(substitute-in-file-name . tramp-smb-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . ignore)
+ (tramp-get-remote-uid . ignore)
(tramp-set-file-uid-gid . ignore)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
@@ -436,11 +438,7 @@ pass to the OPERATION."
(cond
;; We must use a local temporary directory.
((and t1 t2)
- (let ((tmpdir
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-compat-temporary-file-directory)))))
+ (let ((tmpdir (tramp-compat-make-temp-name)))
(unwind-protect
(progn
(make-directory tmpdir)
@@ -468,10 +466,7 @@ pass to the OPERATION."
(localname (file-name-as-directory
(replace-regexp-in-string
"\\\\" "/" (tramp-smb-get-localname v))))
- (tmpdir (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-compat-temporary-file-directory))))
+ (tmpdir (tramp-compat-make-temp-name))
(args (list (concat "//" host "/" share) "-E"))
(options tramp-smb-options))
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index 68e68a2..05242ff 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -132,6 +132,8 @@ See `tramp-actions-before-shell' for more info.")
(start-file-process . ignore)
(substitute-in-file-name . tramp-handle-substitute-in-file-name)
(temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid)
+ (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid)
(tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid)
(unhandled-file-name-directory . ignore)
(vc-registered . ignore)
@@ -689,21 +691,19 @@ component is used as the target of the symlink."
(tramp-flush-file-property v localname "file-selinux-context"))
t)))))
-(defun tramp-sudoedit-get-remote-uid (vec id-format)
+(defun tramp-sudoedit-handle-get-remote-uid (vec id-format)
"The uid of the remote connection VEC, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "uid-%s" id-format)
- (if (equal id-format 'integer)
- (tramp-sudoedit-send-command-and-read vec "id" "-u")
- (tramp-sudoedit-send-command-string vec "id" "-un"))))
+ (if (equal id-format 'integer)
+ (tramp-sudoedit-send-command-and-read vec "id" "-u")
+ (tramp-sudoedit-send-command-string vec "id" "-un")))
-(defun tramp-sudoedit-get-remote-gid (vec id-format)
+(defun tramp-sudoedit-handle-get-remote-gid (vec id-format)
"The gid of the remote connection VEC, in ID-FORMAT.
ID-FORMAT valid values are `string' and `integer'."
- (with-tramp-connection-property vec (format "gid-%s" id-format)
- (if (equal id-format 'integer)
- (tramp-sudoedit-send-command-and-read vec "id" "-g")
- (tramp-sudoedit-send-command-string vec "id" "-gn"))))
+ (if (equal id-format 'integer)
+ (tramp-sudoedit-send-command-and-read vec "id" "-g")
+ (tramp-sudoedit-send-command-string vec "id" "-gn")))
(defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid)
"Like `tramp-set-file-uid-gid' for Tramp files."
@@ -711,8 +711,8 @@ ID-FORMAT valid values are `string' and `integer'."
(tramp-sudoedit-send-command
v "chown"
(format "%d:%d"
- (or uid (tramp-sudoedit-get-remote-uid v 'integer))
- (or gid (tramp-sudoedit-get-remote-gid v 'integer)))
+ (or uid (tramp-get-remote-uid v 'integer))
+ (or gid (tramp-get-remote-gid v 'integer)))
(tramp-unquote-file-local-name filename))))
(defun tramp-sudoedit-handle-write-region
@@ -721,10 +721,10 @@ ID-FORMAT valid values are `string' and `integer'."
(with-parsed-tramp-file-name filename nil
(let* ((uid (or (tramp-compat-file-attribute-user-id
(file-attributes filename 'integer))
- (tramp-sudoedit-get-remote-uid v 'integer)))
+ (tramp-get-remote-uid v 'integer)))
(gid (or (tramp-compat-file-attribute-group-id
(file-attributes filename 'integer))
- (tramp-sudoedit-get-remote-gid v 'integer)))
+ (tramp-get-remote-gid v 'integer)))
(flag (and (eq mustbenew 'excl) 'nofollow))
(modes (tramp-default-file-modes filename flag)))
(prog1
@@ -785,14 +785,7 @@ connection if a previous connection has died for some
reason."
(tramp-set-connection-local-variables vec)
;; Mark it as connected.
- (tramp-set-connection-property p "connected" t))
-
- ;; In `tramp-check-cached-permissions', the connection properties
- ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
- (tramp-sudoedit-get-remote-uid vec 'integer)
- (tramp-sudoedit-get-remote-gid vec 'integer)
- (tramp-sudoedit-get-remote-uid vec 'string)
- (tramp-sudoedit-get-remote-gid vec 'string)))
+ (tramp-set-connection-property p "connected" t))))
(defun tramp-sudoedit-send-command (vec &rest args)
"Send commands ARGS to connection VEC.
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index f1db6a7b..1566162 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -64,6 +64,7 @@
;; Pacify byte-compiler.
(require 'cl-lib)
+(declare-function file-notify-rm-watch "filenotify")
(declare-function netrc-parse "netrc")
(defvar auto-save-file-name-transforms)
@@ -1780,6 +1781,10 @@ ARGUMENTS to actually emit the message (if applicable)."
(put #'tramp-debug-message 'tramp-suppress-trace t)
+(defvar tramp-inhibit-progress-reporter nil
+ "Show Tramp progress reporter in the minibuffer.
+This variable is used to disable concurrent progress reporter messages.")
+
(defsubst tramp-message (vec-or-proc level fmt-string &rest arguments)
"Emit a message depending on verbosity level.
VEC-OR-PROC identifies the Tramp buffer to use. It can be either a
@@ -1795,8 +1800,9 @@ control string and the remaining ARGUMENTS to actually
emit the message (if
applicable)."
(ignore-errors
(when (<= level tramp-verbose)
- ;; Display only when there is a minimum level.
- (when (<= level 3)
+ ;; Display only when there is a minimum level, and the progress
+ ;; reporter doesn't suppress further messages.
+ (when (and (<= level 3) (null tramp-inhibit-progress-reporter))
(apply #'message
(concat
(cond
@@ -2014,7 +2020,12 @@ without a visible progress reporter."
(run-at-time 3 0.1 #'tramp-progress-reporter-update pr))))
(unwind-protect
;; Execute the body.
- (prog1 (progn ,@body) (setq cookie "done"))
+ (prog1
+ ;; Suppress concurrent progress reporter messages.
+ (let ((tramp-inhibit-progress-reporter
+ (or tramp-inhibit-progress-reporter tm)))
+ ,@body)
+ (setq cookie "done"))
;; Stop progress reporter.
(if tm (cancel-timer tm))
(tramp-message ,vec ,level "%s...%s" ,message cookie)))))
@@ -2248,7 +2259,7 @@ Must be handled by the callers."
file-newer-than-file-p rename-file))
(cond
((tramp-tramp-file-p (nth 0 args)) (nth 0 args))
- ((tramp-tramp-file-p (nth 1 args)) (nth 1 args))
+ ((file-name-absolute-p (nth 1 args)) (nth 1 args))
(t default-directory)))
;; FILE DIRECTORY resp FILE1 FILE2.
((eq operation 'expand-file-name)
@@ -2280,6 +2291,9 @@ Must be handled by the callers."
(when (processp (nth 0 args))
(with-current-buffer (process-buffer (nth 0 args))
default-directory)))
+ ;; VEC.
+ ((member operation '(tramp-get-remote-gid tramp-get-remote-uid))
+ (tramp-make-tramp-file-name (nth 0 args)))
;; Unknown file primitive.
(t (error "Unknown file I/O primitive: %s" operation))))
@@ -2436,6 +2450,8 @@ Falls back to normal file name handler if no Tramp file
name handler exists."
"Load Tramp file name handler, and perform OPERATION."
(tramp-unload-file-name-handlers)
(when tramp-mode
+ ;; We cannot use `tramp-compat-temporary-file-directory' here due
+ ;; to autoload.
(let ((default-directory temporary-file-directory))
(load "tramp" 'noerror 'nomessage)))
(apply operation args)))
@@ -3381,6 +3397,8 @@ User is always nil."
;; something is wrong; otherwise they might think that Emacs
;; is hung. Of course, correctness has to come first.
(numchase-limit 20)
+ ;; Unquoting could enable encryption.
+ tramp-crypt-enabled
symlink-target)
(with-parsed-tramp-file-name result v1
;; We cache only the localname.
@@ -3612,7 +3630,8 @@ User is always nil."
v tramp-file-missing "Cannot load nonexistent file `%s'" file))
(if (not (file-exists-p file))
nil
- (let ((inhibit-message nomessage))
+ (let ((signal-hook-function (unless noerror signal-hook-function))
+ (inhibit-message (or inhibit-message nomessage)))
(with-tramp-progress-reporter v 0 (format "Loading %s" file)
(let ((local-copy (file-local-copy file)))
(unwind-protect
@@ -3900,7 +3919,13 @@ of."
(let ((tmpfile (tramp-compat-make-temp-file filename))
(modes (tramp-default-file-modes
- filename (and (eq mustbenew 'excl) 'nofollow))))
+ filename (and (eq mustbenew 'excl) 'nofollow)))
+ (uid (or (tramp-compat-file-attribute-user-id
+ (file-attributes filename 'integer))
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (tramp-compat-file-attribute-group-id
+ (file-attributes filename 'integer))
+ (tramp-get-remote-gid v 'integer))))
(when (and append (file-exists-p filename))
(copy-file filename tmpfile 'ok))
;; The permissions of the temporary file should be set. If
@@ -3919,15 +3944,18 @@ of."
(error
(delete-file tmpfile)
(tramp-error
- v 'file-error "Couldn't write region to `%s'" filename))))
+ v 'file-error "Couldn't write region to `%s'" filename)))
- (tramp-flush-file-properties v localname)
+ (tramp-flush-file-properties v localname)
- ;; Set file modification time.
- (when (or (eq visit t) (stringp visit))
- (set-visited-file-modtime
- (tramp-compat-file-attribute-modification-time
- (file-attributes filename))))
+ ;; Set file modification time.
+ (when (or (eq visit t) (stringp visit))
+ (set-visited-file-modtime
+ (tramp-compat-file-attribute-modification-time
+ (file-attributes filename))))
+
+ ;; Set the ownership.
+ (tramp-set-file-uid-gid filename uid gid))
;; The end.
(when (and (null noninteractive)
@@ -3981,7 +4009,7 @@ of."
"Call `file-notify-rm-watch'."
(unless (process-live-p proc)
(tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event)
- (tramp-compat-funcall 'file-notify-rm-watch proc)))
+ (file-notify-rm-watch proc)))
;;; Functions for establishing connection:
@@ -4603,12 +4631,8 @@ be granted."
(concat "file-attributes-" suffix) nil)
(file-attributes
(tramp-make-tramp-file-name vec) (intern suffix))))
- (remote-uid
- (tramp-get-connection-property
- vec (concat "uid-" suffix) nil))
- (remote-gid
- (tramp-get-connection-property
- vec (concat "gid-" suffix) nil))
+ (remote-uid (tramp-get-remote-uid vec (intern suffix)))
+ (remote-gid (tramp-get-remote-gid vec (intern suffix)))
(unknown-id
(if (string-equal suffix "string")
tramp-unknown-id-string tramp-unknown-id-integer)))
@@ -4642,6 +4666,32 @@ be granted."
(tramp-compat-file-attribute-group-id
file-attr))))))))))))
+(defun tramp-get-remote-uid (vec id-format)
+ "The uid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (with-tramp-connection-property vec (format "uid-%s" id-format)
+ (or (when-let
+ ((handler
+ (find-file-name-handler
+ (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid)))
+ (funcall handler #'tramp-get-remote-uid vec id-format))
+ ;; Ensure there is a valid result.
+ (and (equal id-format 'integer) tramp-unknown-id-integer)
+ (and (equal id-format 'string) tramp-unknown-id-string))))
+
+(defun tramp-get-remote-gid (vec id-format)
+ "The gid of the remote connection VEC, in ID-FORMAT.
+ID-FORMAT valid values are `string' and `integer'."
+ (with-tramp-connection-property vec (format "gid-%s" id-format)
+ (or (when-let
+ ((handler
+ (find-file-name-handler
+ (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid)))
+ (funcall handler #'tramp-get-remote-gid vec id-format))
+ ;; Ensure there is a valid result.
+ (and (equal id-format 'integer) tramp-unknown-id-integer)
+ (and (equal id-format 'string) tramp-unknown-id-string))))
+
(defun tramp-local-host-p (vec)
"Return t if this points to the local host, nil otherwise.
This handles also chrooted environments, which are not regarded as local."
@@ -4664,9 +4714,7 @@ This handles also chrooted environments, which are not
regarded as local."
vec (tramp-compat-temporary-file-directory) 'nohop))
;; On some systems, chown runs only for root.
(or (zerop (user-uid))
- ;; This is defined in tramp-sh.el. Let's assume this is
- ;; loaded already.
- (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer))))))
+ (zerop (tramp-get-remote-uid vec 'integer))))))
(defun tramp-get-remote-tmpdir (vec)
"Return directory for temporary files on the remote host identified by VEC."
@@ -4679,18 +4727,21 @@ This handles also chrooted environments, which are not
regarded as local."
(tramp-error vec 'file-error "Directory %s not accessible" dir))
dir)))
+(defun tramp-make-tramp-temp-name (vec)
+ "Generate a temporary file name on the remote host identified by VEC."
+ (make-temp-name
+ (expand-file-name tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))
+
(defun tramp-make-tramp-temp-file (vec)
"Create a temporary file on the remote host identified by VEC.
Return the local name of the temporary file."
- (let ((prefix (expand-file-name
- tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))
- result)
+ (let (result)
(while (not result)
;; `make-temp-file' would be the natural choice for
;; implementation. But it calls `write-region' internally,
;; which also needs a temporary file - we would end in an
;; infinite loop.
- (setq result (make-temp-name prefix))
+ (setq result (tramp-make-tramp-temp-name vec))
(if (file-exists-p result)
(setq result nil)
;; This creates the file by side effect.
diff --git a/lisp/obsolete/tls.el b/lisp/obsolete/tls.el
index cd091c0..d1b215c 100644
--- a/lisp/obsolete/tls.el
+++ b/lisp/obsolete/tls.el
@@ -47,9 +47,6 @@
(require 'gnutls)
-(autoload 'format-spec "format-spec")
-(autoload 'format-spec-make "format-spec")
-
(defgroup tls nil
"Transport Layer Security (TLS) parameters."
:group 'comm)
@@ -224,14 +221,11 @@ Fourth arg PORT is an integer specifying a port to
connect to."
(while (and (not done) (setq cmd (pop cmds)))
(let ((process-connection-type tls-process-connection-type)
(formatted-cmd
- (format-spec
- cmd
- (format-spec-make
- ?t (car (gnutls-trustfiles))
- ?h host
- ?p (if (integerp port)
- (int-to-string port)
- port)))))
+ (format-spec cmd `((?t . ,(car (gnutls-trustfiles)))
+ (?h . ,host)
+ (?p . ,(if (integerp port)
+ (number-to-string port)
+ port))))))
(message "Opening TLS connection with `%s'..." formatted-cmd)
(setq process (start-process
name buffer shell-file-name shell-command-switch
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 02af263..9df51c1 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -139,12 +139,232 @@ The second subexpression should match the bug reference
(usually a number)."
(when url
(browse-url url))))))
+(defun bug-reference--maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt)
+ (when (string-match url-rx url)
+ (setq-local bug-reference-bug-regexp bug-rx)
+ (setq-local bug-reference-url-format
+ (let (groups)
+ (dotimes (i (/ (length (match-data)) 2))
+ (push (match-string i url) groups))
+ (funcall bug-url-fmt (nreverse groups))))))
+
+(defvar bug-reference-setup-from-vc-alist
+ `(;;
+ ;; GNU projects on savannah.
+ ;;
+ ;; Not all of them use debbugs but that doesn't really matter
+ ;; because the auto-setup is only performed if
+ ;; `bug-reference-url-format' and `bug-reference-bug-regexp'
+ ;; aren't set already.
+ ("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:"
+ "\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>"
+ ,(lambda (_) "https://debbugs.gnu.org/%s";))
+ ;;
+ ;; GitHub projects.
+ ;;
+ ;; Here #17 may refer to either an issue or a pull request but
+ ;; visiting the issue/17 web page will automatically redirect to
+ ;; the pull/17 page if 17 is a PR. Explicit user/project#17 links
+ ;; to possibly different projects are also supported.
+ ("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+ "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
+ ,(lambda (groups)
+ (let ((ns-project (nth 1 groups)))
+ (lambda ()
+ (concat "https://github.com/";
+ (or
+ ;; Explicit user/proj#18 link.
+ (match-string 1)
+ ns-project)
+ "/issues/"
+ (match-string 2))))))
+ ;;
+ ;; GitLab projects.
+ ;;
+ ;; Here #18 is an issue and !17 is a merge request. Explicit
+ ;; namespace/project#18 or namespace/project!17 references to
+ ;; possibly different projects are also supported.
+ ("[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+ "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>"
+ ,(lambda (groups)
+ (let ((ns-project (nth 1 groups)))
+ (lambda ()
+ (concat "https://gitlab.com/";
+ (or (match-string 1)
+ ns-project)
+ "/-/"
+ (if (string= (match-string 3) "#")
+ "issues/"
+ "merge_requests/")
+ (match-string 2)))))))
+ "An alist for setting up `bug-reference-mode' based on VC URL.
+
+Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN).
+
+URL-REGEXP is matched against the version control URL of the
+current buffer's file. If it matches, BUG-REGEXP is set as
+`bug-reference-bug-regexp'. URL-FORMAT-FN is a function of one
+argument that receives a list of the groups 0 to N of matching
+URL-REGEXP against the VCS URL and returns the value to be set as
+`bug-reference-url-format'.")
+
+(defun bug-reference-try-setup-from-vc ()
+ "Try setting up `bug-reference-mode' based on VC information.
+Test each configuration in `bug-reference-setup-from-vc-alist'
+and apply it if applicable."
+ (let ((file-or-dir (or buffer-file-name
+ ;; Catches modes such as vc-dir and Magit.
+ default-directory)))
+ (when file-or-dir
+ (let* ((backend (vc-responsible-backend file-or-dir t))
+ (url
+ (or (ignore-errors
+ (vc-call-backend backend 'repository-url "upstream"))
+ (ignore-errors
+ (vc-call-backend backend 'repository-url)))))
+ (when url
+ (catch 'found
+ (dolist (config bug-reference-setup-from-vc-alist)
+ (when (apply #'bug-reference--maybe-setup-from-vc
+ url config)
+ (throw 'found t)))))))))
+
+(defvar bug-reference-setup-from-mail-alist
+ `((,(regexp-opt '("emacs" "auctex" "gnus") 'words)
+ ,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org"
+ ;; List-Id of Gnus devel mailing list.
+ "ding.gnus.org"))
+ "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
+ "https://debbugs.gnu.org/%s";))
+ "An alist for setting up `bug-reference-mode' in mail modes.
+
+This takes action if `bug-reference-mode' is enabled in group and
+message buffers of Emacs mail clients. Currently, only Gnus is
+supported.
+
+Each element has the form
+
+ (GROUP-REGEXP HEADER-REGEXP BUG-REGEXP URL-FORMAT)
+
+GROUP-REGEXP is a regexp matched against the current mail folder
+or newsgroup name. HEADER-REGEXP is a regexp matched against the
+From, To, Cc, Newsgroup, and List-ID header values of the current
+mail or newsgroup message. If any of those matches, BUG-REGEXP
+is set as `bug-reference-bug-regexp' and URL-FORMAT is set as
+`bug-reference-url-format'.
+
+Note: In Gnus, if a summary buffer has been set up based on
+GROUP-REGEXP, all article buffers opened from there will get the
+same `bug-reference-url-format' and `bug-reference-url-format'.")
+
+(defvar gnus-newsgroup-name)
+
+(defun bug-reference--maybe-setup-from-mail (group header-values)
+ "Set up according to mail GROUP or HEADER-VALUES.
+Group is a mail group/folder name and HEADER-VALUES is a list of
+mail header values, e.g., the values of From, To, Cc, List-ID,
+and Newsgroup.
+
+If any GROUP-REGEXP or HEADER-REGEXP of
+`bug-reference-setup-from-mail-alist' matches GROUP or any
+element in HEADER-VALUES, the corresponding BUG-REGEXP and
+URL-FORMAT are set."
+ (catch 'setup-done
+ (dolist (config bug-reference-setup-from-mail-alist)
+ (when (or
+ (and group
+ (car config)
+ (string-match-p (car config) group))
+ (and header-values
+ (nth 1 config)
+ (catch 'matching-header
+ (dolist (h header-values)
+ (when (and h (string-match-p (nth 1 config) h))
+ (throw 'matching-header t))))))
+ (setq-local bug-reference-bug-regexp (nth 2 config))
+ (setq-local bug-reference-url-format (nth 3 config))
+ (throw 'setup-done t)))))
+
+(defun bug-reference-try-setup-from-gnus ()
+ "Try setting up `bug-reference-mode' based on Gnus group or article.
+Test each configuration in `bug-reference-setup-from-mail-alist'
+and set it if applicable."
+ (when (and (derived-mode-p 'gnus-summary-mode)
+ (bound-and-true-p gnus-newsgroup-name))
+ ;; Gnus reuses its article buffer so we have to check whenever the
+ ;; article changes.
+ (add-hook 'gnus-article-prepare-hook
+ #'bug-reference--try-setup-gnus-article)
+ (bug-reference--maybe-setup-from-mail gnus-newsgroup-name nil)))
+
+(defvar gnus-article-buffer)
+(defvar gnus-original-article-buffer)
+(defvar gnus-summary-buffer)
+
+(defun bug-reference--try-setup-gnus-article ()
+ (with-demoted-errors
+ "Error in bug-reference--try-setup-gnus-article: %S"
+ (when (and bug-reference-mode ;; Only if enabled in article buffers.
+ (derived-mode-p
+ 'gnus-article-mode
+ ;; Apparently, gnus-article-prepare-hook is run in the
+ ;; summary buffer...
+ 'gnus-summary-mode)
+ gnus-article-buffer
+ gnus-original-article-buffer
+ (buffer-live-p (get-buffer gnus-article-buffer))
+ (buffer-live-p (get-buffer gnus-original-article-buffer)))
+ (with-current-buffer gnus-article-buffer
+ (catch 'setup-done
+ ;; Copy over the values from the summary buffer.
+ (when (and gnus-summary-buffer
+ (buffer-live-p gnus-summary-buffer))
+ (setq-local bug-reference-bug-regexp
+ (with-current-buffer gnus-summary-buffer
+ bug-reference-bug-regexp))
+ (setq-local bug-reference-url-format
+ (with-current-buffer gnus-summary-buffer
+ bug-reference-url-format))
+ (when (and bug-reference-bug-regexp
+ bug-reference-url-format)
+ (throw 'setup-done t)))
+ ;; If the summary had no values, try setting according to
+ ;; the values of the From, To, and Cc headers.
+ (let (header-values)
+ (with-current-buffer
+ (get-buffer gnus-original-article-buffer)
+ (save-excursion
+ (goto-char (point-min))
+ ;; The Newsgroup is omitted because we already matched
+ ;; based on group name in the summary buffer.
+ (dolist (field '("list-id" "to" "from" "cc"))
+ (let ((val (mail-fetch-field field)))
+ (when val
+ (push val header-values))))))
+ (bug-reference--maybe-setup-from-mail nil header-values)))))))
+
+(defun bug-reference--run-auto-setup ()
+ (when (or bug-reference-mode
+ bug-reference-prog-mode)
+ ;; Automatic setup only if the variables aren't already set, e.g.,
+ ;; by a local variables section in the file.
+ (unless (and bug-reference-bug-regexp
+ bug-reference-url-format)
+ (with-demoted-errors
+ "Error during bug-reference auto-setup: %S"
+ (catch 'setup
+ (dolist (f (list #'bug-reference-try-setup-from-vc
+ #'bug-reference-try-setup-from-gnus))
+ (when (funcall f)
+ (throw 'setup t))))))))
+
;;;###autoload
(define-minor-mode bug-reference-mode
"Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
nil
""
nil
+ :after-hook (bug-reference--run-auto-setup)
(if bug-reference-mode
(jit-lock-register #'bug-reference-fontify)
(jit-lock-unregister #'bug-reference-fontify)
@@ -158,6 +378,7 @@ The second subexpression should match the bug reference
(usually a number)."
nil
""
nil
+ :after-hook (bug-reference--run-auto-setup)
(if bug-reference-prog-mode
(jit-lock-register #'bug-reference-fontify)
(jit-lock-unregister #'bug-reference-fontify)
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index f3df44f..bfbe236 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,7 +1,7 @@
;;; project.el --- Operations on the current project -*- lexical-binding: t;
-*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
-;; Version: 0.3.0
+;; Version: 0.4.0
;; Package-Requires: ((emacs "26.3"))
;; This is a GNU ELPA :core package. Avoid using functionality that
@@ -195,7 +195,7 @@ subset of the project root and external roots.
The default implementation uses `find-program'. PROJECT is used
to find the list of ignores for each directory."
- (cl-mapcan
+ (mapcan
(lambda (dir)
(project--files-in-directory dir
(project--dir-ignores project dir)))
@@ -306,7 +306,7 @@ backend implementation of `project-external-roots'.")
(if (and
;; FIXME: Invalidate the cache when the value
;; of this variable changes.
- project-vc-merge-submodules
+ (project--vc-merge-submodules-p root)
(project--submodule-p root))
(let* ((parent (file-name-directory
(directory-file-name root))))
@@ -351,7 +351,7 @@ backend implementation of `project-external-roots'.")
(list (project-root project))))
(cl-defmethod project-files ((project (head vc)) &optional dirs)
- (cl-mapcan
+ (mapcan
(lambda (dir)
(let (backend)
(if (and (file-equal-p dir (cdr project))
@@ -396,19 +396,20 @@ backend implementation of `project-external-roots'.")
(split-string
(apply #'vc-git--run-command-string nil "ls-files" args)
"\0" t)))
- ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'.
- (let* ((submodules (project--git-submodules))
- (sub-files
- (mapcar
- (lambda (module)
- (when (file-directory-p module)
- (project--vc-list-files
- (concat default-directory module)
- backend
- extra-ignores)))
- submodules)))
- (setq files
- (apply #'nconc files sub-files)))
+ (when (project--vc-merge-submodules-p default-directory)
+ ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'.
+ (let* ((submodules (project--git-submodules))
+ (sub-files
+ (mapcar
+ (lambda (module)
+ (when (file-directory-p module)
+ (project--vc-list-files
+ (concat default-directory module)
+ backend
+ extra-ignores)))
+ submodules)))
+ (setq files
+ (apply #'nconc files sub-files))))
;; 'git ls-files' returns duplicate entries for merge conflicts.
;; XXX: Better solutions welcome, but this seems cheap enough.
(delete-consecutive-dups files)))
@@ -429,6 +430,11 @@ backend implementation of `project-external-roots'.")
(lambda (s) (concat default-directory s))
(split-string (buffer-string) "\0" t)))))))
+(defun project--vc-merge-submodules-p (dir)
+ (project--value-in-dir
+ 'project-vc-merge-submodules
+ dir))
+
(defun project--git-submodules ()
;; 'git submodule foreach' is much slower.
(condition-case nil
@@ -484,6 +490,28 @@ DIRS must contain directory names."
;; Sidestep the issue of expanded/abbreviated file names here.
(cl-set-difference files dirs :test #'file-in-directory-p))
+
+;;; Project commands
+
+;;;###autoload
+(defvar project-prefix-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "f" 'project-find-file)
+ (define-key map "b" 'project-switch-to-buffer)
+ (define-key map "s" 'project-shell)
+ (define-key map "d" 'project-dired)
+ (define-key map "v" 'project-vc-dir)
+ (define-key map "c" 'project-compile)
+ (define-key map "e" 'project-eshell)
+ (define-key map "k" 'project-kill-buffers)
+ (define-key map "p" 'project-switch-project)
+ (define-key map "g" 'project-find-regexp)
+ (define-key map "r" 'project-query-replace-regexp)
+ map)
+ "Keymap for project commands.")
+
+;;;###autoload (define-key ctl-x-map "p" project-prefix-map)
+
(defun project--value-in-dir (var dir)
(with-temp-buffer
(setq default-directory dir)
@@ -644,6 +672,7 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in
(defun project-find-file-in (filename dirs project)
"Complete FILENAME in DIRS in PROJECT and visit the result."
(let* ((all-files (project-files project dirs))
+ (completion-ignore-case read-file-name-completion-ignore-case)
(file (funcall project-read-file-name-function
"Find file" all-files nil nil
filename)))
@@ -674,30 +703,53 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in
;;;###autoload
(defun project-dired ()
- "Open Dired in the current project."
+ "Start Dired in the current project's root."
(interactive)
(dired (project-root (project-current t))))
;;;###autoload
(defun project-vc-dir ()
- "Open VC-Dir in the current project."
+ "Run VC-Dir in the current project's root."
(interactive)
(vc-dir (project-root (project-current t))))
;;;###autoload
(defun project-shell ()
- "Open Shell in the current project."
+ "Start an inferior shell in the current project's root directory.
+If a buffer already exists for running a shell in the project's root,
+switch to it. Otherwise, create a new shell buffer.
+With \\[universal-argument] prefix arg, create a new inferior shell buffer even
+if one already exist."
(interactive)
- (let ((default-directory (project-root (project-current t))))
- ;; Use ‘create-file-buffer’ to uniquify shell buffer names.
- (shell (create-file-buffer "*shell*"))))
+ (let* ((default-directory (project-root (project-current t)))
+ (default-project-shell-name
+ (concat "*" (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory default-directory)))
+ "-shell*"))
+ (shell-buffer (get-buffer default-project-shell-name)))
+ (if (and shell-buffer (not current-prefix-arg))
+ (pop-to-buffer shell-buffer)
+ (shell (generate-new-buffer-name default-project-shell-name)))))
;;;###autoload
(defun project-eshell ()
- "Open Eshell in the current project."
+ "Start Eshell in the current project's root directory.
+If a buffer already exists for running Eshell in the project's root,
+switch to it. Otherwise, create a new Eshell buffer.
+With \\[universal-argument] prefix arg, create a new Eshell buffer even
+if one already exist."
(interactive)
- (let ((default-directory (project-root (project-current t))))
- (eshell t)))
+ (let* ((default-directory (project-root (project-current t)))
+ (eshell-buffer-name
+ (concat "*" (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory default-directory)))
+ "-eshell*"))
+ (eshell-buffer (get-buffer eshell-buffer-name)))
+ (if (and eshell-buffer (not current-prefix-arg))
+ (pop-to-buffer eshell-buffer)
+ (eshell t))))
(declare-function fileloop-continue "fileloop" ())
@@ -744,11 +796,76 @@ Arguments the same as in `compile'."
(default-directory (project-root pr)))
(compile command comint)))
+;;;###autoload
+(defun project-switch-to-buffer ()
+ "Switch to another buffer that is related to the current project.
+A buffer is related to a project if its `default-directory'
+is inside the directory hierarchy of the project's root."
+ (interactive)
+ (let* ((root (project-root (project-current t)))
+ (current-buffer (current-buffer))
+ (other-buffer (other-buffer current-buffer))
+ (other-name (buffer-name other-buffer))
+ (predicate
+ (lambda (buffer)
+ ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist.
+ (and (not (eq (cdr buffer) current-buffer))
+ (when-let ((file (buffer-local-value 'default-directory
+ (cdr buffer))))
+ (file-in-directory-p file root))))))
+ (switch-to-buffer
+ (read-buffer
+ "Switch to buffer: "
+ (when (funcall predicate (cons other-name other-buffer))
+ other-name)
+ t
+ predicate))))
+
+(defcustom project-kill-buffers-skip-conditions
+ '("\\*Help\\*")
+ "Conditions for buffers `project-kill-buffers' should not kill.
+Each condition is either a regular expression matching a buffer
+name, or a predicate function that takes a buffer object as
+argument and returns non-nil if it matches. Buffers that match
+any of the conditions will not be killed."
+ :type '(repeat (choice regexp function))
+ :version "28.1")
+
+(defun project--buffer-list (pr)
+ "Return the list of all buffers in project PR."
+ (let ((root (project-root pr))
+ bufs)
+ (dolist (buf (buffer-list))
+ (let ((filename (or (buffer-file-name buf)
+ (buffer-local-value 'default-directory buf))))
+ (when (and filename (file-in-directory-p filename root))
+ (push buf bufs))))
+ (nreverse bufs)))
+
+;;;###autoload
+(defun project-kill-buffers ()
+ "Kill all live buffers belonging to the current project.
+Certain buffers may be \"spared\", see `project-kill-buffers-skip-conditions'."
+ (interactive)
+ (let ((pr (project-current t)) bufs)
+ (dolist (buf (project--buffer-list pr))
+ (unless (seq-some
+ (lambda (c)
+ (cond ((stringp c)
+ (string-match-p c (buffer-name buf)))
+ ((functionp c)
+ (funcall c buf))))
+ project-kill-buffers-skip-conditions)
+ (push buf bufs)))
+ (when (yes-or-no-p (format "Kill %d buffers in %s? "
+ (length bufs) (project-root pr)))
+ (mapc #'kill-buffer bufs))))
+
;;; Project list
(defcustom project-list-file (locate-user-emacs-file "projects")
- "File to save the list of known projects."
+ "File in which to save the list of known projects."
:type 'file
:version "28.1"
:group 'project)
@@ -757,7 +874,7 @@ Arguments the same as in `compile'."
"List of known project directories.")
(defun project--read-project-list ()
- "Initialize `project--list' from the project list file."
+ "Initialize `project--list' using contents of `project-list-file'."
(let ((filename project-list-file))
(setq project--list
(when (file-exists-p filename)
@@ -766,12 +883,12 @@ Arguments the same as in `compile'."
(read (current-buffer)))))))
(defun project--ensure-read-project-list ()
- "Initialize `project--list' if it hasn't already been."
+ "Initialize `project--list' if it isn't already initialized."
(when (eq project--list 'unset)
(project--read-project-list)))
(defun project--write-project-list ()
- "Persist `project--list' to the project list file."
+ "Save `project--list' in `project-list-file'."
(let ((filename project-list-file))
(with-temp-buffer
(insert ";;; -*- lisp-data -*-\n")
@@ -780,7 +897,7 @@ Arguments the same as in `compile'."
(defun project--add-to-project-list-front (pr)
"Add project PR to the front of the project list.
-Save the result to disk if the project list was changed."
+Save the result in `project-list-file' if the list of projects has changed."
(project--ensure-read-project-list)
(let ((dir (project-root pr)))
(unless (equal (caar project--list) dir)
@@ -789,9 +906,10 @@ Save the result to disk if the project list was changed."
(project--write-project-list))))
(defun project--remove-from-project-list (pr-dir)
- "Remove directory PR-DIR from the project list.
+ "Remove directory PR-DIR of a missing project from the project list.
If the directory was in the list before the removal, save the
-result to disk."
+result in `project-list-file'. Announce the project's removal
+from the list."
(project--ensure-read-project-list)
(when (assoc pr-dir project--list)
(setq project--list (assoc-delete-all pr-dir project--list))
@@ -799,9 +917,10 @@ result to disk."
(project--write-project-list)))
(defun project-prompt-project-dir ()
- "Prompt the user for a directory from known project roots.
-The project is chosen among projects known from the project list.
-It's also possible to enter an arbitrary directory."
+ "Prompt the user for a directory that is one of the known project roots.
+The project is chosen among projects known from the project list,
+see `project-list-file'.
+It's also possible to enter an arbitrary directory not in the list."
(project--ensure-read-project-list)
(let* ((dir-choice "... (choose a dir)")
(choices
@@ -820,18 +939,17 @@ It's also possible to enter an arbitrary directory."
;;;###autoload
(defvar project-switch-commands
'((?f "Find file" project-find-file)
- (?r "Find regexp" project-find-regexp)
+ (?g "Find regexp" project-find-regexp)
(?d "Dired" project-dired)
(?v "VC-Dir" project-vc-dir)
- (?s "Shell" project-shell)
(?e "Eshell" project-eshell))
"Alist mapping keys to project switching menu entries.
Used by `project-switch-project' to construct a dispatch menu of
commands available upon \"switching\" to another project.
-Each element looks like (KEY LABEL COMMAND), where COMMAND is the
+Each element is of the form (KEY LABEL COMMAND), where COMMAND is the
command to run when KEY is pressed. LABEL is used to distinguish
-the choice in the dispatch menu.")
+the menu entries in the dispatch menu.")
(defun project--keymap-prompt ()
"Return a prompt for the project swithing dispatch menu."
@@ -845,9 +963,9 @@ the choice in the dispatch menu.")
;;;###autoload
(defun project-switch-project ()
- "\"Switch\" to another project by running a chosen command.
-The available commands are picked from `project-switch-commands'
-and presented in a dispatch menu."
+ "\"Switch\" to another project by running an Emacs command.
+The available commands are presented as a dispatch menu
+made from `project-switch-commands'."
(interactive)
(let ((dir (project-prompt-project-dir))
(choice nil))
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 1ca9f01..22248f0 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -633,6 +633,8 @@ builtins.")
(,(lambda (limit)
(let ((re (python-rx (group (+ (any word ?. ?_)))
(? ?\[ (+ (not (any ?\]))) ?\]) (* space)
+ ;; A type, like " : int ".
+ (? ?: (* space) (+ (any word ?. ?_)) (* space))
assignment-operator))
(res nil))
(while (and (setq res (re-search-forward re limit t))
@@ -2090,7 +2092,7 @@ executed through tramp connections."
This variable, when set to a string, makes the environment to be
modified such that shells are started within the specified
virtualenv."
- :type '(choice (const nil) string)
+ :type '(choice (const nil) directory)
:group 'python)
(defcustom python-shell-setup-codes nil
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 6fd750d..c86fc59 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -2683,7 +2683,7 @@ highlighting rules in SQL mode.")
nil 'require-match
init 'sql-product-history init))))
-(defun sql-add-product (product display &optional plist)
+(defun sql-add-product (product display &rest plist)
"Add support for a database product in `sql-mode'.
Add PRODUCT to `sql-product-alist' which enables `sql-mode' to
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index 87f901a..6400e1e 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -605,7 +605,7 @@ are lineup only when \\[verilog-pretty-declarations] is
typed."
(function :tag "Other"))
:group 'verilog-mode-indent )
(put 'verilog-auto-lineup 'safe-local-variable
- '(lambda (x) (memq x '(nil all assignments declarations))))
+ (lambda (x) (memq x '(nil all assignments declarations))))
(defcustom verilog-indent-level 3
"Indentation of Verilog statements with respect to containing block."
@@ -1118,7 +1118,7 @@ SystemVerilog designs."
:type 'boolean
:group 'verilog-mode-auto)
(put 'verilog-auto-reset-widths 'safe-local-variable
- '(lambda (x) (memq x '(nil t unbased))))
+ (lambda (x) (memq x '(nil t unbased))))
(defcustom verilog-assignment-delay ""
"Text used for delays in delayed assignments. Add a trailing space if set."
@@ -1138,7 +1138,7 @@ line."
(const :tag "Line up Assignment statements" single))
:group 'verilog-mode-auto)
(put 'verilog-auto-arg-format 'safe-local-variable
- '(lambda (x) (memq x '(packed single))))
+ (lambda (x) (memq x '(packed single))))
(defcustom verilog-auto-arg-sort nil
"Non-nil means AUTOARG signal names will be sorted, not in declaration order.
@@ -1263,7 +1263,7 @@ otherwise no vectors if sizes match (like using nil)."
:group 'verilog-mode-auto
:type '(choice (const nil) (const t) (const unsigned)))
(put 'verilog-auto-inst-vector 'safe-local-variable
- '(lambda (x) (memq x '(nil t unsigned))))
+ (lambda (x) (memq x '(nil t unsigned))))
(defcustom verilog-auto-inst-template-numbers nil
"If true, when creating templated ports with AUTOINST, add a comment.
@@ -1280,7 +1280,7 @@ won't merge conflict."
:group 'verilog-mode-auto
:type '(choice (const nil) (const t) (const lhs)))
(put 'verilog-auto-inst-template-numbers 'safe-local-variable
- '(lambda (x) (memq x '(nil t lhs))))
+ (lambda (x) (memq x '(nil t lhs))))
(defcustom verilog-auto-inst-template-required nil
"If non-nil, when creating a port with AUTOINST, require a template.
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 5b5fb4b..3e3a37f 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -264,7 +264,7 @@ be found, return nil.
The default implementation uses `semantic-symref-tool-alist' to
find a search tool; by default, this uses \"find | grep\" in the
`project-current' roots."
- (cl-mapcan
+ (mapcan
(lambda (dir)
(xref-references-in-directory identifier dir))
(let ((pr (project-current t)))
@@ -1383,8 +1383,8 @@ Such as the current syntax table and the applied syntax
properties."
(let (xref--last-file-buffer
(tmp-buffer (generate-new-buffer " *xref-temp*")))
(unwind-protect
- (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer))
- hits)
+ (mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer))
+ hits)
(kill-buffer tmp-buffer))))
(defun xref--collect-matches (hit regexp tmp-buffer)
diff --git a/lisp/simple.el b/lisp/simple.el
index 0fe8a10..a28d10f 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -212,7 +212,7 @@ all other buffers."
(const :tag "Single next-error capable buffer on selected
frame"
next-error-buffer-on-selected-frame)
(const :tag "Current buffer if next-error capable and outside
navigation"
- next-error-no-navigation-try-current)
+ next-error-buffer-unnavigated-current)
(function :tag "Other function"))
:group 'next-error
:version "28.1")
@@ -242,10 +242,9 @@ from which next-error navigated, and a target buffer
TO-BUFFER."
(if (eq (length window-buffers) 1)
(car window-buffers))))
-(defun next-error-no-navigation-try-current (&optional
- avoid-current
- extra-test-inclusive
- extra-test-exclusive)
+(defun next-error-buffer-unnavigated-current (&optional avoid-current
+ extra-test-inclusive
+ extra-test-exclusive)
"Try the current buffer when outside navigation.
But return nil if we navigated to the current buffer by the means
of `next-error' command. Othewise, return it if it's next-error
@@ -3951,7 +3950,12 @@ is used for ERROR-BUFFER.
Optional seventh arg DISPLAY-ERROR-BUFFER, if non-nil, means to
display the error buffer if there were any errors. When called
-interactively, this is t."
+interactively, this is t.
+
+Non-nil REGION-NONCONTIGUOUS-P means that the region is composed of
+noncontiguous pieces. The most common example of this is a
+rectangular region, where the pieces are separated by newline
+characters."
(interactive (let (string)
(unless (mark)
(user-error "The mark is not set now, so there is no
region"))
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index eb3ad72..b54258a 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -44,25 +44,12 @@
:group 'convenience
:version "27.1")
-(defgroup tab-bar-faces nil
+(defgroup tab-bar-faces '((tab-bar custom-face)) ; tab-bar is defined in
faces.el
"Faces used in the tab bar."
:group 'tab-bar
:group 'faces
:version "27.1")
-(defface tab-bar
- '((((class color) (min-colors 88))
- :inherit variable-pitch
- :background "grey85"
- :foreground "black")
- (((class mono))
- :background "grey")
- (t
- :inverse-video t))
- "Tab bar face."
- :version "27.1"
- :group 'tab-bar-faces)
-
(defface tab-bar-tab
'((default
:inherit tab-bar)
diff --git a/lisp/tab-line.el b/lisp/tab-line.el
index 7a2bdc0..e8c4dc4 100644
--- a/lisp/tab-line.el
+++ b/lisp/tab-line.el
@@ -35,26 +35,12 @@
:group 'convenience
:version "27.1")
-(defgroup tab-line-faces nil
+(defgroup tab-line-faces '((tab-line custom-face)) ; tab-line is defined in
faces.el
"Faces used in the tab line."
:group 'tab-line
:group 'faces
:version "27.1")
-(defface tab-line
- '((((class color) (min-colors 88))
- :inherit variable-pitch
- :height 0.9
- :background "grey85"
- :foreground "black")
- (((class mono))
- :background "grey")
- (t
- :inverse-video t))
- "Tab line face."
- :version "27.1"
- :group 'tab-line-faces)
-
(defface tab-line-tab
'((default
:inherit tab-line)
diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el
index 39ca2d3..73e2431 100644
--- a/lisp/term/tty-colors.el
+++ b/lisp/term/tty-colors.el
@@ -923,62 +923,8 @@ The returned value reflects the standard Emacs definition
of
COLOR (see the info node `(emacs) Colors'), regardless of whether
the terminal can display it, so the return value should be the
same regardless of what display is being used."
- (let ((len (length color)))
- (cond ((and (>= len 4) ;; HTML/CSS/SVG-style "#XXYYZZ" color spec
- (eq (aref color 0) ?#)
- (member (aref color 1)
- '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
- ?a ?b ?c ?d ?e ?f
- ?A ?B ?C ?D ?E ?F)))
- ;; Translate the string "#XXYYZZ" into a list of numbers
- ;; (XX YY ZZ), scaling each to the {0..65535} range. This
- ;; follows the HTML color convention, where both "#fff" and
- ;; "#ffffff" represent the same color, white.
- (let* ((ndig (/ (- len 1) 3))
- (maxval (1- (ash 1 (* 4 ndig))))
- (i1 1)
- (i2 (+ i1 ndig))
- (i3 (+ i2 ndig))
- (i4 (+ i3 ndig)))
- (list
- (/ (* (string-to-number
- (substring color i1 i2) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i2 i3) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i3 i4) 16)
- 65535)
- maxval))))
- ((and (>= len 9) ;; X-style rgb:xx/yy/zz color spec
- (string= (substring color 0 4) "rgb:"))
- ;; Translate the string "rgb:XX/YY/ZZ" into a list of
- ;; numbers (XX YY ZZ), scaling each to the {0..65535}
- ;; range. "rgb:F/F/F" is white.
- (let* ((ndig (/ (- len 3) 3))
- (maxval (1- (ash 1 (* 4 (- ndig 1)))))
- (i1 4)
- (i2 (+ i1 ndig))
- (i3 (+ i2 ndig))
- (i4 (+ i3 ndig)))
- (list
- (/ (* (string-to-number
- (substring color i1 (- i2 1)) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i2 (- i3 1)) 16)
- 65535)
- maxval)
- (/ (* (string-to-number
- (substring color i3 (1- i4)) 16)
- 65535)
- maxval))))
- (t
- (cdr (assoc color color-name-rgb-alist))))))
+ (or (internal-color-values-from-color-spec color)
+ (cdr (assoc color color-name-rgb-alist))))
(defun tty-color-translate (color &optional frame)
"Given a color COLOR, return the index of the corresponding TTY color.
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index 4712f31..0018b89 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -850,11 +850,11 @@ Predefined dialects include BibTeX and biblatex."
To interactively change the dialect use the command `bibtex-set-dialect'."
:group 'bibtex
:version "24.1"
- :set '(lambda (symbol value)
- (set-default symbol value)
- ;; `bibtex-set-dialect' is undefined during loading (no problem)
- (if (fboundp 'bibtex-set-dialect)
- (bibtex-set-dialect value)))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ ;; `bibtex-set-dialect' is undefined during loading (no problem).
+ (if (fboundp 'bibtex-set-dialect)
+ (bibtex-set-dialect value)))
:type '(choice (const BibTeX)
(const biblatex)
(symbol :tag "Custom")))
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 1b302e3..e3d5759 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -2295,9 +2295,6 @@ FILE is typically the output DVI or PDF file."
(setq uptodate nil)))))
uptodate)))
-
-(autoload 'format-spec "format-spec")
-
(defvar tex-executable-cache nil)
(defun tex-executable-exists-p (name)
"Like `executable-find' but with a cache."
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index e5d307e..f98730e 100644
--- a/lisp/vc/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -1316,6 +1316,15 @@ stream. Standard error output is discarded."
vc-bzr-revision-keywords))
string pred)))))
+(defun vc-bzr-repository-url (file-or-dir &optional _remote-name)
+ (let ((default-directory (vc-bzr-root file-or-dir)))
+ (with-temp-buffer
+ (vc-bzr-command "info" (current-buffer) 0 nil)
+ (goto-char (point-min))
+ (if (re-search-forward "parent branch: \\(.*\\)$" nil t)
+ (match-string 1)
+ (error "Cannot determine Bzr repository URL")))))
+
(provide 'vc-bzr)
;;; vc-bzr.el ends here
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index dcb5228..b5cb842 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -101,6 +101,7 @@
;; - rename-file (old new) OK
;; - find-file-hook () OK
;; - conflicted-files OK
+;; - repository-url (file-or-dir) OK
;;; Code:
@@ -734,6 +735,7 @@ or an empty string if none."
(with-current-buffer standard-output
(vc-git--out-ok "symbolic-ref" "HEAD"))))
(stash-list (vc-git-stash-list))
+ (default-directory dir)
branch remote remote-url stash-button stash-string)
(if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
@@ -746,14 +748,8 @@ or an empty string if none."
(concat "branch." branch ".remote")))))
(when (string-match "\\([^\n]+\\)" remote)
(setq remote (match-string 1 remote)))
- (when remote
- (setq remote-url
- (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "config"
- (concat "remote." remote ".url"))))))
- (when (string-match "\\([^\n]+\\)" remote-url)
- (setq remote-url (match-string 1 remote-url))))
+ (when (> (length remote) 0)
+ (setq remote-url (vc-git-repository-url dir remote))))
(setq branch "not (detached HEAD)"))
(when stash-list
(let* ((len (length stash-list))
@@ -808,7 +804,7 @@ or an empty string if none."
(propertize "Branch : " 'face 'font-lock-type-face)
(propertize branch
'face 'font-lock-variable-name-face)
- (when remote
+ (when remote-url
(concat
"\n"
(propertize "Remote : " 'face 'font-lock-type-face)
@@ -820,10 +816,10 @@ or an empty string if none."
(when (file-exists-p (expand-file-name ".git/rebase-apply" (vc-git-root
dir)))
(propertize "\nRebase : in progress" 'face
'font-lock-warning-face))
(if stash-list
- (concat
- (propertize "\nStash : " 'face 'font-lock-type-face)
- stash-button
- stash-string)
+ (concat
+ (propertize "\nStash : " 'face 'font-lock-type-face)
+ stash-button
+ stash-string)
(concat
(propertize "\nStash : " 'face 'font-lock-type-face)
(propertize "Nothing stashed"
@@ -1082,6 +1078,13 @@ This prompts for a branch to merge from."
"DU" "AA" "UU"))
(push (expand-file-name file directory) files)))))))
+(defun vc-git-repository-url (file-or-dir &optional remote-name)
+ (let ((default-directory (vc-git-root file-or-dir)))
+ (with-temp-buffer
+ (vc-git-command (current-buffer) 0 nil "remote" "get-url"
+ (or remote-name "origin"))
+ (buffer-substring-no-properties (point-min) (1- (point-max))))))
+
;; Everywhere but here, follows vc-git-command, which uses vc-do-command
;; from vc-dispatcher.
(autoload 'vc-resynch-buffer "vc-dispatcher")
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index 40d7573..95ced7b 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -1525,6 +1525,14 @@ This function differs from vc-do-command in that it
invokes
(defun vc-hg-root (file)
(vc-find-root file ".hg"))
+(defun vc-hg-repository-url (file-or-dir &optional remote-name)
+ (let ((default-directory (vc-hg-root file-or-dir)))
+ (with-temp-buffer
+ (vc-hg-command (current-buffer) 0 nil
+ "config"
+ (concat "paths." (or remote-name "default")))
+ (buffer-substring-no-properties (point-min) (1- (point-max))))))
+
(provide 'vc-hg)
;;; vc-hg.el ends here
diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el
index d039bf3..e108b3a 100644
--- a/lisp/vc/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -816,7 +816,14 @@ Set file properties accordingly. If FILENAME is non-nil,
return its status."
(push (match-string 1 loglines) vc-svn-revisions)
(setq start (+ start (match-end 0)))
(setq loglines (buffer-substring-no-properties start (point-max)))))
- vc-svn-revisions)))
+ vc-svn-revisions)))
+
+(defun vc-svn-repository-url (file-or-dir &optional _remote-name)
+ (let ((default-directory (vc-svn-root file-or-dir)))
+ (with-temp-buffer
+ (vc-svn-command (current-buffer) 0 nil
+ "info" "--show-item" "repos-root-url")
+ (buffer-substring-no-properties (point-min) (1- (point-max))))))
(provide 'vc-svn)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index c640ba0..9b12d44 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -553,6 +553,13 @@
;; Return the list of files where conflict resolution is needed in
;; the project that contains DIR.
;; FIXME: what should it do with non-text conflicts?
+;;
+;; - repository-url (file-or-dir &optional remote-name)
+;;
+;; Returns the URL of the repository of the current checkout
+;; containing FILE-OR-DIR. The optional REMOTE-NAME specifies the
+;; remote (in Git parlance) whose URL is to be returned. It has
+;; only a meaning for distributed VCS and is ignored otherwise.
;;; Changes from the pre-25.1 API:
;;
@@ -957,7 +964,7 @@ use."
(throw 'found bk))))
;;;###autoload
-(defun vc-responsible-backend (file)
+(defun vc-responsible-backend (file &optional no-error)
"Return the name of a backend system that is responsible for FILE.
If FILE is already registered, return the
@@ -967,7 +974,10 @@ responsible for FILE is returned.
Note that if FILE is a symbolic link, it will not be resolved --
the responsible backend system for the symbolic link itself will
-be reported."
+be reported.
+
+If NO-ERROR is nil, signal an error that no VC backend is
+responsible for the given file."
(or (and (not (file-directory-p file)) (vc-backend file))
(catch 'found
;; First try: find a responsible backend. If this is for registration,
@@ -975,7 +985,8 @@ be reported."
(dolist (backend vc-handled-backends)
(and (vc-call-backend backend 'responsible-p file)
(throw 'found backend))))
- (error "No VC backend is responsible for %s" file)))
+ (unless no-error
+ (error "No VC backend is responsible for %s" file))))
(defun vc-expand-dirs (file-or-dir-list backend)
"Expands directories in a file list specification.
diff --git a/src/dispextern.h b/src/dispextern.h
index 0b1f3d1..e1d6edd 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -3514,6 +3514,8 @@ void update_face_from_frame_parameter (struct frame *,
Lisp_Object,
Lisp_Object);
extern bool tty_defined_color (struct frame *, const char *, Emacs_Color *,
bool, bool);
+bool parse_color_spec (const char *,
+ unsigned short *, unsigned short *, unsigned short *);
Lisp_Object tty_color_name (struct frame *, int);
void clear_face_cache (bool);
diff --git a/src/lisp.h b/src/lisp.h
index 70ef7db..54ade65 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1675,6 +1675,13 @@ ASIZE (Lisp_Object array)
}
INLINE ptrdiff_t
+gc_asize (Lisp_Object array)
+{
+ /* Like ASIZE, but also can be used in the garbage collector. */
+ return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG;
+}
+
+INLINE ptrdiff_t
PVSIZE (Lisp_Object pv)
{
return ASIZE (pv) & PSEUDOVECTOR_SIZE_MASK;
@@ -1856,22 +1863,17 @@ bool_vector_set (Lisp_Object a, EMACS_INT i, bool b)
INLINE Lisp_Object
AREF (Lisp_Object array, ptrdiff_t idx)
{
+ eassert (0 <= idx && idx < gc_asize (array));
return XVECTOR (array)->contents[idx];
}
INLINE Lisp_Object *
aref_addr (Lisp_Object array, ptrdiff_t idx)
{
+ eassert (0 <= idx && idx <= gc_asize (array));
return & XVECTOR (array)->contents[idx];
}
-INLINE ptrdiff_t
-gc_asize (Lisp_Object array)
-{
- /* Like ASIZE, but also can be used in the garbage collector. */
- return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG;
-}
-
INLINE void
ASET (Lisp_Object array, ptrdiff_t idx, Lisp_Object val)
{
diff --git a/src/nsterm.m b/src/nsterm.m
index 3dc7e1d..0e405fc 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -2341,9 +2341,6 @@ ns_get_color (const char *name, NSColor **col)
See https://lists.gnu.org/r/emacs-devel/2009-07/msg01203.html. */
{
NSColor *new = nil;
- static char hex[20];
- int scaling = 0;
- float r = -1.0, g, b;
NSString *nsname = [NSString stringWithUTF8String: name];
NSTRACE ("ns_get_color(%s, **)", name);
@@ -2386,51 +2383,31 @@ ns_get_color (const char *name, NSColor **col)
}
/* First, check for some sort of numeric specification. */
- hex[0] = '\0';
-
- if (name[0] == '0' || name[0] == '1' || name[0] == '.') /* RGB decimal */
+ unsigned short r16, g16, b16;
+ if (parse_color_spec (name, &r16, &g16, &b16))
{
- NSScanner *scanner = [NSScanner scannerWithString: nsname];
- [scanner scanFloat: &r];
- [scanner scanFloat: &g];
- [scanner scanFloat: &b];
- }
- else if (!strncmp(name, "rgb:", 4)) /* A newer X11 format -- rgb:r/g/b */
- scaling = (snprintf (hex, sizeof hex, "%s", name + 4) - 2) / 3;
- else if (name[0] == '#') /* An old X11 format; convert to newer */
- {
- int len = 0;
- while (isxdigit (name[len + 1]))
- len++;
- if (name[len + 1] == '\0' && len >= 1 && len <= 12 && len % 3 == 0)
- {
- scaling = len / 3;
- for (int i = 0; i < 3; i++)
- sprintf (hex + i * (scaling + 1), "%.*s/", scaling,
- name + 1 + i * scaling);
- hex[3 * (scaling + 1) - 1] = '\0';
- }
+ *col = [NSColor colorForEmacsRed: r16 / 65535.0
+ green: g16 / 65535.0
+ blue: b16 / 65535.0
+ alpha: 1.0];
+ unblock_input ();
+ return 0;
}
-
- if (hex[0])
+ else if (name[0] == '0' || name[0] == '1' || name[0] == '.')
{
- unsigned int rr, gg, bb;
- float fscale = (1 << (scaling * 4)) - 1;
- if (sscanf (hex, "%x/%x/%x", &rr, &gg, &bb))
+ /* RGB decimal */
+ NSScanner *scanner = [NSScanner scannerWithString: nsname];
+ float r, g, b;
+ if ( [scanner scanFloat: &r] && r >= 0 && r <= 1
+ && [scanner scanFloat: &g] && g >= 0 && g <= 1
+ && [scanner scanFloat: &b] && b >= 0 && b <= 1)
{
- r = rr / fscale;
- g = gg / fscale;
- b = bb / fscale;
+ *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0];
+ unblock_input ();
+ return 0;
}
}
- if (r >= 0.0F)
- {
- *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0];
- unblock_input ();
- return 0;
- }
-
/* Otherwise, color is expected to be from a list */
{
NSEnumerator *lenum, *cenum;
diff --git a/src/term.c b/src/term.c
index 94bf013..5cbb092 100644
--- a/src/term.c
+++ b/src/term.c
@@ -4168,6 +4168,15 @@ use the Bourne shell command 'TERM=...; export TERM'
(C-shell:\n\
could return 32767. */
tty->TN_max_colors = 16777216;
}
+ /* Fall back to xterm+direct (semicolon version) if requested
+ by the COLORTERM environment variable. */
+ else if ((bg = getenv("COLORTERM")) != NULL
+ && strcasecmp(bg, "truecolor") == 0)
+ {
+ tty->TS_set_foreground =
"\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m";
+ tty->TS_set_background =
"\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m";
+ tty->TN_max_colors = 16777216;
+ }
}
#endif
diff --git a/src/w32fns.c b/src/w32fns.c
index e595b02..ab86433 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -864,161 +864,14 @@ x_to_w32_color (const char * colorname)
block_input ();
- if (colorname[0] == '#')
+ unsigned short r, g, b;
+ if (parse_color_spec (colorname, &r, &g, &b))
{
- /* Could be an old-style RGB Device specification. */
- int size = strlen (colorname + 1);
- char *color = alloca (size + 1);
-
- strcpy (color, colorname + 1);
- if (size == 3 || size == 6 || size == 9 || size == 12)
- {
- UINT colorval;
- int i, pos;
- pos = 0;
- size /= 3;
- colorval = 0;
-
- for (i = 0; i < 3; i++)
- {
- char *end;
- char t;
- unsigned long value;
-
- /* The check for 'x' in the following conditional takes into
- account the fact that strtol allows a "0x" in front of
- our numbers, and we don't. */
- if (!isxdigit (color[0]) || color[1] == 'x')
- break;
- t = color[size];
- color[size] = '\0';
- value = strtoul (color, &end, 16);
- color[size] = t;
- if (errno == ERANGE || end - color != size)
- break;
- switch (size)
- {
- case 1:
- value = value * 0x10;
- break;
- case 2:
- break;
- case 3:
- value /= 0x10;
- break;
- case 4:
- value /= 0x100;
- break;
- }
- colorval |= (value << pos);
- pos += 0x8;
- if (i == 2)
- {
- unblock_input ();
- XSETINT (ret, colorval);
- return ret;
- }
- color = end;
- }
- }
- }
- else if (strnicmp (colorname, "rgb:", 4) == 0)
- {
- const char *color;
- UINT colorval;
- int i, pos;
- pos = 0;
-
- colorval = 0;
- color = colorname + 4;
- for (i = 0; i < 3; i++)
- {
- char *end;
- unsigned long value;
-
- /* The check for 'x' in the following conditional takes into
- account the fact that strtol allows a "0x" in front of
- our numbers, and we don't. */
- if (!isxdigit (color[0]) || color[1] == 'x')
- break;
- value = strtoul (color, &end, 16);
- if (errno == ERANGE)
- break;
- switch (end - color)
- {
- case 1:
- value = value * 0x10 + value;
- break;
- case 2:
- break;
- case 3:
- value /= 0x10;
- break;
- case 4:
- value /= 0x100;
- break;
- default:
- value = ULONG_MAX;
- }
- if (value == ULONG_MAX)
- break;
- colorval |= (value << pos);
- pos += 0x8;
- if (i == 2)
- {
- if (*end != '\0')
- break;
- unblock_input ();
- XSETINT (ret, colorval);
- return ret;
- }
- if (*end != '/')
- break;
- color = end + 1;
- }
+ unblock_input ();
+ /* Throw away the low 8 bits and return 0xBBGGRR. */
+ return make_fixnum ((b & 0xff00) << 8 | (g & 0xff00) | r >> 8);
}
- else if (strnicmp (colorname, "rgbi:", 5) == 0)
- {
- /* This is an RGB Intensity specification. */
- const char *color;
- UINT colorval;
- int i, pos;
- pos = 0;
-
- colorval = 0;
- color = colorname + 5;
- for (i = 0; i < 3; i++)
- {
- char *end;
- double value;
- UINT val;
- value = strtod (color, &end);
- if (errno == ERANGE)
- break;
- if (value < 0.0 || value > 1.0)
- break;
- val = (UINT)(0x100 * value);
- /* We used 0x100 instead of 0xFF to give a continuous
- range between 0.0 and 1.0 inclusive. The next statement
- fixes the 1.0 case. */
- if (val == 0x100)
- val = 0xFF;
- colorval |= (val << pos);
- pos += 0x8;
- if (i == 2)
- {
- if (*end != '\0')
- break;
- unblock_input ();
- XSETINT (ret, colorval);
- return ret;
- }
- if (*end != '/')
- break;
- color = end + 1;
- }
- }
/* I am not going to attempt to handle any of the CIE color schemes
or TekHVC, since I don't know the algorithms for conversion to
RGB. */
diff --git a/src/xfaces.c b/src/xfaces.c
index cf15528..308509a 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -220,6 +220,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "sysstdio.h"
#include <sys/types.h>
#include <sys/stat.h>
+#include <math.h>
#include "lisp.h"
#include "character.h"
@@ -819,6 +820,120 @@ load_pixmap (struct frame *f, Lisp_Object name)
Color Handling
***********************************************************************/
+/* Parse hex color component at S ending right before E.
+ Set *DST to the value normalized so that the maximum for the
+ number of digits given becomes 65535, and return true on success,
+ false otherwise. */
+static bool
+parse_hex_color_comp (const char *s, const char *e, unsigned short *dst)
+{
+ int n = e - s;
+ if (n <= 0 || n > 4)
+ return false;
+ int val = 0;
+ for (; s < e; s++)
+ {
+ int digit;
+ if (*s >= '0' && *s <= '9')
+ digit = *s - '0';
+ else if (*s >= 'A' && *s <= 'F')
+ digit = *s - 'A' + 10;
+ else if (*s >= 'a' && *s <= 'f')
+ digit = *s - 'a' + 10;
+ else
+ return false;
+ val = (val << 4) | digit;
+ }
+ int maxval = (1 << (n * 4)) - 1;
+ *dst = (unsigned)val * 65535 / maxval;
+ return true;
+}
+
+/* Parse floating-point color component at S ending right before E.
+ Return the number if in the range [0,1]; otherwise -1. */
+static double
+parse_float_color_comp (const char *s, const char *e)
+{
+ char *end;
+ double x = strtod (s, &end);
+ return (end == e && x >= 0 && x <= 1) ? x : -1;
+}
+
+/* Parse S as a numeric color specification and set *R, *G and *B.
+ Return true on success, false on failure.
+ Recognized formats:
+
+ "#RGB", with R, G and B hex strings of equal length, 1-4 digits each
+ "rgb:R/G/B", with R, G and B hex strings, 1-4 digits each
+ "rgbi:R/G/B", with R, G and B numbers in [0,1]
+
+ The result is normalized to a maximum value of 65535 per component. */
+bool
+parse_color_spec (const char *s,
+ unsigned short *r, unsigned short *g, unsigned short *b)
+{
+ int len = strlen (s);
+ if (s[0] == '#')
+ {
+ if ((len - 1) % 3 == 0)
+ {
+ int n = (len - 1) / 3;
+ return ( parse_hex_color_comp (s + 1 + 0 * n, s + 1 + 1 * n, r)
+ && parse_hex_color_comp (s + 1 + 1 * n, s + 1 + 2 * n, g)
+ && parse_hex_color_comp (s + 1 + 2 * n, s + 1 + 3 * n, b));
+ }
+ }
+ else if (strncmp (s, "rgb:", 4) == 0)
+ {
+ char *sep1, *sep2;
+ return ((sep1 = strchr (s + 4, '/')) != NULL
+ && (sep2 = strchr (sep1 + 1, '/')) != NULL
+ && parse_hex_color_comp (s + 4, sep1, r)
+ && parse_hex_color_comp (sep1 + 1, sep2, g)
+ && parse_hex_color_comp (sep2 + 1, s + len, b));
+ }
+ else if (strncmp (s, "rgbi:", 5) == 0)
+ {
+ char *sep1, *sep2;
+ double red, green, blue;
+ if ((sep1 = strchr (s + 5, '/')) != NULL
+ && (sep2 = strchr (sep1 + 1, '/')) != NULL
+ && (red = parse_float_color_comp (s + 5, sep1)) >= 0
+ && (green = parse_float_color_comp (sep1 + 1, sep2)) >= 0
+ && (blue = parse_float_color_comp (sep2 + 1, s + len)) >= 0)
+ {
+ *r = lrint (red * 65535);
+ *g = lrint (green * 65535);
+ *b = lrint (blue * 65535);
+ return true;
+ }
+ }
+ return false;
+}
+
+DEFUN ("internal-color-values-from-color-spec",
+ Finternal_color_values_from_color_spec,
+ Sinternal_color_values_from_color_spec,
+ 1, 1, 0,
+ doc: /* Parse STRING as a numeric color and return (RED GREEN BLUE).
+Recognised formats for STRING are:
+
+ #RGB, where R, G and B are hex numbers of equal length, 1-4 digits each
+ rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each
+ rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1]
+
+The result is normalized to a maximum value of 65535 per component,
+forming a list of three integers in [0,65535].
+If STRING is not in one of the above forms, return nil. */)
+ (Lisp_Object string)
+{
+ CHECK_STRING (string);
+ unsigned short r, g, b;
+ return (parse_color_spec (SSDATA (string), &r, &g, &b)
+ ? list3i (r, g, b)
+ : Qnil);
+}
+
/* Parse RGB_LIST, and fill in the RGB fields of COLOR.
RGB_LIST should contain (at least) 3 lisp integers.
Return true iff RGB_LIST is OK. */
@@ -7018,4 +7133,5 @@ clear the face cache, see `clear-face-cache'. */);
defsubr (&Sinternal_face_x_get_resource);
defsubr (&Sx_family_fonts);
#endif
+ defsubr (&Sinternal_color_values_from_color_spec);
}
diff --git a/src/xterm.c b/src/xterm.c
index 7989cec..6340700 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -2376,8 +2376,6 @@ x_query_frame_background_color (struct frame *f, XColor
*bgcolor)
x_query_colors (f, bgcolor, 1);
}
-#define HEX_COLOR_NAME_LENGTH 32
-
/* On frame F, translate the color name to RGB values. Use cached
information, if possible.
@@ -2389,44 +2387,23 @@ x_query_frame_background_color (struct frame *f, XColor
*bgcolor)
Status x_parse_color (struct frame *f, const char *color_name,
XColor *color)
{
+ /* Don't pass #RGB strings directly to XParseColor, because that
+ follows the X convention of zero-extending each channel
+ value: #f00 means #f00000. We want the convention of scaling
+ channel values, so #f00 means #ff0000, just as it does for
+ HTML, SVG, and CSS. */
+ unsigned short r, g, b;
+ if (parse_color_spec (color_name, &r, &g, &b))
+ {
+ color->red = r;
+ color->green = g;
+ color->blue = b;
+ return 1;
+ }
+
Display *dpy = FRAME_X_DISPLAY (f);
Colormap cmap = FRAME_X_COLORMAP (f);
struct color_name_cache_entry *cache_entry;
-
- if (color_name[0] == '#')
- {
- /* Don't pass #RGB strings directly to XParseColor, because that
- follows the X convention of zero-extending each channel
- value: #f00 means #f00000. We want the convention of scaling
- channel values, so #f00 means #ff0000, just as it does for
- HTML, SVG, and CSS.
-
- So we translate #f00 to rgb:f/0/0, which X handles
- differently. */
- char rgb_color_name[HEX_COLOR_NAME_LENGTH];
- int len = strlen (color_name);
- int digits_per_channel;
- if (len == 4)
- digits_per_channel = 1;
- else if (len == 7)
- digits_per_channel = 2;
- else if (len == 10)
- digits_per_channel = 3;
- else if (len == 13)
- digits_per_channel = 4;
- else
- return 0;
-
- snprintf (rgb_color_name, sizeof rgb_color_name, "rgb:%.*s/%.*s/%.*s",
- digits_per_channel, color_name + 1,
- digits_per_channel, color_name + digits_per_channel + 1,
- digits_per_channel, color_name + 2 * digits_per_channel + 1);
-
- /* The rgb form is parsed directly by XParseColor without
- talking to the X server. No need for caching. */
- return XParseColor (dpy, cmap, rgb_color_name, color);
- }
-
for (cache_entry = FRAME_DISPLAY_INFO (f)->color_names; cache_entry;
cache_entry = cache_entry->next)
{
diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el
index 574763c..eafa9c6 100644
--- a/test/lisp/autoinsert-tests.el
+++ b/test/lisp/autoinsert-tests.el
@@ -79,10 +79,10 @@
(ert-deftest autoinsert-tests-define-auto-insert-before ()
(let ((auto-insert-alist
- (list (cons 'text-mode '(lambda () (insert "foo")))))
+ (list (cons 'text-mode (lambda () (insert "foo")))))
(auto-insert-query nil))
(define-auto-insert 'text-mode
- '(lambda () (insert "bar")))
+ (lambda () (insert "bar")))
(with-temp-buffer
(text-mode)
(auto-insert)
@@ -90,10 +90,10 @@
(ert-deftest autoinsert-tests-define-auto-insert-after ()
(let ((auto-insert-alist
- (list (cons 'text-mode '(lambda () (insert "foo")))))
+ (list (cons 'text-mode (lambda () (insert "foo")))))
(auto-insert-query nil))
(define-auto-insert 'text-mode
- '(lambda () (insert "bar"))
+ (lambda () (insert "bar"))
t)
(with-temp-buffer
(text-mode)
diff --git a/test/lisp/battery-tests.el b/test/lisp/battery-tests.el
index 052ae49..8d7cc7f 100644
--- a/test/lisp/battery-tests.el
+++ b/test/lisp/battery-tests.el
@@ -22,9 +22,9 @@
(require 'battery)
(ert-deftest battery-linux-proc-apm-regexp ()
- "Test `battery-linux-proc-apm-regexp'."
+ "Test `rx' definition `battery--linux-proc-apm'."
(let ((str "1.16 1.2 0x07 0x01 0xff 0x80 -1% -1 ?"))
- (should (string-match battery-linux-proc-apm-regexp str))
+ (should (string-match (rx battery--linux-proc-apm) str))
(should (equal (match-string 0 str) str))
(should (equal (match-string 1 str) "1.16"))
(should (equal (match-string 2 str) "1.2"))
@@ -36,7 +36,7 @@
(should (equal (match-string 8 str) "-1"))
(should (equal (match-string 9 str) "?")))
(let ((str "1.16 1.2 0x03 0x00 0x00 0x01 99% 1792 min"))
- (should (string-match battery-linux-proc-apm-regexp str))
+ (should (string-match (rx battery--linux-proc-apm) str))
(should (equal (match-string 0 str) str))
(should (equal (match-string 1 str) "1.16"))
(should (equal (match-string 2 str) "1.2"))
@@ -48,11 +48,107 @@
(should (equal (match-string 8 str) "1792"))
(should (equal (match-string 9 str) "min"))))
+(ert-deftest battery-acpi-rate-regexp ()
+ "Test `rx' definition `battery--acpi-rate'."
+ (let ((str "01 mA"))
+ (should (string-match (rx (battery--acpi-rate)) str))
+ (should (equal (match-string 0 str) str))
+ (should (equal (match-string 1 str) "01"))
+ (should (equal (match-string 2 str) "mA")))
+ (let ((str "23 mW"))
+ (should (string-match (rx (battery--acpi-rate)) str))
+ (should (equal (match-string 0 str) str))
+ (should (equal (match-string 1 str) "23"))
+ (should (equal (match-string 2 str) "mW")))
+ (let ((str "23 mWh"))
+ (should (string-match (rx (battery--acpi-rate)) str))
+ (should (equal (match-string 0 str) "23 mW"))
+ (should (equal (match-string 1 str) "23"))
+ (should (equal (match-string 2 str) "mW")))
+ (should-not (string-match (rx (battery--acpi-rate) eos) "45 mWh")))
+
+(ert-deftest battery-acpi-capacity-regexp ()
+ "Test `rx' definition `battery--acpi-capacity'."
+ (let ((str "01 mAh"))
+ (should (string-match (rx battery--acpi-capacity) str))
+ (should (equal (match-string 0 str) str))
+ (should (equal (match-string 1 str) "01"))
+ (should (equal (match-string 2 str) "mAh")))
+ (let ((str "23 mWh"))
+ (should (string-match (rx battery--acpi-capacity) str))
+ (should (equal (match-string 0 str) str))
+ (should (equal (match-string 1 str) "23"))
+ (should (equal (match-string 2 str) "mWh")))
+ (should-not (string-match (rx battery--acpi-capacity eos) "45 mW")))
+
+(ert-deftest battery-upower-state ()
+ "Test `battery--upower-state'."
+ ;; Charging.
+ (dolist (total '(nil charging discharging empty fully-charged
+ pending-charge pending-discharge))
+ (should (eq (battery--upower-state '(("State" . 1)) total) 'charging)))
+ (dolist (state '(nil 0 1 2 3 4 5 6))
+ (should (eq (battery--upower-state `(("State" . ,state)) 'charging)
+ 'charging)))
+ ;; Discharging.
+ (dolist (total '(nil discharging empty fully-charged
+ pending-charge pending-discharge))
+ (should (eq (battery--upower-state '(("State" . 2)) total) 'discharging)))
+ (dolist (state '(nil 0 2 3 4 5 6))
+ (should (eq (battery--upower-state `(("State" . ,state)) 'discharging)
+ 'discharging)))
+ ;; Pending charge.
+ (dolist (total '(nil empty fully-charged pending-charge pending-discharge))
+ (should (eq (battery--upower-state '(("State" . 5)) total)
+ 'pending-charge)))
+ (dolist (state '(nil 0 3 4 5 6))
+ (should (eq (battery--upower-state `(("State" . ,state)) 'pending-charge)
+ 'pending-charge)))
+ ;; Pending discharge.
+ (dolist (total '(nil empty fully-charged pending-discharge))
+ (should (eq (battery--upower-state '(("State" . 6)) total)
+ 'pending-discharge)))
+ (dolist (state '(nil 0 3 4 6))
+ (should (eq (battery--upower-state `(("State" . ,state))
'pending-discharge)
+ 'pending-discharge)))
+ ;; Empty.
+ (dolist (total '(nil empty))
+ (should (eq (battery--upower-state '(("State" . 3)) total) 'empty)))
+ (dolist (state '(nil 0 3))
+ (should (eq (battery--upower-state `(("State" . ,state)) 'empty) 'empty)))
+ ;; Fully charged.
+ (dolist (total '(nil fully-charged))
+ (should (eq (battery--upower-state '(("State" . 4)) total)
'fully-charged)))
+ (dolist (state '(nil 0 4))
+ (should (eq (battery--upower-state `(("State" . ,state)) 'fully-charged)
+ 'fully-charged))))
+
+(ert-deftest battery-upower-state-unknown ()
+ "Test `battery--upower-state' with unknown states."
+ ;; Unknown running total retains new state.
+ (should-not (battery--upower-state () nil))
+ (should-not (battery--upower-state '(("State" . state)) nil))
+ (should-not (battery--upower-state '(("State" . 0)) nil))
+ (should (eq (battery--upower-state '(("State" . 1)) nil) 'charging))
+ (should (eq (battery--upower-state '(("State" . 2)) nil) 'discharging))
+ (should (eq (battery--upower-state '(("State" . 3)) nil) 'empty))
+ (should (eq (battery--upower-state '(("State" . 4)) nil) 'fully-charged))
+ (should (eq (battery--upower-state '(("State" . 5)) nil) 'pending-charge))
+ (should (eq (battery--upower-state '(("State" . 6)) nil) 'pending-discharge))
+ ;; Unknown new state retains running total.
+ (dolist (props '(() (("State" . state)) (("State" . 0))))
+ (dolist (total '(nil charging discharging empty fully-charged
+ pending-charge pending-discharge))
+ (should (eq (battery--upower-state props total) total))))
+ ;; Conflicting empty and fully-charged.
+ (should-not (battery--upower-state '(("State" . 3)) 'fully-charged))
+ (should-not (battery--upower-state '(("State" . 4)) 'empty)))
+
(ert-deftest battery-format ()
"Test `battery-format'."
(should (equal (battery-format "" ()) ""))
(should (equal (battery-format "" '((?b . "-"))) ""))
- (should (equal (battery-format "%a%b%p%%" '((?b . "-") (?p . "99")))
- "-99%")))
+ (should (equal (battery-format "%2a%-3b%.1p%%" '((?b . "-") (?p . "99")))
+ "- 9%")))
;;; battery-tests.el ends here
diff --git a/test/lisp/calendar/lunar-tests.el
b/test/lisp/calendar/lunar-tests.el
index 8d8a988..d2647aa 100644
--- a/test/lisp/calendar/lunar-tests.el
+++ b/test/lisp/calendar/lunar-tests.el
@@ -42,7 +42,12 @@
(with-lunar-test
(should (equal (eclipse-check 1 1) "** Eclipse **"))))
+;; This fails in certain time zones.
+;; Eg TZ=America/Phoenix make lisp/calendar/lunar-tests
+;; Similarly with TZ=UTC.
+;; Daylight saving related?
(ert-deftest lunar-test-phase-list ()
+ :tags '(:unstable)
(with-lunar-test
(should (equal (lunar-phase-list 3 1871)
'(((3 20 1871) "11:03pm" 0 "")
diff --git a/test/lisp/emacs-lisp/generator-tests.el
b/test/lisp/emacs-lisp/generator-tests.el
index bcfab20..9b1a573 100644
--- a/test/lisp/emacs-lisp/generator-tests.el
+++ b/test/lisp/emacs-lisp/generator-tests.el
@@ -304,4 +304,13 @@ identical output."
(1+ it)))))))
-2)))
+(ert-deftest generator-tests-edebug ()
+ "Check that Bug#40434 is fixed."
+ (with-temp-buffer
+ (prin1 '(iter-defun generator-tests-edebug ()
+ (iter-yield 123))
+ (current-buffer))
+ (edebug-defun))
+ (should (eql (iter-next (generator-tests-edebug)) 123)))
+
;;; generator-tests.el ends here
diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el
index 7fa4cd5..7a8402b 100644
--- a/test/lisp/emacs-lisp/gv-tests.el
+++ b/test/lisp/emacs-lisp/gv-tests.el
@@ -19,6 +19,7 @@
;;; Code:
+(require 'edebug)
(require 'ert)
(eval-when-compile (require 'cl-lib))
@@ -137,6 +138,24 @@
(should (equal (buffer-string)
"Symbol's function definition is void: \\(setf\\
gv-test-foo\\)\n")))))
+(ert-deftest gv-setter-edebug ()
+ "Check that a setter can be defined and edebugged together with
+its getter (Bug#41853)."
+ (with-temp-buffer
+ (let ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop))
+ (dolist (form '((defun gv-setter-edebug-help (b) b)
+ (defun gv-setter-edebug-get (a b)
+ (get a (gv-setter-edebug-help b)))
+ (gv-define-setter gv-setter-edebug-get (x a b)
+ `(setf (get ,a (gv-setter-edebug-help ,b)) ,x))
+ (push 123 (gv-setter-edebug-get 'gv-setter-edebug
+
'gv-setter-edebug-prop))))
+ (print form (current-buffer)))
+ ;; Only check whether evaluation works in general.
+ (eval-buffer)))
+ (should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123))))
+
;; `ert-deftest' messes up macroexpansion when the test file itself is
;; compiled (see Bug #24402).
diff --git a/test/lisp/emacs-lisp/package-tests.el
b/test/lisp/emacs-lisp/package-tests.el
index 90714af..cb06dd4 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -175,9 +175,8 @@
(defun package-test-suffix-matches (base suffix-list)
"Return file names matching BASE concatenated with each item in SUFFIX-LIST"
- (cl-mapcan
- '(lambda (item) (file-expand-wildcards (concat base item)))
- suffix-list))
+ (mapcan (lambda (item) (file-expand-wildcards (concat base item)))
+ suffix-list))
(defvar tar-parse-info)
(declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct
@@ -419,17 +418,17 @@ Must called from within a `tar-mode' buffer."
(ert-deftest package-test-list-filter-marked ()
"Ensure package list is filtered correctly by non-empty mark."
(with-package-test ()
- (let ((buf (package-list-packages)))
- (revert-buffer)
- (search-forward-regexp "^ +simple-single")
- (package-menu-mark-install)
- (package-menu-filter-marked)
- (goto-char (point-min))
- (should (re-search-forward "^I +simple-single" nil t))
- (should (= (count-lines (point-min) (point-max)) 1))
- (package-menu-mark-unmark)
- ;; No marked packages in default environment.
- (should-error (package-menu-filter-marked)))))
+ (package-list-packages)
+ (revert-buffer)
+ (search-forward-regexp "^ +simple-single")
+ (package-menu-mark-install)
+ (package-menu-filter-marked)
+ (goto-char (point-min))
+ (should (re-search-forward "^I +simple-single" nil t))
+ (should (= (count-lines (point-min) (point-max)) 1))
+ (package-menu-mark-unmark)
+ ;; No marked packages in default environment.
+ (should-error (package-menu-filter-marked))))
(ert-deftest package-test-list-filter-by-version ()
(with-package-menu-test
diff --git a/test/lisp/format-spec-tests.el b/test/lisp/format-spec-tests.el
index 23ee88c..1188221 100644
--- a/test/lisp/format-spec-tests.el
+++ b/test/lisp/format-spec-tests.el
@@ -22,22 +22,145 @@
(require 'ert)
(require 'format-spec)
-(ert-deftest test-format-spec ()
+(ert-deftest format-spec-make ()
+ "Test `format-spec-make'."
+ (should-not (format-spec-make))
+ (should-error (format-spec-make ?b))
+ (should (equal (format-spec-make ?b "b") '((?b . "b"))))
+ (should-error (format-spec-make ?b "b" ?a))
+ (should (equal (format-spec-make ?b "b" ?a 'a)
+ '((?b . "b")
+ (?a . a)))))
+
+(ert-deftest format-spec-parse-flags ()
+ "Test `format-spec--parse-flags'."
+ (should-not (format-spec--parse-flags nil))
+ (should-not (format-spec--parse-flags ""))
+ (should (equal (format-spec--parse-flags "-") '(:pad-right)))
+ (should (equal (format-spec--parse-flags " 0") '(:pad-zero)))
+ (should (equal (format-spec--parse-flags " -x0y< >^_z ")
+ '(:pad-right :pad-zero :chop-left :chop-right
+ :upcase :downcase))))
+
+(ert-deftest format-spec-do-flags ()
+ "Test `format-spec--do-flags'."
+ (should (equal (format-spec--do-flags "" () nil nil) ""))
+ (dolist (flag '(:pad-zero :pad-right :upcase :downcase
+ :chop-left :chop-right))
+ (should (equal (format-spec--do-flags "" (list flag) nil nil) "")))
+ (should (equal (format-spec--do-flags "FOOBAR" '(:downcase :chop-right) 5 2)
+ " fo"))
+ (should (equal (format-spec--do-flags
+ "foobar" '(:pad-zero :pad-right :upcase :chop-left) 5 2)
+ "AR000")))
+
+(ert-deftest format-spec-do-flags-truncate ()
+ "Test `format-spec--do-flags' truncation."
+ (let (flags)
+ (should (equal (format-spec--do-flags "" flags nil 0) ""))
+ (should (equal (format-spec--do-flags "" flags nil 1) ""))
+ (should (equal (format-spec--do-flags "a" flags nil 0) ""))
+ (should (equal (format-spec--do-flags "a" flags nil 1) "a"))
+ (should (equal (format-spec--do-flags "a" flags nil 2) "a"))
+ (should (equal (format-spec--do-flags "asd" flags nil 0) ""))
+ (should (equal (format-spec--do-flags "asd" flags nil 1) "a")))
+ (let ((flags '(:chop-left)))
+ (should (equal (format-spec--do-flags "" flags nil 0) ""))
+ (should (equal (format-spec--do-flags "" flags nil 1) ""))
+ (should (equal (format-spec--do-flags "a" flags nil 0) ""))
+ (should (equal (format-spec--do-flags "a" flags nil 1) "a"))
+ (should (equal (format-spec--do-flags "a" flags nil 2) "a"))
+ (should (equal (format-spec--do-flags "asd" flags nil 0) ""))
+ (should (equal (format-spec--do-flags "asd" flags nil 1) "d"))))
+
+(ert-deftest format-spec-do-flags-pad ()
+ "Test `format-spec--do-flags' padding."
+ (let (flags)
+ (should (equal (format-spec--do-flags "" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "" flags 1 nil) " "))
+ (should (equal (format-spec--do-flags "a" flags 0 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 1 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 2 nil) " a")))
+ (let ((flags '(:pad-zero)))
+ (should (equal (format-spec--do-flags "" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "" flags 1 nil) "0"))
+ (should (equal (format-spec--do-flags "a" flags 0 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 1 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 2 nil) "0a")))
+ (let ((flags '(:pad-right)))
+ (should (equal (format-spec--do-flags "" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "" flags 1 nil) " "))
+ (should (equal (format-spec--do-flags "a" flags 0 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 1 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 2 nil) "a ")))
+ (let ((flags '(:pad-right :pad-zero)))
+ (should (equal (format-spec--do-flags "" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "" flags 1 nil) "0"))
+ (should (equal (format-spec--do-flags "a" flags 0 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 1 nil) "a"))
+ (should (equal (format-spec--do-flags "a" flags 2 nil) "a0"))))
+
+(ert-deftest format-spec-do-flags-chop ()
+ "Test `format-spec--do-flags' chopping."
+ (let ((flags '(:chop-left)))
+ (should (equal (format-spec--do-flags "a" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "a" flags 1 nil) "a"))
+ (should (equal (format-spec--do-flags "asd" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "asd" flags 1 nil) "d")))
+ (let ((flags '(:chop-right)))
+ (should (equal (format-spec--do-flags "a" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "a" flags 1 nil) "a"))
+ (should (equal (format-spec--do-flags "asd" flags 0 nil) ""))
+ (should (equal (format-spec--do-flags "asd" flags 1 nil) "a"))))
+
+(ert-deftest format-spec-do-flags-case ()
+ "Test `format-spec--do-flags' case fiddling."
+ (dolist (flag '(:pad-zero :pad-right :chop-left :chop-right))
+ (let ((flags (list flag)))
+ (should (equal (format-spec--do-flags "a" flags nil nil) "a"))
+ (should (equal (format-spec--do-flags "A" flags nil nil) "A")))
+ (let ((flags (list flag :downcase)))
+ (should (equal (format-spec--do-flags "a" flags nil nil) "a"))
+ (should (equal (format-spec--do-flags "A" flags nil nil) "a")))
+ (let ((flags (list flag :upcase)))
+ (should (equal (format-spec--do-flags "a" flags nil nil) "A"))
+ (should (equal (format-spec--do-flags "A" flags nil nil) "A")))))
+
+(ert-deftest format-spec ()
+ (should (equal (format-spec "" ()) ""))
+ (should (equal (format-spec "a" ()) "a"))
+ (should (equal (format-spec "b" '((?b . "bar"))) "b"))
+ (should (equal (format-spec "%%%b%%b%b%%" '((?b . "bar"))) "%bar%bbar%"))
(should (equal (format-spec "foo %b zot" `((?b . "bar")))
"foo bar zot"))
(should (equal (format-spec "foo %-10b zot" '((?b . "bar")))
"foo bar zot"))
(should (equal (format-spec "foo %10b zot" '((?b . "bar")))
- "foo bar zot")))
+ "foo bar zot"))
+ (should (equal-including-properties
+ (format-spec (propertize "a" 'a 'b) '((?a . "foo")))
+ #("a" 0 1 (a b))))
+ (let ((fmt (concat (propertize "%a" 'a 'b)
+ (propertize "%%" 'c 'd)
+ "%b"
+ (propertize "%b" 'e 'f))))
+ (should (equal-including-properties
+ (format-spec fmt '((?b . "asd") (?a . "fgh")))
+ #("fgh%asdasd" 0 3 (a b) 3 4 (c d) 7 10 (e f))))))
-(ert-deftest test-format-unknown ()
+(ert-deftest format-spec-unknown ()
(should-error (format-spec "foo %b %z zot" '((?b . "bar"))))
+ (should-error (format-spec "foo %b %%%z zot" '((?b . "bar"))))
(should (equal (format-spec "foo %b %z zot" '((?b . "bar")) t)
"foo bar %z zot"))
- (should (equal (format-spec "foo %b %z %% zot" '((?b . "bar")) t)
- "foo bar %z %% zot")))
+ (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) t)
+ "foo bar %%%4z %%4 zot"))
+ (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'ignore)
+ "foo bar %%4z %4 zot"))
+ (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'delete)
+ "foo bar % %4 zot")))
-(ert-deftest test-format-modifiers ()
+(ert-deftest format-spec-flags ()
(should (equal (format-spec "foo %10b zot" '((?b . "bar")))
"foo bar zot"))
(should (equal (format-spec "foo % 10b zot" '((?b . "bar")))
diff --git a/test/lisp/imenu-tests.el b/test/lisp/imenu-tests.el
index 5dbeb88..e5cdb9e 100644
--- a/test/lisp/imenu-tests.el
+++ b/test/lisp/imenu-tests.el
@@ -50,24 +50,23 @@
(setq input (cdr input)))))
result))
-(defmacro imenu-simple-scan-deftest (name doc major-mode content
expected-items)
+(defmacro imenu-simple-scan-deftest (name doc mode content expected-items)
"Generate an ert test for mode-own imenu expression.
Run `imenu-create-index-function' at the buffer which content is
-CONTENT with MAJOR-MODE. A generated test runs `imenu-create-index-function'
-at the buffer which content is CONTENT with MAJOR-MODE. Then it compares a list
-of strings which are picked up from the result with EXPECTED-ITEMS."
+CONTENT with major MODE. A generated test runs `imenu-create-index-function'
+at the buffer which content is CONTENT with major MODE. Then it compares a
+list of strings which are picked up from the result with EXPECTED-ITEMS."
(let ((xname (intern (concat "imenu-simple-scan-deftest-" (symbol-name
name)))))
`(ert-deftest ,xname ()
- ,doc
+ ,doc
(with-temp-buffer
(insert ,content)
- (funcall ',major-mode)
+ (funcall #',mode)
(let ((result-items (sort
(imenu-simple-scan-deftest-gather-strings-from-list
(funcall imenu-create-index-function))
#'string-lessp))
(expected-items (sort (copy-sequence ,expected-items)
#'string-lessp)))
- (should (equal result-items expected-items))
- )))))
+ (should (equal result-items expected-items)))))))
(imenu-simple-scan-deftest sh "Test imenu expression for sh-mode." sh-mode "a()
{
diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el
index e263c45..45c9851 100644
--- a/test/lisp/net/dbus-tests.el
+++ b/test/lisp/net/dbus-tests.el
@@ -176,8 +176,8 @@ This includes initialization and closing the bus."
(defun dbus-test-all (&optional interactive)
"Run all tests for \\[dbus]."
(interactive "p")
- (funcall
- (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus"))
+ (funcall (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch)
+ "^dbus"))
(provide 'dbus-tests)
;;; dbus-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 578da41..43630c4 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2925,6 +2925,9 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
;; (this is performed by `dired'). If FULL is nil, it shows just
;; one file. So we refrain from testing.
(skip-unless (not (tramp--test-ange-ftp-p)))
+ ;; `insert-directory' of crypted remote directories works only since
+ ;; Emacs 27.1.
+ (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p)))
(dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
(let* ((tmp-name1
@@ -2995,6 +2998,8 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-rsync-p)))
+ ;; Wildcards are not supported in tramp-crypt.el.
+ (skip-unless (not (tramp--test-crypt-p)))
;; Since Emacs 26.1.
(skip-unless (fboundp 'insert-directory-wildcard-in-dir-p))
@@ -6037,6 +6042,7 @@ Use the `ls' command."
(skip-unless (not (tramp--test-windows-nt-and-batch)))
(skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(skip-unless (not (tramp--test-ksh-p)))
+ (skip-unless (not (tramp--test-crypt-p)))
(tramp--test-utf8))
@@ -6051,6 +6057,7 @@ Use the `stat' command."
(skip-unless (not (tramp--test-windows-nt-and-batch)))
(skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(skip-unless (not (tramp--test-ksh-p)))
+ (skip-unless (not (tramp--test-crypt-p)))
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-stat v)))
@@ -6072,6 +6079,7 @@ Use the `perl' command."
(skip-unless (not (tramp--test-windows-nt-and-batch)))
(skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(skip-unless (not (tramp--test-ksh-p)))
+ (skip-unless (not (tramp--test-crypt-p)))
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-perl v)))
@@ -6096,6 +6104,7 @@ Use the `ls' command."
(skip-unless (not (tramp--test-windows-nt-and-batch)))
(skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(skip-unless (not (tramp--test-ksh-p)))
+ (skip-unless (not (tramp--test-crypt-p)))
(let ((tramp-connection-properties
(append
diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el
index 65ed76b..91805ab 100644
--- a/test/lisp/progmodes/sql-tests.el
+++ b/test/lisp/progmodes/sql-tests.el
@@ -187,7 +187,13 @@ Perform ACTION and validate results"
(sql-add-product 'xyz "XyzDb")
(should (equal (pp-to-string (assoc 'xyz sql-product-alist))
- "(xyz :name \"XyzDb\")\n"))))
+ "(xyz :name \"XyzDb\")\n")))
+
+ (sql-test-product-feature-harness
+ (sql-add-product 'stu "StuDb" :X 1 :Y "2")
+
+ (should (equal (pp-to-string (assoc 'stu sql-product-alist))
+ "(stu :name \"StuDb\" :X 1 :Y \"2\")\n"))))
(ert-deftest sql-test-add-existing-product ()
"Add a product that already exists."
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index ff85e2f..8e5cc95 100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@ -224,11 +224,10 @@ For backends which don't support it, `vc-not-supported'
is signaled."
(defmacro vc-test--run-maybe-unsupported-function (func &rest args)
"Run FUNC with ARGS as arguments.
Catch the `vc-not-supported' error."
- `(let (err)
- (condition-case err
- (funcall ,func ,@args)
- (vc-not-supported 'vc-not-supported)
- (t (signal (car err) (cdr err))))))
+ `(condition-case err
+ (funcall ,func ,@args)
+ (vc-not-supported 'vc-not-supported)
+ (t (signal (car err) (cdr err)))))
(defun vc-test--register (backend)
"Register and unregister a file.
diff --git a/test/manual/etags/tex-src/gzip.texi
b/test/manual/etags/tex-src/gzip.texi
index ea5f7f5..72c5c7e 100644
--- a/test/manual/etags/tex-src/gzip.texi
+++ b/test/manual/etags/tex-src/gzip.texi
@@ -148,7 +148,7 @@ input and writes the uncompressed data on standard output.
@code{zcat}
will uncompress files that have the correct magic number whether they
have a @samp{.gz} suffix or not.
-@code{gzip} uses the Lempel-Ziv algorithm used in @code{zip} and PKZIP.
+@code{gzip} uses the Lempel-Ziv algorithm used in @code{zip} and PKZIP@.
The amount of compression obtained depends on the size of the input and
the distribution of common substrings. Typically, text such as source
code or English is reduced by 60-70%. Compression is generally much
diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el
index 13335a9..b26a276 100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@ -452,7 +452,7 @@ Demonstrates bug 25599."
(insert ";; aaaaaaaaa
;; bbbbbbbb")
(let ((overlay-modified
- (lambda (ov after-p _beg _end &optional length)
+ (lambda (ov after-p _beg _end &optional _length)
(unless after-p
(when (overlay-buffer ov)
(delete-overlay ov))))))
diff --git a/test/src/xfaces-tests.el b/test/src/xfaces-tests.el
index 5ed16c9..34cda07 100644
--- a/test/src/xfaces-tests.el
+++ b/test/src/xfaces-tests.el
@@ -24,4 +24,27 @@
(should (equal (color-distance "#222222" "#ffffff")
(color-distance "#ffffff" "#222222"))))
+(ert-deftest xfaces-internal-color-values-from-color-spec ()
+ (should (equal (internal-color-values-from-color-spec "#f05")
+ '(#xffff #x0000 #x5555)))
+ (should (equal (internal-color-values-from-color-spec "#1fb0C5")
+ '(#x1f1f #xb0b0 #xc5c5)))
+ (should (equal (internal-color-values-from-color-spec "#1f8b0AC5e")
+ '(#x1f81 #xb0aa #xc5eb)))
+ (should (equal (internal-color-values-from-color-spec "#1f83b0ADC5e2")
+ '(#x1f83 #xb0ad #xc5e2)))
+ (should (equal (internal-color-values-from-color-spec "#1f83b0ADC5e2g") nil))
+ (should (equal (internal-color-values-from-color-spec "#1f83b0ADC5e20") nil))
+ (should (equal (internal-color-values-from-color-spec "#12345") nil))
+ (should (equal (internal-color-values-from-color-spec "rgb:f/23/28a")
+ '(#xffff #x2323 #x28a2)))
+ (should (equal (internal-color-values-from-color-spec "rgb:1234/5678/09ab")
+ '(#x1234 #x5678 #x09ab)))
+ (should (equal (internal-color-values-from-color-spec "rgb:0//0") nil))
+ (should (equal (internal-color-values-from-color-spec "rgbi:0/0.5/0.1")
+ '(0 32768 6554)))
+ (should (equal (internal-color-values-from-color-spec "rgbi:1e-3/1.0e-2/1e0")
+ '(66 655 65535)))
+ (should (equal (internal-color-values-from-color-spec "rgbi:0/0.5/10") nil)))
+
(provide 'xfaces-tests)
- feature/native-comp c37b544 01/12: Add native compiler dynamic scope support, (continued)
- feature/native-comp c37b544 01/12: Add native compiler dynamic scope support, Andrea Corallo, 2020/06/21
- feature/native-comp 47ab6c2 02/12: Add some testing for dynamic scope, Andrea Corallo, 2020/06/21
- feature/native-comp 29b2a08 03/12: Execute top level forms in the right lex/dyn scope., Andrea Corallo, 2020/06/21
- feature/native-comp decced8 04/12: Allow per function speed declaration, Andrea Corallo, 2020/06/21
- feature/native-comp 34117de 05/12: Add a test for speed -1, Andrea Corallo, 2020/06/21
- feature/native-comp 51df0ab 06/12: Do not native compile two functions to allow cc-mode hack, Andrea Corallo, 2020/06/21
- feature/native-comp 1179a1c 07/12: * Add a func-arity test for dynamic functions, Andrea Corallo, 2020/06/21
- feature/native-comp 89b6f56 09/12: * src/comp.c (Fcomp__compile_ctxt_to_file): Confine gcc optim level in [0, 3]., Andrea Corallo, 2020/06/21
- feature/native-comp cfb871a 08/12: * Handle correctly pure delaration specifier., Andrea Corallo, 2020/06/21
- feature/native-comp 0a70ed9 10/12: ; * src/comp.c (define_maybe_gc_or_quit): Fix a comment., Andrea Corallo, 2020/06/21
- feature/native-comp c324e02 12/12: Merge remote-tracking branch 'savahnna/master' into dev,
Andrea Corallo <=
- feature/native-comp f0e9fdd 11/12: Two `load-history' eln related fixes., Andrea Corallo, 2020/06/21